getopt-long.scm

MSYS在windows下模拟了一个类unix的终端

                    ((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)
  ;; 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 (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
                                       ;; handle multiple occurrances
                                       (cond ((option-spec->value spec)
                                              => (lambda (cur)
                                                   ((if (list? cur) cons list)
                                                    val cur)))
                                             (else 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
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."
  (let* ((specifications (map parse-option-spec option-desc-list))
	 (pair (split-arg-list (cdr program-arguments)))
	 (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)
          (let ((multi-count (map (lambda (desc)
                                    (cons (car desc) 0))
                                  option-desc-list)))
            (map (lambda (spec)
                   (let ((name (string->symbol (option-spec->name spec))))
                     (cons name
                           ;; handle multiple occurrances
                           (let ((maybe-ls (option-spec->value spec)))
                             (if (list? maybe-ls)
                                 (let* ((look (assq name multi-count))
                                        (idx (cdr look))
                                        (val (list-ref maybe-ls idx)))
                                   (set-cdr! look (1+ idx)) ; ugh!
                                   val)
                                 maybe-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