Commit | Line | Data |
16816334 |
1 | BEGIN { |
d695c1a1 |
2 | if ($ENV{PERL_CORE}) { |
16816334 |
3 | chdir 't' if -d 't'; |
1a6a8453 |
4 | @INC = ("../lib", "lib/compress"); |
16816334 |
5 | } |
6 | } |
642e522c |
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 | |