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