argscli.sa


Generated by gen_html_sa_files from ICSI. Contact gomes@icsi.berkeley.edu for details
 
------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 2000 by K Hopper, University of Waikato, New Zealand        --
-- This file is part of the GNU Sather library. It is free software; you may --
-- redistribute  and/or modify it under the terms of the GNU Library General --
-- Public  License (LGPL)  as published  by the  Free  Software  Foundation; --
-- either version 2 of the license, or (at your option) any later version.   --
-- This  library  is distributed  in the  hope that it will  be  useful, but --
-- WITHOUT ANY WARRANTY without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See Doc/LGPL for more details.       --
-- The license text is also available from:  Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA                     --
-------------->  Please email comments to <bug-sather@gnu.org>  <--------------


abstract class $OPTION

abstract class $OPTION is --This abstraction encapsulates the notion of a program option -- argument. An option may be of any kind for which an external textual -- representation is provided and suitable for reading. -- Version 1.0 Nov 2000. Copyright K Hopper, U of Waikato -- Development History -- ------------------- -- Date Who By Detail -- ---- ------ ------ -- 17 Nov 00 kh Original from new specifications create( str : STR) : SAME ; --This returns a new object which has been converted from the given -- textual representation string using the default repertoire and encoding. end ; -- $OPTION

class PROGRAM_ARGS

class PROGRAM_ARGS is --This class provides the facility to handle arbitrary program -- arguments in unix-style format. -- Options may be made available either as the traditional Unix -- argument 'pack' or as a single string (provided, for example under DOS) -- or as the contents of some named file. -- The syntax for an individual argument is -- Argument := Option | Program Argument ; -- Option := Option delimiter, Option name,[White Space, Option value] ; -- Option delimiter := Minus symbol | Plus symbol ; -- Option name := Identifier ; -- Option value := Number | Truth value | Value string ; -- Number := Whole number | Approximate number ; -- Truth value := True symbol | False symbol ; -- Value string := Quoted String | No Space String ; -- Quoted String := Quote symbol, {Encoding *}, Quote symbol ; -- Program Argument := No Space String ; -- All symbols are arbitrary bit-sequences determined from the default -- program argument mapping parameter file when the argument class is first -- created. -- -- There may be an arbitrary number of alternative quote symbols, -- the only restriction being that the encoding which is detected at the -- beginning of a quoted string must be the same as used at the end -- and -- must not, of course, appear anywhere within the bit-stream of the string -- value itself. -- -- Numeric values are both presumed to begin with an encoding which is -- NOT a quote symbol, white space or an option delimiter and is also -- not permitted as the first encoding in an identifier. Otherwise there -- are no restrictions on the encodings. -- -- After creation it is expected that a number of parameters will be -- specifed in terms of their name and the function associated with that -- option which is to be called when the name is recognised during argument -- reading. -- -- Option handler functions must have the signature ROUT{$OPTION} -- -- The public interface of this class consists of the following -- routines :-- -- create() -- add_option(name,funct) -- delete_option(name) -- read(filename) -- which return false if error -- read(filehandle) -- read(string) -- read(array of strings) -- the traditional Unix argv -- Version 1.4 Nov 2000. Copyright K Hopper, U of Waikato -- Development History -- ------------------- -- Date Who By Detail -- ---- ------ ------ -- 5 Apr 96 kh Original -- 9 Jun 97 kh Modified for portability, etc -- 21 Oct 98 kh Improved portability and added pre/posts -- 22 Sep 99 kh All reads now return BOOL -- 17 Nov 00 kh Handlers now ROUT{$OPTION} private const Error_Start, Unexpected_End, Eval, Missing_Token, Unknown_Option, Unknown_Handler, Space_Skip, Arg_Expected, Name_is, Value_Missing, Bad_Arg, Unknown_Env_Var, Not_Open ; -- The above is a private simple enumeration for indexing the error message array. private const Msg_Count : CARD := Not_Open + 1 ; private shared Messages : ARRAY{STR} ; private shared report : REPORTER ; private attr options : FMAP{STR,TUP{$OB,BOOL}} ; readonly attr arguments : FLIST{STR} ; readonly attr progname : STR ; -- These attributes are the map which contains option handlers and -- the list of arguments and its name(!) which may be needed by the program. private shared delimiters : ARRAY{STR} ; private shared quotes : ARRAY{STR} ; private shared whitespace : ARRAY{STR} ; private shared line_mark : STR ; private init(lib : LIBCHARS) pre ~void(self) and ~void(lib) post ~void(delimiters) -- or an exception has been raised! is --This private routine is provided to initialise all of the shared -- components - but only once! if void(delimiters) then loc_cult : CULTURE := lib.culture ; Messages := loc_cult.resources.read(SYS::rune_name(self),Msg_Count) ; report := REPORTER::create(Messages) ; line_mark := lib.Line_Mark.tgt_str ; delimiters := | lib.Minus_Sign.char.str(lib), lib.Plus_Sign.char.str(lib) | ; quotes := | lib.Quotation_Mark.char.str(lib), lib.Apostrophe.char.str(lib) | ; whitespace := | lib.Space.char.str(lib), (CHAR::create(CONTROL_CODES::HORIZONTAL_TAB,lib)).str(lib), (CHAR::create(CONTROL_CODES::VERTICAL_TAB,lib)).str(lib) | end end ; create(lib : LIBCHARS) : SAME pre ~void(lib) post ~void(result) is --This creation routine sets up an initially empty map, a void program -- name and an empty list of arguments. me : SAME := new ; me.init(lib) ; me.options := FMAP{STR,TUP{$OB,BOOL}}::create ; me.arguments := void ; me.progname := void ; return(me) end ; create : SAME pre true post ~void(result) is --This creation routine sets up an initially empty map, a void program -- name and an empty list of arguments using the default culture. return create(LIBCHARS::default) end ; add_option(name : STR,func : $OB,has_val : BOOL) pre ~void(self) and ~void(func) and (name.size > 0) post options.test(name) or ~report.error_free is --This routine attempts to add a new option name to the map. This -- is only possible if the name does not already exist in the map. The -- second argument is expected to be appropriate to the named option. If -- the has_val argument is true then a value will be looked for after the -- option name in the argument list. If this argument is false then the -- handler must be a ROUT{BOOL}. typecase func when BOOL then else if ~has_val then report.error(Arg_Expected,name) end end ; if report.error_free and (void(options) or ~options.test(name)) then options := options.insert(name, TUP{$OB,BOOL}::create(func,has_val)) end end ; delete_option(name : STR) pre ~void(self) and (name.size > 0) post ~options.test(name) is --This routine attempts to delete an option named name. If the -- option is not in the map this routine does nothing since the name has -- either already been deleted or was never there. if options.test(name) then options := options.delete(name) end end ; private check_error(index : STR_CURSOR,msg : STR,check_done : BOOL) pre (msg.size > 0) and ~void(index) post report.error_free or ((index.has_error or index.is_done)) is --This private auxiliary routine is used to handle string cursor -- class error detection. Note that in this context premature -- termination of the option input is treated as an error. if index.has_error then report.error(Value_Missing,msg) elsif index.is_done and check_done then report.error(Unexpected_End,msg) end end ; private val_error(index : STR_CURSOR,option_name : STR,kind : STR) pre ~void(index) and (option_name.size > 0) and (kind.size > 0) post index.has_error or report.error_free is --This routine reports an error if one was detected while -- attempting to obtain a value of 'kind'. if index.has_error then report.error(Eval,kind,option_name) end end ; private skip_valid(index : STR_CURSOR,try : STR) : STR pre ~void(index) and ~index.is_done and (try.size > 0) -- zero is returned if void! post true -- string is void or equals the lookup item is --This routine checks to see if the string pointed to by index is -- the test string try. If so then try is returned, otherwise void. test : STR := STR::create ; mark : CARD := index.index ; loop -- test string of same length try.size.times! ; test := test + index.item ; index.advance end ; if test = try then return try else index.set_index(mark) ; return void end end ; private skip_valid(index : STR_CURSOR,lookup : ARRAY{STR}) : STR pre ~void(index) and ~index.is_done and ~void(lookup) -- which implies at least one element post true -- string is void or equals the lookup item is --This routine checks to see if the string pointed to by index starts -- with any of the strings in lookup. If this is true then the relevant -- string is returned and index is moved past the valid string, otherwise -- index is not changed and a void string is returned. loop -- on lookup array try : STR := skip_valid(index,lookup.elt!) ; if ~void(try) then return try end end ; return void end ; private skip_valid_delimiter(index : STR_CURSOR) : STR is --This routine returns void unless the indexed string begins with -- an option delimiter -- in which case the value of the delimiter is -- returned. return skip_valid(index,delimiters) end ; private skip_valid_quote(index : STR_CURSOR) : STR is --This routine returns void unless the indexed string begins with -- a valid string quote mark -- in which case the value of the mark is -- returned. return skip_valid(index,quotes) end ; private get_up_to(str : STR,index : STR_CURSOR) : STR pre (str.size > 0) and ~void(index) and ~index.is_done post ~void(result) -- although it may be empty! is --This routine is a private version of the string cursor get_upto -- routine but stops at the first octet of a multiple octet mark. res : STR := STR::create ; loop tmp : STR := skip_valid(index,str) ; if void(tmp) then res := res + index.get_item ; if index.has_error then report.error(Missing_Token,str) end else return res end end end ; private get_quoted_string(index : STR_CURSOR,quote : STR) : STR pre (quote.size > 0) and ~void(index) and ~index.is_done post ~void(result) -- although it may be empty is --This routine expects that index is indicating the first element -- in a string on entry. It returns the string up to but not including -- the first encoding which is equal to quote. return get_up_to(quote,index) end ; private get_value(index : STR_CURSOR) : STR pre ~void(index) and ~index.is_done post ~void(result) -- but it may be empty is --This routine produces a string which, if it contains quote marks -- may include whitespace up to but not including the first unprotected -- white space. res : STR := STR::create ; loop if index.is_done -- a 'space'! or index.item.is_space then return res else tmp : STR := skip_valid_quote(index) ; if void(tmp) then res := res + index.get_item ; -- even if off the end! if index.has_error then index.clear_error ; break! end else -- It is quoted so get it and -- re-insert the quotes! res := res + tmp ; res := res + get_quoted_string(index,tmp) ; index.advance ; -- past the final quote res := res + tmp end end end ; return res end ; private call_handler(name : STR,index : STR_CURSOR) pre ~void(self) and ~void(index) and (name.size > 0) post report.error_free -- if so the handler has been called! is --This routine checks if name is a valid option name and, if so -- it tries to obtain the option value from val. Providing that this -- too is successful, the associated routine is invoked. loc_tup : TUP{$OB,BOOL} ; handler : $OB ; if (options.test(name)) then loc_tup := options.get(name) ; handler := loc_tup.t1 else report.error(Unknown_Option,name) end ; typecase handler when ROUT{BOOL} then truth_val : BOOL ; if loc_tup.t2 then truth_val := BOOL::build(index) ; val_error(index,name,SYS::rune_name(truth_val).str) else -- just a 'flag' with default 'true' truth_val := true end ; handler.call(truth_val) when ROUT{STR} then quote : STR := skip_valid_quote(index) ; if ~void(quote) then -- IS a quoted string! msg : STR := get_quoted_string(index,quote) ; val_error(index,name,SYS::rune_name(msg).str) ; handler.call(msg) else -- No quotation marks - use all! handler.call(index.get_word) end else loc_str : STR := index.get_word ; typecase handler when ROUT{CARD} then loc_val : CARD := CARD::create(loc_str) ; val_error(index,name,SYS::rune_name(loc_val).str) ; handler.call(loc_val) when ROUT{FIELD} then loc_val : FIELD := FIELD::create(loc_str) ; val_error(index,name,SYS::rune_name(loc_val).str) ; handler.call(loc_val) when ROUT{INT} then loc_val : INT := INT::create(loc_str) ; val_error(index,name,SYS::rune_name(loc_val).str) ; handler.call(loc_val) when ROUT{FLT} then loc_val : FLT := FLT::create(loc_str) ; val_error(index,name,SYS::rune_name(loc_val).str) ; handler.call(loc_val) when ROUT{RAT} then loc_val : RAT := RAT::create(loc_str) ; val_error(index,name,SYS::rune_name(loc_val).str) ; handler.call(loc_val) when ROUT{CPX} then loc_val : CPX := CPX::create(loc_str) ; val_error(index,name,SYS::rune_name(loc_val).str) ; handler.call(loc_val) when ROUT{MONEY} then loc_val : MONEY := MONEY::create(loc_str) ; val_error(index,name,SYS::rune_name(loc_val).str) ; handler.call(loc_val) else report.error(Unknown_Handler,name) end ; end end ; private read_option(index : STR_CURSOR) : BOOL pre ~void(self) and ~void(index) and ~index.is_done post result or ~report.error_free is --This routine scans the string from the current position of the -- cursor index looking for either an argument or an option value -- specification. -- -- If the first item found is an option delimiter then, provided that -- no arguments have yet been encountered, the following name is looked up. -- Provided the name is recognised then the associated option handler is -- called, otherwise an error is reported. -- -- If the first item found is not an option delimiter then it is -- assumed that the item and all following items are arguments. -- -- Should the conditions not be met then an error is reported and -- false is returned, otherwise true. index.skip_space ; if index.is_done then return false end ; check_error(index,Messages[Space_Skip],false) ; delim : STR := skip_valid_delimiter(index) ; if ~void(delim) then if ~void(arguments) then -- Oops! Arguments must be last! report.error(Arg_Expected) ; return false else -- OK to handle option! option_name : STR := index.get_word ; check_error(index,FMT::create(Messages[Name_is], option_name).str,true) ; index.skip_space ; -- this should be successful! check_error(index,FMT::create(Messages[Value_Missing], option_name).str,true) ; call_handler(option_name,index) -- index to get option value! end else -- It is just an argument! tmp : CARD := index.index ; argument : STR := get_value(index) ; check_error(index,FMT::create(Messages[Bad_Arg],argument).str,false) ; arguments := arguments.push(argument) end ; index.skip_space ; return true end ; read(filename : FILE_PATH) : BOOL pre ~void(self) and ~void(filename) post true -- or an exception raised by report! is --This routine reads program options and arguments from the file specified. fyle : TEXT_FILE := TEXT_FILE::open_for_read(filename.str) ; if void(fyle) or fyle.error then -- couldn't open/find the file? report.fatal ; report.error(Not_Open,filename.str) ; return false else contents : STR := fyle.fstr.str ; index : STR_CURSOR := contents.cursor ; loop while!(~index.is_done) ; if ~read_option(index) then return false end end ; return true end end ; private config(name : STR) pre ~void(self) and (name.size > 0) post true -- or an exception has been raised by report. is --This routine looks in the environment for the named environment -- variable which it uses to look for an option configuration file which -- it reads to set the above option attributes. file_name : STR := OPSYS::get_env(name) ; if void(file_name) then report.fatal ; report.error(Unknown_Env_Var,name) ; return false -- to satisfy compiler! else return read(file_name) end end ; private read(index : STR_CURSOR) : BOOL pre ~void(self) and ~void(index) and ~index.is_done post true -- or an exception has been raised is --This private routine parses commands from the string cursor index, -- returning true if there have been no errors!. loop while!(~index.is_done) ; if ~read_option(index) then return false end end ; return true end ; read(fyle : TEXT_FILE) : BOOL pre ~void(self) and ~void(fyle) post true is --This routine scans the file provided for options/arguments. True is -- returned only if there have been no reported errors. return read(fyle.fstr.str.cursor) end ; read(string : STR) : BOOL pre ~void(self) and (string.size > 0) post true -- or an exception has been raised! is --This routine uses the string as a list of options/arguments, -- returning true if there are no errors. return read(string.cursor) end ; read(argv : ARRAY{STR}) : BOOL pre ~void(self) and ~void(argv) and (argv.size > 0) and (argv[0].size > 0) post true -- or an exception has been raised by report. is --This routine converts the array of strings into one space separated -- string and then calls the cursor version of read to find the options and -- arguments. True is only returned if there have been no errors. res : STR := STR::create ; if argv[0].width = 0 then -- external generated! loop argv.set!(argv.elt!.create_from_external_string(argv.elt!.array_ptr)) end end ; progname := argv[0] ; --loc_sep : STR := LIBCHARS::default.Space.str ; loc_sep : STR := #(LIBCHARS::default.Space) ; loop loc_str : STR := argv.elt!(1) ; res := res + loc_sep.separate!(loc_str) end ; -- #OUT+"argscli.sa res:"+res+"\n"; if res.size > 0 then return read(res.cursor) else return true end end ; end ; -- PROGRAM_ARGS