Hello,
Please find attached a first draft of a patch for getopt-long that will
cause it to throw errors, instead of simply exiting, when an additional
keyword argument is passed to `getopt-long`.
Libraries may want to catch errors in `getopt-long` and process those
errors themselves, but we do not want to break backward compatibility.
This patch addresses both those concerns.
I have carried out testing using the updated file, using different
personal projects and test scripts, but I must confess I had real
trouble running the test suite for getopt-long from a git checkout,
using that Git checkout's Guile.
In the end I also ran the test suite by using my system's Guile and
placing the updated getopt-long in GUILE_LOAD_PATH. Doing this caused
the getopt-long test suite to run with the new file, and pass.
Please let me know if you spot any problems, have concerns or if I need
to do anything else before we can consider pushing this to master.
Best wishes,
alx
PS: I have not yet committed code to GNU projects that assign copyright
to the FSF — and I'm not sure whether Guile does so — but if needed I'd
be happy to assign copyright.
>From ca68d19528a21fec4bde269be261eff123709ac4 Mon Sep 17 00:00:00 2001
From: Alex Sassmannshausen <alex.sassmannshau...@gmail.com>
Date: Wed, 10 Feb 2016 13:16:38 +0100
Subject: [PATCH] Make getopt-long throw errors if requested.
Getopt-long thus far simply prints a user message and exits if it
encounters an error in either the option specification, or in the
processing of command-line options. This is not desirable when
libraries are built using the getopt-long library: they will want to
catch errors thrown by getopt-long, and handle those errors with their
own logic. This patch implements optional error throwing.
* module/ice-9/getopt-long.scm (parse-option-spec, process-options):
Take additional `throw-errors' argument. Throw errors if present.
(getopt-long): Update doc string. Pass `throw-errors' to helper
procedures. Throw errors if present.
---
module/ice-9/getopt-long.scm | 69 ++++++++++++++++++++++++++++++--------------
1 file changed, 48 insertions(+), 21 deletions(-)
diff --git a/module/ice-9/getopt-long.scm b/module/ice-9/getopt-long.scm
index 14eaf8e..dc74e62 100644
--- a/module/ice-9/getopt-long.scm
+++ b/module/ice-9/getopt-long.scm
@@ -159,6 +159,7 @@
(define-module (ice-9 getopt-long)
#:use-module ((ice-9 common-list) #:select (remove-if-not))
#:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 optargs)
@@ -191,7 +192,7 @@
(define (make-option-spec name)
(%make-option-spec name #f #f #f #f))
-(define (parse-option-spec desc)
+(define (parse-option-spec desc throw-errors)
(let ((spec (make-option-spec (symbol->string (car desc)))))
(for-each (match-lambda
(('required? val)
@@ -200,17 +201,20 @@
(set-option-spec-value-policy! spec val))
(('single-char val)
(or (char? val)
- (error "`single-char' value must be a char!"))
+ (throw 'getopt-long-spec-single-char
+ "`single-char' value must be a char:" val))
(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)))))
+ (if throw-errors
+ (throw 'getopt-long 'predicate-failed name)
+ (fatal-error "option predicate failed: --~a"
+ name))))))
((prop val)
- (error "invalid getopt-long option property:" prop)))
+ (throw 'getopt-long 'property-invalid prop)))
(cdr desc))
spec))
@@ -231,7 +235,8 @@
(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)
+(define (process-options specs argument-ls stop-at-first-non-option
+ throw-errors)
;; 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
@@ -254,8 +259,11 @@
((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))
+ (if throw-errors
+ (throw 'getopt-long 'opt-missing-arg
+ (option-spec->name spec))
+ (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))))
@@ -271,7 +279,10 @@
;; 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))))
+ (if throw-errors
+ (throw 'getopt-long 'no-option c)
+ (fatal-error "no such option: -~a"
+ c)))))
(eat! spec rest))
;; Expand a clumped group of short options.
(let* ((extra (match:substring match 2))
@@ -289,17 +300,26 @@
=> (lambda (match)
(let* ((opt (match:substring match 1))
(spec (or (assoc-ref idx opt)
- (fatal-error "no such option: --~a" opt))))
+ (if throw-errors
+ (throw 'getopt-long 'no-option 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)))))
+ (if throw-errors
+ (throw 'getopt-long 'no-option opt)
+ (fatal-error "no such option: --~a"
+ opt)))))
+ (cond ((option-spec->value-policy spec)
+ (eat! spec (cons (match:substring match 2) rest)))
+ (throw-errors
+ (throw 'getopt-long 'opt-arg-not-supported opt))
+ (else
+ (fatal-error "option does not support argument: --~a"
+ opt))))))
((and stop-at-first-non-option
(<= unclumped 0))
(cons found (append (reverse etc) argument-ls)))
@@ -307,7 +327,7 @@
(loop (- unclumped 1) rest found (cons opt etc)))))))))
(define* (getopt-long program-arguments option-desc-list
- #:key stop-at-first-non-option)
+ #:key stop-at-first-non-option throw-errors)
"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
@@ -337,14 +357,19 @@ 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."
+to add a `single-char' clause to the option description.
+ Specifying the boolean `throw-errors' keyword option will cause
+getopt-long to throw errors instead of emitting a message and exiting
+when an error is encountered."
(with-fluids ((%program-name (car program-arguments)))
- (let* ((specifications (map parse-option-spec option-desc-list))
+ (let* ((specifications (map (cut parse-option-spec <> throw-errors)
+ 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))
+ stop-at-first-non-option
+ throw-errors))
(found (car found/etc))
(rest-ls (append (cdr found/etc) non-split-ls)))
(for-each (lambda (spec)
@@ -352,8 +377,10 @@ to add a `single-char' clause to the option description."
(val (assq-ref found spec)))
(and (option-spec->required? spec)
(or val
- (fatal-error "option must be specified: --~a"
- name)))
+ (if throw-errors
+ (throw 'getopt-long 'opt-required name)
+ (fatal-error "option must be specified: --~a"
+ name))))
(let ((pred (option-spec->predicate spec)))
(and pred (pred name val)))))
specifications)
--
2.6.3
