Import Upstream version 2c3upstream/2c3

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)))