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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
-- File created: 2008-10-10 13:29:03
{-# LANGUAGE CPP #-}
module System.FilePath.Glob.Match (match, matchWith) where
import Control.Exception (assert)
import Data.Char (isDigit, toLower, toUpper)
import Data.List (findIndex)
import Data.Maybe (fromMaybe, isJust)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (mappend)
#endif
import System.FilePath (isPathSeparator, isExtSeparator)
import System.FilePath.Glob.Base ( Pattern(..), Token(..)
, MatchOptions(..), matchDefault
, isLiteral, tokToLower
)
import System.FilePath.Glob.Utils (dropLeadingZeroes, inRange, pathParts)
-- |Matches the given 'Pattern' against the given 'FilePath', returning 'True'
-- if the pattern matches and 'False' otherwise.
match :: Pattern -> FilePath -> Bool
match = matchWith matchDefault
-- |Like 'match', but applies the given 'MatchOptions' instead of the defaults.
matchWith :: MatchOptions -> Pattern -> FilePath -> Bool
matchWith opts p f = begMatch opts (lcPat $ unPattern p) (lcPath f)
where
lcPath = if ignoreCase opts then map toLower else id
lcPat = if ignoreCase opts then map tokToLower else id
-- begMatch takes care of some things at the beginning of a pattern or after /:
-- - . needs to be matched explicitly
-- - ./foo is equivalent to foo (for any number of /)
--
-- .*/foo still needs to match ./foo though, and it won't match plain foo;
-- special case that one
--
-- and .**/foo should /not/ match ../foo; more special casing
--
-- (All of the above is modulo options, of course)
begMatch, match' :: MatchOptions -> [Token] -> FilePath -> Bool
begMatch _ (Literal '.' : AnyDirectory : _) (x:y:_)
| isExtSeparator x && isExtSeparator y = False
begMatch opts (Literal '.' : PathSeparator : pat) s | ignoreDotSlash opts =
begMatch opts (dropWhile isSlash pat) (dropDotSlash s)
where
isSlash PathSeparator = True
isSlash _ = False
dropDotSlash (x:y:ys) | isExtSeparator x && isPathSeparator y =
dropWhile isPathSeparator ys
dropDotSlash xs = xs
begMatch opts pat (x:y:s)
| dotSlash && dotStarSlash = match' opts pat' s
| ignoreDotSlash opts && dotSlash =
begMatch opts pat (dropWhile isPathSeparator s)
where
dotSlash = isExtSeparator x && isPathSeparator y
(dotStarSlash, pat') =
case pat of
Literal '.': AnyNonPathSeparator : PathSeparator : rest -> (True, rest)
_ -> (False, pat)
begMatch opts pat (e:_)
| isExtSeparator e
&& not (matchDotsImplicitly opts)
&& not (isLiteral . Pattern $ take 1 pat) = False
begMatch opts pat s = match' opts pat s
match' _ [] s = null s
match' _ (AnyNonPathSeparator:s) "" = null s
match' _ _ "" = False
match' o (Literal l :xs) (c:cs) = l == c && match' o xs cs
match' o (NonPathSeparator:xs) (c:cs) =
not (isPathSeparator c) && match' o xs cs
match' o (PathSeparator :xs) (c:cs) =
isPathSeparator c && begMatch o (dropWhile (== PathSeparator) xs)
(dropWhile isPathSeparator cs)
match' o (CharRange b rng :xs) (c:cs) =
let rangeMatch r =
either (== c) (`inRange` c) r ||
-- See comment near Base.tokToLower for an explanation of why we
-- do this
ignoreCase o && either (== toUpper c) (`inRange` toUpper c) r
in not (isPathSeparator c) &&
any rangeMatch rng == b &&
match' o xs cs
match' o (OpenRange lo hi :xs) path =
let getNumChoices n =
tail . takeWhile (not.null.snd) . map (`splitAt` n) $ [0..]
(lzNum,cs) = span isDigit path
num = dropLeadingZeroes lzNum
numChoices = getNumChoices num
zeroChoices = takeWhile (all (=='0') . fst) (getNumChoices lzNum)
in -- null lzNum means no digits: definitely not a match
not (null lzNum) &&
-- So, given the path "00123foo" what we've got is:
-- lzNum = "00123"
-- cs = "foo"
-- num = "123"
-- numChoices = [("1","23"),("12","3")]
-- zeroChoices = [("0", "0123"), ("00", "123")]
--
-- We want to try matching x against each of 123, 12, and 1.
-- 12 and 1 are in numChoices already, but we need to add (num,"")
-- manually.
--
-- It's also possible that we only want to match the zeroes. Handle
-- that separately since inOpenRange doesn't like leading zeroes.
(any (\(n,rest) -> inOpenRange lo hi n && match' o xs (rest ++ cs))
((num,"") : numChoices)
|| (not (null zeroChoices) && inOpenRange lo hi "0"
&& any (\(_,rest) -> match' o xs (rest ++ cs)) zeroChoices))
match' o again@(AnyNonPathSeparator:xs) path@(c:cs) =
match' o xs path || (not (isPathSeparator c) && match' o again cs)
match' o (AnyDirectory:xs) path =
if matchDotsImplicitly o
then hasMatch
-- **/baz shouldn't match foo/.bar/baz, so check that none of the
-- directories matched by **/ start with .
else hasMatch && all (not.isExtSeparator.head) matchedDirs
where parts = pathParts (dropWhile isPathSeparator path)
matchIndex = findIndex (match' o xs) parts
hasMatch = isJust matchIndex
matchedDirs = take (fromMaybe 0 matchIndex) parts
match' o (LongLiteral len s:xs) path =
let (pre,cs) = splitAt len path
in pre == s && match' o xs cs
match' _ (Unmatchable:_) _ = False
match' _ (ExtSeparator:_) _ = error "ExtSeparator survived optimization?"
-- Does the actual open range matching: finds whether the third parameter
-- is between the first two or not.
--
-- It does this by keeping track of the Ordering so far (e.g. having
-- looked at "12" and "34" the Ordering of the two would be LT: 12 < 34)
-- and aborting if a String "runs out": a longer string is automatically
-- greater.
--
-- Assumes that the input strings contain only digits, and no leading zeroes.
inOpenRange :: Maybe String -> Maybe String -> String -> Bool
inOpenRange l_ h_ s_ = assert (all isDigit s_) $ go l_ h_ s_ EQ EQ
where
go Nothing Nothing _ _ _ = True -- no bounds
go (Just []) _ [] LT _ = False -- lesser than lower bound
go _ (Just []) _ _ GT = False -- greater than upper bound
go _ (Just []) (_:_) _ _ = False -- longer than upper bound
go (Just (_:_)) _ [] _ _ = False -- shorter than lower bound
go _ _ [] _ _ = True
go (Just (l:ls)) (Just (h:hs)) (c:cs) ordl ordh =
let ordl' = ordl `mappend` compare c l
ordh' = ordh `mappend` compare c h
in go (Just ls) (Just hs) cs ordl' ordh'
go Nothing (Just (h:hs)) (c:cs) _ ordh =
let ordh' = ordh `mappend` compare c h
in go Nothing (Just hs) cs GT ordh'
go (Just (l:ls)) Nothing (c:cs) ordl _ =
let ordl' = ordl `mappend` compare c l
in go (Just ls) Nothing cs ordl' LT
-- lower bound is shorter: s is greater
go (Just []) hi s _ ordh = go Nothing hi s GT ordh
|
