guile-devel
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Getopt-long patch


From: Alex Sassmannshausen
Subject: Getopt-long patch
Date: Sun, 14 Feb 2016 16:20:33 +0100
User-agent: mu4e 0.9.13; emacs 24.5.1

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 <address@hidden>
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


reply via email to

[Prev in Thread] Current Thread [Next in Thread]