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