1;;; args-fold.scm - a program argument processor 2;;; 3;;; Copyright (c) 2002 Anthony Carrico 4;;; 5;;; All rights reserved. 6;;; 7;;; Redistribution and use in source and binary forms, with or without 8;;; modification, are permitted provided that the following conditions 9;;; are met: 10;;; 1. Redistributions of source code must retain the above copyright 11;;; notice, this list of conditions and the following disclaimer. 12;;; 2. Redistributions in binary form must reproduce the above copyright 13;;; notice, this list of conditions and the following disclaimer in the 14;;; documentation and/or other materials provided with the distribution. 15;;; 3. The name of the authors may not be used to endorse or promote products 16;;; derived from this software without specific prior written permission. 17;;; 18;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 19;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 20;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 21;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, 22;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 23;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 24;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 25;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 26;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 27;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 29;;; Modified by Shiro Kawai to adapt to Gauche 30;;; * Module stuff added. 31;;; * Replaced a srfi-9 record type for a class. 32;;; * Replaced some expressions to utilize Gauche's native features. 33 34(define-module srfi-37 35 (use srfi-1) 36 (use srfi-11) 37 (export option option-names option-required-arg? option-optional-arg? 38 option-processor option? args-fold) 39 ) 40(select-module srfi-37) 41 42(define-class <option-type> () 43 ((names :init-keyword :names :getter option-names) 44 (required-arg? :init-keyword :required-arg? :getter option-required-arg?) 45 (optional-arg? :init-keyword :optional-arg? :getter option-optional-arg?) 46 (processor :init-keyword :processor :getter option-processor) 47 )) 48 49(define (option names required-arg? optional-arg? processor) 50 (make <option-type> 51 :names names :required-arg? required-arg? 52 :optional-arg? optional-arg? :processor processor)) 53 54(define (option? obj) (is-a? obj <option-type>)) 55 56(define (args-fold args options unrecognized-option-proc operand-proc . seeds) 57 (define (find-option name) 58 (find (^[option] (find (cut equal? name <>) (option-names option))) options)) 59 (define (scan-short-options index shorts args seeds) 60 (if (= index (string-length shorts)) 61 (scan-args args seeds) 62 (let* ([name (string-ref shorts index)] 63 [option (or (find-option name) 64 (option (list name) #f #f 65 unrecognized-option-proc))]) 66 (cond [(and (< (+ index 1) (string-length shorts)) 67 (or (option-required-arg? option) 68 (option-optional-arg? option))) 69 (receive seeds 70 (apply (option-processor option) option name 71 (substring shorts (+ index 1) 72 (string-length shorts)) 73 seeds) 74 (scan-args args seeds))] 75 [(and (option-required-arg? option) 76 (pair? args)) 77 (receive seeds 78 (apply (option-processor option) option name 79 (car args) seeds) 80 (scan-args (cdr args) seeds))] 81 [else 82 (receive seeds 83 (apply (option-processor option) option name #f seeds) 84 (scan-short-options (+ index 1) shorts args seeds))] 85 )))) 86 (define (scan-operands operands seeds) 87 (if (null? operands) 88 (apply values seeds) 89 (receive seeds (apply operand-proc (car operands) seeds) 90 (scan-operands (cdr operands) seeds)))) 91 (define (scan-args args seeds) 92 (if (null? args) 93 (apply values seeds) 94 (let ([arg (car args)] 95 [args (cdr args)]) 96 (cond 97 [(string=? "--" arg) 98 ;; End option scanning: 99 (scan-operands args seeds)] 100 [(#/^--([^=]+)=(.*)$/ arg) 101 ;; Found long option with arg: 102 => (^m (let*-values ([(name) (m 1)] 103 [(option-arg) (m 2)] 104 [(option) 105 (or (find-option name) 106 (option (list name) #t #f 107 unrecognized-option-proc))] 108 [seeds 109 (apply (option-processor option) option name 110 option-arg seeds)]) 111 (scan-args args seeds)))] 112 [(#/^--(.+)$/ arg) 113 ;; Found long option: 114 => (^m (let* ([name (m 1)] 115 [option (or (find-option name) 116 (option (list name) #f #f 117 unrecognized-option-proc))]) 118 [if (and (option-required-arg? option) 119 (pair? args)) 120 (receive seeds 121 (apply (option-processor option) option name 122 (car args) seeds) 123 (scan-args (cdr args) seeds)) 124 (receive seeds 125 (apply (option-processor option) option name 126 #f seeds) 127 (scan-args args seeds))]))] 128 [(#/^-(.+)$/ arg) 129 ;; Found short options 130 => (^m (scan-short-options 0 (m 1) args seeds))] 131 [else 132 (receive seeds (apply operand-proc arg seeds) 133 (scan-args args seeds))] 134 ) 135 ))) 136 (scan-args args seeds)) 137 138