summaryrefslogtreecommitdiffstats
path: root/getparam.scm
diff options
context:
space:
mode:
Diffstat (limited to 'getparam.scm')
-rw-r--r--getparam.scm132
1 files changed, 110 insertions, 22 deletions
diff --git a/getparam.scm b/getparam.scm
index 3e2d7f1..1e7b7c0 100644
--- a/getparam.scm
+++ b/getparam.scm
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
@@ -19,12 +19,41 @@
(require 'getopt)
(require 'coerce)
+(require 'parameters)
+(require-if 'compiling 'printf)
+(require-if 'compiling 'common-list-functions)
-(define (getopt->parameter-list argc argv optnames arities types aliases
- . description)
+;;@code{(require 'getopt-parameters)}
+;;@ftindex getopt-parameters
+
+;;@args optnames arities types aliases desc @dots{}
+;;Returns @var{*argv*} converted to a parameter-list. @var{optnames} are
+;;the parameter-names. @var{arities} and @var{types} are lists of symbols
+;;corresponding to @var{optnames}.
+;;
+;;@var{aliases} is a list of lists of strings or integers paired with
+;;elements of @var{optnames}. Each one-character string will be treated
+;;as a single @samp{-} option by @code{getopt}. Longer strings will be
+;;treated as long-named options (@pxref{Getopt, getopt--}).
+;;
+;;If the @var{aliases} association list has only strings as its
+;;@code{car}s, then all the option-arguments after an option (and before
+;;the next option) are adjoined to that option.
+;;
+;;If the @var{aliases} association list has integers, then each (string)
+;;option will take at most one option-argument. Unoptioned arguments are
+;;collected in a list. A @samp{-1} alias will take the last argument in
+;;this list; @samp{+1} will take the first argument in the list. The
+;;aliases -2 then +2; -3 then +3; @dots{} are tried so long as a positive
+;;or negative consecutive alias is found and arguments remain in the list.
+;;Finally a @samp{0} alias, if found, absorbs any remaining arguments.
+;;
+;;In all cases, if unclaimed arguments remain after processing, a warning
+;;is signaled and #f is returned.
+(define (getopt->parameter-list optnames arities types aliases . description)
(define (can-take-arg? opt)
(not (eq? 'boolean (list-ref arities (position opt optnames)))))
- (let ((progname (list-ref argv (+ -1 *optind*)))
+ (let ((progname (list-ref *argv* (+ -1 *optind*)))
(optlist '())
(long-opt-list '())
(optstring #f)
@@ -63,7 +92,8 @@
(for-each (lambda (unc) (adjoin-val unc curopt)) unclaimeds)
(set! unclaimeds '()))))))
(cond ((not (null? unclaimeds))
- (slib:warn 'getopt->parameter-list 'arguments 'unclaimed unclaimeds)
+ (getopt-barf "%s: Unclaimed argument '%s'"
+ progname (car unclaimeds))
(apply parameter-list->getopt-usage
progname optnames arities types aliases description))
(else parameter-list)))
@@ -94,34 +124,34 @@
aliases)
(set! optstring (list->string (cons #\: optlist)))
(let loop ()
- (let ((opt (getopt-- argc argv optstring)))
+ (let ((opt (getopt-- optstring)))
(case opt
((#\: #\?)
- (slib:warn 'getopt->parameter-list
- (case opt
- ((#\:) "argument missing after")
- ((#\?) "unrecognized option"))
- (string #\- getopt:opt))
+ (getopt-barf (case opt
+ ((#\:) "%s: argument missing after '-%c'")
+ ((#\?) "%s: unrecognized option '-%c'"))
+ progname
+ getopt:opt)
(apply parameter-list->getopt-usage
progname optnames arities types aliases description))
((#f)
- (cond ((and (< *optind* argc)
- (string=? "-" (list-ref argv *optind*)))
+ (cond ((and (< *optind* (length *argv*))
+ (string=? "-" (list-ref *argv* *optind*)))
(set! *optind* (+ 1 *optind*))
(finish))
- ((< *optind* argc)
+ ((< *optind* (length *argv*))
(let ((topt (assoc curopt aliases)))
(if topt (set! curopt (cadr topt)))
(cond
((and positional? (not topt))
(set! unclaimeds
- (cons (list-ref argv *optind*) unclaimeds))
+ (cons (list-ref *argv* *optind*) unclaimeds))
(set! *optind* (+ 1 *optind*)) (loop))
((and (member curopt optnames)
- (adjoin-val (list-ref argv *optind*) curopt))
+ (adjoin-val (list-ref *argv* *optind*) curopt))
(set! *optind* (+ 1 *optind*)) (loop))
(else (slib:error 'getopt->parameter-list curopt
- (list-ref argv *optind*)
+ (list-ref *argv* *optind*)
'not 'supported)))))
(else (finish))))
(else
@@ -130,7 +160,7 @@
(if topt (set! topt (cadr topt)))
(cond
((not topt)
- (slib:warn "Option not recognized -" opt)
+ (getopt-barf "%s: '--%s' option not recognized" progname opt)
(apply parameter-list->getopt-usage
progname optnames arities types aliases description))
((not (can-take-arg? topt))
@@ -138,9 +168,15 @@
(loop))
(*optarg* (set! curopt topt) (adjoin-val *optarg* curopt) (loop))
(else
-;;; (slib:warn 'getopt->parameter-list "= missing for option--" opt)
+ ;;(getopt-barf "%s: '--%s' option expects '='" progname opt)
+ ;;(apply parameter-list->getopt-usage progname optnames arities types aliases description)
(set! curopt topt) (loop))))))))))
+(define (getopt-barf . args)
+ (require 'printf)
+ (apply fprintf (current-error-port) args)
+ (newline (current-error-port)))
+
(define (parameter-list->getopt-usage comname optnames arities types aliases
. description)
(require 'printf)
@@ -198,11 +234,17 @@
(for-each (lambda (desc) (fprintf cep " %s\\n" desc)) description))
#f)
-(define (getopt->arglist argc argv optnames positions
+;;@args optnames positions arities types defaulters checks aliases desc @dots{}
+;;Like @code{getopt->parameter-list}, but converts @var{*argv*} to an
+;;argument-list as specified by @var{optnames}, @var{positions},
+;;@var{arities}, @var{types}, @var{defaulters}, @var{checks}, and
+;;@var{aliases}. If the options supplied violate the @var{arities} or
+;;@var{checks} constraints, then a warning is signaled and #f is returned.
+(define (getopt->arglist optnames positions
arities types defaulters checks aliases . description)
- (define progname (list-ref argv (+ -1 *optind*)))
+ (define progname (list-ref *argv* (+ -1 *optind*)))
(let* ((params (apply getopt->parameter-list
- argc argv optnames arities types aliases description))
+ optnames arities types aliases description))
(fparams (and params (fill-empty-parameters defaulters params))))
(cond ((and (list? params)
(check-parameters checks fparams)
@@ -211,3 +253,49 @@
progname optnames arities types aliases description))
(else #f))))
+;;@noindent
+;;These @code{getopt} functions can be used with SLIB relational
+;;databases. For an example, @xref{Using Databases, make-command-server}.
+;;
+;;@noindent
+;;If errors are encountered while processing options, directions for using
+;;the options (and argument strings @var{desc} @dots{}) are printed to
+;;@code{current-error-port}.
+;;
+;;@example
+;;(begin
+;; (set! *optind* 1)
+;; (set! *argv* '("cmd" "-?")
+;; (getopt->parameter-list
+;; '(flag number symbols symbols string flag2 flag3 num2 num3)
+;; '(boolean optional nary1 nary single boolean boolean nary nary)
+;; '(boolean integer symbol symbol string boolean boolean integer integer)
+;; '(("flag" flag)
+;; ("f" flag)
+;; ("Flag" flag2)
+;; ("B" flag3)
+;; ("optional" number)
+;; ("o" number)
+;; ("nary1" symbols)
+;; ("N" symbols)
+;; ("nary" symbols)
+;; ("n" symbols)
+;; ("single" string)
+;; ("s" string)
+;; ("a" num2)
+;; ("Abs" num3))))
+;;@print{}
+;;Usage: cmd [OPTION ARGUMENT ...] ...
+;;
+;; -f, --flag
+;; -o, --optional=<number>
+;; -n, --nary=<symbols> ...
+;; -N, --nary1=<symbols> ...
+;; -s, --single=<string>
+;; --Flag
+;; -B
+;; -a <num2> ...
+;; --Abs=<num3> ...
+;;
+;;ERROR: getopt->parameter-list "unrecognized option" "-?"
+;;@end example