module/mes/getopt-long.scm

   1 ;;; Copyright (C) 1998, 2001, 2006 Free Software Foundation, Inc.
   2 ;;; Copyright (C) 2017 Jan Nieuwenhuizen <janneke@gnu.org>
   3 ;;;
   4 ;; This library is free software; you can redistribute it and/or
   5 ;; modify it under the terms of the GNU Lesser General Public
   6 ;; License as published by the Free Software Foundation; either
   7 ;; version 2.1 of the License, or (at your option) any later version.
   8 ;;
   9 ;; This library is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;; Lesser General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU Lesser General Public
  15 ;; License along with this library; if not, write to the Free Software
  16 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17
  18 ;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
  19 ;;;                      (regexps removed by Jan Nieuwenhuizen)
  20 ;;;                      (srfi-9 backport by Jan Nieuwenhuizen)
  21
  22 ;;; Commentary:
  23
  24 ;;; This module implements some complex command line option parsing, in
  25 ;;; the spirit of the GNU C library function `getopt_long'.  Both long
  26 ;;; and short options are supported.
  27 ;;;
  28 ;;; The theory is that people should be able to constrain the set of
  29 ;;; options they want to process using a grammar, rather than some arbitrary
  30 ;;; structure.  The grammar makes the option descriptions easy to read.
  31 ;;;
  32 ;;; `getopt-long' is a procedure for parsing command-line arguments in a
  33 ;;; manner consistent with other GNU programs.  `option-ref' is a procedure
  34 ;;; that facilitates processing of the `getopt-long' return value.
  35
  36 ;;; (getopt-long ARGS GRAMMAR)
  37 ;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR.
  38 ;;;
  39 ;;; ARGS should be a list of strings.  Its first element should be the
  40 ;;; name of the program; subsequent elements should be the arguments
  41 ;;; that were passed to the program on the command line.  The
  42 ;;; `program-arguments' procedure returns a list of this form.
  43 ;;;
  44 ;;; GRAMMAR is a list of the form:
  45 ;;; ((OPTION (PROPERTY VALUE) ...) ...)
  46 ;;;
  47 ;;; Each OPTION should be a symbol.  `getopt-long' will accept a
  48 ;;; command-line option named `--OPTION'.
  49 ;;; Each option can have the following (PROPERTY VALUE) pairs:
  50 ;;;
  51 ;;;   (single-char CHAR) --- Accept `-CHAR' as a single-character
  52 ;;;             equivalent to `--OPTION'.  This is how to specify traditional
  53 ;;;             Unix-style flags.
  54 ;;;   (required? BOOL) --- If BOOL is true, the option is required.
  55 ;;;             getopt-long will raise an error if it is not found in ARGS.
  56 ;;;   (value BOOL) --- If BOOL is #t, the option accepts a value; if
  57 ;;;             it is #f, it does not; and if it is the symbol
  58 ;;;             `optional', the option may appear in ARGS with or
  59 ;;;             without a value.
  60 ;;;   (predicate FUNC) --- If the option accepts a value (i.e. you
  61 ;;;             specified `(value #t)' for this option), then getopt
  62 ;;;             will apply FUNC to the value, and throw an exception
  63 ;;;             if it returns #f.  FUNC should be a procedure which
  64 ;;;             accepts a string and returns a boolean value; you may
  65 ;;;             need to use quasiquotes to get it into GRAMMAR.
  66 ;;;
  67 ;;; The (PROPERTY VALUE) pairs may occur in any order, but each
  68 ;;; property may occur only once.  By default, options do not have
  69 ;;; single-character equivalents, are not required, and do not take
  70 ;;; values.
  71 ;;;
  72 ;;; In ARGS, single-character options may be combined, in the usual
  73 ;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy").  If an option
  74 ;;; accepts values, then it must be the last option in the
  75 ;;; combination; the value is the next argument.  So, for example, using
  76 ;;; the following grammar:
  77 ;;;      ((apples    (single-char #\a))
  78 ;;;       (blimps    (single-char #\b) (value #t))
  79 ;;;       (catalexis (single-char #\c) (value #t)))
  80 ;;; the following argument lists would be acceptable:
  81 ;;;    ("-a" "-b" "bang" "-c" "couth")     ("bang" and "couth" are the values
  82 ;;;                                         for "blimps" and "catalexis")
  83 ;;;    ("-ab" "bang" "-c" "couth")         (same)
  84 ;;;    ("-ac" "couth" "-b" "bang")         (same)
  85 ;;;    ("-abc" "couth" "bang")             (an error, since `-b' is not the
  86 ;;;                                         last option in its combination)
  87 ;;;
  88 ;;; If an option's value is optional, then `getopt-long' decides
  89 ;;; whether it has a value by looking at what follows it in ARGS.  If
  90 ;;; the next element is does not appear to be an option itself, then
  91 ;;; that element is the option's value.
  92 ;;;
  93 ;;; The value of a long option can appear as the next element in ARGS,
  94 ;;; or it can follow the option name, separated by an `=' character.
  95 ;;; Thus, using the same grammar as above, the following argument lists
  96 ;;; are equivalent:
  97 ;;;   ("--apples" "Braeburn" "--blimps" "Goodyear")
  98 ;;;   ("--apples=Braeburn" "--blimps" "Goodyear")
  99 ;;;   ("--blimps" "Goodyear" "--apples=Braeburn")
 100 ;;;
 101 ;;; If the option "--" appears in ARGS, argument parsing stops there;
 102 ;;; subsequent arguments are returned as ordinary arguments, even if
 103 ;;; they resemble options.  So, in the argument list:
 104 ;;;         ("--apples" "Granny Smith" "--" "--blimp" "Goodyear")
 105 ;;; `getopt-long' will recognize the `apples' option as having the
 106 ;;; value "Granny Smith", but it will not recognize the `blimp'
 107 ;;; option; it will return the strings "--blimp" and "Goodyear" as
 108 ;;; ordinary argument strings.
 109 ;;;
 110 ;;; The `getopt-long' function returns the parsed argument list as an
 111 ;;; assocation list, mapping option names --- the symbols from GRAMMAR
 112 ;;; --- onto their values, or #t if the option does not accept a value.
 113 ;;; Unused options do not appear in the alist.
 114 ;;;
 115 ;;; All arguments that are not the value of any option are returned
 116 ;;; as a list, associated with the empty list.
 117 ;;;
 118 ;;; `getopt-long' throws an exception if:
 119 ;;; - it finds an unrecognized property in GRAMMAR
 120 ;;; - the value of the `single-char' property is not a character
 121 ;;; - it finds an unrecognized option in ARGS
 122 ;;; - a required option is omitted
 123 ;;; - an option that requires an argument doesn't get one
 124 ;;; - an option that doesn't accept an argument does get one (this can
 125 ;;;   only happen using the long option `--opt=value' syntax)
 126 ;;; - an option predicate fails
 127 ;;;
 128 ;;; So, for example:
 129 ;;;
 130 ;;; (define grammar
 131 ;;;   `((lockfile-dir (required? #t)
 132 ;;;                   (value #t)
 133 ;;;                   (single-char #\k)
 134 ;;;                   (predicate ,file-is-directory?))
 135 ;;;     (verbose (required? #f)
 136 ;;;              (single-char #\v)
 137 ;;;              (value #f))
 138 ;;;     (x-includes (single-char #\x))
 139 ;;;     (rnet-server (single-char #\y)
 140 ;;;                  (predicate ,string?))))
 141 ;;;
 142 ;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include"
 143 ;;;                "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3")
 144 ;;;                grammar)
 145 ;;; => ((() "foo1" "-fred" "foo2" "foo3")
 146 ;;;     (rnet-server . "lamprod")
 147 ;;;     (x-includes . "/usr/include")
 148 ;;;     (lockfile-dir . "/tmp")
 149 ;;;     (verbose . #t))
 150
 151 ;;; (option-ref OPTIONS KEY DEFAULT)
 152 ;;; Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not
 153 ;;; found.  The value is either a string or `#t'.
 154 ;;;
 155 ;;; For example, using the `getopt-long' return value from above:
 156 ;;;
 157 ;;; (option-ref (getopt-long ...) 'x-includes 42) => "/usr/include"
 158 ;;; (option-ref (getopt-long ...) 'not-a-key! 31) => 31
 159
 160 ;;; Code:
 161
 162 (define-module (mes getopt-long)
 163   #:use-module (srfi srfi-1)
 164   #:use-module (srfi srfi-9)
 165   #:export (getopt-long option-ref))
 166
 167 (define (remove-if-not pred l)
 168   (let loop ((l l) (result '()))
 169     (cond ((null? l) (reverse! result))
 170           ((not (pred (car l))) (loop (cdr l) result))
 171           (else (loop (cdr l) (cons (car l) result))))))
 172
 173 (define-record-type option-spec
 174   (%make-option-spec name required? option-spec->single-char predicate value-policy)
 175   option-spec?
 176   (name
 177    option-spec->name set-option-spec-name!)
 178   (required?
 179    option-spec->required? set-option-spec-required?!)
 180   (option-spec->single-char
 181    option-spec->single-char set-option-spec-single-char!)
 182   (predicate
 183    option-spec->predicate set-option-spec-predicate!)
 184   (value-policy
 185    option-spec->value-policy set-option-spec-value-policy!))
 186
 187 (define (make-option-spec name)
 188   (%make-option-spec name #f #f #f #f))
 189
 190 (define (parse-option-spec desc)
 191   (let ((spec (make-option-spec (symbol->string (car desc)))))
 192     (for-each (lambda (desc-elem)
 193                 (let ((given (lambda () (cadr desc-elem))))
 194                   (case (car desc-elem)
 195                     ((required?)
 196                      (set-option-spec-required?! spec (given)))
 197                     ((value)
 198                      (set-option-spec-value-policy! spec (given)))
 199                     ((single-char)
 200                      (or (char? (given))
 201                          (error "`single-char' value must be a char!"))
 202                      (set-option-spec-single-char! spec (given)))
 203                     ((predicate)
 204                      (set-option-spec-predicate!
 205                       spec ((lambda (pred)
 206                               (lambda (name val)
 207                                 (or (not val)
 208                                     (pred val)
 209                                     (error "option predicate failed:" name))))
 210                             (given))))
 211                     (else
 212                      (error "invalid getopt-long option property:"
 213                             (car desc-elem))))))
 214               (cdr desc))
 215     spec))
 216
 217 (define (split-arg-list argument-list)
 218   ;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS).
 219   ;; Discard the "--".  If no "--" is found, AFTER-LS is empty.
 220   (let loop ((yes '()) (no argument-list))
 221     (cond ((null? no)               (cons (reverse yes) no))
 222           ((string=? "--" (car no)) (cons (reverse yes) (cdr no)))
 223           (else (loop (cons (car no) yes) (cdr no))))))
 224
 225 (define (expand-clumped-singles opt-ls)
 226   ;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d")
 227   (let loop ((opt-ls opt-ls) (ret-ls '()))
 228     (cond ((null? opt-ls)
 229            (reverse ret-ls))                                    ;;; retval
 230           ((let ((opt (car opt-ls)))
 231              (and (eq? (string-ref opt 0) #\-)
 232                   (let ((n (char->integer (string-ref opt 1))))
 233                     (or (and (>= n (char->integer #\A)) (<= n (char->integer #\Z)))
 234                         (and (>= n (char->integer #\a)) (<= n (char->integer #\z)))))))
 235            (let* ((opt (car opt-ls))
 236                   (n (char->integer (string-ref opt 1)))
 237                   (end (or (string-index opt (lambda (c) (not (or (and (>= n (char->integer #\A)) (<= n (char->integer #\Z)))
 238                                                                   (and (>= n (char->integer #\a)) (<= n (char->integer #\z)))))))
 239                            (string-length opt)))
 240                   (singles-string (substring opt 1 end))
 241                   (singles (reverse
 242                             (map (lambda (c)
 243                                    (string-append "-" (make-string 1 c)))
 244                                  (string->list singles-string))))
 245                  (extra (substring opt end)))
 246              (loop (cdr opt-ls)
 247                    (append (if (string=? "" extra)
 248                                singles
 249                                (cons extra singles))
 250                            ret-ls))))
 251           (else (loop (cdr opt-ls)
 252                       (cons (car opt-ls) ret-ls))))))
 253
 254 (define (looks-like-an-option string)
 255   (eq? (string-ref string 0) #\-))
 256
 257 (define (process-options specs argument-ls)
 258   ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
 259   ;; FOUND is an unordered list of option specs for found options, while ETC
 260   ;; is an order-maintained list of elements in ARGUMENT-LS that are neither
 261   ;; options nor their values.
 262   (let ((idx (map (lambda (spec)
 263                     (cons (option-spec->name spec) spec))
 264                   specs))
 265         (sc-idx (map (lambda (spec)
 266                        (cons (make-string 1 (option-spec->single-char spec))
 267                              spec))
 268                      (remove-if-not option-spec->single-char specs))))
 269     (let loop ((argument-ls argument-ls) (found '()) (etc '()))
 270       (let ((eat! (lambda (spec ls)
 271                     (let ((val!loop (lambda (val n-ls n-found n-etc)
 272                                       (set-option-spec-value-policy!
 273                                        spec
 274                                        ;; handle multiple occurrances
 275                                        (cond ((option-spec->value-policy spec)
 276                                               => (lambda (cur)
 277                                                    ((if (list? cur) cons list)
 278                                                     val cur)))
 279                                              (else val)))
 280                                       (loop n-ls n-found n-etc)))
 281                           (ERR:no-arg (lambda ()
 282                                         (error (string-append
 283                                                 "option must be specified"
 284                                                 " with argument:")
 285                                                (option-spec->name spec)))))
 286                       (cond
 287                        ((eq? 'optional (option-spec->value-policy spec))
 288                         (if (or (null? (cdr ls))
 289                                 (looks-like-an-option (cadr ls)))
 290                             (val!loop #t
 291                                       (cdr ls)
 292                                       (cons spec found)
 293                                       etc)
 294                             (val!loop (cadr ls)
 295                                       (cddr ls)
 296                                       (cons spec found)
 297                                       etc)))
 298                        ((eq? #t (option-spec->value-policy spec))
 299                         (if (or (null? (cdr ls))
 300                                 (looks-like-an-option (cadr ls)))
 301                             (ERR:no-arg)
 302                             (val!loop (cadr ls)
 303                                       (cddr ls)
 304                                       (cons spec found)
 305                                       etc)))
 306                        (else
 307                         (val!loop #t
 308                                   (cdr ls)
 309                                   (cons spec found)
 310                                   etc)))))))
 311
 312         (if (null? argument-ls)
 313             (cons found (reverse etc))                          ;;; retval
 314             (cond ((let ((opt (car argument-ls)))
 315                      (and (eq? (string-ref opt 0) #\-)
 316                           (let ((n (char->integer (string-ref opt 1))))
 317                             (or (and (>= n (char->integer #\A)) (<= n (char->integer #\Z)))
 318                                 (and (>= n (char->integer #\a)) (<= n (char->integer #\z)))))))
 319                    (let* ((c (substring (car argument-ls) 1 2))
 320                           (spec (or (assoc-ref sc-idx c)
 321                                     (error "no such option:" (car argument-ls)))))
 322                      (eat! spec argument-ls)))
 323                   ((let ((opt (car argument-ls)))
 324                      (and (string-prefix? "--" opt)
 325                           (let ((n (char->integer (string-ref opt 2))))
 326                             (or (and (>= n (char->integer #\A)) (<= n (char->integer #\Z)))
 327                                 (and (>= n (char->integer #\a)) (<= n (char->integer #\z)))))
 328                           (not (string-index opt #\space))
 329                           (not (string-index opt #\=))))
 330                    (let* ((opt (substring (car argument-ls) 2))
 331                           (spec (or (assoc-ref idx opt)
 332                                     (error "no such option:" (car argument-ls)))))
 333                      (eat! spec argument-ls)))
 334                   ((let ((opt (car argument-ls)))
 335                      (and (string-prefix? "--" opt)
 336                           (let ((n (char->integer (string-ref opt 2))))
 337                             (or (and (>= n (char->integer #\A)) (<= n (char->integer #\Z)))
 338                                 (and (>= n (char->integer #\a)) (<= n (char->integer #\z)))))
 339                           (or (string-index opt #\=)
 340                               (string-index opt #\space))))
 341                    (let* ((is (or (string-index (car argument-ls) #\=)
 342                                   (string-index (car argument-ls) #\space)))
 343                           (opt (substring (car argument-ls) 2 is))
 344                           (spec (or (assoc-ref idx opt)
 345                                     (error "no such option:" (substring opt is)))))
 346                      (if (option-spec->value-policy spec)
 347                          (eat! spec (append
 348                                      (list 'ignored
 349                                            (substring (car argument-ls) (1+ is)))
 350                                      (cdr argument-ls)))
 351                          (error "option does not support argument:"
 352                                 opt))))
 353                   (else
 354                    (loop (cdr argument-ls)
 355                          found
 356                          (cons (car argument-ls) etc)))))))))
 357
 358 (define (getopt-long program-arguments option-desc-list)
 359 ;;   "Process options, handling both long and short options, similar to
 360 ;; the glibc function 'getopt_long'.  PROGRAM-ARGUMENTS should be a value
 361 ;; similar to what (program-arguments) returns.  OPTION-DESC-LIST is a
 362 ;; list of option descriptions.  Each option description must satisfy the
 363 ;; following grammar:
 364
 365 ;;     <option-spec>           :: (<name> . <attribute-ls>)
 366 ;;     <attribute-ls>          :: (<attribute> . <attribute-ls>)
 367 ;;                                | ()
 368 ;;     <attribute>             :: <required-attribute>
 369 ;;                                | <arg-required-attribute>
 370 ;;                                | <single-char-attribute>
 371 ;;                                | <predicate-attribute>
 372 ;;                                | <value-attribute>
 373 ;;     <required-attribute>    :: (required? <boolean>)
 374 ;;     <single-char-attribute> :: (single-char <char>)
 375 ;;     <value-attribute>       :: (value #t)
 376 ;;                                (value #f)
 377 ;;                                (value optional)
 378 ;;     <predicate-attribute>   :: (predicate <1-ary-function>)
 379
 380 ;;     The procedure returns an alist of option names and values.  Each
 381 ;; option name is a symbol.  The option value will be '#t' if no value
 382 ;; was specified.  There is a special item in the returned alist with a
 383 ;; key of the empty list, (): the list of arguments that are not options
 384 ;; or option values.
 385 ;;     By default, options are not required, and option values are not
 386 ;; required.  By default, single character equivalents are not supported;
 387 ;; if you want to allow the user to use single character options, you need
 388 ;; to add a `single-char' clause to the option description."
 389   (let* ((specifications (map parse-option-spec option-desc-list))
 390          (pair (split-arg-list (cdr program-arguments)))
 391          (split-ls (expand-clumped-singles (car pair)))
 392          (non-split-ls (cdr pair))
 393          (found/etc (process-options specifications split-ls))
 394          (found (car found/etc))
 395          (rest-ls (append (cdr found/etc) non-split-ls)))
 396     (for-each (lambda (spec)
 397                 (let ((name (option-spec->name spec))
 398                       (val (option-spec->value-policy spec)))
 399                   (and (option-spec->required? spec)
 400                        (or (memq spec found)
 401                            (error "option must be specified:" name)))
 402                   (and (memq spec found)
 403                        (eq? #t (option-spec->value-policy spec))
 404                        (or val
 405                            (error "option must be specified with argument:"
 406                                   name)))
 407                   (let ((pred (option-spec->predicate spec)))
 408                     (and pred (pred name val)))))
 409               specifications)
 410     (cons (cons '() rest-ls)
 411           (let ((multi-count (map (lambda (desc)
 412                                     (cons (car desc) 0))
 413                                   option-desc-list)))
 414             (map (lambda (spec)
 415                    (let ((name (string->symbol (option-spec->name spec))))
 416                      (cons name
 417                            ;; handle multiple occurrances
 418                            (let ((maybe-ls (option-spec->value-policy spec)))
 419                              (if (list? maybe-ls)
 420                                  (let* ((look (assq name multi-count))
 421                                         (idx (cdr look))
 422                                         (val (list-ref maybe-ls idx)))
 423                                    (set-cdr! look (1+ idx)) ; ugh!
 424                                    val)
 425                                  maybe-ls)))))
 426                  found)))))
 427
 428 (define (option-ref options key default)
 429 ;;   "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
 430 ;; The value is either a string or `#t'."
 431   (or (assq-ref options key) default))
 432
 433 ;;; getopt-long.scm ends here