Changeset 25764 in project for release


Ignore:
Timestamp:
01/05/12 09:50:52 (10 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:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/getopt-long/trunk/getopt-long.scm

    r25419 r25764  
    66;; Ported to Chicken Scheme and extensively modified by Ivan Raikov.
    77;;
    8 ;; Copyright 2009-2011 Ivan Raikov.
     8;; Copyright 2009-2012 Ivan Raikov.
    99;;
    1010;; Portions copyright (C) 1998, 2001, 2006 Free Software Foundation,
     
    182182            (fetch-value kv)))))
    183183
     184
     185(define-record-type  unknown-option
     186  (make-unknown-option name )
     187  unknown-option?
     188  (name        unknown-option-name)
     189  )
     190 
    184191
    185192(define-record-type  value-policy
     
    462469
    463470
    464 (define (long-option? specs a next
    465                       #!key (unknown-option-handler (lambda (x) (error 'long-option? "unknown option" x))))
     471(define (long-option? specs a next)
    466472
    467473  (let ((l (string->list a)))
     
    514520                                  )))
    515521                              (else
    516                                (unknown-option-handler n)))))
     522                               (list next (make-unknown-option n))))))
    517523           (else #f))))
    518524
     
    533539              (else (list ax lst))))))
    534540
    535 (define (short-options? specs a next
    536                         #!key (unknown-option-handler (lambda (x) (error 'short-options? "unknown option" x))))
     541(define (short-options? specs a next)
    537542
    538543  (let ((l (string->list a)))
     
    576581                         (list next (cons name #t)))))))
    577582                  (else
    578                    (unknown-option-handler n1)))))
     583                   (list next (make-unknown-option (->string n1)))))))
    579584               (list next
    580585                     (cons opt1
     
    592597                                   
    593598                                   (else
    594                                     (unknown-option-handler n))))
     599                                    (make-unknown-option (->string n)))))
    595600                                ns)))))
    596601              )
     
    600605 
    601606
    602 (define (process-options specs argument-ls
    603                          #!key (unknown-option-handler (lambda _ #f)))
     607(define (process-options specs argument-ls)
    604608
    605609  ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
     
    608612  ;; options nor their values.
    609613
    610   (let loop ((ls argument-ls)  (found (list)) (etc (list)))
    611 
    612     (if (null? ls) (cons found (reverse etc))
     614  (let loop ((ls argument-ls)  (found (list)) (etc (list)) (unknown (list)))
     615
     616    (if (null? ls)
     617
     618        (list found (reverse etc) (reverse unknown))
    613619
    614620        (let ((arg (car ls)) (rest (cdr ls)))
    615621
    616           (cond ((long-option? specs arg rest
    617                                unknown-option-handler: unknown-option-handler) =>
    618                  (lambda (kont)
    619                    (loop (car kont) (cons (cadr kont) found) etc)))
     622          (cond ((long-option? specs arg rest) =>
     623                 (lambda (next.val)
     624                   (let ((optval (cadr next.val)))
     625                     (if (unknown-option? optval)
     626                         (loop (car next.val) found etc (cons optval unknown))
     627                         (loop (car next.val) (cons optval found) etc unknown)))))
    620628               
    621                 ((short-options? specs arg rest
    622                                  unknown-option-handler: unknown-option-handler) =>
    623                  (lambda (kont)
    624                    (loop (car kont) (append (cadr kont) found) etc)))
     629                ((short-options? specs arg rest) =>
     630                 (lambda (next.vals)
     631                   (let-values (((unknowns optvals) (partition unknown-option? (cadr next.vals))))
     632                     (loop (car next.vals) (append optvals found) etc (append unknowns unknown)))))
    625633
    626634                (else
    627                  (loop (cdr ls) found (cons (car ls) etc))))))))
     635                 (loop (cdr ls) found (cons (car ls) etc) unknown)))))))
    628636                                 
    629637
    630638
    631639(define (getopt-long program-arguments option-desc-list
    632                      #!key (unknown-option-handler (lambda _ #f)))
     640                     #!key (unknown-option-handler (lambda (x) (error 'getopt-long "unknown options" x))))
    633641
    634642;;
     
    679687                                       spec)))
    680688                          specifications))
    681          (pair           (split-argument-list program-arguments))
    682          (split-ls       (car pair))
    683          (non-split-ls   (cdr pair))
    684          (found/etc      (process-options
    685                           (list spec-long spec-short) split-ls
    686                           unknown-option-handler: unknown-option-handler))
    687          (found          (car found/etc))
    688          (rest-ls        (append (cdr found/etc) non-split-ls)))
     689
     690         (pair            (split-argument-list program-arguments))
     691         (split-ls        (car pair))
     692         (non-split-ls    (cdr pair)))
     693
     694    (match-let (((found etc unknown)
     695                 (process-options (list spec-long spec-short) split-ls)))
     696
     697
     698       (let ((rest-ls (append etc non-split-ls)))
    689699   
    690     (for-each (lambda (spec)
    691                 (let ((name (option-spec-name spec)))
    692 
    693                   (and (option-spec-required? spec)
    694                        (or (assoc name found )
    695                            (error "option must be specified" name)))
    696 
    697                   (and (assoc name found)
    698 
    699                        (and (option-spec-value spec)
    700                             (not (value-policy-optional?
    701                                   (option-spec-value spec))))
    702 
    703                        (or (cdr (assoc name found))
    704                            (error "option must be specified with argument"
    705                                   name)))))
    706               specifications)
    707 
    708     (cons (cons '@ rest-ls) found)))
     700         (for-each (lambda (spec)
     701                     (let ((name (option-spec-name spec)))
     702                       
     703                       (and (option-spec-required? spec)
     704                            (or (assoc name found )
     705                                (error "option must be specified" name)))
     706                       
     707                       (and (assoc name found)
     708                           
     709                            (and (option-spec-value spec)
     710                                 (not (value-policy-optional?
     711                                       (option-spec-value spec))))
     712                           
     713                            (or (cdr (assoc name found))
     714                                (error "option must be specified with argument"
     715                                       name)))))
     716                   specifications)
     717
     718
     719
     720       (values
     721        (cons (cons '@ rest-ls) found)
     722        (or (and (not (null? unknown))
     723                 (unknown-option-handler (map unknown-option-name unknown)))
     724            '()))
     725       ))
     726    ))
    709727
    710728(define (make-option-dispatch opts options-desc-list)
  • release/4/getopt-long/trunk/tests/run.scm

    r25419 r25764  
    146146
    147147    (test
    148      'unknown
    149      (getopt-long '("-u") grammar2
    150                   unknown-option-handler: (lambda (x) 'unknown))
    151      )
     148     (list "u")
     149     (let-values (((_ unknown)
     150                   (getopt-long '("-u") grammar2 unknown-option-handler: (lambda (x) x))))
     151       unknown))
    152152   
    153153    )
Note: See TracChangeset for help on using the changeset viewer.