1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
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)))
|
