ext/B/t/walkoptree.t

   1 #!./perl
   2
   3 BEGIN {
   4     unshift @INC, 't';
   5     require Config;
   6     if (($Config::Config{'extensions'} !~ /\bB\b/) ){
   7         print "1..0 # Skip -- Perl configured without B module\n";
   8         exit 0;
   9     }
  10 }
  11
  12 use warnings;
  13 use strict;
  14 use Test::More;
  15
  16 BEGIN { use_ok( 'B' ); }
  17
  18 # Somewhat minimal tests.
  19
  20 my %seen;
  21
  22 sub B::OP::pie {
  23     my $self = shift;
  24     return ++$seen{$self->name};
  25 }
  26
  27 my %debug;
  28 sub B::OP::walkoptree_debug {
  29     my $self = shift;
  30     return ++$debug{$self->name};
  31 }
  32
  33 my $victim = sub {
  34     # This gives us a substcont, which gets to the second recursive call
  35     # point (in the if statement in the XS code)
  36     $_[0] =~ s/(a)/$1/;
  37     # PMOP_pmreplroot(cPMOPo) is NULL for this
  38     $_[0] =~ s/(b)//;
  39     # This gives an OP_PUSHRE
  40     split /c/;
  41 };
  42
  43 is (B::walkoptree_debug, 0, 'walkoptree_debug() is 0');
  44 B::walkoptree(B::svref_2object($victim)->ROOT, "pie");
  45 foreach (qw(substcont pushre split leavesub)) {
  46     is ($seen{$_}, 1, "Our victim had a $_ OP");
  47 }
  48 is_deeply ([keys %debug], [], 'walkoptree_debug was not called');
  49
  50 B::walkoptree_debug(2);
  51 is (B::walkoptree_debug, 1, 'walkoptree_debug() is 1');
  52 %seen = ();
  53
  54 B::walkoptree(B::svref_2object($victim)->ROOT, "pie");
  55 foreach (qw(substcont pushre split leavesub)) {
  56     is ($seen{$_}, 1, "Our victim had a $_ OP");
  57 }
  58 is_deeply (\%debug, \%seen, 'walkoptree_debug was called correctly');
  59
  60 my %seen2;
  61
  62 # Now try to exercise the code in walkoptree that decides that it can't re-use
  63 # the object and reference.
  64 sub B::OP::fiddle {
  65     my $name = $_[0]->name;
  66     ++$seen2{$name};
  67     if ($name =~ /^s/) {
  68         # Take another reference to the reference
  69         push @::junk, \$_[0];
  70     } elsif ($name =~ /^p/) {
  71         # Take another reference to the object
  72         push @::junk, \${$_[0]};
  73     } elsif ($name =~ /^l/) {
  74         undef $_[0];
  75     } elsif ($name =~ /g/) {
  76         ${$_[0]} = "Muhahahahaha!";
  77     } elsif ($name =~ /^c/) {
  78         bless \$_[0];
  79     }
  80 }
  81
  82 B::walkoptree(B::svref_2object($victim)->ROOT, "fiddle");
  83 is_deeply (\%seen2, \%seen, 'everything still seen');
  84
  85 done_testing();