Re: [Another bug] Re: about Storable perl module (again)
[p5sagit/p5-mst-13.2.git] / ext / Storable / t / blessed.t
1 #!./perl
2
3 # $Id: blessed.t,v 1.0 2000/09/01 19:40:41 ram Exp $
4 #
5 #  Copyright (c) 1995-2000, Raphael Manfredi
6 #  
7 #  You may redistribute only under the same terms as Perl 5, as specified
8 #  in the README file that comes with the distribution.
9 #
10 # $Log: blessed.t,v $
11 # Revision 1.0  2000/09/01 19:40:41  ram
12 # Baseline for first official release.
13 #
14
15 sub BEGIN {
16     if ($ENV{PERL_CORE}){
17         chdir('t') if -d 't';
18         @INC = ('.', '../lib', '../ext/Storable/t');
19     } else {
20         unshift @INC, 't';
21     }
22     require Config; import Config;
23     if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
24         print "1..0 # Skip: Storable was not built\n";
25         exit 0;
26     }
27     require 'st-dump.pl';
28 }
29
30 sub ok;
31
32 use Storable qw(freeze thaw);
33
34 print "1..10\n";
35
36 package SHORT_NAME;
37
38 sub make { bless [], shift }
39
40 package SHORT_NAME_WITH_HOOK;
41
42 sub make { bless [], shift }
43
44 sub STORABLE_freeze {
45         my $self = shift;
46         return ("", $self);
47 }
48
49 sub STORABLE_thaw {
50         my $self = shift;
51         my $cloning = shift;
52         my ($x, $obj) = @_;
53         die "STORABLE_thaw" unless $obj eq $self;
54 }
55
56 package main;
57
58 # Still less than 256 bytes, so long classname logic not fully exercised
59 # Wait until Perl removes the restriction on identifier lengths.
60 my $name = "LONG_NAME_" . 'xxxxxxxxxxxxx::' x 14 . "final";
61
62 eval <<EOC;
63 package $name;
64
65 \@ISA = ("SHORT_NAME");
66 EOC
67 die $@ if $@;
68 ok 1, $@ eq '';
69
70 eval <<EOC;
71 package ${name}_WITH_HOOK;
72
73 \@ISA = ("SHORT_NAME_WITH_HOOK");
74 EOC
75 ok 2, $@ eq '';
76
77 # Construct a pool of objects
78 my @pool;
79
80 for (my $i = 0; $i < 10; $i++) {
81         push(@pool, SHORT_NAME->make);
82         push(@pool, SHORT_NAME_WITH_HOOK->make);
83         push(@pool, $name->make);
84         push(@pool, "${name}_WITH_HOOK"->make);
85 }
86
87 my $x = freeze \@pool;
88 ok 3, 1;
89
90 my $y = thaw $x;
91 ok 4, ref $y eq 'ARRAY';
92 ok 5, @{$y} == @pool;
93
94 ok 6, ref $y->[0] eq 'SHORT_NAME';
95 ok 7, ref $y->[1] eq 'SHORT_NAME_WITH_HOOK';
96 ok 8, ref $y->[2] eq $name;
97 ok 9, ref $y->[3] eq "${name}_WITH_HOOK";
98
99 my $good = 1;
100 for (my $i = 0; $i < 10; $i++) {
101         do { $good = 0; last } unless ref $y->[4*$i]   eq 'SHORT_NAME';
102         do { $good = 0; last } unless ref $y->[4*$i+1] eq 'SHORT_NAME_WITH_HOOK';
103         do { $good = 0; last } unless ref $y->[4*$i+2] eq $name;
104         do { $good = 0; last } unless ref $y->[4*$i+3] eq "${name}_WITH_HOOK";
105 }
106 ok 10, $good;
107