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 => 118 + $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' => [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
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    }
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";
88
89#    eval { ParseParameters(1, {'Fred' => [1, 1, Parse_any, 0]}, Fred => 1, Fred => 2) ; };
90#    like $@, mkErr("Muliple instances of 'Fred' found"),
91#        "wanted scalar";
92
93    my $g = ParseParameters(1, {'Fred' => [1, 1, Parse_unsigned|Parse_multiple, 7]}, Fred => 1, Fred => 2) ;
94    is_deeply $g->value('Fred'), [ 1, 2 ] ;
95
96    #ok 1;
97
98    my $got = ParseParameters(1, {'Fred' => [1, 1, 0x1000000, 0]}, Fred => 'abc') ;
99    is $got->value('Fred'), "abc", "other" ;
100
101    $got = ParseParameters(1, {'Fred' => [0, 1, Parse_any, undef]}, Fred => undef) ;
102    ok $got->parsed('Fred'), "undef" ;
103    ok ! defined $got->value('Fred'), "undef" ;
104
105    $got = ParseParameters(1, {'Fred' => [0, 1, Parse_string, undef]}, Fred => undef) ;
106    ok $got->parsed('Fred'), "undef" ;
107    is $got->value('Fred'), "", "empty string" ;
108
109    my $xx;
110    $got = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, Fred => $xx) ;
111
112    ok $got->parsed('Fred'), "parsed" ;
113    my $xx_ref = $got->value('Fred');
114    $$xx_ref = 77 ;
115    is $xx, 77;
116
117    $got = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, Fred => \$xx) ;
118
119    ok $got->parsed('Fred'), "parsed" ;
120    $xx_ref = $got->value('Fred');
121
122    $$xx_ref = 666 ;
123    is $xx, 666;
124
125    {
126        my $got1 = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, $got) ;
127        is $got1, $got, "Same object";
128
129        ok $got1->parsed('Fred'), "parsed" ;
130        $xx_ref = $got1->value('Fred');
131
132        $$xx_ref = 777 ;
133        is $xx, 777;
134    }
135
136    my $got2 = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, '__xxx__' => $got) ;
137    isnt $got2, $got, "not the Same object";
138
139    ok $got2->parsed('Fred'), "parsed" ;
140    $xx_ref = $got2->value('Fred');
141    $$xx_ref = 888 ;
142    is $xx, 888;
143
144    my $other;
145    my $got3 = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, '__xxx__' => $got, Fred => \$other) ;
146    isnt $got3, $got, "not the Same object";
147
148    ok $got3->parsed('Fred'), "parsed" ;
149    $xx_ref = $got3->value('Fred');
150    $$xx_ref = 999 ;
151    is $other, 999;
152    is $xx, 888;
153}
154
155
156My::testParseParameters();
157
158
159{
160    title "isaFilename" ;
161    ok   isaFilename("abc"), "'abc' isaFilename";
162
163    ok ! isaFilename(undef), "undef ! isaFilename";
164    ok ! isaFilename([]),    "[] ! isaFilename";
165    $main::X = 1; $main::X = $main::X ;
166    ok ! isaFilename(*X),    "glob ! isaFilename";
167}
168
169{
170    title "whatIsInput" ;
171
172    my $lex = new LexFile my $out_file ;
173    open FH, ">$out_file" ;
174    is whatIsInput(*FH), 'handle', "Match filehandle" ;
175    close FH ;
176
177    my $stdin = '-';
178    is whatIsInput($stdin),       'handle',   "Match '-' as stdin";
179    #is $stdin,                    \*STDIN,    "'-' changed to *STDIN";
180    #isa_ok $stdin,                'IO::File',    "'-' changed to IO::File";
181    is whatIsInput("abc"),        'filename', "Match filename";
182    is whatIsInput(\"abc"),       'buffer',   "Match buffer";
183    is whatIsInput(sub { 1 }, 1), 'code',     "Match code";
184    is whatIsInput(sub { 1 }),    ''   ,      "Don't match code";
185
186}
187
188{
189    title "whatIsOutput" ;
190
191    my $lex = new LexFile my $out_file ;
192    open FH, ">$out_file" ;
193    is whatIsOutput(*FH), 'handle', "Match filehandle" ;
194    close FH ;
195
196    my $stdout = '-';
197    is whatIsOutput($stdout),     'handle',   "Match '-' as stdout";
198    #is $stdout,                   \*STDOUT,   "'-' changed to *STDOUT";
199    #isa_ok $stdout,               'IO::File',    "'-' changed to IO::File";
200    is whatIsOutput("abc"),        'filename', "Match filename";
201    is whatIsOutput(\"abc"),       'buffer',   "Match buffer";
202    is whatIsOutput(sub { 1 }, 1), 'code',     "Match code";
203    is whatIsOutput(sub { 1 }),    ''   ,      "Don't match code";
204
205}
206
207# U64
208
209{
210    title "U64" ;
211
212    my $x = new U64();
213    is $x->getHigh, 0, "  getHigh is 0";
214    is $x->getLow, 0, "  getLow is 0";
215    ok ! $x->is64bit(), " ! is64bit";
216
217    $x = new U64(1,2);
218    is $x->getHigh, 1, "  getHigh is 1";
219    is $x->getLow, 2, "  getLow is 2";
220    ok $x->is64bit(), " is64bit";
221
222    $x = new U64(0xFFFFFFFF,2);
223    is $x->getHigh, 0xFFFFFFFF, "  getHigh is 0xFFFFFFFF";
224    is $x->getLow, 2, "  getLow is 2";
225    ok $x->is64bit(), " is64bit";
226
227    $x = new U64(7, 0xFFFFFFFF);
228    is $x->getHigh, 7, "  getHigh is 7";
229    is $x->getLow, 0xFFFFFFFF, "  getLow is 0xFFFFFFFF";
230    ok $x->is64bit(), " is64bit";
231
232    $x = new U64(666);
233    is $x->getHigh, 0, "  getHigh is 0";
234    is $x->getLow, 666, "  getLow is 666";
235    ok ! $x->is64bit(), " ! is64bit";
236
237    title "U64 - add" ;
238
239    $x = new U64(0, 1);
240    is $x->getHigh, 0, "  getHigh is 0";
241    is $x->getLow, 1, "  getLow is 1";
242    ok ! $x->is64bit(), " ! is64bit";
243
244    $x->add(1);
245    is $x->getHigh, 0, "  getHigh is 0";
246    is $x->getLow, 2, "  getLow is 2";
247    ok ! $x->is64bit(), " ! is64bit";
248
249    $x = new U64(0, 0xFFFFFFFE);
250    is $x->getHigh, 0, "  getHigh is 0";
251    is $x->getLow, 0xFFFFFFFE, "  getLow is 0xFFFFFFFE";
252    is $x->get32bit(),  0xFFFFFFFE, "  get32bit is 0xFFFFFFFE";
253    is $x->get64bit(),  0xFFFFFFFE, "  get64bit is 0xFFFFFFFE";
254    ok ! $x->is64bit(), " ! is64bit";
255
256    $x->add(1);
257    is $x->getHigh, 0, "  getHigh is 0";
258    is $x->getLow, 0xFFFFFFFF, "  getLow is 0xFFFFFFFF";
259    is $x->get32bit(),  0xFFFFFFFF, "  get32bit is 0xFFFFFFFF";
260    is $x->get64bit(),  0xFFFFFFFF, "  get64bit is 0xFFFFFFFF";
261    ok ! $x->is64bit(), " ! is64bit";
262
263    $x->add(1);
264    is $x->getHigh, 1, "  getHigh is 1";
265    is $x->getLow, 0, "  getLow is 0";
266    is $x->get32bit(),  0x0, "  get32bit is 0x0";
267    is $x->get64bit(), 0xFFFFFFFF+1, "  get64bit is 0x100000000";
268    ok $x->is64bit(), " is64bit";
269
270    $x->add(1);
271    is $x->getHigh, 1, "  getHigh is 1";
272    is $x->getLow, 1, "  getLow is 1";
273    is $x->get32bit(),  0x1, "  get32bit is 0x1";
274    is $x->get64bit(),  0xFFFFFFFF+2, "  get64bit is 0x100000001";
275    ok $x->is64bit(), " is64bit";
276
277    $x->add(1);
278    is $x->getHigh, 1, "  getHigh is 1";
279    is $x->getLow, 2, "  getLow is 1";
280    is $x->get32bit(),  0x2, "  get32bit is 0x2";
281    is $x->get64bit(),  0xFFFFFFFF+3, "  get64bit is 0x100000002";
282    ok $x->is64bit(), " is64bit";
283
284    $x = new U64(1, 0xFFFFFFFE);
285    my $y = new U64(2, 3);
286
287    $x->add($y);
288    is $x->getHigh, 4, "  getHigh is 4";
289    is $x->getLow, 1, "  getLow is 1";
290    ok $x->is64bit(), " is64bit";
291
292    title "U64 - equal" ;
293
294    $x = new U64(0, 1);
295    is $x->getHigh, 0, "  getHigh is 0";
296    is $x->getLow, 1, "  getLow is 1";
297    ok ! $x->is64bit(), " ! is64bit";
298
299    $y = new U64(0, 1);
300    is $y->getHigh, 0, "  getHigh is 0";
301    is $y->getLow, 1, "  getLow is 1";
302    ok ! $y->is64bit(), " ! is64bit";
303
304    my $z = new U64(0, 2);
305    is $z->getHigh, 0, "  getHigh is 0";
306    is $z->getLow, 2, "  getLow is 2";
307    ok ! $z->is64bit(), " ! is64bit";
308
309    ok $x->equal($y), "  equal";
310    ok !$x->equal($z), "  ! equal";
311
312    title "U64 - clone" ;
313    $x = new U64(21, 77);
314    $z =  U64::clone($x);
315    is $z->getHigh, 21, "  getHigh is 21";
316    is $z->getLow, 77, "  getLow is 77";
317}
318