Commit | Line | Data |
---|---|---|
46983aad | 1 | #!./perl |
58d73325 JH |
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 | |
46983aad AE |
4 | |
5 | BEGIN { | |
ba566e15 JH |
6 | if ($^O eq 'VMS') { |
7 | print "1..0 # skip - Bytecode/ByteLoader doesn't work on VMS\n"; | |
8 | exit 0; | |
9 | } | |
5638aaac SM |
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 | } | |
a243a48e | 17 | use Config; |
9cd8f857 NC |
18 | if (($Config{'extensions'} !~ /\bB\b/) ){ |
19 | print "1..0 # Skip -- Perl configured without B module\n"; | |
20 | exit 0; | |
21 | } | |
f8c7b90f | 22 | if ($Config{ccflags} =~ /-DPERL_OLD_COPY_ON_WRITE/) { |
a243a48e JH |
23 | print "1..0 # skip - no COW for now\n"; |
24 | exit 0; | |
25 | } | |
5638aaac | 26 | require 'test.pl'; # for run_perl() |
46983aad AE |
27 | } |
28 | use strict; | |
29 | ||
46983aad AE |
30 | undef $/; |
31 | my @tests = split /\n###+\n/, <DATA>; | |
32 | ||
33 | print "1..".($#tests+1)."\n"; | |
34 | ||
35 | my $cnt = 1; | |
58d73325 | 36 | my $test; |
46983aad AE |
37 | |
38 | for (@tests) { | |
39 | my $got; | |
40 | my ($script, $expect) = split />>>+\n/; | |
41 | $expect =~ s/\n$//; | |
58d73325 | 42 | $test = "bytecode$cnt.pl"; |
46983aad | 43 | open T, ">$test"; print T $script; close T; |
ba566e15 JH |
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" | |
46983aad AE |
47 | progfile => $test); |
48 | unless ($?) { | |
ba566e15 | 49 | $got = run_perl(progfile => "${test}c"); # run the .plc |
46983aad AE |
50 | unless ($?) { |
51 | if ($got =~ /^$expect$/) { | |
52 | print "ok $cnt\n"; | |
53 | next; | |
54 | } else { | |
58d73325 | 55 | $keep_plc = $keep_plc_fail unless $keep_plc; |
46983aad AE |
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"; | |
c7c9533e | 71 | not ok $cnt |
46983aad AE |
72 | --------- SCRIPT |
73 | $script | |
c7c9533e | 74 | --------- \$\? = $? |
46983aad AE |
75 | $got |
76 | EOT | |
77 | } continue { | |
58d73325 | 78 | 1 while unlink($test, $keep_plc ? () : "${test}c"); |
46983aad AE |
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); | |
5638aaac SM |
123 | print 'ok'; |
124 | >>>> | |
125 | ok | |
46983aad | 126 | ############################################################ |
46983aad AE |
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 | ############################################################ | |
5638aaac SM |
139 | open our $T,"a"; |
140 | print 'ok'; | |
141 | >>>> | |
142 | ok | |
46983aad AE |
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 |