diff options
author | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:27 -0800 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:27 -0800 |
commit | fa3f23105ddcf07c5900de47f19af43d1db1b597 (patch) | |
tree | b2c6cce6b97698098f50cbc78c23fdc0f8d401ab /glob.scm | |
parent | f24b9140d6f74804d5599ec225717d38ca443813 (diff) | |
download | slib-fa3f23105ddcf07c5900de47f19af43d1db1b597.tar.gz slib-fa3f23105ddcf07c5900de47f19af43d1db1b597.zip |
Import Upstream version 2c3upstream/2c3
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))) |