summaryrefslogtreecommitdiffstats
path: root/getopt.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commit8ffbc2df0fde83082610149d24e594c1cd879f4a (patch)
treea2be9aad5101c5e450ad141d15c514bc9c2a2963 /getopt.scm
downloadslib-8ffbc2df0fde83082610149d24e594c1cd879f4a.tar.gz
slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.zip
Import Upstream version 2a6upstream/2a6
Diffstat (limited to 'getopt.scm')
-rw-r--r--getopt.scm80
1 files changed, 80 insertions, 0 deletions
diff --git a/getopt.scm b/getopt.scm
new file mode 100644
index 0000000..c2962db
--- /dev/null
+++ b/getopt.scm
@@ -0,0 +1,80 @@
+;;; "getopt.scm" POSIX command argument processing
+;Copyright (C) 1993, 1994 Aubrey Jaffer
+;
+;Permission to copy this software, to redistribute it, and to use it
+;for any purpose is granted, subject to the following restrictions and
+;understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(define getopt:scan #f)
+(define getopt:char #\-)
+(define getopt:opt #f)
+(define *optind* 1)
+(define *optarg* 0)
+
+(define (getopt argc argv optstring)
+ (let ((opts (string->list optstring))
+ (place #f)
+ (arg #f)
+ (argref (lambda () ((if (vector? argv) vector-ref list-ref)
+ argv *optind*))))
+ (and
+ (cond ((and getopt:scan (not (string=? "" getopt:scan))) #t)
+ ((>= *optind* argc) #f)
+ (else
+ (set! arg (argref))
+ (cond ((or (<= (string-length arg) 1)
+ (not (char=? (string-ref arg 0) getopt:char)))
+ #f)
+ ((and (= (string-length arg) 2)
+ (char=? (string-ref arg 1) getopt:char))
+ (set! *optind* (+ *optind* 1))
+ #f)
+ (else
+ (set! getopt:scan
+ (substring arg 1 (string-length arg)))
+ #t))))
+ (begin
+ (set! getopt:opt (string-ref getopt:scan 0))
+ (set! getopt:scan
+ (substring getopt:scan 1 (string-length getopt:scan)))
+ (if (string=? "" getopt:scan) (set! *optind* (+ *optind* 1)))
+ (set! place (member getopt:opt opts))
+ (cond ((not place) #\?)
+ ((or (null? (cdr place)) (not (char=? #\: (cadr place))))
+ getopt:opt)
+ ((not (string=? "" getopt:scan))
+ (set! *optarg* getopt:scan)
+ (set! *optind* (+ *optind* 1))
+ (set! getopt:scan #f)
+ getopt:opt)
+ ((< *optind* argc)
+ (set! *optarg* (argref))
+ (set! *optind* (+ *optind* 1))
+ getopt:opt)
+ ((and (not (null? opts)) (char=? #\: (car opts))) #\:)
+ (else #\?))))))
+
+(define (getopt-- argc argv optstring)
+ (let* ((opt (getopt argc argv (string-append optstring "-:")))
+ (optarg *optarg*))
+ (cond ((eqv? #\- opt) ;long option
+ (do ((l (string-length *optarg*))
+ (i 0 (+ 1 i)))
+ ((or (>= i l) (char=? #\= (string-ref optarg i)))
+ (cond
+ ((>= i l) (set! *optarg* #f) optarg)
+ (else (set! *optarg* (substring optarg (+ 1 i) l))
+ (substring optarg 0 i))))))
+ (else opt))))