------------------------------------------------------------------------------ -- BUSH Parser Aux (Parser Support) -- -- -- -- Part of BUSH -- ------------------------------------------------------------------------------ -- -- -- Copyright (C) 2001-2005 Ken O. Burtch & FSF -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. This is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with this; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- This is maintained at http://www.pegasoft.ca -- -- -- ------------------------------------------------------------------------------ with ada.text_io, Interfaces.C, string_util, script_io, parser; use ada.text_io, Interfaces.C, string_util, script_io, parser; package body parser_aux is use bush_os.HEptrs; function isExecutingCommand return boolean is -- True if OK to execute a statement that does work. -- That is, the parser isn't skipping the line because of -- an error or exiting a block. begin return not error_found and not exit_block and not syntax_check; end isExecutingCommand; --pragma inline( isExecutingCommand ); procedure discardUnusedIdentifier( id : identifier ) is -- if an identifier has been not been assigned a type, -- assume it's unused and discard it. b : boolean; begin if id /= eof_t then if identifiers( id ).kind = new_t or identifiers( id ).kind = eof_t then b := deleteIdent( id ); end if; end if; end discardUnusedIdentifier; procedure makeTempFile( s : out unbounded_string ) is -- create a unique temporary filename LinuxPath : string := "/tmp/bushXXXXXX" & ASCII.NUL; result : aFileDescriptor; begin s := null_unbounded_string; mkstemp( result, LinuxPath ); if result < 0 then err( "makeTempFile: mkstemp failed" & OSError( C_errno ) ); s := null_unbounded_string; else close( result ); -- not the most secure for i in aLinuxPath'range loop exit when LinuxPath( i ) = ASCII.NUL; s := s & LinuxPath( i ); end loop; end if; end makeTempFile; --function isEOF( fd : aFileDescriptor ) return boolean is -- true if the file descriptor is at the end of file -- ch : character; -- result : long_integer; -- seekResult : long_integer; --begin -- read( result, fd, ch, 1 ); -- read a single character -- if result > 0 then -- read something? -- seekResult := lseek( fd, -1, WHENCE_SEEK_CUR); -- move back one character -- end if; -- return result < 1; -- return if read reported EOF --end isEOF; procedure AssignParameter( ref : in reference; value : unbounded_string ) is -- assign value to an out or in out parameter begin if ref.index = 0 then identifiers( ref.id ).value := value; else assignElement( ref.a_id, ref.index, value ); end if; end AssignParameter; pragma inline( AssignParameter ); procedure GetParameterValue( ref : in reference; value : out unbounded_string ) is begin if ref.index = 0 then value := identifiers( ref.id ).value; else value := arrayElement( ref.a_id, ref.index ); end if; end GetParameterValue; pragma inline( GetParameterValue ); function stringField( i : identifier; f : natural ) return unbounded_string is -- same as string_util.stringField except uses an identifier's value begin return stringField( identifiers( i ).value, recSep, f ); end stringField; procedure replaceField( i : identifier; f : natural; field : string ) is -- same as string_util.replaceField except users an identifier's value begin replaceField( identifiers( i ).value, recSep, f, field ); end replaceField; function stringField( r : reference; f : natural ) return unbounded_string is -- same as string_util.stringField except uses a reference tempStr : unbounded_string; begin getParameterValue( r, tempStr ); return stringField( tempStr, recSep, f ); end stringField; procedure replaceField( r : reference; f : natural; field : string ) is -- same as string_util.replaceField except users an identifier's value tempStr : unbounded_string; begin getParameterValue( r, tempStr ); replaceField( tempStr, recSep, f, field ); assignParameter( r, tempStr ); end replaceField; function OSerror( e : integer ) return string is -- return an OS error message for error number e lastchar : natural := 0; ep : anErrorPtr; begin ep := strerror( e ); for i in ep.all'range loop if ep(i) = ASCII.NUL then lastchar := i-1; exit; end if; end loop; return string( ep( 1..lastchar ) ); end OSerror; function openSocket( serverName : unbounded_string; port : integer ) return aSocketFD is -- procedure SendHTTPCommand( soc : aSocketFD; cmd : string ) is -- Write a HTTP command string to the socket -- amountWritten : integer := 0; -- totalWritten : integer := 0; -- position : integer := cmd'first; -- begin --loop --Write( amountWritten, soc, cmd( position )'address, -- cmd'length - integer( totalWritten ) ); -- if amountWritten < 0 then --Put_Line( Standard_Error, "Write to socket failed" ); -- return; -- end if; -- Put_Line( "Sent" & amountWritten'img & " bytes" ); -- totalWritten := totalWritten + amountWritten; -- position := position + amountWritten; -- exit when totalWritten = cmd'length; -- end loop; -- end SendHTTPCommand; -- ServerName: string := "hyde"; mySocket : aSocketFD; -- the socket myAddress : aSocketAddr; -- where it goes myServer : aHEptr; -- IP number of server myServerPtr : HEptrs.Object_Pointer; addrList : addrListPtrs.Object_Pointer; Result : int; begin -- initialize a new TCP/IP socket -- 0 for the third param lets the kernel decide --Put_Line( "Initializing a TCP/IP socket" ); --Put_Line( "Socket( " & PF_INET'img & ',' & SOCK_STREAM'img & ", 0 );" ); mySocket := Socket( PF_INET, SOCK_STREAM, 0 ); if mySocket = -1 then err( "error making socket: " & OSError( C_errno ) ); return -1; end if; --New_Line; -- Lookup the IP number for the server --Put_Line( "Looking for information on " & to_string( serverName ) ); myServer := GetHostByName( to_string( serverName ) & ASCII.NUL ); myServerPtr := HEptrs.To_Pointer( myServer ); if myServerPtr = null then if C_errno = 0 then err( "there is no server by this name" ); else err( "error looking up host: " & OSError( C_errno ) ); end if; return -1; end if; --Put_Line( "IP number is" & myServerPtr.h_length'img & " bytes long" ); addrList := addrlistPtrs.To_Pointer( myServerPtr.h_addr_list ); --New_Line; -- Create the IP, port and protocol information --Put_Line( "Preparing connection destination information" ); myAddress.family := AF_INET; myAddress.port := htons( Interfaces.C.Unsigned_Short( port ) ); memcpy( myAddress.ip'address, addrlist.all, myServerPtr.h_length ); --New_Line; -- Open a connection to the server --Put_Line( "Connect( Result, Socket, Family/Address rec, F/A rec size )" ); Connect( Result, mySocket, myAddress, myAddress'size/8 ); --Put( "Connect( " & Result'img & "," ); --Put( myAddress.family'img & "/" ); --PutIPNum( myAddress.ip ); --Put( "," & integer'image( myAddress'size / 8 ) & ")" ); if Result /= 0 then err( "error connecting to server: " & OSerror( C_errno ) ); return -1; end if; --New_Line; return mySocket; end openSocket; -- Parsing short-cuts --procedure ParseSingleUniStringExpression( expr_val : out unbounded_string; --expr_type : out identifier ) is --begin --expect( symbol_t, "(" ); --ParseExpression( expr_val, expr_type ); --if uniTypesOk( expr_type, string_t ) then --expect( symbol_t, ")" ); --end if; --end ParseSingleUniStringExpression; -- --procedure ParseSingleStringExpression( expr_val : out unbounded_string; --expr_type : out identifier ) is --begin --expect( symbol_t, "(" ); --ParseExpression( expr_val, expr_type ); --if baseTypesOk( expr_type, string_t ) then --expect( symbol_t, ")" ); --end if; --end ParseSingleStringExpression; -- --procedure ParseSingleNumericExpression( expr_val : out unbounded_string; --expr_type : out identifier ) is --begin --expect( symbol_t, "(" ); --ParseExpression( expr_val, expr_type ); --if uniTypesOk( expr_type, uni_numeric_t ) then --expect( symbol_t, ")" ); --end if; --end ParseSingleNumericExpression; ------------------------------------------------------------------------------ -- PROCESS TEMPLATE -- -- Read a template and process embedded scripts. This procedure is expected -- to be invoked after the main script has run. -- Exceptions: Caller should handle STATUS_ERROR, NAME_ERROR, MODE_ERROR, etc. ------------------------------------------------------------------------------ procedure processTemplate is f : file_type; ch : character; type aMode is ( noMode, -- shouldn't be used gatheringStartTag, -- looking for a start tag gatheringScript, -- gathering script gatheringEndTag, -- looking for end tag outputTemplate -- writing out template ); mode : aMode := outputTemplate; -- what are we doing now bushStartTag : string := ""; -- the end tag tag : unbounded_string; -- possible tag text tagCount : natural := 0; -- characters in p. tag uncompressedScript : unbounded_string; -- script being gathered -- lineno : natural := 1; startingLineNo : natural := 1; -- save_lineno : aLineNumber; -- swap space for line no lastLine : Positive_Count := 1; begin gccOpt := true; -- force gcc errors since these will go into -- web servers (text) log so hilighting will be annoying if not unrestrictedTemplate then rshOpt := true; restriction_no_external_commands := true; end if; scriptFilePath := templatePath; open( f, in_file, to_string( templatePath ) ); -- open the template while not end_of_file( f ) loop -- while text to do get( f, ch ); -- get next character ---------------------------------------------------------------------- -- Text_IO Automatically skips lines. This should be rewritten. ---------------------------------------------------------------------- if line( f ) - lastLine > 1 then for i in 1..line( f ) - lastLine -1 loop uncompressedScript := uncompressedScript & ASCII.LF; end loop; end if; lastLine := line( f ); ---------------------------------------------------------------------- -- Depending on the mode, interpret the template character ---------------------------------------------------------------------- case mode is -- are we searching for ---------------------------------------------------------------------- -- Examining a possible script start tag? ---------------------------------------------------------------------- when gatheringStartTag => -- possible -- collecting text --put_line( "read '" & ch & "', tag = '" & to_string( tag ) & "', tagCount = " & tagCount'img ); if ch = bushEndTag(1) then -- possible end tag? tag := null_unbounded_string & ch; -- record char tagCount := 1; -- first in tag mode := gatheringEndTag; -- looking for tag else uncompressedScript := uncompressedScript & ch; -- add character if end_of_line( f ) then -- EOL? -- lineno := lineno + 1; -- template line uncompressedScript := uncompressedScript & ASCII.LF; end if; end if; ---------------------------------------------------------------------- -- Examining a possible end tag? ---------------------------------------------------------------------- when gatheringEndTag => -- possible ?> ? --put_line( "get: read '" & ch & "', tag = '" & to_string( tag ) & "', tagCount = " & tagCount'img ); tag := tag & ch; -- record in case not tagCount := tagCount + 1; -- count characters if tagCount < bushEndTag'length then -- subset of tag? if ch /= bushEndTag(tagCount) then -- match failed? mode := gatheringScript; -- continue w/script tagCount := 0; -- forget it uncompressedScript := uncompressedScript & tag; -- text is script end if; elsif ch = bushEndTag( tagCount ) then -- but if last matches mode := outputTemplate; -- done, run scripts tagCount := 0; -- forget tag else mode := gatheringScript; -- continue w/script tagCount := 0; -- forget it uncompressedScript := uncompressedScript & tag; -- text is script end if; if end_of_line( f ) then -- EOL? -- lineno := lineno + 1; -- template line uncompressedScript := uncompressedScript & ASCII.LF; end if; ---------------------------------------------------------------------- -- We have a script. Run it. ---------------------------------------------------------------------- if mode = outputTemplate then -- interpretCommand( uncompressedScript ); -- there should be a proc for this compileTemplate( uncompressedScript, startingLineNo ); inputMode := fromScriptFile; -- running a script error_found := false; -- no error found exit_block := false; -- not exit-ing a block cmdpos := firstScriptCommandOffset; -- start at first char token := identifiers'first; -- dummy, replaced by g_n_t -- don't reset line number (for error msgs) lineno := 1; getNextToken; -- load first token -- save_lineno := lineno; -- save line loop -- run commands ParseGeneralStatement; exit when done or token = eof_t; -- continue until done end loop; -- or eof hit if not done then -- not exiting? expect( eof_t ); -- should be nothing else end if; -- lineno := save_lineno; -- restore template line --DoRunTimeStatements( identifiers( token ).value, ); uncompressedScript := null_unbounded_string; -- clear script end if; ---------------------------------------------------------------------- -- Examining a template. ---------------------------------------------------------------------- when outputTemplate => if ch = bushStartTag(1) then -- possible start tag? tag := null_unbounded_string & ch; -- record char tagCount := 1; -- first in tag mode := gatheringStartTag; -- looking for tag elsif end_of_line( f ) then -- otherwise EOL? if last_status = 0 then -- we are outputting? put( ch ); -- write character end if; -- lineno := lineno + 1; -- count template line if last_status = 0 then -- we are outputting? new_line; -- output a line feed end if; else -- not EOL? if last_status = 0 then -- we are outputting? put( ch ); -- write character end if; end if; when others => -- unexpected mode err( "internal error: unknown template mode" ); end case; end loop; -- continue while text close( f ); -- close template file exception when end_error => -- kludge: if a blank line is at the end of template, an end_error -- exception will be thrown. I should fix the EOL handling... close( f ); end processTemplate; --------------------------------------------------------- -- PARSER UTILITIES --------------------------------------------------------- procedure DoQuit is -- Quit a script begin done := true; -- stop parsing exit_block := true; -- exit any block done_sub := false; -- only leaving subprogram if trace then -- tracing? explain put_trace( "Terminating" ); end if; end DoQuit; procedure DoReturn is -- Quit a user-defined subprogram begin done := true; -- stop parsing exit_block := true; -- exit any block done_sub := true; -- only leaving subprogram if trace then -- tracing? explain put_trace( "Returning" ); end if; end DoReturn; procedure parseProcedureCallSemicolon is begin if token = symbol_t then if identifiers( token ).value = ";" then getNextToken; elsif identifiers( token ).value = "|" then err( "procedures cannot be used in a pipeline like commands" ); elsif identifiers( token ).value = ">" then err( "procedure output cannot be redirected like commands" ); elsif identifiers( token ).value = ">>" then err( "procedure output cannot be redirected like commands" ); elsif identifiers( token ).value = "<" then err( "procedure input cannot be redirected like commands" ); elsif identifiers( token ).value = "2>" then err( "procedure error output cannot be redirected like commands" ); elsif identifiers( token ).value = "2>>" then err( "procedure error output cannot be redirected like commands" ); elsif identifiers( token ).value = "&" then err( "procedures cannot be run in the background like commands" ); else expect( symbol_t, ";" ); end if; else expect( symbol_t, ";" ); end if; end parseProcedureCallSemicolon; procedure parseFunctionCallSemicolon is begin if token = symbol_t then if identifiers( token ).value = ";" then getNextToken; elsif identifiers( token ).value = "|" then err( "functions cannot be used in a pipeline like commands" ); elsif identifiers( token ).value = ">" then err( "function output cannot be redirected like commands" ); elsif identifiers( token ).value = ">>" then err( "function output cannot be redirected like commands" ); elsif identifiers( token ).value = "<" then err( "function input cannot be redirected like commands" ); elsif identifiers( token ).value = "2>" then err( "function error output cannot be redirected like commands" ); elsif identifiers( token ).value = "2>>" then err( "function error output cannot be redirected like commands" ); elsif identifiers( token ).value = "&" then err( "functions cannot be run in the background like commands" ); else expect( symbol_t, ";" ); end if; else expect( symbol_t, ";" ); end if; end parseFunctionCallSemicolon; end parser_aux;