lib/mauve.t

   1 #!./perl
   2
   3 use Test::More tests => 32 + 60 + 12 + 22;
   4
   5 use mauve qw(refaddr reftype blessed weaken isweak);
   6 use vars qw($t $y $x *F $v $r $never_blessed);
   7 use Symbol qw(gensym);
   8 use Config;
   9
  10 # Ensure we do not trigger any tied methods
  11 tie *F, 'MyTie';
  12
  13 my $i = 1;
  14 foreach $v (undef, 10, 'string') {
  15   is(refaddr($v), !1, "not " . (defined($v) ? "'$v'" : "undef"));
  16 }
  17
  18 foreach $r ({}, \$t, [], \*F, sub {}) {
  19   my $n = "refaddr $r";
  20   $n =~ /0x(\w+)/;
  21   my $addr = do { local $^W; hex $1 };
  22   my $before = ref($r);
  23   is( refaddr($r), $addr, $n);
  24   is( ref($r), $before, $n);
  25
  26   my $obj = bless $r, 'FooBar';
  27   is( refaddr($r), $addr, "blessed with overload $n");
  28   is( ref($r), 'FooBar', $n);
  29 }
  30
  31 {
  32   my $z = '77';
  33   my $y = \$z;
  34   my $a = '78';
  35   my $b = \$a;
  36   tie my %x, 'Hash3', {};
  37   $x{$y} = 22;
  38   $x{$b} = 23;
  39   my $xy = $x{$y};
  40   my $xb = $x{$b};
  41   ok(ref($x{$y}));
  42   ok(ref($x{$b}));
  43   ok(refaddr($xy) == refaddr($y));
  44   ok(refaddr($xb) == refaddr($b));
  45   ok(refaddr($x{$y}));
  46   ok(refaddr($x{$b}));
  47 }
  48 {
  49   my $z = bless {}, '0';
  50   ok(refaddr($z));
  51   @{"0::ISA"} = qw(FooBar);
  52   my $a = {};
  53   my $r = refaddr($a);
  54   $z = bless $a, '0';
  55   ok(refaddr($z) > 10);
  56   is(refaddr($z),$r,"foo");
  57 }
  58 {
  59
  60     my $HAVE_RE = 5.011 <= $];
  61     my $RE = $HAVE_RE ? 'REGEXP' : 'SCALAR';
  62     my($m,@m,%m);
  63     format STDOUT = # do not indent the lone dot in next line
  64 .
  65     @test = (
  66      [ 0, !1,        1,                 'number'        ],
  67      [ 0, !1,        'A',               'string'        ],
  68      [ 0, !1,        *::t,              'glob'          ],
  69      [ 1, HASH    => {},                'HASH ref'      ],
  70      [ 1, HASH    => \%::t,             'HASH ref'      ],
  71      [ 1, HASH    => \%m,               'HASH ref'      ],
  72      [ 1, ARRAY   => [],                'ARRAY ref'     ],
  73      [ 1, ARRAY   => \@::t,             'ARRAY ref'     ],
  74      [ 1, ARRAY   => \@m,               'ARRAY ref'     ],
  75      [ 0, SCALAR  => \1,                'SCALAR ref'    ],
  76      [ 1, SCALAR  => \$t,               'SCALAR ref'    ],
  77      [ 1, SCALAR  => \$m,               'SCALAR ref'    ],
  78      [ 1, REF     => \(\$t),            'REF ref'       ],
  79      [ 1, REF     => \[],               'REF ref'       ],
  80      [ 1, LVALUE  => \substr("",0),     'LVALUE ref'    ],
  81      [ 0, VSTRING => \v1.0.0,           'VSTRING ref'   ],
  82      [ 1, VSTRING => \(my $v = v1.0.0), 'VSTRING ref'   ],
  83      [ 1, GLOB    => \*F,               'tied GLOB ref' ],
  84      [ 1, GLOB    => gensym,            'GLOB ref'      ],
  85      [ 1, CODE    => sub {},            'CODE ref'      ],
  86      [ 1, IO      => *STDIN{IO},        'IO ref'        ],
  87      [ 1, FORMAT  => *STDOUT{FORMAT},   'FORMAT ref'    ],
  88      [ 1, $RE     => qr/x/,             'REGEXP'        ],
  89      [ 0, !1,        ${qr//},           'derefed regex' ],
  90     );
  91
  92     foreach $test (@test) {
  93       my($writable,$type,$what, $n) = @$test;
  94
  95       SKIP: {
  96       if ($n =~ /derefed regex/i && !$HAVE_RE) {
  97         skip "regexes are not scalar references in perl < 5.011", 1;
  98       }
  99
 100       is( reftype($what), $type, "reftype: $n");
 101       next unless $writable;
 102
 103       bless $what, "ABC";
 104       is( reftype($what), $type, "reftype: blessed $n");
 105
 106       bless $what, "0";
 107       is( reftype($what), $type, "reftype: blessed to false $n");
 108       }
 109     }
 110 }
 111 {
 112     is(blessed(undef),"",       'undef is not blessed');
 113     is(blessed(1),"",           'Numbers are not blessed');
 114     is(blessed('A'),"", 'Strings are not blessed');
 115     is(blessed({}),"",  'blessed: Unblessed HASH-ref');
 116     is(blessed([]),"",  'blessed: Unblessed ARRAY-ref');
 117     is(blessed(\$never_blessed),"",     'blessed: Unblessed SCALAR-ref');
 118
 119     $x = bless [], "ABC::\0::\t::\n::ABC";
 120     is(blessed($x), "ABC::\0::\t::\n::ABC",     'blessed ARRAY-ref');
 121
 122     $x = bless [], "ABC";
 123     is(blessed($x), "ABC",      'blessed ARRAY-ref');
 124
 125     $x = bless {}, "DEF";
 126     is(blessed($x), "DEF",      'blessed HASH-ref');
 127
 128     $x = bless {}, "0";
 129     cmp_ok(blessed($x), "eq", "0",      'blessed HASH-ref');
 130
 131     {
 132       my $depth;
 133       {
 134         no warnings 'redefine';
 135         *UNIVERSAL::can = sub { die "Burp!" if ++$depth > 2; blessed(shift) };
 136       }
 137       $x = bless {}, "DEF";
 138       is(blessed($x), "DEF", 'recursion of UNIVERSAL::can');
 139     }
 140
 141     {
 142       my $obj = bless [], "Broken";
 143       is( blessed($obj), "Broken", "blessed on broken isa() and can()" );
 144     }
 145 }
 146 {
 147     if (0) {
 148       require Devel::Peek;
 149       Devel::Peek->import('Dump');
 150     }
 151     else {
 152       *Dump = sub {};
 153     }
 154
 155
 156     if(1) {
 157
 158         my ($y,$z);
 159
 160 #
 161 # Case 1: two references, one is weakened, the other is then undef'ed.
 162 #
 163
 164         {
 165                 my $x = "foo";
 166                 $y = \$x;
 167                 $z = \$x;
 168         }
 169         print "# START\n";
 170         Dump($y); Dump($z);
 171
 172         ok( ref($y) and ref($z));
 173
 174         print "# WEAK:\n";
 175         weaken($y);
 176         Dump($y); Dump($z);
 177
 178         ok( ref($y) and ref($z));
 179
 180         print "# UNDZ:\n";
 181         undef($z);
 182         Dump($y); Dump($z);
 183
 184         ok( not (defined($y) and defined($z)) );
 185
 186         print "# UNDY:\n";
 187         undef($y);
 188         Dump($y); Dump($z);
 189
 190         ok( not (defined($y) and defined($z)) );
 191
 192         print "# FIN:\n";
 193         Dump($y); Dump($z);
 194
 195
 196 #
 197 # Case 2: one reference, which is weakened
 198 #
 199
 200         print "# CASE 2:\n";
 201
 202         {
 203                 my $x = "foo";
 204                 $y = \$x;
 205         }
 206
 207         ok( ref($y) );
 208         print "# BW: \n";
 209         Dump($y);
 210         weaken($y);
 211         print "# AW: \n";
 212         Dump($y);
 213         ok( not defined $y  );
 214
 215         print "# EXITBLOCK\n";
 216     }
 217
 218 #
 219 # Case 3: a circular structure
 220 #
 221
 222     my $flag = 0;
 223     {
 224             my $y = bless {}, 'Dest';
 225             Dump($y);
 226             print "# 1: $y\n";
 227             $y->{Self} = $y;
 228             Dump($y);
 229             print "# 2: $y\n";
 230             $y->{Flag} = \$flag;
 231             print "# 3: $y\n";
 232             weaken($y->{Self});
 233             print "# WKED\n";
 234             ok( ref($y) );
 235             print "# VALS: HASH ",$y,"   SELF ",\$y->{Self},"  Y ",\$y,
 236                     "    FLAG: ",\$y->{Flag},"\n";
 237             print "# VPRINT\n";
 238     }
 239     print "# OUT $flag\n";
 240     ok( $flag == 1 );
 241
 242     print "# AFTER\n";
 243
 244     undef $flag;
 245
 246     print "# FLAGU\n";
 247
 248 #
 249 # Case 4: a more complicated circular structure
 250 #
 251
 252     $flag = 0;
 253     {
 254             my $y = bless {}, 'Dest';
 255             my $x = bless {}, 'Dest';
 256             $x->{Ref} = $y;
 257             $y->{Ref} = $x;
 258             $x->{Flag} = \$flag;
 259             $y->{Flag} = \$flag;
 260             weaken($x->{Ref});
 261     }
 262     ok( $flag == 2 );
 263
 264 #
 265 # Case 5: deleting a weakref before the other one
 266 #
 267
 268     my ($y,$z);
 269     {
 270             my $x = "foo";
 271             $y = \$x;
 272             $z = \$x;
 273     }
 274
 275     print "# CASE5\n";
 276     Dump($y);
 277
 278     weaken($y);
 279     Dump($y);
 280     undef($y);
 281
 282     ok( not defined $y);
 283     ok( ref($z) );
 284
 285
 286 #
 287 # Case 6: test isweakref
 288 #
 289
 290     $a = 5;
 291     ok(!isweak($a));
 292     $b = \$a;
 293     ok(!isweak($b));
 294     weaken($b);
 295     ok(isweak($b));
 296     $b = \$a;
 297     ok(!isweak($b));
 298
 299     my $x = {};
 300     weaken($x->{Y} = \$a);
 301     ok(isweak($x->{Y}));
 302     ok(!isweak($x->{Z}));
 303
 304 #
 305 # Case 7: test weaken on a read only ref
 306 #
 307
 308     SKIP: {
 309         # Doesn't work for older perls, see bug [perl #24506]
 310         skip("Test does not work with perl < 5.8.3", 5) if $] < 5.008003;
 311
 312         # in a MAD build, constants have refcnt 2, not 1
 313         skip("Test does not work with MAD", 5) if exists $Config{mad};
 314
 315         $a = eval '\"hello"';
 316         ok(ref($a)) or print "# didn't get a ref from eval\n";
 317         $b = $a;
 318         eval{weaken($b)};
 319         # we didn't die
 320         ok($@ eq "") or print "# died with $@\n";
 321         ok(isweak($b));
 322         ok($$b eq "hello") or print "# b is '$$b'\n";
 323         $a="";
 324         ok(not $b) or print "# b didn't go away\n";
 325     }
 326 }
 327
 328 package Broken;
 329 sub isa { die };
 330 sub can { die };
 331
 332 package FooBar;
 333
 334 use overload  '0+' => sub { 10 },
 335                 '+' => sub { 10 + $_[1] },
 336                 '"' => sub { "10" };
 337
 338 package MyTie;
 339
 340 sub TIEHANDLE { bless {} }
 341 sub DESTROY {}
 342
 343 sub AUTOLOAD {
 344   warn "$AUTOLOAD called";
 345   exit 1; # May be in an eval
 346 }
 347
 348 package Hash3;
 349
 350 use Scalar::Util qw(refaddr);
 351
 352 sub TIEHASH
 353 {
 354         my $pkg = shift;
 355         return bless [ @_ ], $pkg;
 356 }
 357 sub FETCH
 358 {
 359         my $self = shift;
 360         my $key = shift;
 361         my ($underlying) = @$self;
 362         return $underlying->{refaddr($key)};
 363 }
 364 sub STORE
 365 {
 366         my $self = shift;
 367         my $key = shift;
 368         my $value = shift;
 369         my ($underlying) = @$self;
 370         return ($underlying->{refaddr($key)} = $key);
 371 }
 372
 373
 374
 375 package Dest;
 376
 377 sub DESTROY {
 378         print "# INCFLAG\n";
 379         ${$_[0]{Flag}} ++;
 380 }