ext/Storable/t/attach_errors.t

   1 #!./perl -w
   2 #
   3 #  Copyright 2005, Adam Kennedy.
   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 # Man, blessed.t scared the hell out of me. For a second there I thought
  10 # I'd lose Test::More...
  11
  12 # This file tests several known-error cases relating to STORABLE_attach, in
  13 # which Storable should (correctly) throw errors.
  14
  15 sub BEGIN {
  16     if ($ENV{PERL_CORE}){
  17         chdir('t') if -d 't';
  18         @INC = ('.', '../lib');
  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 }
  28
  29 use Test::More tests => 35;
  30 use Storable ();
  31
  32
  33
  34
  35
  36 #####################################################################
  37 # Error 1
  38 #
  39 # Classes that implement STORABLE_thaw _cannot_ have references
  40 # returned by their STORABLE_freeze method. When they do, Storable
  41 # should throw an exception
  42
  43
  44
  45 # Good Case - should not die
  46 {
  47         my $goodfreeze = bless {}, 'My::GoodFreeze';
  48         my $frozen = undef;
  49         eval {
  50                 $frozen = Storable::freeze( $goodfreeze );
  51         };
  52         ok( ! $@, 'Storable does not die when STORABLE_freeze does not return references' );
  53         ok( $frozen, 'Storable freezes to a string successfully' );
  54
  55         package My::GoodFreeze;
  56
  57         sub STORABLE_freeze {
  58                 my ($self, $clone) = @_;
  59
  60                 # Illegally include a reference in this return
  61                 return ('');
  62         }
  63
  64         sub STORABLE_attach {
  65                 my ($class, $clone, $string) = @_;
  66                 return bless { }, 'My::GoodFreeze';
  67         }
  68 }
  69
  70
  71
  72 # Error Case - should die on freeze
  73 {
  74         my $badfreeze = bless {}, 'My::BadFreeze';
  75         eval {
  76                 Storable::freeze( $badfreeze );
  77         };
  78         ok( $@, 'Storable dies correctly when STORABLE_freeze returns a referece' );
  79         # Check for a unique substring of the error message
  80         ok( $@ =~ /cannot return references/, 'Storable dies with the expected error' );
  81
  82         package My::BadFreeze;
  83
  84         sub STORABLE_freeze {
  85                 my ($self, $clone) = @_;
  86
  87                 # Illegally include a reference in this return
  88                 return ('', []);
  89         }
  90
  91         sub STORABLE_attach {
  92                 my ($class, $clone, $string) = @_;
  93                 return bless { }, 'My::BadFreeze';
  94         }
  95 }
  96
  97
  98
  99
 100
 101 #####################################################################
 102 # Error 2
 103 #
 104 # If, for some reason, a STORABLE_attach object is accidentally stored
 105 # with references, this should be checked and and error should be throw.
 106
 107
 108
 109 # Good Case - should not die
 110 {
 111         my $goodthaw = bless {}, 'My::GoodThaw';
 112         my $frozen = undef;
 113         eval {
 114                 $frozen = Storable::freeze( $goodthaw );
 115         };
 116         ok( $frozen, 'Storable freezes to a string as expected' );
 117         my $thawed = eval {
 118                 Storable::thaw( $frozen );
 119         };
 120         isa_ok( $thawed, 'My::GoodThaw' );
 121         is( $thawed->{foo}, 'bar', 'My::GoodThaw thawed correctly as expected' );
 122
 123         package My::GoodThaw;
 124
 125         sub STORABLE_freeze {
 126                 my ($self, $clone) = @_;
 127
 128                 return ('');
 129         }
 130
 131         sub STORABLE_attach {
 132                 my ($class, $clone, $string) = @_;
 133                 return bless { 'foo' => 'bar' }, 'My::GoodThaw';
 134         }
 135 }
 136
 137
 138
 139 # Bad Case - should die on thaw
 140 {
 141         # Create the frozen string normally
 142         my $badthaw = bless { }, 'My::BadThaw';
 143         my $frozen = undef;
 144         eval {
 145                 $frozen = Storable::freeze( $badthaw );
 146         };
 147         ok( $frozen, 'BadThaw was frozen with references correctly' );
 148
 149         # Set up the error condition by deleting the normal STORABLE_thaw,
 150         # and creating a STORABLE_attach.
 151         *My::BadThaw::STORABLE_attach = *My::BadThaw::STORABLE_thaw;
 152         *My::BadThaw::STORABLE_attach = *My::BadThaw::STORABLE_thaw; # Suppress a warning
 153         delete ${'My::BadThaw::'}{STORABLE_thaw};
 154
 155         # Trigger the error condition
 156         my $thawed = undef;
 157         eval {
 158                 $thawed = Storable::thaw( $frozen );
 159         };
 160         ok( $@, 'My::BadThaw object dies when thawing as expected' );
 161         # Check for a snippet from the error message
 162         ok( $@ =~ /unexpected references/, 'Dies with the expected error message' );
 163
 164         package My::BadThaw;
 165
 166         sub STORABLE_freeze {
 167                 my ($self, $clone) = @_;
 168
 169                 return ('', []);
 170         }
 171
 172         # Start with no STORABLE_attach method so we can get a
 173         # frozen object-containing-a-reference into the freeze string.
 174         sub STORABLE_thaw {
 175                 my ($class, $clone, $string) = @_;
 176                 return bless { 'foo' => 'bar' }, 'My::BadThaw';
 177         }
 178 }
 179
 180
 181
 182
 183 #####################################################################
 184 # Error 3
 185 #
 186 # Die if what is returned by STORABLE_attach is not something of that class
 187
 188
 189
 190 # Good Case - should not die
 191 {
 192         my $goodattach = bless { }, 'My::GoodAttach';
 193         my $frozen = Storable::freeze( $goodattach );
 194         ok( $frozen, 'My::GoodAttach return as expected' );
 195         my $thawed = eval {
 196                 Storable::thaw( $frozen );
 197         };
 198         isa_ok( $thawed, 'My::GoodAttach' );
 199         is( ref($thawed), 'My::GoodAttach::Subclass',
 200                 'The slightly-tricky good "returns a subclass" case returns as expected' );
 201
 202         package My::GoodAttach;
 203
 204         sub STORABLE_freeze {
 205                 my ($self, $cloning) = @_;
 206                 return ('');
 207         }
 208
 209         sub STORABLE_attach {
 210                 my ($class, $cloning, $string) = @_;
 211
 212                 return bless { }, 'My::GoodAttach::Subclass';
 213         }
 214
 215         package My::GoodAttach::Subclass;
 216
 217         BEGIN {
 218                 @ISA = 'My::GoodAttach';
 219         }
 220 }
 221
 222
 223
 224 # Bad Cases - die on thaw
 225 {
 226         my $returnvalue = undef;
 227
 228         # Create and freeze the object
 229         my $badattach = bless { }, 'My::BadAttach';
 230         my $frozen = Storable::freeze( $badattach );
 231         ok( $frozen, 'BadAttach freezes as expected' );
 232
 233         # Try a number of different return values, all of which
 234         # should cause Storable to die.
 235         my @badthings = (
 236                 undef,
 237                 '',
 238                 1,
 239                 [],
 240                 {},
 241                 \"foo",
 242                 (bless { }, 'Foo'),
 243                 );
 244         foreach ( @badthings ) {
 245                 $returnvalue = $_;
 246
 247                 my $thawed = undef;
 248                 eval {
 249                         $thawed = Storable::thaw( $frozen );
 250                 };
 251                 ok( $@, 'BadAttach dies on thaw' );
 252                 ok( $@ =~ /STORABLE_attach did not return a My::BadAttach object/,
 253                         'BadAttach dies on thaw with the expected error message' );
 254                 is( $thawed, undef, 'Double checking $thawed was not set' );
 255         }
 256
 257         package My::BadAttach;
 258
 259         sub STORABLE_freeze {
 260                 my ($self, $cloning) = @_;
 261                 return ('');
 262         }
 263
 264         sub STORABLE_attach {
 265                 my ($class, $cloning, $string) = @_;
 266
 267                 return $returnvalue;
 268         }
 269 }