ext/B/t/concise.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 plan tests => 38;
  10
  11 require_ok("B::Concise");
  12
  13 $out = runperl(switches => ["-MO=Concise"], prog => '$a', stderr => 1);
  14
  15 # If either of the next two tests fail, it probably means you need to
  16 # fix the section labeled 'fragile kludge' in Concise.pm
  17
  18 ($op_base) = ($out =~ /^(\d+)\s*<0>\s*enter/m);
  19
  20 is($op_base, 1, "Smallest OP sequence number");
  21
  22 ($op_base_p1, $cop_base)
  23   = ($out =~ /^(\d+)\s*<;>\s*nextstate\(main (-?\d+) /m);
  24
  25 is($op_base_p1, 2, "Second-smallest OP sequence number");
  26
  27 is($cop_base, 1, "Smallest COP sequence number");
  28
  29 # test that with -exec B::Concise navigates past logops (bug #18175)
  30
  31 $out = runperl(
  32     switches => ["-MO=Concise,-exec"],
  33     prog => q{$a//=$b && print q/foo/},
  34     stderr => 1,
  35 );
  36
  37 like($out, qr/print/, "'-exec' option output has print opcode");
  38
  39 ######## API tests v.60
  40
  41 use Config;     # used for perlio check
  42 B::Concise->import(qw(set_style set_style_standard add_callback
  43                       add_style walk_output));
  44
  45 ## walk_output argument checking
  46
  47 # test that walk_output accepts a HANDLE arg
  48 foreach my $foo (\*STDOUT, \*STDERR) {
  49     eval {  walk_output($foo) };
  50     is ($@, '', "walk_output() accepts STD* " . ref $foo);
  51 }
  52
  53 # test that walk_output rejects non-HANDLE args
  54 foreach my $foo (undef, 0, "string",[], {}) {
  55     eval {  walk_output($foo) };
  56     isnt ($@, '', "walk_output() rejects arg '$foo'");
  57     $@=''; # clear the fail for next test
  58 }
  59
  60 {   # any object that can print should be ok for walk_output
  61     package Hugo;
  62     sub new { my $foo = bless {} };
  63     sub print { CORE::print @_ }
  64 }
  65 my $foo = new Hugo;     # suggested this API fix
  66 eval {  walk_output($foo) };
  67 is ($@, '', "walk_output() accepts obj that can print");
  68
  69 # now test a ref to scalar
  70 eval {  walk_output(\my $junk) };
  71 is ($@, '', "walk_output() accepts ref-to-sprintf target");
  72
  73 $junk = "non-empty";
  74 eval {  walk_output(\$junk) };
  75 is ($@, '', "walk_output() accepts ref-to-non-empty-scalar");
  76
  77 ## add_style
  78 my @stylespec;
  79 $@='';
  80 eval { add_style ('junk_B' => @stylespec) };
  81 like ($@, 'expecting 3 style-format args',
  82     "add_style rejects insufficient args");
  83
  84 @stylespec = (0,0,0); # right length, invalid values
  85 $@='';
  86 eval { add_style ('junk' => @stylespec) };
  87 is ($@, '', "add_style accepts: stylename => 3-arg-array");
  88
  89 $@='';
  90 eval { add_style (junk => @stylespec) };
  91 like ($@, qr/style 'junk' already exists, choose a new name/,
  92     "add_style correctly disallows re-adding same style-name" );
  93
  94 # test new arg-checks on set_style
  95 $@='';
  96 eval { set_style (@stylespec) };
  97 is ($@, '', "set_style accepts 3 style-format args");
  98
  99 @stylespec = (); # bad style
 100
 101 eval { set_style (@stylespec) };
 102 like ($@, qr/expecting 3 style-format args/,
 103     "set_style rejects bad style-format args");
 104
 105
 106 #### for content with doc'd options
 107
 108 set_style_standard('concise');  # MUST CALL b4 output needed
 109 my $func = sub{ $a = $b+42 };
 110
 111 @options = qw(
 112     -basic -exec -tree -compact -loose -vt -ascii -main
 113     -base10 -bigendian -littleendian
 114     );
 115 foreach $opt (@options) {
 116     walk_output(\my $out);
 117     my $treegen = B::Concise::compile($opt, $func);
 118     $treegen->();
 119     #print "foo:$out\n";
 120     isnt($out, '', "got output with option $opt");
 121 }
 122
 123 ## test output control via walk_output
 124
 125 my $treegen = B::Concise::compile('-basic', $func); # reused
 126
 127 { # test output into a package global string (sprintf-ish)
 128     our $thing;
 129     walk_output(\$thing);
 130     $treegen->();
 131     ok($thing, "walk_output to our SCALAR, output seen");
 132 }
 133
 134 { # test output to GLOB, using perlio feature directly
 135     skip 1, "no perlio on this build" unless $Config{useperlio};
 136     open (my $fh, '>', \my $buf);
 137     walk_output($fh);
 138     $treegen->();
 139     ok($buf, "walk_output to GLOB, output seen");
 140 }
 141
 142 ## Test B::Concise::compile error checking
 143
 144 # call compile on non-CODE ref items
 145 foreach my $ref ([], {}) {
 146     my $typ = ref $ref;
 147     walk_output(\my $out);
 148     eval { B::Concise::compile('-basic', $ref)->() };
 149     like ($@, qr/^err: not a coderef: $typ/,
 150           "compile detects $typ-ref where expecting subref");
 151     # is($out,'', "no output when errd"); # announcement prints
 152 }
 153
 154 # test against a bogus autovivified subref.
 155 # in debugger, it should look like:
 156 #  1  CODE(0x84840cc)
 157 #      -> &CODE(0x84840cc) in ???
 158 sub nosuchfunc;
 159 eval { B::Concise::compile('-basic', \&nosuchfunc)->() };
 160 like ($@, qr/^err: coderef has no START/,
 161       "compile detects CODE-ref w/o actual code");
 162
 163 foreach my $opt (qw( -concise -exec )) {
 164     eval { B::Concise::compile($opt,'non_existent_function')->() };
 165     like ($@, qr/unknown function \(main::non_existent_function\)/,
 166           "'$opt' reports non-existent-function properly");
 167 }