compat06.t revision 1.1.1.1
1#!./perl 2# 3# Copyright (c) 1995-2000, Raphael Manfredi 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 9BEGIN { 10 unshift @INC, 't'; 11 require Config; import Config; 12 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { 13 print "1..0 # Skip: Storable was not built\n"; 14 exit 0; 15 } 16 require 'st-dump.pl'; 17} 18 19sub ok; 20 21print "1..8\n"; 22 23use Storable qw(freeze nfreeze thaw); 24 25package TIED_HASH; 26 27sub TIEHASH { 28 my $self = bless {}, shift; 29 return $self; 30} 31 32sub FETCH { 33 my $self = shift; 34 my ($key) = @_; 35 $main::hash_fetch++; 36 return $self->{$key}; 37} 38 39sub STORE { 40 my $self = shift; 41 my ($key, $val) = @_; 42 $self->{$key} = $val; 43} 44 45package SIMPLE; 46 47sub make { 48 my $self = bless [], shift; 49 my ($x) = @_; 50 $self->[0] = $x; 51 return $self; 52} 53 54package ROOT; 55 56sub make { 57 my $self = bless {}, shift; 58 my $h = tie %hash, TIED_HASH; 59 $self->{h} = $h; 60 $self->{ref} = \%hash; 61 my @pool; 62 for (my $i = 0; $i < 5; $i++) { 63 push(@pool, SIMPLE->make($i)); 64 } 65 $self->{obj} = \@pool; 66 my @a = ('string', $h, $self); 67 $self->{a} = \@a; 68 $self->{num} = [1, 0, -3, -3.14159, 456, 4.5]; 69 $h->{key1} = 'val1'; 70 $h->{key2} = 'val2'; 71 return $self; 72}; 73 74sub num { $_[0]->{num} } 75sub h { $_[0]->{h} } 76sub ref { $_[0]->{ref} } 77sub obj { $_[0]->{obj} } 78 79package main; 80 81my $is_EBCDIC = (ord('A') == 193) ? 1 : 0; 82 83my $r = ROOT->make; 84 85my $data = ''; 86if (!$is_EBCDIC) { # ASCII machine 87 while (<DATA>) { 88 next if /^#/; 89 $data .= unpack("u", $_); 90 } 91} else { 92 while (<DATA>) { 93 next if /^#$/; # skip comments 94 next if /^#\s+/; # skip comments 95 next if /^[^#]/; # skip uuencoding for ASCII machines 96 s/^#//; # prepare uuencoded data for EBCDIC machines 97 $data .= unpack("u", $_); 98 } 99} 100 101my $expected_length = $is_EBCDIC ? 217 : 278; 102ok 1, length $data == $expected_length; 103 104my $y = thaw($data); 105ok 2, 1; 106ok 3, ref $y eq 'ROOT'; 107 108$Storable::canonical = 1; # Prevent "used once" warning 109$Storable::canonical = 1; 110# Allow for long double string conversions. 111$y->{num}->[3] += 0; 112$r->{num}->[3] += 0; 113ok 4, nfreeze($y) eq nfreeze($r); 114 115ok 5, $y->ref->{key1} eq 'val1'; 116ok 6, $y->ref->{key2} eq 'val2'; 117ok 7, $hash_fetch == 2; 118 119my $num = $r->num; 120my $ok = 1; 121for (my $i = 0; $i < @$num; $i++) { 122 do { $ok = 0; last } unless $num->[$i] == $y->num->[$i]; 123} 124ok 8, $ok; 125 126__END__ 127# 128# using Storable-0.6@11, output of: print pack("u", nfreeze(ROOT->make)); 129# original size: 278 bytes 130# 131M`P,````%!`(````&"(%8"(!8"'U8"@@M,RXQ-#$U.5@)```!R%@*`S0N-5A8 132M6`````-N=6T$`P````(*!'9A;#%8````!&ME>3$*!'9A;#)8````!&ME>3)B 133M"51)141?2$%32%A8`````6@$`@````,*!G-T<FEN9U@$``````I8!``````` 134M6%A8`````6$$`@````4$`@````$(@%AB!E-)35!,15A8!`(````!"(%88@93 135M24U03$586`0"`````0B"6&(&4TE-4$Q%6%@$`@````$(@UAB!E-)35!,15A8 136M!`(````!"(188@9324U03$586%A8`````V]B:@0,!``````*6%A8`````W)E 137(9F($4D]/5%@` 138# 139# using Storable-0.6@11, output of: print '#' . pack("u", nfreeze(ROOT->make)); 140# on OS/390 (cp 1047) original size: 217 bytes 141# 142#M!0,1!-G6UN,#````!00,!!$)X\G%Q&W(P>+(`P````(*!*6!D_$````$DH6H 143#M\0H$I8&3\@````22A:CR`````YF%A@0"````!@B!"(`(?0H(8/-+\?3Q]?D) 144#M```!R`H#]$OU`````Y6DE`0"````!001!N+)U-?3Q0(````!"(`$$@("```` 145#M`0B!!!("`@````$(@@02`@(````!"(,$$@("`````0B$`````Y:"D00````` 146#E!`````&(!`(````#"@:BHYF)E8<$``````0$```````````!@0`` 147