git.maemo.org Git - pkg-perl/blob - deb-src/libio-compress-base-perl/libio-compress-base-perl-2.012/t/globmapper.t

   1 BEGIN {
   2     if ($ENV{PERL_CORE}) {
   3         chdir 't' if -d 't';
   4         @INC = ("../lib", "lib/compress");
   5     }
   6 }
   7
   8 use lib qw(t t/compress);
   9 use strict ;
  10 use warnings ;
  11
  12 use Test::More ;
  13 use CompTestUtils;
  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