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 => 78 + $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 =>
  99 undef) ;
 100     ok $got->parsed('Fred'), "undef" ;
 101     ok ! defined $got->value('Fred'), "undef" ;
 102
 103     $got = ParseParameters(1, {'Fred' => [0, 1, Parse_string, undef]}, Fred =>
 104 undef) ;
 105     ok $got->parsed('Fred'), "undef" ;
 106     is $got->value('Fred'), "", "empty string" ;
 107
 108     my $xx;
 109     $got = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, Fred => $xx) ;
 110
 111     ok $got->parsed('Fred'), "parsed" ;
 112     my $xx_ref = $got->value('Fred');
 113     $$xx_ref = 77 ;
 114     is $xx, 77;
 115
 116     $got = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, Fred => \$xx) ;
 117
 118     ok $got->parsed('Fred'), "parsed" ;
 119     $xx_ref = $got->value('Fred');
 120     $$xx_ref = 666 ;
 121     is $xx, 666;
 122
 123 }
 124
 125 My::testParseParameters();
 126
 127
 128 {
 129     title "isaFilename" ;
 130     ok   isaFilename("abc"), "'abc' isaFilename";
 131
 132     ok ! isaFilename(undef), "undef ! isaFilename";
 133     ok ! isaFilename([]),    "[] ! isaFilename";
 134     $main::X = 1; $main::X = $main::X ;
 135     ok ! isaFilename(*X),    "glob ! isaFilename";
 136 }
 137
 138 {
 139     title "whatIsInput" ;
 140
 141     my $lex = new LexFile my $out_file ;
 142     open FH, ">$out_file" ;
 143     is whatIsInput(*FH), 'handle', "Match filehandle" ;
 144     close FH ;
 145
 146     my $stdin = '-';
 147     is whatIsInput($stdin),       'handle',   "Match '-' as stdin";
 148     #is $stdin,                    \*STDIN,    "'-' changed to *STDIN";
 149     #isa_ok $stdin,                'IO::File',    "'-' changed to IO::File";
 150     is whatIsInput("abc"),        'filename', "Match filename";
 151     is whatIsInput(\"abc"),       'buffer',   "Match buffer";
 152     is whatIsInput(sub { 1 }, 1), 'code',     "Match code";
 153     is whatIsInput(sub { 1 }),    ''   ,      "Don't match code";
 154
 155 }
 156
 157 {
 158     title "whatIsOutput" ;
 159
 160     my $lex = new LexFile my $out_file ;
 161     open FH, ">$out_file" ;
 162     is whatIsOutput(*FH), 'handle', "Match filehandle" ;
 163     close FH ;
 164
 165     my $stdout = '-';
 166     is whatIsOutput($stdout),     'handle',   "Match '-' as stdout";
 167     #is $stdout,                   \*STDOUT,   "'-' changed to *STDOUT";
 168     #isa_ok $stdout,               'IO::File',    "'-' changed to IO::File";
 169     is whatIsOutput("abc"),        'filename', "Match filename";
 170     is whatIsOutput(\"abc"),       'buffer',   "Match buffer";
 171     is whatIsOutput(sub { 1 }, 1), 'code',     "Match code";
 172     is whatIsOutput(sub { 1 }),    ''   ,      "Don't match code";
 173
 174 }
 175
 176 # U64
 177
 178 {
 179     title "U64" ;
 180
 181     my $x = new U64();
 182     is $x->getHigh, 0, "  getHigh is 0";
 183     is $x->getLow, 0, "  getLow is 0";
 184
 185     $x = new U64(1,2);
 186     $x = new U64(1,2);
 187     is $x->getHigh, 1, "  getHigh is 1";
 188     is $x->getLow, 2, "  getLow is 2";
 189
 190     $x = new U64(0xFFFFFFFF,2);
 191     is $x->getHigh, 0xFFFFFFFF, "  getHigh is 0xFFFFFFFF";
 192     is $x->getLow, 2, "  getLow is 2";
 193
 194     $x = new U64(7, 0xFFFFFFFF);
 195     is $x->getHigh, 7, "  getHigh is 7";
 196     is $x->getLow, 0xFFFFFFFF, "  getLow is 0xFFFFFFFF";
 197
 198     $x = new U64(666);
 199     is $x->getHigh, 0, "  getHigh is 0";
 200     is $x->getLow, 666, "  getLow is 666";
 201
 202     title "U64 - add" ;
 203
 204     $x = new U64(0, 1);
 205     is $x->getHigh, 0, "  getHigh is 0";
 206     is $x->getLow, 1, "  getLow is 1";
 207
 208     $x->add(1);
 209     is $x->getHigh, 0, "  getHigh is 0";
 210     is $x->getLow, 2, "  getLow is 2";
 211
 212     $x = new U64(0, 0xFFFFFFFE);
 213     is $x->getHigh, 0, "  getHigh is 0";
 214     is $x->getLow, 0xFFFFFFFE, "  getLow is 0xFFFFFFFE";
 215
 216     $x->add(1);
 217     is $x->getHigh, 0, "  getHigh is 0";
 218     is $x->getLow, 0xFFFFFFFF, "  getLow is 0xFFFFFFFF";
 219
 220     $x->add(1);
 221     is $x->getHigh, 1, "  getHigh is 1";
 222     is $x->getLow, 0, "  getLow is 0";
 223
 224     $x->add(1);
 225     is $x->getHigh, 1, "  getHigh is 1";
 226     is $x->getLow, 1, "  getLow is 1";
 227
 228     $x = new U64(1, 0xFFFFFFFE);
 229     my $y = new U64(2, 3);
 230
 231     $x->add($y);
 232     is $x->getHigh, 4, "  getHigh is 4";
 233     is $x->getLow, 1, "  getLow is 1";
 234
 235     title "U64 - equal" ;
 236
 237     $x = new U64(0, 1);
 238     is $x->getHigh, 0, "  getHigh is 0";
 239     is $x->getLow, 1, "  getLow is 1";
 240
 241     $y = new U64(0, 1);
 242     is $x->getHigh, 0, "  getHigh is 0";
 243     is $x->getLow, 1, "  getLow is 1";
 244
 245     my $z = new U64(0, 2);
 246     is $x->getHigh, 0, "  getHigh is 0";
 247     is $x->getLow, 1, "  getLow is 1";
 248
 249     ok $x->equal($y), "  equal";
 250     ok !$x->equal($z), "  ! equal";
 251
 252     title "U64 - pack_V" ;
 253 }