File Coverage

lib/PHP/Decode/Parser.pm
Criterion Covered Total %
statement 1695 3007 56.3
branch 886 1818 48.7
condition 467 935 49.9
subroutine 91 107 85.0
pod 3 94 3.1
total 3142 5961 52.7


line stmt bran cond sub pod time code
1             #
2             # parse PHP source files
3             #
4             package PHP::Decode::Parser;
5 6     6   142801 use base 'PHP::Decode::Tokenizer';
  6         42  
  6         2991  
6              
7 6     6   46 use strict;
  6         12  
  6         136  
8 6     6   31 use warnings;
  6         11  
  6         159  
9 6     6   31 use Carp 'croak';
  6         32  
  6         319  
10 6     6   33 use Config;
  6         12  
  6         272  
11 6     6   1695 use PHP::Decode::Array qw(is_int_index);
  6         27  
  6         301  
12 6     6   38 use Exporter qw(import);
  6         12  
  6         421  
13             our @EXPORT_OK = qw(is_variable is_symbol is_null is_const is_numval is_strval is_array is_block global_var global_split inst_var inst_split method_name method_split ns_name ns_split);
14             our %EXPORT_TAGS = (all => \@EXPORT_OK);
15              
16             our $VERSION = '0.127';
17              
18             # avoid 'Deep recursion' warnings for depth > 100
19             #
20 6     6   35 no warnings 'recursion';
  6         11  
  6         29681  
21              
22             my $stridx = 1;
23             my $numidx = 1;
24             my $constidx = 1;
25             my $funidx = 1;
26             my $callidx = 1;
27             my $elemidx = 1;
28             my $expridx = 1;
29             my $stmtidx = 1;
30             my $blkidx = 1;
31             my $pfxidx = 1;
32             my $objidx = 1; # obj->
33             my $scopeidx = 1; # class::
34             my $refidx = 1; # & $var
35             my $classidx = 1; # class name {}
36             my $instidx = 1; # class instance
37             my $traitidx = 1; # trait name {}
38             my $nsidx = 1; # namespace\
39             my $fhidx = 1;
40              
41             # Initialize new parser using PHP::Decode::Tokenizer
42             # {inscript} - set to indicate already inside of script
43             # {warn} - warning message handler
44             # {log} - log message handler
45             # {debug} - debug message handler
46             # {filename} - optional filename (if not stdin or textstr)
47             # {max_strlen} - max strlen for debug strings
48             #
49             sub new {
50 795     795 1 6494 my ($class, %args) = @_;
51 795 50       2432 my $strmap = $args{strmap} or croak __PACKAGE__ . " expects strmap";
52              
53 795         3088 my $self = $class->SUPER::new(%args);
54 795 100       2402 $self->{max_strlen} = 0 unless exists $self->{max_strlen};
55 795         1573 $self->{tok} = []; # init token list
56              
57             # filename is required to decode __FILE__
58 795 100       1841 $self->{filename} = '__FILE__' unless exists $self->{filename};
59              
60 795 100       2028 $strmap->{'__LINE__'} = 1 unless exists $strmap->{'__LINE__'};
61 795 100       1946 $strmap->{'#null'} = '' unless exists $strmap->{'#null'};
62 795         2048 return $self;
63             }
64              
65             # A sub parser is always inscript (the parent might have inscript=0)
66             #
67             sub subparser {
68 70     70 0 163 my ($self, %args) = @_;
69 70         271 my $parser = PHP::Decode::Parser->new(strmap => $self->{strmap}, inscript => 1, filename => $self->{filename}, max_strlen => $self->{max_strlen}, warn => $self->{warn});
70 70 50       205 $parser->{log} = $self->{log} if exists $self->{log};
71 70 50       170 $parser->{debug} = $self->{debug} if exists $self->{debug};
72              
73 70         158 foreach my $k (keys %args) {
74 0         0 $parser->{$k} = $args{$k};
75             }
76 70         157 return $parser;
77             }
78              
79             sub clear_strmap {
80 0     0 0 0 my ($self) = @_;
81              
82 0         0 $stridx = 1;
83 0         0 $self->{strmap} = {};
84 0         0 $self->{strmap}{'__LINE__'} = 1;
85 0         0 return;
86             }
87              
88             my %ctrlmap = map { chr($_) => sprintf "\\x%02x", $_ } (0x00..0x1f, 0x7f);
89              
90             # convert controls from pattern to "\xNN"
91             #
92             sub escape_ctrl {
93 0     0 0 0 my ($s, $pat) = @_;
94 0         0 my @list = ();
95              
96 0 0       0 return "''" if ($s eq '');
97              
98 0         0 $_ = $s;
99 0         0 while (1) {
100             #if(/\G([${pat}])/sgc) {
101             # push(@list, sprintf "\"\\x%02x\"", ord($1));
102 0 0       0 if(/\G([${pat}]+)/sgc) {
    0          
103 0 0       0 push(@list, '"' . join('', map { exists $ctrlmap{$_} ? $ctrlmap{$_} : $_ } split(//, $1)) . '"');
  0         0  
104             } elsif (/\G([^${pat}]+)/sgc) {
105 0         0 push(@list, "'" . $1 . "'");
106             } else {
107 0         0 last;
108             }
109             }
110 0         0 return join('.', @list);
111             }
112              
113             sub shortstr {
114 0     0 0 0 my ($self, $s, $maxlen) = @_;
115              
116 0 0       0 if (!defined $s) {
117 0         0 return '(null)';
118             }
119              
120             # remove linefeeds
121             #
122             #$s =~ s/\r\n/ /g;
123              
124             # remove non-printable
125             #
126 0         0 $s =~ s/[\x01-\x1f\x7f]/\./g;
127              
128 0 0 0     0 if (($self->{max_strlen} > 0) && (!$maxlen || ($maxlen > $self->{max_strlen}))) {
      0        
129 0         0 $maxlen = $self->{max_strlen};
130             }
131 0 0 0     0 if ($maxlen && (length($s) > $maxlen)) {
132 0         0 $s = substr($s, 0, $maxlen-2).'..';
133             }
134 0         0 return $s;
135             }
136              
137             # 'str' -> #str$i
138             #
139             sub setstr {
140 2030     2030 0 4656 my ($self, $v) = @_;
141 2030         2862 my $k;
142              
143 2030 100       4520 if (exists $self->{strmap}->{rev}{$v}) {
144 121         255 $k = $self->{strmap}->{rev}{$v};
145 121         345 return $k;
146             } else {
147 1909         3431 $k = "#str$stridx";
148 1909         2926 $stridx++;
149 1909         4713 $self->{strmap}->{$k} = $v;
150 1909         5205 $self->{strmap}->{rev}{$v} = $k;
151             }
152             # TODO: log also for $opt{P}
153 1909 50 0     3954 $self->{log}->('setstr', "%s = %s", $k, $self->shortstr($v, $self->{max_strlen} || 60)) if $self->{log};
154 1909         4035 return $k;
155             }
156              
157             # for expensive operations like repeated strconcat don't
158             # store reverse entry to save some space
159             #
160             sub setstr_norev {
161 110     110 0 242 my ($self, $v) = @_;
162 110         171 my $k;
163              
164 110 100       281 if (exists $self->{strmap}->{rev}{$v}) {
165 21         47 $k = $self->{strmap}->{rev}{$v};
166 21         53 return $k;
167             } else {
168 89         194 $k = "#str$stridx";
169 89         135 $stridx++;
170 89         308 $self->{strmap}->{$k} = $v;
171             }
172             # TODO: log also for $opt{P}
173 89 50 0     212 $self->{log}->('setstr', "%s = %s [norev]", $k, $self->shortstr($v, $self->{max_strlen} || 60)) if $self->{log};
174 89         203 return $k;
175             }
176              
177             # number -> #num$i
178             #
179             sub setnum {
180 868     868 0 2546 my ($self, $v) = @_;
181 868         1157 my $k;
182              
183 868 100       2200 if (exists $self->{strmap}->{num}{$v}) {
184 182         391 $k = $self->{strmap}->{num}{$v};
185 182         439 return $k;
186             } else {
187 686         1344 $k = "#num$numidx";
188 686         1017 $numidx++;
189 686         2287 $self->{strmap}->{$k} = $v;
190 686         1616 $self->{strmap}->{num}{$v} = $k;
191             }
192 686 50       1430 $self->{log}->('setnum', "%s = %s", $k, $self->shortstr($v, 60)) if $self->{log};
193 686         1477 return $k;
194             }
195              
196             # 'const' -> #const$i
197             #
198             sub setconst {
199 344     344 0 751 my ($self, $v) = @_;
200 344         727 my $k = "#const$constidx";
201 344         502 $constidx++;
202              
203 344         1343 $self->{strmap}->{$k} = $v;
204 344 50       751 $self->{log}->('setconst', "%s = %s", $k, $v) if $self->{log};
205 344         795 return $k;
206             }
207              
208             sub newarr {
209 274     274 0 1126 my ($self) = @_;
210 274         1140 my $arr = PHP::Decode::Array->new(strmap => $self->{strmap});
211 274 50       616 $self->{log}->('newarr', "%s", $arr->{name}) if $self->{log};
212 274         633 return $arr;
213             }
214              
215             # function -> #fun$i
216             #
217             sub setfun {
218 309     309 0 732 my ($self, $cmd, $arglist, $block, $p) = @_;
219 309         637 my $k = "#fun$funidx";
220 309         420 $funidx++;
221              
222 309         1331 $self->{strmap}->{$k} = [$cmd, $arglist, $block, $p];
223 309 50       711 $self->{log}->('setfun', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
224 309         726 return $k;
225             }
226              
227             sub setcall {
228 781     781 0 1506 my ($self, $cmd, $arglist) = @_;
229 781         1613 my $k = "#call$callidx";
230 781         1227 $callidx++;
231              
232 781         3186 $self->{strmap}->{$k} = [$cmd, $arglist];
233 781 50       1637 $self->{log}->('setcall', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
234 781         1924 return $k;
235             }
236              
237             sub setelem {
238 538     538 0 1115 my ($self, $var, $idx) = @_;
239 538         1174 my $k = "#elem$elemidx";
240 538         868 $elemidx++;
241              
242 538         2144 $self->{strmap}->{$k} = [$var, $idx];
243 538 50       1215 $self->{log}->('setelem', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
244 538         1205 return $k;
245             }
246              
247             sub setexpr {
248 1983     1983 0 4541 my ($self, $op, $v1, $v2) = @_;
249 1983         4177 my $k = "#expr$expridx";
250 1983         3081 $expridx++;
251              
252 1983         8870 $self->{strmap}->{$k} = [$op, $v1, $v2];
253 1983 50       4192 $self->{log}->('setexpr', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
254 1983         4630 return $k;
255             }
256              
257             sub setblk {
258 2877     2877 0 5408 my ($self, $type, $a) = @_;
259 2877         5924 my $k = "#blk$blkidx";
260 2877         4390 $blkidx++;
261              
262 2877         12352 $self->{strmap}->{$k} = [$type, $a];
263 2877 50       6034 $self->{log}->('setblk', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
264 2877         6299 return $k;
265             }
266              
267             sub setstmt {
268 853     853 0 1523 my ($self, $s) = @_;
269 853         1922 my $k = "#stmt$stmtidx";
270 853         1262 $stmtidx++;
271              
272 853         2743 $self->{strmap}->{$k} = $s;
273 853 50       1881 $self->{log}->('setstmt', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
274 853         2136 return $k;
275             }
276              
277             sub setpfx {
278 55     55 0 118 my ($self, $s) = @_;
279 55         126 my $k = "#pfx$pfxidx";
280 55         98 $pfxidx++;
281              
282 55         167 $self->{strmap}->{$k} = $s;
283 55 50       116 $self->{log}->('setpfx', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
284 55         130 return $k;
285             }
286              
287             sub setobj {
288 52     52 0 115 my ($self, $s, $property) = @_;
289 52         126 my $k = "#obj$objidx";
290 52         73 $objidx++;
291              
292 52         331 $self->{strmap}->{$k} = [$s, $property];
293 52 50       143 $self->{log}->('setobj', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
294 52         113 return $k;
295             }
296              
297             sub setscope {
298 41     41 0 90 my ($self, $s, $elem) = @_;
299 41         85 my $k = "#scope$scopeidx";
300 41         66 $scopeidx++;
301              
302 41         206 $self->{strmap}->{$k} = [$s, $elem];
303 41 50       98 $self->{log}->('setscope', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
304 41         102 return $k;
305             }
306              
307             sub setref {
308 8     8 0 23 my ($self, $s) = @_;
309 8         23 my $k = "#ref$refidx";
310 8         14 $refidx++;
311              
312 8         32 $self->{strmap}->{$k} = [$s];
313 8 50       22 $self->{log}->('setref', "%s = %s", $k, $s) if $self->{log};
314 8         19 return $k;
315             }
316              
317             sub setclass {
318 69     69 0 179 my ($self, $name, $block, $p) = @_;
319 69         144 my $k = "#class$classidx";
320 69         106 $classidx++;
321              
322 69         326 $self->{strmap}->{$k} = [$name, $block, $p];
323 69 50       170 $self->{log}->('setclass', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
324 69         166 return $k;
325             }
326              
327             sub settrait {
328 1     1 0 4 my ($self, $name, $block) = @_;
329 1         4 my $k = "#trait$traitidx";
330 1         3 $traitidx++;
331              
332 1         4 $self->{strmap}->{$k} = [$name, $block];
333 1 50       5 $self->{log}->('settrait', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
334 1         3 return $k;
335             }
336              
337             sub setinst {
338 34     34 0 72 my ($self, $class, $initcall, $instctx) = @_;
339 34         84 my $k = "#inst$instidx";
340 34         55 $instidx++;
341              
342 34         151 $self->{strmap}->{$k} = [$class, $initcall, $instctx];
343 34 50       81 $self->{log}->('setinst', "%s = %s", $k, $class) if $self->{log};
344 34         91 return $k;
345             }
346              
347             sub setns {
348 12     12 0 38 my ($self, $name, $elem) = @_;
349 12         26 my $k = "#ns$nsidx";
350 12         16 $nsidx++;
351              
352 12         41 $self->{strmap}->{$k} = [$name, $elem];
353 12 50       27 $self->{log}->('setns', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
354 12         25 return $k;
355             }
356              
357             sub newfh {
358 2     2 0 11 my ($self, $filename, $mode) = @_;
359 2         7 my %file;
360             my $a;
361 2         9 my $fh = "#fh$fhidx";
362 2         6 $fhidx++;
363              
364 2         10 $self->{strmap}->{$fh} = \%file;
365 2         9 $self->{strmap}->{idx}{$fh} = 0;
366              
367 2         22 $file{name} = $filename;
368 2         6 $file{mode} = $mode;
369 2         7 $file{pos} = 0;
370 2 50       8 if ($filename eq '__FILE__') {
371 0         0 $file{buf} = $self->{strmap}->{$filename}; # todo: cleanup
372             } else {
373 2         5 $file{buf} = '';
374 2         9 return; # TODO: support write & non-existing files
375             }
376 0 0       0 $self->{log}->('newfh', "$fh ($filename, $mode)") if $self->{log};
377 0         0 return ($fh, \%file);
378             }
379              
380             sub stmt_str {
381 71     71 0 179 my ($self, $s) = @_;
382              
383 71 50       377 unless ($s =~ /^#\w+\d+$/) {
384 0         0 return $s;
385             }
386              
387 71 50       594 if ($s =~ /^#null$/) {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
388 0         0 return 'null'; # '' or 0 in str/num context
389             } elsif ($s =~ /^#num\d+$/) {
390 0         0 return $self->{strmap}{$s};
391             } elsif ($s =~ /^#const\d+$/) {
392 0         0 return $self->{strmap}{$s};
393             } elsif ($s =~ /^#str\d+$/) {
394 0         0 my $v = $self->{strmap}{$s};
395 0         0 return $self->shortstr($v, 60);
396             } elsif ($s =~ /^#arr\d+$/) {
397 0         0 my $arr = $self->{strmap}{$s};
398 0         0 my $keys = $arr->get_keys();
399 0         0 my $size = scalar @$keys;
400              
401 0         0 return $arr->{name} . "[size $size]";
402             } elsif ($s =~ /^#fun\d+$/) {
403 0         0 my ($f, $a, $b, $p) = @{$self->{strmap}{$s}};
  0         0  
404 0         0 my ($type, $stmts) = @{$self->{strmap}{$b}};
  0         0  
405              
406 0 0       0 return (defined $f ? $f : '') . "(" . join(', ', @$a) . ") { " . join(' ', @$stmts) . " }";
407             } elsif ($s =~ /^#call\d+$/) {
408 69         104 my ($f, $a) = @{$self->{strmap}->{$s}};
  69         222  
409              
410 69         460 return $f . "(" . join(', ', @$a) . ")";
411             } elsif ($s =~ /^#elem\d+$/) {
412 2         4 my ($v, $i) = @{$self->{strmap}{$s}};
  2         10  
413              
414 2 50       12 return $v . "[" . (defined $i ? $i : '') . "]";
415             } elsif ($s =~ /^#expr\d+$/) {
416             # if v1 missing: prefix op
417             # if v2 missing: postfix op
418 0         0 my ($op, $v1, $v2) = @{$self->{strmap}{$s}};
  0         0  
419              
420 0 0       0 return (defined $v1 ? $v1 . " " : '') . $op . (defined $v2 ? " " . $v2 : '');
    0          
421             } elsif ($s =~ /^#pfx\d+$/) {
422 0         0 my $pfx = $self->{strmap}{$s};
423 0         0 return join(' ', sort keys %$pfx);
424             } elsif ($s =~ /^#obj\d+$/) {
425 0         0 my ($o, $m) = @{$self->{strmap}{$s}};
  0         0  
426 0         0 return $o . "->" . $m;
427             } elsif ($s =~ /^#scope\d+$/) {
428 0         0 my ($c, $e) = @{$self->{strmap}{$s}};
  0         0  
429 0         0 return $c . "::" . $e;
430             } elsif ($s =~ /^#ns\d+$/) {
431 0         0 my ($n, $e) = @{$self->{strmap}{$s}};
  0         0  
432 0 0       0 return (defined $n ? $n : '') . '\\' . $e;
433             } elsif ($s =~ /^#inst\d+$/) {
434 0         0 my ($c, $f, $i) = @{$self->{strmap}{$s}};
  0         0  
435 0         0 return $c;
436             } elsif ($s =~ /^#ref\d+$/) {
437 0         0 my ($v) = @{$self->{strmap}{$s}};
  0         0  
438 0         0 return "&" . $v;
439             } elsif ($s =~ /^#class\d+$/) {
440 0         0 my ($c, $b, $p) = @{$self->{strmap}{$s}};
  0         0  
441 0         0 my ($type, $stmts) = @{$self->{strmap}{$b}};
  0         0  
442              
443 0 0       0 return (defined $c ? $c : '') . (exists $p->{parent} ? " extends $p->{parent}" : '') . " { " . join(' ', @$stmts) . " }";
    0          
444             } elsif ($s =~ /^#trait\d+$/) {
445 0         0 my ($t, $b) = @{$self->{strmap}{$s}};
  0         0  
446 0         0 my ($type, $stmts) = @{$self->{strmap}{$b}};
  0         0  
447              
448 0 0       0 return (defined $t ? $t : '') . " { " . join(' ', @$stmts) . " }";
449             } elsif ($s =~ /^#fh\d+$/) {
450 0         0 my $f = $self->{strmap}{$s}{name};
451 0         0 my $m = $self->{strmap}{$s}{mode};
452 0         0 my $p = $self->{strmap}{$s}{pos};
453              
454 0         0 return "(" . $f . ", " . $m . ")";
455             } elsif ($s =~ /^#blk\d+$/) {
456 0         0 my ($type, $a) = @{$self->{strmap}{$s}};
  0         0  
457 0         0 return $type . " { " . join(' ', @$a) . " }";
458             } elsif ($s =~ /^#stmt\d+$/) {
459 0         0 my $cmd = $self->{strmap}{$s}[0];
460              
461 0 0       0 if ($cmd eq 'echo') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
462 0         0 my $a = $self->{strmap}{$s}[1];
463 0         0 return $cmd . " " . join(', ', @$a);
464             } elsif ($cmd eq 'print') {
465 0         0 my $arg = $self->{strmap}{$s}[1];
466 0         0 return $cmd . " " . $arg;
467             } elsif ($cmd eq 'namespace') {
468 0         0 my ($arg, $block) = @{$self->{strmap}->{$s}}[1..2];
  0         0  
469 0 0       0 return $cmd . " " . $arg . (defined $block ? " { $block }" : '');
470             } elsif ($cmd =~ /^(include|include_once|require|require_once)$/) {
471 0         0 my $arg = $self->{strmap}{$s}[1];
472 0         0 return $cmd . " " . $arg;
473             } elsif ($cmd eq 'use') {
474 0         0 my $a = $self->{strmap}{$s}[1];
475 0         0 return $cmd . " " . join(', ', @$a);
476             } elsif ($cmd eq 'global') {
477 0         0 my $a = $self->{strmap}{$s}[1];
478 0         0 return $cmd . " " . join(', ', @$a);
479             } elsif ($cmd eq 'static') {
480 0         0 my ($a, $p) = @{$self->{strmap}{$s}}[1..2];
  0         0  
481 0         0 return $cmd . join(' ', (grep { $_ ne $cmd } sort keys %$p), $cmd) . ' ' . join(', ', @$a);
  0         0  
482             } elsif ($cmd eq 'const') {
483 0         0 my ($a, $p) = @{$self->{strmap}{$s}}[1..2];
  0         0  
484 0         0 return $cmd . join(' ', (grep { $_ ne $cmd } sort keys %$p), $cmd) . ' ' . join(', ', @$a);
  0         0  
485             } elsif ($cmd eq 'unset') {
486 0         0 my $a = $self->{strmap}{$s}[1];
487 0         0 return $cmd . " (" . join(', ', @$a) . ")";
488             } elsif ($cmd eq 'return') {
489 0         0 my $a = $self->{strmap}{$s}[1];
490 0         0 return $cmd . " " . $a;
491             } elsif ($cmd eq 'goto') {
492 0         0 my $a = $self->{strmap}{$s}[1];
493 0         0 return $cmd . " " . $a;
494             } elsif ($cmd eq 'label') {
495 0         0 my $a = $self->{strmap}{$s}[1];
496 0         0 return $cmd . " " . $a . ":";
497             } elsif ($cmd eq 'throw') {
498 0         0 my $arg = $self->{strmap}{$s}[1];
499 0         0 return $cmd . " " . $arg;
500             } elsif ($cmd eq 'if') {
501 0         0 my ($cond, $then, $else) = @{$self->{strmap}{$s}}[1..3];
  0         0  
502 0 0       0 return $cmd . " ($cond) then $then" . (defined $else ? " else $else" : '');
503             } elsif ($cmd eq 'while') {
504 0         0 my ($cond, $block) = @{$self->{strmap}{$s}}[1..2];
  0         0  
505 0         0 return $cmd . " ($cond) { $block }";
506             } elsif ($cmd eq 'do') {
507 0         0 my ($cond, $block) = @{$self->{strmap}{$s}}[1..2];
  0         0  
508 0         0 return $cmd . " { $block } while ($cond)";
509             } elsif ($cmd eq 'for') {
510 0         0 my ($pre, $cond, $post, $block) = @{$self->{strmap}{$s}}[1..4];
  0         0  
511 0         0 return $cmd . " ($pre; $cond; $post) { $block }";
512             } elsif ($cmd eq 'foreach') {
513 0         0 my ($expr, $key, $value, $block) = @{$self->{strmap}{$s}}[1..4];
  0         0  
514 0 0       0 return $cmd . " ($expr " . (defined $key ? "$key => " : '') . "$value) { $block }";
515             } elsif ($cmd eq 'switch') {
516 0         0 my ($expr, $cases) = @{$self->{strmap}{$s}}[1..2];
  0         0  
517 0 0       0 return $cmd . " ($expr) { " . join(' ', map { sprintf "%s %s", defined $_->[0] ? "case $_->[0]:" : "default:", $_->[1]; } @$cases) . " }";
  0         0  
518             } elsif ($cmd eq 'case') {
519 0         0 my $expr = $self->{strmap}{$s}[1];
520 0 0       0 return (defined $expr ? "case $expr:" : "default:");
521             } elsif ($cmd eq 'try') {
522 0         0 my ($try, $catches, $finally) = @{$self->{strmap}->{$s}}[1..3];
  0         0  
523 0 0 0     0 return $cmd . " { $try }" . join(' ', map { sprintf " catch (%s) { %s }", $_->[0] // '-', $_->[1]; } @$catches) . (defined $finally ? " finally { $finally }" : '');
  0         0  
524             } else {
525 0         0 return $cmd;
526             }
527             }
528 0         0 return $s;
529             }
530              
531             sub val {
532 0     0 0 0 my ($self, $s) = @_;
533             #exists $self->{strmap}{$s} || die "assert: bad statement $s passed to parser->val()";
534 0         0 return $self->{strmap}{$s}; # for lookup after is_strval(), is_array(), ..
535             }
536              
537             sub get_strval {
538 1223     1223 0 2220 my ($self, $s) = @_;
539             #defined($s) || die "assert: undefined statement passed to parser->get_strval()";
540              
541 1223 100       6260 if ($s =~ /^(\#(str|num|const)\d+|\#null)$/) {
542 1202         3835 return $self->{strmap}{$s};
543             }
544 21         64 return;
545             }
546              
547             sub get_strval_or_str {
548 199     199 0 423 my ($self, $s) = @_;
549              
550 199 100       715 if ($s =~ /^(\#(str|num|const)\d+|\#null)$/) {
551 64         149 $s = $self->{strmap}{$s};
552             }
553 199         461 return $s;
554             }
555              
556             sub get_numval {
557 0     0 0 0 my ($self, $s) = @_;
558              
559 0 0       0 if ($s =~ /^(\#num\d+|\#null)$/) {
560 0         0 $s = $self->{strmap}{$s};
561             }
562 0         0 return $s;
563             }
564              
565             sub is_null {
566 1079     1079 0 1903 my ($s) = @_;
567              
568 1079 100       2531 if ($s =~ /^(\#null)$/) {
569 57         275 return 1;
570             }
571 1022         3123 return 0;
572             }
573              
574             sub is_const {
575 7561     7561 0 12812 my ($s) = @_;
576              
577 7561 100       14497 if ($s =~ /^(\#const\d++)$/) {
578 259         816 return 1;
579             }
580 7302         40908 return 0;
581             }
582              
583             sub is_numval {
584 190     190 0 352 my ($s) = @_;
585              
586 190 100       555 if ($s =~ /^(\#num\d+)$/) {
587 135         507 return 1;
588             }
589 55         278 return 0;
590             }
591              
592             sub is_strval {
593 16224     16224 0 26651 my ($s) = @_;
594              
595 16224 100       46379 if ($s =~ /^(\#(str|num|const)\d+|\#null)$/) {
596 5832         20886 return 1;
597             }
598 10392         31794 return 0;
599             }
600              
601             sub is_array {
602 2478     2478 0 4162 my ($s) = @_;
603              
604 2478 100       5763 if ($s =~ /^#arr\d+$/) {
605 968         3508 return 1;
606             }
607 1510         6027 return 0;
608             }
609              
610             sub is_block {
611 12800     12800 0 20268 my ($s) = @_;
612              
613 12800 100       31013 if ($s =~ /^#blk\d+$/) {
614 4254         11727 return 1;
615             }
616 8546         20161 return 0;
617             }
618              
619             sub bighex {
620 4     4 0 10 my ($hex) = @_;
621              
622             # hex() warns for 64-bit numbers like 0x10000000
623             # (Hexadecimal number > 0xffffffff non-portable)
624             # php converts such numbers to float.
625             #
626             # The 'use bigint qw/hex/' workaround would transparently
627             # use Math::BigInt internally. So convert 64-bit floats
628             # manually to float.
629             #
630             # also: perl warns for '0X'-prefix - php not
631             #
632 4 100       14 if (length($hex) <= 10) {
633 3 50       12 if ($hex =~ /^0X(.*)$/) {
634 0         0 return hex($1);
635             } else {
636 3         14 return hex($hex);
637             }
638             }
639 1         9 my ($high, $low) = $hex =~ /^0[xX]([0-9a-fA-F]{1,8})([0-9a-fA-F]{8})$/;
640 1 50       5 unless (defined $high) {
641 0         0 warn "$hex is not a 64-bit hex number";
642 0         0 return hex($hex);
643             }
644             # with 32bit integers perl truncates (1 << 32) to 0x1
645             #
646 1 50       101 if ($Config{ivsize} == 4) {
647 6     6   3305 use bigint;
  6         30212  
  6         29  
648 0         0 return hex("0x$low") + (hex("0x$high") << 32);
649             } else {
650 1         27 return hex("0x$low") + (hex("0x$high") << 32);
651             }
652             }
653              
654             # override methods inherited from PhpTokenizer
655             {
656             sub add {
657 3143     3143 0 7729 my ($tab, $sym) = @_;
658 3143         4542 push(@{$tab->{tok}}, $sym);
  3143         6562  
659 3143         5760 return;
660             }
661             sub add_open {
662 2271     2271 0 5774 my ($tab, $sym) = @_;
663 2271         3472 push(@{$tab->{tok}}, $sym);
  2271         4804  
664 2271         4215 return;
665             }
666             sub add_close {
667 2263     2263 0 5853 my ($tab, $sym) = @_;
668 2263         3399 my $pos = scalar @{$tab->{tok}};
  2263         3876  
669              
670             # join string literals with '.' operator if possible
671             # (this should also be done by php_decode)
672             #
673 2263 100 66     13463 if (defined $tab->{strmap}
      100        
      100        
      100        
      100        
674             && ($sym eq ')')
675             && ($pos > 2)
676             && ($tab->{tok}->[$pos-1] =~ /^#num\d+$/)
677             && ($tab->{tok}->[$pos-2] eq '(')
678             && ($tab->{tok}->[$pos-3] =~ /^chr$/i)) {
679 6         16 my $val = $tab->{strmap}->{$tab->{tok}->[$pos-1]};
680 6 50       17 if ($val != 0) {
681 6         18 my $ch = chr(int($val) & 0xff);
682 6         11 pop(@{$tab->{tok}});
  6         26  
683 6         12 pop(@{$tab->{tok}});
  6         8  
684 6         13 pop(@{$tab->{tok}});
  6         10  
685             #$tab->{log}->('tokenize', "CHR chr($val) [$ch]") if $tab->{log};
686 6         18 $tab->add_str($ch);
687             } else {
688 0         0 push(@{$tab->{tok}}, $sym);
  0         0  
689             }
690             } else {
691 2257         3272 push(@{$tab->{tok}}, $sym);
  2257         4806  
692             }
693 2263         4509 return;
694             }
695             sub add_white {
696 3493     3493 0 8200 my ($tab, $sym) = @_;
697 3493 100       7295 if ($sym eq "\n") {
698 6         13 $tab->{strmap}->{'__LINE__'} += 1;
699 6 50       15 $tab->{debug}->('tokenize', "set linenum: %d", $tab->{strmap}->{'__LINE__'}) if $tab->{debug};
700             }
701             #push(@{$tab->{tok}}, ' ');
702 3493         6296 return;
703             }
704             sub add_comment {
705 8     8 0 28 my ($tab, $sym) = @_;
706             #push(@{$tab->{tok}}, "/*$sym*/");
707 8         18 return;
708             }
709             sub add_sym {
710 2187     2187 0 5738 my ($tab, $sym) = @_;
711 2187 100       4475 if ($sym eq '__LINE__') {
712             # TODO: track line-number for each symbol, so that
713             # it is also valid in eval()-code?
714             #
715 4         21 $tab->{warn}->('tokenize', "substitute __LINE__ with %d", $tab->{strmap}->{'__LINE__'});
716 4         160 my $k = $tab->setnum($tab->{strmap}->{'__LINE__'});
717 4         10 push(@{$tab->{tok}}, $k);
  4         8  
718             } else {
719 2183         2903 push(@{$tab->{tok}}, $sym);
  2183         4684  
720             }
721 2187         4203 return;
722             }
723             sub add_var {
724 1780     1780 0 4770 my ($tab, $sym) = @_;
725 1780         2814 push(@{$tab->{tok}}, '$'.$sym);
  1780         4482  
726 1780         3554 return;
727             }
728             sub add_str {
729 1041     1041 0 2001 my ($tab, $sym) = @_;
730              
731 1041 50       2125 if (defined $tab->{strmap}) {
732 1041         1422 my $pos = scalar @{$tab->{tok}};
  1041         1831  
733              
734             # join string literals with '.' operator if possible
735             # (this should also be done by php_decode)
736             #
737 1041 100 100     4668 if (($pos > 1) && ($tab->{tok}->[$pos-1] eq '.') && ($tab->{tok}->[$pos-2] =~ /^#str\d+$/)) {
      100        
738 11         35 my $oldstr = $tab->{strmap}->{$tab->{tok}->[$pos-2]};
739 11         19 pop(@{$tab->{tok}});
  11         17  
740 11         21 pop(@{$tab->{tok}});
  11         19  
741             #$tab->{log}->('tokenize', "JOIN $oldstr . $sym") if $tab->{log};
742 11         27 $sym = $oldstr . $sym;
743             }
744              
745             # remember last linenum for each new #str symbol
746             #
747 1041         4159 $tab->{strmap}->{'__LINEMAP__'}{"#str$stridx"} = $tab->{strmap}->{'__LINE__'};
748              
749             # substitute: 'str' -> #str$i
750             #
751 1041         2231 my $k = $tab->setstr($sym);
752 1041         1583 push(@{$tab->{tok}}, $k);
  1041         2502  
753             } else {
754 0         0 push(@{$tab->{tok}}, '\'');
  0         0  
755 0         0 push(@{$tab->{tok}}, $sym);
  0         0  
756 0         0 push(@{$tab->{tok}}, '\'');
  0         0  
757             }
758 1041         2098 return;
759             }
760             sub add_num {
761 538     538 0 1079 my ($tab, $sym) = @_;
762              
763 538 50       1140 if (defined $tab->{strmap}) {
764             # substitute: number -> #num$i
765             #
766 538         746 my $num;
767 538 100       1794 if ($sym =~ /^0[xX][0-9a-fA-F]+$/) {
    50          
    100          
768             #$num = hex($sym);
769 4         17 $num = bighex($sym);
770             } elsif ($sym =~ /^0[0-7]+$/) {
771 0         0 $num = oct($sym);
772             } elsif ($sym =~ /^[0-9]*\.[0-9]*/) {
773 6         25 $num = $sym * 1;
774             } else {
775 528         793 $num = $sym;
776             }
777 538         1199 my $k = $tab->setnum($num);
778 538         807 push(@{$tab->{tok}}, $k);
  538         1182  
779             } else {
780 0         0 push(@{$tab->{tok}}, $sym);
  0         0  
781             }
782 538         1122 return;
783             }
784             sub add_script_start {
785 8     8 0 18 my ($tab, $sym) = @_;
786             #push(@{$tab->{tok}}, $sym);
787 8         17 return;
788             }
789             sub add_script_end {
790 799     799 0 1895 my ($tab, $sym) = @_;
791             #push(@{$tab->{tok}}, $sym);
792 799         1539 return;
793             }
794             sub add_noscript {
795 8     8 0 18 my ($tab, $sym) = @_;
796              
797 8 100 100     13 if ((scalar @{$tab->{tok}} > 0) && ($tab->{tok}->[-1] ne ';')) {
  8         35  
798             # append ';' if missing at end of php-block
799 1         4 $tab->add(';');
800             }
801 8         90 $tab->add_sym('echo');
802 8         23 $tab->add_str($sym);
803 8         26 $tab->add(';');
804 8         20 $tab->add_script_end('');
805 8         17 return;
806             }
807             sub add_bad_open {
808 0     0 0 0 my ($tab, $sym) = @_;
809              
810 0         0 $tab->{warn}->('tokenize', "in script got bad open %s", $sym);
811 0         0 $tab->add($sym);
812 0         0 return;
813             }
814             sub tok_dump {
815 0     0 0 0 my ($tab) = @_;
816 0         0 return join('', @{$tab->{tok}});
  0         0  
817             }
818             sub tok_count {
819 0     0 0 0 my ($tab) = @_;
820 0         0 return scalar @{$tab->{tok}};
  0         0  
821             }
822             }
823              
824             # http://php.net/manual/en/reserved.keywords.php
825             #
826             my %php_keywords = map { $_ => 1 } ('__halt_compiler', 'abstract', 'and', 'array', 'as', 'break', 'callable', 'case', 'catch', 'class', 'clone', 'const', 'continue', 'declare', 'default', 'die', 'do', 'echo', 'else', 'elseif', 'empty', 'enddeclare', 'endfor', 'endforeach', 'endif', 'endswitch', 'endwhile', 'eval', 'exit', 'extends', 'final', 'for', 'foreach', 'function', 'global', 'goto', 'if', 'implements', 'include', 'include_once', 'instanceof', 'insteadof', 'interface', 'isset', 'list', 'namespace', 'new', 'or', 'print', 'private', 'protected', 'public', 'readonly', 'require', 'require_once', 'return', 'static', 'switch', 'throw', 'trait', 'try', 'unset', 'use', 'var', 'while', 'xor');
827              
828             my %php_modifiers = map { $_ => 1 } ('const', 'final', 'private', 'protected', 'public', 'readonly', 'static', 'var');
829              
830             # All magic constants are resolved at compile time
831             # https://www.php.net/manual/en/language.constants.magic.php
832             #
833             my %magic_constants = map { $_ => 1 } ('__CLASS__', '__DIR__', '__FILE__', '__FUNCTION__', '__LINE__', '__METHOD__', '__NAMESPACE__', '__TRAIT__', 'ClassName::class');
834              
835             # builtin types: https://www.php.net/manual/en/language.types.intro.php
836             #
837             use constant {
838 6         154844 T_VOID => 0x0001,
839             T_INT => 0x0002,
840             T_FLOAT => 0x0004,
841             T_BOOL => 0x0008,
842             T_STR => 0x0010,
843             T_ARRAY => 0x0020,
844             T_OBJECT => 0x0040,
845             T_CALL => 0x0080,
846             T_MASK => 0xffff,
847 6     6   307501 };
  6         15  
848              
849              
850             # see: http://perldoc.perl.org/perlop.html#Operator-Precedence-and-Associativity
851             # http://php.net/manual/en/language.operators.precedence.php
852             #
853             my %op_prio = (
854             '\\' => 0,
855             '->' => 1,
856             '::' => 1,
857             '+-' => 2, # sign
858             '$' => 2,
859             '++' => 2,
860             '--' => 2,
861             'new'=> 2, # unary
862             '**' => 3,
863             '!' => 4, # unary
864             '~' => 4, # unary
865             '*' => 5,
866             '/' => 5,
867             '%' => 5,
868             '+' => 6,
869             '-' => 6,
870             '.' => 6,
871             '<<' => 7,
872             '>>' => 7,
873             '<' => 8,
874             '>' => 8,
875             '<=' => 8,
876             '>=' => 8,
877             'lt' => 8, # (does not exist in php5-8)
878             'gt' => 8, # (does not exist in php5-8)
879             'le' => 8, # (does not exist in php5-8)
880             'ge' => 8, # (does not exist in php5-8)
881             '==' => 9,
882             '!=' => 9,
883             '<>' => 9, # diamond seems to work as != even if not documented
884             '===' => 9,
885             '!==' => 9,
886             '<=>' => 9, # spaceship since php7
887             'eq' => 9, # (does not exist in php5-8)
888             'ne' => 9, # (does not exist in php5-8)
889             '&' => 10,
890             '^' => 11,
891             '|' => 12,
892             '&&' => 13,
893             '||' => 14,
894             '??' => 15, # right since php7
895             ':' => 16, # right
896             '?' => 17, # right
897             '?:' => 17, # right
898             '=' => 18, # right
899             'not'=> 19, # right (does not exist in php5-8)
900             'and'=> 20,
901             'or' => 21,
902             'xor'=> 21,
903             'instanceof'=> 21,
904             '...'=> 22, # ellipses
905             );
906              
907             my %op_right = (
908             '**' => 1, # right associative
909             '->' => 1, # right associative
910             '::' => 1, # right associative
911             '??' => 1, # right associative
912             '$' => 1, # right associative
913             '=' => 1, # right associative
914             );
915              
916             my %op_unary = (
917             'new'=> 1, # unary
918             '!' => 1, # unary
919             '~' => 1, # unary
920             '?' => 1, # in ternary (dummy for op_prio)
921             ':' => 1, # in ternary (dummy for op_prio)
922             );
923              
924             # Variables, constants & function names: ^[a-zA-Z_\x80-\xff][a-zA-Z0-9_\x80-\xff]*$
925             # see: https://www.php.net/manual/en/language.variables.basics.php
926             # see: https://www.php.net/manual/en/language.constants.php
927             # see: https://www.php.net/manual/en/functions.user-defined.php
928             #
929             sub is_variable {
930 21476     21476 0 35770 my ($s) = @_;
931              
932             # represent global vars as $GLOBALS$varname
933             # represent class vars as $classname$varname
934             # represent instance vars as $#instNNN$varname
935             # represent non symbol ${"xxx"} vars also as $#instNNN$varname
936             #
937 21476 100       57799 if ($s =~/^\$(GLOBALS\$|#inst\d+\$|[\w\x80-\xff]+\$)?(\$|[^\$]*)$/) {
938 7443         20773 return 1;
939             }
940 14033         40715 return 0;
941             }
942              
943             sub is_strict_variable {
944 10339     10339 0 20044 my ($s) = @_;
945              
946 10339 100       29402 if ($s =~/^\$(GLOBALS\$|#inst\d+\$|[\w\x80-\xff]+\$)?[a-zA-Z_\x80-\xff][a-zA-Z0-9_\x80-\xff]*$/) {
947 4442         26235 return 1;
948             }
949 5897         30588 return 0;
950             }
951              
952             sub is_symbol {
953 2086     2086 0 4576 my ($s) = @_;
954              
955 2086 100       6412 if ($s =~/^[a-zA-Z_\x80-\xff][a-zA-Z0-9_\x80-\xff]*$/) {
956 1814         5272 return 1;
957             }
958 272         1395 return 0;
959             }
960              
961             sub is_magic_const {
962 17     17 0 35 my ($self, $s) = @_;
963              
964 17 50       87 if ($s =~ /^#const\d+$/) {
965 17 100       65 if (exists $magic_constants{$self->{strmap}->{$s}}) {
966 12         81 return $self->{strmap}->{$s};
967             }
968             }
969 5         47 return;
970             }
971              
972             # check if statement is empty block
973             #
974             sub is_empty_block {
975 148     148 0 294 my ($self, $s) = @_;
976              
977 148 100       287 if (is_block($s)) {
978 84         131 my ($type, $a) = @{$self->{strmap}->{$s}};
  84         217  
979 84 100       214 if (scalar @$a == 0) {
980 79         203 return 1;
981             }
982             }
983 69         182 return 0;
984             }
985              
986             # flatten block (and remove #null statements)
987             #
988             sub flatten_block {
989 3793     3793 0 6929 my ($self, $s, $out) = @_;
990              
991 3793 100       6419 if (is_block($s)) {
992 694         980 my ($type, $a) = @{$self->{strmap}{$s}};
  694         1599  
993 694         1360 foreach my $stmt (@$a) {
994 876         1724 $self->flatten_block($stmt, $out);
995             }
996             } else {
997 3099 100       5656 if ($s ne '#null') {
998 2996         5600 push(@$out, $s);
999             }
1000             }
1001 3793         8496 return;
1002             }
1003              
1004             # flatten block with single statement
1005             #
1006             sub flatten_block_if_single {
1007 245     245 0 545 my ($self, $s) = @_;
1008              
1009 245 100       499 if (is_block($s)) {
1010 238         367 my ($type, $a) = @{$self->{strmap}{$s}};
  238         578  
1011 238 100       657 if (scalar @$a == 1) {
1012 147         426 return $a->[0];
1013             }
1014             }
1015 98         256 return $s;
1016             }
1017              
1018             # create and split global var
1019             #
1020             sub global_var {
1021 59     59 0 116 my ($global) = @_;
1022 59         158 return '$GLOBALS' . $global;
1023             }
1024              
1025             sub global_split {
1026 6053     6053 0 10272 my ($var) = @_;
1027 6053         10372 my ($global) = $var =~ /^\$GLOBALS(\$.*)$/;
1028 6053         12762 return $global;
1029             }
1030              
1031             # create and split method name
1032             #
1033             sub method_name {
1034 354     354 0 705 my ($class, $name) = @_;
1035 354         996 return $class . '::' . $name;
1036             }
1037              
1038             sub method_split {
1039 2080     2080 0 3423 my ($method) = @_;
1040             # allow namespace prefix
1041 2080         4549 my ($class, $name) = $method =~ /^(#inst\d+|[\w\x80-\xff\\]+)::([\w\x80-\xff]+)$/;
1042 2080         4765 return ($class, $name);
1043             }
1044              
1045             # create and split instance var
1046             #
1047             sub inst_var {
1048 53     53 0 142 my ($inst, $var) = @_;
1049 53         174 return '$' . $inst . $var;
1050             }
1051              
1052             sub inst_split {
1053 7042     7042 0 11471 my ($instvar) = @_;
1054 7042         12599 my ($inst, $var) = $instvar =~ /^\$(#inst\d+|[\w\x80-\xff]+)(\$.*)$/;
1055 7042         15420 return ($inst, $var);
1056             }
1057              
1058             # create and split namespace name
1059             #
1060             sub ns_name {
1061 31     31 0 58 my ($name, $elem) = @_;
1062 31         95 return $name . '\\' . $elem;
1063             }
1064              
1065             sub ns_split {
1066 0     0 0 0 my ($name) = @_;
1067 0         0 my ($ns, $elem) = $name =~ /^([^\\]*)\\(.+)$/;
1068 0         0 return ($ns, $elem);
1069             }
1070              
1071             # create path from namespace
1072             #
1073             sub ns_to_str {
1074 14     14 0 25 my ($self, $var) = @_;
1075              
1076 14 100       45 if ($var =~ /^#ns\d+$/) {
    100          
1077 3         5 my ($n, $e) = @{$self->{strmap}{$var}};
  3         11  
1078              
1079 3 100       7 unless (defined $n) {
1080 2         4 $n = ''; # toplevel
1081             }
1082 3         10 $e = $self->ns_to_str($e);
1083 3 50       8 if (defined $e) {
1084 3         18 return ns_name($n, $e);
1085             }
1086             } elsif (is_strval($var)) {
1087 8         33 return $self->{strmap}{$var};
1088             } else {
1089 3         17 return $var;
1090             }
1091 0         0 return;
1092             }
1093              
1094             # create variable from variable variable
1095             # $$var -> $val
1096             # ${$var} -> $val
1097             #
1098             sub varvar_to_var {
1099 90     90 0 198 my ($self, $var) = @_;
1100              
1101 90 100       173 if (is_strval($var)) {
1102 79         167 my $str = $self->{strmap}{$var};
1103              
1104             # variable names are only handled up to first '$'.
1105             # also 'null' is allowed (represented as '' or ${null})
1106             #
1107 79         300 my ($suffix) = $str =~ /^(\$$|[^\$]*)/;
1108 79         295 return '$' . $suffix;
1109             }
1110 11         35 return;
1111             }
1112              
1113             # $GLOBALS['str'] -> $str
1114             #
1115             sub globalvar_to_var {
1116 604     604 0 1192 my ($self, $base, $idx) = @_;
1117              
1118 604 100       1386 if ($base =~ /^\$GLOBALS$/) {
1119 124         316 my $idxval = $self->get_strval($idx);
1120 124 100       284 if (defined $idxval) {
1121             # variable names are only handled up to first '$'.
1122             # also 'null' is allowed (represented as '' or ${null})
1123             #
1124 123         404 my ($suffix) = $idxval =~ /^(\$$|[^\$]*)/;
1125 123         436 return '$' . $suffix;
1126             }
1127             }
1128 481         951 return;
1129             }
1130              
1131             # return base var of multi dimensional elem
1132             #
1133             sub elem_base {
1134 363     363 0 658 my ($self, $s) = @_;
1135              
1136 363         888 while ($s =~ /^#elem\d+$/) {
1137 54         94 my ($v, $i) = @{$self->{strmap}->{$s}};
  54         137  
1138              
1139 54 100       138 if (defined $i) {
1140             # add resolvable globals
1141             #
1142 37         97 my $g = $self->globalvar_to_var($v, $i);
1143 37 100       104 if (defined $g) {
1144 8         31 $g = global_var($g);
1145 8         24 return $g;
1146             }
1147             }
1148 46         161 $s = $v;
1149             }
1150 355         725 return $s;
1151             }
1152              
1153             sub getline {
1154 0     0 0 0 my ($self) = @_;
1155              
1156             #$self->{log}->('getline', "%d", $self->{strmap}->{'__LINE__'}) if $self->{log};
1157 0         0 return $self->{strmap}->{'__LINE__'};
1158             }
1159              
1160             sub updateline {
1161 1027     1027 0 1843 my ($self, $var) = @_;
1162              
1163             #$self->{log}->('updateline', "test $var") if $self->{log};
1164              
1165             # update line number based on preceeding string
1166             #
1167 1027 100       2624 if (exists $self->{strmap}->{'__LINEMAP__'}{$var}) {
1168 1026         1620 my $val = $self->{strmap}->{'__LINEMAP__'}{$var};
1169 1026 50       2364 if ($self->{strmap}->{'__LINE__'} < $val) {
1170 0 0       0 $self->{log}->('updateline', "[$var] %d -> %d", $self->{strmap}->{'__LINE__'}, $val) if $self->{log};
1171 0         0 $self->{strmap}->{'__LINE__'} = $val;
1172             }
1173             }
1174 1027         1688 return;
1175             }
1176              
1177             sub trim_list {
1178 0     0 0 0 my ($list) = @_;
1179              
1180 0   0     0 while ((scalar @$list > 0) && ($list->[0] =~ /^\s+$/)) {
1181 0         0 shift @$list;
1182             }
1183 0   0     0 while ((scalar @$list > 0) && ($list->[-1] =~ /^\s+$/)) {
1184 0         0 pop @$list;
1185             }
1186             }
1187              
1188             sub unspace_list {
1189 785     785 0 1273 my ($list) = @_;
1190             # remove empty fields
1191 785         1666 my @filtered = grep { $_ !~ /^\s+$/ } @$list;
  13177         27293  
1192              
1193             # remove comments
1194 785         1531 @filtered = grep { $_ !~ /^\/\*.*\*\/$/ } @filtered;
  13177         24620  
1195              
1196 785         1854 return \@filtered;
1197             }
1198              
1199             sub unquote_names {
1200 6083     6083 0 10464 my ($str) = @_;
1201              
1202             # todo: is this really needed?
1203 6083         7800 if (1) {
1204             # \xXX
1205 6083         11582 $str =~ s/\\x([0-9a-fA-F]{2})/chr(hex($1))/ge;
  0         0  
1206             }
1207 6083         11279 return $str;
1208             }
1209              
1210             sub dump_line {
1211 0     0 0 0 my ($self, $prefix, $tok) = @_;
1212              
1213 0         0 for (my $i=0; $i < scalar @$tok; $i++) {
1214 0         0 my $word = $tok->[$i];
1215              
1216 0 0       0 if ($word =~ /^#/) {
1217 0         0 my $s = $self->shortstr($self->{strmap}->{$word}, 100);
1218 0         0 print "$prefix> $word [$s]\n";
1219             } else {
1220 0         0 my $t = unquote_names($word);
1221 0         0 print "$prefix> $t [$word]\n";
1222             }
1223             }
1224 0         0 my $q = join('', @$tok);
1225 0         0 print "$prefix> SHORTQ: $q\n";
1226 0         0 return;
1227             }
1228              
1229             sub read_array {
1230 145     145 0 328 my ($self, $tok, $close, $arr) = @_;
1231              
1232 145         265 while (1) {
1233 244 50       577 if (scalar @$tok == 0) {
1234 0         0 last;
1235             }
1236 244 100       580 if ($tok->[0] eq $close) {
1237 25         55 shift @$tok;
1238 25         51 last;
1239             }
1240 219         548 my $val = $self->read_statement($tok, undef);
1241 219 50 33     889 if (!defined $val || ($val eq $close)) {
1242 0         0 last;
1243             }
1244 219 100       435 if ($val eq ',') {
1245 1         6 $arr->set(undef, undef);
1246 1         1 next; # allow empty fields for list()
1247             }
1248 218 50       431 if (scalar @$tok > 0) {
1249 218 100       577 if ($tok->[0] eq $close) {
    100          
    50          
1250 103         186 shift @$tok;
1251 103         417 $arr->set(undef, $val);
1252 103         184 last;
1253             } elsif ($tok->[0] eq ',') {
1254 82         139 shift @$tok;
1255 82         333 $arr->set(undef, $val);
1256 82         180 next;
1257             } elsif ($tok->[0] eq '=>') {
1258 33         55 shift @$tok;
1259 33         69 my $key = $val;
1260 33 100       123 if ($key =~ /^#expr\d+$/) {
    100          
1261 2         3 my ($op, $v1, $v2) = @{$self->{strmap}->{$key}};
  2         23  
1262 2 50 33     14 if (($op eq '-') && !defined $v1) {
1263 2         11 my $str = $self->get_strval($v2);
1264 2 50 33     15 if (defined $str && is_int_index($str)) {
1265 2         10 $key = -$str;
1266             }
1267             }
1268             } elsif (is_null($key)) {
1269 1         11 $key = $self->setstr(''); # null maps to '' array index
1270             }
1271 33         95 $val = $self->read_statement($tok, undef);
1272 33 50 33     142 if (!defined $val || ($val eq $close)) {
1273 0         0 $arr->set($key, undef);
1274 0         0 last;
1275             }
1276 33         140 $arr->set($key, $val);
1277 33 50       87 if (scalar @$tok > 0) {
1278 33 100       93 if ($tok->[0] eq $close) {
    50          
1279 17         30 shift @$tok;
1280 17         46 last;
1281             } elsif ($tok->[0] eq ',') {
1282 16         23 shift @$tok;
1283 16         42 next;
1284             }
1285             } else {
1286 0         0 last;
1287             }
1288             }
1289             }
1290             }
1291 145         287 return;
1292             }
1293              
1294             # last_op is optional param
1295             #
1296             sub _read_statement {
1297 13401     13401   21299 my ($self, $tok, $last_op) = @_;
1298              
1299 13401 100 66     381816 if ((scalar @$tok > 0) && ($tok->[0] =~ /^([\;\:\,\)\]\}]|else|endif|endwhile|endfor|endforeach|as|=>|catch|finally)$/i)) {
    100 66        
    100 100        
    100 100        
    100 100        
    100 100        
    100 100        
    50 100        
    50 33        
    50 33        
    100 66        
    50 33        
    100 33        
    50 0        
    50 0        
    100 33        
    100 33        
    100 66        
    50 33        
    100 66        
    50 33        
    100 33        
    50 66        
    100 66        
    100 66        
    100 33        
    50 66        
    100 33        
    100 66        
    100 33        
    100 100        
    100 66        
    100 100        
    100 66        
    100 100        
    100 33        
    100 100        
    100 66        
    50 100        
    100 66        
    100 100        
    100 66        
    100 100        
    50 66        
    100 100        
    100 66        
    100 100        
      66        
      66        
      66        
      66        
      66        
      100        
      66        
      100        
      100        
      66        
      66        
      66        
      100        
      100        
      66        
      100        
      100        
      100        
      66        
      100        
      100        
      66        
      33        
      33        
      66        
      66        
      66        
1300 3389         6036 my $sym = shift @$tok;
1301 3389         7353 return $sym;
1302             } elsif ((scalar @$tok > 0) && ($tok->[0] =~ /^null$/i)) {
1303 16         27 shift @$tok;
1304 16         46 unshift(@$tok, '#null');
1305 16         44 my $res = $self->read_statement($tok, $last_op);
1306 16         45 return $res;
1307             } elsif ((scalar @$tok > 1) && ($tok->[0] eq '{')) {
1308             # block expression { statement1; statement2; ... }
1309             # also allow empty { } block
1310             #
1311 184         378 shift @$tok;
1312 184         551 my $arglist = $self->read_code_block($tok, '}', ';');
1313 184         519 my $k = $self->setblk('std', $arglist);
1314 184         400 return $k;
1315             } elsif ((scalar @$tok > 1) && ($tok->[0] eq '(')) {
1316             # brace expression ( expr | call ) => result
1317             # also: allow empty ( ) block
1318             # also: type casting (int|bool|float|array|object|unset)
1319             # http://php.net/manual/en/language.types.type-juggling.php
1320             #
1321 60         116 shift @$tok;
1322 60         190 my $arglist = $self->read_block($tok, ')', undef);
1323              
1324 60 50       239 if (scalar @$arglist > 0) {
1325 60 50       160 if (scalar @$arglist == 1) {
1326 60         99 my $ref = $arglist->[0];
1327 60         166 my $str = $self->get_strval_or_str($ref);
1328             #$self->{log}->('parse', "braces: $ref, $str") if $self->{log};
1329 60 100 100     141 if (is_strval($ref) && ($str =~ /^(int|bool|float|string|array|object|unset)$/)) {
1330             # type casting
1331             # https://www.php.net/manual/en/language.types.type-juggling.php
1332             # https://www.php.net/manual/en/function.settype.php
1333             #
1334 2         6 my $res = $self->read_statement($tok, $last_op);
1335 2         10 my $k;
1336 2 100       15 if ($str eq 'int') {
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1337 1         5 $k = $self->setcall('intval', [$res]);
1338             } elsif ($str eq 'integer') {
1339 0         0 $k = $self->setcall('intval', [$res]);
1340             } elsif ($str eq 'string') {
1341 1         4 $k = $self->setcall('strval', [$res]);
1342             } elsif ($str eq 'binary') {
1343 0         0 $k = $self->setcall('strval', [$res]);
1344             } elsif ($str eq 'float') {
1345 0         0 $k = $self->setcall('floatval', [$res]);
1346             } elsif ($str eq 'double') {
1347 0         0 $k = $self->setcall('floatval', [$res]);
1348             } elsif ($str eq 'real') { # removed in php8
1349 0         0 $k = $self->setcall('floatval', [$res]);
1350             } elsif ($str eq 'bool') {
1351 0         0 $k = $self->setcall('boolval', [$res]);
1352             } elsif ($str eq 'boolean') {
1353 0         0 $k = $self->setcall('boolval', [$res]);
1354             } elsif ($str eq 'array') {
1355 0         0 $k = $self->setcall('array', [$res]);
1356             } elsif ($str eq 'object') {
1357 0         0 $k = $self->setcall('object', [$res]);
1358             } elsif ($str eq 'unset') { # removed in php8
1359 0         0 my $t = $self->setstr('null');
1360 0         0 $k = $self->setcall('settype', [$res, $t]);
1361             } else {
1362 0         0 $k = $self->setcall('settype', [$res, $ref]);
1363             }
1364 2         7 unshift(@$tok, $k);
1365 2         6 $res = $self->read_statement($tok, $last_op);
1366 2         7 return $res;
1367             }
1368 58 100 100     128 if (is_strval($ref) || ($ref =~ /^#expr\d+$/) || ($ref =~ /^#call\d+$/) || ($ref =~ /^#inst\d+$/)) {
      100        
      66        
1369 56         143 unshift(@$tok, $ref);
1370 56         142 my $res = $self->read_statement($tok, $last_op);
1371 56         150 return $res;
1372             }
1373             }
1374 2         9 my $res = $self->setblk('brace', $arglist);
1375              
1376             # - anonymous functions might be called directly -> '(function () { return 1; })()'
1377             # - also subexpressions might use braces -> '$x = ($y) ? 1 : 2'
1378             #
1379 2         8 unshift(@$tok, $res);
1380 2         6 $res = $self->read_statement($tok, $last_op);
1381 2         6 return $res;
1382             }
1383 0         0 my $res = $self->setblk('brace', []);
1384 0         0 return $res;
1385             } elsif ((scalar @$tok > 1) && ($tok->[0] eq '[')) {
1386             # $array = ['a','b','c']
1387             #
1388 12         29 shift @$tok;
1389              
1390 12         37 my $arr = $self->newarr();
1391 12         39 $self->read_array($tok, ']', $arr);
1392              
1393             #my $arglist = $self->read_block($tok, ']', ',');
1394             #foreach my $val (@$arglist) {
1395             # $arr->set(undef, $val);
1396             #}
1397 12         27 unshift(@$tok, $arr->{name});
1398 12         28 my $res = $self->read_statement($tok, $last_op);
1399 12         26 return $res;
1400             } elsif ((scalar @$tok > 1) && ($tok->[0] eq '&')) {
1401             # variable reference
1402             # & $var
1403             #
1404 8         48 shift @$tok;
1405              
1406 8         37 my $var = $self->read_statement($tok, undef);
1407 8         58 my $k = $self->setref($var);
1408 8         18 return $k;
1409             } elsif (((scalar @$tok == 1)
1410             || ((scalar @$tok > 1) && ($tok->[1] =~ /^([\;\,\)\]\}]|as|=>)$/))
1411             || ((scalar @$tok > 2) && ($tok->[1] eq ':') && ($tok->[2] ne ':'))) && !exists $php_keywords{$tok->[0]}) {
1412             # variable dereference
1413             # #str/#num/#const
1414             # constant
1415             # __FILE__
1416             # __LINE__
1417             #
1418 6083         12293 my $sym = shift @$tok;
1419 6083         11915 my $var = unquote_names($sym);
1420              
1421 6083 100 100     11055 if (is_strict_variable($var) || ($var =~ /^#/)) {
    50          
    50          
    100          
    100          
    50          
1422 5733 100       12276 if ($var =~ /^#str/) {
1423 1027         2320 $self->updateline($var);
1424             }
1425 5733         13325 return $var;
1426             } elsif ($var =~ /^__FILE__$/) {
1427 0         0 my $v = $self->{filename};
1428 0         0 my $k = $self->setstr($v);
1429 0 0       0 $self->{log}->('parse', "getfile: $k -> $v") if $self->{log};
1430 0         0 return $k;
1431             } elsif ($var =~ /^__LINE__$/) {
1432 0         0 my $k = $self->setnum($self->getline());
1433 0 0       0 $self->{log}->('parse', "getline: $k -> %d", $self->{strmap}->{$k}) if $self->{log};
1434 0         0 return $k;
1435             } elsif ($var =~ /^false$/i) {
1436 3         11 return $self->setnum(0);
1437             } elsif ($var =~ /^true$/i) {
1438 3         14 return $self->setnum(1);
1439             } elsif (is_symbol($var)) {
1440             # constants are always global
1441             # (undefined constants are propagated to string in exec)
1442             #
1443 344         934 my $k = $self->setconst($var);
1444 344 50 100     1195 if ((scalar @$tok > 1) && ($tok->[0] eq ':') && ($tok->[1] ne ':') && !defined $last_op) {
      66        
      66        
1445 2         8 shift @$tok;
1446 2         7 $k = $self->setstmt(['label', $k]); # goto label
1447             }
1448 344         792 return $k;
1449             }
1450 0         0 return $var;
1451             } elsif ((scalar @$tok > 1) && ($tok->[0] eq '<') && ($tok->[1] eq '?')) {
1452 0 0 0     0 if ((scalar @$tok > 2) && ($tok->[2] eq 'php')) {
1453 0         0 shift @$tok;
1454 0         0 shift @$tok;
1455 0         0 shift @$tok;
1456 0         0 return '
1457             } else {
1458 0         0 shift @$tok;
1459 0         0 shift @$tok;
1460 0         0 return '
1461             }
1462             } elsif ((scalar @$tok > 5) && ($tok->[0] eq '<') && ($tok->[1] eq 'script') && ($tok->[2] eq 'type') && ($tok->[3] eq '=') && ($tok->[5] eq '>')) {
1463             # filter out bad javascript tags in scripts with no proper end-tag
1464             # (this avoids misinterpretations of javascript while(1)-loops)
1465             #
1466 0         0 my @list = ();
1467 0         0 push(@list, shift @$tok);
1468 0         0 push(@list, shift @$tok);
1469 0         0 push(@list, shift @$tok);
1470 0         0 push(@list, shift @$tok);
1471 0         0 push(@list, shift @$tok); # type
1472 0         0 push(@list, shift @$tok);
1473              
1474 0         0 while (scalar @$tok > 0) {
1475 0 0 0     0 if ((scalar @$tok > 3) && ($tok->[0] eq '<') && ($tok->[1] eq '/') && ($tok->[2] eq 'script') && ($tok->[3] eq '>')) {
      0        
      0        
      0        
1476 0         0 push(@list, shift @$tok);
1477 0         0 push(@list, shift @$tok);
1478 0         0 push(@list, shift @$tok);
1479 0         0 push(@list, shift @$tok);
1480 0         0 last;
1481             }
1482 0         0 my $sym = shift @$tok;
1483 0         0 push(@list, $sym);
1484             }
1485 0         0 my $script = join(' ', @list);
1486 0         0 my $s = $self->setstr($script);
1487 0         0 my $k = $self->setstmt(['echo', [$s]]);
1488 0 0       0 $self->{log}->('parse', "javascript string: %s", $script) if $self->{log};
1489 0         0 return $k;
1490             } elsif ((scalar @$tok > 1) && ($tok->[0] eq '?') && ($tok->[1] eq '>')) {
1491 0         0 shift @$tok;
1492 0         0 shift @$tok;
1493 0         0 return '?>';
1494             } elsif ((scalar @$tok > 1) && (lc($tok->[0]) eq 'echo')) {
1495 147         276 shift @$tok;
1496 147         308 my $all_str = 1;
1497 147         300 my @args = ();
1498 147         256 while (1) {
1499 156         432 my $arg = $self->read_statement($tok, undef);
1500              
1501 156 100       431 unless (is_strval($arg)) {
1502 64         131 $all_str = 0;
1503             }
1504 156 50       459 if ($arg ne ',') {
1505 156         400 push(@args, $arg);
1506             }
1507 156 100 100     701 unless ((scalar @$tok > 0) && ($tok->[0] eq ',')) {
1508 147         264 last;
1509             }
1510 9         19 shift @$tok;
1511             }
1512 147         470 my $k = $self->setstmt(['echo', \@args]);
1513              
1514             # execute expr & might continue with operation
1515             #
1516 147         387 unshift(@$tok, $k);
1517 147         425 return $self->read_statement($tok, $last_op);
1518             } elsif ((scalar @$tok > 1) && (lc($tok->[0]) eq 'print')) {
1519 0         0 shift @$tok;
1520 0         0 my $arg = $self->read_statement($tok, undef);
1521 0         0 my $k = $self->setstmt(['print', $arg]);
1522              
1523             # execute expr & might continue with operation
1524             #
1525 0         0 unshift(@$tok, $k);
1526 0         0 return $self->read_statement($tok, $last_op);
1527             } elsif ((scalar @$tok > 1) && (lc($tok->[0]) eq 'namespace')) {
1528 10         24 shift @$tok;
1529              
1530 10         16 my $arg = ''; # toplevel
1531 10 100       25 if ($tok->[0] ne '{') {
1532 9         21 $arg = $self->read_statement($tok, undef);
1533 9         24 my $str = $self->ns_to_str($arg);
1534 9 50       19 if (defined $str) {
1535 9         17 $arg = $str;
1536             } else {
1537 0         0 $self->{warn}->('parse', "bad namespace: %s", $arg);
1538             }
1539             }
1540 10         12 my $block;
1541 10 100 66     41 if ((scalar @$tok > 0) && ($tok->[0] eq '{')) {
1542 2         4 shift @$tok;
1543 2         19 my $arglist = $self->read_code_block($tok, '}', ';');
1544 2         15 $block = $self->setblk('std', $arglist);
1545             }
1546 10         48 return $self->setstmt(['namespace', $arg, $block]);
1547             } elsif ((scalar @$tok > 1) && (lc($tok->[0]) eq 'use')) {
1548 0         0 shift @$tok;
1549             # https://php.net/manual/en/language.oop5.traits.php
1550 0         0 my @args = ();
1551 0         0 while (1) {
1552 0         0 my $arg = $self->read_statement($tok, undef);
1553              
1554 0         0 push(@args, $arg);
1555 0 0 0     0 unless ((scalar @$tok > 0) && ($tok->[0] eq ',')) {
1556 0         0 last;
1557             }
1558 0         0 shift @$tok;
1559             }
1560 0         0 return $self->setstmt(['use', \@args]);
1561             } elsif ((scalar @$tok > 1) && ($tok->[0] =~ /^(include|include_once|require|require_once)$/i)) {
1562 0         0 my $type = lc(shift @$tok);
1563 0         0 my $arg = $self->read_statement($tok, undef);
1564 0         0 return $self->setstmt([$type, $arg]);
1565             } elsif ((scalar @$tok > 1) && (lc($tok->[0]) eq 'global')) {
1566 6         27 shift @$tok;
1567 6         15 my @args = ();
1568 6         23 while (1) {
1569 6         22 my $arg = $self->read_statement($tok, undef);
1570              
1571 6         19 push(@args, $arg);
1572 6 50 33     45 unless ((scalar @$tok > 0) && ($tok->[0] eq ',')) {
1573 6         12 last;
1574             }
1575 0         0 shift @$tok;
1576             }
1577 6         23 return $self->setstmt(['global', \@args]);
1578             } elsif ((scalar @$tok > 1) && (lc($tok->[0]) eq 'return')) {
1579 118         266 shift @$tok;
1580 118         355 my $res = $self->read_statement($tok, undef);
1581             # remove trailing ';' if evaluated as string
1582             #
1583 118 100 66     697 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1584 99         171 shift @$tok;
1585             }
1586 118         435 return $self->setstmt(['return', $res]);
1587             } elsif ((scalar @$tok > 1) && (lc($tok->[0]) eq 'goto')) {
1588 1         7 shift @$tok;
1589 1         5 my $res = $self->read_statement($tok, undef);
1590             # remove trailing ';' if evaluated as string
1591             #
1592 1 50 33     15 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1593 1         3 shift @$tok;
1594             }
1595 1         4 return $self->setstmt(['goto', $res]);
1596             } elsif ((scalar @$tok > 1) && (lc($tok->[0]) eq 'throw')) {
1597 0         0 shift @$tok;
1598 0         0 my $arg = $self->read_statement($tok, undef);
1599 0         0 return $self->setstmt(['throw', $arg]);
1600             } elsif ((scalar @$tok > 0) && (lc($tok->[0]) eq 'break')) {
1601 2         13 shift @$tok;
1602 2         8 my $res = $self->read_statement($tok, undef); # optional level
1603 2 50 33     31 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1604 0         0 shift @$tok;
1605             }
1606 2         13 return $self->setstmt(['break', $res]);
1607             } elsif ((scalar @$tok > 0) && (lc($tok->[0]) eq 'continue')) {
1608 0         0 shift @$tok;
1609 0         0 my $res = $self->read_statement($tok, undef); # optional level
1610 0 0 0     0 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1611 0         0 shift @$tok;
1612             }
1613 0         0 return $self->setstmt(['continue', $res]);
1614             } elsif ((scalar @$tok > 0) && (lc($tok->[0]) =~ /^(var|static|public|protected|private|final|const)$/)) {
1615 55         163 my $type = shift @$tok;
1616 55         171 my $pfx = {$type => 1};
1617              
1618 55 100 66     304 if ((scalar @$tok > 0) && (lc($tok->[0]) =~ /^(var|static|public|protected|private|final|const)$/)) {
1619 7         15 $type = shift @$tok;
1620 7         14 $pfx->{$type} = 1;
1621             }
1622 55         167 my $k = $self->setpfx($pfx);
1623 55         143 unshift(@$tok, $k);
1624 55         127 return $self->read_statement($tok);
1625             } elsif ((scalar @$tok > 0) && (lc($tok->[0]) eq '__halt_compiler')) {
1626 0         0 my $k = shift @$tok;
1627 0         0 @$tok = ();
1628 0         0 return $k;
1629             } elsif ((scalar @$tok > 3) && (lc($tok->[0]) eq 'if') && ($tok->[1] eq '(')) {
1630 124         295 shift @$tok;
1631 124         269 shift @$tok;
1632 124         360 my $expr = $self->read_block($tok, ')', undef);
1633 124         317 my $then;
1634             my $else;
1635              
1636 124 100 66     506 if ((scalar @$tok > 0) && ($tok->[0] eq ':')) {
1637             # allow alternative block syntax
1638             # http://php.net/manual/en/control-structures.alternative-syntax.php
1639             #
1640 1         5 shift @$tok;
1641 1         7 my $block = $self->read_code_block($tok, 'endif', ';');
1642 1         9 $then = $self->setblk('std', $block);
1643             } else {
1644 123         262 $then = $self->read_statement($tok);
1645 123 100       324 if (!is_block($then)) {
1646 16 50 66     135 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1647 0         0 shift @$tok;
1648             }
1649             # always put '{ .. }' braces around if/else
1650 16         63 $then = $self->setblk('std', [$then]);
1651             }
1652             }
1653 124 100 100     919 if ((scalar @$tok > 0) && (lc($tok->[0]) eq 'else')) {
    100 100        
1654 17         51 shift @$tok;
1655 17 50 33     106 if ((scalar @$tok > 0) && ($tok->[0] eq ':')) {
1656             # allow alternative block syntax
1657             # http://php.net/manual/en/control-structures.alternative-syntax.php
1658             #
1659 0         0 shift @$tok;
1660 0         0 my $block = $self->read_code_block($tok, 'endif', ';');
1661 0         0 $else = $self->setblk('std', $block);
1662             } else {
1663 17         53 $else = $self->read_statement($tok);
1664 17 100       95 if (!is_block($else)) {
1665 1 50 33     8 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1666 1         3 shift @$tok;
1667             }
1668 1         4 $else = $self->setblk('std', [$else]);
1669             }
1670             }
1671             } elsif ((scalar @$tok > 0) && (lc($tok->[0]) eq 'elseif')) {
1672 6         16 shift @$tok;
1673 6         16 unshift(@$tok, 'if');
1674 6         21 $else = $self->read_statement($tok, undef);
1675 6 50       21 if (!is_block($else)) {
1676 6         20 $else = $self->setblk('std', [$else]);
1677             }
1678             }
1679 124 50       320 if (scalar @$expr > 1) {
1680 0         0 $self->{warn}->('parse', "if: bad cond %s", join(' ', @$expr));
1681 0         0 my $badcond = $self->setblk('expr', $expr);
1682 0         0 $expr = [$badcond];
1683             }
1684 124         475 return $self->setstmt(['if', $expr->[0], $then, $else]);
1685             } elsif ((scalar @$tok > 3) && (lc($tok->[0]) eq 'switch') && ($tok->[1] eq '(')) {
1686 9         34 shift @$tok;
1687 9         18 shift @$tok;
1688 9         29 my $expr = $self->read_block($tok, ')', undef);
1689 9         38 my $block = [];
1690 9 50 33     72 if ((scalar @$tok > 0) && ($tok->[0] eq ':')) {
    50 33        
1691             # allow alternative block syntax
1692             # http://php.net/manual/en/control-structures.alternative-syntax.php
1693             #
1694 0         0 shift @$tok;
1695 0         0 $block = $self->read_code_block($tok, 'endswitch', ';');
1696             } elsif ((scalar @$tok > 0) && ($tok->[0] eq '{')) {
1697 9         13 shift @$tok;
1698 9         30 $block = $self->read_code_block($tok, '}', ';');
1699             } else {
1700 0         0 $self->{warn}->('parse', "expected switch block {}");
1701             }
1702 9 50       66 if (scalar @$expr > 1) {
1703 0         0 $self->{warn}->('parse', "switch: bad cond %s", join(' ', @$expr));
1704 0         0 my $badcond = $self->setblk('expr', $expr);
1705 0         0 $expr = [$badcond];
1706             }
1707 9         32 my @cases = ();
1708 9         15 my $inst;
1709 9         26 foreach my $e (@$block) {
1710 29 100 100     151 if ($e =~ /^#stmt\d+$/ && (lc($self->{strmap}->{$e}->[0]) eq 'case')) {
1711 15         34 my $c = $self->{strmap}->{$e}->[1]; # undef for default case
1712 15         27 $inst = [];
1713 15         35 my $b = $self->setblk('case', $inst); # block content added in next iterations
1714 15         65 push (@cases, [$c, $b]);
1715             } else {
1716 14 50       37 if (!defined $inst) {
1717 0         0 $self->{warn}->('parse', "switch: inst w/o case: %s", $e);
1718 0         0 $inst = [];
1719             }
1720 14         32 push (@$inst, $e);
1721             }
1722             }
1723 9         32 return $self->setstmt(['switch', $expr->[0], \@cases]);
1724             } elsif ((scalar @$tok > 2) && (lc($tok->[0]) eq 'case')) {
1725 15         42 shift @$tok;
1726 15         48 my $expr = $self->read_statement($tok, undef);
1727             # 'case' might also be terminated by ';'
1728             #
1729 15 100 66     95 if ((scalar @$tok > 0) && ($tok->[0] eq ':') || ($tok->[0] eq ';')) {
      66        
1730 14         25 shift @$tok;
1731             }
1732 15 100 66     63 if ($expr =~ /^#stmt\d+$/ && (lc($self->{strmap}->{$expr}->[0]) eq 'label')) {
1733 1         4 $expr = $self->{strmap}->{$expr}->[1]; # label -> const
1734             }
1735 15         53 return $self->setstmt(['case', $expr]);
1736             } elsif ((scalar @$tok > 1) && (lc($tok->[0]) eq 'default')) {
1737 0         0 shift @$tok;
1738             # 'case' might also be terminated by ';'
1739             #
1740 0 0 0     0 if ((scalar @$tok > 0) && ($tok->[0] eq ':') || ($tok->[0] eq ';')) {
      0        
1741 0         0 shift @$tok;
1742             }
1743 0         0 return $self->setstmt(['case', undef]);
1744             } elsif ((scalar @$tok > 3) && (lc($tok->[0]) eq 'try') && ($tok->[1] eq '{')) {
1745 1         3 shift @$tok;
1746 1         3 my $try;
1747             my $finally;
1748              
1749             # https://www.php.net/manual/en/language.exceptions.php
1750             #
1751 1         10 $try = $self->read_statement($tok);
1752 1 50       5 if (!is_block($try)) {
1753 0 0 0     0 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1754 0         0 shift @$tok;
1755             }
1756             # always put '{ .. }' braces around try
1757 0         0 $try = $self->setblk('std', [$try]);
1758             }
1759 1         3 my @catches = ();
1760 1   66     12 while ((scalar @$tok > 1) && (lc($tok->[0]) eq 'catch') && ($tok->[1] eq '(')) {
      66        
1761 1         2 shift @$tok;
1762 1         3 shift @$tok;
1763 1         4 my $exception = $self->read_block($tok, ')', undef);
1764 1         15 my $block= $self->read_statement($tok);
1765              
1766 1 50       11 if (!is_block($block)) {
1767 0 0 0     0 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1768 0         0 shift @$tok;
1769             }
1770             # always put '{ .. }' braces around catch
1771 0         0 $block = $self->setblk('std', [$block]);
1772             }
1773 1         13 push (@catches, [$exception->[0], $block]);
1774             }
1775 1 50 33     12 if ((scalar @$tok > 0) && (lc($tok->[0]) eq 'finally')) {
1776 1         3 shift @$tok;
1777 1         5 $finally= $self->read_statement($tok);
1778              
1779 1 50       10 if (!is_block($finally)) {
1780 0 0 0     0 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1781 0         0 shift @$tok;
1782             }
1783             # always put '{ .. }' braces around finally
1784 0         0 $finally = $self->setblk('std', [$finally]);
1785             }
1786             }
1787 1         7 return $self->setstmt(['try', $try, \@catches, $finally]);
1788             } elsif ((scalar @$tok > 3) && (lc($tok->[0]) eq 'for') && ($tok->[1] eq '(')) {
1789             # note: just for-loops can take ',' operators in pre- and post-cond.
1790             # All 3 expressions can be empty;
1791             # http://php.net/manual/en/control-structures.for.php
1792             #
1793 20         47 shift @$tok;
1794 20         42 shift @$tok;
1795 20         60 my $expr1 = $self->read_code_block($tok, ';', ',');
1796 20         66 my $expr2 = $self->read_code_block($tok, ';', ',');
1797 20         54 my $expr3 = $self->read_code_block($tok, ')', ',');
1798 20         59 my $block;
1799 20 50 33     88 if ((scalar @$tok > 0) && ($tok->[0] eq ':')) {
1800             # allow alternative block syntax
1801             # http://php.net/manual/en/control-structures.alternative-syntax.php
1802             #
1803 0         0 shift @$tok;
1804 0         0 $block = $self->read_code_block($tok, 'endfor', ';');
1805 0         0 $block = $self->setblk('std', $block);
1806             } else {
1807 20         47 $block = $self->read_statement($tok);
1808 20 50       52 if (!is_block($block)) {
1809 0 0 0     0 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1810 0         0 shift @$tok;
1811             }
1812             # always put '{ .. }' braces around if/else
1813 0         0 $block = $self->setblk('std', [$block]);
1814             }
1815             }
1816 20         50 my $pre = $self->setblk('expr', $expr1);
1817 20         56 my $cond = $self->setblk('expr', $expr2);
1818 20         63 my $post = $self->setblk('expr', $expr3);
1819 20         80 return $self->setstmt(['for', $pre, $cond, $post, $block]);
1820             } elsif ((scalar @$tok > 3) && (lc($tok->[0]) eq 'while') && ($tok->[1] eq '(')) {
1821 10         24 shift @$tok;
1822 10         22 shift @$tok;
1823 10         28 my $expr = $self->read_block($tok, ')', ',');
1824 10         20 my $block;
1825 10 50 33     45 if ((scalar @$tok > 0) && ($tok->[0] eq ':')) {
1826             # allow alternative block syntax
1827             # http://php.net/manual/en/control-structures.alternative-syntax.php
1828             #
1829 0         0 shift @$tok;
1830 0         0 $block = $self->read_code_block($tok, 'endwhile', ';');
1831 0         0 $block = $self->setblk('std', $block);
1832             } else {
1833 10         23 $block = $self->read_statement($tok);
1834 10 100       27 if (!is_block($block)) {
1835 1 50 33     7 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1836 1         3 shift @$tok;
1837             }
1838             # always put '{ .. }' braces around if/else
1839 1         5 $block = $self->setblk('std', [$block]);
1840             }
1841             }
1842 10 50       37 if (scalar @$expr > 1) {
1843 0         0 $self->{warn}->('parse', "while: bad cond %s", join(' ', @$expr));
1844 0         0 my $badcond = $self->setblk('expr', $expr);
1845 0         0 $expr = [$badcond];
1846             }
1847 10         36 return $self->setstmt(['while', $expr->[0], $block]);
1848             } elsif ((scalar @$tok > 3) && (lc($tok->[0]) eq 'do') && ($tok->[1] eq '{')) {
1849 7         18 shift @$tok;
1850 7         18 my $block;
1851             my $expr;
1852              
1853 7         18 $block = $self->read_statement($tok);
1854 7 50       25 if (!is_block($block)) {
1855 0 0 0     0 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1856 0         0 shift @$tok;
1857             }
1858             # always put '{ .. }' braces around do-while block
1859 0         0 $block = $self->setblk('std', [$block]);
1860             }
1861 7 50 33     59 if ((scalar @$tok > 3) && (lc($tok->[0]) eq 'while') && ($tok->[1] eq '(')) {
      33        
1862 7         16 shift @$tok;
1863 7         12 shift @$tok;
1864 7         20 $expr = $self->read_block($tok, ')', ',');
1865              
1866 7 50       55 if (scalar @$expr > 1) {
1867 0         0 $self->{warn}->('parse', "do-while: bad cond %s", join(' ', @$expr));
1868 0         0 my $badcond = $self->setblk('expr', $expr);
1869 0         0 $expr = [$badcond];
1870             }
1871             } else {
1872 0         0 $self->{warn}->('parse', "do-while: miss while");
1873 0         0 my $badcond = $self->setblk('expr', undef);
1874 0         0 $expr = [$badcond];
1875             }
1876 7         38 return $self->setstmt(['do', $expr->[0], $block]);
1877             } elsif ((scalar @$tok > 3) && (lc($tok->[0]) eq 'foreach') && ($tok->[1] eq '(')) {
1878 18         40 shift @$tok;
1879 18         32 shift @$tok;
1880 18         62 my $expr = $self->read_block($tok, ')', ',');
1881 18         44 my $key;
1882             my $value;
1883              
1884 18 100 66     146 if ((scalar @$expr == 3) && (lc($expr->[1]) eq 'as')) {
    50 33        
      33        
1885 6         15 $value = $expr->[2];
1886             } elsif ((scalar @$expr == 5) && (lc($expr->[1]) eq 'as') && ($expr->[3] eq '=>')) {
1887 12         24 $key = $expr->[2];
1888 12         17 $value = $expr->[4];
1889             } else {
1890 0         0 $self->{warn}->('parse', "foreach: bad expr %s", join(' ', @$expr));
1891 0         0 my $badcond = $self->setblk('expr', $expr);
1892 0         0 $expr = [$badcond];
1893             }
1894 18         33 my $block;
1895 18 50 33     75 if ((scalar @$tok > 0) && ($tok->[0] eq ':')) {
1896             # allow alternative block syntax
1897             # http://php.net/manual/en/control-structures.alternative-syntax.php
1898             #
1899 0         0 shift @$tok;
1900 0         0 $block = $self->read_code_block($tok, 'endforeach', ';');
1901 0         0 $block = $self->setblk('std', $block);
1902             } else {
1903 18         42 $block = $self->read_statement($tok);
1904 18 100       60 if (!is_block($block)) {
1905 1 50 33     12 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1906 1         3 shift @$tok;
1907             }
1908             # always put '{ .. }' braces around if/else
1909 1         6 $block = $self->setblk('std', [$block]);
1910             }
1911             }
1912 18         106 return $self->setstmt(['foreach', $expr->[0], $key, $value, $block]);
1913             } elsif ((scalar @$tok > 2) && ($tok->[0] =~ /^array$/i) && ($tok->[1] eq '(')) {
1914 133         309 shift @$tok;
1915 133         252 shift @$tok;
1916              
1917 133         395 my $arr = $self->newarr();
1918 133         507 $self->read_array($tok, ')', $arr);
1919              
1920             # execute expr & might continue with operation -> 'array(...)[idx]'?
1921             #
1922 133         342 unshift(@$tok, $arr->{name});
1923 133         315 return $self->read_statement($tok, $last_op);
1924             } elsif ((scalar @$tok > 4) && ((lc($tok->[0]) eq 'function') || (($tok->[0] =~ /^#pfx\d+$/) && (lc($tok->[1]) eq 'function')))) {
1925 228         651 my $pfx = shift @$tok;
1926 228         476 my $p = {};
1927              
1928 228 100       683 if ($pfx =~ /^#pfx\d+$/) {
1929 19         68 $p = $self->{strmap}->{$pfx};
1930 19         33 shift @$tok;
1931             }
1932 228         355 my $cmd;
1933              
1934             # also allow anonymous funcs: http://php.net/manual/en/functions.anonymous.php
1935             #
1936 228 100       580 if ($tok->[0] ne '(') {
1937 212         433 my $sym = shift @$tok;
1938 212         771 $cmd = $self->read_statement([$sym], undef);
1939 212 100       619 if (is_strval($cmd)) {
1940 211         498 $cmd = $self->{strmap}{$cmd};
1941             }
1942             }
1943 228         477 my $arglist = [];
1944 228 50 33     907 if ((scalar @$tok > 0) && ($tok->[0] eq '(')) {
1945 228         363 shift @$tok;
1946 228         655 $arglist = $self->read_block($tok, ')', ',');
1947             } else {
1948 0         0 $self->{warn}->('parse', "expected function arglist ()");
1949             }
1950 228         517 my $block = [];
1951 228 50 33     828 if ((scalar @$tok > 0) && ($tok->[0] eq '{')) {
1952 228         338 shift @$tok;
1953 228         631 $block = $self->read_code_block($tok, '}', ';');
1954             } else {
1955 0         0 $self->{warn}->('parse', "expected function block {}");
1956             }
1957 228         660 $block = $self->setblk('std', $block);
1958              
1959             # function are registered later via registerfun
1960             #
1961 228         635 my $k = $self->setfun($cmd, $arglist, $block, $p);
1962              
1963 228 100       509 unless (defined $cmd) {
1964             # anonymous functions might be called directly -> 'function () { return 1; }()'
1965             #
1966 16         39 unshift(@$tok, $k);
1967 16         37 $k = $self->read_statement($tok, $last_op);
1968             }
1969 228         530 return $k;
1970             } elsif ((scalar @$tok > 3) && ((lc($tok->[0]) eq 'class') || (($tok->[0] =~ /^#pfx\d+$/) && (lc($tok->[1]) eq 'class')))) {
1971 56         182 my $pfx = shift @$tok;
1972 56         124 my $p = {};
1973              
1974 56 50       160 if ($pfx =~ /^#pfx\d+$/) {
1975 0         0 $p = $self->{strmap}->{$pfx};
1976 0         0 shift @$tok;
1977             }
1978 56         96 my $name = shift @$tok;
1979              
1980             # http://php.net/manual/en/language.oop5.basic.php
1981             #
1982 56 50       154 if ($tok->[0] eq 'extends') {
1983 0         0 shift @$tok;
1984 0         0 $p->{parent} = shift @$tok;
1985             }
1986 56         102 my $block = [];
1987 56 50 33     274 if ((scalar @$tok > 0) && ($tok->[0] eq '{')) {
1988 56         90 shift @$tok;
1989 56         183 $block = $self->read_block($tok, '}', ';');
1990             }
1991 56         151 $block = $self->setblk('std', $block);
1992 56         180 return $self->setclass($name, $block, $p);
1993             } elsif ((scalar @$tok > 3) && (lc($tok->[0]) eq 'trait')) {
1994 1         3 shift @$tok;
1995 1         3 my $name = shift @$tok;
1996              
1997             # https://www.php.net/manual/en/language.oop5.traits.php
1998             #
1999 1         2 my $block = [];
2000 1 50 33     10 if ((scalar @$tok > 0) && ($tok->[0] eq '{')) {
2001 1         4 shift @$tok;
2002 1         6 $block = $self->read_block($tok, '}', ';');
2003             }
2004 1         3 $block = $self->setblk('std', $block);
2005 1         5 return $self->settrait($name, $block);
2006             } elsif ((scalar @$tok > 1) && ($tok->[0] =~ /^#pfx\d+$/)) {
2007 36         121 my $sym = shift @$tok;
2008              
2009             # TODO: support const and other visibility modifiers
2010             # https://www.php.net/manual/en/language.oop5.visibility.php
2011             #
2012 36 50       490 if (exists $self->{strmap}->{$sym}) {
2013 36         101 my $pfx = $self->{strmap}->{$sym};
2014 36 100       103 if (exists $pfx->{static}) {
2015 11         23 my @args = ();
2016 11         17 while (1) {
2017 11         31 my $arg = $self->read_statement($tok, undef);
2018              
2019 11         31 push(@args, $arg);
2020 11 50 33     60 unless ((scalar @$tok > 0) && ($tok->[0] eq ',')) {
2021 11         22 last;
2022             }
2023 0         0 shift @$tok;
2024             }
2025 11         39 return $self->setstmt(['static', \@args, $pfx]);
2026             }
2027 25 100       70 if (exists $pfx->{const}) {
2028 9         41 my @args = ();
2029 9         14 while (1) {
2030 9         42 my $arg = $self->read_statement($tok, undef);
2031              
2032 9         48 push(@args, $arg);
2033 9 50 33     58 unless ((scalar @$tok > 0) && ($tok->[0] eq ',')) {
2034 9         29 last;
2035             }
2036 0         0 shift @$tok;
2037             }
2038 9         30 return $self->setstmt(['const', \@args, $pfx]);
2039             }
2040             }
2041 16         47 return $sym;
2042             } elsif ((scalar @$tok > 2) && ($tok->[0] !~ /^([\~\!\+\-\\]|new)$/i) && ($tok->[1] eq '(')) {
2043             # function call
2044             # (function name might be variable)
2045             #
2046 721         2070 my $sym = shift @$tok;
2047 721         1503 my $cmd = $sym;
2048              
2049 721 100       1641 unless (is_symbol($sym)) {
2050 78         323 $cmd = $self->read_statement([$sym], undef);
2051             }
2052 721 100 100     1994 if (defined $last_op && ($last_op eq '$')) {
2053             # handle case: $$var(x) is ${$var}(x)
2054 1         4 return $cmd;
2055             }
2056 720 100 100     1925 if (defined $last_op && ($last_op eq '::')) {
2057             # handle case: (class::member)(x)
2058 23         90 return $cmd;
2059             }
2060 697 100 100     1629 if (defined $last_op && ($last_op eq '->')) {
2061             # handle case: ($obj->method)(x)
2062 26         92 return $cmd;
2063             }
2064 671 100 100     1612 if (defined $last_op && ($last_op eq '\\')) {
2065             # handle case: (ns \\ cmd)(x)
2066 2         7 return $cmd;
2067             }
2068 669 100       1378 if (is_strict_variable($sym)) {
2069 16         47 $cmd = $sym; # don't insert copy anonymous function here
2070             }
2071 669         1120 shift @$tok;
2072              
2073 669 50 33     1734 if (is_strval($cmd) && !is_null($cmd)) {
2074 0         0 $cmd = $self->{strmap}{$cmd};
2075             }
2076 669 50       1576 if ($cmd =~ /^\@(.*)$/) {
2077             # remove optional '@' error suppress operator
2078 0         0 $cmd = $1;
2079             }
2080             # get arglist so that ref-params are not resolved to value
2081             # (need function definition to decide how to resolve variables)
2082             #
2083 669         1961 my $arglist = $self->read_block($tok, ')', ',');
2084 669         1230 my $k;
2085 669 100       1594 if ($cmd eq 'unset') {
    100          
2086 5         17 $k = $self->setstmt(['unset', $arglist]);
2087             } elsif ($cmd eq 'list') {
2088 2         9 my $arr = $self->newarr();
2089 2         19 foreach my $val (@$arglist) {
2090 4         16 $arr->set(undef, $val);
2091             }
2092 2         24 $k = $arr->{name};
2093             } else {
2094 662         1503 $k = $self->setcall($cmd, $arglist);
2095             }
2096 669         1454 unshift(@$tok, $k);
2097 669         1471 return $self->read_statement($tok, $last_op);
2098             } elsif ((scalar @$tok > 1) && ($tok->[0] eq '$') && (is_symbol($tok->[1]))) {
2099             # variable reference via $ val => $val
2100             #
2101 0         0 shift @$tok;
2102 0         0 my $sym = shift @$tok;
2103              
2104 0         0 my $str = $self->get_strval_or_str($sym);
2105 0         0 my $var = '$' . $str;
2106 0         0 unshift(@$tok, $var);
2107 0         0 return $self->read_statement($tok, $last_op);
2108             } elsif ((scalar @$tok > 1) && ($tok->[0] eq '$') && ($tok->[1] =~ /^\$/)) {
2109             # variable variable via $ $var => $
2110             # Attention:
2111             # - $$var[x] is ${$var[x]}
2112             # - $$var(x) is ${$var}(x)
2113             #
2114 6         13 shift @$tok;
2115 6         15 my $res = $self->read_statement($tok, '$');
2116 6         19 my $k = $self->setexpr('$', undef, $res);
2117              
2118 6         16 unshift(@$tok, $k);
2119 6         17 return $self->read_statement($tok, $last_op);
2120             #} elsif ((scalar @$tok > 1) && ($tok->[0] eq '#') && ($tok->[1] =~ /^(str|num)\d+$/)) {
2121             # # for re-eval: literal reference via # str/num => #str
2122             # #
2123             # shift @$tok;
2124             # my $sym = shift @$tok;
2125             #
2126             # my $var = '#' . $sym;
2127             # unshift(@$tok, $var);
2128             # return $self->read_statement($tok, $last_op);
2129             } elsif ((scalar @$tok > 3) && ($tok->[0] eq '$') && ($tok->[1] eq '{')) {
2130             # variable variable via $ { string } => $string
2131             # variable variable via $ { func(xxx) } is also allowed
2132             #
2133 78         145 shift @$tok;
2134 78         176 shift @$tok;
2135              
2136 78         254 my $arglist = $self->read_block($tok, '}', undef);
2137 78         143 my $k;
2138 78 50       185 if (scalar @$arglist == 1) {
2139 78         145 my $res = $arglist->[0];
2140 78 100       160 if (is_strval($res)) {
2141 21         44 my $str = $self->{strmap}{$res};
2142 21 100       59 if (is_symbol($str)) {
2143 16         66 my $var = '$' . $str;
2144 16         40 unshift(@$tok, $var);
2145 16         34 return $self->read_statement($tok, $last_op);
2146             }
2147             }
2148 62         169 $k = $self->setexpr('$', undef, $res);
2149             } else {
2150 0         0 $self->{warn}->('parse', "bad arglist \$ { %s }", join(' ', @$arglist));
2151 0         0 my $res = $self->setblk('std', $arglist);
2152 0         0 $k = $self->setexpr('$', undef, $res);
2153             }
2154 62         229 unshift(@$tok, $k);
2155 62         183 return $self->read_statement($tok, $last_op);
2156             } elsif ((scalar @$tok > 3) && (is_strict_variable($tok->[0]) || ($tok->[0] =~ /^#/)) && (($tok->[1] eq '[') || ($tok->[1] eq '{'))) {
2157             # array reference via $var['string']
2158             # or: variable $GLOBALS['string'] -> $string
2159             # or: $strvar[idx] -> char
2160             #
2161             # or: $var[string] -> string
2162             # (old: php autoconverts bare string into string const which
2163             # contains the string - not always the same as the 'str' index
2164             # see: http://php.net/manual/en/language.types.array.php
2165             # see: define('const', 'val')
2166             # )
2167             #
2168             # http://php.net/manual/de/language.types.string.php
2169             # - Strings may also be accessed using braces, as in $str{42},
2170             # for the same purpose. However, this syntax is deprecated as
2171             # of php7.4 and disabled in php8. Use square brackets instead.
2172             #
2173 420         989 my $sym = shift @$tok;
2174              
2175 420 100 100     1358 if (defined $last_op && ($last_op eq '::')) {
2176             # handle case: (class::$var)(x)
2177 4         14 return $sym;
2178             }
2179 416 50 66     936 if (defined $last_op && ($last_op eq '->')) {
2180             # handle case: ($obj->var)(x)
2181 0         0 return $sym;
2182             }
2183 416         757 my $bracket = shift @$tok;
2184 416         629 my $arglist;
2185              
2186 416 100       753 if ($bracket eq '[') {
2187 414         1122 $arglist = $self->read_index_block($tok, ']', undef);
2188             } else {
2189 2         10 $arglist = $self->read_index_block($tok, '}', undef);
2190             }
2191 416 50       1115 if (scalar @$arglist > 1) {
2192 0         0 $self->{warn}->('parse', "bad arglist %s [ %s ]", $sym, join(' ', @$arglist));
2193 0         0 unshift(@$tok, ('[', @$arglist, ']'));
2194 0         0 return $sym;
2195             }
2196 416 100 100     1519 if ((scalar @$arglist == 1) && is_strval($arglist->[0])) {
    50 66        
2197 320         612 my $str = $arglist->[0];
2198 320         496 if (0) {
2199             if ($sym =~ /^\$GLOBALS$/) {
2200             my $val = $self->get_strval($str);
2201             my $var = '$' . $val;
2202             unshift(@$tok, $var);
2203             my $res = $self->read_statement($tok, $last_op);
2204             return $res;
2205             }
2206             }
2207             } elsif ((scalar @$arglist == 1) && (is_symbol($arglist->[0]))) {
2208             # bare string
2209 0         0 my $str = $arglist->[0];
2210 0         0 my $k = $self->setstr($str);
2211 0         0 unshift(@$tok, ($sym, '[', $k, ']'));
2212 0         0 my $res = $self->read_statement($tok, $last_op);
2213 0         0 return $res;
2214             }
2215 416         1205 my $k = $self->setelem($sym, $arglist->[0]);
2216              
2217             # execute expr & might continue with lower prio operation
2218             #
2219 416         942 unshift(@$tok, $k);
2220 416         935 return $self->read_statement($tok, $last_op);
2221             } elsif ((scalar @$tok > 2) && ($tok->[0] =~ /^(\+|\-)$/) && ($tok->[1] eq $tok->[0])) {
2222             # ++$var
2223             # --$var
2224             #
2225 12         35 my $op = shift @$tok;
2226 12         23 shift @$tok;
2227              
2228 12         66 my $var = $self->read_statement($tok, "$op$op");
2229 12         99 my $k = $self->setexpr($op.$op, undef, $var);
2230              
2231             # execute expr & might continue with lower prio operation
2232             #
2233 12         40 unshift(@$tok, $k);
2234 12         37 return $self->read_statement($tok, $last_op);
2235             } elsif ((scalar @$tok > 3) && ($tok->[0] eq '.') && ($tok->[1] eq '.') && ($tok->[2] eq '.')) {
2236             # ...$var
2237             #
2238 0         0 shift @$tok;
2239 0         0 shift @$tok;
2240 0         0 shift @$tok;
2241              
2242 0         0 my $var = $self->read_statement($tok, '...');
2243 0         0 my $k = $self->setexpr('...', undef, $var);
2244              
2245             # execute expr & might continue with lower prio operation
2246             #
2247 0         0 unshift(@$tok, $k);
2248 0         0 return $self->read_statement($tok, $last_op);
2249             } elsif ((scalar @$tok > 1) && ($tok->[0] =~ /^\\$/)) {
2250             # \val
2251             #
2252 7         17 my $op = shift @$tok;
2253              
2254 7         23 my $val = $self->read_statement($tok, $op);
2255 7         18 my $k = $self->setns(undef, $val); # toplevel namespace
2256              
2257             # execute expr & might continue with lower prio operation
2258             #
2259 7         16 unshift(@$tok, $k);
2260 7         18 return $self->read_statement($tok, $last_op);
2261             } elsif ((scalar @$tok > 1) && ($tok->[0] =~ /^([\~\!\+\-]|new|exception)$/i)) {
2262             # ~val
2263             # !val
2264             # +val
2265             # -val
2266             # new val
2267             #
2268 66         178 my $op = shift @$tok;
2269 66         155 my $val;
2270              
2271 66 100 100     361 if (($op eq '+') || ($op eq '-')) {
    100          
2272 7         24 $val = $self->read_statement($tok, '+-');
2273             } elsif (lc($op) eq 'new') {
2274             # add optional parenthesis for 'new a' if necessary
2275             # -> with parenthesis $val is parsed as #call
2276             #
2277 39         109 $val = $self->read_statement($tok, $op);
2278 39 100       167 if ($val =~ /^#(str|const)/) {
2279 7         28 $val = $self->setcall($self->{strmap}->{$val}, []);
2280             }
2281             } else {
2282 20         68 $val = $self->read_statement($tok, $op);
2283             }
2284 66         222 my $k = $self->setexpr($op, undef, $val);
2285              
2286             # execute expr & might continue with lower prio operation
2287             #
2288 66         172 unshift(@$tok, $k);
2289 66         216 return $self->read_statement($tok, $last_op);
2290             } elsif ((scalar @$tok > 2) && ($tok->[1] =~ /^([\.\+\-\*\/\^\&\|\%<>\?\:]|=|\!|==|\!=|<>|<=|>=|<<|>>|===|\!==|<=>|\?\:|\?\?|\&\&|\|\||\+\+|\-\-|and|or|xor|instanceof|\->|::|\\)$/i)) {
2291             # val1 . val2
2292             # val1 + val2
2293             # val1 - val2
2294             # val1 ^ val2
2295             # ...
2296             #
2297 1329 100 100     3836 if (($tok->[1] =~ /^[<>\&\|\*\?]$/) && ($tok->[2] eq $tok->[1])) {
2298             # val1 << val2 (also: <<=)
2299             # val1 >> val2 (also: >>=)
2300             # val1 ** val2 (also: **=)
2301             # val1 ?? val2 (also: ??=)
2302             # val1 || val2
2303             # val1 && val2
2304             #
2305 16         47 my $sym = shift @$tok;
2306 16         43 my $op = shift @$tok;
2307 16         27 shift @$tok;
2308 16         89 unshift(@$tok, ($sym, $op.$op));
2309             # fall through
2310             }
2311 1329 100 100     3937 if (($tok->[2] eq '=') && ($tok->[1] =~ /^([\.\+\-\*\/\^\&\|\%]|<<|>>|\*\*|\?\?)$/)) {
2312             # num += ...
2313             # num .= ...
2314             #
2315 29         78 my $sym = shift @$tok;
2316 29         67 my $op = shift @$tok;
2317 29         54 shift @$tok;
2318              
2319             # keep in_block flag for '='
2320 29         97 my $op2 = $self->read_statement($tok, undef);
2321              
2322             # keep precedence of $op against following expr
2323 29         99 my $k2 = $self->setexpr($op, $sym, $op2);
2324 29         97 unshift(@$tok, ($sym, '=', $k2));
2325 29         75 return $self->read_statement($tok, $last_op);
2326             }
2327 1300 100 100     4115 if (($tok->[1] eq '=') && ($tok->[2] eq '>')) {
2328             # $expr1 =>
2329             #
2330 45         151 my $sym = shift @$tok;
2331 45         87 shift @$tok;
2332 45         67 shift @$tok;
2333 45         125 unshift(@$tok, ($sym, '=>'));
2334              
2335 45         128 return $self->read_statement($tok, $last_op);
2336             }
2337 1255 100 100     19806 if (($tok->[1] =~ /^(\+|\-)$/) && ($tok->[2] eq $tok->[1]) && (is_strict_variable($tok->[0]) || ($tok->[0] =~ /^#(scope|inst)\d+$/))) {
    100 66        
    100 100        
    100 100        
    50 100        
    50 100        
    100 100        
    100 100        
    100 100        
      100        
      66        
      66        
      100        
      66        
      100        
2338             # $var++
2339             # $var--
2340             #
2341 35         130 my $sym = shift @$tok;
2342 35         94 my $op = shift @$tok;
2343 35         61 shift @$tok;
2344 35         121 unshift(@$tok, ($sym, $op.$op));
2345             # fall through
2346             } elsif ((scalar @$tok > 3) && ($tok->[1] =~ /^[=\!]$/) && ($tok->[2] eq '=') && ($tok->[3] eq '=')) {
2347             # val1 === val2
2348             # val1 !== val2
2349             #
2350 5         16 my $sym = shift @$tok;
2351 5         13 my $op = shift @$tok;
2352 5         13 shift @$tok;
2353 5         9 shift @$tok;
2354 5         19 unshift(@$tok, ($sym, $op.'=='));
2355             # fall through
2356             } elsif ((scalar @$tok > 3) && ($tok->[1] eq '<') && ($tok->[2] eq '=') && ($tok->[3] eq '>')) {
2357             # val1 <=> val2
2358             #
2359 3         7 my $sym = shift @$tok;
2360 3         5 my $op = shift @$tok;
2361 3         6 shift @$tok;
2362 3         5 shift @$tok;
2363 3         10 unshift(@$tok, ($sym, '<=>'));
2364             # fall through
2365             } elsif (($tok->[1] =~ /^[=\!<>]$/) && ($tok->[2] eq '=')) {
2366             # val1 == val2
2367             # val1 != val2
2368             # val1 <= val2
2369             # val1 >= val2
2370             #
2371 20         79 my $sym = shift @$tok;
2372 20         54 my $op = shift @$tok;
2373 20         45 shift @$tok;
2374 20         69 unshift(@$tok, ($sym, $op.'='));
2375             # fall through
2376             } elsif (($tok->[1] eq '<') && ($tok->[2] eq '>')) {
2377             # val1 <> val2 (diamond operator work as !=)
2378             #
2379 0         0 my $sym = shift @$tok;
2380 0         0 my $op = shift @$tok;
2381 0         0 shift @$tok;
2382 0         0 unshift(@$tok, ($sym, '!='));
2383             # fall through
2384             } elsif (($tok->[1] =~ /^[=\!]$/) && ($tok->[2] eq '==')) { # TODO: does this occur?
2385             # val1 === val2
2386             # val1 !== val2
2387             #
2388 0         0 my $sym = shift @$tok;
2389 0         0 my $op = shift @$tok;
2390 0         0 shift @$tok;
2391 0         0 unshift(@$tok, ($sym, $op.'=='));
2392             # fall through
2393             } elsif (($tok->[1] eq '-') && ($tok->[2] eq '>')) {
2394             # $obj -> member
2395             #
2396 52         120 my $sym = shift @$tok;
2397 52         100 shift @$tok;
2398 52         92 shift @$tok;
2399 52         151 unshift(@$tok, ($sym, '->')); # for operator precedence
2400             # fall through
2401             } elsif (($tok->[1] eq ':') && ($tok->[2] eq ':')) {
2402             # class :: elem
2403             #
2404 41         114 my $sym = shift @$tok;
2405 41         94 shift @$tok;
2406 41         63 shift @$tok;
2407 41         130 unshift(@$tok, ($sym, '::'));
2408             # fall through
2409             } elsif (($tok->[1] eq '?') && ($tok->[2] eq ':')) {
2410             # ternary: $expr1 ?: $expr3
2411             #
2412 3         12 my $sym = shift @$tok;
2413 3         9 shift @$tok;
2414 3         5 shift @$tok;
2415 3         10 unshift(@$tok, ($sym, '?:'));
2416             # fall through
2417             }
2418             # remaining binary ops
2419             # variable assignment
2420             #
2421 1255         2718 my $sym = shift @$tok;
2422 1255         2521 my $op = shift @$tok;
2423 1255         1741 my $op1;
2424 1255         2063 $op = lc($op);
2425              
2426 1255 100 100     5047 if (($op eq '->') || ($op eq '::') || ($op eq '\\')) {
      100        
2427 103         172 $op1 = $sym; # don't evaluate lefthand side variable
2428             } else {
2429 1152         3983 $op1 = $self->read_statement([$sym], undef);
2430             }
2431 1255 100       2928 if (defined $last_op) {
2432 175 50       632 unless (exists $op_prio{$op}) {
2433 0         0 $self->{warn}->('parse', "missing op_prio(%s) [last %s]", $op, $last_op);
2434             }
2435 175 50       441 unless (exists $op_prio{$last_op}) {
2436 0         0 $self->{warn}->('parse', "op_prio(%s) [op %s]", $last_op, $op);
2437             }
2438 175 50       442 $self->{debug}->('parse', "SYM $sym OP %s LAST %s", $op, $last_op) if $self->{debug};
2439 175 100       492 if ($op_prio{$op} >= $op_prio{$last_op}) {
2440             # - for right associative ops like '=' continue to parse left-hand side.
2441             # - but for identical ops like '$a=$b=1' parse right-hand side first.
2442             # - there is a special case for unary op and '=' ('!$x=2' is same as '!($x=2)')
2443             #
2444 66 100 100     329 if (($op ne $last_op) || !exists $op_right{$op}) {
2445 62 100 100     266 unless (($op eq '=') && (exists $op_unary{$last_op} || !exists $op_right{$last_op})) {
      100        
2446 58 50       145 $self->{log}->('parse', "curr %s %s has higher/equal prio than last %s", $op1, $op, $last_op) if $self->{log};
2447 58         131 unshift(@$tok, $op);
2448 58         147 return $op1;
2449             }
2450             }
2451             }
2452             }
2453 1197         1741 my $k;
2454 1197 100 100     5663 if ($op eq '?') {
    100          
    100          
    100          
    100          
2455             # ternary: $op1 ? $expr2 : $expr3
2456             #
2457 15         41 my $expr2 = $self->read_statement($tok, $op);
2458 15 50 33     81 if ((scalar @$tok > 0) && $tok->[0] eq ':') {
2459 15         28 shift @$tok;
2460             } else {
2461 0         0 $self->{warn}->('parse', "ternary: missing : [%s ? %s]", $sym, $expr2);
2462             }
2463 15         39 my $expr3 = $self->read_statement($tok, ':');
2464 15         44 my $op2 = $self->setexpr(':', $expr2, $expr3);
2465 15         37 $k = $self->setexpr('?', $op1, $op2);
2466             } elsif ($op eq '->') {
2467             # $obj -> member
2468             #
2469 52         162 my $op2 = $self->read_statement($tok, $op);
2470              
2471 52 100       129 if (is_block($op2)) {
2472             # $obj -> {'member'}
2473             #
2474 2         8 my ($type, $a) = @{$self->{strmap}->{$op2}};
  2         45  
2475 2 50       8 if (scalar @$a == 1) {
2476 2         7 $op2 = $a->[0];
2477             }
2478             }
2479 52         143 $op2 = $self->get_strval_or_str($op2);
2480              
2481 52         167 $k = $self->setobj($op1, $op2);
2482             } elsif ($op eq '::') {
2483             # class :: member
2484             #
2485 41         71 my $class = $sym;
2486 41 100       127 unless (is_symbol($sym)) {
2487 1         8 $class = $self->read_statement([$sym], undef);
2488 1         16 $class = $self->get_strval_or_str($class);
2489             }
2490 41         139 my $elem = $self->read_statement($tok, $op);
2491 41         140 $elem = $self->get_strval_or_str($elem);
2492              
2493 41         120 $k = $self->setscope($class, $elem);
2494             } elsif ($op eq '\\') {
2495             # ns/elem
2496             #
2497 5         28 my $op2 = $self->read_statement($tok, $op);
2498 5         13 $op1 = $self->get_strval_or_str($op1);
2499              
2500 5         18 $k = $self->setns($op1, $op2);
2501             } elsif (($op eq '++') || ($op eq '--')) {
2502             # $var++
2503             # $var--
2504             #
2505 35         226 $k = $self->setexpr($op, $op1, undef);
2506             } else {
2507 1049         1482 if (1) {
2508             # optimize long concat chains to avoid memory exhaustion
2509             # (sometimes hundreds of strings get concatted)
2510             #
2511 1049 50 100     2333 if (($op eq '.') && is_strval($op1) && (scalar @$tok > 2) && is_strval($tok->[0]) && ($tok->[1] eq '.')) {
      100        
      66        
      33        
2512 0         0 my @list;
2513 0         0 push(@list, $op1);
2514 0   0     0 while ((scalar @$tok > 2) && is_strval($tok->[0]) && ($tok->[1] eq '.')) {
      0        
2515 0         0 my $s = shift @$tok;
2516 0         0 shift @$tok;
2517 0         0 push(@list, $s);
2518             }
2519 0         0 $self->{warn}->('parse', "optimize concat chain here: %s", join(' ', @list));
2520 0         0 my $line = join('', map { $self->{strmap}->{$_} } @list);
  0         0  
2521 0         0 $op1 = $self->setstr($line);
2522             }
2523             }
2524 1049         2254 my $op2 = $self->read_statement($tok, $op);
2525 1049         2542 $k = $self->setexpr($op, $op1, $op2);
2526             }
2527             # execute expr & might continue with lower prio operation
2528             #
2529 1197         2496 unshift(@$tok, $k);
2530 1197         2903 return $self->read_statement($tok, $last_op);
2531             }
2532              
2533 13 50       63 if (scalar @$tok > 0) {
2534 13         37 my $sym = shift @$tok;
2535              
2536             # some symbols are pushed back into token-stream and might be passed through here
2537             #
2538 13 50       42 $self->{log}->('parse', "skip symbol %s", $sym) if $self->{log};
2539 13         45 return $sym;
2540             }
2541 0         0 return;
2542             }
2543              
2544             # last_op & in_block are optional params
2545             #
2546             sub read_statement {
2547 13401     13401 0 22311 my ($self, $tok, $last_op) = @_;
2548 13401         17400 my $level = 0;
2549              
2550 13401 100       25490 if (exists $self->{strmap}->{_LEVEL}) {
2551 12681         18869 $self->{strmap}->{_LEVEL} += 1;
2552             } else {
2553 720         1922 $self->{strmap}->{_LEVEL} = 1;
2554             }
2555 13401         20159 $level = $self->{strmap}->{_LEVEL};
2556              
2557             # show next 10 tokens to process
2558             #
2559 13401 100       24263 my $tl = (scalar @$tok > 10) ? 10 : scalar @$tok;
2560             #$self->{log}->('PARSE', "[%d:%d] %s %s", $level, scalar @$tok, join(' ', @$tok[0..$tl-1]), (scalar @$tok > 10) ? '...' : '') if $self->{log};
2561 13401 100       29775 my $tab = ($level <= 1) ? '' : ('....' x ($level-2)) . '... ';
2562 13401 0       25114 $self->{log}->('PARSE', "$tab%s%s", join(' ', @$tok[0..$tl-1]), (scalar @$tok > 10) ? ' ..['.(scalar @$tok - 10).']' : '') if $self->{log};
    50          
2563              
2564 13401         26724 my $ret = $self->_read_statement($tok, $last_op);
2565 13401         21437 $self->{strmap}->{_LEVEL} -= 1;
2566 13401         26350 return $ret;
2567             }
2568              
2569             sub filter_bad_brace {
2570 3544     3544 0 6032 my ($stmt) = @_;
2571              
2572 3544 50       8311 if ($stmt =~ /^[\)\]\}]$/) {
2573 0         0 $stmt = "";
2574             }
2575 3544         6460 return $stmt;
2576             }
2577              
2578             sub read_index_block {
2579 416     416 0 844 my ($self, $tok, $close, $separator) = @_;
2580 416         655 my @out = ();
2581              
2582 416 50       968 $self->{debug}->('parse', "B+$close") if $self->{debug};
2583              
2584 416         874 while (scalar @$tok > 0) {
2585             # always resolve assignment in index to value
2586             #
2587 816         1777 my $stmt = $self->read_statement($tok, undef);
2588              
2589 816 50       1677 $self->{debug}->('parse', "B-$close $stmt") if $self->{debug};
2590              
2591 816 100 33     1787 if ($stmt eq $close) {
    50          
2592             # block end
2593             #
2594 416         1116 return \@out;
2595             } elsif (defined $separator && ($stmt eq $separator)) {
2596             #push(@out, $separator);
2597             } else {
2598 400         834 $stmt = filter_bad_brace($stmt);
2599 400         1231 push(@out, $stmt);
2600             }
2601             }
2602 0         0 return \@out;
2603             }
2604              
2605             sub read_block {
2606 1261     1261 0 2613 my ($self, $tok, $close, $separator) = @_;
2607 1261         1808 my @out = ();
2608 1261         1796 my $last;
2609              
2610 1261 50       2652 $self->{debug}->('parse', "B+$close") if $self->{debug};
2611              
2612 1261         2581 while (scalar @$tok > 0) {
2613 2526         5148 my $stmt = $self->read_statement($tok, undef);
2614              
2615 2526 50       4877 $self->{debug}->('parse', "B-$close $stmt") if $self->{debug};
2616              
2617 2526 100 100     6056 if ($stmt eq $close) {
    100          
2618             # block end
2619             #
2620 1261         3201 return \@out;
2621             } elsif (defined $separator && ($stmt eq $separator)) {
2622 147 50 33     612 if (defined $last && ($last eq $separator)) {
2623 0         0 push(@out, undef); # allow empty field
2624             }
2625             #push(@out, $separator);
2626             } else {
2627 1118         2121 $stmt = filter_bad_brace($stmt);
2628 1118         2169 push(@out, $stmt);
2629             }
2630 1265         2752 $last = $stmt;
2631             }
2632 0         0 return \@out;
2633             }
2634              
2635             sub read_code_block {
2636 1269     1269 0 2644 my ($self, $tok, $close, $separator) = @_;
2637 1269         1830 my @out = ();
2638              
2639 1269 50       2913 $self->{debug}->('parse', "B+$close") if $self->{debug};
2640              
2641 1269         2550 while (scalar @$tok > 0) {
2642 3558         7364 my $stmt = $self->read_statement($tok, undef);
2643              
2644 3558 50       7543 $self->{debug}->('parse', "B-$close $stmt") if $self->{debug};
2645              
2646 3558 100 66     11698 if ($stmt eq $close) {
    100          
2647             # block end
2648             #
2649 476         1308 return \@out;
2650             } elsif (defined $separator && ($stmt eq $separator)) {
2651             #push(@out, $separator);
2652             } else {
2653 2026         3831 $stmt = filter_bad_brace($stmt);
2654 2026         5645 push(@out, $stmt);
2655             }
2656             }
2657 793         1811 return \@out;
2658             }
2659              
2660             sub tokens {
2661 1     1 0 394 my ($self) = @_;
2662 1         3 return $self->{tok};
2663             }
2664              
2665             sub read_code {
2666 785     785 1 2068 my ($self, $tok) = @_;
2667 785         1119 my $in;
2668 785         1152 my @out = ();
2669              
2670 785         1742 $in = unspace_list($tok);
2671              
2672 785         1941 my $stmts = $self->read_code_block($in, '?>', ';');
2673 785 100       1961 if (scalar @$stmts == 1) {
2674 331         1384 return $stmts->[0];
2675             }
2676 454         979 my $k = $self->setblk('flat', $stmts);
2677 454         1616 return $k;
2678             }
2679              
2680             sub map_stmt {
2681 3116     3116 0 5819 my ($self, $s, $cb, @params) = @_;
2682              
2683             #$self->{log}->('MAP', "$s") if $self->{log};
2684              
2685 3116         6131 my $k = $cb->($s, @params);
2686 3116 100       5475 if (defined $k) {
2687 286         629 return $k;
2688             }
2689 2830         4024 my $s0 = $s;
2690              
2691 2830 50       21993 if (!defined $s) {
    100          
    100          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
2692 0         0 $self->{warn}->('map', "undefined symbol");
2693             # keep
2694             } elsif ($s =~ /^#null$/) {
2695             # keep
2696             } elsif ($s =~ /^#num\d+$/) {
2697             # keep
2698             } elsif ($s =~ /^#const\d+$/) {
2699             # keep
2700             } elsif ($s =~ /^#str\d+$/) {
2701             # keep
2702             } elsif ($s =~ /^#arr\d+$/) {
2703 133         272 my $arr = $self->{strmap}{$s};
2704 133         442 my $keys = $arr->get_keys();
2705 133         210 my %newmap;
2706 133         211 my @newkeys = ();
2707 133         194 my $changed = 0;
2708              
2709 133         273 foreach my $k (@$keys) {
2710 236         545 my $val = $arr->val($k);
2711 236 50 33     531 if ((is_int_index($k) || is_strval($k)) && (!defined $val
      33        
      33        
2712             || (defined $val && is_strval($val)))) {
2713 236         432 push(@newkeys, $k);
2714 236         569 $newmap{$k} = $val;
2715             } else {
2716 0         0 my $k2 = $k;
2717 0 0       0 unless (is_int_index($k)) {
2718 0         0 $k2 = $self->map_stmt($k, $cb, @params);
2719             }
2720 0         0 push(@newkeys, $k2);
2721 0 0       0 if (defined $val) {
2722 0         0 my $v = $self->map_stmt($val, $cb, @params);
2723 0         0 $newmap{$k2} = $v;
2724             } else {
2725 0         0 $newmap{$k2} = undef;
2726             }
2727 0 0 0     0 if (($k ne $k2) || ($val ne $newmap{$k2})) {
2728 0         0 $changed = 1;
2729             }
2730             }
2731             }
2732 133 50       440 if ($changed) {
2733 0         0 $arr = $self->newarr();
2734 0         0 foreach my $k (@newkeys) {
2735 0         0 $arr->set($k, $newmap{$k});
2736             }
2737 0         0 $s = $arr->{name};
2738             }
2739             } elsif ($s =~ /^#fun\d+$/) {
2740 14         22 my ($f, $a, $b, $p) = @{$self->{strmap}->{$s}};
  14         38  
2741             # no context change here
2742             } elsif ($s =~ /^#call\d+$/) {
2743 87         124 my ($f, $a) = @{$self->{strmap}->{$s}};
  87         248  
2744 87         154 my @args = ();
2745 87         137 my $arg_changed = 0;
2746 87         131 my $name = $f;
2747              
2748 87 50       161 if ($f =~ /^#fun\d+$/) {
2749             # no context change here
2750             #$name = $self->map_stmt($f, $cb, @params);
2751             } else {
2752 87         189 $name = $self->map_stmt($f, $cb, @params);
2753             }
2754 87         218 foreach my $k (@$a) {
2755 65         120 my $v = $self->map_stmt($k, $cb, @params);
2756 65         128 push(@args, $v);
2757 65 50       152 if ($v ne $k) {
2758 0         0 $arg_changed = 1;
2759             }
2760             }
2761 87 50 33     353 if (($name ne $f) || $arg_changed) {
2762 0         0 $s = $self->setcall($name, \@args);
2763             }
2764             } elsif ($s =~ /^#elem\d+$/) {
2765 50         73 my ($v, $i) = @{$self->{strmap}->{$s}};
  50         145  
2766 50         209 my $vv = $self->map_stmt($v, $cb, @params);
2767 50         93 my $ii = $i;
2768              
2769 50 50       124 if (defined $i) {
2770 50         104 $ii = $self->map_stmt($i, $cb, @params);
2771             }
2772 50 50 33     273 if (($v ne $vv) || (defined $i && ($i ne $ii))) {
      33        
2773 0         0 $s = $self->setelem($vv, $ii);
2774             }
2775             } elsif ($s =~ /^#expr\d+$/) {
2776             # if v1 missing: prefix op
2777             # if v2 missing: postfix op
2778 282         560 my ($op, $v1, $v2) = @{$self->{strmap}->{$s}};
  282         775  
2779 282         490 my $vv1 = $v1;
2780 282         387 my $vv2 = $v2;
2781              
2782 282 100       562 if (defined $v1) {
2783 276         592 $vv1 = $self->map_stmt($v1, $cb, @params);
2784             }
2785 282 50       577 if (defined $v2) {
2786 282         569 $vv2 = $self->map_stmt($v2, $cb, @params);
2787             }
2788 282 100 100     2021 if ((defined $v1 && ($v1 ne $vv1)) || (defined $v2 && ($v2 ne $vv2))) {
      33        
      66        
2789 10         27 $s = $self->setexpr($op, $vv1, $vv2);
2790             }
2791             } elsif ($s =~ /^#pfx\d+$/) {
2792             # keep
2793             } elsif ($s =~ /^#obj\d+$/) {
2794 12         31 my ($o, $m) = @{$self->{strmap}->{$s}};
  12         33  
2795 12         20 my $oo = $o;
2796 12         22 my $mm = $m;
2797              
2798 12 50       32 unless ($o =~ /^#call\d+$/) {
2799             # not 'new'
2800 12         28 $oo = $self->map_stmt($o, $cb, @params);
2801             }
2802 12 50 33     44 unless (exists $self->{strmap}->{$m} && is_symbol($self->{strmap}->{$m})) {
2803             # not 'sym'
2804 12         30 $mm = $self->map_stmt($m, $cb, @params);
2805             }
2806 12 50 33     74 if (($o ne $oo) || ($m ne $mm)) {
2807 0         0 $s = $self->setobj($oo, $mm);
2808             }
2809             } elsif ($s =~ /^#scope\d+$/) {
2810 0         0 my ($c, $e) = @{$self->{strmap}->{$s}};
  0         0  
2811 0         0 my $cc = $c;
2812 0         0 my $ee = $e;
2813              
2814 0 0 0     0 unless (exists $self->{strmap}->{$c} && is_symbol($self->{strmap}->{$c})) {
2815             # not 'class'
2816 0         0 $cc = $self->map_stmt($c, $cb, @params);
2817             }
2818 0 0 0     0 unless (exists $self->{strmap}->{$e} && is_symbol($self->{strmap}->{$e})) {
2819             # not 'sym'
2820 0         0 $ee = $self->map_stmt($e, $cb, @params);
2821             }
2822 0 0 0     0 if (($c ne $cc) || ($e ne $ee)) {
2823 0         0 $s = $self->setscope($cc, $ee);
2824             }
2825             } elsif ($s =~ /^#ns\d+$/) {
2826 0         0 my ($n, $e) = @{$self->{strmap}->{$s}};
  0         0  
2827 0         0 my $nn = $n;
2828 0         0 my $ee = $self->map_stmt($e, $cb, @params);
2829              
2830 0 0       0 if (defined $n) {
2831             # non-sym should be error
2832 0 0 0     0 unless (exists $self->{strmap}->{$n} && is_symbol($self->{strmap}->{$n})) {
2833 0         0 $nn = $self->map_stmt($n, $cb, @params);
2834             }
2835             }
2836 0 0 0     0 if ((defined $n && ($n ne $nn)) || ($e ne $ee)) {
      0        
2837 0         0 $s = $self->setobj($nn, $ee);
2838             }
2839             } elsif ($s =~ /^#inst\d+$/) {
2840 0         0 my ($c, $f, $i) = @{$self->{strmap}->{$s}};
  0         0  
2841             } elsif ($s =~ /^#ref\d+$/) {
2842 0         0 my ($v) = @{$self->{strmap}->{$s}};
  0         0  
2843             } elsif ($s =~ /^#class\d+$/) {
2844 0         0 my ($c, $b, $p) = @{$self->{strmap}->{$s}};
  0         0  
2845             # no context change here
2846             } elsif ($s =~ /^#trait\d+$/) {
2847 0         0 my ($t, $b) = @{$self->{strmap}->{$s}};
  0         0  
2848             # no context change here
2849             } elsif ($s =~ /^#fh\d+$/) {
2850 0         0 my $f = $self->{strmap}->{$s}{name};
2851 0         0 my $m = $self->{strmap}->{$s}{mode};
2852 0         0 my $p = $self->{strmap}->{$s}{pos};
2853             } elsif ($s =~ /^#blk\d+$/) {
2854 602         945 my ($type, $a) = @{$self->{strmap}->{$s}};
  602         1612  
2855 602         1185 my @args = ();
2856 602         831 my $arg_changed = 0;
2857              
2858 602         1288 foreach my $k (@$a) {
2859 698         1572 my $v = $self->map_stmt($k, $cb, @params);
2860 698 100       1443 if ($v ne $k) {
2861 93 100       258 unless ($self->is_empty_block($v)) {
2862 18         35 push(@args, $v);
2863             }
2864 93         194 $arg_changed = 1;
2865             } else {
2866 605         1357 push(@args, $v);
2867             }
2868             }
2869 602 100       1274 if ($arg_changed) {
2870 85         204 $s = $self->setblk($type, \@args);
2871             }
2872             } elsif ($s =~ /^#stmt\d+$/) {
2873 529         1200 my $cmd = $self->{strmap}->{$s}->[0];
2874 529 100       2813 if ($cmd eq 'echo') {
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    0          
    0          
    0          
2875 108         205 my $a = $self->{strmap}->{$s}->[1];
2876 108         181 my @args = ();
2877 108         151 my $arg_changed = 0;
2878              
2879 108         254 foreach my $k (@$a) {
2880 108         217 my $v = $self->map_stmt($k, $cb, @params);
2881 108         220 push(@args, $v);
2882 108 50       270 if ($v ne $k) {
2883 0         0 $arg_changed = 1;
2884             }
2885             }
2886 108 50       255 if ($arg_changed) {
2887 0         0 $s = $self->setstmt(['echo', \@args]);
2888             }
2889             } elsif ($cmd eq 'print') {
2890 0         0 my $arg = $self->{strmap}->{$s}->[1];
2891 0         0 my $v = $self->map_stmt($arg, $cb, @params);
2892              
2893 0 0       0 if ($v ne $arg) {
2894 0         0 $s = $self->setstmt(['print', $v]);
2895             }
2896             } elsif ($cmd eq 'namespace') {
2897 0         0 my ($arg, $block) = @{$self->{strmap}->{$s}}[1..2];
  0         0  
2898 0         0 my $v = $arg;
2899 0         0 my $block1 = $block;
2900              
2901 0 0       0 if (defined $block) {
2902 0         0 $block1 = $self->map_stmt($block, $cb, @params);
2903             }
2904 0 0 0     0 if (($v ne $arg) || ($block1 ne $block)) {
2905 0         0 $s = $self->setstmt(['namespace', $v, $block1]);
2906             }
2907             } elsif ($cmd =~ /^(include|include_once|require|require_once)$/) {
2908 0         0 my $arg = $self->{strmap}->{$s}->[1];
2909 0         0 my $v = $self->map_stmt($arg, $cb, @params);
2910              
2911 0 0       0 if ($v ne $arg) {
2912 0         0 $s = $self->setstmt([$cmd, $v]);
2913             }
2914             } elsif ($cmd eq 'use') {
2915 0         0 my $a = $self->{strmap}->{$s}->[1];
2916 0         0 my @args = ();
2917 0         0 my $arg_changed = 0;
2918              
2919 0         0 foreach my $k (@$a) {
2920 0         0 my $v = $self->map_stmt($k, $cb, @params);
2921 0         0 push(@args, $v);
2922 0 0       0 if ($v ne $k) {
2923 0         0 $arg_changed = 1;
2924             }
2925             }
2926 0 0       0 if ($arg_changed) {
2927 0         0 $s = $self->setstmt(['use', \@args]);
2928             }
2929             } elsif ($cmd eq 'global') {
2930 8         23 my $a = $self->{strmap}->{$s}->[1];
2931 8         14 my @args = ();
2932 8         16 my $arg_changed = 0;
2933              
2934 8         18 foreach my $k (@$a) {
2935 8         16 my $v = $self->map_stmt($k, $cb, @params);
2936 8         21 push(@args, $v);
2937 8 50       25 if ($v ne $k) {
2938 0         0 $arg_changed = 1;
2939             }
2940             }
2941 8 50       22 if ($arg_changed) {
2942 0         0 $s = $self->setstmt(['global', \@args]);
2943             }
2944             } elsif ($cmd eq 'static') {
2945 8         17 my ($a, $p) = @{$self->{strmap}->{$s}}[1..2];
  8         21  
2946 8         13 my @args = ();
2947 8         12 my $arg_changed = 0;
2948              
2949 8         16 foreach my $k (@$a) {
2950 8         25 my $v = $self->map_stmt($k, $cb, @params);
2951 8         15 push(@args, $v);
2952 8 50       20 if ($v ne $k) {
2953 0         0 $arg_changed = 1;
2954             }
2955             }
2956 8 50       19 if ($arg_changed) {
2957 0         0 $s = $self->setstmt(['static', \@args, $p]);
2958             }
2959             } elsif ($cmd eq 'const') {
2960 0         0 my ($a, $p) = @{$self->{strmap}->{$s}}[1..2];
  0         0  
2961 0         0 my @args = ();
2962 0         0 my $arg_changed = 0;
2963              
2964 0         0 foreach my $k (@$a) {
2965 0         0 my $v = $self->map_stmt($k, $cb, @params);
2966 0         0 push(@args, $v);
2967 0 0       0 if ($v ne $k) {
2968 0         0 $arg_changed = 1;
2969             }
2970             }
2971 0 0       0 if ($arg_changed) {
2972 0         0 $s = $self->setstmt(['const', \@args, $p]);
2973             }
2974             } elsif ($cmd eq 'unset') {
2975 0         0 my $a = $self->{strmap}->{$s}->[1];
2976 0         0 my @args = ();
2977 0         0 my $arg_changed = 0;
2978              
2979 0         0 foreach my $k (@$a) {
2980 0         0 my $v = $self->map_stmt($k, $cb, @params);
2981 0         0 push(@args, $v);
2982 0 0       0 if ($v ne $k) {
2983 0         0 $arg_changed = 1;
2984             }
2985             }
2986 0 0       0 if ($arg_changed) {
2987 0         0 $s = $self->setstmt(['unset', \@args]);
2988             }
2989             } elsif ($cmd eq 'return') {
2990 386         638 my $arg = $self->{strmap}->{$s}->[1];
2991 386         645 my $v = $arg;
2992              
2993 386 50       747 if (defined $v) {
2994 386         792 $v = $self->map_stmt($arg, $cb, @params);
2995             }
2996 386 50 33     1531 if (defined $v && ($v ne $arg)) {
2997 0         0 $s = $self->setstmt(['return', $v]);
2998             }
2999             } elsif ($cmd eq 'goto') {
3000 0         0 my $arg = $self->{strmap}->{$s}->[1];
3001 0         0 my $v = $self->map_stmt($arg, $cb, @params);
3002              
3003 0 0       0 if ($v ne $arg) {
3004 0         0 $s = $self->setstmt(['goto', $v]);
3005             }
3006             } elsif ($cmd eq 'label') {
3007 0         0 my $arg = $self->{strmap}->{$s}->[1];
3008 0         0 my $v = $self->map_stmt($arg, $cb, @params);
3009              
3010 0 0       0 if ($v ne $arg) {
3011 0         0 $s = $self->setstmt(['label', $v]);
3012             }
3013             } elsif ($cmd eq 'throw') {
3014 0         0 my $arg = $self->{strmap}->{$s}->[1];
3015 0         0 my $v = $self->map_stmt($arg, $cb, @params);
3016              
3017 0 0       0 if ($v ne $arg) {
3018 0         0 $s = $self->setstmt(['throw', $v]);
3019             }
3020             } elsif ($cmd eq 'if') {
3021 15         32 my ($cond, $then, $else) = @{$self->{strmap}->{$s}}[1..3];
  15         63  
3022 15         47 my $cond1 = $self->map_stmt($cond, $cb, @params);
3023 15         54 my $then1 = $self->map_stmt($then, $cb, @params);
3024 15         38 my $else1 = $else;
3025              
3026 15 50       41 if (defined $else) {
3027 0         0 $else1 = $self->map_stmt($else, $cb, @params);
3028             }
3029 15 100 66     96 if (($cond ne $cond1) || ($then ne $then1) || (defined $else && ($else ne $else1))) {
      33        
      66        
3030 2 50 33     6 if ($self->is_empty_block($then1) && (!defined $else || $self->is_empty_block($else1))) {
      33        
3031 2         6 $s = $cond1;
3032             } else {
3033 0         0 $s = $self->setstmt(['if', $cond1, $then1, $else1]);
3034             }
3035             }
3036             } elsif ($cmd eq 'while') {
3037 0         0 my ($cond, $block) = @{$self->{strmap}->{$s}}[1..2];
  0         0  
3038 0         0 my $cond1 = $self->map_stmt($cond, $cb, @params);
3039 0         0 my $block1 = $self->map_stmt($block, $cb, @params);
3040              
3041 0 0 0     0 if (($cond ne $cond1) || ($block ne $block1)) {
3042 0         0 $s = $self->setstmt(['while', $cond1, $block1]);
3043             }
3044             } elsif ($cmd eq 'do') {
3045 0         0 my ($cond, $block) = @{$self->{strmap}->{$s}}[1..2];
  0         0  
3046 0         0 my $cond1 = $self->map_stmt($cond, $cb, @params);
3047 0         0 my $block1 = $self->map_stmt($block, $cb, @params);
3048              
3049 0 0 0     0 if (($cond ne $cond1) || ($block ne $block1)) {
3050 0         0 $s = $self->setstmt(['do', $cond1, $block1]);
3051             }
3052             } elsif ($cmd eq 'for') {
3053 0         0 my ($pre, $cond, $post, $block) = @{$self->{strmap}->{$s}}[1..4];
  0         0  
3054 0         0 my $pre1 = $self->map_stmt($pre, $cb, @params);
3055 0         0 my $cond1 = $self->map_stmt($cond, $cb, @params);
3056 0         0 my $post1 = $self->map_stmt($post, $cb, @params);
3057 0         0 my $block1 = $self->map_stmt($block, $cb, @params);
3058              
3059 0 0 0     0 if (($pre ne $pre1) || ($cond ne $cond1) || ($post ne $post1) || ($block ne $block1)) {
      0        
      0        
3060 0         0 $s = $self->setstmt(['for', $pre1, $cond1, $post1, $block1]);
3061             }
3062             } elsif ($cmd eq 'foreach') {
3063 4         8 my ($expr, $key, $value, $block) = @{$self->{strmap}->{$s}}[1..4];
  4         15  
3064 4         11 my $expr1 = $self->map_stmt($expr, $cb, @params);
3065 4         7 my $key1 = $key;
3066              
3067 4 50       10 if (defined $key) {
3068 4         10 $key1 = $self->map_stmt($key, $cb, @params);
3069             }
3070 4         13 my $value1 = $self->map_stmt($value, $cb, @params);
3071 4         24 my $block1 = $self->map_stmt($block, $cb, @params);
3072              
3073 4 100 33     51 if (($expr ne $expr1) || (defined $key && ($key ne $key1)) || ($value ne $value1) || ($block ne $block1)) {
      33        
      33        
      66        
3074 1         13 $s = $self->setstmt(['foreach', $expr1, $key1, $value1, $block1]);
3075             }
3076             } elsif ($cmd eq 'switch') {
3077 0         0 my ($expr, $cases) = @{$self->{strmap}->{$s}}[1..2];
  0         0  
3078 0         0 my $expr1 = $self->map_stmt($expr, $cb, @params);
3079 0         0 my @cnew = ();
3080 0         0 my $changed = 0;
3081              
3082 0         0 foreach my $e (@$cases) {
3083 0         0 my $c = $e->[0];
3084 0         0 my $b = $e->[1];
3085 0         0 my $c1 = $c;
3086              
3087 0 0       0 if (defined $c) {
3088 0         0 $c1 = $self->map_stmt($c, $cb, @params);
3089             }
3090 0         0 my $b1 = $self->map_stmt($b, $cb, @params);
3091              
3092 0 0 0     0 if ((defined $c1 && ($c ne $c1)) || ($b ne $b1)) {
      0        
3093 0         0 $changed = 1;
3094             }
3095 0         0 push (@cnew, [$c1, $b1]);
3096             }
3097 0 0 0     0 if (($expr ne $expr1) || $changed) {
3098 0         0 $s = $self->setstmt(['switch', $expr1, \@cnew]);
3099             }
3100             } elsif ($cmd eq 'case') {
3101 0         0 my $expr = $self->{strmap}->{$s}->[1];
3102 0         0 my $expr1 = $expr;
3103              
3104 0 0       0 if (!defined $expr) {
3105 0         0 $expr1 = $self->map_stmt($expr, $cb, @params);
3106             }
3107 0 0 0     0 if (defined $expr && ($expr ne $expr1)) {
3108 0         0 $s = $self->setstmt(['case', $expr1]);
3109             }
3110             } elsif ($cmd eq 'try') {
3111 0         0 my ($try, $catches, $finally) = @{$self->{strmap}->{$s}}[1..3];
  0         0  
3112 0         0 my $try1 = $self->map_stmt($try, $cb, @params);
3113 0         0 my $finally1 = $finally;
3114 0         0 my @cnew = ();
3115 0         0 my $changed = 0;
3116              
3117 0         0 foreach my $c (@$catches) {
3118 0         0 my $e = $c->[0];
3119 0         0 my $b = $c->[1];
3120              
3121 0         0 my $e1 = $self->map_stmt($e, $cb, @params);
3122 0         0 my $b1 = $self->map_stmt($b, $cb, @params);
3123              
3124 0 0 0     0 if ((defined $e1 && ($e ne $e1)) || ($b ne $b1)) {
      0        
3125 0         0 $changed = 1;
3126             }
3127 0         0 push (@cnew, [$e1, $b1]);
3128             }
3129 0 0       0 if (defined $finally) {
3130 0         0 $finally1 = $self->map_stmt($finally, $cb, @params);
3131             }
3132 0 0 0     0 if (($try ne $try1) || $changed || (defined $finally && ($finally ne $finally1))) {
      0        
      0        
3133 0         0 $s = $self->setstmt(['try', $try1, \@cnew, $finally1]);
3134             }
3135             }
3136             } elsif (is_variable($s)) {
3137             # keep
3138             }
3139 2830 100       5175 if ($s ne $s0) {
3140 98 50       247 $self->{debug}->('map', "map %s -> %s", $s0, $s) if $self->{debug};
3141             }
3142 2830         5755 return $s;
3143             }
3144              
3145             sub escape_str {
3146 1173     1173 0 1953 my ($s, $fmt) = @_;
3147              
3148             # escape string (keep newlines as newline like php does)
3149             # http://php.net/manual/de/language.types.string.php
3150             # - php single quoted strings suppport backslash escapes
3151             # for literal backslash & single quote.
3152             # - use single quotes to avoid string interpolation on
3153             # re-evaluation.
3154             #
3155 1173         2545 $s =~ s/\\/\\\\/sg;
3156 1173         1739 $s =~ s/'/\\'/sg;
3157              
3158 1173 50       2069 if (exists $fmt->{escape_ctrl}) {
3159             # convert controls other than \t\r\n to "\xNN"
3160 0         0 $s = escape_ctrl($s, "\x00-\x08\x0b\x0c\x0e-\x1f\x7f");
3161             } else {
3162 1173         2439 $s = "'" . $s . "'";
3163             }
3164 1173         2561 return $s;
3165             }
3166              
3167             sub expand_stmt {
3168 8423     8423 0 14156 my ($self, $out, $s, $fmt) = @_;
3169              
3170             #$self->{log}->('EXPAND', "$s") if $self->{log};
3171              
3172 8423 50       58887 if (!defined $s) {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
3173 0         0 $self->{warn}->('expand', "undefined symbol");
3174 0         0 push(@$out, '');
3175             } elsif ($s =~ /^#null$/) {
3176 30         120 push(@$out, 'null');
3177             } elsif ($s =~ /^#num\d+$/) {
3178 570 50       1503 if (exists $self->{strmap}->{$s}) {
3179 570 50       1233 unless (exists $fmt->{unified}) {
3180 570         1108 $s = $self->{strmap}->{$s};
3181             }
3182             }
3183 570         1106 push(@$out, $s);
3184             } elsif ($s =~ /^#const\d+$/) {
3185 23 50       91 if (exists $self->{strmap}->{$s}) {
3186 23 50       60 unless (exists $fmt->{unified}) {
3187 23         54 $s = $self->{strmap}->{$s};
3188             }
3189             }
3190 23         55 push(@$out, $s);
3191             } elsif ($s =~ /^#str\d+$/) {
3192 1172 50       2613 if (exists $self->{strmap}->{$s}) {
3193 1172 50       2141 unless (exists $fmt->{unified}) {
3194 1172         2261 $s = $self->{strmap}->{$s};
3195 1172 50       2042 if (exists $fmt->{mask_eval}) {
3196             # substitute 'eval' in strings on output
3197 0         0 $s =~ s/(^|\W)eval(\s*\()/$1$fmt->{mask_eval}$2/g;
3198             }
3199 1172 50 33     2500 if (exists $fmt->{max_strlen} && (length($s) > $fmt->{max_strlen})) {
3200 0         0 $s = substr($s, 0, $fmt->{max_strlen}-2).'..';
3201             }
3202 1172         2336 $s = escape_str($s, $fmt);
3203             }
3204             }
3205 1172         2240 push(@$out, $s);
3206             } elsif ($s =~ /^#arr\d+$/) {
3207 186         469 my $arr = $self->{strmap}{$s};
3208 186         584 my $keys = $arr->get_keys();
3209 186         425 push(@$out, 'array');
3210 186         305 push(@$out, '(');
3211              
3212 186         395 foreach my $k (@$keys) {
3213 278         644 my $val = $arr->val($k);
3214 278         1240 $self->expand_stmt($out, $k, $fmt);
3215 278         493 push(@$out, '=>');
3216 278 50       561 if (defined $val) {
3217 278         515 $self->expand_stmt($out, $val, $fmt);
3218             }
3219 278         630 push(@$out, ',');
3220             }
3221 186 100       464 if (scalar @$keys > 0) {
3222 162         249 pop(@$out);
3223             }
3224 186         376 push(@$out, ')');
3225             } elsif ($s =~ /^#fun\d+$/) {
3226 239         416 my ($f, $a, $b, $p) = @{$self->{strmap}->{$s}};
  239         776  
3227              
3228 239         754 foreach my $k (sort grep { exists $php_modifiers{$_} } keys %$p) {
  25         101  
3229 25         53 push(@$out, $k);
3230             }
3231 239         473 push(@$out, 'function');
3232 239 100       518 if (defined $f) {
3233 213         412 push(@$out, $f);
3234             }
3235 239         383 push(@$out, '(');
3236 239         543 foreach my $k (@$a) {
3237             #push(@$out, $k);
3238 104         328 $self->expand_stmt($out, $k, $fmt);
3239 104         226 push(@$out, ',');
3240             }
3241 239 100       628 if (scalar @$a > 0) {
3242 100         167 pop(@$out);
3243             }
3244 239         405 push(@$out, ')');
3245 239         649 $self->expand_stmt($out, $b, $fmt);
3246             #push(@$out, '{');
3247             #foreach my $k (@$b) {
3248             # $self->expand_stmt($out, $k, $fmt);
3249             # push(@$out, ';');
3250             #}
3251             #if (scalar @$b > 0) {
3252             # pop(@$out);
3253             #}
3254             #push(@$out, '}');
3255             } elsif ($s =~ /^#call\d+$/) {
3256 370         656 my ($f, $a) = @{$self->{strmap}->{$s}};
  370         1043  
3257              
3258 370 100       811 if ($f =~ /^#fun\d+$/) {
3259             # anonymous function call requires braces around func
3260 4         15 push(@$out, '(');
3261 4         12 $self->expand_stmt($out, $f, $fmt);
3262 4         15 push(@$out, ')');
3263             } else {
3264 366         800 $self->expand_stmt($out, $f, $fmt);
3265             }
3266 370         621 push(@$out, '(');
3267 370         809 foreach my $k (@$a) {
3268 198         537 $self->expand_stmt($out, $k, $fmt);
3269 198         442 push(@$out, ',');
3270             }
3271 370 100       885 if (scalar @$a > 0) {
3272 169         273 pop(@$out);
3273             }
3274 370         645 push(@$out, ')');
3275             } elsif ($s =~ /^#elem\d+$/) {
3276 275         523 my ($v, $i) = @{$self->{strmap}->{$s}};
  275         782  
3277              
3278 275         982 $self->expand_stmt($out, $v, $fmt);
3279 275         467 push(@$out, '[');
3280 275 100       582 if (defined $i) {
3281 254         530 $self->expand_stmt($out, $i, $fmt);
3282             }
3283 275         510 push(@$out, ']');
3284             } elsif ($s =~ /^#expr\d+$/) {
3285             # if v1 missing: prefix op
3286             # if v2 missing: postfix op
3287 1323         1983 my ($op, $v1, $v2) = @{$self->{strmap}->{$s}};
  1323         3646  
3288              
3289 1323 100       2600 if (defined $v1) {
3290 1272 100 100     4826 if ($v1 =~ /^#expr\d+$/) {
    100          
3291 30         88 my ($vop, $vv1, $vv2) = @{$self->{strmap}->{$v1}};
  30         122  
3292 30         56 my $add_brace = 0;
3293 30 100 100     130 if (($op ne '=') && ($op ne $vop)) {
3294 6         15 $add_brace = 1;
3295             }
3296 30 0 33     91 if (exists $op_unary{$vop} && ($vop ne 'new') && (is_variable($vv2) || ($vv2 =~ /^#elem\d+$/) || ($vv2 =~ /^#call\d+$/))) {
      0        
      33        
3297 0         0 $add_brace = 0;
3298             }
3299 30 100       68 if ($add_brace) {
3300 6         14 push(@$out, '(');
3301             }
3302 30         86 $self->expand_stmt($out, $v1, $fmt);
3303 30 100       66 if ($add_brace) {
3304 6         15 push(@$out, ')');
3305             }
3306             } elsif (($op eq '=') && ($v1 =~ /^#arr\d+$/)) {
3307             # output lhs array() as list() and allow empty elems
3308             #
3309 6         24 my $arr = $self->{strmap}{$v1};
3310 6         29 my $keys = $arr->get_keys();
3311 6         46 my $numerical = $arr->is_numerical();
3312 6         14 push(@$out, 'list');
3313 6         14 push(@$out, '(');
3314              
3315 6         11 foreach my $k (@$keys) {
3316 13         32 my $val = $arr->val($k);
3317 13 100       30 if (defined $val) {
3318 12 50       24 unless ($numerical) {
3319 0         0 $self->expand_stmt($out, $k, $fmt);
3320 0         0 push(@$out, '=>');
3321             }
3322 12         46 $self->expand_stmt($out, $val, $fmt);
3323             }
3324 13         34 push(@$out, ',');
3325             }
3326 6 50       20 if (scalar @$keys > 0) {
3327 6         10 pop(@$out);
3328             }
3329 6         15 push(@$out, ')');
3330             } else {
3331 1236         2676 $self->expand_stmt($out, $v1, $fmt);
3332             }
3333             }
3334 1323         2494 push(@$out, $op);
3335 1323 100       2361 if (defined $v2) {
3336 1288 100       2415 if ($op eq '$') {
3337 24         48 push(@$out, '{');
3338             }
3339 1288 100       2530 if ($v2 =~ /^#expr\d+$/) {
3340 96         194 my ($vop, $vv1, $vv2) = @{$self->{strmap}->{$v2}};
  96         356  
3341 96         178 my $add_brace = 0;
3342 96 100 100     449 if (($op ne '?') && ($op ne '=') && ($op ne $vop)) {
      100        
3343 8         14 $add_brace = 1;
3344             }
3345 96 100 66     328 if (exists $op_unary{$vop} && (is_variable($vv2) || ($vv2 =~ /^#elem\d+$/) || ($vv2 =~ /^#call\d+$/))) {
      100        
3346 8         21 $add_brace = 0;
3347             }
3348 96 100       193 if ($add_brace) {
3349 7         17 push(@$out, '(');
3350             }
3351 96         252 $self->expand_stmt($out, $v2, $fmt);
3352 96 100       259 if ($add_brace) {
3353 7         25 push(@$out, ')');
3354             }
3355             } else {
3356 1192         2571 $self->expand_stmt($out, $v2, $fmt);
3357             }
3358 1288 100       2681 if ($op eq '$') {
3359 24         62 push(@$out, '}');
3360             }
3361             }
3362             } elsif ($s =~ /^#pfx\d+$/) {
3363 16         42 my $pfx = $self->{strmap}->{$s};
3364 16         61 foreach my $k (sort keys %$pfx) {
3365 16         37 push(@$out, $k);
3366             }
3367             } elsif ($s =~ /^#obj\d+$/) {
3368 34         53 my ($o, $m) = @{$self->{strmap}->{$s}};
  34         158  
3369              
3370 34 50       79 if ($o =~ /^#call\d+$/) {
3371 0         0 push(@$out, '(');
3372 0         0 $self->expand_stmt($out, $o, $fmt);
3373 0         0 push(@$out, ')');
3374             } else {
3375 34         83 $self->expand_stmt($out, $o, $fmt);
3376             }
3377 34         66 push(@$out, '->');
3378 34 50 33     131 if (exists $self->{strmap}->{$m} && is_strval($m)) {
3379 0         0 my $sym = $self->{strmap}->{$m};
3380 0 0       0 if (is_symbol($sym)) {
3381 0         0 push(@$out, $sym);
3382             } else {
3383 0         0 $sym = escape_str($sym, $fmt);
3384              
3385 0         0 push(@$out, '{');
3386 0         0 push(@$out, $sym);
3387 0         0 push(@$out, '}');
3388             }
3389             } else {
3390 34         95 $self->expand_stmt($out, $m, $fmt);
3391             }
3392             } elsif ($s =~ /^#scope\d+$/) {
3393 4         17 my ($c, $e) = @{$self->{strmap}->{$s}};
  4         19  
3394              
3395 4 50 33     23 if (exists $self->{strmap}->{$c} && is_symbol($self->{strmap}->{$c})) {
3396 0         0 push(@$out, $self->{strmap}->{$c});
3397             } else {
3398 4         26 $self->expand_stmt($out, $c, $fmt);
3399             }
3400 4         30 push(@$out, '::');
3401 4 50 33     32 if (exists $self->{strmap}->{$e} && is_symbol($self->{strmap}->{$e})) {
3402 0         0 push(@$out, $self->{strmap}->{$e});
3403             } else {
3404 4         17 $self->expand_stmt($out, $e, $fmt);
3405             }
3406             } elsif ($s =~ /^#ns\d+$/) {
3407 0         0 my ($n, $e) = @{$self->{strmap}->{$s}};
  0         0  
3408              
3409 0 0       0 if (defined $n) {
3410 0 0 0     0 if (exists $self->{strmap}->{$n} && is_symbol($self->{strmap}->{$n})) {
3411 0         0 push(@$out, $self->{strmap}->{$n});
3412             } else {
3413 0         0 $self->expand_stmt($out, $n, $fmt);
3414             }
3415             }
3416 0         0 push(@$out, '\\');
3417 0         0 $self->expand_stmt($out, $e, $fmt);
3418             } elsif ($s =~ /^#inst\d+$/) {
3419 21         40 my ($c, $f, $i) = @{$self->{strmap}->{$s}};
  21         64  
3420              
3421 21         45 push(@$out, 'new');
3422 21         50 $self->expand_stmt($out, $f, $fmt);
3423             } elsif ($s =~ /^#ref\d+$/) {
3424 8         19 my ($v) = @{$self->{strmap}->{$s}};
  8         35  
3425              
3426 8         20 push(@$out, '&');
3427 8         32 $self->expand_stmt($out, $v, $fmt);
3428             } elsif ($s =~ /^#class\d+$/) {
3429 56         119 my ($c, $b, $p) = @{$self->{strmap}->{$s}};
  56         185  
3430              
3431 56         188 foreach my $k (sort grep { exists $php_modifiers{$_} } keys %$p) {
  0         0  
3432 0         0 push(@$out, $k);
3433             }
3434 56         122 push(@$out, 'class');
3435 56         101 push(@$out, $c);
3436              
3437 56 50       120 if (exists $p->{parent}) {
3438 0         0 push(@$out, 'extends');
3439 0         0 push(@$out, $p->{parent});
3440             }
3441 56         129 $self->expand_stmt($out, $b, $fmt);
3442             } elsif ($s =~ /^#trait\d+$/) {
3443 1         3 my ($t, $b) = @{$self->{strmap}->{$s}};
  1         4  
3444              
3445 1         13 push(@$out, 'trait');
3446 1         7 push(@$out, $t);
3447 1         6 $self->expand_stmt($out, $b, $fmt);
3448             } elsif ($s =~ /^#fh\d+$/) {
3449 0         0 my $f = $self->{strmap}->{$s}{name};
3450 0         0 my $m = $self->{strmap}->{$s}{mode};
3451 0         0 my $p = $self->{strmap}->{$s}{pos};
3452 0         0 push(@$out, 'FH');
3453 0         0 push(@$out, '(');
3454 0         0 push(@$out, $f);
3455 0         0 push(@$out, ',');
3456 0         0 push(@$out, $m);
3457 0         0 push(@$out, ')');
3458             } elsif ($s =~ /^#blk\d+$/) {
3459 1099         1737 my ($type, $a) = @{$self->{strmap}->{$s}};
  1099         2675  
3460 1099 100       3110 if ($type eq 'expr') {
    100          
    100          
    100          
3461 93         169 foreach my $k (@$a) {
3462 86         213 $self->expand_stmt($out, $k, $fmt);
3463 86         166 push(@$out, ',');
3464             }
3465 93 100       175 if (scalar @$a > 0) {
3466 82         135 pop(@$out);
3467             }
3468             } elsif ($type eq 'flat') {
3469 500         1035 foreach my $k (@$a) {
3470 1295         3257 $self->expand_stmt($out, $k, $fmt);
3471 1295 50       2535 if ($k =~ /^#pfx\d+$/) {
3472 0         0 next; # avoid ;
3473             }
3474 1295 100 100     4167 if (($out->[-1] ne '}') && ($out->[-1] ne ':')) {
3475 1040         2042 push(@$out, ';');
3476             }
3477             }
3478 500 100 100     2040 if ((scalar @$a > 0) && ($out->[-1] eq ';')) {
3479 433 50       1047 pop(@$out) if $fmt->{avoid_semicolon};
3480             }
3481             } elsif ($type eq 'case') {
3482 8         31 foreach my $k (@$a) {
3483 8         83 $self->expand_stmt($out, $k, $fmt);
3484 8         30 push(@$out, ';');
3485             }
3486 8 50       31 if (scalar @$a > 0) {
3487 8         14 pop(@$out);
3488             }
3489             } elsif ($type eq 'brace') {
3490 1 50       6 if (scalar @$a == 1) {
3491 1         5 $self->expand_stmt($out, $a->[0], $fmt);
3492             } else {
3493 0         0 push(@$out, '(');
3494 0         0 foreach my $k (@$a) {
3495 0         0 $self->expand_stmt($out, $k, $fmt);
3496 0 0       0 if ($out->[-1] ne ')') {
3497 0         0 push(@$out, ';');
3498             }
3499             }
3500 0 0 0     0 if ((scalar @$a > 0) && ($out->[-1] eq ';')) {
3501 0         0 pop(@$out);
3502             }
3503 0         0 push(@$out, ')');
3504             }
3505             } else {
3506 497         1037 push(@$out, '{');
3507 497         943 foreach my $k (@$a) {
3508 665         1731 $self->expand_stmt($out, $k, $fmt);
3509 665 100       1444 if ($k =~ /^#pfx\d+$/) {
3510 16         30 next; # avoid ;
3511             }
3512 649 100 66     2348 if (($out->[-1] ne '}') && ($out->[-1] ne ':')) {
3513 533         1027 push(@$out, ';');
3514             }
3515             }
3516 497 100 100     1535 if ((scalar @$a > 0) && ($out->[-1] eq ';')) {
3517 382 50       742 pop(@$out) if $fmt->{avoid_semicolon};
3518             }
3519 497         1028 push(@$out, '}');
3520             }
3521             } elsif ($s =~ /^#stmt\d+$/) {
3522 537         1338 my $cmd = $self->{strmap}->{$s}->[0];
3523 537 100       3507 if ($cmd eq 'echo') {
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
3524 183         351 my $a = $self->{strmap}->{$s}->[1];
3525 183         348 push(@$out, $cmd);
3526 183         380 foreach my $k (@$a) {
3527 186         620 $self->expand_stmt($out, $k, $fmt);
3528 186         369 push(@$out, ',');
3529             }
3530 183 50       451 if (scalar @$a > 0) {
3531 183         348 pop(@$out);
3532             }
3533             #push(@$out, ';');
3534             } elsif ($cmd eq 'print') {
3535 0         0 my $arg = $self->{strmap}->{$s}->[1];
3536 0         0 push(@$out, $cmd);
3537 0         0 $self->expand_stmt($out, $arg, $fmt);
3538             } elsif ($cmd eq 'namespace') {
3539 10         30 my ($arg, $block) = @{$self->{strmap}->{$s}}[1..2];
  10         28  
3540 10         21 push(@$out, $cmd);
3541 10 100       45 if ($arg ne '') {
3542 9         18 push(@$out, $arg);
3543             }
3544 10 100       36 if (defined $block) {
3545 2         8 $self->expand_stmt($out, $block, $fmt);
3546             }
3547             } elsif ($cmd =~ /^(include|include_once|require|require_once)$/) {
3548 0         0 my $arg = $self->{strmap}->{$s}->[1];
3549 0         0 push(@$out, $cmd);
3550 0         0 $self->expand_stmt($out, $arg, $fmt);
3551             } elsif ($cmd eq 'use') {
3552 0         0 my $a = $self->{strmap}->{$s}->[1];
3553 0         0 push(@$out, $cmd);
3554 0         0 foreach my $k (@$a) {
3555 0         0 $self->expand_stmt($out, $k, $fmt);
3556 0         0 push(@$out, ',');
3557             }
3558 0 0       0 if (scalar @$a > 0) {
3559 0         0 pop(@$out);
3560             }
3561             } elsif ($cmd eq 'global') {
3562 6         23 my $a = $self->{strmap}->{$s}->[1];
3563 6         13 push(@$out, $cmd);
3564 6         14 foreach my $k (@$a) {
3565 6         19 $self->expand_stmt($out, $k, $fmt);
3566 6         14 push(@$out, ',');
3567             }
3568 6 50       28 if (scalar @$a > 0) {
3569 6         26 pop(@$out);
3570             }
3571             } elsif ($cmd eq 'static') {
3572 11         29 my ($a, $p) = @{$self->{strmap}->{$s}}[1..2];
  11         31  
3573              
3574             #push(@$out, join(' ', sort keys %$p));
3575 11         50 push(@$out, join(' ', (grep { $_ ne $cmd } sort keys %$p), $cmd));
  11         46  
3576             #push(@$out, $cmd);
3577 11         33 foreach my $k (@$a) {
3578 11         42 $self->expand_stmt($out, $k, $fmt);
3579 11         33 push(@$out, ',');
3580             }
3581 11 50       35 if (scalar @$a > 0) {
3582 11         22 pop(@$out);
3583             }
3584             } elsif ($cmd eq 'const') {
3585 9         34 my ($a, $p) = @{$self->{strmap}->{$s}}[1..2];
  9         33  
3586              
3587             #push(@$out, join(' ', sort keys %$p));
3588 9         46 push(@$out, join(' ', (grep { $_ ne $cmd } sort keys %$p), $cmd));
  10         41  
3589             #push(@$out, $cmd);
3590 9         25 foreach my $k (@$a) {
3591 9         30 $self->expand_stmt($out, $k, $fmt);
3592 9         46 push(@$out, ',');
3593             }
3594 9 50       53 if (scalar @$a > 0) {
3595 9         18 pop(@$out);
3596             }
3597             } elsif ($cmd eq 'unset') {
3598 5         12 my $a = $self->{strmap}->{$s}->[1];
3599 5         10 push(@$out, $cmd);
3600 5         11 push(@$out, '(');
3601 5         12 foreach my $k (@$a) {
3602 5         17 $self->expand_stmt($out, $k, $fmt);
3603 5         12 push(@$out, ',');
3604             }
3605 5 50       31 if (scalar @$a > 0) {
3606 5         8 pop(@$out);
3607             }
3608 5         12 push(@$out, ')');
3609             } elsif ($cmd eq 'return') {
3610 116         256 my $a = $self->{strmap}->{$s}->[1];
3611 116         194 push(@$out, $cmd);
3612 116         268 $self->expand_stmt($out, $a, $fmt);
3613             } elsif ($cmd eq 'goto') {
3614 1         14 my $a = $self->{strmap}->{$s}->[1];
3615 1         7 push(@$out, $cmd);
3616 1         6 $self->expand_stmt($out, $a, $fmt);
3617             } elsif ($cmd eq 'label') {
3618 1         3 my $a = $self->{strmap}->{$s}->[1];
3619 1         4 $self->expand_stmt($out, $a, $fmt);
3620 1         8 push(@$out, ':');
3621             } elsif ($cmd eq 'throw') {
3622 0         0 my $arg = $self->{strmap}->{$s}->[1];
3623 0         0 push(@$out, $cmd);
3624 0         0 $self->expand_stmt($out, $arg, $fmt);
3625             } elsif ($cmd eq 'if') {
3626 103         227 my ($cond, $then, $else) = @{$self->{strmap}->{$s}}[1..3];
  103         357  
3627              
3628 103         192 push(@$out, $cmd);
3629 103         170 push(@$out, '(');
3630 103         270 $self->expand_stmt($out, $cond, $fmt);
3631 103         182 push(@$out, ')');
3632 103         296 $self->expand_stmt($out, $then, $fmt);
3633 103 100       268 if (defined $else) {
3634 14         37 push(@$out, 'else');
3635              
3636             # remove block around 'if else'
3637             #
3638 14 50       45 my $stmts = is_block($else) ? $self->{strmap}->{$else}->[1] : [];
3639 14 100 100     145 if ((@$stmts == 1) && ($stmts->[0] =~ /#stmt\d+$/) && ($self->{strmap}->{$stmts->[0]}->[0] eq 'if')) {
      100        
3640 5         18 $self->expand_stmt($out, $stmts->[0], $fmt);
3641             } else {
3642 9         31 $self->expand_stmt($out, $else, $fmt);
3643             }
3644             }
3645             } elsif ($cmd eq 'while') {
3646 16         24 my ($cond, $block) = @{$self->{strmap}->{$s}}[1..2];
  16         42  
3647              
3648 16         31 push(@$out, $cmd);
3649 16         26 push(@$out, '(');
3650 16         39 $self->expand_stmt($out, $cond, $fmt);
3651 16         30 push(@$out, ')');
3652 16         35 $self->expand_stmt($out, $block, $fmt);
3653             } elsif ($cmd eq 'do') {
3654 8         30 my ($cond, $block) = @{$self->{strmap}->{$s}}[1..2];
  8         32  
3655              
3656 8         19 push(@$out, $cmd);
3657 8         28 $self->expand_stmt($out, $block, $fmt);
3658 8         32 push(@$out, 'while');
3659 8         15 push(@$out, '(');
3660 8         26 $self->expand_stmt($out, $cond, $fmt);
3661 8         19 push(@$out, ')');
3662             } elsif ($cmd eq 'for') {
3663 31         54 my ($pre, $cond, $post, $block) = @{$self->{strmap}->{$s}}[1..4];
  31         99  
3664              
3665 31         68 push(@$out, $cmd);
3666 31         48 push(@$out, '(');
3667 31         87 $self->expand_stmt($out, $pre, $fmt);
3668 31         55 push(@$out, ';');
3669 31         78 $self->expand_stmt($out, $cond, $fmt);
3670 31         56 push(@$out, ';');
3671 31         89 $self->expand_stmt($out, $post, $fmt);
3672 31         84 push(@$out, ')');
3673 31         72 $self->expand_stmt($out, $block, $fmt);
3674             } elsif ($cmd eq 'foreach') {
3675 29         53 my ($expr, $key, $value, $block) = @{$self->{strmap}->{$s}}[1..4];
  29         132  
3676              
3677 29         55 push(@$out, $cmd);
3678 29         52 push(@$out, '(');
3679 29         109 $self->expand_stmt($out, $expr, $fmt);
3680 29         61 push(@$out, 'as');
3681 29 100       71 if (defined $key) {
3682 19         82 $self->expand_stmt($out, $key, $fmt);
3683 19         42 push(@$out, '=>');
3684             }
3685 29         91 $self->expand_stmt($out, $value, $fmt);
3686 29         55 push(@$out, ')');
3687 29         73 $self->expand_stmt($out, $block, $fmt);
3688             } elsif ($cmd eq 'switch') {
3689 6         14 my ($expr, $cases) = @{$self->{strmap}->{$s}}[1..2];
  6         27  
3690              
3691 6         12 push(@$out, $cmd);
3692 6         13 push(@$out, '(');
3693 6         17 $self->expand_stmt($out, $expr, $fmt);
3694 6         15 push(@$out, ')');
3695 6         13 push(@$out, '{');
3696 6         22 foreach my $e (@$cases) {
3697 8         19 my $c = $e->[0];
3698 8         16 my $b = $e->[1];
3699 8 50       18 if (defined $c) {
3700 8         14 push(@$out, 'case');
3701 8         25 $self->expand_stmt($out, $c, $fmt);
3702 8         37 push(@$out, ':');
3703             } else {
3704 0         0 push(@$out, 'default');
3705 0         0 push(@$out, ':');
3706             }
3707 8         23 $self->expand_stmt($out, $b, $fmt);
3708 8         37 push(@$out, ';');
3709             }
3710 6         14 push(@$out, '}');
3711             } elsif ($cmd eq 'case') {
3712 0         0 my $expr = $self->{strmap}->{$s}->[1];
3713 0 0       0 if (!defined $expr) {
3714 0         0 push(@$out, 'default');
3715 0         0 push(@$out, ':');
3716             } else {
3717 0         0 push(@$out, 'case');
3718 0         0 $self->expand_stmt($out, $expr, $fmt);
3719 0         0 push(@$out, ':');
3720             }
3721             } elsif ($cmd eq 'try') {
3722 1         3 my ($try, $catches, $finally) = @{$self->{strmap}->{$s}}[1..3];
  1         5  
3723              
3724 1         3 push(@$out, $cmd);
3725 1         4 $self->expand_stmt($out, $try, $fmt);
3726 1         7 foreach my $c (@$catches) {
3727 1         3 my $e = $c->[0];
3728 1         5 my $b = $c->[1];
3729 1         5 push(@$out, 'catch');
3730 1         3 push(@$out, '(');
3731 1         18 $self->expand_stmt($out, $e, $fmt);
3732 1         3 push(@$out, ')');
3733 1         12 $self->expand_stmt($out, $b, $fmt);
3734             }
3735 1 50       7 if (defined $finally) {
3736 1         3 push(@$out, 'finally');
3737 1         5 $self->expand_stmt($out, $finally, $fmt);
3738             }
3739             } else {
3740 1         3 push(@$out, $cmd);
3741             }
3742             } elsif (is_variable($s)) {
3743 1827         3297 my ($global) = global_split($s);
3744 1827 100       3339 if (defined $global) {
3745 35         182 my ($sym) = $global =~ /^\$(.*)$/;
3746 35         94 push(@$out, '$GLOBALS');
3747 35         88 push(@$out, '[');
3748 35         107 push(@$out, '\'' . $sym . '\'');
3749 35         64 push(@$out, ']');
3750             } else {
3751 1792         3154 my ($class, $sym) = inst_split($s);
3752 1792 100       4577 if (defined $class) {
    100          
    100          
3753 14         31 push(@$out, $class);
3754 14         30 push(@$out, '::');
3755 14         33 push(@$out, $sym);
3756             } elsif ($s eq '$') {
3757 4         10 push(@$out, '$');
3758 4         10 push(@$out, '{');
3759 4         8 push(@$out, 'null');
3760 4         11 push(@$out, '}');
3761             } elsif (!is_strict_variable($s)) {
3762 1         5 ($sym) = $s =~ /^\$(.*)$/;
3763 1         5 $sym = escape_str($sym, $fmt);
3764              
3765 1         4 push(@$out, '$');
3766 1         2 push(@$out, '{');
3767 1         4 push(@$out, $sym);
3768 1         2 push(@$out, '}');
3769             } else {
3770 1773         3772 push(@$out, $s);
3771             }
3772             }
3773             } else {
3774 632         1344 my ($class, $sym) = method_split($s);
3775 632 100       1215 if (defined $class) {
3776 12 50       23 if ($class =~ /^(#inst\d+)$/) {
3777 0         0 $self->expand_stmt($out, $class, $fmt);
3778 0         0 push(@$out, '->');
3779 0         0 push(@$out, $sym);
3780             } else {
3781 12         28 push(@$out, $class);
3782 12         21 push(@$out, '::');
3783 12         22 push(@$out, $sym);
3784             }
3785             } else {
3786 620         1233 push(@$out, $s);
3787             }
3788             }
3789 8423         13010 return;
3790             }
3791              
3792             sub expand_formatted {
3793 0     0 0 0 my ($out, $in, $tabs) = @_;
3794 0         0 my $orgtabs = $tabs;
3795 0         0 my $spc = "\t" x $tabs;
3796 0         0 my $val;
3797             my $lastval;
3798 0         0 my $varblk = 0;
3799              
3800             # insert newlines and indent {}-blocks
3801             #
3802 0         0 while (1) {
3803 0         0 my $val = shift @$in;
3804 0         0 my $isfor = 0;
3805 0         0 my $isswitch = 0;
3806 0         0 my $iscase = 0;
3807 0         0 my $isfunc = 0;
3808 0         0 my $exprblk = 0;
3809              
3810 0 0       0 if (!defined $val) {
3811 0         0 return;
3812             }
3813 0 0       0 if ($val eq '}') {
3814 0         0 return;
3815             }
3816 0         0 push(@$out, $spc);
3817 0         0 STMT: while(defined $val) {
3818 0 0       0 if ($val =~ /^(case|default)$/) {
    0          
3819 0         0 $iscase = 1;
3820             } elsif ($val =~ /^(function|class)$/) {
3821 0         0 $isfunc = 1;
3822             }
3823 0 0 0     0 if ((scalar @$in > 0) && ($in->[0] =~ /^(case|default)$/)) {
3824 0         0 $tabs = $orgtabs;
3825 0         0 $spc = "\t" x $tabs;
3826             }
3827 0         0 push(@$out, $val);
3828 0 0 0     0 if (($val eq '{') && defined $lastval && ($lastval eq '$')) {
    0 0        
    0          
    0          
    0          
3829 0         0 $varblk++;
3830             } elsif ($val eq '(') {
3831 0 0 0     0 if (defined $lastval && ($lastval eq 'for')) {
    0 0        
3832 0         0 $isfor = 1;
3833             } elsif (defined $lastval && ($lastval eq 'switch')) {
3834 0         0 $isswitch = 1;
3835             }
3836 0         0 $exprblk++;
3837             } elsif ($val eq '{') {
3838 0         0 push(@$out, "\n");
3839 0 0       0 if ($isswitch) {
3840 0         0 &expand_formatted($out, $in, $tabs);
3841             } else {
3842 0         0 &expand_formatted($out, $in, $tabs+1);
3843             }
3844 0         0 push(@$out, $spc);
3845 0         0 push(@$out, "}");
3846 0 0 0     0 if ((scalar @$in > 0) && !($in->[0] =~ /^(else|catch|finally|\))$/)) {
3847 0         0 push(@$out, "\n");
3848             #push(@$out, "\n") if $isfunc; # blank line after function?
3849 0         0 last STMT;
3850             }
3851             } elsif ($val eq ';') {
3852 0 0       0 if (!$isfor) {
3853 0         0 push(@$out, "\n");
3854 0         0 last STMT;
3855             }
3856             } elsif ($val eq ':') {
3857 0 0       0 if ($iscase) {
3858 0         0 push(@$out, "\n");
3859 0         0 $iscase = 0;
3860 0         0 $tabs++;
3861 0         0 $spc .= "\t";
3862 0         0 last STMT;
3863             }
3864             }
3865 0         0 $lastval = $val;
3866 0         0 $val = shift @$in;
3867              
3868 0 0 0     0 if (defined $val && ($val eq '}')) {
3869 0 0       0 if ($varblk == 0) {
3870 0         0 return;
3871             }
3872 0         0 $varblk--;
3873             }
3874 0 0 0     0 if (defined $val && ($val eq ')')) {
3875 0         0 $exprblk--;
3876             }
3877             }
3878             }
3879 0         0 return;
3880             }
3881              
3882             sub insert_blanks {
3883 0     0 0 0 my ($in) = @_;
3884 0         0 my @out = ();
3885 0         0 my $lastval;
3886              
3887 0         0 while (1) {
3888 0         0 my $val = shift @$in;
3889 0 0       0 if (!defined $val) {
3890 0         0 last;
3891             }
3892             # - no blanks in parenthesis or square brackets
3893             # - blank after semicolon or comma
3894             # - blank after most php keywords
3895             # - no blank after function calls
3896             # - no blank after unary ops
3897             # - no blank in pre/post inc/decrement
3898             # - no blank in object/scope reference
3899             #
3900 0 0 0     0 if (defined $lastval && ($lastval ne "\n") && ($lastval !~ /^\t*$/)) { # zero or more tabs
      0        
3901 0 0 0     0 if ($val !~ /^(\[|\]|\(|\)|\;|\,|\\n|->|::)$/) {
    0 0        
    0 0        
3902 0 0       0 if ($lastval !~ /^(\[|\(|\!|\~|->|::)$/) {
3903 0 0 0     0 unless ((($val eq '++') || ($val eq '--')) && is_strict_variable($lastval)) {
      0        
3904 0         0 push(@out, ' ');
3905             }
3906             }
3907             } elsif (($val eq '(') && exists $php_keywords{lc($lastval)}) {
3908 0 0       0 unless ($lastval =~ /^(array|empty|isset|unset|list)$/) {
3909 0         0 push(@out, ' ');
3910             }
3911             } elsif (($val eq '(') && !is_symbol($lastval) && ($lastval !~ /^(\[|\]|\(|\))$/)) {
3912 0         0 push(@out, ' ');
3913             }
3914             }
3915 0         0 push(@out, $val);
3916 0         0 $lastval = $val;
3917             }
3918 0         0 return @out;
3919             }
3920              
3921             # convert statements to code (flags are optional)
3922             # {indent} - output indented multiline code
3923             # {unified} - unified #str/#num output
3924             # {mask_eval} - mask eval in strings with pattern
3925             # {escape_ctrl} - escape control characters in output strings
3926             # {avoid_semicolon} - avoid semicolons after braces
3927             # {max_strlen} - max length for strings in output
3928             #
3929             sub format_stmt {
3930 783     783 1 3066 my ($self, $line, $fmt) = @_;
3931 783         1255 my @out = ();
3932 783 100       2236 $fmt = {} unless defined $fmt;
3933              
3934 783         2309 $self->expand_stmt(\@out, $line, $fmt);
3935              
3936 783 100 100     4820 if (!$fmt->{avoid_semicolon} && (scalar @out > 0) && ($out[-1] ne '}') && ($out[-1] ne ';')) {
      100        
      100        
3937 175         339 push(@out, ';');
3938             }
3939 783 50       1640 if (exists $fmt->{indent}) {
3940 0         0 my @tmp = ();
3941 0         0 expand_formatted(\@tmp, \@out, 0);
3942 0         0 return join('', insert_blanks(\@tmp));
3943             }
3944 783         5110 return join(' ', @out);
3945             }
3946              
3947 6     6   85 use constant HINT_ASSIGN => 0x10000; # variable is assigned to
  6         15  
  6         466  
3948 6     6   46 use constant HINT_UNSET => 0x20000; # variable is unset
  6         17  
  6         57957  
3949              
3950             # if expression in block contains an unresolvable variable, then return it
3951             #
3952             sub stmt_info {
3953 5471     5471 0 10070 my ($self, $s, $info, $hint) = @_;
3954              
3955 5471 100       38892 if ($s =~ /^#blk\d+$/) {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    100          
3956 681         1000 my ($type, $a) = @{$self->{strmap}->{$s}};
  681         1540  
3957 681         1303 foreach my $stmt (@$a) {
3958 894         2028 $self->stmt_info($stmt, $info);
3959             }
3960             #} elsif ($s =~ /^#num\d+$/) {
3961             # my $v = $self->{strmap}->{$s};
3962             # $info->{nums}{$s} = $v;
3963             #} elsif ($s =~ /^#str\d+$/) {
3964             # my $v = $self->{strmap}->{$s};
3965             # $info->{strs}{$s} = $v;
3966             } elsif ($s =~ /^#const\d+$/) {
3967 12         55 $s = $self->{strmap}->{$s};
3968 12         44 $info->{consts}{$s} = 1;
3969             } elsif ($s =~ /^#arr\d+$/) {
3970 286         617 my $arr = $self->{strmap}{$s};
3971 286         799 my $keys = $arr->get_keys();
3972 286         502 my $haskey = 0;
3973              
3974 286         609 foreach my $k (@$keys) {
3975 457         1039 my $val = $arr->val($k);
3976 457 100       1365 unless (is_int_index($k)) {
3977 21         74 $self->stmt_info($k, $info);
3978             }
3979 457 50       1116 if (defined $val) {
3980 457         1093 $self->stmt_info($val, $info);
3981 457         856 $haskey = 1;
3982             }
3983             }
3984 286 100       771 if ($haskey) {
3985 264         1000 $info->{arrays}{$s} = 'map';
3986             } else {
3987 22         84 $info->{arrays}{$s} = 'array';
3988             }
3989             } elsif ($s =~ /^#fun\d+$/) {
3990 23         56 my ($f, $a, $b, $p) = @{$self->{strmap}->{$s}};
  23         65  
3991 23 100       54 if (defined $f) {
3992 8         29 $info->{funcs}{$f} = 1;
3993             } else {
3994 15         44 $info->{funcs}{$s} = 1; # anon func
3995             }
3996             } elsif ($s =~ /^#expr\d+$/) {
3997 482         725 my ($op, $v1, $v2) = @{$self->{strmap}->{$s}};
  482         1382  
3998 482 100       1117 if (defined $v1) {
3999 450 100 100     3671 if (($op eq '=') && ($v1 =~ /^#elem\d+$/) && defined $v2) {
    100 66        
    100 66        
    100 100        
    100 66        
      66        
4000 51         78 my ($v, $i) = @{$self->{strmap}->{$v1}};
  51         151  
4001              
4002 51 100       115 unless (defined $i) {
4003 17         49 $self->stmt_info($v1, $info, T_ARRAY|HINT_ASSIGN);
4004             } else {
4005 34         77 $self->stmt_info($v1, $info, HINT_ASSIGN);
4006             }
4007             } elsif (($op eq '=') && defined $v2 && ($v2 =~ /^#call\d+$/)) {
4008 14         54 my ($f, $a) = @{$self->{strmap}->{$v2}};
  14         70  
4009              
4010 14 50       43 if ($f eq 'range') {
4011 0         0 $self->stmt_info($v1, $info, T_ARRAY|HINT_ASSIGN);
4012             } else {
4013 14         39 $self->stmt_info($v1, $info, HINT_ASSIGN);
4014             }
4015             } elsif (($op eq '=') && defined $v2) {
4016 283         591 $self->stmt_info($v1, $info, HINT_ASSIGN);
4017             } elsif ($op eq '.') {
4018 30         69 $self->stmt_info($v1, $info, T_STR);
4019             } elsif (($op eq '++') || ($op eq '--')) {
4020 14         45 $self->stmt_info($v1, $info, HINT_ASSIGN);
4021             } else {
4022 58         137 $self->stmt_info($v1, $info);
4023             }
4024 450 100       986 if ($op eq '=') {
    100          
    50          
4025 348         935 my $vb = $self->elem_base($v1);
4026 348         875 $info->{assigns}{$vb} = 1;
4027             } elsif ($op eq '++') {
4028 14         43 my $vb = $self->elem_base($v1);
4029 14         44 $info->{assigns}{$vb} = 1;
4030             } elsif ($op eq '--') {
4031 0         0 my $vb = $self->elem_base($v1);
4032 0         0 $info->{assigns}{$vb} = 1;
4033             }
4034             }
4035 482 100       951 if (defined $v2) {
4036 468 100 66     1558 if ($op eq '.') {
    100          
4037 30         85 $self->stmt_info($v2, $info, T_STR);
4038             } elsif (($op eq '++') || ($op eq '--')) {
4039 1         4 $self->stmt_info($v2, $info, HINT_ASSIGN);
4040             } else {
4041 437         846 $self->stmt_info($v2, $info);
4042             }
4043 468 50       1312 if ($op eq '++') {
    100          
4044 0         0 my $vb = $self->elem_base($v2);
4045 0         0 $info->{assigns}{$vb} = 1;
4046             } elsif ($op eq '--') {
4047 1         4 my $vb = $self->elem_base($v2);
4048 1         3 $info->{assigns}{$vb} = 1;
4049             }
4050             }
4051             } elsif ($s =~ /^#elem\d+$/) {
4052 174         279 my ($v, $i) = @{$self->{strmap}->{$s}};
  174         471  
4053 174 50       360 if (defined $v) {
4054 174         277 my $hint_assign = 0;
4055 174 100 100     517 $hint_assign = HINT_ASSIGN if (defined $hint && ($hint & HINT_ASSIGN));
4056 174 100       313 if (defined $i) {
4057 157         457 $self->stmt_info($v, $info, $hint_assign);
4058             } else {
4059 17         55 $self->stmt_info($v, $info, T_STR|T_ARRAY|$hint_assign);
4060             }
4061             }
4062 174 100       363 if (defined $i) {
4063 157         409 $self->stmt_info($i, $info);
4064              
4065             # add resolvable globals
4066             #
4067 157         495 my $g = $self->globalvar_to_var($v, $i);
4068 157 100       397 if (defined $g) {
4069 22         81 $info->{globals}{$g} = 1;
4070             }
4071             }
4072             } elsif ($s =~ /^#obj\d+$/) {
4073 9         22 my ($o, $m) = @{$self->{strmap}->{$s}};
  9         34  
4074 9 100       33 if (lc($o) ne '$this') {
4075 4         9 $self->stmt_info($o, $info);
4076             }
4077 9 50       26 if (defined $m) {
4078 9         25 $self->stmt_info($m, $info);
4079             }
4080             } elsif ($s =~ /^#inst\d+$/) {
4081 19         41 my ($c, $f, $i) = @{$self->{strmap}->{$s}};
  19         61  
4082 19 50       53 if (defined $c) {
4083 19         50 $self->stmt_info($c, $info);
4084             }
4085             } elsif ($s =~ /^#scope\d+$/) {
4086 0         0 my ($c, $e) = @{$self->{strmap}->{$s}};
  0         0  
4087 0 0       0 if (defined $e) {
4088 0         0 $self->stmt_info($e, $info);
4089             }
4090             } elsif ($s =~ /^#ns\d+$/) {
4091 0         0 my ($n, $e) = @{$self->{strmap}->{$s}};
  0         0  
4092 0 0       0 if (defined $e) {
4093 0         0 $self->stmt_info($e, $info);
4094             }
4095             } elsif ($s =~ /^#ref\d+$/) {
4096 0         0 my $v = $self->{strmap}->{$s}->[0];
4097 0 0       0 if (defined $v) {
4098 0         0 $self->stmt_info($v, $info);
4099             }
4100             } elsif ($s =~ /^#call\d+$/) {
4101 295         508 my ($f, $a) = @{$self->{strmap}->{$s}};
  295         833  
4102 295         583 my $narg = scalar @$a;
4103 295 100 66     911 if (exists $info->{state} && $info->{state}) {
4104 14         39 $info->{calls}{$f} = $info->{state};
4105             } else {
4106 281         647 $info->{calls}{$f} = 1;
4107             }
4108 295         902 $info->{callargs}{$f}{$narg} = 1; # track args count
4109              
4110 295         735 foreach my $k (@$a) {
4111 183 100       586 if ($f eq 'strlen') {
    100          
    50          
4112 3         9 $self->stmt_info($k, $info, T_STR);
4113             } elsif ($f eq 'base64_decode') {
4114 2         6 $self->stmt_info($k, $info, T_STR);
4115             } elsif ($f eq 'gzinflate') {
4116 0         0 $self->stmt_info($k, $info, T_STR);
4117             } else {
4118 178         439 $self->stmt_info($k, $info);
4119             }
4120             }
4121             } elsif ($s =~ /^#pfx\d+$/) {
4122 0         0 my $pfx = $self->{strmap}->{$s};
4123             } elsif ($s =~ /^#class\d+$/) {
4124 19         38 my ($c, $b, $p) = @{$self->{strmap}->{$s}};
  19         50  
4125 19         58 $info->{classes}{$c} = 1;
4126             } elsif ($s =~ /^#trait\d+$/) {
4127 0         0 my ($t, $b) = @{$self->{strmap}->{$s}};
  0         0  
4128 0         0 $info->{traits}{$t} = 1;
4129             } elsif ($s =~ /^#fh\d+$/) {
4130 0         0 my $f = $self->{strmap}->{$s}{name};
4131 0         0 my $m = $self->{strmap}->{$s}{mode};
4132 0         0 my $p = $self->{strmap}->{$s}{pos};
4133 0         0 $info->{fhs}{$f} = 1;
4134             } elsif ($s =~ /^#stmt\d+$/) {
4135 582         1435 my $cmd = $self->{strmap}->{$s}->[0];
4136 582 100       3465 if ($cmd eq 'echo') {
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    0          
4137 128         257 my $a = $self->{strmap}->{$s}->[1];
4138 128         320 foreach my $k (@$a) {
4139 128         277 $self->stmt_info($k, $info);
4140             }
4141 128         328 $info->{stmts}{$s} = 1;
4142             } elsif ($cmd eq 'print') {
4143 0         0 my $arg = $self->{strmap}->{$s}->[1];
4144 0         0 $self->stmt_info($arg, $info);
4145 0         0 $info->{stmts}{$s} = 1;
4146             } elsif ($cmd eq 'namespace') {
4147 0         0 my ($arg, $block) = @{$self->{strmap}->{$s}}[1..2];
  0         0  
4148 0 0       0 if (defined $block) {
4149 0         0 $self->stmt_info($block, $info);
4150             }
4151 0         0 $info->{stmts}{$s} = 1;
4152             } elsif ($cmd =~ /^(include|include_once|require|require_once)$/) {
4153 0         0 my $arg = $self->{strmap}->{$s}->[1];
4154 0         0 $info->{includes}{$arg} = 1;
4155 0         0 $self->stmt_info($arg, $info);
4156             } elsif ($cmd eq 'use') {
4157 0         0 my $a = $self->{strmap}->{$s}->[1];
4158 0         0 foreach my $v (@$a) {
4159 0         0 $self->stmt_info($v, $info);
4160             }
4161 0         0 $info->{stmts}{$s} = 1;
4162             } elsif ($cmd eq 'global') {
4163 9         25 my $a = $self->{strmap}->{$s}->[1];
4164 9         22 foreach my $v (@$a) {
4165 9         44 $info->{globals}{$v} = 1;
4166 9         27 $self->stmt_info($v, $info);
4167             }
4168             } elsif ($cmd eq 'static') {
4169 6         13 my $a = $self->{strmap}->{$s}->[1];
4170 6         12 foreach my $v (@$a) {
4171 6         17 $info->{statics}{$v} = 1;
4172 6         13 $self->stmt_info($v, $info);
4173             }
4174             } elsif ($cmd eq 'const') {
4175 0         0 my $a = $self->{strmap}->{$s}->[1];
4176 0         0 foreach my $v (@$a) {
4177 0         0 $info->{const}{$v} = 1;
4178 0         0 $self->stmt_info($v, $info);
4179             }
4180             } elsif ($cmd eq 'unset') {
4181 0         0 my $a = $self->{strmap}->{$s}->[1];
4182 0         0 foreach my $v (@$a) {
4183 0         0 $info->{assigns}{$v} = 1;
4184 0         0 $self->stmt_info($v, $info, HINT_ASSIGN|HINT_UNSET);
4185             }
4186             } elsif ($cmd eq 'return') {
4187 276         547 my $a = $self->{strmap}->{$s}->[1];
4188 276         410 my $old;
4189 276 100       584 $old = $info->{state} if exists $info->{state};
4190 276         529 $info->{state} = 'return';
4191 276         648 $self->stmt_info($a, $info);
4192 276         475 $info->{state} = $old;
4193 276         846 $info->{returns}{$a} = 1;
4194             } elsif ($cmd eq 'goto') {
4195 0         0 my $arg = $self->{strmap}->{$s}->[1];
4196 0         0 $self->stmt_info($arg, $info);
4197 0         0 $info->{stmts}{$s} = 1;
4198             } elsif ($cmd eq 'label') {
4199 0         0 my $arg = $self->{strmap}->{$s}->[1];
4200 0         0 $self->stmt_info($arg, $info);
4201 0         0 $info->{stmts}{$s} = 1;
4202             } elsif ($cmd eq 'throw') {
4203 0         0 my $arg = $self->{strmap}->{$s}->[1];
4204 0         0 $self->stmt_info($arg, $info);
4205 0         0 $info->{stmts}{$s} = 1;
4206             } elsif ($cmd eq 'if') {
4207 129         219 my ($cond, $then, $else) = @{$self->{strmap}->{$s}}[1..3];
  129         384  
4208              
4209 129         399 $self->stmt_info($cond, $info);
4210 129         349 $self->stmt_info($then, $info);
4211 129 100       320 if (defined $else) {
4212 15         44 $self->stmt_info($else, $info);
4213             }
4214 129         343 $info->{stmts}{$s} = 1;
4215             } elsif ($cmd eq 'while') {
4216 6         12 my ($cond, $block) = @{$self->{strmap}->{$s}}[1..2];
  6         19  
4217              
4218 6         20 $self->stmt_info($cond, $info);
4219 6         15 $self->stmt_info($block, $info);
4220 6         29 $info->{stmts}{$s} = 1;
4221             } elsif ($cmd eq 'do') {
4222 1         3 my ($cond, $block) = @{$self->{strmap}->{$s}}[1..2];
  1         4  
4223              
4224 1         6 $self->stmt_info($block, $info);
4225 1         3 $self->stmt_info($cond, $info);
4226 1         2 $info->{stmts}{$s} = 1;
4227             } elsif ($cmd eq 'for') {
4228 8         21 my ($pre, $cond, $post, $block) = @{$self->{strmap}->{$s}}[1..4];
  8         31  
4229              
4230 8         23 $self->stmt_info($pre, $info);
4231 8         63 $self->stmt_info($cond, $info);
4232 8         56 $self->stmt_info($post, $info);
4233 8         35 $self->stmt_info($block, $info);
4234 8         28 $info->{stmts}{$s} = 1;
4235             } elsif ($cmd eq 'foreach') {
4236 11         23 my ($expr, $key, $value, $block) = @{$self->{strmap}->{$s}}[1..4];
  11         40  
4237              
4238 11         39 $self->stmt_info($expr, $info);
4239 11 100       30 if (defined $key) {
4240 7         19 $self->stmt_info($key, $info);
4241 7         20 $info->{assigns}{$key} = 1;
4242             }
4243 11         32 $self->stmt_info($value, $info);
4244 11         32 $info->{assigns}{$value} = 1;
4245 11         38 $self->stmt_info($block, $info);
4246 11         48 $info->{stmts}{$s} = 1;
4247             } elsif ($cmd eq 'switch') {
4248 7         15 my ($expr, $cases) = @{$self->{strmap}->{$s}}[1..2];
  7         22  
4249              
4250 7         37 $self->stmt_info($expr, $info);
4251 7         17 foreach my $e (@$cases) {
4252 9         17 my $c = $e->[0];
4253 9         16 my $b = $e->[1];
4254 9 50       28 if (defined $c) {
4255 9         21 $self->stmt_info($c, $info);
4256             }
4257 9         27 $self->stmt_info($b, $info);
4258             }
4259 7         31 $info->{stmts}{$s} = 1;
4260             } elsif ($cmd eq 'case') {
4261 0         0 my $expr = $self->{strmap}->{$s}->[1];
4262 0 0       0 if (defined $expr) {
4263 0         0 $self->stmt_info($expr, $info);
4264             }
4265             } elsif ($cmd eq 'try') {
4266 0         0 my ($try, $catches, $finally) = @{$self->{strmap}->{$s}}[1..3];
  0         0  
4267              
4268 0         0 $self->stmt_info($try, $info);
4269 0         0 foreach my $c (@$catches) {
4270 0         0 my $e = $c->[0];
4271 0         0 my $b = $c->[1];
4272 0         0 $self->stmt_info($e, $info);
4273 0         0 $self->stmt_info($b, $info);
4274             }
4275 0 0       0 if (defined $finally) {
4276 0         0 $self->stmt_info($finally, $info);
4277             }
4278 0         0 $info->{stmts}{$s} = 1;
4279             } elsif ($cmd eq 'break') {
4280 1         7 $info->{breaks}{$s} = 1;
4281             } elsif ($cmd eq 'continue') {
4282 0         0 $info->{continues}{$s} = 1;
4283             }
4284             } elsif (is_variable($s)) {
4285 750         1486 my ($global) = global_split($s);
4286 750 100       1465 if (defined $global) {
4287 48         161 $info->{globals}{$global} = 1;
4288             } else {
4289 702 100       1221 if (defined $hint) {
4290 469         1427 $info->{vars}{$s} |= ($hint & T_MASK);
4291 469 100       1187 $info->{noassigns}{$s} |= ($hint & T_MASK) unless ($hint & HINT_ASSIGN);
4292             } else {
4293 233         611 $info->{vars}{$s} |= 0;
4294 233         463 $info->{noassigns}{$s} |= 0;
4295             }
4296             }
4297             }
4298 5471         10157 return;
4299             }
4300              
4301             sub translate_stmt {
4302 0     0 0   my ($self, $out, $s, $info) = @_;
4303              
4304             #$self->{log}->('TRANSLATE', "$s") if $self->{log};
4305              
4306 0 0         if (!defined $s) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4307 0           $self->{warn}->('translate', "undefined symbol");
4308 0           return;
4309             } elsif ($s =~ /^#null$/) {
4310 0           push(@$out, 'undef');
4311             } elsif ($s =~ /^#num\d+$/) {
4312 0 0         unless (exists $self->{strmap}->{$s}) {
4313 0           $self->{warn}->('translate', "num $s not found");
4314 0           return;
4315             }
4316 0           $s = $self->{strmap}->{$s};
4317 0           push(@$out, $s);
4318             } elsif ($s =~ /^#const\d+$/) {
4319 0 0         unless (exists $self->{strmap}->{$s}) {
4320 0           $self->{warn}->('translate', "bad const $s");
4321 0           return;
4322             }
4323 0           $s = $self->{strmap}->{$s};
4324 0 0         unless (is_symbol($s)) {
4325 0           $self->{warn}->('translate', "bad const name $s");
4326 0           return;
4327             }
4328 0           push(@$out, '$'.$s); # convert to var
4329             } elsif ($s =~ /^#str\d+$/) {
4330 0 0         unless (exists $self->{strmap}->{$s}) {
4331 0           $self->{warn}->('translate', "bad str $s");
4332 0           return;
4333             }
4334 0           $s = $self->{strmap}->{$s};
4335             # escape string (keep newlines as newline like php does)
4336             #
4337 0           $s =~ s/\\/\\\\/sg;
4338 0           $s =~ s/'/\\'/sg;
4339 0           $s = '\'' . $s . '\'';
4340 0           push(@$out, $s);
4341             } elsif ($s =~ /^#arr\d+$/) {
4342 0           my $arr = $self->{strmap}{$s};
4343 0           my $keys = $arr->get_keys();
4344 0           push(@$out, '{');
4345              
4346 0           foreach my $k (@$keys) {
4347 0           my $val = $arr->val($k);
4348 0 0         if (is_int_index($k)) {
4349 0           push(@$out, $k);
4350             } else {
4351 0 0         return unless $self->translate_stmt($out, $k, $info);
4352             }
4353 0           push(@$out, '=>');
4354 0 0         if (defined $val) {
4355 0 0         return unless $self->translate_stmt($out, $val, $info);
4356             } else {
4357 0           push(@$out, 'undef');
4358             }
4359 0           push(@$out, ',');
4360             }
4361 0 0         if (scalar @$keys > 0) {
4362 0           pop(@$out);
4363             }
4364 0           push(@$out, '}');
4365             } elsif ($s =~ /^#fun\d+$/) {
4366 0           my ($f, $a, $b, $p) = @{$self->{strmap}->{$s}};
  0            
4367              
4368 0           push(@$out, 'sub');
4369 0 0         if (defined $f) {
4370 0 0         unless (is_symbol($f)) {
4371 0           $self->{warn}->('translate', "bad func name $s $f not supported");
4372 0           return;
4373             }
4374 0           $self->{warn}->('translate', "func in func $s $f not supported");
4375 0           return;
4376             #push(@$out, $f);
4377             }
4378 0           push(@$out, '{');
4379 0 0         if (scalar @$a > 0) {
4380 0           push(@$out, 'my');
4381 0           push(@$out, '(');
4382 0           foreach my $k (@$a) {
4383 0 0         return unless $self->translate_stmt($out, $k, $info);
4384 0           push(@$out, ',');
4385             }
4386 0           pop(@$out);
4387 0           push(@$out, ')');
4388 0           push(@$out, '=');
4389 0           push(@$out, '@_');
4390 0           push(@$out, ';');
4391             }
4392             # TODO: don't pass local func info from outside
4393             #
4394 0 0         if (keys %{$info->{locals}} > 0) {
  0            
4395 0           push(@$out, 'my');
4396 0           push(@$out, '(');
4397 0           foreach my $k (keys %{$info->{locals}}) {
  0            
4398 0 0         return unless $self->translate_stmt($out, $k, $info);
4399 0           push(@$out, ',');
4400             }
4401 0           pop(@$out);
4402 0           push(@$out, ')');
4403 0           push(@$out, ';');
4404             }
4405             #$self->translate_stmt($out, $b, $info);
4406              
4407 0           my ($type, $c) = @{$self->{strmap}->{$b}};
  0            
4408 0           foreach my $k (@$c) {
4409 0 0         return unless $self->translate_stmt($out, $k, $info);
4410             #if ($out->[-1] ne '}') {
4411 0           push(@$out, ';');
4412             #}
4413             }
4414 0           push(@$out, '}');
4415             } elsif ($s =~ /^#call\d+$/) {
4416 0           my ($f, $a) = @{$self->{strmap}->{$s}};
  0            
4417              
4418 0 0         unless (is_symbol($f)) {
4419 0           $self->{warn}->('translate', "call name $s $f not supported");
4420 0           return;
4421             }
4422 0 0 0       if (($f eq 'strlen') && (scalar @$a == 1)) {
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
4423 0           push(@$out, 'length');
4424             } elsif (($f eq 'isset') && (scalar @$a == 1)) {
4425 0           push(@$out, 'defined');
4426             } elsif (($f eq 'range') && (scalar @$a == 2)) {
4427 0           push(@$out, '[');
4428 0 0         return unless $self->translate_stmt($out, $a->[0], $info);
4429 0           push(@$out, '..');
4430 0 0         return unless $self->translate_stmt($out, $a->[1], $info);
4431 0           push(@$out, ']');
4432 0           return 1;
4433             } elsif (($f eq 'base64_encode') && (scalar @$a == 1)) {
4434             # encode_base64($s,'')
4435 0           push(@$out, 'encode_base64');
4436 0           push(@$out, '(');
4437 0 0         return unless $self->translate_stmt($out, $a->[0], $info);
4438 0           push(@$out, ',');
4439 0           push(@$out, '\'\'');
4440 0           push(@$out, ')');
4441 0           return 1;
4442             } elsif (($f eq 'base64_decode') && (scalar @$a == 1)) {
4443             # decode_base64($s)
4444 0           push(@$out, 'decode_base64');
4445 0           push(@$out, '(');
4446 0 0         return unless $self->translate_stmt($out, $a->[0], $info);
4447 0           push(@$out, ')');
4448 0           return 1;
4449             } elsif (($f eq 'gzinflate') && (scalar @$a == 1)) {
4450             # (Compress::Zlib::inflateInit(-WindowBits => -(MAX_WBITS))->inflate($s))[0])
4451 0           push(@$out, '(');
4452 0           push(@$out, 'Compress::Zlib::inflateInit(-WindowBits => -(MAX_WBITS))->inflate');
4453 0           push(@$out, '(');
4454 0 0         return unless $self->translate_stmt($out, $a->[0], $info);
4455 0           push(@$out, ')');
4456 0           push(@$out, ')');
4457 0           push(@$out, '[');
4458 0           push(@$out, '0');
4459 0           push(@$out, ']');
4460 0           return 1;
4461             } elsif (($f =~ /^(chr|ord)$/) && (scalar @$a == 1)) {
4462 0           push(@$out, $f);
4463             } else {
4464 0           $self->{warn}->('translate', "call $s $f not supported");
4465 0           return;
4466             }
4467 0           push(@$out, '(');
4468 0           foreach my $k (@$a) {
4469 0 0         return unless $self->translate_stmt($out, $k, $info);
4470 0           push(@$out, ',');
4471             }
4472 0 0         if (scalar @$a > 0) {
4473 0           pop(@$out);
4474             }
4475 0           push(@$out, ')');
4476             } elsif ($s =~ /^#elem\d+$/) {
4477 0           my ($v, $i) = @{$self->{strmap}->{$s}};
  0            
4478              
4479 0 0 0       if (exists $info->{vars}{$v} && (($info->{vars}{$v} & T_MASK) == T_STR)) {
4480 0           push(@$out, 'substr');
4481 0           push(@$out, '(');
4482 0 0         return unless $self->translate_stmt($out, $v, $info);
4483 0           push(@$out, ',');
4484 0 0         if (defined $i) {
4485 0 0         return unless $self->translate_stmt($out, $i, $info);
4486 0           push(@$out, ',');
4487 0           push(@$out, '1');
4488             } else {
4489 0           push(@$out, '-1');
4490             }
4491 0           push(@$out, ')');
4492 0           return 1;
4493             }
4494 0 0         return unless $self->translate_stmt($out, $v, $info);
4495 0           push(@$out, '->');
4496 0 0 0       if (exists $info->{vars}{$v} && (($info->{vars}{$v} & T_MASK) == T_ARRAY)) {
4497 0           push(@$out, '[');
4498 0 0         if (defined $i) {
4499 0 0         return unless $self->translate_stmt($out, $i, $info);
4500             }
4501 0           push(@$out, ']');
4502             } else {
4503 0           push(@$out, '{');
4504 0 0         if (defined $i) {
4505 0 0         return unless $self->translate_stmt($out, $i, $info);
4506             }
4507 0           push(@$out, '}');
4508             }
4509             } elsif ($s =~ /^#expr\d+$/) {
4510 0           my ($op, $v1, $v2) = @{$self->{strmap}->{$s}};
  0            
4511              
4512 0 0         if (defined $v1) {
4513 0 0 0       if ($v1 =~ /^#expr\d+$/) {
    0 0        
4514 0           my $vop = $self->{strmap}->{$v1}->[0];
4515 0 0 0       if (($op ne '=') && ($op ne $vop)) {
4516 0           push(@$out, '(');
4517             }
4518 0 0         return unless $self->translate_stmt($out, $v1, $info);
4519 0 0 0       if (($op ne '=') && ($op ne $vop)) {
4520 0           push(@$out, ')');
4521             }
4522             } elsif (($v1 =~ /^#elem\d+$/) && defined $v2 && ($op eq '=')) {
4523 0           my $v = $self->{strmap}->{$v1}->[0];
4524 0           my $i = $self->{strmap}->{$v1}->[1];
4525 0 0 0       unless (defined $i && is_strict_variable($v)) {
4526             # try to emulate php-arrays with perl-maps
4527             # see: https://www.php.net/manual/en/language.types.array.php
4528             # - if no key is specified, the maximum of the existing int
4529             # indices is taken, and the new key will be that maximum
4530             # value plus 1 (but at least 0).
4531             # - If no int indices exist yet, the key will be 0 (zero).
4532             #
4533             # TODO: Note that the maximum integer key used for this
4534             # need not currently exist in the array. It need only
4535             # have existed in the array at some time since the
4536             # last time the array was re-indexed.
4537             #
4538 0 0 0       if (exists $info->{vars}{$v} && (($info->{vars}{$v} && T_MASK) == T_ARRAY)) {
      0        
4539             # for 'array' convert '$x[] = $v' to:
4540             # push(@{$x}, $v)
4541             #
4542 0           push(@$out, 'push');
4543 0           push(@$out, '(');
4544 0           push(@$out, '@');
4545 0           push(@$out, '{');
4546 0 0         return unless $self->translate_stmt($out, $v, $info);
4547 0           push(@$out, '}');
4548 0           push(@$out, ',');
4549 0 0         return unless $self->translate_stmt($out, $v2, $info);
4550 0           push(@$out, ')');
4551 0           return 1;
4552             } else {
4553             # for 'map' convert '$x[] = $v' to:
4554             # $x->{(max keys %$x)[-1] + 1} = $v
4555             # (or: $x->{keys %$x ? (sort keys %$x)[-1] + 1 : 0} = $v)
4556             #
4557 0 0         return unless $self->translate_stmt($out, $v, $info);
4558 0           my $vx = $out->[-1];
4559 0           push(@$out, '->');
4560 0           push(@$out, '{');
4561 0           push(@$out, '(');
4562 0           push(@$out, 'max');
4563 0           push(@$out, 'keys');
4564 0           push(@$out, '%'.$vx);
4565 0           push(@$out, ')');
4566 0           push(@$out, '[');
4567 0           push(@$out, '-1');
4568 0           push(@$out, ']');
4569 0           push(@$out, '+');
4570 0           push(@$out, '1');
4571 0           push(@$out, '}');
4572             }
4573             } else {
4574 0 0         return unless $self->translate_stmt($out, $v1, $info);
4575             }
4576             } else {
4577 0 0         return unless $self->translate_stmt($out, $v1, $info);
4578             }
4579             }
4580 0 0         if ($op eq '==') {
    0          
4581 0           push(@$out, 'eq');
4582             } elsif ($op eq '!=') {
4583 0           push(@$out, 'ne');
4584             } else {
4585 0           push(@$out, $op);
4586             }
4587 0 0         if (defined $v2) {
4588 0 0         if ($op eq '$') {
4589 0           push(@$out, '{');
4590             }
4591 0 0         if ($v2 =~ /^#expr\d+$/) {
4592 0           my $vop = $self->{strmap}->{$v2}->[0];
4593 0 0 0       if (($op ne '?') && ($op ne '=') && ($op ne $vop)) {
      0        
4594 0           push(@$out, '(');
4595             }
4596 0 0         return unless $self->translate_stmt($out, $v2, $info);
4597 0 0 0       if (($op ne '?') && ($op ne '=') && ($op ne $vop)) {
      0        
4598 0           push(@$out, ')');
4599             }
4600             } else {
4601 0 0         return unless $self->translate_stmt($out, $v2, $info);
4602             }
4603 0 0         if ($op eq '$') {
4604 0           push(@$out, '}');
4605             }
4606             }
4607             } elsif ($s =~ /^#pfx\d+$/) {
4608 0 0         unless (exists $self->{strmap}->{$s}) {
4609 0           $self->{warn}->('translate', "pfx $s not found");
4610 0           return;
4611             }
4612 0           my $pfx = $self->{strmap}->{$s};
4613 0 0         if (exists $pfx->{global}) {
4614 0           my $s = join(' ', sort keys %$pfx);
4615 0           $self->{warn}->('translate', "global pfx $s");
4616 0           return;
4617             }
4618 0           push(@$out, 'my');
4619             } elsif ($s =~ /^#obj\d+$/) {
4620 0           my ($o, $m) = @{$self->{strmap}->{$s}};
  0            
4621              
4622 0           $self->{warn}->('translate', "obj $s $o->$m not supported");
4623 0           return;
4624             } elsif ($s =~ /^#scope\d+$/) {
4625 0           my ($c, $e) = @{$self->{strmap}->{$s}};
  0            
4626              
4627 0           $self->{warn}->('translate', "scope $s $c::$e not supported");
4628 0           return;
4629             } elsif ($s =~ /^#ns\d+$/) {
4630 0           my ($n, $e) = @{$self->{strmap}->{$s}};
  0            
4631              
4632 0           $self->{warn}->('translate', "namespace $s $n::$e not supported");
4633 0           return;
4634             } elsif ($s =~ /^#inst\d+$/) {
4635 0           my ($c, $f, $i) = @{$self->{strmap}->{$s}};
  0            
4636              
4637 0           $self->{warn}->('translate', "new inst $s $f not supported");
4638 0           return;
4639             } elsif ($s =~ /^#ref\d+$/) {
4640 0           my $v = $self->{strmap}->{$s}->[0];
4641 0           push(@$out, '\\');
4642 0 0         return unless $self->translate_stmt($out, $v, $info);
4643             } elsif ($s =~ /^#class\d+$/) {
4644 0           my ($c, $b, $p) = @{$self->{strmap}->{$s}};
  0            
4645              
4646 0           $self->{warn}->('translate', "class $s $c not supported");
4647 0           return;
4648             } elsif ($s =~ /^#trait\d+$/) {
4649 0           my ($t, $b) = @{$self->{strmap}->{$s}};
  0            
4650              
4651 0           $self->{warn}->('translate', "trait $s $t not supported");
4652 0           return;
4653             } elsif ($s =~ /^#fh\d+$/) {
4654 0           my $f = $self->{strmap}->{$s}{name};
4655 0           my $m = $self->{strmap}->{$s}{mode};
4656 0           my $p = $self->{strmap}->{$s}{pos};
4657              
4658 0           $self->{warn}->('translate', "fh $s $f not supported");
4659 0           return;
4660             } elsif ($s =~ /^#blk\d+$/) {
4661 0           my ($type, $a) = @{$self->{strmap}->{$s}};
  0            
4662              
4663 0 0         if ($type eq 'expr') {
    0          
    0          
    0          
4664 0           foreach my $k (@$a) {
4665 0 0         return unless $self->translate_stmt($out, $k, $info);
4666 0           push(@$out, ',');
4667             }
4668 0 0         if (scalar @$a > 0) {
4669 0           pop(@$out);
4670             }
4671             } elsif ($type eq 'flat') {
4672 0           foreach my $k (@$a) {
4673 0 0         return unless $self->translate_stmt($out, $k, $info);
4674 0 0         if ($k =~ /^#pfx\d+$/) {
4675 0           next; # avoid ;
4676             }
4677 0 0         if ($out->[-1] ne '}') {
4678 0           push(@$out, ';');
4679             }
4680             }
4681 0 0 0       if ((scalar @$a > 0) && ($out->[-1] eq ';')) {
4682 0           pop(@$out);
4683             }
4684             } elsif ($type eq 'case') {
4685 0           foreach my $k (@$a) {
4686 0 0         return unless $self->translate_stmt($out, $k, $info);
4687 0           push(@$out, ';');
4688             }
4689 0 0         if (scalar @$a > 0) {
4690 0           pop(@$out);
4691             }
4692             } elsif ($type eq 'brace') {
4693 0 0         if (scalar @$a == 1) {
4694 0 0         return unless $self->translate_stmt($out, $a->[0], $info);
4695             } else {
4696 0           push(@$out, '(');
4697 0           foreach my $k (@$a) {
4698 0 0         return unless $self->translate_stmt($out, $k, $info);
4699 0 0         if ($out->[-1] ne ')') {
4700 0           push(@$out, ';');
4701             }
4702             }
4703 0 0 0       if ((scalar @$a > 0) && ($out->[-1] eq ';')) {
4704 0           pop(@$out);
4705             }
4706 0           push(@$out, ')');
4707             }
4708             } else {
4709 0           push(@$out, '{');
4710 0           foreach my $k (@$a) {
4711 0 0         return unless $self->translate_stmt($out, $k, $info);
4712 0 0         if ($k =~ /^#pfx\d+$/) {
4713 0           next; # avoid ;
4714             }
4715 0 0         if ($out->[-1] ne '}') {
4716 0           push(@$out, ';');
4717             }
4718             }
4719 0 0 0       if ((scalar @$a > 0) && ($out->[-1] eq ';')) {
4720 0           pop(@$out);
4721             }
4722 0           push(@$out, '}');
4723             }
4724             } elsif ($s =~ /^#stmt\d+$/) {
4725 0           my $cmd = $self->{strmap}->{$s}->[0];
4726 0 0         if ($cmd eq 'echo') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4727 0           my $a = $self->{strmap}->{$s}->[1];
4728 0           push(@$out, 'print');
4729 0           foreach my $k (@$a) {
4730 0 0         return unless $self->translate_stmt($out, $k, $info);
4731 0           push(@$out, ',');
4732             }
4733 0 0         if (scalar @$a > 0) {
4734 0           pop(@$out);
4735             }
4736             } elsif ($cmd eq 'print') {
4737 0           my $arg = $self->{strmap}->{$s}->[1];
4738 0           push(@$out, $cmd);
4739 0 0         return unless $self->translate_stmt($out, $arg, $info);
4740             } elsif ($cmd eq 'namespace') {
4741 0           my ($a, $block) = @{$self->{strmap}->{$s}}[1..2];
  0            
4742 0           $self->{warn}->('translate', "namespace $s $a not supported");
4743 0           return;
4744             } elsif ($cmd =~ /^(include|include_once|require|require_once)$/) {
4745 0           my $arg = $self->{strmap}->{$s}->[1];
4746 0           push(@$out, $cmd);
4747 0 0         return unless $self->translate_stmt($out, $arg, $info);
4748             } elsif ($cmd eq 'use') {
4749 0           my $a = $self->{strmap}->{$s}->[1];
4750 0           $self->{warn}->('translate', "use $s not supported");
4751 0           return;
4752             } elsif ($cmd eq 'global') {
4753 0           my $a = $self->{strmap}->{$s}->[1];
4754 0           $self->{warn}->('translate', "global $s not supported");
4755 0           return;
4756             } elsif ($cmd eq 'static') {
4757 0           my $a = $self->{strmap}->{$s}->[1];
4758 0           $self->{warn}->('translate', "static $s not supported");
4759 0           return;
4760             } elsif ($cmd eq 'const') {
4761 0           my $a = $self->{strmap}->{$s}->[1];
4762 0           $self->{warn}->('translate', "const $s not supported");
4763 0           return;
4764             } elsif ($cmd eq 'unset') {
4765 0           my $a = $self->{strmap}->{$s}->[1];
4766 0           $self->{warn}->('translate', "unset $s not supported");
4767 0           return;
4768             } elsif ($cmd eq 'return') {
4769 0           my $a = $self->{strmap}->{$s}->[1];
4770 0           push(@$out, $cmd);
4771 0 0         return unless $self->translate_stmt($out, $a, $info);
4772             } elsif ($cmd eq 'goto') {
4773 0           my $a = $self->{strmap}->{$s}->[1];
4774 0           $self->{warn}->('translate', "goto $s not supported");
4775 0           return;
4776             } elsif ($cmd eq 'label') {
4777 0           my $a = $self->{strmap}->{$s}->[1];
4778 0           $self->{warn}->('translate', "label $s not supported");
4779 0           return;
4780             } elsif ($cmd eq 'if') {
4781 0           my ($cond, $then, $else) = @{$self->{strmap}->{$s}}[1..3];
  0            
4782              
4783 0           push(@$out, $cmd);
4784 0           push(@$out, '(');
4785 0 0         return unless $self->translate_stmt($out, $cond, $info);
4786 0           push(@$out, ')');
4787 0 0         return unless $self->translate_stmt($out, $then, $info);
4788 0 0         if (defined $else) {
4789 0           push(@$out, 'else');
4790 0 0         return unless $self->translate_stmt($out, $else, $info);
4791             }
4792             } elsif ($cmd eq 'while') {
4793 0           my ($cond, $block) = @{$self->{strmap}->{$s}}[1..2];
  0            
4794              
4795 0           push(@$out, $cmd);
4796 0           push(@$out, '(');
4797 0 0         return unless $self->translate_stmt($out, $cond, $info);
4798 0           push(@$out, ')');
4799 0 0         return unless $self->translate_stmt($out, $block, $info);
4800             } elsif ($cmd eq 'do') {
4801 0           my ($cond, $block) = @{$self->{strmap}->{$s}}[1..2];
  0            
4802              
4803 0           push(@$out, $cmd);
4804 0 0         return unless $self->translate_stmt($out, $block, $info);
4805 0           push(@$out, 'while');
4806 0           push(@$out, '(');
4807 0 0         return unless $self->translate_stmt($out, $cond, $info);
4808 0           push(@$out, ')');
4809             } elsif ($cmd eq 'for') {
4810 0           my ($pre, $cond, $post, $block) = @{$self->{strmap}->{$s}}[1..4];
  0            
4811              
4812 0           push(@$out, $cmd);
4813 0           push(@$out, '(');
4814             #push(@$out, 'my'); # set as local -> persists after for-loop
4815 0 0         return unless $self->translate_stmt($out, $pre, $info);
4816 0           push(@$out, ';');
4817 0 0         return unless $self->translate_stmt($out, $cond, $info);
4818 0           push(@$out, ';');
4819 0 0         return unless $self->translate_stmt($out, $post, $info);
4820 0           push(@$out, ')');
4821 0 0         return unless $self->translate_stmt($out, $block, $info);
4822             } elsif ($cmd eq 'foreach') {
4823 0           my ($expr, $key, $value, $block) = @{$self->{strmap}->{$s}}[1..4];
  0            
4824              
4825 0 0         if (defined $key) {
4826             # convert 'foreach ($x as $k => $v)' to
4827             # foreach my $k ( sort { $a <=> $b } keys %$x ) { my $v = $x->{$k}; .. }
4828             #
4829 0           push(@$out, 'foreach');
4830             #push(@$out, 'my');
4831 0 0         return unless $self->translate_stmt($out, $key, $info);
4832 0           push(@$out, '(');
4833 0           push(@$out, 'sort');
4834 0           push(@$out, '{');
4835 0           push(@$out, '$a');
4836 0           push(@$out, '<=>');
4837 0           push(@$out, '$b');
4838 0           push(@$out, '}');
4839 0           push(@$out, 'keys');
4840 0           push(@$out, '%');
4841 0           push(@$out, '{');
4842 0 0         return unless $self->translate_stmt($out, $expr, $info);
4843 0           push(@$out, '}');
4844 0           push(@$out, ')');
4845 0           push(@$out, '{');
4846              
4847             #push(@$out, 'my');
4848 0 0         return unless $self->translate_stmt($out, $value, $info);
4849 0           push(@$out, '=');
4850 0 0         return unless $self->translate_stmt($out, $expr, $info);
4851 0           push(@$out, '->');
4852 0           push(@$out, '{');
4853 0 0         return unless $self->translate_stmt($out, $key, $info);
4854 0           push(@$out, '}');
4855 0           push(@$out, ';');
4856              
4857 0           my $type = $self->{strmap}->{$block}->[1];
4858 0           my $c = $self->{strmap}->{$block}->[2];
4859 0           foreach my $k (@$c) {
4860 0 0         return unless $self->translate_stmt($out, $k, $info);
4861             #if ($out->[-1] ne '}') {
4862 0           push(@$out, ';'); # might follow {} after map define/deref
4863             #}
4864             }
4865 0           push(@$out, '}');
4866 0           return 1;
4867             } else {
4868 0           push(@$out, $cmd);
4869 0           push(@$out, 'my');
4870 0 0         return unless $self->translate_stmt($out, $value, $info);
4871 0           push(@$out, '(');
4872 0 0         return unless $self->translate_stmt($out, $expr, $info);
4873 0           push(@$out, ')');
4874             }
4875 0 0         return unless $self->translate_stmt($out, $block, $info);
4876             } elsif ($cmd eq 'switch') {
4877 0           my ($expr, $cases) = @{$self->{strmap}->{$s}}[1..2];
  0            
4878 0           my $first = 1;
4879              
4880 0           foreach my $e (@$cases) {
4881 0           my $c = $e->[0];
4882 0           my $b = $e->[1];
4883 0 0         if (!defined $c) {
4884 0 0         if ($first) {
4885 0           $self->{warn}->('translate', "bad switch $s");
4886 0           return;
4887             }
4888 0           push(@$out, 'else');
4889             } else {
4890 0 0         if ($first) {
4891 0           push(@$out, 'if');
4892 0           $first = 0;
4893             } else {
4894 0           push(@$out, 'elsif');
4895             }
4896 0           push(@$out, '(');
4897 0 0         return unless $self->translate_stmt($out, $expr, $info);
4898 0           push(@$out, '==');
4899 0           push(@$out, '(');
4900 0 0         return unless $self->translate_stmt($out, $c, $info);
4901 0           push(@$out, ')');
4902 0           push(@$out, ')');
4903             }
4904 0           push(@$out, '{');
4905 0 0         return unless $self->translate_stmt($out, $b, $info);
4906 0           push(@$out, '}');
4907             }
4908             } elsif ($cmd eq 'break') {
4909 0           push(@$out, 'last');
4910             } elsif ($cmd eq 'continue') {
4911 0           push(@$out, 'next');
4912             } else {
4913 0           $self->{warn}->('translate', "bad statement $s");
4914 0           return;
4915             }
4916             } elsif (is_variable($s)) {
4917 0           my ($global) = global_split($s);
4918 0 0         if (defined $global) {
4919 0           $self->{warn}->('translate', "global $s not supported");
4920 0           return;
4921             }
4922 0 0         unless (is_symbol($s)) {
4923 0           $self->{warn}->('translate', "bad var name $s not supported");
4924 0           return;
4925             }
4926 0           push(@$out, $s);
4927             } else {
4928 0           $self->{warn}->('translate', "bad symbol $s not supported");
4929 0           return;
4930             }
4931 0           return 1;
4932             }
4933              
4934             sub translate_func {
4935 0     0 0   my ($self, $s, $maxlen, $format) = @_;
4936 0           my @out = ();
4937              
4938 0 0         unless ($s =~ /^#fun\d+$/) {
4939 0           $self->{warn}->('translate', "no func $s");
4940 0           return;
4941             }
4942             # create anonymous subroutine here
4943             #
4944 0           my ($f, $a, $b, $p) = @{$self->{strmap}->{$s}};
  0            
4945 0           $f = $self->setfun(undef, $a, $b, $p);
4946              
4947 0           my $info = {args => {}, vars => {}, locals => {}, globals => {}, calls => {}, returns => {}};
4948 0           $self->stmt_info($b, $info);
4949              
4950 0 0         if (scalar @$a > 0) {
4951 0           foreach my $v (@$a) {
4952 0           $info->{args}{$v} = 0;
4953             }
4954 0           foreach my $v (keys %{$info->{vars}}) {
  0            
4955 0 0         $info->{locals}{$v} |= $info->{vars}{$v} unless exists $info->{args}{$v};
4956             }
4957 0           foreach my $v (keys %{$info->{args}}) {
  0            
4958 0 0         $info->{vars}{$v} |= $info->{args}{$v} unless exists $info->{vars}{$v};
4959             }
4960             } else {
4961 0           $info->{locals} = $info->{vars};
4962             }
4963 0 0         if (keys %{$info->{args}}) {
  0            
4964 0 0         $self->{log}->('translate', "local args: %s", join(' ', map { ($info->{vars}{$_} ne '1') ? "$_:$info->{vars}{$_}" : $_ } keys %{$info->{args}})) if $self->{log};
  0 0          
  0            
4965             }
4966 0 0         if (keys %{$info->{locals}}) {
  0            
4967 0 0         $self->{log}->('translate', "local vars: %s", join(' ', map { ($info->{vars}{$_} ne '1') ? "$_:$info->{vars}{$_}" : $_ } keys %{$info->{locals}})) if $self->{log};
  0 0          
  0            
4968             }
4969 0 0         if (keys %{$info->{globals}}) {
  0            
4970 0 0         $self->{log}->('translate', "globals: %s", join(' ', keys %{$info->{globals}})) if $self->{log};
  0            
4971             }
4972 0 0         if (keys %{$info->{calls}}) {
  0            
4973 0 0         $self->{log}->('translate', "calls: %s", join(' ', keys %{$info->{calls}})) if $self->{log};
  0            
4974             }
4975 0 0         if (keys %{$info->{returns}}) {
  0            
4976 0 0         $self->{log}->('translate', "returns: %s", join(' ', keys %{$info->{returns}})) if $self->{log};
  0            
4977             } else {
4978 0           $self->{warn}->('translate', "no return for func $s");
4979 0           return;
4980             }
4981              
4982 0 0         unless ($self->translate_stmt(\@out, $f, $info)) {
4983 0           return;
4984             }
4985              
4986 0 0         if ($format) {
4987 0           my @tmp = ();
4988 0           expand_formatted(\@tmp, \@out, 0);
4989 0           return join(' ', @tmp);
4990             }
4991 0           return join(' ', @out);
4992             }
4993              
4994             1;
4995              
4996             __END__