[p5sagit/p5-mst-13.2.git] / ext / IO / Compress / Base / t / 01misc.t

BEGIN {
    if ($ENV{PERL_CORE}) {
	chdir 't' if -d 't';
	@INC = ("../lib", "lib/compress");
    }
}

use lib qw(t t/compress);
use strict;
use warnings;
use bytes;

use Test::More ; 
use CompTestUtils;

BEGIN {
    # use Test::NoWarnings, if available
    my $extra = 0 ;
    $extra = 1
        if eval { require Test::NoWarnings ;  import Test::NoWarnings; 1 };

    plan tests => 76 + $extra ;

    use_ok('IO::Compress::Base::Common');
}

# Compress::Zlib::Common;

sub My::testParseParameters()
{
    eval { ParseParameters(1, {}, 1) ; };
    like $@, mkErr(': Expected even number of parameters, got 1'), 
            "Trap odd number of params";

    eval { ParseParameters(1, {}, undef) ; };
    like $@, mkErr(': Expected even number of parameters, got 1'), 
            "Trap odd number of params";

    eval { ParseParameters(1, {}, []) ; };
    like $@, mkErr(': Expected even number of parameters, got 1'), 
            "Trap odd number of params";

    eval { ParseParameters(1, {'Fred' => [1, 1, Parse_boolean, 0]}, Fred => 'joe') ; };
    like $@, mkErr("Parameter 'Fred' must be an int, got 'joe'"), 
            "wanted unsigned, got undef";

    eval { ParseParameters(1, {'Fred' => [1, 1, Parse_unsigned, 0]}, Fred => undef) ; };
    like $@, mkErr("Parameter 'Fred' must be an unsigned int, got 'undef'"), 
            "wanted unsigned, got undef";

    eval { ParseParameters(1, {'Fred' => [1, 1, Parse_signed, 0]}, Fred => undef) ; };
    like $@, mkErr("Parameter 'Fred' must be a signed int, got 'undef'"), 
            "wanted signed, got undef";

    eval { ParseParameters(1, {'Fred' => [1, 1, Parse_signed, 0]}, Fred => 'abc') ; };
    like $@, mkErr("Parameter 'Fred' must be a signed int, got 'abc'"), 
            "wanted signed, got 'abc'";


    SKIP:
    {
        use Config;

        skip 'readonly + threads', 1
            if $Config{useithreads};

        eval { ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, 0]}, Fred => 'abc') ; };
        like $@, mkErr("Parameter 'Fred' not writable"), 
                "wanted writable, got readonly";
    }

    my @xx;
    eval { ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, 0]}, Fred => \@xx) ; };
    like $@, mkErr("Parameter 'Fred' not a scalar reference"), 
            "wanted scalar reference";

    local *ABC;
    eval { ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, 0]}, Fred => *ABC) ; };
    like $@, mkErr("Parameter 'Fred' not a scalar"), 
            "wanted scalar";

    #eval { ParseParameters(1, {'Fred' => [1, 1, Parse_any|Parse_multiple, 0]}, Fred => 1, Fred => 2) ; };
    #like $@, mkErr("Muliple instances of 'Fred' found"),
        #"wanted scalar";

    ok 1;

    my $got = ParseParameters(1, {'Fred' => [1, 1, 0x1000000, 0]}, Fred => 'abc') ;
    is $got->value('Fred'), "abc", "other" ;

    $got = ParseParameters(1, {'Fred' => [0, 1, Parse_any, undef]}, Fred =>
undef) ;
    ok $got->parsed('Fred'), "undef" ;
    ok ! defined $got->value('Fred'), "undef" ;

    $got = ParseParameters(1, {'Fred' => [0, 1, Parse_string, undef]}, Fred =>
undef) ;
    ok $got->parsed('Fred'), "undef" ;
    is $got->value('Fred'), "", "empty string" ;

    my $xx;
    $got = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, Fred => $xx) ;

    ok $got->parsed('Fred'), "parsed" ;
    my $xx_ref = $got->value('Fred');
    $$xx_ref = 77 ;
    is $xx, 77;

    $got = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, Fred => \$xx) ;

    ok $got->parsed('Fred'), "parsed" ;
    $xx_ref = $got->value('Fred');
    $$xx_ref = 666 ;
    is $xx, 666;

}

My::testParseParameters();


{
    title "isaFilename" ;
    ok   isaFilename("abc"), "'abc' isaFilename";

    ok ! isaFilename(undef), "undef ! isaFilename";
    ok ! isaFilename([]),    "[] ! isaFilename";
    $main::X = 1; $main::X = $main::X ;
    ok ! isaFilename(*X),    "glob ! isaFilename";
}

{
    title "whatIsInput" ;

    my $lex = new LexFile my $out_file ;
    open FH, ">$out_file" ;
    is whatIsInput(*FH), 'handle', "Match filehandle" ;
    close FH ;

    my $stdin = '-';
    is whatIsInput($stdin),       'handle',   "Match '-' as stdin";
    #is $stdin,                    \*STDIN,    "'-' changed to *STDIN";
    #isa_ok $stdin,                'IO::File',    "'-' changed to IO::File";
    is whatIsInput("abc"),        'filename', "Match filename";
    is whatIsInput(\"abc"),       'buffer',   "Match buffer";
    is whatIsInput(sub { 1 }, 1), 'code',     "Match code";
    is whatIsInput(sub { 1 }),    ''   ,      "Don't match code";

}

{
    title "whatIsOutput" ;

    my $lex = new LexFile my $out_file ;
    open FH, ">$out_file" ;
    is whatIsOutput(*FH), 'handle', "Match filehandle" ;
    close FH ;

    my $stdout = '-';
    is whatIsOutput($stdout),     'handle',   "Match '-' as stdout";
    #is $stdout,                   \*STDOUT,   "'-' changed to *STDOUT";
    #isa_ok $stdout,               'IO::File',    "'-' changed to IO::File";
    is whatIsOutput("abc"),        'filename', "Match filename";
    is whatIsOutput(\"abc"),       'buffer',   "Match buffer";
    is whatIsOutput(sub { 1 }, 1), 'code',     "Match code";
    is whatIsOutput(sub { 1 }),    ''   ,      "Don't match code";

}

# U64

{
    title "U64" ;

    my $x = new U64();
    is $x->getHigh, 0, "  getHigh is 0";
    is $x->getLow, 0, "  getLow is 0";

    $x = new U64(1,2);
    $x = new U64(1,2);
    is $x->getHigh, 1, "  getHigh is 1";
    is $x->getLow, 2, "  getLow is 2";

    $x = new U64(0xFFFFFFFF,2);
    is $x->getHigh, 0xFFFFFFFF, "  getHigh is 0xFFFFFFFF";
    is $x->getLow, 2, "  getLow is 2";

    $x = new U64(7, 0xFFFFFFFF);
    is $x->getHigh, 7, "  getHigh is 7";
    is $x->getLow, 0xFFFFFFFF, "  getLow is 0xFFFFFFFF";

    $x = new U64(666);
    is $x->getHigh, 0, "  getHigh is 0";
    is $x->getLow, 666, "  getLow is 666";

    title "U64 - add" ;

    $x = new U64(0, 1);
    is $x->getHigh, 0, "  getHigh is 0";
    is $x->getLow, 1, "  getLow is 1";

    $x->add(1);
    is $x->getHigh, 0, "  getHigh is 0";
    is $x->getLow, 2, "  getLow is 2";

    $x = new U64(0, 0xFFFFFFFE);
    is $x->getHigh, 0, "  getHigh is 0";
    is $x->getLow, 0xFFFFFFFE, "  getLow is 0xFFFFFFFE";

    $x->add(1);
    is $x->getHigh, 0, "  getHigh is 0";
    is $x->getLow, 0xFFFFFFFF, "  getLow is 0xFFFFFFFF";

    $x->add(1);
    is $x->getHigh, 1, "  getHigh is 1";
    is $x->getLow, 0, "  getLow is 0";

    $x->add(1);
    is $x->getHigh, 1, "  getHigh is 1";
    is $x->getLow, 1, "  getLow is 1";

    $x = new U64(1, 0xFFFFFFFE);
    my $y = new U64(2, 3);

    $x->add($y);
    is $x->getHigh, 4, "  getHigh is 4";
    is $x->getLow, 1, "  getLow is 1";

    title "U64 - equal" ;

    $x = new U64(0, 1);
    is $x->getHigh, 0, "  getHigh is 0";
    is $x->getLow, 1, "  getLow is 1";

    $y = new U64(0, 1);
    is $x->getHigh, 0, "  getHigh is 0";
    is $x->getLow, 1, "  getLow is 1";

    my $z = new U64(0, 2);
    is $x->getHigh, 0, "  getHigh is 0";
    is $x->getLow, 1, "  getLow is 1";

    ok $x->equal($y), "  equal";
    ok !$x->equal($z), "  ! equal";

    title "U64 - pack_V" ;
}
Commit	Line	Data
25f0751f	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
258133d1	22	plan tests => 76 + $extra ;
25f0751f	23
25f0751f	24	use_ok('IO::Compress::Base::Common');
25f0751f	25	}
25f0751f	26
25f0751f	27	# Compress::Zlib::Common;
	28
	29	sub My::testParseParameters()
	30	{
	31	eval { ParseParameters(1, {}, 1) ; };
	32	like $@, mkErr(': Expected even number of parameters, got 1'),
	33	"Trap odd number of params";
	34
	35	eval { ParseParameters(1, {}, undef) ; };
	36	like $@, mkErr(': Expected even number of parameters, got 1'),
	37	"Trap odd number of params";
	38
	39	eval { ParseParameters(1, {}, []) ; };
	40	like $@, mkErr(': Expected even number of parameters, got 1'),
	41	"Trap odd number of params";
	42
	43	eval { ParseParameters(1, {'Fred' => [1, 1, Parse_boolean, 0]}, Fred => 'joe') ; };
	44	like $@, mkErr("Parameter 'Fred' must be an int, got 'joe'"),
	45	"wanted unsigned, got undef";
	46
	47	eval { ParseParameters(1, {'Fred' => [1, 1, Parse_unsigned, 0]}, Fred => undef) ; };
	48	like $@, mkErr("Parameter 'Fred' must be an unsigned int, got 'undef'"),
	49	"wanted unsigned, got undef";
	50
	51	eval { ParseParameters(1, {'Fred' => [1, 1, Parse_signed, 0]}, Fred => undef) ; };
	52	like $@, mkErr("Parameter 'Fred' must be a signed int, got 'undef'"),
	53	"wanted signed, got undef";
	54
	55	eval { ParseParameters(1, {'Fred' => [1, 1, Parse_signed, 0]}, Fred => 'abc') ; };
	56	like $@, mkErr("Parameter 'Fred' must be a signed int, got 'abc'"),
	57	"wanted signed, got 'abc'";
	58
80213491	59
	60	SKIP:
	61	{
	62	use Config;
	63
	64	skip 'readonly + threads', 1
	65	if $Config{useithreads};
	66
	67	eval { ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, 0]}, Fred => 'abc') ; };
	68	like $@, mkErr("Parameter 'Fred' not writable"),
	69	"wanted writable, got readonly";
	70	}
258133d1	71
	72	my @xx;
	73	eval { ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, 0]}, Fred => \@xx) ; };
	74	like $@, mkErr("Parameter 'Fred' not a scalar reference"),
	75	"wanted scalar reference";
	76
	77	local *ABC;
	78	eval { ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, 0]}, Fred => *ABC) ; };
	79	like $@, mkErr("Parameter 'Fred' not a scalar"),
	80	"wanted scalar";
25f0751f	81
258133d1	82	#eval { ParseParameters(1, {'Fred' => [1, 1, Parse_any\|Parse_multiple, 0]}, Fred => 1, Fred => 2) ; };
	83	#like $@, mkErr("Muliple instances of 'Fred' found"),
	84	#"wanted scalar";
	85
	86	ok 1;
	87
	88	my $got = ParseParameters(1, {'Fred' => [1, 1, 0x1000000, 0]}, Fred => 'abc') ;
25f0751f	89	is $got->value('Fred'), "abc", "other" ;
25f0751f	90
c70c1701	91	$got = ParseParameters(1, {'Fred' => [0, 1, Parse_any, undef]}, Fred =>
	92	undef) ;
	93	ok $got->parsed('Fred'), "undef" ;
	94	ok ! defined $got->value('Fred'), "undef" ;
	95
	96	$got = ParseParameters(1, {'Fred' => [0, 1, Parse_string, undef]}, Fred =>
	97	undef) ;
	98	ok $got->parsed('Fred'), "undef" ;
	99	is $got->value('Fred'), "", "empty string" ;
	100
258133d1	101	my $xx;
	102	$got = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, Fred => $xx) ;
	103
	104	ok $got->parsed('Fred'), "parsed" ;
	105	my $xx_ref = $got->value('Fred');
	106	$$xx_ref = 77 ;
	107	is $xx, 77;
	108
	109	$got = ParseParameters(1, {'Fred' => [1, 1, Parse_writable_scalar, undef]}, Fred => \$xx) ;
	110
	111	ok $got->parsed('Fred'), "parsed" ;
	112	$xx_ref = $got->value('Fred');
	113	$$xx_ref = 666 ;
	114	is $xx, 666;
	115
25f0751f	116	}
	117
	118	My::testParseParameters();
	119
	120
	121	{
	122	title "isaFilename" ;
	123	ok isaFilename("abc"), "'abc' isaFilename";
	124
	125	ok ! isaFilename(undef), "undef ! isaFilename";
	126	ok ! isaFilename([]), "[] ! isaFilename";
	127	$main::X = 1; $main::X = $main::X ;
	128	ok ! isaFilename(*X), "glob ! isaFilename";
	129	}
	130
	131	{
	132	title "whatIsInput" ;
	133
	134	my $lex = new LexFile my $out_file ;
	135	open FH, ">$out_file" ;
	136	is whatIsInput(*FH), 'handle', "Match filehandle" ;
	137	close FH ;
	138
	139	my $stdin = '-';
	140	is whatIsInput($stdin), 'handle', "Match '-' as stdin";
	141	#is $stdin, \STDIN, "'-' changed to STDIN";
	142	#isa_ok $stdin, 'IO::File', "'-' changed to IO::File";
	143	is whatIsInput("abc"), 'filename', "Match filename";
	144	is whatIsInput(\"abc"), 'buffer', "Match buffer";
	145	is whatIsInput(sub { 1 }, 1), 'code', "Match code";
	146	is whatIsInput(sub { 1 }), '' , "Don't match code";
	147
	148	}
	149
	150	{
	151	title "whatIsOutput" ;
	152
	153	my $lex = new LexFile my $out_file ;
	154	open FH, ">$out_file" ;
	155	is whatIsOutput(*FH), 'handle', "Match filehandle" ;
	156	close FH ;
	157
	158	my $stdout = '-';
	159	is whatIsOutput($stdout), 'handle', "Match '-' as stdout";
	160	#is $stdout, \STDOUT, "'-' changed to STDOUT";
	161	#isa_ok $stdout, 'IO::File', "'-' changed to IO::File";
	162	is whatIsOutput("abc"), 'filename', "Match filename";
	163	is whatIsOutput(\"abc"), 'buffer', "Match buffer";
	164	is whatIsOutput(sub { 1 }, 1), 'code', "Match code";
	165	is whatIsOutput(sub { 1 }), '' , "Don't match code";
	166
	167	}
e7d45986	168
	169	# U64
	170
	171	{
	172	title "U64" ;
	173
	174	my $x = new U64();
	175	is $x->getHigh, 0, " getHigh is 0";
	176	is $x->getLow, 0, " getLow is 0";
	177
	178	$x = new U64(1,2);
	179	$x = new U64(1,2);
	180	is $x->getHigh, 1, " getHigh is 1";
	181	is $x->getLow, 2, " getLow is 2";
	182
	183	$x = new U64(0xFFFFFFFF,2);
	184	is $x->getHigh, 0xFFFFFFFF, " getHigh is 0xFFFFFFFF";
	185	is $x->getLow, 2, " getLow is 2";
	186
	187	$x = new U64(7, 0xFFFFFFFF);
	188	is $x->getHigh, 7, " getHigh is 7";
	189	is $x->getLow, 0xFFFFFFFF, " getLow is 0xFFFFFFFF";
	190
	191	$x = new U64(666);
	192	is $x->getHigh, 0, " getHigh is 0";
	193	is $x->getLow, 666, " getLow is 666";
	194
	195	title "U64 - add" ;
	196
	197	$x = new U64(0, 1);
	198	is $x->getHigh, 0, " getHigh is 0";
	199	is $x->getLow, 1, " getLow is 1";
	200
	201	$x->add(1);
	202	is $x->getHigh, 0, " getHigh is 0";
	203	is $x->getLow, 2, " getLow is 2";
	204
	205	$x = new U64(0, 0xFFFFFFFE);
	206	is $x->getHigh, 0, " getHigh is 0";
	207	is $x->getLow, 0xFFFFFFFE, " getLow is 0xFFFFFFFE";
	208
	209	$x->add(1);
	210	is $x->getHigh, 0, " getHigh is 0";
	211	is $x->getLow, 0xFFFFFFFF, " getLow is 0xFFFFFFFF";
	212
	213	$x->add(1);
	214	is $x->getHigh, 1, " getHigh is 1";
	215	is $x->getLow, 0, " getLow is 0";
	216
	217	$x->add(1);
	218	is $x->getHigh, 1, " getHigh is 1";
	219	is $x->getLow, 1, " getLow is 1";
	220
	221	$x = new U64(1, 0xFFFFFFFE);
	222	my $y = new U64(2, 3);
	223
	224	$x->add($y);
	225	is $x->getHigh, 4, " getHigh is 4";
	226	is $x->getLow, 1, " getLow is 1";
	227
	228	title "U64 - equal" ;
	229
	230	$x = new U64(0, 1);
	231	is $x->getHigh, 0, " getHigh is 0";
232	is $x->getLow, 1, " getLow is 1";
233
234	$y = new U64(0, 1);
235	is $x->getHigh, 0, " getHigh is 0";
236	is $x->getLow, 1, " getLow is 1";
237
238	my $z = new U64(0, 2);
239	is $x->getHigh, 0, " getHigh is 0";
240	is $x->getLow, 1, " getLow is 1";
241
242	ok $x->equal($y), " equal";
243	ok !$x->equal($z), " ! equal";
244
245	title "U64 - pack_V" ;
246	}