mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-19 10:10:23 +02:00
Code Activity

Rewrite.

Browse source 
Touch up docstrings.
Augment commentary.
This commit is contained in:
Thien-Thi Nguyen 2001-08-12 19:21:59 +00:00
parent 24bf1e2f6b
commit b817e7ef1c
1 changed files with 212 additions and 530 deletions
Download patch file Download diff file Expand all files Collapse all files

730
ice-9/getopt-long.scm
View file

@ -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 (expand-clumped-singles opt-ls)
(define (iter opt-ls ret-ls) ;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d")
(let loop ((opt-ls opt-ls) (ret-ls '()))
(cond ((null? opt-ls) (cond ((null? opt-ls)
(reverse ret-ls)) (reverse ret-ls)) ;;; retval
((is-short-opt? (car opt-ls)) ((regexp-exec short-opt-rx (car opt-ls))
(let* ((orig-str (car opt-ls)) => (lambda (match)
(match-pair (vector-ref response 2)) (let ((singles (reverse
(match-str (substring orig-str (car match-pair) (map (lambda (c)
(cdr match-pair)))) (string-append "-" (make-string 1 c)))
(if (= (string-length match-str) 1) (string->list
(iter (cdr opt-ls) (match-substring match 1)))))
(cons (string-append "-" match-str) ret-ls)) (extra (match-substring match 2)))
(iter (cons (string-append "-" (substring match-str 1)) (loop (cdr opt-ls)
(cdr opt-ls)) (append (if (string=? "" extra)
(cons (string-append "-" (substring match-str 0 1)) singles
(cons extra singles))
ret-ls))))) ret-ls)))))
(#t (iter (cdr opt-ls) (else (loop (cdr opt-ls)
(cons (car opt-ls) ret-ls))))) (cons (car opt-ls) ret-ls))))))
(iter opt-ls '())))
(define (process-short-option specifications argument-ls alist) (define (looks-like-an-option string)
"Process a single short option that appears at the front of the ARGUMENT-LS, (some (lambda (rx)
according to SPECIFICATIONS. Returns #f is there is no such argument. (regexp-exec rx string))
Otherwise returns a pair whose car is the list of remaining arguments, and `(,short-opt-rx
whose cdr is a new association list, constructed by adding a pair to the ,long-opt-with-value-rx
supplied ALIST. The pair on the front of the returned association list ,long-opt-no-value-rx)))
describes the option found at the head of ARGUMENT-LS. The way this routine
currently works, an option that never takes a value that is followed by a non
option will cause an error, which is probably a bug. To fix the bug the
option specification needs to record whether the option ever can take a
value."
(define (short-option->char option)
(string-ref option 1))
(define (is-short-option? option)
(regexp-exec short-opt-rx option))
(define (is-long-option? option)
(or (regexp-exec long-opt-with-value-rx option)
(regexp-exec long-opt-no-value-rx option)))
(define (find-matching-spec option)
(let ((key (short-option->char option)))
(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 (process-options specs argument-ls)
(define (find-matching-spec key) ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
(find-if (lambda (spec) ;; FOUND is an unordered list of option specs for found options, while ETC
(eq? key (option-spec->name spec))) ;; is an order-maintained list of elements in ARGUMENT-LS that are neither
specifications)) ;; options nor their values.
(define (split-long-option option) (let ((idx (map (lambda (spec)
;; returns a pair whose car is a symbol naming the option, cdr is (cons (option-spec->name spec) spec))
;; the option value. as a special case, if the option value is specs))
;; #f, then the caller should use the next item in argument-ls as (sc-idx (map (lambda (spec)
;; the option value. (cons (make-string 1 (option-spec->single-char spec))
(let ((resp (regexp-exec long-opt-no-value-rx option))) spec))
(if resp (remove-if-not option-spec->single-char specs))))
;; Aha, we've found a long option without an equal sign. (let loop ((argument-ls argument-ls) (found '()) (etc '()))
;; Maybe we need to grab a value from argument-ls. To find (let ((eat! (lambda (spec ls)
;; out we need to refer to the option-spec. (let ((val!loop (lambda (val n-ls n-found n-etc)
(let* ((key-pair (vector-ref resp 2)) (set-option-spec-value! spec val)
(key (string->symbol (loop n-ls n-found n-etc)))
(substring option (car key-pair) (cdr key-pair)))) (ERR:no-arg (lambda ()
(spec (find-matching-spec key))) (error (string-append
(let* ((req (option-spec->value-required? spec)) "option must be specified"
(retval (cons key (if req #f #t)))) " with argument:")
;; this is a fucking kludge, i hate it. it's necessary because (option-spec->name spec)))))
;; the protocol (return #f to indicate next element is an option (cond
;; arg) is insufficient. needs redesign. why am i checking in ((eq? 'optional (option-spec->value-policy spec))
;; such ugliness? read moby dick! -ttn (if (or (null? (cdr ls))
(and (eq? 'optional req) (looks-like-an-option (cadr ls)))
(set-object-property! retval 'optional #t)) (val!loop #t
retval)) (cdr ls)
(let ((resp (regexp-exec long-opt-with-value-rx option))) (cons spec found)
;; Aha, we've found a long option with an equal sign. The etc)
;; option value is simply the value to the right of the (val!loop (cadr ls)
;; equal sign. (cddr ls)
(if resp (cons spec found)
(let* ((key-pair (vector-ref resp 2)) etc)))
(key (string->symbol ((eq? #t (option-spec->value-policy spec))
(substring option (if (or (null? (cdr ls))
(car key-pair) (cdr key-pair)))) (looks-like-an-option (cadr ls)))
(value-pair (vector-ref resp 3)) (ERR:no-arg)
(value (substring option (val!loop (cadr ls)
(car value-pair) (cdr value-pair)))) (cddr ls)
(cons key value)) (cons spec found)
#f))))) etc)))
(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 (else
(cons (cddr argument-ls) (val!loop #t
(cons (cons (car pair) (cadr argument-ls)) alist))))) (cdr ls)
(pair (cons spec found)
(cons (cdr argument-ls) (cons pair alist))) etc)))))))
(else #f))))
(define (process-options specifications argument-ls)
(define (iter argument-ls alist rest-ls)
(if (null? argument-ls) (if (null? argument-ls)
(cons alist (reverse rest-ls)) (cons found (reverse etc)) ;;; retval
(let ((pair (process-short-option specifications argument-ls alist))) (cond ((regexp-exec short-opt-rx (car argument-ls))
(if pair => (lambda (match)
(let ((argument-ls (car pair)) (let* ((c (match-substring match 1))
(alist (cdr pair))) (spec (or (assoc-ref sc-idx c)
(iter argument-ls alist rest-ls)) (error "no such option:" c))))
(let ((pair (process-long-option (eat! spec argument-ls))))
specifications argument-ls alist))) ((regexp-exec long-opt-no-value-rx (car argument-ls))
(if pair => (lambda (match)
(let ((argument-ls (car pair)) (let* ((opt (match-substring match 1))
(alist (cdr pair))) (spec (or (assoc-ref idx opt)
(iter argument-ls alist rest-ls)) (error "no such option:" opt))))
(iter (cdr argument-ls) (eat! spec argument-ls))))
alist ((regexp-exec long-opt-with-value-rx (car argument-ls))
(cons (car argument-ls) rest-ls)))))))) => (lambda (match)
(iter argument-ls '() '())) (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 (pair)
(let* ((key (car pair))
(val (cdr pair))
(spec (find-if (lambda (spec)
(eq? key (option-spec->name spec)))
specifications)))
(if spec (set-option-spec-value! spec val))))
alist)
;; now fire all the predicates
(for-each (lambda (spec) (for-each (lambda (spec)
(let ((predicate-ls (option-spec->predicate-ls spec))) (let ((name (option-spec->name spec))
(for-each (lambda (predicate) (val (option-spec->value spec)))
(predicate spec)) (and (option-spec->required? spec)
predicate-ls))) (or (memq spec found)
(error "option must be specified:" name)))
(and (memq spec found)
(eq? #t (option-spec->value-policy spec))
(or val
(error "option must be specified with argument:"
name)))
(let ((pred (option-spec->predicate spec)))
(and pred (pred name val)))))
specifications) specifications)
(cons (cons '() rest-ls) alist)))) (cons (cons '() rest-ls)
(map (lambda (spec)
(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