lib/ExtUtils/t/Packlist.t

   1 #!/usr/bin/perl -w
   2
   3 BEGIN {
   4     if( $ENV{PERL_CORE} ) {
   5         chdir 't' if -d 't';
   6         @INC = '../lib';
   7     }
   8 }
   9 chdir 't';
  10
  11 use Test::More tests => 34;
  12
  13 use_ok( 'ExtUtils::Packlist' );
  14
  15 is( ref(ExtUtils::Packlist::mkfh()), 'GLOB', 'mkfh() should return a FH' );
  16
  17 # new calls tie()
  18 my $pl = ExtUtils::Packlist->new();
  19 isa_ok( $pl, 'ExtUtils::Packlist' );
  20 is( ref tied %$pl, 'ExtUtils::Packlist', 'obj should be tied underneath' );
  21
  22
  23 $pl = ExtUtils::Packlist::TIEHASH( 'tieclass', 'packfile' );
  24 is( ref($pl), 'tieclass', 'TIEHASH() should bless into class' );
  25 is( $pl->{packfile}, 'packfile', 'TIEHASH() should store packfile name' );
  26
  27
  28 ExtUtils::Packlist::STORE($pl, 'key', 'value');
  29 is( $pl->{data}{key}, 'value', 'STORE() should stuff stuff in data member' );
  30
  31
  32 $pl->{data}{foo} = 'bar';
  33 is( ExtUtils::Packlist::FETCH($pl, 'foo'), 'bar', 'check FETCH()' );
  34
  35
  36 # test FIRSTKEY and NEXTKEY
  37 SKIP: {
  38         $pl->{data}{bar} = 'baz';
  39         skip('not enough keys to test FIRSTKEY', 2)
  40       unless keys %{ $pl->{data} } > 2;
  41
  42         # get the first and second key
  43         my ($first, $second) = keys %{ $pl->{data} };
  44
  45         # now get a couple of extra keys, to mess with the hash iterator
  46         my $i = 0;
  47         for (keys %{ $pl->{data} } ) {
  48                 last if $i++;
  49         }
  50
  51         # finally, see if it really can get the first key again
  52         is( ExtUtils::Packlist::FIRSTKEY($pl), $first,
  53                 'FIRSTKEY() should be consistent' );
  54
  55         is( ExtUtils::Packlist::NEXTKEY($pl), $second,
  56                 'and NEXTKEY() should also be consistent' );
  57 }
  58
  59
  60 ok( ExtUtils::Packlist::EXISTS($pl, 'bar'), 'EXISTS() should find keys' );
  61
  62
  63 ExtUtils::Packlist::DELETE($pl, 'bar');
  64 ok( !(exists $pl->{data}{bar}), 'DELETE() should delete cleanly' );
  65
  66
  67 ExtUtils::Packlist::CLEAR($pl);
  68 is( keys %{ $pl->{data} }, 0, 'CLEAR() should wipe out data' );
  69
  70
  71 # DESTROY does nothing...
  72 can_ok( 'ExtUtils::Packlist', 'DESTROY' );
  73
  74
  75 # write is a little more complicated
  76 eval { ExtUtils::Packlist::write({}) };
  77 like( $@, qr/No packlist filename/, 'write() should croak without packfile' );
  78
  79 eval { ExtUtils::Packlist::write({}, 'eplist') };
  80 my $file_is_ready = $@ ? 0 : 1;
  81 ok( $file_is_ready, 'write() can write a file' );
  82
  83 local *IN;
  84
  85 SKIP: {
  86         skip('cannot write files, some tests difficult', 3) unless $file_is_ready;
  87
  88         # set this file to read-only
  89         chmod 0444, 'eplist';
  90
  91         SKIP: {
  92             skip("can write readonly files", 1) if -w 'eplist';
  93
  94             eval { ExtUtils::Packlist::write({}, 'eplist') };
  95             like( $@, qr/Can't open file/, 'write() should croak on open failure' );
  96         }
  97
  98         #'now set it back (tick here fixes vim syntax highlighting ;)
  99         chmod 0777, 'eplist';
 100
 101         # and some test data to be read
 102         $pl->{data} = {
 103                 single => 1,
 104                 hash => {
 105                         foo => 'bar',
 106                         baz => 'bup',
 107                 },
 108                 '/./abc' => '',
 109         };
 110         eval { ExtUtils::Packlist::write($pl, 'eplist') };
 111         is( $@, '', 'write() should normally succeed' );
 112         is( $pl->{packfile}, 'eplist', 'write() should set packfile name' );
 113
 114         $file_is_ready = open(IN, 'eplist');
 115 }
 116
 117
 118 eval { ExtUtils::Packlist::read({}) };
 119 like( $@, qr/^No packlist filename/, 'read() should croak without packfile' );
 120
 121
 122 eval { ExtUtils::Packlist::read({}, 'abadfilename') };
 123 like( $@, qr/^Can't open file/, 'read() should croak with bad packfile name' );
 124 #'open packfile for reading
 125
 126
 127 # and more read() tests
 128 SKIP: {
 129         skip("cannot open file for reading: $!", 5) unless $file_is_ready;
 130         my $file = do { local $/ = <IN> };
 131
 132         like( $file, qr/single\n/, 'key with value should be available' );
 133         like( $file, qr!/\./abc\n!, 'key with no value should also be present' );
 134         like( $file, qr/hash.+baz=bup/, 'key with hash value should be present' );
 135         like( $file, qr/hash.+foo=bar/, 'second embedded hash value should appear');
 136         close IN;
 137
 138         eval{ ExtUtils::Packlist::read($pl, 'eplist') };
 139         is( $@, '', 'read() should normally succeed' );
 140         is( $pl->{data}{single}, undef, 'single keys should have undef value' );
 141         is( ref($pl->{data}{hash}), 'HASH', 'multivalue keys should become hashes');
 142
 143         is( $pl->{data}{hash}{foo}, 'bar', 'hash values should be set' );
 144         ok( exists $pl->{data}{'/abc'}, 'read() should resolve /./ to / in keys' );
 145
 146         # give validate a valid and an invalid file to find
 147         $pl->{data} = {
 148                 eplist => 1,
 149                 fake => undef,
 150         };
 151
 152         is( ExtUtils::Packlist::validate($pl), 1,
 153                 'validate() should find missing files' );
 154         ExtUtils::Packlist::validate($pl, 1);
 155         ok( !exists $pl->{data}{fake},
 156                 'validate() should remove missing files when prompted' );
 157
 158         # one more new() test, to see if it calls read() successfully
 159         $pl = ExtUtils::Packlist->new('eplist');
 160 }
 161
 162
 163 # packlist_file, $pl should be set from write test
 164 is( ExtUtils::Packlist::packlist_file({ packfile => 'pl' }), 'pl',
 165         'packlist_file() should fetch packlist from passed hash' );
 166 is( ExtUtils::Packlist::packlist_file($pl), 'eplist',
 167         'packlist_file() should fetch packlist from ExtUtils::Packlist object' );
 168
 169 END {
 170         1 while unlink qw( eplist );
 171 }