ext/IO_Compress_Base/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 => 88 + $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' => [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|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') ;
  96     is $got->value('Fred'), "abc", "other" ;
  97
  98     $got = ParseParameters(1, {'Fred' => [0, 1, Parse_any, undef]}, Fred => undef) ;
  99     ok $got->parsed('Fred'), "undef" ;
 100     ok ! defined $got->value('Fred'), "undef" ;
 101
 102     $got = ParseParameters(1, {'Fred' => [0, 1, Parse_string, undef]}, Fred => undef) ;
 103     ok $got->parsed('Fred'), "undef" ;
 104     is $got->value('Fred'), "", "empty string" ;
 105
 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');
 118
 119     $$xx_ref = 666 ;
 120     is $xx, 666;
 121
 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;
 150 }
 151
 152
 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 }
 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";
 212
 213     $x = new U64(1,2);
 214     $x = new U64(1,2);
 215     is $x->getHigh, 1, "  getHigh is 1";
 216     is $x->getLow, 2, "  getLow is 2";
 217
 218     $x = new U64(0xFFFFFFFF,2);
 219     is $x->getHigh, 0xFFFFFFFF, "  getHigh is 0xFFFFFFFF";
 220     is $x->getLow, 2, "  getLow is 2";
 221
 222     $x = new U64(7, 0xFFFFFFFF);
 223     is $x->getHigh, 7, "  getHigh is 7";
 224     is $x->getLow, 0xFFFFFFFF, "  getLow is 0xFFFFFFFF";
 225
 226     $x = new U64(666);
 227     is $x->getHigh, 0, "  getHigh is 0";
 228     is $x->getLow, 666, "  getLow is 666";
 229
 230     title "U64 - add" ;
 231
 232     $x = new U64(0, 1);
 233     is $x->getHigh, 0, "  getHigh is 0";
 234     is $x->getLow, 1, "  getLow is 1";
 235
 236     $x->add(1);
 237     is $x->getHigh, 0, "  getHigh is 0";
 238     is $x->getLow, 2, "  getLow is 2";
 239
 240     $x = new U64(0, 0xFFFFFFFE);
 241     is $x->getHigh, 0, "  getHigh is 0";
 242     is $x->getLow, 0xFFFFFFFE, "  getLow is 0xFFFFFFFE";
 243
 244     $x->add(1);
 245     is $x->getHigh, 0, "  getHigh is 0";
 246     is $x->getLow, 0xFFFFFFFF, "  getLow is 0xFFFFFFFF";
 247
 248     $x->add(1);
 249     is $x->getHigh, 1, "  getHigh is 1";
 250     is $x->getLow, 0, "  getLow is 0";
 251
 252     $x->add(1);
 253     is $x->getHigh, 1, "  getHigh is 1";
 254     is $x->getLow, 1, "  getLow is 1";
 255
 256     $x = new U64(1, 0xFFFFFFFE);
 257     my $y = new U64(2, 3);
 258
 259     $x->add($y);
 260     is $x->getHigh, 4, "  getHigh is 4";
 261     is $x->getLow, 1, "  getLow is 1";
 262
 263     title "U64 - equal" ;
 264
 265     $x = new U64(0, 1);
 266     is $x->getHigh, 0, "  getHigh is 0";
 267     is $x->getLow, 1, "  getLow is 1";
 268
 269     $y = new U64(0, 1);
 270     is $x->getHigh, 0, "  getHigh is 0";
 271     is $x->getLow, 1, "  getLow is 1";
 272
 273     my $z = new U64(0, 2);
 274     is $x->getHigh, 0, "  getHigh is 0";
 275     is $x->getLow, 1, "  getLow is 1";
 276
 277     ok $x->equal($y), "  equal";
 278     ok !$x->equal($z), "  ! equal";
 279
 280     title "U64 - pack_V" ;
 281 }