1BEGIN {
2    if ($ENV{PERL_CORE}) {
3	chdir 't' if -d 't';
4	@INC = ("../lib", "lib/compress");
5    }
6}
7
8use lib qw(t t/compress);
9use strict;
10use warnings;
11use bytes;
12
13use Test::More ;
14use CompTestUtils;
15
16BEGIN {
17    # use Test::NoWarnings, if available
18    my $extra = 0 ;
19    $extra = 1
20        if eval { require Test::NoWarnings ;  import Test::NoWarnings; 1 };
21
22    plan tests => 163 + $extra ;
23
24    use_ok('Scalar::Util');
25    use_ok('IO::Compress::Base::Common');
26}
27
28
29ok gotScalarUtilXS(), "Got XS Version of Scalar::Util"
30    or diag <<EOM;
31You don't have the XS version of Scalar::Util
32EOM
33
34# Compress::Zlib::Common;
35
36sub 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' => [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' => [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' => [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' => [Parse_signed, 0]}, fred => 'abc') ; };
63    like $@, mkErr("Parameter 'fred' must be a signed int, got 'abc'"),
64            "wanted signed, got 'abc'";
65
66    eval { ParseParameters(1, {'fred' => [Parse_code, undef]}, fred => 'abc') ; };
67    like $@, mkErr("Parameter 'fred' must be a code reference, got 'abc'"),
68            "wanted code, got 'abc'";
69
70
71    SKIP:
72    {
73        use Config;
74
75        skip 'readonly + threads', 2
76            if $Config{useithreads};
77
78        eval { ParseParameters(1, {'fred' => [Parse_writable_scalar, 0]}, fred => 'abc') ; };
79        like $@, mkErr("Parameter 'fred' not writable"),
80                "wanted writable, got readonly";
81
82        skip '\\ returns mutable value in 5.19.3', 1
83            if $] >= 5.019003;
84
85        eval { ParseParameters(1, {'fred' => [Parse_writable_scalar, 0]}, fred => \'abc') ; };
86        like $@, mkErr("Parameter 'fred' not writable"),
87                "wanted writable, got readonly";
88    }
89
90    my @xx;
91    eval { ParseParameters(1, {'fred' => [Parse_writable_scalar, 0]}, fred => \@xx) ; };
92    like $@, mkErr("Parameter 'fred' not a scalar reference"),
93            "wanted scalar reference";
94
95    local *ABC;
96    eval { ParseParameters(1, {'fred' => [Parse_writable_scalar, 0]}, fred => *ABC) ; };
97    like $@, mkErr("Parameter 'fred' not a scalar"),
98            "wanted scalar";
99
100    eval { ParseParameters(1, {'fred' => [Parse_any, 0]}, fred => 1, fred => 2) ; };
101    like $@, mkErr("Muliple instances of 'fred' found"),
102        "multiple instances";
103
104#    my $g = ParseParameters(1, {'fred' => [Parse_unsigned|Parse_multiple, 7]}, fred => 1, fred => 2) ;
105#    is_deeply $g->value('fred'), [ 1, 2 ] ;
106    ok 1;
107
108    #ok 1;
109
110    my $got = ParseParameters(1, {'fred' => [0x1000000, 0]}, fred => 'abc') ;
111    is $got->getValue('fred'), "abc", "other" ;
112
113    $got = ParseParameters(1, {'fred' => [Parse_any, undef]}, fred => undef) ;
114    ok $got->parsed('fred'), "undef" ;
115    ok ! defined $got->getValue('fred'), "undef" ;
116
117    $got = ParseParameters(1, {'fred' => [Parse_string, undef]}, fred => undef) ;
118    ok $got->parsed('fred'), "undef" ;
119    is $got->getValue('fred'), "", "empty string" ;
120
121    my $xx;
122    $got = ParseParameters(1, {'fred' => [Parse_writable_scalar, undef]}, fred => $xx) ;
123
124    ok $got->parsed('fred'), "parsed" ;
125    my $xx_ref = $got->getValue('fred');
126    $$xx_ref = 77 ;
127    is $xx, 77;
128
129    $got = ParseParameters(1, {'fred' => [Parse_writable_scalar, undef]}, fred => \$xx) ;
130
131    ok $got->parsed('fred'), "parsed" ;
132    $xx_ref = $got->getValue('fred');
133
134    $$xx_ref = 666 ;
135    is $xx, 666;
136
137    {
138        my $got1 = ParseParameters(1, {'fred' => [Parse_writable_scalar, undef]}, $got) ;
139        is $got1, $got, "Same object";
140
141        ok $got1->parsed('fred'), "parsed" ;
142        $xx_ref = $got1->getValue('fred');
143
144        $$xx_ref = 777 ;
145        is $xx, 777;
146    }
147
148    for my $type (Parse_unsigned, Parse_signed, Parse_any)
149    {
150        my $value = 0;
151        my $got1 ;
152        eval { $got1 = ParseParameters(1, {'fred' => [$type, 1]}, fred => $value) } ;
153
154        ok ! $@;
155        ok $got1->parsed('fred'), "parsed ok" ;
156        is $got1->getValue('fred'), 0;
157    }
158
159    {
160        # setValue/getValue
161        my $value = 0;
162        my $got1 ;
163        eval { $got1 = ParseParameters(1, {'fred' => [Parse_any, 1]}, fred => $value) } ;
164
165        ok ! $@;
166        ok $got1->parsed('fred'), "parsed ok" ;
167        is $got1->getValue('fred'), 0;
168        $got1->setValue('fred' => undef);
169        is $got1->getValue('fred'), undef;
170    }
171
172    {
173        # twice
174        my $value = 0;
175
176        my $got = IO::Compress::Base::Parameters::new();
177
178
179        ok $got->parse({'fred' => [Parse_any, 1]}, fred => $value) ;
180
181        ok $got->parsed('fred'), "parsed ok" ;
182        is $got->getValue('fred'), 0;
183
184        ok $got->parse({'fred' => [Parse_any, 1]}, fred => undef) ;
185        ok $got->parsed('fred'), "parsed ok" ;
186        is $got->getValue('fred'), undef;
187
188        ok $got->parse({'fred' => [Parse_any, 1]}, fred => 7) ;
189        ok $got->parsed('fred'), "parsed ok" ;
190        is $got->getValue('fred'), 7;
191    }
192}
193
194
195My::testParseParameters();
196
197
198{
199    title "isaFilename" ;
200    ok   isaFilename("abc"), "'abc' isaFilename";
201
202    ok ! isaFilename(undef), "undef ! isaFilename";
203    ok ! isaFilename([]),    "[] ! isaFilename";
204    $main::X = 1; $main::X = $main::X ;
205    ok ! isaFilename(*X),    "glob ! isaFilename";
206}
207
208{
209    title "whatIsInput" ;
210
211    my $lex = new LexFile my $out_file ;
212    open FH, ">$out_file" ;
213    is whatIsInput(*FH), 'handle', "Match filehandle" ;
214    close FH ;
215
216    my $stdin = '-';
217    is whatIsInput($stdin),       'handle',   "Match '-' as stdin";
218    #is $stdin,                    \*STDIN,    "'-' changed to *STDIN";
219    #isa_ok $stdin,                'IO::File',    "'-' changed to IO::File";
220    is whatIsInput("abc"),        'filename', "Match filename";
221    is whatIsInput(\"abc"),       'buffer',   "Match buffer";
222    is whatIsInput(sub { 1 }, 1), 'code',     "Match code";
223    is whatIsInput(sub { 1 }),    ''   ,      "Don't match code";
224
225}
226
227{
228    title "whatIsOutput" ;
229
230    my $lex = new LexFile my $out_file ;
231    open FH, ">$out_file" ;
232    is whatIsOutput(*FH), 'handle', "Match filehandle" ;
233    close FH ;
234
235    my $stdout = '-';
236    is whatIsOutput($stdout),     'handle',   "Match '-' as stdout";
237    #is $stdout,                   \*STDOUT,   "'-' changed to *STDOUT";
238    #isa_ok $stdout,               'IO::File',    "'-' changed to IO::File";
239    is whatIsOutput("abc"),        'filename', "Match filename";
240    is whatIsOutput(\"abc"),       'buffer',   "Match buffer";
241    is whatIsOutput(sub { 1 }, 1), 'code',     "Match code";
242    is whatIsOutput(sub { 1 }),    ''   ,      "Don't match code";
243
244}
245
246# U64
247
248{
249    title "U64" ;
250
251    my $x = new U64();
252    is $x->getHigh, 0, "  getHigh is 0";
253    is $x->getLow, 0, "  getLow is 0";
254    ok ! $x->is64bit(), " ! is64bit";
255
256    $x = new U64(1,2);
257    is $x->getHigh, 1, "  getHigh is 1";
258    is $x->getLow, 2, "  getLow is 2";
259    ok $x->is64bit(), " is64bit";
260
261    $x = new U64(0xFFFFFFFF,2);
262    is $x->getHigh, 0xFFFFFFFF, "  getHigh is 0xFFFFFFFF";
263    is $x->getLow, 2, "  getLow is 2";
264    ok $x->is64bit(), " is64bit";
265
266    $x = new U64(7, 0xFFFFFFFF);
267    is $x->getHigh, 7, "  getHigh is 7";
268    is $x->getLow, 0xFFFFFFFF, "  getLow is 0xFFFFFFFF";
269    ok $x->is64bit(), " is64bit";
270
271    $x = new U64(666);
272    is $x->getHigh, 0, "  getHigh is 0";
273    is $x->getLow, 666, "  getLow is 666";
274    ok ! $x->is64bit(), " ! is64bit";
275
276    title "U64 - add" ;
277
278    $x = new U64(0, 1);
279    is $x->getHigh, 0, "  getHigh is 0";
280    is $x->getLow, 1, "  getLow is 1";
281    ok ! $x->is64bit(), " ! is64bit";
282
283    $x->add(1);
284    is $x->getHigh, 0, "  getHigh is 0";
285    is $x->getLow, 2, "  getLow is 2";
286    ok ! $x->is64bit(), " ! is64bit";
287
288    $x = new U64(0, 0xFFFFFFFE);
289    is $x->getHigh, 0, "  getHigh is 0";
290    is $x->getLow, 0xFFFFFFFE, "  getLow is 0xFFFFFFFE";
291    is $x->get32bit(),  0xFFFFFFFE, "  get32bit is 0xFFFFFFFE";
292    is $x->get64bit(),  0xFFFFFFFE, "  get64bit is 0xFFFFFFFE";
293    ok ! $x->is64bit(), " ! is64bit";
294
295    $x->add(1);
296    is $x->getHigh, 0, "  getHigh is 0";
297    is $x->getLow, 0xFFFFFFFF, "  getLow is 0xFFFFFFFF";
298    is $x->get32bit(),  0xFFFFFFFF, "  get32bit is 0xFFFFFFFF";
299    is $x->get64bit(),  0xFFFFFFFF, "  get64bit is 0xFFFFFFFF";
300    ok ! $x->is64bit(), " ! is64bit";
301
302    $x->add(1);
303    is $x->getHigh, 1, "  getHigh is 1";
304    is $x->getLow, 0, "  getLow is 0";
305    is $x->get32bit(),  0x0, "  get32bit is 0x0";
306    is $x->get64bit(), 0xFFFFFFFF+1, "  get64bit is 0x100000000";
307    ok $x->is64bit(), " is64bit";
308
309    $x->add(1);
310    is $x->getHigh, 1, "  getHigh is 1";
311    is $x->getLow, 1, "  getLow is 1";
312    is $x->get32bit(),  0x1, "  get32bit is 0x1";
313    is $x->get64bit(),  0xFFFFFFFF+2, "  get64bit is 0x100000001";
314    ok $x->is64bit(), " is64bit";
315
316    $x->add(1);
317    is $x->getHigh, 1, "  getHigh is 1";
318    is $x->getLow, 2, "  getLow is 1";
319    is $x->get32bit(),  0x2, "  get32bit is 0x2";
320    is $x->get64bit(),  0xFFFFFFFF+3, "  get64bit is 0x100000002";
321    ok $x->is64bit(), " is64bit";
322
323    $x = new U64(1, 0xFFFFFFFE);
324    my $y = new U64(2, 3);
325
326    $x->add($y);
327    is $x->getHigh, 4, "  getHigh is 4";
328    is $x->getLow, 1, "  getLow is 1";
329    ok $x->is64bit(), " is64bit";
330
331    title "U64 - subtract" ;
332
333    $x = new U64(0, 1);
334    is $x->getHigh, 0, "  getHigh is 0";
335    is $x->getLow, 1, "  getLow is 1";
336    ok ! $x->is64bit(), " ! is64bit";
337
338    $x->subtract(1);
339    is $x->getHigh, 0, "  getHigh is 0";
340    is $x->getLow, 0, "  getLow is 0";
341    ok ! $x->is64bit(), " ! is64bit";
342
343    $x = new U64(1, 0);
344    is $x->getHigh, 1, "  getHigh is 1";
345    is $x->getLow, 0, "  getLow is 0";
346    is $x->get32bit(),  0, "  get32bit is 0xFFFFFFFE";
347    is $x->get64bit(),  0xFFFFFFFF+1, "  get64bit is 0x100000000";
348    ok $x->is64bit(), " is64bit";
349
350    $x->subtract(1);
351    is $x->getHigh, 0, "  getHigh is 0";
352    is $x->getLow, 0xFFFFFFFF, "  getLow is 0xFFFFFFFF";
353    is $x->get32bit(),  0xFFFFFFFF, "  get32bit is 0xFFFFFFFF";
354    is $x->get64bit(),  0xFFFFFFFF, "  get64bit is 0xFFFFFFFF";
355    ok ! $x->is64bit(), " ! is64bit";
356
357    $x = new U64(2, 2);
358    $y = new U64(1, 3);
359
360    $x->subtract($y);
361    is $x->getHigh, 0, "  getHigh is 0";
362    is $x->getLow, 0xFFFFFFFF, "  getLow is 1";
363    ok ! $x->is64bit(), " ! is64bit";
364
365    $x = new U64(0x01CADCE2, 0x4E815983);
366    $y = new U64(0x19DB1DE, 0xD53E8000); # NTFS to Unix time delta
367
368    $x->subtract($y);
369    is $x->getHigh, 0x2D2B03, "  getHigh is 2D2B03";
370    is $x->getLow, 0x7942D983, "  getLow is 7942D983";
371    ok $x->is64bit(), " is64bit";
372
373    title "U64 - equal" ;
374
375    $x = new U64(0, 1);
376    is $x->getHigh, 0, "  getHigh is 0";
377    is $x->getLow, 1, "  getLow is 1";
378    ok ! $x->is64bit(), " ! is64bit";
379
380    $y = new U64(0, 1);
381    is $y->getHigh, 0, "  getHigh is 0";
382    is $y->getLow, 1, "  getLow is 1";
383    ok ! $y->is64bit(), " ! is64bit";
384
385    my $z = new U64(0, 2);
386    is $z->getHigh, 0, "  getHigh is 0";
387    is $z->getLow, 2, "  getLow is 2";
388    ok ! $z->is64bit(), " ! is64bit";
389
390    ok $x->equal($y), "  equal";
391    ok !$x->equal($z), "  ! equal";
392
393    title "U64 - clone" ;
394    $x = new U64(21, 77);
395    $z =  U64::clone($x);
396    is $z->getHigh, 21, "  getHigh is 21";
397    is $z->getLow, 77, "  getLow is 77";
398
399    title "U64 - cmp.gt" ;
400    $x = new U64 1;
401    $y = new U64 0;
402    cmp_ok $x->cmp($y), '>', 0, "  cmp > 0";
403    is $x->gt($y), 1, "  gt";
404    cmp_ok $y->cmp($x), '<', 0, "  cmp < 0";
405
406}
407