diff options
Diffstat (limited to 'getparam.scm')
| -rw-r--r-- | getparam.scm | 132 |
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 |