summaryrefslogtreecommitdiffstats
path: root/glob.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
commitbd9733926076885e3417b74de76e4c9c7bc56254 (patch)
tree2c99dced547d48407ad44cb0e45e31bb4d02ce43 /glob.scm
parentfa3f23105ddcf07c5900de47f19af43d1db1b597 (diff)
downloadslib-bd9733926076885e3417b74de76e4c9c7bc56254.tar.gz
slib-bd9733926076885e3417b74de76e4c9c7bc56254.zip
Import Upstream version 2c7upstream/2c7
Diffstat (limited to 'glob.scm')
-rw-r--r--glob.scm246
1 files changed, 177 insertions, 69 deletions
diff --git a/glob.scm b/glob.scm
index 5f692b7..0029243 100644
--- a/glob.scm
+++ b/glob.scm
@@ -1,4 +1,4 @@
-;;; glob.scm: String matching for filenames (a la BASH).
+;;; "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
@@ -17,26 +17,68 @@
;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 $
+;;$Header: /usr/local/cvsroot/slib/glob.scm,v 1.15 1999/11/01 01:37:08 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:pattern->tokens pat)
+ (cond
+ ((string? pat)
+ (let loop ((i 0)
+ (toks '()))
+ (if (>= i (string-length pat))
+ (reverse toks)
+ (let ((pch (string-ref pat i)))
+ (case pch
+ ((#\? #\*)
+ (loop (+ i 1)
+ (cons (substring pat i (+ i 1)) toks)))
+ ((#\[)
+ (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)))))))
+ (loop (+ j 1) (cons (substring pat i (+ j 1)) toks))))
+ (else
+ (let search ((j (+ i 1)))
+ (cond ((= j (string-length pat))
+ (loop j (cons (substring pat i j) toks)))
+ ((memv (string-ref pat j) '(#\? #\* #\[))
+ (loop j (cons (substring pat i j) toks)))
+ (else (search (+ j 1)))))))))))
+ ((pair? pat)
+ (for-each (lambda (elt) (or (string? elt)
+ (slib:error 'glob:pattern->tokens
+ "bad pattern" pat)))
+ pat)
+ pat)
+ (else (slib:error 'glob:pattern->tokens "bad pattern" pat))))
(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-end str k kmatch)
+ (and (= k (string-length str)) (reverse (cons k kmatch))))
+ (define (match-str pstr nxt)
+ (let ((plen (string-length pstr)))
+ (lambda (str k kmatch)
+ (and (<= (+ k plen) (string-length str))
+ (let loop ((i 0))
+ (cond ((= i plen)
+ (nxt str (+ k plen) (cons k kmatch)))
+ ((ch=? (string-ref pstr i)
+ (string-ref str (+ k i)))
+ (loop (+ i 1)))
+ (else #f)))))))
(define (match-? nxt)
- (lambda (str k)
+ (lambda (str k kmatch)
(and (< k (string-length str))
- (nxt str (+ k 1)))))
+ (nxt str (+ k 1) (cons k kmatch)))))
(define (match-set1 chrs)
(let recur ((i 0))
(cond ((= i (string-length chrs))
@@ -53,67 +95,133 @@
(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-set tok nxt)
+ (let ((chrs (substring tok 1 (- (string-length tok) 1))))
+ (if (and (positive? (string-length chrs))
+ (memv (string-ref chrs 0) '(#\^ #\!)))
+ (let ((pred (match-set1 (substring chrs 1 (string-length chrs)))))
+ (lambda (str k kmatch)
+ (and (< k (string-length str))
+ (not (pred (string-ref str k)))
+ (nxt str (+ k 1) (cons k kmatch)))))
+ (let ((pred (match-set1 chrs)))
+ (lambda (str k kmatch)
+ (and (< k (string-length str))
+ (pred (string-ref str k))
+ (nxt str (+ k 1) (cons k kmatch))))))))
(define (match-* nxt)
- (lambda (str k)
- (let loop ((kk (string-length str)))
- (and (>= kk k)
- (or (nxt str kk)
- (loop (- kk 1)))))))
+ (lambda (str k kmatch)
+ (let ((kmatch (cons k kmatch)))
+ (let loop ((kk (string-length str)))
+ (and (>= kk k)
+ (or (nxt str kk kmatch)
+ (loop (- kk 1))))))))
(let ((matcher
- (let recur ((i 0))
- (if (= i (string-length pat))
+ (let recur ((toks (glob:pattern->tokens pat)))
+ (if (null? toks)
match-end
- (let ((pch (string-ref pat i)))
+ (let ((pch (or (string=? (car toks) "")
+ (string-ref (car toks) 0))))
(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))))
+ ((#\?) (match-? (recur (cdr toks))))
+ ((#\*) (match-* (recur (cdr toks))))
+ ((#\[) (match-set (car toks) (recur (cdr toks))))
+ (else (match-str (car toks) (recur (cdr toks))))))))))
+ (lambda (str) (matcher str 0 '()))))
+
+(define (glob:caller-with-matches pat proc ch=? ch<=?)
+ (define (glob:wildcard? pat)
+ (cond ((string=? pat "") #f)
+ ((memv (string-ref pat 0) '(#\* #\? #\[)) #t)
+ (else #f)))
+ (let* ((toks (glob:pattern->tokens pat))
+ (wild? (map glob:wildcard? toks))
+ (matcher (glob:make-matcher toks ch=? ch<=?)))
+ (lambda (str)
+ (let loop ((inds (matcher str))
+ (wild? wild?)
+ (res '()))
+ (cond ((not inds) #f)
+ ((null? wild?)
+ (apply proc (reverse res)))
+ ((car wild?)
+ (loop (cdr inds)
+ (cdr wild?)
+ (cons (substring str (car inds) (cadr inds)) res)))
+ (else
+ (loop (cdr inds) (cdr wild?) res)))))))
+
+(define (glob:make-substituter pattern template ch=? ch<=?)
+ (define (wildcard? pat)
+ (cond ((string=? pat "") #f)
+ ((memv (string-ref pat 0) '(#\* #\? #\[)) #t)
+ (else #f)))
+ (define (countq val lst)
+ (do ((lst lst (cdr lst))
+ (c 0 (if (eq? val (car lst)) (+ c 1) c)))
+ ((null? lst) c)))
+ (let ((tmpl-literals (map (lambda (tok)
+ (if (wildcard? tok) #f tok))
+ (glob:pattern->tokens template)))
+ (pat-wild? (map wildcard? (glob:pattern->tokens pattern)))
+ (matcher (glob:make-matcher pattern ch=? ch<=?)))
+ (or (= (countq #t pat-wild?) (countq #f tmpl-literals))
+ (slib:error 'glob:make-substituter
+ "number of wildcards doesn't match" pattern template))
+ (lambda (str)
+ (let ((indices (matcher str)))
+ (and indices
+ (let loop ((inds indices)
+ (wild? pat-wild?)
+ (lits tmpl-literals)
+ (res '()))
+ (cond
+ ((null? lits)
+ (apply string-append (reverse res)))
+ ((car lits)
+ (loop inds wild? (cdr lits) (cons (car lits) res)))
+ ((null? wild?) ;this should never happen.
+ (loop '() '() lits res))
+ ((car wild?)
+ (loop (cdr inds) (cdr wild?) (cdr lits)
+ (cons (substring str (car inds) (cadr inds))
+ res)))
+ (else
+ (loop (cdr inds) (cdr wild?) lits res)))))))))
+
+(define (glob:match?? pat)
+ (glob:make-matcher pat char=? char<=?))
+(define (glob:match-ci?? pat)
+ (glob:make-matcher pat char-ci=? char-ci<=?))
(define filename:match?? glob:match??)
(define filename:match-ci?? glob:match-ci??)
+(define (glob:substitute?? pat templ)
+ (cond ((procedure? templ)
+ (glob:caller-with-matches pat templ char=? char<=?))
+ ((string? templ)
+ (glob:make-substituter pat templ char=? char<=?))
+ (else
+ (slib:error 'glob:substitute "bad second argument" templ))))
+(define (glob:substitute-ci?? pat templ)
+ (cond ((procedure? templ)
+ (glob:caller-with-matches pat templ char-ci=? char-ci<=?))
+ ((string? templ)
+ (glob:make-substituter pat templ char-ci=? char-ci<=?))
+ (else
+ (slib:error 'glob:substitute "bad second argument" templ))))
+(define filename:substitute?? glob:substitute??)
+(define filename:substitute-ci?? glob:substitute-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)))
+ (let* ((f (glob:make-substituter (list "*" old) (list "*" new)
+ char=? char<=?))
+ (g (lambda (st)
+ (or (f st)
+ (slib:error 'replace-suffix "suffix doesn't match:"
+ old st)))))
+ (if (pair? str)
+ (map g str)
+ (g str))))