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