[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
guile/guile-core/ice-9 getopt-long.scm
|
From: |
Thien-Thi Nguyen |
|
Subject: |
guile/guile-core/ice-9 getopt-long.scm |
|
Date: |
Sun, 12 Aug 2001 11:56:39 -0700 |
CVSROOT: /cvs
Module name: guile
Changes by: Thien-Thi Nguyen <address@hidden> 01/08/12 11:56:39
Modified files:
guile-core/ice-9: getopt-long.scm
Log message:
Rewrite.
Touch up docstrings.
Augment commentary.
CVSWeb URLs:
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/ice-9/getopt-long.scm.diff?cvsroot=OldCVS&tr1=1.5&tr2=1.6&r1=text&r2=text
Patches:
Index: guile/guile-core/ice-9/getopt-long.scm
diff -u guile/guile-core/ice-9/getopt-long.scm:1.5
guile/guile-core/ice-9/getopt-long.scm:1.6
--- guile/guile-core/ice-9/getopt-long.scm:1.5 Thu Aug 2 03:26:52 2001
+++ guile/guile-core/ice-9/getopt-long.scm Sun Aug 12 11:56:39 2001
@@ -1,6 +1,3 @@
-;;; Author: Russ McManus
-;;; $Id: getopt-long.scm,v 1.5 2001/08/02 10:26:52 ttn Exp $
-;;;
;;; Copyright (C) 1998, 2001 Free Software Foundation, Inc.
;;;
;;; 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.
;;; If you do not wish that, delete this exception notice.
+;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
+
;;; Commentary:
;;; 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.
;;;
;;; 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
;;; structure. The grammar makes the option descriptions easy to read.
;;;
-
-;;; getopt-long is a function for parsing command-line arguments in a
-;;; manner consistent with other GNU programs.
+;;; `getopt-long' is a procedure for parsing command-line arguments in a
+;;; manner consistent with other GNU programs. `option-ref' is a procedure
+;;; that facilitates processing of the `getopt-long' return value.
;;; (getopt-long ARGS 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
;;; 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
-;;; option itself, then that string is the option's value.
+;;; the next element is does not appear to be an option itself, then
+;;; that element is the option's value.
;;;
;;; 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.
@@ -138,6 +137,8 @@
;;; as a list, associated with the empty list.
;;;
;;; `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
;;; - a required option is omitted
;;; - an option that requires an argument doesn't get one
@@ -168,515 +169,200 @@
;;; (lockfile-dir . "/tmp")
;;; (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:
(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))
-
-;;; The code on this page was expanded by hand using the following code:
-;;; (pretty-print
-;;; (macroexpand
-;;; '(define-record option-spec
-;;; (name
-;;; 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))))
-
-
-;;;
-;;; 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
- (lambda ()
- (lambda (spec)
- (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
- (lambda ()
- (lambda (spec)
- (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
- (lambda (predicate)
- (lambda (spec)
- (let ((val (option-spec->value spec)))
- (if (not (predicate val))
- (let ((name (option-spec->name spec)))
- (error "Bad option value:" name val)))))))
-
-(define make-required-value-fn
- (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?
- (lambda (val)
- (char? val)))
+(define option-spec-fields '(name
+ value
+ required?
+ single-char
+ predicate
+ value-policy))
+
+(define option-spec (make-record-type 'option-spec option-spec-fields))
+(define make-option-spec (record-constructor option-spec option-spec-fields))
+
+(define (define-one-option-spec-field-accessor field)
+ `(define ,(symbol-append 'option-spec-> field) ;;; name slib-compat
+ (record-accessor option-spec ',field)))
+
+(define (define-one-option-spec-field-modifier field)
+ `(define ,(symbol-append 'set-option-spec- field '!) ;;; name slib-compat
+ (record-modifier option-spec ',field)))
+
+(defmacro define-all-option-spec-accessors/modifiers ()
+ `(begin
+ ,@(map define-one-option-spec-field-accessor option-spec-fields)
+ ,@(map define-one-option-spec-field-modifier option-spec-fields)))
+
+(define-all-option-spec-accessors/modifiers)
+
+(define make-option-spec
+ (let ((ctor (record-constructor option-spec '(name))))
+ (lambda (name)
+ (ctor name))))
(define (parse-option-spec desc)
- (letrec ((parse-iter
- (lambda (spec)
- (let ((parse-ls (option-spec->parse-ls spec)))
- (if (null? parse-ls)
- spec
- (let ((ls (car parse-ls)))
- (if (or (not (list? ls))
- (not (= (length ls) 2)))
- (error "Bad option specification:" ls))
- (let ((key (car ls))
- (val (cadr ls)))
- (cond ((and (eq? key 'required?) val)
- ;; required values implemented as a predicate
- (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-option-required-predicate)
- (option-spec->predicate-ls spec))
- (cdr parse-ls))))
- ;; if value not required, don't add predicate,
- ((eq? key 'required?)
- (parse-iter
- (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)))))
+ (let ((spec (make-option-spec (symbol->string (car desc)))))
+ (for-each (lambda (desc-elem)
+ (let ((given (lambda () (cadr desc-elem))))
+ (case (car desc-elem)
+ ((required?)
+ (set-option-spec-required?! spec (given)))
+ ((value)
+ (set-option-spec-value-policy! spec (given)))
+ ((single-char)
+ (or (char? (given))
+ (error "`single-char' value must be a char!"))
+ (set-option-spec-single-char! spec (given)))
+ ((predicate)
+ (set-option-spec-predicate!
+ spec ((lambda (pred)
+ (lambda (name val)
+ (or (not val)
+ (pred val)
+ (error "option predicate failed:" name))))
+ (given))))
+ (else
+ (error "invalid getopt-long option property:"
+ (car desc-elem))))))
+ (cdr desc))
+ spec))
-
-;;;
-;;;
-;;;
(define (split-arg-list argument-list)
- "Given an ARGUMENT-LIST, decide which part to process for options.
-Everything before an arg of \"--\" is fair game, everything after it
-should not be processed. The \"--\" is discarded. A cons pair is
-returned whose car is the list to process for options, and whose cdr
-is the list to not process."
- (let loop ((process-ls '())
- (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))))))
+ ;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS).
+ ;; Discard the "--". If no "--" is found, AFTER-LS is empty.
+ (let loop ((yes '()) (no argument-list))
+ (cond ((null? no) (cons (reverse yes) no))
+ ((string=? "--" (car no)) (cons (reverse yes) (cdr no)))
+ (else (loop (cons (car no) yes) (cdr no))))))
-(define short-opt-rx (make-regexp "^-([a-zA-Z]+)"))
-(define long-opt-no-value-rx (make-regexp "^--([^=]+)$"))
+(define short-opt-rx (make-regexp "^-([a-zA-Z]+)(.*)"))
+(define long-opt-no-value-rx (make-regexp "^--([^=]+)$"))
(define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
-(define (single-char-expander specifications opt-ls)
- "Expand single letter options that are mushed together."
- (let ((response #f))
- (define (is-short-opt? str)
- (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)
- "Process a single short option that appears at the front of the ARGUMENT-LS,
-according to SPECIFICATIONS. Returns #f is there is no such argument.
-Otherwise returns a pair whose car is the list of remaining arguments, and
-whose cdr is a new association list, constructed by adding a pair to the
-supplied ALIST. The pair on the front of the returned association list
-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 (find-matching-spec key)
- (find-if (lambda (spec)
- (eq? key (option-spec->name spec)))
- specifications))
- (define (split-long-option option)
- ;; 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 (iter argument-ls alist rest-ls)
- (if (null? argument-ls)
- (cons alist (reverse rest-ls))
- (let ((pair (process-short-option specifications argument-ls alist)))
- (if pair
- (let ((argument-ls (car pair))
- (alist (cdr pair)))
- (iter argument-ls alist rest-ls))
- (let ((pair (process-long-option
- specifications argument-ls alist)))
- (if pair
- (let ((argument-ls (car pair))
- (alist (cdr pair)))
- (iter argument-ls alist rest-ls))
- (iter (cdr argument-ls)
- alist
- (cons (car argument-ls) rest-ls))))))))
- (iter argument-ls '() '()))
+(define (match-substring match which)
+ ;; condensed from (ice-9 regex) `match:{substring,start,end}'
+ (let ((sel (vector-ref match (1+ which))))
+ (substring (vector-ref match 0) (car sel) (cdr sel))))
+
+(define (expand-clumped-singles opt-ls)
+ ;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d")
+ (let loop ((opt-ls opt-ls) (ret-ls '()))
+ (cond ((null? opt-ls)
+ (reverse ret-ls)) ;;; retval
+ ((regexp-exec short-opt-rx (car opt-ls))
+ => (lambda (match)
+ (let ((singles (reverse
+ (map (lambda (c)
+ (string-append "-" (make-string 1 c)))
+ (string->list
+ (match-substring match 1)))))
+ (extra (match-substring match 2)))
+ (loop (cdr opt-ls)
+ (append (if (string=? "" extra)
+ singles
+ (cons extra singles))
+ ret-ls)))))
+ (else (loop (cdr opt-ls)
+ (cons (car opt-ls) ret-ls))))))
+
+(define (looks-like-an-option string)
+ (some (lambda (rx)
+ (regexp-exec rx string))
+ `(,short-opt-rx
+ ,long-opt-with-value-rx
+ ,long-opt-no-value-rx)))
+
+(define (process-options specs argument-ls)
+ ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
+ ;; FOUND is an unordered list of option specs for found options, while ETC
+ ;; is an order-maintained list of elements in ARGUMENT-LS that are neither
+ ;; options nor their values.
+ (let ((idx (map (lambda (spec)
+ (cons (option-spec->name spec) spec))
+ specs))
+ (sc-idx (map (lambda (spec)
+ (cons (make-string 1 (option-spec->single-char spec))
+ spec))
+ (remove-if-not option-spec->single-char specs))))
+ (let loop ((argument-ls argument-ls) (found '()) (etc '()))
+ (let ((eat! (lambda (spec ls)
+ (let ((val!loop (lambda (val n-ls n-found n-etc)
+ (set-option-spec-value! spec val)
+ (loop n-ls n-found n-etc)))
+ (ERR:no-arg (lambda ()
+ (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)
"Process options, handling both long and short options, similar to
@@ -708,41 +394,37 @@
By default, options are not required, and option values are not
required. By default, single character equivalents are not supported;
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))
(pair (split-arg-list (cdr program-arguments)))
- (split-ls (single-char-expander specifications (car pair)))
- (non-split-ls (cdr pair)))
- (let* ((opt-pair (process-options specifications split-ls))
- (alist (car opt-pair))
- (rest-ls (append (cdr opt-pair) 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)
- (let ((predicate-ls (option-spec->predicate-ls spec)))
- (for-each (lambda (predicate)
- (predicate spec))
- predicate-ls)))
- specifications)
- (cons (cons '() rest-ls) alist))))
+ (split-ls (expand-clumped-singles (car pair)))
+ (non-split-ls (cdr pair))
+ (found/etc (process-options specifications split-ls))
+ (found (car found/etc))
+ (rest-ls (append (cdr found/etc) non-split-ls)))
+ (for-each (lambda (spec)
+ (let ((name (option-spec->name spec))
+ (val (option-spec->value spec)))
+ (and (option-spec->required? spec)
+ (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)
+ (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)
- "Look for an option value in OPTIONS using KEY. If no such value is
-found, return DEFAULT."
- (let ((pair (assq key options)))
- (if pair
- (cdr pair)
- default)))
-
-(export option-ref)
-(export getopt-long)
+ "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
+The value is either a string or `#t'."
+ (or (assq-ref options key) default))
;;; getopt-long.scm ends here