mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-19 10:10:23 +02:00
Rewrite.
Touch up docstrings. Augment commentary.
This commit is contained in:
Thien-Thi Nguyen
parent
24bf1e2f6b
commit
b817e7ef1c
1 changed files with 212 additions and 530 deletions
|
|
@ -1,6 +1,3 @@
|
||||||
;;; Author: Russ McManus
|
|
||||||
;;; $Id: getopt-long.scm,v 1.4.2.1 2001-08-02 10:52:37 ttn Exp $
|
|
||||||
;;;
|
|
||||||
;;; Copyright (C) 1998, 2001 Free Software Foundation, Inc.
|
;;; Copyright (C) 1998, 2001 Free Software Foundation, Inc.
|
||||||
;;;
|
;;;
|
||||||
;;; This program is free software; you can redistribute it and/or modify
|
;;; This program is free software; you can redistribute it and/or modify
|
||||||
|
|
@ -41,19 +38,21 @@
|
||||||
;;; whether to permit this exception to apply to your modifications.
|
;;; whether to permit this exception to apply to your modifications.
|
||||||
;;; If you do not wish that, delete this exception notice.
|
;;; If you do not wish that, delete this exception notice.
|
||||||
|
|
||||||
|
;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
|
|
||||||
;;; This module implements some complex command line option parsing, in
|
;;; This module implements some complex command line option parsing, in
|
||||||
;;; the spirit of the GNU C library function 'getopt_long'. Both long
|
;;; the spirit of the GNU C library function `getopt_long'. Both long
|
||||||
;;; and short options are supported.
|
;;; and short options are supported.
|
||||||
;;;
|
;;;
|
||||||
;;; The theory is that people should be able to constrain the set of
|
;;; The theory is that people should be able to constrain the set of
|
||||||
;;; options they want to process using a grammar, rather than some arbitrary
|
;;; options they want to process using a grammar, rather than some arbitrary
|
||||||
;;; structure. The grammar makes the option descriptions easy to read.
|
;;; structure. The grammar makes the option descriptions easy to read.
|
||||||
;;;
|
;;;
|
||||||
|
;;; `getopt-long' is a procedure for parsing command-line arguments in a
|
||||||
;;; getopt-long is a function for parsing command-line arguments in a
|
;;; manner consistent with other GNU programs. `option-ref' is a procedure
|
||||||
;;; manner consistent with other GNU programs.
|
;;; that facilitates processing of the `getopt-long' return value.
|
||||||
|
|
||||||
;;; (getopt-long ARGS GRAMMAR)
|
;;; (getopt-long ARGS GRAMMAR)
|
||||||
;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR.
|
;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR.
|
||||||
|
|
@ -109,8 +108,8 @@
|
||||||
;;;
|
;;;
|
||||||
;;; If an option's value is optional, then `getopt-long' decides
|
;;; If an option's value is optional, then `getopt-long' decides
|
||||||
;;; whether it has a value by looking at what follows it in ARGS. If
|
;;; whether it has a value by looking at what follows it in ARGS. If
|
||||||
;;; the next element is a string, and it does not appear to be an
|
;;; the next element is does not appear to be an option itself, then
|
||||||
;;; option itself, then that string is the option's value.
|
;;; that element is the option's value.
|
||||||
;;;
|
;;;
|
||||||
;;; The value of a long option can appear as the next element in ARGS,
|
;;; The value of a long option can appear as the next element in ARGS,
|
||||||
;;; or it can follow the option name, separated by an `=' character.
|
;;; or it can follow the option name, separated by an `=' character.
|
||||||
|
|
@ -138,6 +137,8 @@
|
||||||
;;; as a list, associated with the empty list.
|
;;; as a list, associated with the empty list.
|
||||||
;;;
|
;;;
|
||||||
;;; `getopt-long' throws an exception if:
|
;;; `getopt-long' throws an exception if:
|
||||||
|
;;; - it finds an unrecognized property in GRAMMAR
|
||||||
|
;;; - the value of the `single-char' property is not a character
|
||||||
;;; - it finds an unrecognized option in ARGS
|
;;; - it finds an unrecognized option in ARGS
|
||||||
;;; - a required option is omitted
|
;;; - a required option is omitted
|
||||||
;;; - an option that requires an argument doesn't get one
|
;;; - an option that requires an argument doesn't get one
|
||||||
|
|
@ -168,515 +169,200 @@
|
||||||
;;; (lockfile-dir . "/tmp")
|
;;; (lockfile-dir . "/tmp")
|
||||||
;;; (verbose . #t))
|
;;; (verbose . #t))
|
||||||
|
|
||||||
|
;;; (option-ref OPTIONS KEY DEFAULT)
|
||||||
|
;;; Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not
|
||||||
|
;;; found. The value is either a string or `#t'.
|
||||||
|
;;;
|
||||||
|
;;; For example, using the `getopt-long' return value from above:
|
||||||
|
;;;
|
||||||
|
;;; (option-ref (getopt-long ...) 'x-includes 42) => "/usr/include"
|
||||||
|
;;; (option-ref (getopt-long ...) 'not-a-key! 31) => 31
|
||||||
|
|
||||||
;;; Code:
|
;;; Code:
|
||||||
|
|
||||||
(define-module (ice-9 getopt-long)
|
(define-module (ice-9 getopt-long)
|
||||||
:use-module (ice-9 common-list))
|
:use-module ((ice-9 common-list) :select (some remove-if-not))
|
||||||
|
:export (getopt-long option-ref))
|
||||||
|
|
||||||
|
(define option-spec-fields '(name
|
||||||
;;; The code on this page was expanded by hand using the following code:
|
value
|
||||||
;;; (pretty-print
|
required?
|
||||||
;;; (macroexpand
|
single-char
|
||||||
;;; '(define-record option-spec
|
predicate
|
||||||
;;; (name
|
value-policy))
|
||||||
;;; value
|
|
||||||
;;; value-required?
|
|
||||||
;;; single-char
|
|
||||||
;;; predicate-ls
|
|
||||||
;;; parse-ls))))
|
|
||||||
;;;
|
|
||||||
;;; This avoids the need to load slib for records.
|
|
||||||
(define slib:error error)
|
|
||||||
(begin (define
|
|
||||||
option-spec->name
|
|
||||||
(lambda
|
|
||||||
(obj)
|
|
||||||
(if (option-spec? obj)
|
|
||||||
(vector-ref obj 1)
|
|
||||||
(slib:error
|
|
||||||
(quote option-spec->name)
|
|
||||||
": bad record"
|
|
||||||
obj))))
|
|
||||||
(define
|
|
||||||
option-spec->value
|
|
||||||
(lambda
|
|
||||||
(obj)
|
|
||||||
(if (option-spec? obj)
|
|
||||||
(vector-ref obj 2)
|
|
||||||
(slib:error
|
|
||||||
(quote option-spec->value)
|
|
||||||
": bad record"
|
|
||||||
obj))))
|
|
||||||
(define
|
|
||||||
option-spec->value-required?
|
|
||||||
(lambda
|
|
||||||
(obj)
|
|
||||||
(if (option-spec? obj)
|
|
||||||
(vector-ref obj 3)
|
|
||||||
(slib:error
|
|
||||||
(quote option-spec->value-required?)
|
|
||||||
": bad record"
|
|
||||||
obj))))
|
|
||||||
(define
|
|
||||||
option-spec->single-char
|
|
||||||
(lambda
|
|
||||||
(obj)
|
|
||||||
(if (option-spec? obj)
|
|
||||||
(vector-ref obj 4)
|
|
||||||
(slib:error
|
|
||||||
(quote option-spec->single-char)
|
|
||||||
": bad record"
|
|
||||||
obj))))
|
|
||||||
(define
|
|
||||||
option-spec->predicate-ls
|
|
||||||
(lambda
|
|
||||||
(obj)
|
|
||||||
(if (option-spec? obj)
|
|
||||||
(vector-ref obj 5)
|
|
||||||
(slib:error
|
|
||||||
(quote option-spec->predicate-ls)
|
|
||||||
": bad record"
|
|
||||||
obj))))
|
|
||||||
(define
|
|
||||||
option-spec->parse-ls
|
|
||||||
(lambda
|
|
||||||
(obj)
|
|
||||||
(if (option-spec? obj)
|
|
||||||
(vector-ref obj 6)
|
|
||||||
(slib:error
|
|
||||||
(quote option-spec->parse-ls)
|
|
||||||
": bad record"
|
|
||||||
obj))))
|
|
||||||
(define
|
|
||||||
set-option-spec-name!
|
|
||||||
(lambda
|
|
||||||
(obj val)
|
|
||||||
(if (option-spec? obj)
|
|
||||||
(vector-set! obj 1 val)
|
|
||||||
(slib:error
|
|
||||||
(quote set-option-spec-name!)
|
|
||||||
": bad record"
|
|
||||||
obj))))
|
|
||||||
(define
|
|
||||||
set-option-spec-value!
|
|
||||||
(lambda
|
|
||||||
(obj val)
|
|
||||||
(if (option-spec? obj)
|
|
||||||
(vector-set! obj 2 val)
|
|
||||||
(slib:error
|
|
||||||
(quote set-option-spec-value!)
|
|
||||||
": bad record"
|
|
||||||
obj))))
|
|
||||||
(define
|
|
||||||
set-option-spec-value-required?!
|
|
||||||
(lambda
|
|
||||||
(obj val)
|
|
||||||
(if (option-spec? obj)
|
|
||||||
(vector-set! obj 3 val)
|
|
||||||
(slib:error
|
|
||||||
(quote set-option-spec-value-required?!)
|
|
||||||
": bad record"
|
|
||||||
obj))))
|
|
||||||
(define
|
|
||||||
set-option-spec-single-char!
|
|
||||||
(lambda
|
|
||||||
(obj val)
|
|
||||||
(if (option-spec? obj)
|
|
||||||
(vector-set! obj 4 val)
|
|
||||||
(slib:error
|
|
||||||
(quote set-option-spec-single-char!)
|
|
||||||
": bad record"
|
|
||||||
obj))))
|
|
||||||
(define
|
|
||||||
set-option-spec-predicate-ls!
|
|
||||||
(lambda
|
|
||||||
(obj val)
|
|
||||||
(if (option-spec? obj)
|
|
||||||
(vector-set! obj 5 val)
|
|
||||||
(slib:error
|
|
||||||
(quote set-option-spec-predicate-ls!)
|
|
||||||
": bad record"
|
|
||||||
obj))))
|
|
||||||
(define
|
|
||||||
set-option-spec-parse-ls!
|
|
||||||
(lambda
|
|
||||||
(obj val)
|
|
||||||
(if (option-spec? obj)
|
|
||||||
(vector-set! obj 6 val)
|
|
||||||
(slib:error
|
|
||||||
(quote set-option-spec-parse-ls!)
|
|
||||||
": bad record"
|
|
||||||
obj))))
|
|
||||||
(define
|
|
||||||
option-spec?
|
|
||||||
(lambda
|
|
||||||
(obj)
|
|
||||||
(and (vector? obj)
|
|
||||||
(= (vector-length obj) 7)
|
|
||||||
(eq? (vector-ref obj 0) (quote option-spec)))))
|
|
||||||
(define
|
|
||||||
make-option-spec
|
|
||||||
(lambda
|
|
||||||
(option-spec->name
|
|
||||||
option-spec->value
|
|
||||||
option-spec->value-required?
|
|
||||||
option-spec->single-char
|
|
||||||
option-spec->predicate-ls
|
|
||||||
option-spec->parse-ls)
|
|
||||||
(vector
|
|
||||||
(quote option-spec)
|
|
||||||
option-spec->name
|
|
||||||
option-spec->value
|
|
||||||
option-spec->value-required?
|
|
||||||
option-spec->single-char
|
|
||||||
option-spec->predicate-ls
|
|
||||||
option-spec->parse-ls))))
|
|
||||||
|
|
||||||
|
(define option-spec (make-record-type 'option-spec option-spec-fields))
|
||||||
;;;
|
(define make-option-spec (record-constructor option-spec option-spec-fields))
|
||||||
;;; parse functions go on this page.
|
|
||||||
;;;
|
|
||||||
(define make-user-predicate
|
|
||||||
(lambda (pred)
|
|
||||||
(lambda (spec)
|
|
||||||
(let ((val (option-spec->value spec)))
|
|
||||||
(if (and val
|
|
||||||
(pred val)) #t
|
|
||||||
(error "option predicate failed:" (option-spec->name spec)))))))
|
|
||||||
|
|
||||||
(define make-not-allowed-value-fn
|
(define (define-one-option-spec-field-accessor field)
|
||||||
(lambda ()
|
`(define ,(symbol-append 'option-spec-> field) ;;; name slib-compat
|
||||||
(lambda (spec)
|
(record-accessor option-spec ',field)))
|
||||||
(let ((val (option-spec->value spec)))
|
|
||||||
(if (not (or (eq? val #t)
|
|
||||||
(eq? val #f)))
|
|
||||||
(let ((name (option-spec->name spec)))
|
|
||||||
(error "option does not support argument:" name)))))))
|
|
||||||
|
|
||||||
(define make-option-required-predicate
|
(define (define-one-option-spec-field-modifier field)
|
||||||
(lambda ()
|
`(define ,(symbol-append 'set-option-spec- field '!) ;;; name slib-compat
|
||||||
(lambda (spec)
|
(record-modifier option-spec ',field)))
|
||||||
(let ((val (option-spec->value spec)))
|
|
||||||
(if (not val)
|
|
||||||
(let ((name (option-spec->name spec)))
|
|
||||||
(error "option must be specified:" name)))))))
|
|
||||||
|
|
||||||
(define make-option-value-predicate
|
(defmacro define-all-option-spec-accessors/modifiers ()
|
||||||
(lambda (predicate)
|
`(begin
|
||||||
(lambda (spec)
|
,@(map define-one-option-spec-field-accessor option-spec-fields)
|
||||||
(let ((val (option-spec->value spec)))
|
,@(map define-one-option-spec-field-modifier option-spec-fields)))
|
||||||
(if (not (predicate val))
|
|
||||||
(let ((name (option-spec->name spec)))
|
|
||||||
(error "Bad option value:" name val)))))))
|
|
||||||
|
|
||||||
(define make-required-value-fn
|
(define-all-option-spec-accessors/modifiers)
|
||||||
(lambda ()
|
|
||||||
(lambda (spec)
|
|
||||||
(let ((val (option-spec->value spec)))
|
|
||||||
(if (eq? val #t)
|
|
||||||
(let ((name (option-spec->name spec)))
|
|
||||||
(error "option must be specified with argument:" name)))))))
|
|
||||||
|
|
||||||
(define single-char-value?
|
(define make-option-spec
|
||||||
(lambda (val)
|
(let ((ctor (record-constructor option-spec '(name))))
|
||||||
(char? val)))
|
(lambda (name)
|
||||||
|
(ctor name))))
|
||||||
|
|
||||||
(define (parse-option-spec desc)
|
(define (parse-option-spec desc)
|
||||||
(letrec ((parse-iter
|
(let ((spec (make-option-spec (symbol->string (car desc)))))
|
||||||
(lambda (spec)
|
(for-each (lambda (desc-elem)
|
||||||
(let ((parse-ls (option-spec->parse-ls spec)))
|
(let ((given (lambda () (cadr desc-elem))))
|
||||||
(if (null? parse-ls)
|
(case (car desc-elem)
|
||||||
spec
|
((required?)
|
||||||
(let ((ls (car parse-ls)))
|
(set-option-spec-required?! spec (given)))
|
||||||
(if (or (not (list? ls))
|
((value)
|
||||||
(not (= (length ls) 2)))
|
(set-option-spec-value-policy! spec (given)))
|
||||||
(error "Bad option specification:" ls))
|
((single-char)
|
||||||
(let ((key (car ls))
|
(or (char? (given))
|
||||||
(val (cadr ls)))
|
(error "`single-char' value must be a char!"))
|
||||||
(cond ((and (eq? key 'required?) val)
|
(set-option-spec-single-char! spec (given)))
|
||||||
;; required values implemented as a predicate
|
((predicate)
|
||||||
(parse-iter
|
(set-option-spec-predicate!
|
||||||
(make-option-spec
|
spec ((lambda (pred)
|
||||||
(option-spec->name spec)
|
(lambda (name val)
|
||||||
(option-spec->value spec)
|
(or (not val)
|
||||||
(option-spec->value-required? spec)
|
(pred val)
|
||||||
(option-spec->single-char spec)
|
(error "option predicate failed:" name))))
|
||||||
(cons (make-option-required-predicate)
|
(given))))
|
||||||
(option-spec->predicate-ls spec))
|
(else
|
||||||
(cdr parse-ls))))
|
(error "invalid getopt-long option property:"
|
||||||
;; if value not required, don't add predicate,
|
(car desc-elem))))))
|
||||||
((eq? key 'required?)
|
(cdr desc))
|
||||||
(parse-iter
|
spec))
|
||||||
(make-option-spec
|
|
||||||
(option-spec->name spec)
|
|
||||||
(option-spec->value spec)
|
|
||||||
(option-spec->value-required? spec)
|
|
||||||
(option-spec->single-char spec)
|
|
||||||
(option-spec->predicate-ls spec)
|
|
||||||
(cdr parse-ls))))
|
|
||||||
;; handle value specification
|
|
||||||
((eq? key 'value)
|
|
||||||
(cond ((eq? val #t)
|
|
||||||
;; when value is required, add a
|
|
||||||
;; predicate to that effect and record
|
|
||||||
;; the fact in value-required? field.
|
|
||||||
(parse-iter
|
|
||||||
(make-option-spec
|
|
||||||
(option-spec->name spec)
|
|
||||||
(option-spec->value spec)
|
|
||||||
#t
|
|
||||||
(option-spec->single-char spec)
|
|
||||||
(cons (make-required-value-fn)
|
|
||||||
(option-spec->predicate-ls spec))
|
|
||||||
(cdr parse-ls))))
|
|
||||||
((eq? val #f)
|
|
||||||
;; when the value is not allowed, add a
|
|
||||||
;; predicate to that effect. one can
|
|
||||||
;; detect that a value is not supplied
|
|
||||||
;; by checking the option value against
|
|
||||||
;; #f.
|
|
||||||
(parse-iter
|
|
||||||
(make-option-spec
|
|
||||||
(option-spec->name spec)
|
|
||||||
(option-spec->value spec)
|
|
||||||
#f
|
|
||||||
(option-spec->single-char spec)
|
|
||||||
(cons (make-not-allowed-value-fn)
|
|
||||||
(option-spec->predicate-ls spec))
|
|
||||||
(cdr parse-ls))))
|
|
||||||
((eq? val 'optional)
|
|
||||||
;; for optional values, don't add a
|
|
||||||
;; predicate. do, however put the value
|
|
||||||
;; 'optional in the value-required?
|
|
||||||
;; field. this setting checks whether
|
|
||||||
;; optional values are 'greedy'. set to
|
|
||||||
;; #f to make optional value clauses
|
|
||||||
;; 'non-greedy'.
|
|
||||||
(parse-iter
|
|
||||||
(make-option-spec
|
|
||||||
(option-spec->name spec)
|
|
||||||
(option-spec->value spec)
|
|
||||||
'optional
|
|
||||||
(option-spec->single-char spec)
|
|
||||||
(option-spec->predicate-ls spec)
|
|
||||||
(cdr parse-ls))))
|
|
||||||
(#t
|
|
||||||
;; error case
|
|
||||||
(error "Bad value specification for option:"
|
|
||||||
(cons key val)))))
|
|
||||||
;; specify single char defined for this option.
|
|
||||||
((eq? key 'single-char)
|
|
||||||
(if (not (single-char-value? val))
|
|
||||||
(error "Not a single-char-value:"
|
|
||||||
val " for option:" key)
|
|
||||||
(parse-iter
|
|
||||||
(make-option-spec
|
|
||||||
(option-spec->name spec)
|
|
||||||
(option-spec->value spec)
|
|
||||||
(option-spec->value-required? spec)
|
|
||||||
val
|
|
||||||
(option-spec->predicate-ls spec)
|
|
||||||
(cdr parse-ls)))))
|
|
||||||
((eq? key 'predicate)
|
|
||||||
(if (procedure? val)
|
|
||||||
(parse-iter
|
|
||||||
(make-option-spec
|
|
||||||
(option-spec->name spec)
|
|
||||||
(option-spec->value spec)
|
|
||||||
(option-spec->value-required? spec)
|
|
||||||
(option-spec->single-char spec)
|
|
||||||
(cons (make-user-predicate val)
|
|
||||||
(option-spec->predicate-ls spec))
|
|
||||||
(cdr parse-ls)))
|
|
||||||
(error "Bad predicate specified for option:"
|
|
||||||
(cons key val))))))))))))
|
|
||||||
(if (or (not (pair? desc))
|
|
||||||
(string? (car desc)))
|
|
||||||
(error "Bad option specification:" desc))
|
|
||||||
(parse-iter (make-option-spec (car desc)
|
|
||||||
#f
|
|
||||||
#f
|
|
||||||
#f
|
|
||||||
'()
|
|
||||||
(cdr desc)))))
|
|
||||||
|
|
||||||
|
|
||||||
;;;
|
|
||||||
;;;
|
|
||||||
;;;
|
|
||||||
(define (split-arg-list argument-list)
|
(define (split-arg-list argument-list)
|
||||||
"Given an ARGUMENT-LIST, decide which part to process for options.
|
;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS).
|
||||||
Everything before an arg of \"--\" is fair game, everything after it
|
;; Discard the "--". If no "--" is found, AFTER-LS is empty.
|
||||||
should not be processed. The \"--\" is discarded. A cons pair is
|
(let loop ((yes '()) (no argument-list))
|
||||||
returned whose car is the list to process for options, and whose cdr
|
(cond ((null? no) (cons (reverse yes) no))
|
||||||
is the list to not process."
|
((string=? "--" (car no)) (cons (reverse yes) (cdr no)))
|
||||||
(let loop ((process-ls '())
|
(else (loop (cons (car no) yes) (cdr no))))))
|
||||||
(not-process-ls argument-list))
|
|
||||||
(cond ((null? not-process-ls)
|
|
||||||
(cons (reverse process-ls) '()))
|
|
||||||
((string=? "--" (car not-process-ls))
|
|
||||||
(cons (reverse process-ls) (cdr not-process-ls)))
|
|
||||||
(#t
|
|
||||||
(loop (cons (car not-process-ls) process-ls)
|
|
||||||
(cdr not-process-ls))))))
|
|
||||||
|
|
||||||
(define short-opt-rx (make-regexp "^-([a-zA-Z]+)"))
|
(define short-opt-rx (make-regexp "^-([a-zA-Z]+)(.*)"))
|
||||||
(define long-opt-no-value-rx (make-regexp "^--([^=]+)$"))
|
(define long-opt-no-value-rx (make-regexp "^--([^=]+)$"))
|
||||||
(define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
|
(define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
|
||||||
|
|
||||||
(define (single-char-expander specifications opt-ls)
|
(define (match-substring match which)
|
||||||
"Expand single letter options that are mushed together."
|
;; condensed from (ice-9 regex) `match:{substring,start,end}'
|
||||||
(let ((response #f))
|
(let ((sel (vector-ref match (1+ which))))
|
||||||
(define (is-short-opt? str)
|
(substring (vector-ref match 0) (car sel) (cdr sel))))
|
||||||
(set! response (regexp-exec short-opt-rx str))
|
|
||||||
response)
|
|
||||||
(define (iter opt-ls ret-ls)
|
|
||||||
(cond ((null? opt-ls)
|
|
||||||
(reverse ret-ls))
|
|
||||||
((is-short-opt? (car opt-ls))
|
|
||||||
(let* ((orig-str (car opt-ls))
|
|
||||||
(match-pair (vector-ref response 2))
|
|
||||||
(match-str (substring orig-str (car match-pair)
|
|
||||||
(cdr match-pair))))
|
|
||||||
(if (= (string-length match-str) 1)
|
|
||||||
(iter (cdr opt-ls)
|
|
||||||
(cons (string-append "-" match-str) ret-ls))
|
|
||||||
(iter (cons (string-append "-" (substring match-str 1))
|
|
||||||
(cdr opt-ls))
|
|
||||||
(cons (string-append "-" (substring match-str 0 1))
|
|
||||||
ret-ls)))))
|
|
||||||
(#t (iter (cdr opt-ls)
|
|
||||||
(cons (car opt-ls) ret-ls)))))
|
|
||||||
(iter opt-ls '())))
|
|
||||||
|
|
||||||
(define (process-short-option specifications argument-ls alist)
|
(define (expand-clumped-singles opt-ls)
|
||||||
"Process a single short option that appears at the front of the ARGUMENT-LS,
|
;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d")
|
||||||
according to SPECIFICATIONS. Returns #f is there is no such argument.
|
(let loop ((opt-ls opt-ls) (ret-ls '()))
|
||||||
Otherwise returns a pair whose car is the list of remaining arguments, and
|
(cond ((null? opt-ls)
|
||||||
whose cdr is a new association list, constructed by adding a pair to the
|
(reverse ret-ls)) ;;; retval
|
||||||
supplied ALIST. The pair on the front of the returned association list
|
((regexp-exec short-opt-rx (car opt-ls))
|
||||||
describes the option found at the head of ARGUMENT-LS. The way this routine
|
=> (lambda (match)
|
||||||
currently works, an option that never takes a value that is followed by a non
|
(let ((singles (reverse
|
||||||
option will cause an error, which is probably a bug. To fix the bug the
|
(map (lambda (c)
|
||||||
option specification needs to record whether the option ever can take a
|
(string-append "-" (make-string 1 c)))
|
||||||
value."
|
(string->list
|
||||||
(define (short-option->char option)
|
(match-substring match 1)))))
|
||||||
(string-ref option 1))
|
(extra (match-substring match 2)))
|
||||||
(define (is-short-option? option)
|
(loop (cdr opt-ls)
|
||||||
(regexp-exec short-opt-rx option))
|
(append (if (string=? "" extra)
|
||||||
(define (is-long-option? option)
|
singles
|
||||||
(or (regexp-exec long-opt-with-value-rx option)
|
(cons extra singles))
|
||||||
(regexp-exec long-opt-no-value-rx option)))
|
ret-ls)))))
|
||||||
(define (find-matching-spec option)
|
(else (loop (cdr opt-ls)
|
||||||
(let ((key (short-option->char option)))
|
(cons (car opt-ls) ret-ls))))))
|
||||||
(find-if (lambda (spec)
|
|
||||||
(eq? key (option-spec->single-char spec))) specifications)))
|
|
||||||
(let ((option (car argument-ls)))
|
|
||||||
(if (is-short-option? option)
|
|
||||||
(let ((spec (find-matching-spec option)))
|
|
||||||
(if spec
|
|
||||||
(let* ((next-value (if (null? (cdr argument-ls))
|
|
||||||
#f
|
|
||||||
(cadr argument-ls)))
|
|
||||||
(option-value (if (and next-value
|
|
||||||
(not (is-short-option? next-value))
|
|
||||||
(not (is-long-option? next-value))
|
|
||||||
(option-spec->value-required? spec))
|
|
||||||
next-value
|
|
||||||
#t))
|
|
||||||
(new-alist (cons (cons (option-spec->name spec)
|
|
||||||
option-value)
|
|
||||||
alist)))
|
|
||||||
(cons (if (eq? option-value #t)
|
|
||||||
(cdr argument-ls) ; one value, skip just one
|
|
||||||
(cddr argument-ls)) ; must be a value, skip two
|
|
||||||
new-alist))
|
|
||||||
(error "No such option:" option)))
|
|
||||||
#f)))
|
|
||||||
|
|
||||||
(define (process-long-option specifications argument-ls alist)
|
(define (looks-like-an-option string)
|
||||||
(define (find-matching-spec key)
|
(some (lambda (rx)
|
||||||
(find-if (lambda (spec)
|
(regexp-exec rx string))
|
||||||
(eq? key (option-spec->name spec)))
|
`(,short-opt-rx
|
||||||
specifications))
|
,long-opt-with-value-rx
|
||||||
(define (split-long-option option)
|
,long-opt-no-value-rx)))
|
||||||
;; returns a pair whose car is a symbol naming the option, cdr is
|
|
||||||
;; the option value. as a special case, if the option value is
|
|
||||||
;; #f, then the caller should use the next item in argument-ls as
|
|
||||||
;; the option value.
|
|
||||||
(let ((resp (regexp-exec long-opt-no-value-rx option)))
|
|
||||||
(if resp
|
|
||||||
;; Aha, we've found a long option without an equal sign.
|
|
||||||
;; Maybe we need to grab a value from argument-ls. To find
|
|
||||||
;; out we need to refer to the option-spec.
|
|
||||||
(let* ((key-pair (vector-ref resp 2))
|
|
||||||
(key (string->symbol
|
|
||||||
(substring option (car key-pair) (cdr key-pair))))
|
|
||||||
(spec (find-matching-spec key)))
|
|
||||||
(let* ((req (option-spec->value-required? spec))
|
|
||||||
(retval (cons key (if req #f #t))))
|
|
||||||
;; this is a fucking kludge, i hate it. it's necessary because
|
|
||||||
;; the protocol (return #f to indicate next element is an option
|
|
||||||
;; arg) is insufficient. needs redesign. why am i checking in
|
|
||||||
;; such ugliness? read moby dick! -ttn
|
|
||||||
(and (eq? 'optional req)
|
|
||||||
(set-object-property! retval 'optional #t))
|
|
||||||
retval))
|
|
||||||
(let ((resp (regexp-exec long-opt-with-value-rx option)))
|
|
||||||
;; Aha, we've found a long option with an equal sign. The
|
|
||||||
;; option value is simply the value to the right of the
|
|
||||||
;; equal sign.
|
|
||||||
(if resp
|
|
||||||
(let* ((key-pair (vector-ref resp 2))
|
|
||||||
(key (string->symbol
|
|
||||||
(substring option
|
|
||||||
(car key-pair) (cdr key-pair))))
|
|
||||||
(value-pair (vector-ref resp 3))
|
|
||||||
(value (substring option
|
|
||||||
(car value-pair) (cdr value-pair))))
|
|
||||||
(cons key value))
|
|
||||||
#f)))))
|
|
||||||
(let* ((option (car argument-ls))
|
|
||||||
(pair (split-long-option option)))
|
|
||||||
(cond ((and pair (eq? (cdr pair) #f))
|
|
||||||
(cond ((and (null? (cdr argument-ls))
|
|
||||||
(not (object-property pair 'optional)))
|
|
||||||
(error "Not enough options."))
|
|
||||||
((null? (cdr argument-ls))
|
|
||||||
(cons '() (cons (cons (car pair) #t) alist)))
|
|
||||||
((let* ((next (cadr argument-ls))
|
|
||||||
(m (or (regexp-exec short-opt-rx next)
|
|
||||||
(regexp-exec long-opt-with-value-rx next)
|
|
||||||
(regexp-exec long-opt-no-value-rx next))))
|
|
||||||
(and m (object-property pair 'optional)))
|
|
||||||
(cons (cdr argument-ls)
|
|
||||||
(cons (cons (car pair) #t) alist)))
|
|
||||||
(else
|
|
||||||
(cons (cddr argument-ls)
|
|
||||||
(cons (cons (car pair) (cadr argument-ls)) alist)))))
|
|
||||||
(pair
|
|
||||||
(cons (cdr argument-ls) (cons pair alist)))
|
|
||||||
(else #f))))
|
|
||||||
|
|
||||||
(define (process-options specifications argument-ls)
|
(define (process-options specs argument-ls)
|
||||||
(define (iter argument-ls alist rest-ls)
|
;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
|
||||||
(if (null? argument-ls)
|
;; FOUND is an unordered list of option specs for found options, while ETC
|
||||||
(cons alist (reverse rest-ls))
|
;; is an order-maintained list of elements in ARGUMENT-LS that are neither
|
||||||
(let ((pair (process-short-option specifications argument-ls alist)))
|
;; options nor their values.
|
||||||
(if pair
|
(let ((idx (map (lambda (spec)
|
||||||
(let ((argument-ls (car pair))
|
(cons (option-spec->name spec) spec))
|
||||||
(alist (cdr pair)))
|
specs))
|
||||||
(iter argument-ls alist rest-ls))
|
(sc-idx (map (lambda (spec)
|
||||||
(let ((pair (process-long-option
|
(cons (make-string 1 (option-spec->single-char spec))
|
||||||
specifications argument-ls alist)))
|
spec))
|
||||||
(if pair
|
(remove-if-not option-spec->single-char specs))))
|
||||||
(let ((argument-ls (car pair))
|
(let loop ((argument-ls argument-ls) (found '()) (etc '()))
|
||||||
(alist (cdr pair)))
|
(let ((eat! (lambda (spec ls)
|
||||||
(iter argument-ls alist rest-ls))
|
(let ((val!loop (lambda (val n-ls n-found n-etc)
|
||||||
(iter (cdr argument-ls)
|
(set-option-spec-value! spec val)
|
||||||
alist
|
(loop n-ls n-found n-etc)))
|
||||||
(cons (car argument-ls) rest-ls))))))))
|
(ERR:no-arg (lambda ()
|
||||||
(iter argument-ls '() '()))
|
(error (string-append
|
||||||
|
"option must be specified"
|
||||||
|
" with argument:")
|
||||||
|
(option-spec->name spec)))))
|
||||||
|
(cond
|
||||||
|
((eq? 'optional (option-spec->value-policy spec))
|
||||||
|
(if (or (null? (cdr ls))
|
||||||
|
(looks-like-an-option (cadr ls)))
|
||||||
|
(val!loop #t
|
||||||
|
(cdr ls)
|
||||||
|
(cons spec found)
|
||||||
|
etc)
|
||||||
|
(val!loop (cadr ls)
|
||||||
|
(cddr ls)
|
||||||
|
(cons spec found)
|
||||||
|
etc)))
|
||||||
|
((eq? #t (option-spec->value-policy spec))
|
||||||
|
(if (or (null? (cdr ls))
|
||||||
|
(looks-like-an-option (cadr ls)))
|
||||||
|
(ERR:no-arg)
|
||||||
|
(val!loop (cadr ls)
|
||||||
|
(cddr ls)
|
||||||
|
(cons spec found)
|
||||||
|
etc)))
|
||||||
|
(else
|
||||||
|
(val!loop #t
|
||||||
|
(cdr ls)
|
||||||
|
(cons spec found)
|
||||||
|
etc)))))))
|
||||||
|
(if (null? argument-ls)
|
||||||
|
(cons found (reverse etc)) ;;; retval
|
||||||
|
(cond ((regexp-exec short-opt-rx (car argument-ls))
|
||||||
|
=> (lambda (match)
|
||||||
|
(let* ((c (match-substring match 1))
|
||||||
|
(spec (or (assoc-ref sc-idx c)
|
||||||
|
(error "no such option:" c))))
|
||||||
|
(eat! spec argument-ls))))
|
||||||
|
((regexp-exec long-opt-no-value-rx (car argument-ls))
|
||||||
|
=> (lambda (match)
|
||||||
|
(let* ((opt (match-substring match 1))
|
||||||
|
(spec (or (assoc-ref idx opt)
|
||||||
|
(error "no such option:" opt))))
|
||||||
|
(eat! spec argument-ls))))
|
||||||
|
((regexp-exec long-opt-with-value-rx (car argument-ls))
|
||||||
|
=> (lambda (match)
|
||||||
|
(let* ((opt (match-substring match 1))
|
||||||
|
(spec (or (assoc-ref idx opt)
|
||||||
|
(error "no such option:" opt))))
|
||||||
|
(if (option-spec->value-policy spec)
|
||||||
|
(eat! spec (append
|
||||||
|
(list 'ignored
|
||||||
|
(match-substring match 2))
|
||||||
|
(cdr argument-ls)))
|
||||||
|
(error "option does not support argument:"
|
||||||
|
opt)))))
|
||||||
|
(else
|
||||||
|
(loop (cdr argument-ls)
|
||||||
|
found
|
||||||
|
(cons (car argument-ls) etc)))))))))
|
||||||
|
|
||||||
(define (getopt-long program-arguments option-desc-list)
|
(define (getopt-long program-arguments option-desc-list)
|
||||||
"Process options, handling both long and short options, similar to
|
"Process options, handling both long and short options, similar to
|
||||||
|
|
@ -708,41 +394,37 @@ or option values.
|
||||||
By default, options are not required, and option values are not
|
By default, options are not required, and option values are not
|
||||||
required. By default, single character equivalents are not supported;
|
required. By default, single character equivalents are not supported;
|
||||||
if you want to allow the user to use single character options, you need
|
if you want to allow the user to use single character options, you need
|
||||||
to add a 'single-char' clause to the option description."
|
to add a `single-char' clause to the option description."
|
||||||
(let* ((specifications (map parse-option-spec option-desc-list))
|
(let* ((specifications (map parse-option-spec option-desc-list))
|
||||||
(pair (split-arg-list (cdr program-arguments)))
|
(pair (split-arg-list (cdr program-arguments)))
|
||||||
(split-ls (single-char-expander specifications (car pair)))
|
(split-ls (expand-clumped-singles (car pair)))
|
||||||
(non-split-ls (cdr pair)))
|
(non-split-ls (cdr pair))
|
||||||
(let* ((opt-pair (process-options specifications split-ls))
|
(found/etc (process-options specifications split-ls))
|
||||||
(alist (car opt-pair))
|
(found (car found/etc))
|
||||||
(rest-ls (append (cdr opt-pair) non-split-ls)))
|
(rest-ls (append (cdr found/etc) non-split-ls)))
|
||||||
;; loop through returned alist, set values into specifications
|
(for-each (lambda (spec)
|
||||||
(for-each (lambda (pair)
|
(let ((name (option-spec->name spec))
|
||||||
(let* ((key (car pair))
|
(val (option-spec->value spec)))
|
||||||
(val (cdr pair))
|
(and (option-spec->required? spec)
|
||||||
(spec (find-if (lambda (spec)
|
(or (memq spec found)
|
||||||
(eq? key (option-spec->name spec)))
|
(error "option must be specified:" name)))
|
||||||
specifications)))
|
(and (memq spec found)
|
||||||
(if spec (set-option-spec-value! spec val))))
|
(eq? #t (option-spec->value-policy spec))
|
||||||
alist)
|
(or val
|
||||||
;; now fire all the predicates
|
(error "option must be specified with argument:"
|
||||||
(for-each (lambda (spec)
|
name)))
|
||||||
(let ((predicate-ls (option-spec->predicate-ls spec)))
|
(let ((pred (option-spec->predicate spec)))
|
||||||
(for-each (lambda (predicate)
|
(and pred (pred name val)))))
|
||||||
(predicate spec))
|
specifications)
|
||||||
predicate-ls)))
|
(cons (cons '() rest-ls)
|
||||||
specifications)
|
(map (lambda (spec)
|
||||||
(cons (cons '() rest-ls) alist))))
|
(cons (string->symbol (option-spec->name spec))
|
||||||
|
(option-spec->value spec)))
|
||||||
|
found))))
|
||||||
|
|
||||||
(define (option-ref options key default)
|
(define (option-ref options key default)
|
||||||
"Look for an option value in OPTIONS using KEY. If no such value is
|
"Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
|
||||||
found, return DEFAULT."
|
The value is either a string or `#t'."
|
||||||
(let ((pair (assq key options)))
|
(or (assq-ref options key) default))
|
||||||
(if pair
|
|
||||||
(cdr pair)
|
|
||||||
default)))
|
|
||||||
|
|
||||||
(export option-ref)
|
|
||||||
(export getopt-long)
|
|
||||||
|
|
||||||
;;; getopt-long.scm ends here
|
;;; getopt-long.scm ends here
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue