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