cpan/IO-Compress/t/01misc.t

   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
  22     plan tests => 163 + $extra ;
  23
  24     use_ok('Scalar::Util');
  25     use_ok('IO::Compress::Base::Common');
  26 }
  27
  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
  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' => [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
 195 My::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 }