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