mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
e2ed33ef04
These were found with: make GUILE_WARNINGS='-W1 -Wunused-module' * module/ice-9/copy-tree.scm: * module/ice-9/eval-string.scm: * module/ice-9/getopt-long.scm: * module/ice-9/poll.scm: * module/ice-9/popen.scm: * module/ice-9/sandbox.scm: * module/ice-9/threads.scm: * module/sxml/apply-templates.scm: * module/sxml/simple.scm: * module/system/base/types.scm: * module/system/repl/command.scm: * module/system/repl/common.scm: * module/system/repl/coop-server.scm: * module/system/repl/debug.scm: * module/system/repl/error-handling.scm: * module/system/repl/repl.scm: * module/system/repl/server.scm: * module/system/vm/assembler.scm: * module/system/vm/disassembler.scm: * module/system/vm/dwarf.scm: * module/system/vm/elf.scm: * module/system/vm/frame.scm: * module/system/vm/inspect.scm: * module/system/vm/linker.scm: * module/system/vm/program.scm: * module/system/vm/trace.scm: * module/system/vm/trap-state.scm: * module/system/vm/traps.scm: * module/system/xref.scm: * module/texinfo/indexing.scm: * module/texinfo/plain-text.scm: * module/texinfo/reflection.scm: * module/texinfo/string-utils.scm: * module/web/client.scm: * module/web/http.scm: * module/web/request.scm: * module/web/response.scm: Remove imports of unused modules.
370 lines
16 KiB
Scheme
370 lines
16 KiB
Scheme
;;; Copyright (C) 1998, 2001, 2006, 2009, 2011 Free Software Foundation, Inc.
|
|
;;;
|
|
;;;; This library is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Lesser General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 3 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; This library is distributed in the hope that it will be useful,
|
|
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;;; Lesser General Public License for more details.
|
|
;;;;
|
|
;;;; You should have received a copy of the GNU Lesser General Public
|
|
;;;; License along with this library; if not, write to the Free Software
|
|
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
;;; 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
|
|
;;; 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 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.
|
|
;;;
|
|
;;; ARGS should be a list of strings. Its first element should be the
|
|
;;; name of the program; subsequent elements should be the arguments
|
|
;;; that were passed to the program on the command line. The
|
|
;;; `program-arguments' procedure returns a list of this form.
|
|
;;;
|
|
;;; GRAMMAR is a list of the form:
|
|
;;; ((OPTION (PROPERTY VALUE) ...) ...)
|
|
;;;
|
|
;;; Each OPTION should be a symbol. `getopt-long' will accept a
|
|
;;; command-line option named `--OPTION'.
|
|
;;; Each option can have the following (PROPERTY VALUE) pairs:
|
|
;;;
|
|
;;; (single-char CHAR) --- Accept `-CHAR' as a single-character
|
|
;;; equivalent to `--OPTION'. This is how to specify traditional
|
|
;;; Unix-style flags.
|
|
;;; (required? BOOL) --- If BOOL is true, the option is required.
|
|
;;; getopt-long will raise an error if it is not found in ARGS.
|
|
;;; (value BOOL) --- If BOOL is #t, the option accepts a value; if
|
|
;;; it is #f, it does not; and if it is the symbol
|
|
;;; `optional', the option may appear in ARGS with or
|
|
;;; without a value.
|
|
;;; (predicate FUNC) --- If the option accepts a value (i.e. you
|
|
;;; specified `(value #t)' for this option), then getopt
|
|
;;; will apply FUNC to the value, and throw an exception
|
|
;;; if it returns #f. FUNC should be a procedure which
|
|
;;; accepts a string and returns a boolean value; you may
|
|
;;; need to use quasiquotes to get it into GRAMMAR.
|
|
;;;
|
|
;;; The (PROPERTY VALUE) pairs may occur in any order, but each
|
|
;;; property may occur only once. By default, options do not have
|
|
;;; single-character equivalents, are not required, and do not take
|
|
;;; values.
|
|
;;;
|
|
;;; In ARGS, single-character options may be combined, in the usual
|
|
;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy"). If an option
|
|
;;; accepts values, then it must be the last option in the
|
|
;;; combination; the value is the next argument. So, for example, using
|
|
;;; the following grammar:
|
|
;;; ((apples (single-char #\a))
|
|
;;; (blimps (single-char #\b) (value #t))
|
|
;;; (catalexis (single-char #\c) (value #t)))
|
|
;;; the following argument lists would be acceptable:
|
|
;;; ("-a" "-b" "bang" "-c" "couth") ("bang" and "couth" are the values
|
|
;;; for "blimps" and "catalexis")
|
|
;;; ("-ab" "bang" "-c" "couth") (same)
|
|
;;; ("-ac" "couth" "-b" "bang") (same)
|
|
;;; ("-abc" "couth" "bang") (an error, since `-b' is not the
|
|
;;; last option in its combination)
|
|
;;;
|
|
;;; 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 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.
|
|
;;; Thus, using the same grammar as above, the following argument lists
|
|
;;; are equivalent:
|
|
;;; ("--apples" "Braeburn" "--blimps" "Goodyear")
|
|
;;; ("--apples=Braeburn" "--blimps" "Goodyear")
|
|
;;; ("--blimps" "Goodyear" "--apples=Braeburn")
|
|
;;;
|
|
;;; If the option "--" appears in ARGS, argument parsing stops there;
|
|
;;; subsequent arguments are returned as ordinary arguments, even if
|
|
;;; they resemble options. So, in the argument list:
|
|
;;; ("--apples" "Granny Smith" "--" "--blimp" "Goodyear")
|
|
;;; `getopt-long' will recognize the `apples' option as having the
|
|
;;; value "Granny Smith", but it will not recognize the `blimp'
|
|
;;; option; it will return the strings "--blimp" and "Goodyear" as
|
|
;;; ordinary argument strings.
|
|
;;;
|
|
;;; The `getopt-long' function returns the parsed argument list as an
|
|
;;; assocation list, mapping option names --- the symbols from GRAMMAR
|
|
;;; --- onto their values, or #t if the option does not accept a value.
|
|
;;; Unused options do not appear in the alist.
|
|
;;;
|
|
;;; All arguments that are not the value of any option are returned
|
|
;;; 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
|
|
;;; - an option that doesn't accept an argument does get one (this can
|
|
;;; only happen using the long option `--opt=value' syntax)
|
|
;;; - an option predicate fails
|
|
;;;
|
|
;;; So, for example:
|
|
;;;
|
|
;;; (define grammar
|
|
;;; `((lockfile-dir (required? #t)
|
|
;;; (value #t)
|
|
;;; (single-char #\k)
|
|
;;; (predicate ,file-is-directory?))
|
|
;;; (verbose (required? #f)
|
|
;;; (single-char #\v)
|
|
;;; (value #f))
|
|
;;; (x-includes (single-char #\x))
|
|
;;; (rnet-server (single-char #\y)
|
|
;;; (predicate ,string?))))
|
|
;;;
|
|
;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include"
|
|
;;; "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3")
|
|
;;; grammar)
|
|
;;; => ((() "foo1" "-fred" "foo2" "foo3")
|
|
;;; (rnet-server . "lamprod")
|
|
;;; (x-includes . "/usr/include")
|
|
;;; (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) #:select (remove-if-not))
|
|
#:use-module (srfi srfi-9)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 regex)
|
|
#:export (getopt-long option-ref))
|
|
|
|
(define %program-name (make-fluid "guile"))
|
|
(define (program-name)
|
|
(fluid-ref %program-name))
|
|
|
|
(define (fatal-error fmt . args)
|
|
(format (current-error-port) "~a: " (program-name))
|
|
(apply format (current-error-port) fmt args)
|
|
(newline (current-error-port))
|
|
(exit 1))
|
|
|
|
(define-record-type option-spec
|
|
(%make-option-spec name required? option-spec->single-char predicate value-policy)
|
|
option-spec?
|
|
(name
|
|
option-spec->name set-option-spec-name!)
|
|
(required?
|
|
option-spec->required? set-option-spec-required?!)
|
|
(option-spec->single-char
|
|
option-spec->single-char set-option-spec-single-char!)
|
|
(predicate
|
|
option-spec->predicate set-option-spec-predicate!)
|
|
(value-policy
|
|
option-spec->value-policy set-option-spec-value-policy!))
|
|
|
|
(define (make-option-spec name)
|
|
(%make-option-spec name #f #f #f #f))
|
|
|
|
(define (parse-option-spec desc)
|
|
(let ((spec (make-option-spec (symbol->string (car desc)))))
|
|
(for-each (match-lambda
|
|
(('required? val)
|
|
(set-option-spec-required?! spec val))
|
|
(('value val)
|
|
(set-option-spec-value-policy! spec val))
|
|
(('single-char val)
|
|
(or (char? val)
|
|
(error "`single-char' value must be a char!"))
|
|
(set-option-spec-single-char! spec val))
|
|
(('predicate pred)
|
|
(set-option-spec-predicate!
|
|
spec (lambda (name val)
|
|
(or (not val)
|
|
(pred val)
|
|
(fatal-error "option predicate failed: --~a"
|
|
name)))))
|
|
((prop val)
|
|
(error "invalid getopt-long option property:" prop)))
|
|
(cdr desc))
|
|
spec))
|
|
|
|
(define (split-arg-list argument-list)
|
|
;; 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 long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
|
|
|
|
(define (looks-like-an-option string)
|
|
(or (regexp-exec short-opt-rx string)
|
|
(regexp-exec long-opt-with-value-rx string)
|
|
(regexp-exec long-opt-no-value-rx string)))
|
|
|
|
(define (process-options specs argument-ls stop-at-first-non-option)
|
|
;; 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 ((unclumped 0) (argument-ls argument-ls) (found '()) (etc '()))
|
|
(define (eat! spec ls)
|
|
(cond
|
|
((eq? 'optional (option-spec->value-policy spec))
|
|
(if (or (null? ls)
|
|
(looks-like-an-option (car ls)))
|
|
(loop (- unclumped 1) ls (acons spec #t found) etc)
|
|
(loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc)))
|
|
((eq? #t (option-spec->value-policy spec))
|
|
(if (or (null? ls)
|
|
(looks-like-an-option (car ls)))
|
|
(fatal-error "option must be specified with argument: --~a"
|
|
(option-spec->name spec))
|
|
(loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc)))
|
|
(else
|
|
(loop (- unclumped 1) ls (acons spec #t found) etc))))
|
|
|
|
(match argument-ls
|
|
(()
|
|
(cons found (reverse etc)))
|
|
((opt . rest)
|
|
(cond
|
|
((regexp-exec short-opt-rx opt)
|
|
=> (lambda (match)
|
|
(if (> unclumped 0)
|
|
;; Next option is known not to be clumped.
|
|
(let* ((c (match:substring match 1))
|
|
(spec (or (assoc-ref sc-idx c)
|
|
(fatal-error "no such option: -~a" c))))
|
|
(eat! spec rest))
|
|
;; Expand a clumped group of short options.
|
|
(let* ((extra (match:substring match 2))
|
|
(unclumped-opts
|
|
(append (map (lambda (c)
|
|
(string-append "-" (make-string 1 c)))
|
|
(string->list
|
|
(match:substring match 1)))
|
|
(if (string=? "" extra) '() (list extra)))))
|
|
(loop (length unclumped-opts)
|
|
(append unclumped-opts rest)
|
|
found
|
|
etc)))))
|
|
((regexp-exec long-opt-no-value-rx opt)
|
|
=> (lambda (match)
|
|
(let* ((opt (match:substring match 1))
|
|
(spec (or (assoc-ref idx opt)
|
|
(fatal-error "no such option: --~a" opt))))
|
|
(eat! spec rest))))
|
|
((regexp-exec long-opt-with-value-rx opt)
|
|
=> (lambda (match)
|
|
(let* ((opt (match:substring match 1))
|
|
(spec (or (assoc-ref idx opt)
|
|
(fatal-error "no such option: --~a" opt))))
|
|
(if (option-spec->value-policy spec)
|
|
(eat! spec (cons (match:substring match 2) rest))
|
|
(fatal-error "option does not support argument: --~a"
|
|
opt)))))
|
|
((and stop-at-first-non-option
|
|
(<= unclumped 0))
|
|
(cons found (append (reverse etc) argument-ls)))
|
|
(else
|
|
(loop (- unclumped 1) rest found (cons opt etc)))))))))
|
|
|
|
(define* (getopt-long program-arguments option-desc-list
|
|
#:key stop-at-first-non-option)
|
|
"Process options, handling both long and short options, similar to
|
|
the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a value
|
|
similar to what (program-arguments) returns. OPTION-DESC-LIST is a
|
|
list of option descriptions. Each option description must satisfy the
|
|
following grammar:
|
|
|
|
<option-spec> :: (<name> . <attribute-ls>)
|
|
<attribute-ls> :: (<attribute> . <attribute-ls>)
|
|
| ()
|
|
<attribute> :: <required-attribute>
|
|
| <arg-required-attribute>
|
|
| <single-char-attribute>
|
|
| <predicate-attribute>
|
|
| <value-attribute>
|
|
<required-attribute> :: (required? <boolean>)
|
|
<single-char-attribute> :: (single-char <char>)
|
|
<value-attribute> :: (value #t)
|
|
(value #f)
|
|
(value optional)
|
|
<predicate-attribute> :: (predicate <1-ary-function>)
|
|
|
|
The procedure returns an alist of option names and values. Each
|
|
option name is a symbol. The option value will be '#t' if no value
|
|
was specified. There is a special item in the returned alist with a
|
|
key of the empty list, (): the list of arguments that are not options
|
|
or option values.
|
|
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."
|
|
(with-fluids ((%program-name (car program-arguments)))
|
|
(let* ((specifications (map parse-option-spec option-desc-list))
|
|
(pair (split-arg-list (cdr program-arguments)))
|
|
(split-ls (car pair))
|
|
(non-split-ls (cdr pair))
|
|
(found/etc (process-options specifications split-ls
|
|
stop-at-first-non-option))
|
|
(found (car found/etc))
|
|
(rest-ls (append (cdr found/etc) non-split-ls)))
|
|
(for-each (lambda (spec)
|
|
(let ((name (option-spec->name spec))
|
|
(val (assq-ref found spec)))
|
|
(and (option-spec->required? spec)
|
|
(or val
|
|
(fatal-error "option must be specified: --~a"
|
|
name)))
|
|
(let ((pred (option-spec->predicate spec)))
|
|
(and pred (pred name val)))))
|
|
specifications)
|
|
(for-each (lambda (spec+val)
|
|
(set-car! spec+val
|
|
(string->symbol (option-spec->name (car spec+val)))))
|
|
found)
|
|
(cons (cons '() rest-ls) found))))
|
|
|
|
(define (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'."
|
|
(or (assq-ref options key) default))
|
|
|
|
;;; getopt-long.scm ends here
|