diff options
Diffstat (limited to 'glob.scm')
| -rw-r--r-- | glob.scm | 246 |
1 files changed, 177 insertions, 69 deletions
@@ -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)))) |