summaryrefslogtreecommitdiffstats
path: root/glob.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
commitfa3f23105ddcf07c5900de47f19af43d1db1b597 (patch)
treeb2c6cce6b97698098f50cbc78c23fdc0f8d401ab /glob.scm
parentf24b9140d6f74804d5599ec225717d38ca443813 (diff)
downloadslib-fa3f23105ddcf07c5900de47f19af43d1db1b597.tar.gz
slib-fa3f23105ddcf07c5900de47f19af43d1db1b597.zip
Import Upstream version 2c3upstream/2c3
Diffstat (limited to 'glob.scm')
-rw-r--r--glob.scm119
1 files changed, 119 insertions, 0 deletions
diff --git a/glob.scm b/glob.scm
new file mode 100644
index 0000000..5f692b7
--- /dev/null
+++ b/glob.scm
@@ -0,0 +1,119 @@
+;;; glob.scm: String matching for filenames (a la BASH).
+;;; Copyright (C) 1998 Radey Shouman.
+;
+;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.
+
+;;$Header: /usr/local/cvsroot/slib/glob.scm,v 1.2 1998/09/03 15:34:59 jaffer Exp $
+;;$Name: $
+
+(define (glob:match?? pat)
+ (glob:make-matcher pat char-ci=? char=?))
+(define (glob:match-ci?? pat)
+ (glob:make-matcher pat char-ci<=? char<=?))
+
+(define (glob:make-matcher pat ch=? ch<=?)
+ (define (match-end str k)
+ (= k (string-length str)))
+ (define (match-char ch nxt)
+ (lambda (str k)
+ (and (< k (string-length str))
+ (ch=? ch (string-ref str k))
+ (nxt str (+ k 1)))))
+ (define (match-? nxt)
+ (lambda (str k)
+ (and (< k (string-length str))
+ (nxt str (+ k 1)))))
+ (define (match-set1 chrs)
+ (let recur ((i 0))
+ (cond ((= i (string-length chrs))
+ (lambda (ch) #f))
+ ((and (< (+ i 2) (string-length chrs))
+ (char=? #\- (string-ref chrs (+ i 1))))
+ (let ((nxt (recur (+ i 3))))
+ (lambda (ch)
+ (or (and (ch<=? ch (string-ref chrs (+ i 2)))
+ (ch<=? (string-ref chrs i) ch))
+ (nxt ch)))))
+ (else
+ (let ((nxt (recur (+ i 1)))
+ (chrsi (string-ref chrs i)))
+ (lambda (ch)
+ (or (ch=? chrsi ch) (nxt ch))))))))
+ (define (match-set chrs nxt)
+ (if (and (positive? (string-length chrs))
+ (memv (string-ref chrs 0) '(#\^ #\!)))
+ (let ((pred (match-set1 (substring chrs 1 (string-length chrs)))))
+ (lambda (str k)
+ (and (< k (string-length str))
+ (not (pred (string-ref str k)))
+ (nxt str (+ k 1)))))
+ (let ((pred (match-set1 chrs)))
+ (lambda (str k)
+ (and (< k (string-length str))
+ (pred (string-ref str k))
+ (nxt str (+ k 1)))))))
+ (define (match-* nxt)
+ (lambda (str k)
+ (let loop ((kk (string-length str)))
+ (and (>= kk k)
+ (or (nxt str kk)
+ (loop (- kk 1)))))))
+
+ (let ((matcher
+ (let recur ((i 0))
+ (if (= i (string-length pat))
+ match-end
+ (let ((pch (string-ref pat i)))
+ (case pch
+ ((#\?)
+ (let ((nxt (recur (+ i 1))))
+ (match-? nxt)))
+ ((#\*)
+ (let ((nxt (recur (+ i 1))))
+ (match-* nxt)))
+ ((#\[)
+ (let ((j
+ (let search ((j (+ i 2)))
+ (cond
+ ((>= j (string-length pat))
+ (slib:error 'glob:make-matcher
+ "unmatched [" pat))
+ ((char=? #\] (string-ref pat j))
+ (if (and (< (+ j 1) (string-length pat))
+ (char=? #\] (string-ref pat (+ j 1))))
+ (+ j 1)
+ j))
+ (else (search (+ j 1)))))))
+ (let ((nxt (recur (+ j 1))))
+ (match-set (substring pat (+ i 1) j) nxt))))
+ (else (let ((nxt (recur (+ i 1))))
+ (match-char pch nxt)))))))))
+ (lambda (str) (matcher str 0))))
+
+(define filename:match?? glob:match??)
+(define filename:match-ci?? glob:match-ci??)
+
+(define (replace-suffix str old new)
+ (define (cs str)
+ (let* ((len (string-length str))
+ (re (- len (string-length old))))
+ (cond ((string-ci=? old (substring str re len))
+ (string-append (substring str 0 re) new))
+ (else
+ (slib:error 'replace-suffix "suffix doesn't match:"
+ old str)))))
+ (if (string? str) (cs str) (map cs str)))