diff options
author | David N. Welton <davidw@efn.org> | 1998-11-09 21:18:01 -0800 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:27 -0800 |
commit | 926b1b647ac830660933a5e63eb52d4a2552e264 (patch) | |
tree | e25db5f6e1441d67f5d9af063432018ee20a5f51 /glob.scm | |
parent | b21cac3362022718634f7086964208b2eed8e897 (diff) | |
parent | fa3f23105ddcf07c5900de47f19af43d1db1b597 (diff) | |
download | slib-926b1b647ac830660933a5e63eb52d4a2552e264.tar.gz slib-926b1b647ac830660933a5e63eb52d4a2552e264.zip |
Import Debian changes 2c3-3debian/2c3-3
slib (2c3-3) frozen unstable; urgency=low
* Fixes #16235.
* Fixes #19943.
* Fixes #20265.
* Fixes #24917.
* Fixes #27389.
slib (2c3-2) frozen unstable; urgency=low
* Re-uploaded for slink freeze.
slib (2c3-1) unstable; urgency=low
* New upstream release.
Diffstat (limited to 'glob.scm')
-rw-r--r-- | glob.scm | 119 |
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))) |