source: project/release/4/getopt-long/getopt-long.scm @ 15633

Last change on this file since 15633 was 15633, checked in by Ivan Raikov, 10 years ago

bug fixes in getopt-long

File size: 22.1 KB
Line 
1;;
2;; getopt-style command-line parser
3;;
4;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
5;;
6;; Ported to Chicken Scheme and extensively modified by Ivan Raikov.
7;;
8;; Copyright 2009 Ivan Raikov.
9;;
10;; Portions copyright (C) 1998, 2001, 2006 Free Software Foundation,
11;; Inc.
12;;
13;; This program is free software: you can redistribute it and/or
14;; modify it under the terms of the GNU Lesser General Public License
15;; as published by the Free Software Foundation, either version 3 of
16;; the License, or (at your option) any later version.
17;;
18;; This program is distributed in the hope that it will be useful, but
19;; WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
21;; General Public License for more details.
22;;
23;; A full copy of the Lesser GPL license can be found at
24;; <http://www.gnu.org/licenses/>.
25;;
26
27;;; Commentary:
28
29;;; This module implements command line option parsing, in the spirit
30;;; of the GNU C library function `getopt_long'.  Both long and short
31;;; options are supported.
32;;;
33;;; The theory is that people should be able to constrain the set of
34;;; options they want to process using a grammar, rather than some
35;;; arbitrary structure.  The grammar makes the option descriptions
36;;; easy to read.
37;;;
38;;; `getopt-long' is a procedure for parsing command-line arguments in
39;;; a manner consistent with GNU programs.
40;;;
41;;; `usage' is a procedure that prints help strings about the
42;;; command-line arguments defined in a grammar.
43
44;;; (getopt-long ARGS GRAMMAR) Parse the arguments ARGS according to
45;;; the argument list grammar GRAMMAR.
46;;;
47;;; ARGS should be a list of strings.  Its first element should be the
48;;; name of the program; subsequent elements should be the arguments
49;;; that were passed to the program on the command line.  The
50;;; `program-arguments' procedure returns a list of this form.
51;;;
52;;; GRAMMAR is a list of the form:
53;;; ((OPTION-NAME [DOCSTRING]
54;;;               (PROPERTY VALUE) ...) ...)
55;;;
56;;; Each OPTION-NAME should be a symbol.  `getopt-long' will accept a
57;;; command-line option named `--OPTION-NAME'.
58;;;
59;;  If DOCSTRING is provided, it must be a either string a string
60;;  containing a brief description of the option.
61;;;
62;;; Each option can have the following (PROPERTY VALUE) pairs:
63;;;
64;;;   (single-char CHAR) --- Accept `-CHAR' as a single-character
65;;;             equivalent to `--OPTION'.  This is how to specify traditional
66;;;             Unix-style flags.
67;;;
68;;;   (required? BOOL) --- If BOOL is true, the option is required.
69;;;             getopt-long will raise an error if it is not found in ARGS.
70;;;
71;;;   (value FLAG [(PROPERTY VALUE) ...])
72;;;             --- If FLAG is #t, the option requires a value; if
73;;;             it is #f, it does not;
74;;;             if it is of the form (REQUIRED name) then the option requires
75;;;             and the name is used by the usage procedure
76;;;             if it is of the form (OPTIONAL name) the option may
77;;;             appear with or without a (named) value.
78;;;             
79;;;             In addition, the following properties can be defined
80;;;             for a value:
81;;;
82;;;            (predicate FUNC) ---
83;;;
84;;;                  If the option accepts a value, then getopt will
85;;;                  apply FUNC to the value, and throw an exception
86;;;                  if it returns #f.  FUNC should be a procedure
87;;;                  which accepts a string and returns a boolean
88;;;                  value; you may need to use quasiquotes to get it
89;;;                  into GRAMMAR.
90;;;
91;;;            (transformer FUNC) ---
92;;;
93;;;                  If the option accepts a value, then getopt will
94;;;                  apply FUNC to the string provided on the command
95;;;                  line, and put the resulting value in the list of
96;;;                  parsed options returned by getopt-long.
97;;;
98;;; The (PROPERTY VALUE) pairs may occur in any order, but each
99;;; property may occur only once.  By default, options do not have
100;;; single-character equivalents, are not required, and do not take
101;;; values.
102;;;
103;;; In ARGS, single-character options may be combined, in the usual
104;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy").  If an option
105;;; accepts values, then it must be the last option in the
106;;; combination; the value is the next argument.  So, for example, using
107;;; the following grammar:
108;;;
109;;;      ((apples    (single-char #\a))
110;;;       (blimps    (single-char #\b) (value #t))
111;;;       (catalexis (single-char #\c) (value #t)))
112;;;
113;;; the following argument lists would be acceptable:
114;;;
115;;;    ("-a" "-b" "bang" "-c" "couth")     ("bang" and "couth" are the values
116;;;                                         for "blimps" and "catalexis")
117;;;    ("-ab" "bang" "-c" "couth")         (same)
118;;;    ("-ac" "couth" "-b" "bang")         (same)
119;;;    ("-abc" "couth" "bang")             (an error, since `-b' is not the
120;;;                                         last option in its combination)
121;;;
122;;; If an option's value is optional, then `getopt-long' decides
123;;; whether it has a value by looking at what follows it in ARGS.  If
124;;; the next element is does not appear to be an option itself, then
125;;; that element is the option's value.
126;;;
127;;; The value of a long option can appear as the next element in ARGS,
128;;; or it can follow the option name, separated by an `=' character.
129;;; Thus, using the same grammar as above, the following argument lists
130;;; are equivalent:
131;;;
132;;;   ("--apples" "Braeburn" "--blimps" "Goodyear")
133;;;   ("--apples=Braeburn" "--blimps" "Goodyear")
134;;;   ("--blimps" "Goodyear" "--apples=Braeburn")
135;;;
136;;; If the option "--" appears in ARGS, argument parsing stops there;
137;;; subsequent arguments are returned as ordinary arguments, even if
138;;; they resemble options.  So, in the argument list:
139;;;
140;;;         ("--apples" "Granny Smith" "--" "--blimp" "Goodyear")
141;;;
142;;; `getopt-long' will recognize the `apples' option as having the
143;;; value "Granny Smith", but it will not recognize the `blimp'
144;;; option; it will return the strings "--blimp" and "Goodyear" as
145;;; ordinary argument strings.
146;;;
147;;; The `getopt-long' function returns the parsed argument list as an
148;;; assocation list, mapping option names --- the symbols from GRAMMAR
149;;; --- onto their values, or #t if the option does not accept a value.
150;;; Unused options do not appear in the alist.
151;;;
152;;; All arguments that are not the value of any option are returned
153;;; as a list, associated with the empty list.
154;;;
155;;; `getopt-long' throws an exception if:
156;;; - it finds an unrecognized property in GRAMMAR
157;;; - the value of the `single-char' property is not a character,
158;;;   or a single-character string/symbol
159;;; - it finds an unrecognized option in ARGS
160;;; - a required option is omitted
161;;; - an option that requires an argument doesn't get one
162;;; - an option that doesn't accept an argument does get one (this can
163;;;   only happen using the long option `--opt=value' syntax)
164;;; - an option predicate fails
165;;;
166;;; For an example, see file tests/run.scm.
167
168
169
170(module getopt-long
171
172        (getopt-long width separator indent usage make-option-dispatch)
173
174        (import scheme chicken)
175       
176        (require-extension data-structures srfi-1 srfi-13 srfi-14 
177                           defstruct matchable )
178
179
180(define (lookup-def k lst . rest)
181  (let-optionals rest ((default #f))
182      (let ((kv (assoc k lst)))
183        (if (not kv) default
184            (match kv ((k v) v) (else (cdr kv)))))))
185
186(defstruct value-policy name predicate transformer
187  optional? default )
188
189(defstruct option-spec name value required? 
190  single-char docstring )
191
192;;
193;; We don't auto-format the left column (the option keys) based on the
194;; length of the longest option, but you can override it manually.
195;;
196(define width (make-parameter 25))
197
198;; The separator used between options.  Default: ", "
199
200(define separator (make-parameter ", "))
201(define indent (make-parameter 1))
202
203(define (spaces n)
204  (let loop ((ls '()) (n n))
205    (if (<= n 0)
206        (list->string ls)
207        (loop (cons #\space ls)
208              (- n 1)))))
209
210;; Join together option names in spec with commas, and append the
211;; argument type and name
212
213(define-record-printer (option-spec x out)
214  (let* ((name          (option-spec-name x))
215         (value-policy  (option-spec-value x))
216         (required?     (option-spec-required? x))
217         (single-char   (option-spec-single-char x))
218         (docstring     (option-spec-docstring x))
219         (long-option   (and (not (make-single-char name))
220                             (string-append "--" (->string name))))
221         (short-option  (or (and single-char 
222                                 (list->string (list #\- single-char)))
223                            (make-single-char name)))
224         (option-lst    (cond ((and short-option long-option)
225                               (list long-option (separator) short-option))
226                              (long-option
227                               (list long-option))
228                              (else (list short-option))))
229         (option-lst
230          (cond
231           (value-policy 
232            (if (value-policy-optional? value-policy) 
233                (cons* "]" (->string (value-policy-name value-policy) )
234                       "[" "=" option-lst)
235                (cons* (->string (value-policy-name value-policy))
236                       "=" 
237                       option-lst)))
238           (else        option-lst)))
239
240         (option-string (string-concatenate (reverse option-lst))))
241
242    (display
243     (string-append (spaces (indent))
244                    (string-pad-right option-string (width))
245                    docstring
246                    "\n")
247     out)))
248
249;; Generate a formatted list of options from OPTION-LIST, and return a
250;; string suitable for embedding into help text.  The single string
251;; consists of multiple lines, with a newline at the end of each line.
252;; Thus, a typical use would be (print (usage opts)).
253(define (usage opts) 
254  (let ((specs (map parse-option-spec opts)))
255    (apply string-append (map ->string specs))))
256
257(define update-option-spec
258  (lambda (x . key/values)
259    (apply
260     (lambda (#!key
261              (name           (option-spec-name x)) 
262              (required?      (option-spec-required? x))
263              (single-char    (option-spec-single-char x))
264              (value          (option-spec-value x))
265              (docstring      (option-spec-docstring x))
266              )
267          (make-option-spec 
268           name:        name
269           required?:   required?
270           single-char: single-char
271           value:       value
272           docstring:   docstring
273           ))
274     key/values)))
275
276(define (make-predicate pred)
277  (lambda (name val)
278    (or (not val)
279        (pred val)
280        (error "option predicate failed:" name))))
281
282(define (make-single-char x)
283  (let ((lst (string->list (->string x))))
284    (and (null? (cdr lst))
285         (car lst))))
286   
287
288(define (parse-option-spec desc)
289 
290  (let* ((name         (car desc))
291         (single-char  (make-single-char name))
292         (spec
293          (make-option-spec 
294           name:        name
295           required?:   #f
296           single-char: single-char
297           value:       #f
298           docstring:   ""
299           )))
300
301    (fold
302     (lambda (desc-elem spec)
303       (cond ((string? desc-elem)
304              (update-option-spec spec docstring: desc-elem))
305
306             (else
307              (let ((given (lambda () (cdr desc-elem))))
308
309                (case (car desc-elem)
310                 
311                  ((required?)
312                   (update-option-spec spec required?: (car (given))))
313                 
314                  ((value)
315                   (let ((value-policy
316                          (match (given)
317
318                                 ((((and flag (or 'required 'optional))
319                                    (and name (or (? symbol?) (? string?)))) . rst)
320                                  (let ((predicate 
321                                         (cond ((lookup-def 'predicate rst) =>
322                                                make-predicate)
323                                               (else
324                                                (lambda x (identity x)))))
325
326                                        (transformer 
327                                         (or (lookup-def 'transformer rst)
328                                             identity))
329
330                                        (default (lookup-def 'default rst))
331                                        )
332
333                                    (make-value-policy 
334                                     name: name
335                                     predicate: predicate
336                                     transformer: transformer
337                                     optional?: (equal? flag 'optional)
338                                     default:  (and default 
339                                                    (->string default))
340                                     
341                                     )))
342
343                                 ((#t) (make-value-policy 
344                                      name: 'ARG
345                                      predicate: (lambda x (identity x))
346                                      transformer: identity
347                                      optional?: #f
348                                      default: #f))
349
350                                 ((#f) #f)
351
352                                 (else (error "invalid value specification "
353                                              (given)))
354
355                                 )))
356                     (update-option-spec spec value: value-policy)))
357                 
358                  ((single-char)
359                   (cond
360                    ((make-single-char (car (given))) =>
361                     (lambda (c)
362                       (update-option-spec spec single-char: c)))
363                    (else
364                     (error "`single-char' value must be a single character, string, or symbol"))))
365
366                  (else
367                   (error "invalid getopt-long option property:"
368                          (car desc-elem))))))))
369     spec (cdr desc))
370    ))
371
372
373
374(define (split-argument-list argument-list)
375  ;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS).
376  ;; Discard the "--".  If no "--" is found, AFTER-LS is empty.
377  (let loop ((yes '()) (no argument-list))
378    (cond ((null? no)               (cons (reverse yes) no))
379          ((string=? "--" (car no)) (cons (reverse yes) (cdr no)))
380          (else (loop (cons (car no) yes) (cdr no))))))
381
382
383(define (check-long-option str)
384  (and (> (string-length str) 1)
385       (string=? (substring str 0 2) "--")))
386
387(define (check-short-option str)
388  (and (positive? (string-length str))
389       (string=? (substring str 0 1) "-")))
390
391(define long-option-name-cs 
392  (char-set-union char-set:letter
393                  (char-set #\-)))
394
395(define (long-option-name lst)
396  (let loop ((lst lst)  (ax (list)))
397    (cond ((null? lst)  (list (list->string (reverse ax)) lst))
398          ((and (char? (car lst))
399                (char-set-contains? long-option-name-cs 
400                                   (car lst)) 
401                (car lst)) =>
402                (lambda (c)
403                  (loop (cdr lst) (cons c ax))))
404
405          ((char=? (car lst) #\=)
406           (list (list->string (reverse ax)) (cdr lst)))
407
408          (else (error 'long-option-name 
409                       "invalid list " lst)))))
410
411(define long-option-value-cs 
412  (char-set-union char-set:letter+digit 
413                  char-set:punctuation))
414
415(define (long-option-value lst)
416  (if (null? lst) (list #f lst)
417      (let loop ((lst lst)  (ax (list)))
418        (cond ((null? lst) 
419               (pair? ax) (list (list->string (reverse ax)) lst))
420             
421              ((and (char? (car lst))
422                    (char-set-contains? long-option-value-cs 
423                                        (car lst)) 
424                    (car lst)) =>
425                    (lambda (c)
426                      (loop (cdr lst) (cons c ax))))
427             
428              (else (error 'long-option-value 
429                           "invalid list " lst))))))
430
431
432(define (long-option? specs a next)
433  (let ((l (string->list a)))
434    (match l
435           ((#\- #\-  . rst)
436            (match-let* (((n nrst)  (long-option-name rst))
437                         ((v ())    (long-option-value nrst))
438                         ((next v)
439                          (begin
440                            (or (and v (list next v))
441                                (and (not (check-long-option (car next)))
442                                     (not (check-short-option (car next)))
443                                     (list (cdr next) (car next)))
444                                (list next #f)))))
445
446              (cond ((alist-ref (string->symbol n) (car specs)) =>
447                     (lambda (spec)
448                       (cond
449
450                        ((and v (option-spec-value spec)) =>
451                         (lambda (value-policy)
452                           (or
453                            (and ((or (value-policy-predicate value-policy)
454                                      (lambda x (identity x))) n v)
455                                 (let ((transformer
456                                        (or (value-policy-transformer value-policy)
457                                            identity)))
458                                 (list next (cons (option-spec-name spec) (transformer v)))))
459                            (error 'long-option? 
460                                   "predicate error on option value " n))))
461
462                        ((and v (not (option-spec-value spec)))
463                         (error 'long-option? 
464                                "superfluous argument given to option " n))
465                       
466                        ((and (not v) (option-spec-value spec))
467                         (error 'long-option? "option requires value " n))
468                       
469                        ((and (not v) (option-spec-value spec)
470                              (value-policy-optional? 
471                               (option-spec-value spec)))
472                         (list next (cons (option-spec-name spec) #t)))
473                       
474                        (else
475                         (list next (cons (option-spec-name spec) #t)))
476                             
477                       )))
478                    (else
479                     (error 'long-option? "unknown option " n)))))
480           (else #f))))
481
482
483(define short-option-name-cs 
484  char-set:letter)
485
486(define (short-option-names lst)
487  (if (null? lst) (list #f lst)
488      (let loop ((lst lst)  (ax (list)))
489        (cond ((null? lst)  (list ax lst))
490
491              ((and (char? (car lst))
492                    (char-set-contains? short-option-name-cs 
493                                        (car lst)) 
494                    (car lst)) =>
495                    (lambda (c)
496                      (loop (cdr lst) (cons c ax))))
497             
498              (else (error 'long-option-name 
499                           "invalid list " lst))))))
500
501(define (short-options? specs a next)
502  (let ((l (string->list a)))
503    (match l
504           ((#\-  . rst)
505            (match-let ((((n1 . ns) ())  (short-option-names rst)))
506              (match-let
507               ;; special case: check if the last single-letter option
508               ;; has an argument
509               (((next opt1)
510                 (cond
511                  ((alist-ref n1 (cadr specs) ) =>
512                   (lambda (spec)
513                     (let ((name (option-spec-name spec)))
514
515                       (cond
516                        ((option-spec-value spec) =>
517                         (lambda (value-policy)
518                           (let ((v (and (pair? next)
519                                         (not (check-long-option (car next) ))
520                                         (not (check-short-option (car next) ))
521                                         (car next))))
522                             (if (not v) 
523                                 (error 'short-options? 
524                                        "option requires value: " name))
525                             
526                             (or
527                              (and ((or (value-policy-predicate value-policy) 
528                                        (lambda x (identity x))) name v)
529                                   (let ((transformer
530                                          (or (value-policy-transformer value-policy) 
531                                              identity)))
532                                     (list (cdr next) (cons name (transformer v)))))
533                              (error 'short-options? 
534                                     "predicate error on option value " 
535                                     name)))))
536                                 
537                        (else
538                         (list next (cons name #t)))))))
539                  (else
540                   (error 'short-options? "unknown option " n1)))))
541               (list next 
542                     (cons opt1 
543                           (map (lambda (n)
544                                  (cond
545                                   ((alist-ref n (cadr specs) ) =>
546                                    (lambda (spec)
547                                      (cond
548                                       ((option-spec-value spec)
549                                        (error 'short-options?
550                                               "option requires value: " n))
551                                       
552                                       (else
553                                        (cons (option-spec-name spec) #t)))))
554                                   
555                                   (else
556                                    (error 'short-options? 
557                                           "unknown option " n))))
558                                ns)))))
559              )
560           (else #f))))
561           
562 
563 
564
565(define (process-options specs argument-ls)
566  ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
567  ;; FOUND is an unordered list of option specs for found options, while ETC
568  ;; is an order-maintained list of elements in ARGUMENT-LS that are neither
569  ;; options nor their values.
570  (let loop ((ls argument-ls)  (found (list)) (etc (list)))
571
572    (if (null? ls) (cons found (reverse etc))
573
574        (let ((arg (car ls)) (rest (cdr ls)))
575          (cond ((long-option? specs arg rest) =>
576                 (lambda (kont)
577                   (loop (car kont) (cons (cadr kont) found) etc)))
578               
579                ((short-options? specs arg rest) =>
580                 (lambda (kont)
581                   (loop (car kont) (append (cadr kont) found) etc)))
582
583                (else
584                 (loop (cdr ls) found (cons (car ls) etc))))))))
585                                 
586
587
588(define (getopt-long program-arguments option-desc-list)
589;;   Process options, handling both long and short options, similar to
590;; the glibc function 'getopt_long'.  PROGRAM-ARGUMENTS should be a value
591;; similar to what (program-arguments) returns.  OPTION-DESC-LIST is a
592;; list of option descriptions.  Each option description must satisfy the
593;; following grammar:
594;;
595;;     <option-spec>           :: (<name> . <attribute-ls>)
596;;     <attribute-ls>          :: (<attribute> . <attribute-ls>)
597;;                                | ()
598;;     <attribute>             :: <required-attribute>
599;;                                | <arg-required-attribute>
600;;                                | <single-char-attribute>
601;;                                | <value-attribute>
602;;     <required-attribute>    :: (required? <boolean>)
603;;     <single-char-attribute> :: (single-char <char>)
604;;     <value-attribute>       :: (value #t)
605;;                                (value #f)
606;;                                (value (required <name>))
607;;                                (value (optional <name>))
608;;                                (<value-attribute>
609;;                                 <predicate-attribute>)
610;;     <predicate-attribute>   :: (predicate <1-ary-function>)
611;;
612;;     The procedure returns an alist of option names and values.
613;; Each option name is a symbol.  The option value will be '#t' if no
614;; value was specified.  There is a special item in the returned alist
615;; with a key @: the list of arguments that are not options or option
616;; values.
617;;
618;;     By default, options are not required, and option values are not
619;; required.  By default, single character equivalents are not
620;; supported; if you want to allow the user to use single character
621;; options, you need to add a `single-char' clause to the option
622;; description.
623
624  (let* ((specifications (map parse-option-spec option-desc-list))
625         (spec-long      (map (lambda (spec)
626                                (cons (option-spec-name spec) spec))
627                              specifications))
628         (spec-short     (filter-map
629                          (lambda (spec)
630                            (and (option-spec-single-char spec)
631                                 (cons (option-spec-single-char spec) 
632                                       spec)))
633                          specifications))
634         (pair           (split-argument-list program-arguments))
635         (split-ls       (car pair))
636         (non-split-ls   (cdr pair))
637         (found/etc      (process-options
638                          (list spec-long spec-short) split-ls))
639         (found          (car found/etc))
640         (rest-ls        (append (cdr found/etc) non-split-ls)))
641    (for-each (lambda (spec)
642                (let ((name (option-spec-name spec)))
643
644                  (and (option-spec-required? spec)
645                       (or (assoc name found )
646                           (error "option must be specified:" name)))
647
648                  (and (assoc name found)
649                       (and (option-spec-value spec)
650                            (not (value-policy-optional?
651                                  (option-spec-value spec))))
652                       (or (cdr (assoc name found))
653                           (error "option must be specified with argument:"
654                                  name)))))
655              specifications)
656
657    (cons (cons '@ rest-ls) found)))
658
659(define (make-option-dispatch opts options-desc-list)
660  (let* ((specifications (map parse-option-spec options-desc-list))
661         (defaults
662           (filter-map
663            (lambda (spec) 
664              (let* ((name (option-spec-name spec))
665                     (value-policy (option-spec-value spec))
666                     (default (and value-policy 
667                                   (value-policy-default value-policy)))
668                     )
669                (cond ((and value-policy 
670                            (value-policy-predicate value-policy)) =>
671                            (lambda (pred)
672                              (or (pred name default) 
673                                  (error 'make-option-dispatch
674                                         "predicate error in default value: "
675                                         default)))))
676                (let ((transformer
677                       (or (and value-policy 
678                                (value-policy-transformer value-policy))
679                           identity)))
680                  (and default (list name (transformer default))))
681                ))
682            specifications)))
683
684    (lambda (name)
685      (case name 
686        ((@)  (alist-ref '@ opts))
687        (else
688         (let ((v (or (lookup-def name (cdr opts))
689                      (lookup-def name defaults))))
690           v)
691         )))
692    ))
693           
694         
695
696)
697;;; getopt-long.scm ends here
Note: See TracBrowser for help on using the repository browser.