Commit | Line | Data |
---|---|---|
9ddacf86 KN |
1 | ;;; "getopt.scm" POSIX command argument processing |
2 | ;Copyright (C) 1993, 1994 Aubrey Jaffer | |
3 | ; | |
4 | ;Permission to copy this software, to redistribute it, and to use it | |
5 | ;for any purpose is granted, subject to the following restrictions and | |
6 | ;understandings. | |
7 | ; | |
8 | ;1. Any copy made of this software must include this copyright notice | |
9 | ;in full. | |
10 | ; | |
11 | ;2. I have made no warrantee or representation that the operation of | |
12 | ;this software will be error-free, and I am under no obligation to | |
13 | ;provide any services, by way of maintenance, update, or otherwise. | |
14 | ; | |
15 | ;3. In conjunction with products arising from the use of this | |
16 | ;material, there shall be no use of my name in any advertising, | |
17 | ;promotional, or sales literature without prior written consent in | |
18 | ;each case. | |
19 | ||
20 | (define getopt:scan #f) | |
21 | (define getopt:char #\-) | |
22 | (define getopt:opt #f) | |
23 | (define *optind* 1) | |
24 | (define *optarg* 0) | |
25 | ||
26 | (define (getopt argc argv optstring) | |
27 | (let ((opts (string->list optstring)) | |
28 | (place #f) | |
29 | (arg #f) | |
30 | (argref (lambda () ((if (vector? argv) vector-ref list-ref) | |
31 | argv *optind*)))) | |
32 | (and | |
33 | (cond ((and getopt:scan (not (string=? "" getopt:scan))) #t) | |
34 | ((>= *optind* argc) #f) | |
35 | (else | |
36 | (set! arg (argref)) | |
37 | (cond ((or (<= (string-length arg) 1) | |
38 | (not (char=? (string-ref arg 0) getopt:char))) | |
39 | #f) | |
40 | ((and (= (string-length arg) 2) | |
41 | (char=? (string-ref arg 1) getopt:char)) | |
42 | (set! *optind* (+ *optind* 1)) | |
43 | #f) | |
44 | (else | |
45 | (set! getopt:scan | |
46 | (substring arg 1 (string-length arg))) | |
47 | #t)))) | |
48 | (begin | |
49 | (set! getopt:opt (string-ref getopt:scan 0)) | |
50 | (set! getopt:scan | |
51 | (substring getopt:scan 1 (string-length getopt:scan))) | |
52 | (if (string=? "" getopt:scan) (set! *optind* (+ *optind* 1))) | |
53 | (set! place (member getopt:opt opts)) | |
54 | (cond ((not place) #\?) | |
55 | ((or (null? (cdr place)) (not (char=? #\: (cadr place)))) | |
56 | getopt:opt) | |
57 | ((not (string=? "" getopt:scan)) | |
58 | (set! *optarg* getopt:scan) | |
59 | (set! *optind* (+ *optind* 1)) | |
60 | (set! getopt:scan #f) | |
61 | getopt:opt) | |
62 | ((< *optind* argc) | |
63 | (set! *optarg* (argref)) | |
64 | (set! *optind* (+ *optind* 1)) | |
65 | getopt:opt) | |
66 | ((and (not (null? opts)) (char=? #\: (car opts))) #\:) | |
67 | (else #\?)))))) | |
68 | ||
69 | (define (getopt-- argc argv optstring) | |
70 | (let* ((opt (getopt argc argv (string-append optstring "-:"))) | |
71 | (optarg *optarg*)) | |
72 | (cond ((eqv? #\- opt) ;long option | |
73 | (do ((l (string-length *optarg*)) | |
74 | (i 0 (+ 1 i))) | |
75 | ((or (>= i l) (char=? #\= (string-ref optarg i))) | |
76 | (cond | |
77 | ((>= i l) (set! *optarg* #f) optarg) | |
78 | (else (set! *optarg* (substring optarg (+ 1 i) l)) | |
79 | (substring optarg 0 i)))))) | |
80 | (else opt)))) |