[perl5.git] / dist / Storable / t / interwork56.t

#!./perl -w
#
#  Copyright 2002, Larry Wall.
#
#  You may redistribute only under the same terms as Perl 5, as specified
#  in the README file that comes with the distribution.
#

# I ought to keep this test easily backwards compatible to 5.004, so no
# qr//;

# This test checks whether the kludge to interwork with 5.6 Storables compiled
# on Unix systems with IV as long long works.

sub BEGIN {
    unshift @INC, 't';
    require Config; import Config;
    if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
        print "1..0 # Skip: Storable was not built\n";
        exit 0;
    }
    unless ($Config{ivsize} and $Config{ivsize} > $Config{longsize}) {
        print "1..0 # Skip: Your IVs are no larger than your longs\n";
        exit 0;
    }
}

use Storable qw(freeze thaw);
use strict;
use Test::More tests=>30;

use vars qw(%tests);

{
    local $/ = "\n\nend\n";
    while (<DATA>) {
        next unless /\S/s;
        unless (/begin ([0-7]{3}) ([^\n]*)\n(.*)$/s) {
            s/\n.*//s;
            warn "Dodgy data in section starting '$_'";
            next;
        }
        next unless oct $1 == ord 'A'; # Skip ASCII on EBCDIC, and vice versa
        my $data = unpack 'u', $3;
        $tests{$2} = $data;
    }
}

# perl makes easy things easy, and hard things possible:
my $test = freeze \'Hell';

my $header = Storable::read_magic ($test);

is ($header->{byteorder}, $Config{byteorder},
    "header's byteorder and Config.pm's should agree");

my $result = eval {thaw $test};
isa_ok ($result, 'SCALAR', "Check thawing test data");
is ($@, '', "causes no errors");
is ($$result, 'Hell', 'and gives the expected data');

my $kingdom = $Config{byteorder} =~ /23/ ? "Lillput" : "Belfuscu";

my $name = join ',', $kingdom, @$header{qw(intsize longsize ptrsize nvsize)};

SKIP: {
    my $real_thing = $tests{$name};
    if (!defined $real_thing) {
        print << "EOM";
# No test data for Storable 1.x for:
#
# byteorder	 '$Config{byteorder}'
# sizeof(int)	 $$header{intsize}
# sizeof(long)	 $$header{longsize}
# sizeof(char *) $$header{ptrsize}
# sizeof(NV)	 $$header{nvsize}

# If you have Storable 1.x built with perl 5.6.x on this platform, please
# make_56_interwork.pl to generate test data, and append the test data to
# this test. 
# You may find that make_56_interwork.pl reports that your platform has no
# interworking problems, in which case you need do nothing.
EOM
        skip "# No 1.x test file", 9;
    }
    my $result = eval {thaw $real_thing};
    is ($result, undef, "By default should not be able to thaw");
    like ($@, qr/Byte order is not compatible/,
          "because the header byte order strings differ");
    local $Storable::interwork_56_64bit = 1;
    $result = eval {thaw $real_thing};
    isa_ok ($result, 'ARRAY', "With flag should now thaw");
    is ($@, '', "with no errors");

    # However, as the file is written with Storable pre 2.01, it's a known
    # bug that large (positive) UVs become IVs
    my $value = (~0 ^ (~0 >> 1) ^ 2);

    is (@$result, 4, "4 elements in array");
    like ($$result[0],
          qr/^This file was written with [0-9.]+ on perl [0-9.]+\z/,
         "1st element");
    is ($$result[1], "$kingdom was correct", "2nd element");
    cmp_ok ($$result[2] ^ $value, '==', 0, "3rd element") or
        printf "# expected %#X, got %#X\n", $value, $$result[2];
    is ($$result[3], "The End", "4th element");
}

$result = eval {thaw $test};
isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data");
is ($@, '', "        causes no errors");
is ($$result, 'Hell', "        and gives the expected data");

my $test_kludge;
{
    local $Storable::interwork_56_64bit = 1;
    $test_kludge = freeze \'Heck';
}

my $header_kludge = Storable::read_magic ($test_kludge);

cmp_ok (length ($header_kludge->{byteorder}), '==', $Config{longsize},
        "With 5.6 interwork kludge byteorder string should be same size as long"
       );
$result = eval {thaw $test_kludge};
is ($result, undef, "By default should not be able to thaw");
like ($@, qr/Byte order is not compatible/,
      "because the header byte order strings differ");

$result = eval {thaw $test};
isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data");
is ($@, '', "        causes no errors");
is ($$result, 'Hell', "        and gives the expected data");

{
    local $Storable::interwork_56_64bit = 1;

    $result = eval {thaw $test_kludge};
    isa_ok ($result, 'SCALAR', "should be able to thaw kludge data");
    is ($@, '', "with no errors");
    is ($$result, 'Heck', "and gives expected data");

    $result = eval {thaw $test};
    is ($result, undef, "But now can't thaw real data");
    like ($@, qr/Byte order is not compatible/,
          "because the header byte order strings differ");
}

#  All together now:
$result = eval {thaw $test};
isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data");
is ($@, '', "        causes no errors");
is ($$result, 'Hell', "        and gives the expected data");

__END__
# A whole run of 1.1.14 freeze data, uuencoded. The "mode bits" are the octal
# value of 'A', the "file name" is the test name. Use make_56_interwork.pl
# with a copy of Storable 1.X generate these.

# byteorder      '1234'
# sizeof(int)    4
# sizeof(long)   4
# sizeof(char *) 4
# sizeof(NV)     8
begin 101 Lillput,4,4,4,8
M!`0$,3(S-`0$!`@"!`````HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@
M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H33&EL;'!U="!W87,@8V]R<F5C=`8"
0````````@`H'5&AE($5N9```

end

# byteorder      '4321'
# sizeof(int)    4
# sizeof(long)   4
# sizeof(char *) 4
# sizeof(NV)     8
begin 101 Belfuscu,4,4,4,8
M!`0$-#,R,00$!`@"````!`HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@
M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H40F5L9G5S8W4@=V%S(&-O<G)E8W0&
1@`````````(*!U1H92!%;F0`

end

# byteorder      '1234'
# sizeof(int)    4
# sizeof(long)   4
# sizeof(char *) 4
# sizeof(NV)     12
begin 101 Lillput,4,4,4,12
M!`0$,3(S-`0$!`P"!`````HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@
M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H33&EL;'!U="!W87,@8V]R<F5C=`8"
0````````@`H'5&AE($5N9```

end
Commit	Line	Data
ee0f7aac	1	#!./perl -w
ee0f7aac NC	2	#
	3	# Copyright 2002, Larry Wall.
	4	#
	5	# You may redistribute only under the same terms as Perl 5, as specified
	6	# in the README file that comes with the distribution.
	7	#
	8
	9	# I ought to keep this test easily backwards compatible to 5.004, so no
	10	# qr//;
	11
	12	# This test checks whether the kludge to interwork with 5.6 Storables compiled
	13	# on Unix systems with IV as long long works.
	14
	15	sub BEGIN {
48c887dd	16	unshift @INC, 't';
ee0f7aac NC	17	require Config; import Config;
	18	if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
	19	print "1..0 # Skip: Storable was not built\n";
	20	exit 0;
	21	}
	22	unless ($Config{ivsize} and $Config{ivsize} > $Config{longsize}) {
	23	print "1..0 # Skip: Your IVs are no larger than your longs\n";
	24	exit 0;
	25	}
	26	}
	27
	28	use Storable qw(freeze thaw);
	29	use strict;
	30	use Test::More tests=>30;
	31
	32	use vars qw(%tests);
	33
	34	{
	35	local $/ = "\n\nend\n";
	36	while (<DATA>) {
	37	next unless /\S/s;
	38	unless (/begin ([0-7]{3}) ([^\n])\n(.)$/s) {
	39	s/\n.*//s;
	40	warn "Dodgy data in section starting '$_'";
	41	next;
	42	}
	43	next unless oct $1 == ord 'A'; # Skip ASCII on EBCDIC, and vice versa
	44	my $data = unpack 'u', $3;
	45	$tests{$2} = $data;
	46	}
	47	}
	48
	49	# perl makes easy things easy, and hard things possible:
	50	my $test = freeze \'Hell';
	51
	52	my $header = Storable::read_magic ($test);
	53
	54	is ($header->{byteorder}, $Config{byteorder},
	55	"header's byteorder and Config.pm's should agree");
	56
	57	my $result = eval {thaw $test};
	58	isa_ok ($result, 'SCALAR', "Check thawing test data");
	59	is ($@, '', "causes no errors");
	60	is ($$result, 'Hell', 'and gives the expected data');
	61
	62	my $kingdom = $Config{byteorder} =~ /23/ ? "Lillput" : "Belfuscu";
	63
	64	my $name = join ',', $kingdom, @$header{qw(intsize longsize ptrsize nvsize)};
	65
	66	SKIP: {
	67	my $real_thing = $tests{$name};
	68	if (!defined $real_thing) {
	69	print << "EOM";
	70	# No test data for Storable 1.x for:
	71	#
	72	# byteorder '$Config{byteorder}'
	73	# sizeof(int) $$header{intsize}
	74	# sizeof(long) $$header{longsize}
	75	# sizeof(char *) $$header{ptrsize}
	76	# sizeof(NV) $$header{nvsize}
	77
	78	# If you have Storable 1.x built with perl 5.6.x on this platform, please
	79	# make_56_interwork.pl to generate test data, and append the test data to
	80	# this test.
81	# You may find that make_56_interwork.pl reports that your platform has no
82	# interworking problems, in which case you need do nothing.
83	EOM
84	skip "# No 1.x test file", 9;
85	}
86	my $result = eval {thaw $real_thing};
87	is ($result, undef, "By default should not be able to thaw");
88	like ($@, qr/Byte order is not compatible/,
89	"because the header byte order strings differ");
90	local $Storable::interwork_56_64bit = 1;
91	$result = eval {thaw $real_thing};
92	isa_ok ($result, 'ARRAY', "With flag should now thaw");
93	is ($@, '', "with no errors");
94
95	# However, as the file is written with Storable pre 2.01, it's a known
96	# bug that large (positive) UVs become IVs
97	my $value = (~0 ^ (~0 >> 1) ^ 2);
98
99	is (@$result, 4, "4 elements in array");
100	like ($$result[0],
101	qr/^This file was written with [0-9.]+ on perl [0-9.]+\z/,
102	"1st element");
103	is ($$result[1], "$kingdom was correct", "2nd element");
104	cmp_ok ($$result[2] ^ $value, '==', 0, "3rd element") or
105	printf "# expected %#X, got %#X\n", $value, $$result[2];
106	is ($$result[3], "The End", "4th element");
107	}
108
109	$result = eval {thaw $test};
110	isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data");
111	is ($@, '', " causes no errors");
112	is ($$result, 'Hell', " and gives the expected data");
113
114	my $test_kludge;
115	{
116	local $Storable::interwork_56_64bit = 1;
117	$test_kludge = freeze \'Heck';
118	}
119
120	my $header_kludge = Storable::read_magic ($test_kludge);
121
122	cmp_ok (length ($header_kludge->{byteorder}), '==', $Config{longsize},
123	"With 5.6 interwork kludge byteorder string should be same size as long"
124	);
125	$result = eval {thaw $test_kludge};
126	is ($result, undef, "By default should not be able to thaw");
127	like ($@, qr/Byte order is not compatible/,
128	"because the header byte order strings differ");
129
130	$result = eval {thaw $test};
131	isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data");
132	is ($@, '', " causes no errors");
133	is ($$result, 'Hell', " and gives the expected data");
134
135	{
136	local $Storable::interwork_56_64bit = 1;
137
138	$result = eval {thaw $test_kludge};
139	isa_ok ($result, 'SCALAR', "should be able to thaw kludge data");
140	is ($@, '', "with no errors");
141	is ($$result, 'Heck', "and gives expected data");
142
143	$result = eval {thaw $test};
144	is ($result, undef, "But now can't thaw real data");
145	like ($@, qr/Byte order is not compatible/,
146	"because the header byte order strings differ");
147	}
148
149	# All together now:
150	$result = eval {thaw $test};
151	isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data");
152	is ($@, '', " causes no errors");
153	is ($$result, 'Hell', " and gives the expected data");
154
155	__END__
156	# A whole run of 1.1.14 freeze data, uuencoded. The "mode bits" are the octal
157	# value of 'A', the "file name" is the test name. Use make_56_interwork.pl
158	# with a copy of Storable 1.X generate these.
159
160	# byteorder '1234'
161	# sizeof(int) 4
162	# sizeof(long) 4
163	# sizeof(char *) 4
164	# sizeof(NV) 8
165	begin 101 Lillput,4,4,4,8
166	M!`0$,3(S-`0$!`@"!`````HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@
167	M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H33&EL;'!U="!W87,@8V]R<F5C=`8"
168	0````````@`H'5&AE($5N9```
169
170	end
171
172	# byteorder '4321'
173	# sizeof(int) 4
174	# sizeof(long) 4
175	# sizeof(char *) 4
176	# sizeof(NV) 8
177	begin 101 Belfuscu,4,4,4,8
178	M!`0$-#,R,00$!`@"````!`HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@
179	M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H40F5L9G5S8W4@=V%S(&-O<G)E8W0&
180	1@`````````(*!U1H92!%;F0`
181
182	end
183
2e72b0af NC	184	# byteorder '1234'
	185	# sizeof(int) 4
	186	# sizeof(long) 4
	187	# sizeof(char *) 4
	188	# sizeof(NV) 12
	189	begin 101 Lillput,4,4,4,12
	190	M!`0$,3(S-`0$!`P"!`````HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@
	191	M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H33&EL;'!U="!W87,@8V]R<F5C=`8"
	192	0````````@`H'5&AE($5N9```
	193
	194	end
	195