1#!./perl
2my $keep_plc      = 0;	# set it to keep the bytecode files
3my $keep_plc_fail = 1;	# set it to keep the bytecode files on failures
4
5BEGIN {
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_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}
28use strict;
29
30undef $/;
31my @tests = split /\n###+\n/, <DATA>;
32
33print "1..".($#tests+1)."\n";
34
35my $cnt = 1;
36my $test;
37
38for (@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;
57not ok $cnt
58--------- SCRIPT
59$script
60--------- GOT
61$got
62--------- EXPECT
63$expect
64----------------
65
66EOT
67	    }
68	}
69    }
70    print <<"EOT";
71not ok $cnt
72--------- SCRIPT
73$script
74--------- \$\? = $?
75$got
76EOT
77} continue {
78    1 while unlink($test, $keep_plc ? () : "${test}c");
79    $cnt++;
80}
81
82__DATA__
83
84print 'hi'
85>>>>
86hi
87############################################################
88for (1,2,3) { print if /\d/ }
89>>>>
90123
91############################################################
92$_ = "xyxyx"; %j=(1,2); s/x/$j{print('z')}/ge; print $_
93>>>>
94zzz2y2y2
95############################################################
96$_ = "xyxyx"; %j=(1,2); s/x/$j{print('z')}/g; print $_
97>>>>
98z2y2y2
99############################################################
100split /a/,"bananarama"; print @_
101>>>>
102bnnrm
103############################################################
104{ package P; sub x { print 'ya' } x }
105>>>>
106ya
107############################################################
108@z = split /:/,"b:r:n:f:g"; print @z
109>>>>
110brnfg
111############################################################
112sub AUTOLOAD { print 1 } &{"a"}()
113>>>>
1141
115############################################################
116my $l = 3; $x = sub { print $l }; &$x
117>>>>
1183
119############################################################
120my $i = 1;
121my $foo = sub {$i = shift if @_};
122&$foo(3);
123print 'ok';
124>>>>
125ok
126############################################################
127$x="Cannot use"; print index $x, "Can"
128>>>>
1290
130############################################################
131my $i=6; eval "print \$i\n"
132>>>>
1336
134############################################################
135BEGIN { %h=(1=>2,3=>4) } print $h{3}
136>>>>
1374
138############################################################
139open our $T,"a";
140print 'ok';
141>>>>
142ok
143############################################################
144print <DATA>
145__DATA__
146a
147b
148>>>>
149a
150b
151############################################################
152BEGIN { tie @a, __PACKAGE__; sub TIEARRAY { bless{} } sub FETCH { 1 } }
153print $a[1]
154>>>>
1551
156############################################################
157my $i=3; print 1 .. $i
158>>>>
159123
160############################################################
161my $h = { a=>3, b=>1 }; print sort {$h->{$a} <=> $h->{$b}} keys %$h
162>>>>
163ba
164############################################################
165print sort { my $p; $b <=> $a } 1,4,3
166>>>>
167431
168