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