Commit | Line | Data |
---|---|---|
642e522c RGS |
1 | |
2 | use lib 't'; | |
3 | use strict ; | |
4 | use warnings ; | |
5 | ||
6 | use Test::More ; | |
7 | use ZlibTestUtils; | |
8 | ||
9 | ||
10 | BEGIN | |
11 | { | |
12 | plan(skip_all => "File::GlobMapper needs Perl 5.005 or better - you have | |
13 | Perl $]" ) | |
14 | if $] < 5.005 ; | |
15 | ||
16 | # use Test::NoWarnings, if available | |
17 | my $extra = 0 ; | |
18 | $extra = 1 | |
19 | if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; | |
20 | ||
21 | plan tests => 68 + $extra ; | |
22 | ||
23 | use_ok('File::GlobMapper') ; | |
24 | } | |
25 | ||
26 | { | |
27 | title "Error Cases" ; | |
28 | ||
29 | my $gm; | |
30 | ||
31 | for my $delim ( qw/ ( ) { } [ ] / ) | |
32 | { | |
33 | $gm = new File::GlobMapper("${delim}abc", '*.X'); | |
34 | ok ! $gm, " new failed" ; | |
35 | is $File::GlobMapper::Error, "Unmatched $delim in input fileglob", | |
36 | " catch unmatched $delim"; | |
37 | } | |
38 | ||
39 | for my $delim ( qw/ ( ) [ ] / ) | |
40 | { | |
41 | $gm = new File::GlobMapper("{${delim}abc}", '*.X'); | |
42 | ok ! $gm, " new failed" ; | |
43 | is $File::GlobMapper::Error, "Unmatched $delim in input fileglob", | |
44 | " catch unmatched $delim inside {}"; | |
45 | } | |
46 | ||
47 | ||
48 | } | |
49 | ||
50 | { | |
51 | title "input glob matches zero files"; | |
52 | ||
53 | my $tmpDir = 'td'; | |
54 | my $lex = new LexDir $tmpDir; | |
55 | ||
56 | my $gm = new File::GlobMapper("$tmpDir/Z*", '*.X'); | |
57 | ok $gm, " created GlobMapper object" ; | |
58 | ||
59 | my $map = $gm->getFileMap() ; | |
60 | is @{ $map }, 0, " returned 0 maps"; | |
61 | is_deeply $map, [], " zero maps" ; | |
62 | ||
63 | my $hash = $gm->getHash() ; | |
64 | is_deeply $hash, {}, " zero maps" ; | |
65 | } | |
66 | ||
67 | { | |
68 | title 'test wildcard mapping of * in destination'; | |
69 | ||
70 | my $tmpDir = 'td'; | |
71 | my $lex = new LexDir $tmpDir; | |
72 | mkdir $tmpDir, 0777 ; | |
73 | ||
74 | touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; | |
75 | ||
76 | my $gm = new File::GlobMapper("$tmpDir/ab*.tmp", "*X"); | |
77 | ok $gm, " created GlobMapper object" ; | |
78 | ||
79 | my $map = $gm->getFileMap() ; | |
80 | is @{ $map }, 3, " returned 3 maps"; | |
81 | is_deeply $map, | |
82 | [ [map { "$tmpDir/$_" } qw(abc1.tmp abc1.tmpX)], | |
83 | [map { "$tmpDir/$_" } qw(abc2.tmp abc2.tmpX)], | |
84 | [map { "$tmpDir/$_" } qw(abc3.tmp abc3.tmpX)], | |
85 | ], " got mapping"; | |
86 | ||
87 | my $hash = $gm->getHash() ; | |
88 | is_deeply $hash, | |
89 | { map { "$tmpDir/$_" } qw(abc1.tmp abc1.tmpX | |
90 | abc2.tmp abc2.tmpX | |
91 | abc3.tmp abc3.tmpX), | |
92 | }, " got mapping"; | |
93 | } | |
94 | ||
95 | { | |
96 | title 'no wildcards in input or destination'; | |
97 | ||
98 | my $tmpDir = 'td'; | |
99 | my $lex = new LexDir $tmpDir; | |
100 | mkdir $tmpDir, 0777 ; | |
101 | ||
102 | touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; | |
103 | ||
104 | my $gm = new File::GlobMapper("$tmpDir/abc2.tmp", "$tmpDir/abc2.tmp"); | |
105 | ok $gm, " created GlobMapper object" ; | |
106 | ||
107 | my $map = $gm->getFileMap() ; | |
108 | is @{ $map }, 1, " returned 1 maps"; | |
109 | is_deeply $map, | |
110 | [ [map { "$tmpDir/$_.tmp" } qw(abc2 abc2)], | |
111 | ], " got mapping"; | |
112 | ||
113 | my $hash = $gm->getHash() ; | |
114 | is_deeply $hash, | |
115 | { map { "$tmpDir/$_.tmp" } qw(abc2 abc2), | |
116 | }, " got mapping"; | |
117 | } | |
118 | ||
119 | { | |
120 | title 'test wildcard mapping of {} in destination'; | |
121 | ||
122 | my $tmpDir = 'td'; | |
123 | my $lex = new LexDir $tmpDir; | |
124 | mkdir $tmpDir, 0777 ; | |
125 | ||
126 | touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; | |
127 | ||
128 | my $gm = new File::GlobMapper("$tmpDir/abc{1,3}.tmp", "*.X"); | |
129 | #diag "Input pattern is $gm->{InputPattern}"; | |
130 | ok $gm, " created GlobMapper object" ; | |
131 | ||
132 | my $map = $gm->getFileMap() ; | |
133 | is @{ $map }, 2, " returned 2 maps"; | |
134 | is_deeply $map, | |
135 | [ [map { "$tmpDir/$_" } qw(abc1.tmp abc1.tmp.X)], | |
136 | [map { "$tmpDir/$_" } qw(abc3.tmp abc3.tmp.X)], | |
137 | ], " got mapping"; | |
138 | ||
139 | $gm = new File::GlobMapper("$tmpDir/abc{1,3}.tmp", "$tmpDir/X.#1.X") | |
140 | or diag $File::GlobMapper::Error ; | |
141 | #diag "Input pattern is $gm->{InputPattern}"; | |
142 | ok $gm, " created GlobMapper object" ; | |
143 | ||
144 | $map = $gm->getFileMap() ; | |
145 | is @{ $map }, 2, " returned 2 maps"; | |
146 | is_deeply $map, | |
147 | [ [map { "$tmpDir/$_" } qw(abc1.tmp X.1.X)], | |
148 | [map { "$tmpDir/$_" } qw(abc3.tmp X.3.X)], | |
149 | ], " got mapping"; | |
150 | ||
151 | } | |
152 | ||
153 | ||
154 | { | |
155 | title 'test wildcard mapping of multiple * to #'; | |
156 | ||
157 | my $tmpDir = 'td'; | |
158 | my $lex = new LexDir $tmpDir; | |
159 | mkdir $tmpDir, 0777 ; | |
160 | ||
161 | touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; | |
162 | ||
163 | my $gm = new File::GlobMapper("$tmpDir/*b(*).tmp", "$tmpDir/X-#2-#1-X"); | |
164 | ok $gm, " created GlobMapper object" | |
165 | or diag $File::GlobMapper::Error ; | |
166 | ||
167 | my $map = $gm->getFileMap() ; | |
168 | is @{ $map }, 3, " returned 3 maps"; | |
169 | is_deeply $map, | |
170 | [ [map { "$tmpDir/$_" } qw(abc1.tmp X-c1-a-X)], | |
171 | [map { "$tmpDir/$_" } qw(abc2.tmp X-c2-a-X)], | |
172 | [map { "$tmpDir/$_" } qw(abc3.tmp X-c3-a-X)], | |
173 | ], " got mapping"; | |
174 | } | |
175 | ||
176 | { | |
177 | title 'test wildcard mapping of multiple ? to #'; | |
178 | ||
179 | my $tmpDir = 'td'; | |
180 | my $lex = new LexDir $tmpDir; | |
181 | mkdir $tmpDir, 0777 ; | |
182 | ||
183 | touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; | |
184 | ||
185 | my $gm = new File::GlobMapper("$tmpDir/?b(*).tmp", "$tmpDir/X-#2-#1-X"); | |
186 | ok $gm, " created GlobMapper object" ; | |
187 | ||
188 | my $map = $gm->getFileMap() ; | |
189 | is @{ $map }, 3, " returned 3 maps"; | |
190 | is_deeply $map, | |
191 | [ [map { "$tmpDir/$_" } qw(abc1.tmp X-c1-a-X)], | |
192 | [map { "$tmpDir/$_" } qw(abc2.tmp X-c2-a-X)], | |
193 | [map { "$tmpDir/$_" } qw(abc3.tmp X-c3-a-X)], | |
194 | ], " got mapping"; | |
195 | } | |
196 | ||
197 | { | |
198 | title 'test wildcard mapping of multiple ?,* and [] to #'; | |
199 | ||
200 | my $tmpDir = 'td'; | |
201 | my $lex = new LexDir $tmpDir; | |
202 | mkdir $tmpDir, 0777 ; | |
203 | ||
204 | touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; | |
205 | ||
206 | my $gm = new File::GlobMapper("./$tmpDir/?b[a-z]*.tmp", "./$tmpDir/X-#3-#2-#1-X"); | |
207 | ok $gm, " created GlobMapper object" ; | |
208 | ||
209 | #diag "Input pattern is $gm->{InputPattern}"; | |
210 | my $map = $gm->getFileMap() ; | |
211 | is @{ $map }, 3, " returned 3 maps"; | |
212 | is_deeply $map, | |
213 | [ [map { "./$tmpDir/$_" } qw(abc1.tmp X-1-c-a-X)], | |
214 | [map { "./$tmpDir/$_" } qw(abc2.tmp X-2-c-a-X)], | |
215 | [map { "./$tmpDir/$_" } qw(abc3.tmp X-3-c-a-X)], | |
216 | ], " got mapping"; | |
217 | } | |
218 | ||
219 | { | |
220 | title 'input glob matches a file multiple times'; | |
221 | ||
222 | my $tmpDir = 'td'; | |
223 | my $lex = new LexDir $tmpDir; | |
224 | mkdir $tmpDir, 0777 ; | |
225 | ||
226 | touch "$tmpDir/abc.tmp"; | |
227 | ||
228 | my $gm = new File::GlobMapper("$tmpDir/{a*,*c}.tmp", '*.X'); | |
229 | ok $gm, " created GlobMapper object" ; | |
230 | ||
231 | my $map = $gm->getFileMap() ; | |
232 | is @{ $map }, 1, " returned 1 maps"; | |
233 | is_deeply $map, | |
234 | [ [map { "$tmpDir/$_" } qw(abc.tmp abc.tmp.X)], ], " got mapping"; | |
235 | ||
236 | my $hash = $gm->getHash() ; | |
237 | is_deeply $hash, | |
238 | { map { "$tmpDir/$_" } qw(abc.tmp abc.tmp.X) }, " got mapping"; | |
239 | ||
240 | } | |
241 | ||
242 | { | |
243 | title 'multiple input files map to one output file'; | |
244 | ||
245 | my $tmpDir = 'td'; | |
246 | my $lex = new LexDir $tmpDir; | |
247 | mkdir $tmpDir, 0777 ; | |
248 | ||
249 | touch map { "$tmpDir/$_.tmp" } qw( abc def) ; | |
250 | ||
251 | my $gm = new File::GlobMapper("$tmpDir/*.tmp", "$tmpDir/fred"); | |
252 | ok ! $gm, " did not create GlobMapper object" ; | |
253 | ||
254 | is $File::GlobMapper::Error, 'multiple input files map to one output file', " Error is expected" ; | |
255 | ||
256 | #my $map = $gm->getFileMap() ; | |
257 | #is @{ $map }, 1, " returned 1 maps"; | |
258 | #is_deeply $map, | |
259 | #[ [map { "$tmpDir/$_" } qw(abc1 abc.X)], ], " got mapping"; | |
260 | } | |
261 | ||
262 | { | |
263 | title "globmap" ; | |
264 | ||
265 | my $tmpDir = 'td'; | |
266 | my $lex = new LexDir $tmpDir; | |
267 | mkdir $tmpDir, 0777 ; | |
268 | ||
269 | touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; | |
270 | ||
271 | my $map = File::GlobMapper::globmap("$tmpDir/*b*.tmp", "$tmpDir/X-#2-#1-X"); | |
272 | ok $map, " got map" | |
273 | or diag $File::GlobMapper::Error ; | |
274 | ||
275 | is @{ $map }, 3, " returned 3 maps"; | |
276 | is_deeply $map, | |
277 | [ [map { "$tmpDir/$_" } qw(abc1.tmp X-c1-a-X)], | |
278 | [map { "$tmpDir/$_" } qw(abc2.tmp X-c2-a-X)], | |
279 | [map { "$tmpDir/$_" } qw(abc3.tmp X-c3-a-X)], | |
280 | ], " got mapping"; | |
281 | } | |
282 | ||
283 | # TODO | |
284 | # test each of the wildcard metacharacters can be mapped to the output filename | |
285 | # | |
286 | # ~ [] {} . * | |
287 | ||
288 | # input & output glob with no wildcards is ok | |
289 | # input with no wild or output with no wild is bad | |
290 | # input wild has concatenated *'s | |
291 | # empty string for either both from & to | |
292 | # escaped chars within [] and {}, including the chars []{} | |
293 | # escaped , within {} | |
294 | # missing ] and missing } | |
295 | # {} and {,} are special cases | |
296 | # {ab*,de*} | |
297 | # {abc,{},{de,f}} => abc {} de f | |
298 |