Commit | Line | Data |
25f0751f |
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 | use bytes; |
12 | |
13 | use Test::More ; |
14 | use CompTestUtils; |
15 | |
16 | BEGIN { |
17 | # use Test::NoWarnings, if available |
18 | my $extra = 0 ; |
19 | $extra = 1 |
20 | if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; |
21 | |
10c2b2bb |
22 | plan tests => 118 + $extra ; |
25f0751f |
23 | |
f6fd7794 |
24 | use_ok('Scalar::Util'); |
25f0751f |
25 | use_ok('IO::Compress::Base::Common'); |
25f0751f |
26 | } |
27 | |
f6fd7794 |
28 | |
29 | ok gotScalarUtilXS(), "Got XS Version of Scalar::Util" |
30 | or diag <<EOM; |
31 | You don't have the XS version of Scalar::Util |
32 | EOM |
33 | |
25f0751f |
34 | # Compress::Zlib::Common; |
35 | |
36 | sub My::testParseParameters() |
37 | { |
38 | eval { ParseParameters(1, {}, 1) ; }; |
39 | like $@, mkErr(': Expected even number of parameters, got 1'), |
40 | "Trap odd number of params"; |
41 | |
42 | eval { ParseParameters(1, {}, undef) ; }; |
43 | like $@, mkErr(': Expected even number of parameters, got 1'), |
44 | "Trap odd number of params"; |
45 | |
46 | eval { ParseParameters(1, {}, []) ; }; |
47 | like $@, mkErr(': Expected even number of parameters, got 1'), |
48 | "Trap odd number of params"; |
49 | |
50 | eval { ParseParameters(1, {'Fred' => [1, 1, Parse_boolean, 0]}, Fred => 'joe') ; }; |
51 | like $@, mkErr("Parameter 'Fred' must be an int, got 'joe'"), |
52 | "wanted unsigned, got undef"; |
53 | |
54 | eval { ParseParameters(1, {'Fred' => [1, 1, Parse_unsigned, 0]}, Fred => undef) ; }; |
55 | like $@, mkErr("Parameter 'Fred' must be an unsigned int, got 'undef'"), |
56 | "wanted unsigned, got undef"; |
57 | |
58 | eval { ParseParameters(1, {'Fred' => [1, 1, Parse_signed, 0]}, Fred => undef) ; }; |
59 | like $@, mkErr("Parameter 'Fred' must be a signed int, got 'undef'"), |
60 | "wanted signed, got undef"; |
61 | |
62 | eval { ParseParameters(1, {'Fred' => [1, 1, Parse_signed, 0]}, Fred => 'abc') ; }; |
63 | like $@, mkErr("Parameter 'Fred' must be a signed int, got 'abc'"), |
64 | "wanted signed, got 'abc'"; |
65 | |
80213491 |
66 | |
67 | SKIP: |
68 | { |
69 | use Config; |
70 | |
71 | skip 'readonly + threads', 1 |
72 | if $Config{useithreads}; |
73 | |
74 | eval { ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, 0]}, Fred => 'abc') ; }; |
75 | like $@, mkErr("Parameter 'Fred' not writable"), |
76 | "wanted writable, got readonly"; |
77 | } |
258133d1 |
78 | |
79 | my @xx; |
80 | eval { ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, 0]}, Fred => \@xx) ; }; |
81 | like $@, mkErr("Parameter 'Fred' not a scalar reference"), |
82 | "wanted scalar reference"; |
83 | |
84 | local *ABC; |
85 | eval { ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, 0]}, Fred => *ABC) ; }; |
86 | like $@, mkErr("Parameter 'Fred' not a scalar"), |
87 | "wanted scalar"; |
25f0751f |
88 | |
258133d1 |
89 | #eval { ParseParameters(1, {'Fred' => [1, 1, Parse_any|Parse_multiple, 0]}, Fred => 1, Fred => 2) ; }; |
90 | #like $@, mkErr("Muliple instances of 'Fred' found"), |
91 | #"wanted scalar"; |
92 | |
93 | ok 1; |
94 | |
95 | my $got = ParseParameters(1, {'Fred' => [1, 1, 0x1000000, 0]}, Fred => 'abc') ; |
25f0751f |
96 | is $got->value('Fred'), "abc", "other" ; |
97 | |
9253672d |
98 | $got = ParseParameters(1, {'Fred' => [0, 1, Parse_any, undef]}, Fred => undef) ; |
c70c1701 |
99 | ok $got->parsed('Fred'), "undef" ; |
100 | ok ! defined $got->value('Fred'), "undef" ; |
101 | |
9253672d |
102 | $got = ParseParameters(1, {'Fred' => [0, 1, Parse_string, undef]}, Fred => undef) ; |
c70c1701 |
103 | ok $got->parsed('Fred'), "undef" ; |
104 | is $got->value('Fred'), "", "empty string" ; |
105 | |
258133d1 |
106 | my $xx; |
107 | $got = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, Fred => $xx) ; |
108 | |
109 | ok $got->parsed('Fred'), "parsed" ; |
110 | my $xx_ref = $got->value('Fred'); |
111 | $$xx_ref = 77 ; |
112 | is $xx, 77; |
113 | |
114 | $got = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, Fred => \$xx) ; |
115 | |
116 | ok $got->parsed('Fred'), "parsed" ; |
117 | $xx_ref = $got->value('Fred'); |
9253672d |
118 | |
258133d1 |
119 | $$xx_ref = 666 ; |
120 | is $xx, 666; |
121 | |
9253672d |
122 | { |
123 | my $got1 = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, $got) ; |
124 | is $got1, $got, "Same object"; |
125 | |
126 | ok $got1->parsed('Fred'), "parsed" ; |
127 | $xx_ref = $got1->value('Fred'); |
128 | |
129 | $$xx_ref = 777 ; |
130 | is $xx, 777; |
131 | } |
132 | |
133 | my $got2 = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, '__xxx__' => $got) ; |
134 | isnt $got2, $got, "not the Same object"; |
135 | |
136 | ok $got2->parsed('Fred'), "parsed" ; |
137 | $xx_ref = $got2->value('Fred'); |
138 | $$xx_ref = 888 ; |
139 | is $xx, 888; |
140 | |
141 | my $other; |
142 | my $got3 = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, '__xxx__' => $got, Fred => \$other) ; |
143 | isnt $got3, $got, "not the Same object"; |
144 | |
145 | ok $got3->parsed('Fred'), "parsed" ; |
146 | $xx_ref = $got3->value('Fred'); |
147 | $$xx_ref = 999 ; |
148 | is $other, 999; |
149 | is $xx, 888; |
25f0751f |
150 | } |
151 | |
9253672d |
152 | |
25f0751f |
153 | My::testParseParameters(); |
154 | |
155 | |
156 | { |
157 | title "isaFilename" ; |
158 | ok isaFilename("abc"), "'abc' isaFilename"; |
159 | |
160 | ok ! isaFilename(undef), "undef ! isaFilename"; |
161 | ok ! isaFilename([]), "[] ! isaFilename"; |
162 | $main::X = 1; $main::X = $main::X ; |
163 | ok ! isaFilename(*X), "glob ! isaFilename"; |
164 | } |
165 | |
166 | { |
167 | title "whatIsInput" ; |
168 | |
169 | my $lex = new LexFile my $out_file ; |
170 | open FH, ">$out_file" ; |
171 | is whatIsInput(*FH), 'handle', "Match filehandle" ; |
172 | close FH ; |
173 | |
174 | my $stdin = '-'; |
175 | is whatIsInput($stdin), 'handle', "Match '-' as stdin"; |
176 | #is $stdin, \*STDIN, "'-' changed to *STDIN"; |
177 | #isa_ok $stdin, 'IO::File', "'-' changed to IO::File"; |
178 | is whatIsInput("abc"), 'filename', "Match filename"; |
179 | is whatIsInput(\"abc"), 'buffer', "Match buffer"; |
180 | is whatIsInput(sub { 1 }, 1), 'code', "Match code"; |
181 | is whatIsInput(sub { 1 }), '' , "Don't match code"; |
182 | |
183 | } |
184 | |
185 | { |
186 | title "whatIsOutput" ; |
187 | |
188 | my $lex = new LexFile my $out_file ; |
189 | open FH, ">$out_file" ; |
190 | is whatIsOutput(*FH), 'handle', "Match filehandle" ; |
191 | close FH ; |
192 | |
193 | my $stdout = '-'; |
194 | is whatIsOutput($stdout), 'handle', "Match '-' as stdout"; |
195 | #is $stdout, \*STDOUT, "'-' changed to *STDOUT"; |
196 | #isa_ok $stdout, 'IO::File', "'-' changed to IO::File"; |
197 | is whatIsOutput("abc"), 'filename', "Match filename"; |
198 | is whatIsOutput(\"abc"), 'buffer', "Match buffer"; |
199 | is whatIsOutput(sub { 1 }, 1), 'code', "Match code"; |
200 | is whatIsOutput(sub { 1 }), '' , "Don't match code"; |
201 | |
202 | } |
e7d45986 |
203 | |
204 | # U64 |
205 | |
206 | { |
207 | title "U64" ; |
208 | |
209 | my $x = new U64(); |
210 | is $x->getHigh, 0, " getHigh is 0"; |
211 | is $x->getLow, 0, " getLow is 0"; |
10c2b2bb |
212 | ok ! $x->is64bit(), " ! is64bit"; |
e7d45986 |
213 | |
214 | $x = new U64(1,2); |
e7d45986 |
215 | is $x->getHigh, 1, " getHigh is 1"; |
216 | is $x->getLow, 2, " getLow is 2"; |
10c2b2bb |
217 | ok $x->is64bit(), " is64bit"; |
e7d45986 |
218 | |
219 | $x = new U64(0xFFFFFFFF,2); |
220 | is $x->getHigh, 0xFFFFFFFF, " getHigh is 0xFFFFFFFF"; |
221 | is $x->getLow, 2, " getLow is 2"; |
10c2b2bb |
222 | ok $x->is64bit(), " is64bit"; |
e7d45986 |
223 | |
224 | $x = new U64(7, 0xFFFFFFFF); |
225 | is $x->getHigh, 7, " getHigh is 7"; |
226 | is $x->getLow, 0xFFFFFFFF, " getLow is 0xFFFFFFFF"; |
10c2b2bb |
227 | ok $x->is64bit(), " is64bit"; |
e7d45986 |
228 | |
229 | $x = new U64(666); |
230 | is $x->getHigh, 0, " getHigh is 0"; |
231 | is $x->getLow, 666, " getLow is 666"; |
10c2b2bb |
232 | ok ! $x->is64bit(), " ! is64bit"; |
e7d45986 |
233 | |
234 | title "U64 - add" ; |
235 | |
236 | $x = new U64(0, 1); |
237 | is $x->getHigh, 0, " getHigh is 0"; |
238 | is $x->getLow, 1, " getLow is 1"; |
10c2b2bb |
239 | ok ! $x->is64bit(), " ! is64bit"; |
e7d45986 |
240 | |
241 | $x->add(1); |
242 | is $x->getHigh, 0, " getHigh is 0"; |
243 | is $x->getLow, 2, " getLow is 2"; |
10c2b2bb |
244 | ok ! $x->is64bit(), " ! is64bit"; |
e7d45986 |
245 | |
246 | $x = new U64(0, 0xFFFFFFFE); |
247 | is $x->getHigh, 0, " getHigh is 0"; |
248 | is $x->getLow, 0xFFFFFFFE, " getLow is 0xFFFFFFFE"; |
10c2b2bb |
249 | is $x->get32bit(), 0xFFFFFFFE, " get32bit is 0xFFFFFFFE"; |
250 | is $x->get64bit(), 0xFFFFFFFE, " get64bit is 0xFFFFFFFE"; |
251 | ok ! $x->is64bit(), " ! is64bit"; |
e7d45986 |
252 | |
253 | $x->add(1); |
254 | is $x->getHigh, 0, " getHigh is 0"; |
255 | is $x->getLow, 0xFFFFFFFF, " getLow is 0xFFFFFFFF"; |
10c2b2bb |
256 | is $x->get32bit(), 0xFFFFFFFF, " get32bit is 0xFFFFFFFF"; |
257 | is $x->get64bit(), 0xFFFFFFFF, " get64bit is 0xFFFFFFFF"; |
258 | ok ! $x->is64bit(), " ! is64bit"; |
e7d45986 |
259 | |
260 | $x->add(1); |
261 | is $x->getHigh, 1, " getHigh is 1"; |
262 | is $x->getLow, 0, " getLow is 0"; |
10c2b2bb |
263 | is $x->get32bit(), 0x0, " get32bit is 0x0"; |
264 | is $x->get64bit(), 0xFFFFFFFF+1, " get64bit is 0x100000000"; |
265 | ok $x->is64bit(), " is64bit"; |
e7d45986 |
266 | |
267 | $x->add(1); |
268 | is $x->getHigh, 1, " getHigh is 1"; |
269 | is $x->getLow, 1, " getLow is 1"; |
10c2b2bb |
270 | is $x->get32bit(), 0x1, " get32bit is 0x1"; |
271 | is $x->get64bit(), 0xFFFFFFFF+2, " get64bit is 0x100000001"; |
272 | ok $x->is64bit(), " is64bit"; |
273 | |
274 | $x->add(1); |
275 | is $x->getHigh, 1, " getHigh is 1"; |
276 | is $x->getLow, 2, " getLow is 1"; |
277 | is $x->get32bit(), 0x2, " get32bit is 0x2"; |
278 | is $x->get64bit(), 0xFFFFFFFF+3, " get64bit is 0x100000002"; |
279 | ok $x->is64bit(), " is64bit"; |
e7d45986 |
280 | |
281 | $x = new U64(1, 0xFFFFFFFE); |
282 | my $y = new U64(2, 3); |
283 | |
284 | $x->add($y); |
285 | is $x->getHigh, 4, " getHigh is 4"; |
286 | is $x->getLow, 1, " getLow is 1"; |
10c2b2bb |
287 | ok $x->is64bit(), " is64bit"; |
e7d45986 |
288 | |
289 | title "U64 - equal" ; |
290 | |
291 | $x = new U64(0, 1); |
292 | is $x->getHigh, 0, " getHigh is 0"; |
293 | is $x->getLow, 1, " getLow is 1"; |
10c2b2bb |
294 | ok ! $x->is64bit(), " ! is64bit"; |
e7d45986 |
295 | |
296 | $y = new U64(0, 1); |
10c2b2bb |
297 | is $y->getHigh, 0, " getHigh is 0"; |
298 | is $y->getLow, 1, " getLow is 1"; |
299 | ok ! $y->is64bit(), " ! is64bit"; |
e7d45986 |
300 | |
301 | my $z = new U64(0, 2); |
10c2b2bb |
302 | is $z->getHigh, 0, " getHigh is 0"; |
303 | is $z->getLow, 2, " getLow is 2"; |
304 | ok ! $z->is64bit(), " ! is64bit"; |
e7d45986 |
305 | |
306 | ok $x->equal($y), " equal"; |
307 | ok !$x->equal($z), " ! equal"; |
308 | |
10c2b2bb |
309 | title "U64 - clone" ; |
310 | $x = new U64(21, 77); |
311 | $z = U64::clone($x); |
312 | is $z->getHigh, 21, " getHigh is 21"; |
313 | is $z->getLow, 77, " getLow is 77"; |
e7d45986 |
314 | } |