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