module/slib/getparam.scm

   1 ;;; "getparam.scm" convert getopt to passing parameters by name.
   2 ; Copyright 1995, 1996, 1997, 2001 Aubrey Jaffer
   3 ;
   4 ;Permission to copy this software, to redistribute it, and to use it
   5 ;for any purpose is granted, subject to the following restrictions and
   6 ;understandings.
   7 ;
   8 ;1.  Any copy made of this software must include this copyright notice
   9 ;in full.
  10 ;
  11 ;2.  I have made no warrantee or representation that the operation of
  12 ;this software will be error-free, and I am under no obligation to
  13 ;provide any services, by way of maintenance, update, or otherwise.
  14 ;
  15 ;3.  In conjunction with products arising from the use of this
  16 ;material, there shall be no use of my name in any advertising,
  17 ;promotional, or sales literature without prior written consent in
  18 ;each case.
  19
  20 (require 'getopt)
  21 (require 'coerce)
  22
  23 (define (getopt->parameter-list argc argv optnames arities types aliases
  24                                 . description)
  25   (define (can-take-arg? opt)
  26     (not (eq? 'boolean (list-ref arities (position opt optnames)))))
  27   (let ((progname (list-ref argv (+ -1 *optind*)))
  28         (optlist '())
  29         (long-opt-list '())
  30         (optstring #f)
  31         (pos-args '())
  32         (parameter-list (make-parameter-list optnames))
  33         (curopt '*unclaimed-argument*)
  34         (positional? (assv 0 aliases))
  35         (unclaimeds '()))
  36     (define (adjoin-val val curopt)
  37       (define ntyp (list-ref types (position curopt optnames)))
  38       (adjoin-parameters! parameter-list
  39                           (list curopt (case ntyp
  40                                          ((expression) val)
  41                                          (else (coerce val ntyp))))))
  42     (define (finish)
  43       (cond
  44        (positional?
  45         (set! unclaimeds (reverse unclaimeds))
  46         (do ((idx 2 (+ 1 idx))
  47              (alias+ (assv 1 aliases) (assv idx aliases))
  48              (alias- (assv -1 aliases) (assv (- idx) aliases)))
  49             ((or (not (or alias+ alias-)) (null? unclaimeds)))
  50           (set! unclaimeds (reverse unclaimeds))
  51           (cond (alias-
  52                  (set! curopt (cadr alias-))
  53                  (adjoin-val (car unclaimeds) curopt)
  54                  (set! unclaimeds (cdr unclaimeds))))
  55           (set! unclaimeds (reverse unclaimeds))
  56           (cond ((and alias+ (not (null? unclaimeds)))
  57                  (set! curopt (cadr alias+))
  58                  (adjoin-val (car unclaimeds) curopt)
  59                  (set! unclaimeds (cdr unclaimeds)))))
  60         (let ((alias (assv '0 aliases)))
  61           (cond (alias
  62                  (set! curopt (cadr alias))
  63                  (for-each (lambda (unc) (adjoin-val unc curopt)) unclaimeds)
  64                  (set! unclaimeds '()))))))
  65       (cond ((not (null? unclaimeds))
  66              (slib:warn 'getopt->parameter-list 'arguments 'unclaimed unclaimeds)
  67              (apply parameter-list->getopt-usage
  68                     progname optnames arities types aliases description))
  69             (else parameter-list)))
  70     (set! aliases
  71           (map (lambda (alias)
  72                  (cond ((string? (car alias))
  73                         (let ((str (string-copy (car alias))))
  74                           (do ((i (+ -1 (string-length str)) (+ -1 i)))
  75                               ((negative? i) (cons str (cdr alias)))
  76                             (cond ((char=? #\ (string-ref str i))
  77                                    (string-set! str i #\-))))))
  78                        ((number? (car alias))
  79                         (set! positional? (car alias))
  80                         alias)
  81                        (else alias)))
  82                aliases))
  83     (for-each
  84      (lambda (alias)
  85        (define opt (car alias))
  86        (cond ((number? opt) (set! pos-args (cons opt pos-args)))
  87              ((not (string? opt)))
  88              ((< 1 (string-length opt))
  89               (set! long-opt-list (cons opt long-opt-list)))
  90              ((not (= 1 (string-length opt))))
  91              ((can-take-arg? (cadr alias))
  92               (set! optlist (cons (string-ref opt 0) (cons #\: optlist))))
  93              (else (set! optlist (cons (string-ref opt 0) optlist)))))
  94      aliases)
  95     (set! optstring (list->string (cons #\: optlist)))
  96     (let loop ()
  97       (let ((opt (getopt-- argc argv optstring)))
  98         (case opt
  99           ((#\: #\?)
 100            (slib:warn 'getopt->parameter-list
 101                       (case opt
 102                         ((#\:) "argument missing after")
 103                         ((#\?) "unrecognized option"))
 104                       (string #\- getopt:opt))
 105            (apply parameter-list->getopt-usage
 106                   progname optnames arities types aliases description))
 107           ((#f)
 108            (cond ((and (< *optind* argc)
 109                        (string=? "-" (list-ref argv *optind*)))
 110                   (set! *optind* (+ 1 *optind*))
 111                   (finish))
 112                  ((< *optind* argc)
 113                   (let ((topt (assoc curopt aliases)))
 114                     (if topt (set! curopt (cadr topt)))
 115                     (cond
 116                      ((and positional? (not topt))
 117                       (set! unclaimeds
 118                             (cons (list-ref argv *optind*) unclaimeds))
 119                       (set! *optind* (+ 1 *optind*)) (loop))
 120                      ((and (member curopt optnames)
 121                            (adjoin-val (list-ref argv *optind*) curopt))
 122                       (set! *optind* (+ 1 *optind*)) (loop))
 123                      (else (slib:error 'getopt->parameter-list curopt
 124                                        (list-ref argv *optind*)
 125                                        'not 'supported)))))
 126                  (else (finish))))
 127           (else
 128            (cond ((char? opt) (set! opt (string opt))))
 129            (let ((topt (assoc opt aliases)))
 130              (if topt (set! topt (cadr topt)))
 131              (cond
 132               ((not topt)
 133                (slib:warn "Option not recognized -" opt)
 134                (apply parameter-list->getopt-usage
 135                       progname optnames arities types aliases description))
 136               ((not (can-take-arg? topt))
 137                (adjoin-parameters! parameter-list (list topt #t))
 138                (loop))
 139               (*optarg* (set! curopt topt) (adjoin-val *optarg* curopt) (loop))
 140               (else
 141 ;;;            (slib:warn 'getopt->parameter-list "= missing for option--" opt)
 142                (set! curopt topt) (loop))))))))))
 143
 144 (define (parameter-list->getopt-usage comname optnames arities types aliases
 145                                       . description)
 146   (require 'printf)
 147   (require 'common-list-functions)
 148   (let ((aliast (map list optnames))
 149         (strlen=1? (lambda (s) (= 1 (string-length s))))
 150         (cep (current-error-port)))
 151     (for-each (lambda (alias)
 152                 (let ((apr (assq (cadr alias) aliast)))
 153                   (set-cdr! apr (cons (car alias) (cdr apr)))))
 154               aliases)
 155     (fprintf cep "Usage: %s [OPTION ARGUMENT ...] ..." comname)
 156     (do ((pos+ '()) (pos- '())
 157          (idx 2 (+ 1 idx))
 158          (alias+ (assv 1 aliases) (assv idx aliases))
 159          (alias- (assv -1 aliases) (assv (- idx) aliases)))
 160         ((not (or alias+ alias-))
 161          (for-each (lambda (alias) (fprintf cep " <%s>" (cadr alias)))
 162                    (reverse pos+))
 163          (let ((alias (assv 0 aliases)))
 164            (if alias (fprintf cep " <%s> ..." (cadr alias))))
 165          (for-each (lambda (alias) (fprintf cep " <%s>" (cadr alias)))
 166                    pos-))
 167       (cond (alias- (set! pos- (cons alias- pos-))))
 168       (cond (alias+ (set! pos+ (cons alias+ pos+)))))
 169     (fprintf cep "\\n\\n")
 170     (for-each
 171      (lambda (optname arity aliat)
 172        (let loop ((initials (remove-if-not strlen=1? (remove-if number? (cdr aliat))))
 173                   (longname (remove-if strlen=1? (remove-if number? (cdr aliat)))))
 174          (cond ((and (null? initials) (null? longname)))
 175                (else (fprintf cep
 176                               (case arity
 177                                 ((boolean) "  %3s %s\\n")
 178                                 (else "  %3s %s<%s> %s\\n"))
 179                               (if (null? initials)
 180                                   ""
 181                                   (string-append "-" (car initials)
 182                                                  (if (null? longname) " " ",")))
 183                               (if (null? longname)
 184                                   "      "
 185                                   (string-append "--" (car longname)
 186                                                  (case arity
 187                                                    ((boolean) " ")
 188                                                    (else "="))))
 189                               (case arity
 190                                 ((boolean) "")
 191                                 (else optname))
 192                               (case arity
 193                                 ((nary nary1) "...")
 194                                 (else "")))
 195                      (loop (if (null? initials) '() (cdr initials))
 196                            (if (null? longname) '() (cdr longname)))))))
 197      optnames arities aliast)
 198     (for-each (lambda (desc) (fprintf cep "  %s\\n" desc)) description))
 199   #f)
 200
 201 (define (getopt->arglist argc argv optnames positions
 202                          arities types defaulters checks aliases . description)
 203   (define progname (list-ref argv (+ -1 *optind*)))
 204   (let* ((params (apply getopt->parameter-list
 205                         argc argv optnames arities types aliases description))
 206          (fparams (and params (fill-empty-parameters defaulters params))))
 207     (cond ((and (list? params)
 208                 (check-parameters checks fparams)
 209                 (parameter-list->arglist positions arities fparams)))
 210           (params (apply parameter-list->getopt-usage
 211                          progname optnames arities types aliases description))
 212           (else #f))))
 213