Changeset 25764 in project

Timestamp:

01/05/12 09:50:52 (9 years ago)

Author:

Ivan Raikov

Message:

getopt-long: modifications to allow for user-provided handler for unknown options

Location:

release/4/getopt-long/trunk

Files:

• getopt-long.scm (modified) (10 diffs)
• tests/run.scm (modified) (1 diff)

release/4/getopt-long/trunk/getopt-long.scm

@@ -6 +6 @@
 ;; Ported to Chicken Scheme and extensively modified by Ivan Raikov.
 ;;
-;; Copyright 2009-2011 Ivan Raikov.
+;; Copyright 2009-2012 Ivan Raikov.
 ;;
 ;; Portions copyright (C) 1998, 2001, 2006 Free Software Foundation,
@@ -182 +182 @@
             (fetch-value kv)))))
 
+
+(define-record-type  unknown-option
+  (make-unknown-option name )
+  unknown-option?
+  (name        unknown-option-name)
+  )
+  
 
 (define-record-type  value-policy
@@ -462 +469 @@
 
 
-(define (long-option? specs a next 
-                      #!key (unknown-option-handler (lambda (x) (error 'long-option? "unknown option" x))))
+(define (long-option? specs a next)
 
   (let ((l (string->list a)))
@@ -514 +520 @@
                                   )))
                               (else 
-                               (unknown-option-handler n)))))
+                               (list next (make-unknown-option n))))))
            (else #f))))
 
@@ -533 +539 @@
               (else (list ax lst))))))
 
-(define (short-options? specs a next
-                        #!key (unknown-option-handler (lambda (x) (error 'short-options? "unknown option" x))))
+(define (short-options? specs a next)
 
   (let ((l (string->list a)))
@@ -576 +581 @@
                          (list next (cons name #t)))))))
                   (else
-                   (unknown-option-handler n1)))))
+                   (list next (make-unknown-option (->string n1)))))))
                (list next 
                      (cons opt1 
@@ -592 +597 @@
                                    
                                    (else 
-                                    (unknown-option-handler n))))
+                                    (make-unknown-option (->string n)))))
                                 ns)))))
               )
@@ -600 +605 @@
   
 
-(define (process-options specs argument-ls
-                         #!key (unknown-option-handler (lambda _ #f)))
+(define (process-options specs argument-ls)
 
   ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
@@ -608 +612 @@
   ;; options nor their values.
 
-  (let loop ((ls argument-ls)  (found (list)) (etc (list)))
-
-    (if (null? ls) (cons found (reverse etc))
+  (let loop ((ls argument-ls)  (found (list)) (etc (list)) (unknown (list)))
+
+    (if (null? ls) 
+
+        (list found (reverse etc) (reverse unknown))
 
         (let ((arg (car ls)) (rest (cdr ls)))
 
-          (cond ((long-option? specs arg rest 
-                               unknown-option-handler: unknown-option-handler) =>
-                 (lambda (kont)
-                   (loop (car kont) (cons (cadr kont) found) etc)))
+          (cond ((long-option? specs arg rest) =>
+                 (lambda (next.val)
+                   (let ((optval (cadr next.val)))
+                     (if (unknown-option? optval)
+                         (loop (car next.val) found etc (cons optval unknown))
+                         (loop (car next.val) (cons optval found) etc unknown)))))
                 
-                ((short-options? specs arg rest
-                                 unknown-option-handler: unknown-option-handler) =>
-                 (lambda (kont)
-                   (loop (car kont) (append (cadr kont) found) etc)))
+                ((short-options? specs arg rest) =>
+                 (lambda (next.vals)
+                   (let-values (((unknowns optvals) (partition unknown-option? (cadr next.vals))))
+                     (loop (car next.vals) (append optvals found) etc (append unknowns unknown)))))
 
                 (else 
-                 (loop (cdr ls) found (cons (car ls) etc))))))))
+                 (loop (cdr ls) found (cons (car ls) etc) unknown)))))))
                                  
 
 
 (define (getopt-long program-arguments option-desc-list 
-                     #!key (unknown-option-handler (lambda _ #f)))
+                     #!key (unknown-option-handler (lambda (x) (error 'getopt-long "unknown options" x))))
 
 ;;
@@ -679 +687 @@
                                        spec)))
                           specifications))
-         (pair           (split-argument-list program-arguments))
-         (split-ls       (car pair))
-         (non-split-ls   (cdr pair))
-         (found/etc      (process-options
-                          (list spec-long spec-short) split-ls
-                          unknown-option-handler: unknown-option-handler))
-         (found          (car found/etc))
-         (rest-ls        (append (cdr found/etc) non-split-ls)))
+
+         (pair            (split-argument-list program-arguments))
+         (split-ls        (car pair))
+         (non-split-ls    (cdr pair)))
+
+    (match-let (((found etc unknown)
+                 (process-options (list spec-long spec-short) split-ls)))
+
+
+       (let ((rest-ls (append etc non-split-ls)))
     
-    (for-each (lambda (spec)
-                (let ((name (option-spec-name spec)))
-
-                  (and (option-spec-required? spec)
-                       (or (assoc name found )
-                           (error "option must be specified" name)))
-
-                  (and (assoc name found)
-
-                       (and (option-spec-value spec)
-                            (not (value-policy-optional?
-                                  (option-spec-value spec))))
-
-                       (or (cdr (assoc name found))
-                           (error "option must be specified with argument"
-                                  name)))))
-              specifications)
-
-    (cons (cons '@ rest-ls) found)))
+         (for-each (lambda (spec)
+                     (let ((name (option-spec-name spec)))
+                       
+                       (and (option-spec-required? spec)
+                            (or (assoc name found )
+                                (error "option must be specified" name)))
+                       
+                       (and (assoc name found)
+                            
+                            (and (option-spec-value spec)
+                                 (not (value-policy-optional?
+                                       (option-spec-value spec))))
+                            
+                            (or (cdr (assoc name found))
+                                (error "option must be specified with argument"
+                                       name)))))
+                   specifications)
+
+
+
+       (values 
+        (cons (cons '@ rest-ls) found)
+        (or (and (not (null? unknown)) 
+                 (unknown-option-handler (map unknown-option-name unknown)))
+            '()))
+       ))
+    ))
 
 (define (make-option-dispatch opts options-desc-list)

release/4/getopt-long/trunk/tests/run.scm

@@ -146 +146 @@
 
     (test
-     'unknown
-     (getopt-long '("-u") grammar2 
-                  unknown-option-handler: (lambda (x) 'unknown))
-     )
+     (list "u")
+     (let-values (((_ unknown)
+                   (getopt-long '("-u") grammar2 unknown-option-handler: (lambda (x) x))))
+       unknown))
     
     )