ext/B/t/bytecode.t

   1 #!./perl
   2 my $keep_plc      = 0;  # set it to keep the bytecode files
   3 my $keep_plc_fail = 1;  # set it to keep the bytecode files on failures
   4
   5 BEGIN {
   6     if ($^O eq 'VMS') {
   7        print "1..0 # skip - Bytecode/ByteLoader doesn't work on VMS\n";
   8        exit 0;
   9     }
  10     if ($ENV{PERL_CORE}){
  11         chdir('t') if -d 't';
  12         @INC = ('.', '../lib');
  13     } else {
  14         unshift @INC, 't';
  15         push @INC, "../../t";
  16     }
  17     use Config;
  18     if (($Config{'extensions'} !~ /\bB\b/) ){
  19         print "1..0 # Skip -- Perl configured without B module\n";
  20         exit 0;
  21     }
  22     if ($Config{ccflags} =~ /-DPERL_OLD_COPY_ON_WRITE/) {
  23         print "1..0 # skip - no COW for now\n";
  24         exit 0;
  25     }
  26     require 'test.pl'; # for run_perl()
  27 }
  28 use strict;
  29
  30 undef $/;
  31 my @tests = split /\n###+\n/, <DATA>;
  32
  33 print "1..".($#tests+1)."\n";
  34
  35 my $cnt = 1;
  36 my $test;
  37
  38 for (@tests) {
  39     my $got;
  40     my ($script, $expect) = split />>>+\n/;
  41     $expect =~ s/\n$//;
  42     $test = "bytecode$cnt.pl";
  43     open T, ">$test"; print T $script; close T;
  44     $got = run_perl(switches => [ "-MO=Bytecode,-H,-o${test}c" ],
  45                     verbose  => 0, # for debugging
  46                     stderr   => 1, # to capture the "bytecode.pl syntax ok"
  47                     progfile => $test);
  48     unless ($?) {
  49         $got = run_perl(progfile => "${test}c"); # run the .plc
  50         unless ($?) {
  51             if ($got =~ /^$expect$/) {
  52                 print "ok $cnt\n";
  53                 next;
  54             } else {
  55                 $keep_plc = $keep_plc_fail unless $keep_plc;
  56                 print <<"EOT"; next;
  57 not ok $cnt
  58 --------- SCRIPT
  59 $script
  60 --------- GOT
  61 $got
  62 --------- EXPECT
  63 $expect
  64 ----------------
  65
  66 EOT
  67             }
  68         }
  69     }
  70     print <<"EOT";
  71 not ok $cnt
  72 --------- SCRIPT
  73 $script
  74 --------- \$\? = $?
  75 $got
  76 EOT
  77 } continue {
  78     1 while unlink($test, $keep_plc ? () : "${test}c");
  79     $cnt++;
  80 }
  81
  82 __DATA__
  83
  84 print 'hi'
  85 >>>>
  86 hi
  87 ############################################################
  88 for (1,2,3) { print if /\d/ }
  89 >>>>
  90 123
  91 ############################################################
  92 $_ = "xyxyx"; %j=(1,2); s/x/$j{print('z')}/ge; print $_
  93 >>>>
  94 zzz2y2y2
  95 ############################################################
  96 $_ = "xyxyx"; %j=(1,2); s/x/$j{print('z')}/g; print $_
  97 >>>>
  98 z2y2y2
  99 ############################################################
 100 split /a/,"bananarama"; print @_
 101 >>>>
 102 bnnrm
 103 ############################################################
 104 { package P; sub x { print 'ya' } x }
 105 >>>>
 106 ya
 107 ############################################################
 108 @z = split /:/,"b:r:n:f:g"; print @z
 109 >>>>
 110 brnfg
 111 ############################################################
 112 sub AUTOLOAD { print 1 } &{"a"}()
 113 >>>>
 114 1
 115 ############################################################
 116 my $l = 3; $x = sub { print $l }; &$x
 117 >>>>
 118 3
 119 ############################################################
 120 my $i = 1;
 121 my $foo = sub {$i = shift if @_};
 122 &$foo(3);
 123 print 'ok';
 124 >>>>
 125 ok
 126 ############################################################
 127 $x="Cannot use"; print index $x, "Can"
 128 >>>>
 129 0
 130 ############################################################
 131 my $i=6; eval "print \$i\n"
 132 >>>>
 133 6
 134 ############################################################
 135 BEGIN { %h=(1=>2,3=>4) } print $h{3}
 136 >>>>
 137 4
 138 ############################################################
 139 open our $T,"a";
 140 print 'ok';
 141 >>>>
 142 ok
 143 ############################################################
 144 print <DATA>
 145 __DATA__
 146 a
 147 b
 148 >>>>
 149 a
 150 b
 151 ############################################################
 152 BEGIN { tie @a, __PACKAGE__; sub TIEARRAY { bless{} } sub FETCH { 1 } }
 153 print $a[1]
 154 >>>>
 155 1
 156 ############################################################
 157 my $i=3; print 1 .. $i
 158 >>>>
 159 123
 160 ############################################################
 161 my $h = { a=>3, b=>1 }; print sort {$h->{$a} <=> $h->{$b}} keys %$h
 162 >>>>
 163 ba
 164 ############################################################
 165 print sort { my $p; $b <=> $a } 1,4,3
 166 >>>>
 167 431