artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

mes: getopt-long: Support stop-at-first-non-option.

Browse source 
* module/mes/getopt-long.scm (process-options): Fix parsing `-'.  Add
  parameter: stop-at-first-non-option.
  (getopt-long): Add keyword parameter #:stop-at-first-non-option.
This commit is contained in:
Jan Nieuwenhuizen 2018-04-22 11:49:30 +02:00
parent bb45012c39
commit a26eae418b
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
2 changed files with 10 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
module/mes/getopt-long.mes
View file

@ -25,5 +25,6 @@
(mes-use-module (srfi srfi-1)) (mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-9)) (mes-use-module (srfi srfi-9))
(mes-use-module (srfi srfi-13)) (mes-use-module (srfi srfi-13))
(mes-use-module (mes optargs))
(define-macro (define-module module . rest) #t) (define-macro (define-module module . rest) #t)
(include-from-path "mes/getopt-long.scm") (include-from-path "mes/getopt-long.scm")

13
module/mes/getopt-long.scm
View file

@ -160,6 +160,7 @@
;;; Code: ;;; Code:
(define-module (mes getopt-long) (define-module (mes getopt-long)
#:use-module (ice-9 optargs)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:export (getopt-long option-ref)) #:export (getopt-long option-ref))
@ -249,7 +250,7 @@
(define (looks-like-an-option string) (define (looks-like-an-option string)
(eq? (string-ref string 0) #\-)) (eq? (string-ref string 0) #\-))
(define (process-options specs argument-ls) (define (process-options specs argument-ls stop-at-first-non-option)
;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC). ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
;; FOUND is an unordered list of option specs for found options, while 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 ;; is an order-maintained list of elements in ARGUMENT-LS that are neither
@ -308,6 +309,7 @@
(cons found (reverse etc)) ;;; retval (cons found (reverse etc)) ;;; retval
(cond ((let ((opt (car argument-ls))) (cond ((let ((opt (car argument-ls)))
(and (eq? (string-ref opt 0) #\-) (and (eq? (string-ref opt 0) #\-)
(> (string-length opt) 1)
(let ((n (char->integer (string-ref opt 1)))) (let ((n (char->integer (string-ref opt 1))))
(or (and (>= n (char->integer #\A)) (<= n (char->integer #\Z))) (or (and (>= n (char->integer #\A)) (<= n (char->integer #\Z)))
(and (>= n (char->integer #\a)) (<= n (char->integer #\z))))))) (and (>= n (char->integer #\a)) (<= n (char->integer #\z)))))))
@ -345,12 +347,14 @@
(cdr argument-ls))) (cdr argument-ls)))
(error "option does not support argument:" (error "option does not support argument:"
opt)))) opt))))
(stop-at-first-non-option
(cons found (append (reverse etc) argument-ls)))
(else (else
(loop (cdr argument-ls) (loop (cdr argument-ls)
found found
(cons (car argument-ls) etc))))))))) (cons (car argument-ls) etc)))))))))
(define (getopt-long program-arguments option-desc-list) (define* (getopt-long program-arguments option-desc-list #:key stop-at-first-non-option)
"Process options, handling both long and short options, similar to "Process options, handling both long and short options, similar to
the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a value the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a value
similar to what (program-arguments) returns. OPTION-DESC-LIST is a similar to what (program-arguments) returns. OPTION-DESC-LIST is a
@ -382,10 +386,11 @@ 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 (expand-clumped-singles (car pair))) (split-ls (expand-clumped-singles (car pair)))
(non-split-ls (cdr pair)) (non-split-ls (cdr pair))
(found/etc (process-options specifications split-ls)) (found/etc (process-options specifications split-ls
stop-at-first-non-option))
(found (car found/etc)) (found (car found/etc))
(rest-ls (append (cdr found/etc) non-split-ls))) (rest-ls (append (cdr found/etc) non-split-ls)))
(for-each (lambda (spec) (for-each (lambda (spec)