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   140289 use base 'PHP::Decode::Tokenizer';
  6         34  
  6         2873  
6              
7 6     6   48 use strict;
  6         12  
  6         133  
8 6     6   30 use warnings;
  6         10  
  6         163  
9 6     6   31 use Carp 'croak';
  6         32  
  6         312  
10 6     6   36 use Config;
  6         11  
  6         254  
11 6     6   1704 use PHP::Decode::Array qw(is_int_index);
  6         28  
  6         311  
12 6     6   39 use Exporter qw(import);
  6         11  
  6         416  
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   34 no warnings 'recursion';
  6         11  
  6         29090  
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 5993 my ($class, %args) = @_;
51 795 50       2390 my $strmap = $args{strmap} or croak __PACKAGE__ . " expects strmap";
52              
53 795         3182 my $self = $class->SUPER::new(%args);
54 795 100       2492 $self->{max_strlen} = 0 unless exists $self->{max_strlen};
55 795         1757 $self->{tok} = []; # init token list
56              
57             # filename is required to decode __FILE__
58 795 100       2384 $self->{filename} = '__FILE__' unless exists $self->{filename};
59              
60 795 100       1943 $strmap->{'__LINE__'} = 1 unless exists $strmap->{'__LINE__'};
61 795 100       1882 $strmap->{'#null'} = '' unless exists $strmap->{'#null'};
62 795         2168 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 145 my ($self, %args) = @_;
69 70         234 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       181 $parser->{log} = $self->{log} if exists $self->{log};
71 70 50       176 $parser->{debug} = $self->{debug} if exists $self->{debug};
72              
73 70         167 foreach my $k (keys %args) {
74 0         0 $parser->{$k} = $args{$k};
75             }
76 70         169 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 4598 my ($self, $v) = @_;
141 2030         2814 my $k;
142              
143 2030 100       4533 if (exists $self->{strmap}->{rev}{$v}) {
144 121         275 $k = $self->{strmap}->{rev}{$v};
145 121         300 return $k;
146             } else {
147 1909         3597 $k = "#str$stridx";
148 1909         2873 $stridx++;
149 1909         4940 $self->{strmap}->{$k} = $v;
150 1909         5086 $self->{strmap}->{rev}{$v} = $k;
151             }
152             # TODO: log also for $opt{P}
153 1909 50 0     4438 $self->{log}->('setstr', "%s = %s", $k, $self->shortstr($v, $self->{max_strlen} || 60)) if $self->{log};
154 1909         4007 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 225 my ($self, $v) = @_;
162 110         152 my $k;
163              
164 110 100       252 if (exists $self->{strmap}->{rev}{$v}) {
165 21         45 $k = $self->{strmap}->{rev}{$v};
166 21         58 return $k;
167             } else {
168 89         169 $k = "#str$stridx";
169 89         132 $stridx++;
170 89         308 $self->{strmap}->{$k} = $v;
171             }
172             # TODO: log also for $opt{P}
173 89 50 0     216 $self->{log}->('setstr', "%s = %s [norev]", $k, $self->shortstr($v, $self->{max_strlen} || 60)) if $self->{log};
174 89         237 return $k;
175             }
176              
177             # number -> #num$i
178             #
179             sub setnum {
180 868     868 0 2606 my ($self, $v) = @_;
181 868         1234 my $k;
182              
183 868 100       2311 if (exists $self->{strmap}->{num}{$v}) {
184 182         381 $k = $self->{strmap}->{num}{$v};
185 182         471 return $k;
186             } else {
187 686         1474 $k = "#num$numidx";
188 686         1078 $numidx++;
189 686         1957 $self->{strmap}->{$k} = $v;
190 686         1638 $self->{strmap}->{num}{$v} = $k;
191             }
192 686 50       1450 $self->{log}->('setnum', "%s = %s", $k, $self->shortstr($v, 60)) if $self->{log};
193 686         1518 return $k;
194             }
195              
196             # 'const' -> #const$i
197             #
198             sub setconst {
199 344     344 0 682 my ($self, $v) = @_;
200 344         754 my $k = "#const$constidx";
201 344         554 $constidx++;
202              
203 344         1151 $self->{strmap}->{$k} = $v;
204 344 50       745 $self->{log}->('setconst', "%s = %s", $k, $v) if $self->{log};
205 344         709 return $k;
206             }
207              
208             sub newarr {
209 274     274 0 1059 my ($self) = @_;
210 274         1214 my $arr = PHP::Decode::Array->new(strmap => $self->{strmap});
211 274 50       706 $self->{log}->('newarr', "%s", $arr->{name}) if $self->{log};
212 274         556 return $arr;
213             }
214              
215             # function -> #fun$i
216             #
217             sub setfun {
218 309     309 0 714 my ($self, $cmd, $arglist, $block, $p) = @_;
219 309         643 my $k = "#fun$funidx";
220 309         529 $funidx++;
221              
222 309         1183 $self->{strmap}->{$k} = [$cmd, $arglist, $block, $p];
223 309 50       705 $self->{log}->('setfun', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
224 309         798 return $k;
225             }
226              
227             sub setcall {
228 781     781 0 1564 my ($self, $cmd, $arglist) = @_;
229 781         1554 my $k = "#call$callidx";
230 781         1167 $callidx++;
231              
232 781         3104 $self->{strmap}->{$k} = [$cmd, $arglist];
233 781 50       1829 $self->{log}->('setcall', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
234 781         1692 return $k;
235             }
236              
237             sub setelem {
238 538     538 0 1288 my ($self, $var, $idx) = @_;
239 538         1192 my $k = "#elem$elemidx";
240 538         850 $elemidx++;
241              
242 538         2158 $self->{strmap}->{$k} = [$var, $idx];
243 538 50       1205 $self->{log}->('setelem', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
244 538         1248 return $k;
245             }
246              
247             sub setexpr {
248 1983     1983 0 4247 my ($self, $op, $v1, $v2) = @_;
249 1983         4262 my $k = "#expr$expridx";
250 1983         2848 $expridx++;
251              
252 1983         7879 $self->{strmap}->{$k} = [$op, $v1, $v2];
253 1983 50       4809 $self->{log}->('setexpr', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
254 1983         5423 return $k;
255             }
256              
257             sub setblk {
258 2877     2877 0 5511 my ($self, $type, $a) = @_;
259 2877         5960 my $k = "#blk$blkidx";
260 2877         4059 $blkidx++;
261              
262 2877         10554 $self->{strmap}->{$k} = [$type, $a];
263 2877 50       6607 $self->{log}->('setblk', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
264 2877         6697 return $k;
265             }
266              
267             sub setstmt {
268 853     853 0 1605 my ($self, $s) = @_;
269 853         1916 my $k = "#stmt$stmtidx";
270 853         1355 $stmtidx++;
271              
272 853         2490 $self->{strmap}->{$k} = $s;
273 853 50       1931 $self->{log}->('setstmt', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
274 853         2293 return $k;
275             }
276              
277             sub setpfx {
278 55     55 0 133 my ($self, $s) = @_;
279 55         142 my $k = "#pfx$pfxidx";
280 55         86 $pfxidx++;
281              
282 55         161 $self->{strmap}->{$k} = $s;
283 55 50       138 $self->{log}->('setpfx', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
284 55         148 return $k;
285             }
286              
287             sub setobj {
288 52     52 0 110 my ($self, $s, $property) = @_;
289 52         121 my $k = "#obj$objidx";
290 52         79 $objidx++;
291              
292 52         213 $self->{strmap}->{$k} = [$s, $property];
293 52 50       139 $self->{log}->('setobj', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
294 52         110 return $k;
295             }
296              
297             sub setscope {
298 41     41 0 106 my ($self, $s, $elem) = @_;
299 41         100 my $k = "#scope$scopeidx";
300 41         74 $scopeidx++;
301              
302 41         217 $self->{strmap}->{$k} = [$s, $elem];
303 41 50       99 $self->{log}->('setscope', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
304 41         93 return $k;
305             }
306              
307             sub setref {
308 8     8 0 24 my ($self, $s) = @_;
309 8         36 my $k = "#ref$refidx";
310 8         15 $refidx++;
311              
312 8         49 $self->{strmap}->{$k} = [$s];
313 8 50       25 $self->{log}->('setref', "%s = %s", $k, $s) if $self->{log};
314 8         21 return $k;
315             }
316              
317             sub setclass {
318 69     69 0 169 my ($self, $name, $block, $p) = @_;
319 69         142 my $k = "#class$classidx";
320 69         94 $classidx++;
321              
322 69         248 $self->{strmap}->{$k} = [$name, $block, $p];
323 69 50       165 $self->{log}->('setclass', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
324 69         178 return $k;
325             }
326              
327             sub settrait {
328 1     1 0 5 my ($self, $name, $block) = @_;
329 1         4 my $k = "#trait$traitidx";
330 1         2 $traitidx++;
331              
332 1         4 $self->{strmap}->{$k} = [$name, $block];
333 1 50       5 $self->{log}->('settrait', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
334 1         5 return $k;
335             }
336              
337             sub setinst {
338 34     34 0 93 my ($self, $class, $initcall, $instctx) = @_;
339 34         91 my $k = "#inst$instidx";
340 34         54 $instidx++;
341              
342 34         133 $self->{strmap}->{$k} = [$class, $initcall, $instctx];
343 34 50       80 $self->{log}->('setinst', "%s = %s", $k, $class) if $self->{log};
344 34         94 return $k;
345             }
346              
347             sub setns {
348 12     12 0 26 my ($self, $name, $elem) = @_;
349 12         46 my $k = "#ns$nsidx";
350 12         19 $nsidx++;
351              
352 12         46 $self->{strmap}->{$k} = [$name, $elem];
353 12 50       29 $self->{log}->('setns', "%s = %s", $k, $self->stmt_str($k)) if $self->{log};
354 12         24 return $k;
355             }
356              
357             sub newfh {
358 2     2 0 7 my ($self, $filename, $mode) = @_;
359 2         6 my %file;
360             my $a;
361 2         8 my $fh = "#fh$fhidx";
362 2         4 $fhidx++;
363              
364 2         7 $self->{strmap}->{$fh} = \%file;
365 2         10 $self->{strmap}->{idx}{$fh} = 0;
366              
367 2         7 $file{name} = $filename;
368 2         4 $file{mode} = $mode;
369 2         6 $file{pos} = 0;
370 2 50       9 if ($filename eq '__FILE__') {
371 0         0 $file{buf} = $self->{strmap}->{$filename}; # todo: cleanup
372             } else {
373 2         5 $file{buf} = '';
374 2         6 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 165 my ($self, $s) = @_;
382              
383 71 50       379 unless ($s =~ /^#\w+\d+$/) {
384 0         0 return $s;
385             }
386              
387 71 50       617 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         113 my ($f, $a) = @{$self->{strmap}->{$s}};
  69         205  
409              
410 69         461 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 2373 my ($self, $s) = @_;
539             #defined($s) || die "assert: undefined statement passed to parser->get_strval()";
540              
541 1223 100       6341 if ($s =~ /^(\#(str|num|const)\d+|\#null)$/) {
542 1202         4268 return $self->{strmap}{$s};
543             }
544 21         51 return;
545             }
546              
547             sub get_strval_or_str {
548 199     199 0 468 my ($self, $s) = @_;
549              
550 199 100       731 if ($s =~ /^(\#(str|num|const)\d+|\#null)$/) {
551 64         145 $s = $self->{strmap}{$s};
552             }
553 199         532 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 1908 my ($s) = @_;
567              
568 1079 100       2665 if ($s =~ /^(\#null)$/) {
569 57         260 return 1;
570             }
571 1022         2949 return 0;
572             }
573              
574             sub is_const {
575 7561     7561 0 12446 my ($s) = @_;
576              
577 7561 100       14917 if ($s =~ /^(\#const\d++)$/) {
578 259         868 return 1;
579             }
580 7302         41878 return 0;
581             }
582              
583             sub is_numval {
584 190     190 0 324 my ($s) = @_;
585              
586 190 100       565 if ($s =~ /^(\#num\d+)$/) {
587 135         475 return 1;
588             }
589 55         253 return 0;
590             }
591              
592             sub is_strval {
593 16224     16224 0 27498 my ($s) = @_;
594              
595 16224 100       47039 if ($s =~ /^(\#(str|num|const)\d+|\#null)$/) {
596 5832         21825 return 1;
597             }
598 10392         31618 return 0;
599             }
600              
601             sub is_array {
602 2478     2478 0 4322 my ($s) = @_;
603              
604 2478 100       5585 if ($s =~ /^#arr\d+$/) {
605 968         3428 return 1;
606             }
607 1510         5595 return 0;
608             }
609              
610             sub is_block {
611 12800     12800 0 20498 my ($s) = @_;
612              
613 12800 100       31232 if ($s =~ /^#blk\d+$/) {
614 4254         11124 return 1;
615             }
616 8546         20764 return 0;
617             }
618              
619             sub bighex {
620 4     4 0 12 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       15 if (length($hex) <= 10) {
633 3 50       11 if ($hex =~ /^0X(.*)$/) {
634 0         0 return hex($1);
635             } else {
636 3         15 return hex($hex);
637             }
638             }
639 1         9 my ($high, $low) = $hex =~ /^0[xX]([0-9a-fA-F]{1,8})([0-9a-fA-F]{8})$/;
640 1 50       8 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       97 if ($Config{ivsize} == 4) {
652 6     6   3143 use bignum;
  6         43528  
  6         39  
653 0         0 return hex("0x$low") + (hex("0x$high") << 32);
654             } else {
655 1         29 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 7794 my ($tab, $sym) = @_;
663 3143         4895 push(@{$tab->{tok}}, $sym);
  3143         6501  
664 3143         5780 return;
665             }
666             sub add_open {
667 2271     2271 0 5580 my ($tab, $sym) = @_;
668 2271         3385 push(@{$tab->{tok}}, $sym);
  2271         4734  
669 2271         4359 return;
670             }
671             sub add_close {
672 2263     2263 0 6081 my ($tab, $sym) = @_;
673 2263         3475 my $pos = scalar @{$tab->{tok}};
  2263         3835  
674              
675             # join string literals with '.' operator if possible
676             # (this should also be done by php_decode)
677             #
678 2263 100 66     14332 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         23 my $val = $tab->{strmap}->{$tab->{tok}->[$pos-1]};
685 6 50       16 if ($val != 0) {
686 6         21 my $ch = chr(int($val) & 0xff);
687 6         8 pop(@{$tab->{tok}});
  6         13  
688 6         13 pop(@{$tab->{tok}});
  6         10  
689 6         11 pop(@{$tab->{tok}});
  6         9  
690             #$tab->{log}->('tokenize', "CHR chr($val) [$ch]") if $tab->{log};
691 6         17 $tab->add_str($ch);
692             } else {
693 0         0 push(@{$tab->{tok}}, $sym);
  0         0  
694             }
695             } else {
696 2257         3194 push(@{$tab->{tok}}, $sym);
  2257         4742  
697             }
698 2263         4538 return;
699             }
700             sub add_white {
701 3493     3493 0 8304 my ($tab, $sym) = @_;
702 3493 100       7614 if ($sym eq "\n") {
703 6         12 $tab->{strmap}->{'__LINE__'} += 1;
704 6 50       15 $tab->{debug}->('tokenize', "set linenum: %d", $tab->{strmap}->{'__LINE__'}) if $tab->{debug};
705             }
706             #push(@{$tab->{tok}}, ' ');
707 3493         6327 return;
708             }
709             sub add_comment {
710 8     8 0 26 my ($tab, $sym) = @_;
711             #push(@{$tab->{tok}}, "/*$sym*/");
712 8         19 return;
713             }
714             sub add_sym {
715 2187     2187 0 5662 my ($tab, $sym) = @_;
716 2187 100       4440 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         21 $tab->{warn}->('tokenize', "substitute __LINE__ with %d", $tab->{strmap}->{'__LINE__'});
721 4         203 my $k = $tab->setnum($tab->{strmap}->{'__LINE__'});
722 4         9 push(@{$tab->{tok}}, $k);
  4         10  
723             } else {
724 2183         2832 push(@{$tab->{tok}}, $sym);
  2183         4613  
725             }
726 2187         4351 return;
727             }
728             sub add_var {
729 1780     1780 0 4617 my ($tab, $sym) = @_;
730 1780         2680 push(@{$tab->{tok}}, '$'.$sym);
  1780         4580  
731 1780         3583 return;
732             }
733             sub add_str {
734 1041     1041 0 2043 my ($tab, $sym) = @_;
735              
736 1041 50       2321 if (defined $tab->{strmap}) {
737 1041         1436 my $pos = scalar @{$tab->{tok}};
  1041         1854  
738              
739             # join string literals with '.' operator if possible
740             # (this should also be done by php_decode)
741             #
742 1041 100 100     4935 if (($pos > 1) && ($tab->{tok}->[$pos-1] eq '.') && ($tab->{tok}->[$pos-2] =~ /^#str\d+$/)) {
      100        
743 11         35 my $oldstr = $tab->{strmap}->{$tab->{tok}->[$pos-2]};
744 11         23 pop(@{$tab->{tok}});
  11         20  
745 11         24 pop(@{$tab->{tok}});
  11         21  
746             #$tab->{log}->('tokenize', "JOIN $oldstr . $sym") if $tab->{log};
747 11         28 $sym = $oldstr . $sym;
748             }
749              
750             # remember last linenum for each new #str symbol
751             #
752 1041         3959 $tab->{strmap}->{'__LINEMAP__'}{"#str$stridx"} = $tab->{strmap}->{'__LINE__'};
753              
754             # substitute: 'str' -> #str$i
755             #
756 1041         2276 my $k = $tab->setstr($sym);
757 1041         1711 push(@{$tab->{tok}}, $k);
  1041         2451  
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         2107 return;
764             }
765             sub add_num {
766 538     538 0 1147 my ($tab, $sym) = @_;
767              
768 538 50       1209 if (defined $tab->{strmap}) {
769             # substitute: number -> #num$i
770             #
771 538         719 my $num;
772 538 100       1787 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         776 $num = $sym;
781             }
782 538         1352 my $k = $tab->setnum($num);
783 538         846 push(@{$tab->{tok}}, $k);
  538         1236  
784             } else {
785 0         0 push(@{$tab->{tok}}, $sym);
  0         0  
786             }
787 538         1186 return;
788             }
789             sub add_script_start {
790 8     8 0 21 my ($tab, $sym) = @_;
791             #push(@{$tab->{tok}}, $sym);
792 8         19 return;
793             }
794             sub add_script_end {
795 799     799 0 1926 my ($tab, $sym) = @_;
796             #push(@{$tab->{tok}}, $sym);
797 799         1594 return;
798             }
799             sub add_noscript {
800 8     8 0 22 my ($tab, $sym) = @_;
801              
802 8 100 100     13 if ((scalar @{$tab->{tok}} > 0) && ($tab->{tok}->[-1] ne ';')) {
  8         32  
803             # append ';' if missing at end of php-block
804 1         5 $tab->add(';');
805             }
806 8         32 $tab->add_sym('echo');
807 8         29 $tab->add_str($sym);
808 8         27 $tab->add(';');
809 8         22 $tab->add_script_end('');
810 8         16 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         153075 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   477865 };
  6         16  
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 34819 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       57519 if ($s =~/^\$(GLOBALS\$|#inst\d+\$|[\w\x80-\xff]+\$)?(\$|[^\$]*)$/) {
943 7443         20538 return 1;
944             }
945 14033         39550 return 0;
946             }
947              
948             sub is_strict_variable {
949 10339     10339 0 20194 my ($s) = @_;
950              
951 10339 100       29952 if ($s =~/^\$(GLOBALS\$|#inst\d+\$|[\w\x80-\xff]+\$)?[a-zA-Z_\x80-\xff][a-zA-Z0-9_\x80-\xff]*$/) {
952 4442         27446 return 1;
953             }
954 5897         31352 return 0;
955             }
956              
957             sub is_symbol {
958 2086     2086 0 4300 my ($s) = @_;
959              
960 2086 100       6911 if ($s =~/^[a-zA-Z_\x80-\xff][a-zA-Z0-9_\x80-\xff]*$/) {
961 1814         5130 return 1;
962             }
963 272         1522 return 0;
964             }
965              
966             sub is_magic_const {
967 17     17 0 36 my ($self, $s) = @_;
968              
969 17 50       63 if ($s =~ /^#const\d+$/) {
970 17 100       62 if (exists $magic_constants{$self->{strmap}->{$s}}) {
971 12         73 return $self->{strmap}->{$s};
972             }
973             }
974 5         44 return;
975             }
976              
977             # check if statement is empty block
978             #
979             sub is_empty_block {
980 148     148 0 279 my ($self, $s) = @_;
981              
982 148 100       280 if (is_block($s)) {
983 84         143 my ($type, $a) = @{$self->{strmap}->{$s}};
  84         196  
984 84 100       234 if (scalar @$a == 0) {
985 79         220 return 1;
986             }
987             }
988 69         190 return 0;
989             }
990              
991             # flatten block (and remove #null statements)
992             #
993             sub flatten_block {
994 3793     3793 0 7178 my ($self, $s, $out) = @_;
995              
996 3793 100       6710 if (is_block($s)) {
997 694         1051 my ($type, $a) = @{$self->{strmap}{$s}};
  694         1671  
998 694         1370 foreach my $stmt (@$a) {
999 876         1716 $self->flatten_block($stmt, $out);
1000             }
1001             } else {
1002 3099 100       6452 if ($s ne '#null') {
1003 2996         5686 push(@$out, $s);
1004             }
1005             }
1006 3793         8049 return;
1007             }
1008              
1009             # flatten block with single statement
1010             #
1011             sub flatten_block_if_single {
1012 245     245 0 453 my ($self, $s) = @_;
1013              
1014 245 100       496 if (is_block($s)) {
1015 238         381 my ($type, $a) = @{$self->{strmap}{$s}};
  238         561  
1016 238 100       644 if (scalar @$a == 1) {
1017 147         413 return $a->[0];
1018             }
1019             }
1020 98         306 return $s;
1021             }
1022              
1023             # create and split global var
1024             #
1025             sub global_var {
1026 59     59 0 131 my ($global) = @_;
1027 59         168 return '$GLOBALS' . $global;
1028             }
1029              
1030             sub global_split {
1031 6053     6053 0 10259 my ($var) = @_;
1032 6053         9443 my ($global) = $var =~ /^\$GLOBALS(\$.*)$/;
1033 6053         13167 return $global;
1034             }
1035              
1036             # create and split method name
1037             #
1038             sub method_name {
1039 354     354 0 709 my ($class, $name) = @_;
1040 354         1077 return $class . '::' . $name;
1041             }
1042              
1043             sub method_split {
1044 2080     2080 0 3739 my ($method) = @_;
1045             # allow namespace prefix
1046 2080         4423 my ($class, $name) = $method =~ /^(#inst\d+|[\w\x80-\xff\\]+)::([\w\x80-\xff]+)$/;
1047 2080         4897 return ($class, $name);
1048             }
1049              
1050             # create and split instance var
1051             #
1052             sub inst_var {
1053 53     53 0 124 my ($inst, $var) = @_;
1054 53         164 return '$' . $inst . $var;
1055             }
1056              
1057             sub inst_split {
1058 7042     7042 0 11162 my ($instvar) = @_;
1059 7042         12551 my ($inst, $var) = $instvar =~ /^\$(#inst\d+|[\w\x80-\xff]+)(\$.*)$/;
1060 7042         15743 return ($inst, $var);
1061             }
1062              
1063             # create and split namespace name
1064             #
1065             sub ns_name {
1066 31     31 0 60 my ($name, $elem) = @_;
1067 31         90 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 24 my ($self, $var) = @_;
1080              
1081 14 100       47 if ($var =~ /^#ns\d+$/) {
    100          
1082 3         4 my ($n, $e) = @{$self->{strmap}{$var}};
  3         9  
1083              
1084 3 100       9 unless (defined $n) {
1085 2         5 $n = ''; # toplevel
1086             }
1087 3         10 $e = $self->ns_to_str($e);
1088 3 50       8 if (defined $e) {
1089 3         23 return ns_name($n, $e);
1090             }
1091             } elsif (is_strval($var)) {
1092 8         24 return $self->{strmap}{$var};
1093             } else {
1094 3         8 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 192 my ($self, $var) = @_;
1105              
1106 90 100       168 if (is_strval($var)) {
1107 79         164 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         263 my ($suffix) = $str =~ /^(\$$|[^\$]*)/;
1113 79         283 return '$' . $suffix;
1114             }
1115 11         34 return;
1116             }
1117              
1118             # $GLOBALS['str'] -> $str
1119             #
1120             sub globalvar_to_var {
1121 604     604 0 1343 my ($self, $base, $idx) = @_;
1122              
1123 604 100       1421 if ($base =~ /^\$GLOBALS$/) {
1124 124         325 my $idxval = $self->get_strval($idx);
1125 124 100       279 if (defined $idxval) {
1126             # variable names are only handled up to first '$'.
1127             # also 'null' is allowed (represented as '' or ${null})
1128             #
1129 123         407 my ($suffix) = $idxval =~ /^(\$$|[^\$]*)/;
1130 123         443 return '$' . $suffix;
1131             }
1132             }
1133 481         1052 return;
1134             }
1135              
1136             # return base var of multi dimensional elem
1137             #
1138             sub elem_base {
1139 363     363 0 715 my ($self, $s) = @_;
1140              
1141 363         895 while ($s =~ /^#elem\d+$/) {
1142 54         87 my ($v, $i) = @{$self->{strmap}->{$s}};
  54         149  
1143              
1144 54 100       120 if (defined $i) {
1145             # add resolvable globals
1146             #
1147 37         72 my $g = $self->globalvar_to_var($v, $i);
1148 37 100       106 if (defined $g) {
1149 8         59 $g = global_var($g);
1150 8         46 return $g;
1151             }
1152             }
1153 46         115 $s = $v;
1154             }
1155 355         758 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 1782 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       2610 if (exists $self->{strmap}->{'__LINEMAP__'}{$var}) {
1173 1026         1702 my $val = $self->{strmap}->{'__LINEMAP__'}{$var};
1174 1026 50       2290 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         1694 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 1428 my ($list) = @_;
1195             # remove empty fields
1196 785         1839 my @filtered = grep { $_ !~ /^\s+$/ } @$list;
  13177         27393  
1197              
1198             # remove comments
1199 785         1745 @filtered = grep { $_ !~ /^\/\*.*\*\/$/ } @filtered;
  13177         24052  
1200              
1201 785         1850 return \@filtered;
1202             }
1203              
1204             sub unquote_names {
1205 6083     6083 0 10752 my ($str) = @_;
1206              
1207             # todo: is this really needed?
1208 6083         8044 if (1) {
1209             # \xXX
1210 6083         11075 $str =~ s/\\x([0-9a-fA-F]{2})/chr(hex($1))/ge;
  0         0  
1211             }
1212 6083         11539 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 332 my ($self, $tok, $close, $arr) = @_;
1236              
1237 145         239 while (1) {
1238 244 50       561 if (scalar @$tok == 0) {
1239 0         0 last;
1240             }
1241 244 100       610 if ($tok->[0] eq $close) {
1242 25         53 shift @$tok;
1243 25         53 last;
1244             }
1245 219         545 my $val = $self->read_statement($tok, undef);
1246 219 50 33     966 if (!defined $val || ($val eq $close)) {
1247 0         0 last;
1248             }
1249 219 100       447 if ($val eq ',') {
1250 1         14 $arr->set(undef, undef);
1251 1         2 next; # allow empty fields for list()
1252             }
1253 218 50       481 if (scalar @$tok > 0) {
1254 218 100       656 if ($tok->[0] eq $close) {
    100          
    50          
1255 103         168 shift @$tok;
1256 103         380 $arr->set(undef, $val);
1257 103         201 last;
1258             } elsif ($tok->[0] eq ',') {
1259 82         146 shift @$tok;
1260 82         300 $arr->set(undef, $val);
1261 82         150 next;
1262             } elsif ($tok->[0] eq '=>') {
1263 33         45 shift @$tok;
1264 33         63 my $key = $val;
1265 33 100       121 if ($key =~ /^#expr\d+$/) {
    100          
1266 2         5 my ($op, $v1, $v2) = @{$self->{strmap}->{$key}};
  2         7  
1267 2 50 33     13 if (($op eq '-') && !defined $v1) {
1268 2         7 my $str = $self->get_strval($v2);
1269 2 50 33     10 if (defined $str && is_int_index($str)) {
1270 2         8 $key = -$str;
1271             }
1272             }
1273             } elsif (is_null($key)) {
1274 1         5 $key = $self->setstr(''); # null maps to '' array index
1275             }
1276 33         95 $val = $self->read_statement($tok, undef);
1277 33 50 33     171 if (!defined $val || ($val eq $close)) {
1278 0         0 $arr->set($key, undef);
1279 0         0 last;
1280             }
1281 33         137 $arr->set($key, $val);
1282 33 50       85 if (scalar @$tok > 0) {
1283 33 100       117 if ($tok->[0] eq $close) {
    50          
1284 17         29 shift @$tok;
1285 17         40 last;
1286             } elsif ($tok->[0] eq ',') {
1287 16         25 shift @$tok;
1288 16         32 next;
1289             }
1290             } else {
1291 0         0 last;
1292             }
1293             }
1294             }
1295             }
1296 145         271 return;
1297             }
1298              
1299             # last_op is optional param
1300             #
1301             sub _read_statement {
1302 13401     13401   21686 my ($self, $tok, $last_op) = @_;
1303              
1304 13401 100 66     397126 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         6010 my $sym = shift @$tok;
1306 3389         7179 return $sym;
1307             } elsif ((scalar @$tok > 0) && ($tok->[0] =~ /^null$/i)) {
1308 16         47 shift @$tok;
1309 16         43 unshift(@$tok, '#null');
1310 16         43 my $res = $self->read_statement($tok, $last_op);
1311 16         36 return $res;
1312             } elsif ((scalar @$tok > 1) && ($tok->[0] eq '{')) {
1313             # block expression { statement1; statement2; ... }
1314             # also allow empty { } block
1315             #
1316 184         397 shift @$tok;
1317 184         636 my $arglist = $self->read_code_block($tok, '}', ';');
1318 184         570 my $k = $self->setblk('std', $arglist);
1319 184         447 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         135 shift @$tok;
1327 60         194 my $arglist = $self->read_block($tok, ')', undef);
1328              
1329 60 50       196 if (scalar @$arglist > 0) {
1330 60 50       148 if (scalar @$arglist == 1) {
1331 60         98 my $ref = $arglist->[0];
1332 60         152 my $str = $self->get_strval_or_str($ref);
1333             #$self->{log}->('parse', "braces: $ref, $str") if $self->{log};
1334 60 100 100     144 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         3 my $k;
1341 2 100       12 if ($str eq 'int') {
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1342 1         6 $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         5 $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         7 unshift(@$tok, $k);
1370 2         6 $res = $self->read_statement($tok, $last_op);
1371 2         7 return $res;
1372             }
1373 58 100 100     123 if (is_strval($ref) || ($ref =~ /^#expr\d+$/) || ($ref =~ /^#call\d+$/) || ($ref =~ /^#inst\d+$/)) {
      100        
      66        
1374 56         167 unshift(@$tok, $ref);
1375 56         139 my $res = $self->read_statement($tok, $last_op);
1376 56         163 return $res;
1377             }
1378             }
1379 2         18 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         7 unshift(@$tok, $res);
1385 2         11 $res = $self->read_statement($tok, $last_op);
1386 2         6 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         24 shift @$tok;
1394              
1395 12         33 my $arr = $self->newarr();
1396 12         39 $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         32 unshift(@$tok, $arr->{name});
1403 12         28 my $res = $self->read_statement($tok, $last_op);
1404 12         27 return $res;
1405             } elsif ((scalar @$tok > 1) && ($tok->[0] eq '&')) {
1406             # variable reference
1407             # & $var
1408             #
1409 8         18 shift @$tok;
1410              
1411 8         23 my $var = $self->read_statement($tok, undef);
1412 8         44 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         11905 my $sym = shift @$tok;
1424 6083         12167 my $var = unquote_names($sym);
1425              
1426 6083 100 100     12318 if (is_strict_variable($var) || ($var =~ /^#/)) {
    50          
    50          
    100          
    100          
    50          
1427 5733 100       12621 if ($var =~ /^#str/) {
1428 1027         2299 $self->updateline($var);
1429             }
1430 5733         13718 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         13 return $self->setnum(0);
1442             } elsif ($var =~ /^true$/i) {
1443 3         12 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         920 my $k = $self->setconst($var);
1449 344 50 100     1112 if ((scalar @$tok > 1) && ($tok->[0] eq ':') && ($tok->[1] ne ':') && !defined $last_op) {
      66        
      66        
1450 2         5 shift @$tok;
1451 2         13 $k = $self->setstmt(['label', $k]); # goto label
1452             }
1453 344         848 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         354 shift @$tok;
1501 147         314 my $all_str = 1;
1502 147         263 my @args = ();
1503 147         209 while (1) {
1504 156         348 my $arg = $self->read_statement($tok, undef);
1505              
1506 156 100       381 unless (is_strval($arg)) {
1507 64         130 $all_str = 0;
1508             }
1509 156 50       414 if ($arg ne ',') {
1510 156         410 push(@args, $arg);
1511             }
1512 156 100 100     668 unless ((scalar @$tok > 0) && ($tok->[0] eq ',')) {
1513 147         286 last;
1514             }
1515 9         26 shift @$tok;
1516             }
1517 147         525 my $k = $self->setstmt(['echo', \@args]);
1518              
1519             # execute expr & might continue with operation
1520             #
1521 147         384 unshift(@$tok, $k);
1522 147         353 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         26 shift @$tok;
1534              
1535 10         21 my $arg = ''; # toplevel
1536 10 100       23 if ($tok->[0] ne '{') {
1537 9         23 $arg = $self->read_statement($tok, undef);
1538 9         24 my $str = $self->ns_to_str($arg);
1539 9 50       18 if (defined $str) {
1540 9         16 $arg = $str;
1541             } else {
1542 0         0 $self->{warn}->('parse', "bad namespace: %s", $arg);
1543             }
1544             }
1545 10         13 my $block;
1546 10 100 66     39 if ((scalar @$tok > 0) && ($tok->[0] eq '{')) {
1547 2         6 shift @$tok;
1548 2         7 my $arglist = $self->read_code_block($tok, '}', ';');
1549 2         6 $block = $self->setblk('std', $arglist);
1550             }
1551 10         36 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         17 shift @$tok;
1572 6         15 my @args = ();
1573 6         12 while (1) {
1574 6         33 my $arg = $self->read_statement($tok, undef);
1575              
1576 6         16 push(@args, $arg);
1577 6 50 33     43 unless ((scalar @$tok > 0) && ($tok->[0] eq ',')) {
1578 6         17 last;
1579             }
1580 0         0 shift @$tok;
1581             }
1582 6         28 return $self->setstmt(['global', \@args]);
1583             } elsif ((scalar @$tok > 1) && (lc($tok->[0]) eq 'return')) {
1584 118         283 shift @$tok;
1585 118         356 my $res = $self->read_statement($tok, undef);
1586             # remove trailing ';' if evaluated as string
1587             #
1588 118 100 66     635 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1589 99         164 shift @$tok;
1590             }
1591 118         479 return $self->setstmt(['return', $res]);
1592             } elsif ((scalar @$tok > 1) && (lc($tok->[0]) eq 'goto')) {
1593 1         4 shift @$tok;
1594 1         7 my $res = $self->read_statement($tok, undef);
1595             # remove trailing ';' if evaluated as string
1596             #
1597 1 50 33     10 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1598 1         3 shift @$tok;
1599             }
1600 1         4 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         4 shift @$tok;
1607 2         8 my $res = $self->read_statement($tok, undef); # optional level
1608 2 50 33     27 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1609 0         0 shift @$tok;
1610             }
1611 2         10 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         139 my $type = shift @$tok;
1621 55         170 my $pfx = {$type => 1};
1622              
1623 55 100 66     326 if ((scalar @$tok > 0) && (lc($tok->[0]) =~ /^(var|static|public|protected|private|final|const)$/)) {
1624 7         16 $type = shift @$tok;
1625 7         16 $pfx->{$type} = 1;
1626             }
1627 55         168 my $k = $self->setpfx($pfx);
1628 55         136 unshift(@$tok, $k);
1629 55         166 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         284 shift @$tok;
1636 124         227 shift @$tok;
1637 124         360 my $expr = $self->read_block($tok, ')', undef);
1638 124         350 my $then;
1639             my $else;
1640              
1641 124 100 66     590 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         3 shift @$tok;
1646 1         4 my $block = $self->read_code_block($tok, 'endif', ';');
1647 1         4 $then = $self->setblk('std', $block);
1648             } else {
1649 123         274 $then = $self->read_statement($tok);
1650 123 100       358 if (!is_block($then)) {
1651 16 50 66     83 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1652 0         0 shift @$tok;
1653             }
1654             # always put '{ .. }' braces around if/else
1655 16         57 $then = $self->setblk('std', [$then]);
1656             }
1657             }
1658 124 100 100     881 if ((scalar @$tok > 0) && (lc($tok->[0]) eq 'else')) {
    100 100        
1659 17         51 shift @$tok;
1660 17 50 33     113 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         47 $else = $self->read_statement($tok);
1669 17 100       81 if (!is_block($else)) {
1670 1 50 33     8 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1671 1         2 shift @$tok;
1672             }
1673 1         3 $else = $self->setblk('std', [$else]);
1674             }
1675             }
1676             } elsif ((scalar @$tok > 0) && (lc($tok->[0]) eq 'elseif')) {
1677 6         17 shift @$tok;
1678 6         18 unshift(@$tok, 'if');
1679 6         20 $else = $self->read_statement($tok, undef);
1680 6 50       24 if (!is_block($else)) {
1681 6         49 $else = $self->setblk('std', [$else]);
1682             }
1683             }
1684 124 50       314 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         559 return $self->setstmt(['if', $expr->[0], $then, $else]);
1690             } elsif ((scalar @$tok > 3) && (lc($tok->[0]) eq 'switch') && ($tok->[1] eq '(')) {
1691 9         26 shift @$tok;
1692 9         14 shift @$tok;
1693 9         31 my $expr = $self->read_block($tok, ')', undef);
1694 9         20 my $block = [];
1695 9 50 33     75 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         32 $block = $self->read_code_block($tok, '}', ';');
1704             } else {
1705 0         0 $self->{warn}->('parse', "expected switch block {}");
1706             }
1707 9 50       43 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         26 my @cases = ();
1713 9         13 my $inst;
1714 9         23 foreach my $e (@$block) {
1715 29 100 100     130 if ($e =~ /^#stmt\d+$/ && (lc($self->{strmap}->{$e}->[0]) eq 'case')) {
1716 15         38 my $c = $self->{strmap}->{$e}->[1]; # undef for default case
1717 15         25 $inst = [];
1718 15         38 my $b = $self->setblk('case', $inst); # block content added in next iterations
1719 15         86 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         28 push (@$inst, $e);
1726             }
1727             }
1728 9         38 return $self->setstmt(['switch', $expr->[0], \@cases]);
1729             } elsif ((scalar @$tok > 2) && (lc($tok->[0]) eq 'case')) {
1730 15         34 shift @$tok;
1731 15         36 my $expr = $self->read_statement($tok, undef);
1732             # 'case' might also be terminated by ';'
1733             #
1734 15 100 66     93 if ((scalar @$tok > 0) && ($tok->[0] eq ':') || ($tok->[0] eq ';')) {
      66        
1735 14         24 shift @$tok;
1736             }
1737 15 100 66     61 if ($expr =~ /^#stmt\d+$/ && (lc($self->{strmap}->{$expr}->[0]) eq 'label')) {
1738 1         3 $expr = $self->{strmap}->{$expr}->[1]; # label -> const
1739             }
1740 15         52 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         4 shift @$tok;
1751 1         4 my $try;
1752             my $finally;
1753              
1754             # https://www.php.net/manual/en/language.exceptions.php
1755             #
1756 1         4 $try = $self->read_statement($tok);
1757 1 50       5 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         5 my @catches = ();
1765 1   66     11 while ((scalar @$tok > 1) && (lc($tok->[0]) eq 'catch') && ($tok->[1] eq '(')) {
      66        
1766 1         4 shift @$tok;
1767 1         2 shift @$tok;
1768 1         4 my $exception = $self->read_block($tok, ')', undef);
1769 1         13 my $block= $self->read_statement($tok);
1770              
1771 1 50       3 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     28 if ((scalar @$tok > 0) && (lc($tok->[0]) eq 'finally')) {
1781 1         4 shift @$tok;
1782 1         6 $finally= $self->read_statement($tok);
1783              
1784 1 50       4 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         5 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         66 shift @$tok;
1800 20         67 my $expr1 = $self->read_code_block($tok, ';', ',');
1801 20         66 my $expr2 = $self->read_code_block($tok, ';', ',');
1802 20         110 my $expr3 = $self->read_code_block($tok, ')', ',');
1803 20         76 my $block;
1804 20 50 33     113 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       62 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         61 my $pre = $self->setblk('expr', $expr1);
1822 20         57 my $cond = $self->setblk('expr', $expr2);
1823 20         49 my $post = $self->setblk('expr', $expr3);
1824 20         93 return $self->setstmt(['for', $pre, $cond, $post, $block]);
1825             } elsif ((scalar @$tok > 3) && (lc($tok->[0]) eq 'while') && ($tok->[1] eq '(')) {
1826 10         24 shift @$tok;
1827 10         20 shift @$tok;
1828 10         31 my $expr = $self->read_block($tok, ')', ',');
1829 10         18 my $block;
1830 10 50 33     66 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         24 $block = $self->read_statement($tok);
1839 10 100       27 if (!is_block($block)) {
1840 1 50 33     9 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1841 1         3 shift @$tok;
1842             }
1843             # always put '{ .. }' braces around if/else
1844 1         6 $block = $self->setblk('std', [$block]);
1845             }
1846             }
1847 10 50       33 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         40 return $self->setstmt(['while', $expr->[0], $block]);
1853             } elsif ((scalar @$tok > 3) && (lc($tok->[0]) eq 'do') && ($tok->[1] eq '{')) {
1854 7         16 shift @$tok;
1855 7         16 my $block;
1856             my $expr;
1857              
1858 7         17 $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     59 if ((scalar @$tok > 3) && (lc($tok->[0]) eq 'while') && ($tok->[1] eq '(')) {
      33        
1867 7         13 shift @$tok;
1868 7         13 shift @$tok;
1869 7         20 $expr = $self->read_block($tok, ')', ',');
1870              
1871 7 50       24 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         37 return $self->setstmt(['do', $expr->[0], $block]);
1882             } elsif ((scalar @$tok > 3) && (lc($tok->[0]) eq 'foreach') && ($tok->[1] eq '(')) {
1883 18         49 shift @$tok;
1884 18         31 shift @$tok;
1885 18         62 my $expr = $self->read_block($tok, ')', ',');
1886 18         35 my $key;
1887             my $value;
1888              
1889 18 100 66     123 if ((scalar @$expr == 3) && (lc($expr->[1]) eq 'as')) {
    50 33        
      33        
1890 6         14 $value = $expr->[2];
1891             } elsif ((scalar @$expr == 5) && (lc($expr->[1]) eq 'as') && ($expr->[3] eq '=>')) {
1892 12         23 $key = $expr->[2];
1893 12         19 $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         29 my $block;
1900 18 50 33     72 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         42 $block = $self->read_statement($tok);
1909 18 100       44 if (!is_block($block)) {
1910 1 50 33     8 if ((scalar @$tok > 0) && ($tok->[0] eq ';')) {
1911 1         4 shift @$tok;
1912             }
1913             # always put '{ .. }' braces around if/else
1914 1         5 $block = $self->setblk('std', [$block]);
1915             }
1916             }
1917 18         80 return $self->setstmt(['foreach', $expr->[0], $key, $value, $block]);
1918             } elsif ((scalar @$tok > 2) && ($tok->[0] =~ /^array$/i) && ($tok->[1] eq '(')) {
1919 133         326 shift @$tok;
1920 133         235 shift @$tok;
1921              
1922 133         375 my $arr = $self->newarr();
1923 133         485 $self->read_array($tok, ')', $arr);
1924              
1925             # execute expr & might continue with operation -> 'array(...)[idx]'?
1926             #
1927 133         317 unshift(@$tok, $arr->{name});
1928 133         384 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         672 my $pfx = shift @$tok;
1931 228         475 my $p = {};
1932              
1933 228 100       725 if ($pfx =~ /^#pfx\d+$/) {
1934 19         59 $p = $self->{strmap}->{$pfx};
1935 19         31 shift @$tok;
1936             }
1937 228         394 my $cmd;
1938              
1939             # also allow anonymous funcs: http://php.net/manual/en/functions.anonymous.php
1940             #
1941 228 100       560 if ($tok->[0] ne '(') {
1942 212         418 my $sym = shift @$tok;
1943 212         722 $cmd = $self->read_statement([$sym], undef);
1944 212 100       644 if (is_strval($cmd)) {
1945 211         559 $cmd = $self->{strmap}{$cmd};
1946             }
1947             }
1948 228         492 my $arglist = [];
1949 228 50 33     973 if ((scalar @$tok > 0) && ($tok->[0] eq '(')) {
1950 228         406 shift @$tok;
1951 228         679 $arglist = $self->read_block($tok, ')', ',');
1952             } else {
1953 0         0 $self->{warn}->('parse', "expected function arglist ()");
1954             }
1955 228         485 my $block = [];
1956 228 50 33     984 if ((scalar @$tok > 0) && ($tok->[0] eq '{')) {
1957 228         398 shift @$tok;
1958 228         608 $block = $self->read_code_block($tok, '}', ';');
1959             } else {
1960 0         0 $self->{warn}->('parse', "expected function block {}");
1961             }
1962 228         749 $block = $self->setblk('std', $block);
1963              
1964             # function are registered later via registerfun
1965             #
1966 228         703 my $k = $self->setfun($cmd, $arglist, $block, $p);
1967              
1968 228 100       530 unless (defined $cmd) {
1969             # anonymous functions might be called directly -> 'function () { return 1; }()'
1970             #
1971 16         40 unshift(@$tok, $k);
1972 16         46 $k = $self->read_statement($tok, $last_op);
1973             }
1974 228         620 return $k;
1975             } elsif ((scalar @$tok > 3) && ((lc($tok->[0]) eq 'class') || (($tok->[0] =~ /^#pfx\d+$/) && (lc($tok->[1]) eq 'class')))) {
1976 56         185 my $pfx = shift @$tok;
1977 56         128 my $p = {};
1978              
1979 56 50       152 if ($pfx =~ /^#pfx\d+$/) {
1980 0         0 $p = $self->{strmap}->{$pfx};
1981 0         0 shift @$tok;
1982             }
1983 56         107 my $name = shift @$tok;
1984              
1985             # http://php.net/manual/en/language.oop5.basic.php
1986             #
1987 56 50       156 if ($tok->[0] eq 'extends') {
1988 0         0 shift @$tok;
1989 0         0 $p->{parent} = shift @$tok;
1990             }
1991 56         145 my $block = [];
1992 56 50 33     253 if ((scalar @$tok > 0) && ($tok->[0] eq '{')) {
1993 56         77 shift @$tok;
1994 56         168 $block = $self->read_block($tok, '}', ';');
1995             }
1996 56         144 $block = $self->setblk('std', $block);
1997 56         171 return $self->setclass($name, $block, $p);
1998             } elsif ((scalar @$tok > 3) && (lc($tok->[0]) eq 'trait')) {
1999 1         3 shift @$tok;
2000 1         3 my $name = shift @$tok;
2001              
2002             # https://www.php.net/manual/en/language.oop5.traits.php
2003             #
2004 1         3 my $block = [];
2005 1 50 33     7 if ((scalar @$tok > 0) && ($tok->[0] eq '{')) {
2006 1         2 shift @$tok;
2007 1         4 $block = $self->read_block($tok, '}', ';');
2008             }
2009 1         5 $block = $self->setblk('std', $block);
2010 1         6 return $self->settrait($name, $block);
2011             } elsif ((scalar @$tok > 1) && ($tok->[0] =~ /^#pfx\d+$/)) {
2012 36         107 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       134 if (exists $self->{strmap}->{$sym}) {
2018 36         71 my $pfx = $self->{strmap}->{$sym};
2019 36 100       111 if (exists $pfx->{static}) {
2020 11         23 my @args = ();
2021 11         23 while (1) {
2022 11         40 my $arg = $self->read_statement($tok, undef);
2023              
2024 11         29 push(@args, $arg);
2025 11 50 33     75 unless ((scalar @$tok > 0) && ($tok->[0] eq ',')) {
2026 11         21 last;
2027             }
2028 0         0 shift @$tok;
2029             }
2030 11         45 return $self->setstmt(['static', \@args, $pfx]);
2031             }
2032 25 100       121 if (exists $pfx->{const}) {
2033 9         20 my @args = ();
2034 9         22 while (1) {
2035 9         31 my $arg = $self->read_statement($tok, undef);
2036              
2037 9         26 push(@args, $arg);
2038 9 50 33     61 unless ((scalar @$tok > 0) && ($tok->[0] eq ',')) {
2039 9         23 last;
2040             }
2041 0         0 shift @$tok;
2042             }
2043 9         40 return $self->setstmt(['const', \@args, $pfx]);
2044             }
2045             }
2046 16         44 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         2223 my $sym = shift @$tok;
2052 721         1365 my $cmd = $sym;
2053              
2054 721 100       1665 unless (is_symbol($sym)) {
2055 78         319 $cmd = $self->read_statement([$sym], undef);
2056             }
2057 721 100 100     2328 if (defined $last_op && ($last_op eq '$')) {
2058             # handle case: $$var(x) is ${$var}(x)
2059 1         3 return $cmd;
2060             }
2061 720 100 100     1916 if (defined $last_op && ($last_op eq '::')) {
2062             # handle case: (class::member)(x)
2063 23         58 return $cmd;
2064             }
2065 697 100 100     2002 if (defined $last_op && ($last_op eq '->')) {
2066             # handle case: ($obj->method)(x)
2067 26         73 return $cmd;
2068             }
2069 671 100 100     1561 if (defined $last_op && ($last_op eq '\\')) {
2070             # handle case: (ns \\ cmd)(x)
2071 2         6 return $cmd;
2072             }
2073 669 100       1394 if (is_strict_variable($sym)) {
2074 16         38 $cmd = $sym; # don't insert copy anonymous function here
2075             }
2076 669         1089 shift @$tok;
2077              
2078 669 50 33     1532 if (is_strval($cmd) && !is_null($cmd)) {
2079 0         0 $cmd = $self->{strmap}{$cmd};
2080             }
2081 669 50       1532 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         1909 my $arglist = $self->read_block($tok, ')', ',');
2089 669         1108 my $k;
2090 669 100       1634 if ($cmd eq 'unset') {
    100          
2091 5         23 $k = $self->setstmt(['unset', $arglist]);
2092             } elsif ($cmd eq 'list') {
2093 2         10 my $arr = $self->newarr();
2094 2         10 foreach my $val (@$arglist) {
2095 4         11 $arr->set(undef, $val);
2096             }
2097 2         7 $k = $arr->{name};
2098             } else {
2099 662         1732 $k = $self->setcall($cmd, $arglist);
2100             }
2101 669         1558 unshift(@$tok, $k);
2102 669         1534 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         28 shift @$tok;
2120 6         26 my $res = $self->read_statement($tok, '$');
2121 6         18 my $k = $self->setexpr('$', undef, $res);
2122              
2123 6         15 unshift(@$tok, $k);
2124 6         17 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         155 shift @$tok;
2139 78         171 shift @$tok;
2140              
2141 78         227 my $arglist = $self->read_block($tok, '}', undef);
2142 78         150 my $k;
2143 78 50       225 if (scalar @$arglist == 1) {
2144 78         140 my $res = $arglist->[0];
2145 78 100       192 if (is_strval($res)) {
2146 21         64 my $str = $self->{strmap}{$res};
2147 21 100       80 if (is_symbol($str)) {
2148 16         58 my $var = '$' . $str;
2149 16         39 unshift(@$tok, $var);
2150 16         37 return $self->read_statement($tok, $last_op);
2151             }
2152             }
2153 62         192 $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         177 unshift(@$tok, $k);
2160 62         155 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         1096 my $sym = shift @$tok;
2179              
2180 420 100 100     1266 if (defined $last_op && ($last_op eq '::')) {
2181             # handle case: (class::$var)(x)
2182 4         13 return $sym;
2183             }
2184 416 50 66     944 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         684 my $arglist;
2190              
2191 416 100       769 if ($bracket eq '[') {
2192 414         1053 $arglist = $self->read_index_block($tok, ']', undef);
2193             } else {
2194 2         8 $arglist = $self->read_index_block($tok, '}', undef);
2195             }
2196 416 50       955 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     1465 if ((scalar @$arglist == 1) && is_strval($arglist->[0])) {
    50 66        
2202 320         628 my $str = $arglist->[0];
2203 320         517 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         1135 my $k = $self->setelem($sym, $arglist->[0]);
2221              
2222             # execute expr & might continue with lower prio operation
2223             #
2224 416         964 unshift(@$tok, $k);
2225 416         924 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         36 my $op = shift @$tok;
2231 12         28 shift @$tok;
2232              
2233 12         57 my $var = $self->read_statement($tok, "$op$op");
2234 12         73 my $k = $self->setexpr($op.$op, undef, $var);
2235              
2236             # execute expr & might continue with lower prio operation
2237             #
2238 12         33 unshift(@$tok, $k);
2239 12         34 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         18 my $op = shift @$tok;
2258              
2259 7         21 my $val = $self->read_statement($tok, $op);
2260 7         21 my $k = $self->setns(undef, $val); # toplevel namespace
2261              
2262             # execute expr & might continue with lower prio operation
2263             #
2264 7         18 unshift(@$tok, $k);
2265 7         16 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         216 my $op = shift @$tok;
2274 66         137 my $val;
2275              
2276 66 100 100     376 if (($op eq '+') || ($op eq '-')) {
    100          
2277 7         27 $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         115 $val = $self->read_statement($tok, $op);
2283 39 100       167 if ($val =~ /^#(str|const)/) {
2284 7         29 $val = $self->setcall($self->{strmap}->{$val}, []);
2285             }
2286             } else {
2287 20         80 $val = $self->read_statement($tok, $op);
2288             }
2289 66         250 my $k = $self->setexpr($op, undef, $val);
2290              
2291             # execute expr & might continue with lower prio operation
2292             #
2293 66         176 unshift(@$tok, $k);
2294 66         210 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     4044 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         45 my $sym = shift @$tok;
2311 16         36 my $op = shift @$tok;
2312 16         28 shift @$tok;
2313 16         63 unshift(@$tok, ($sym, $op.$op));
2314             # fall through
2315             }
2316 1329 100 100     3587 if (($tok->[2] eq '=') && ($tok->[1] =~ /^([\.\+\-\*\/\^\&\|\%]|<<|>>|\*\*|\?\?)$/)) {
2317             # num += ...
2318             # num .= ...
2319             #
2320 29         99 my $sym = shift @$tok;
2321 29         79 my $op = shift @$tok;
2322 29         63 shift @$tok;
2323              
2324             # keep in_block flag for '='
2325 29         88 my $op2 = $self->read_statement($tok, undef);
2326              
2327             # keep precedence of $op against following expr
2328 29         90 my $k2 = $self->setexpr($op, $sym, $op2);
2329 29         111 unshift(@$tok, ($sym, '=', $k2));
2330 29         93 return $self->read_statement($tok, $last_op);
2331             }
2332 1300 100 100     3849 if (($tok->[1] eq '=') && ($tok->[2] eq '>')) {
2333             # $expr1 =>
2334             #
2335 45         113 my $sym = shift @$tok;
2336 45         85 shift @$tok;
2337 45         73 shift @$tok;
2338 45         120 unshift(@$tok, ($sym, '=>'));
2339              
2340 45         145 return $self->read_statement($tok, $last_op);
2341             }
2342 1255 100 100     20826 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         99 my $sym = shift @$tok;
2347 35         107 my $op = shift @$tok;
2348 35         72 shift @$tok;
2349 35         117 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         15 my $sym = shift @$tok;
2356 5         25 my $op = shift @$tok;
2357 5         9 shift @$tok;
2358 5         11 shift @$tok;
2359 5         20 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         6 my $sym = shift @$tok;
2365 3         7 my $op = shift @$tok;
2366 3         8 shift @$tok;
2367 3         4 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         64 my $sym = shift @$tok;
2377 20         53 my $op = shift @$tok;
2378 20         40 shift @$tok;
2379 20         81 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         117 my $sym = shift @$tok;
2402 52         100 shift @$tok;
2403 52         72 shift @$tok;
2404 52         152 unshift(@$tok, ($sym, '->')); # for operator precedence
2405             # fall through
2406             } elsif (($tok->[1] eq ':') && ($tok->[2] eq ':')) {
2407             # class :: elem
2408             #
2409 41         146 my $sym = shift @$tok;
2410 41         75 shift @$tok;
2411 41         73 shift @$tok;
2412 41         120 unshift(@$tok, ($sym, '::'));
2413             # fall through
2414             } elsif (($tok->[1] eq '?') && ($tok->[2] eq ':')) {
2415             # ternary: $expr1 ?: $expr3
2416             #
2417 3         10 my $sym = shift @$tok;
2418 3         9 shift @$tok;
2419 3         5 shift @$tok;
2420 3         10 unshift(@$tok, ($sym, '?:'));
2421             # fall through
2422             }
2423             # remaining binary ops
2424             # variable assignment
2425             #
2426 1255         2690 my $sym = shift @$tok;
2427 1255         2711 my $op = shift @$tok;
2428 1255         1770 my $op1;
2429 1255         2115 $op = lc($op);
2430              
2431 1255 100 100     5635 if (($op eq '->') || ($op eq '::') || ($op eq '\\')) {
      100        
2432 103         170 $op1 = $sym; # don't evaluate lefthand side variable
2433             } else {
2434 1152         4234 $op1 = $self->read_statement([$sym], undef);
2435             }
2436 1255 100       3110 if (defined $last_op) {
2437 175 50       545 unless (exists $op_prio{$op}) {
2438 0         0 $self->{warn}->('parse', "missing op_prio(%s) [last %s]", $op, $last_op);
2439             }
2440 175 50       426 unless (exists $op_prio{$last_op}) {
2441 0         0 $self->{warn}->('parse', "op_prio(%s) [op %s]", $last_op, $op);
2442             }
2443 175 50       393 $self->{debug}->('parse', "SYM $sym OP %s LAST %s", $op, $last_op) if $self->{debug};
2444 175 100       486 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     319 if (($op ne $last_op) || !exists $op_right{$op}) {
2450 62 100 100     255 unless (($op eq '=') && (exists $op_unary{$last_op} || !exists $op_right{$last_op})) {
      100        
2451 58 50       142 $self->{log}->('parse', "curr %s %s has higher/equal prio than last %s", $op1, $op, $last_op) if $self->{log};
2452 58         134 unshift(@$tok, $op);
2453 58         139 return $op1;
2454             }
2455             }
2456             }
2457             }
2458 1197         1950 my $k;
2459 1197 100 100     5620 if ($op eq '?') {
    100          
    100          
    100          
    100          
2460             # ternary: $op1 ? $expr2 : $expr3
2461             #
2462 15         40 my $expr2 = $self->read_statement($tok, $op);
2463 15 50 33     61 if ((scalar @$tok > 0) && $tok->[0] eq ':') {
2464 15         23 shift @$tok;
2465             } else {
2466 0         0 $self->{warn}->('parse', "ternary: missing : [%s ? %s]", $sym, $expr2);
2467             }
2468 15         40 my $expr3 = $self->read_statement($tok, ':');
2469 15         44 my $op2 = $self->setexpr(':', $expr2, $expr3);
2470 15         37 $k = $self->setexpr('?', $op1, $op2);
2471             } elsif ($op eq '->') {
2472             # $obj -> member
2473             #
2474 52         150 my $op2 = $self->read_statement($tok, $op);
2475              
2476 52 100       128 if (is_block($op2)) {
2477             # $obj -> {'member'}
2478             #
2479 2         9 my ($type, $a) = @{$self->{strmap}->{$op2}};
  2         10  
2480 2 50       10 if (scalar @$a == 1) {
2481 2         6 $op2 = $a->[0];
2482             }
2483             }
2484 52         138 $op2 = $self->get_strval_or_str($op2);
2485              
2486 52         158 $k = $self->setobj($op1, $op2);
2487             } elsif ($op eq '::') {
2488             # class :: member
2489             #
2490 41         77 my $class = $sym;
2491 41 100       100 unless (is_symbol($sym)) {
2492 1         7 $class = $self->read_statement([$sym], undef);
2493 1         5 $class = $self->get_strval_or_str($class);
2494             }
2495 41         128 my $elem = $self->read_statement($tok, $op);
2496 41         141 $elem = $self->get_strval_or_str($elem);
2497              
2498 41         124 $k = $self->setscope($class, $elem);
2499             } elsif ($op eq '\\') {
2500             # ns/elem
2501             #
2502 5         16 my $op2 = $self->read_statement($tok, $op);
2503 5         14 $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         137 $k = $self->setexpr($op, $op1, undef);
2511             } else {
2512 1049         1573 if (1) {
2513             # optimize long concat chains to avoid memory exhaustion
2514             # (sometimes hundreds of strings get concatted)
2515             #
2516 1049 50 100     2488 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         2264 my $op2 = $self->read_statement($tok, $op);
2530 1049         2404 $k = $self->setexpr($op, $op1, $op2);
2531             }
2532             # execute expr & might continue with lower prio operation
2533             #
2534 1197         2603 unshift(@$tok, $k);
2535 1197         2824 return $self->read_statement($tok, $last_op);
2536             }
2537              
2538 13 50       56 if (scalar @$tok > 0) {
2539 13         28 my $sym = shift @$tok;
2540              
2541             # some symbols are pushed back into token-stream and might be passed through here
2542             #
2543 13 50       37 $self->{log}->('parse', "skip symbol %s", $sym) if $self->{log};
2544 13         40 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 23509 my ($self, $tok, $last_op) = @_;
2553 13401         18384 my $level = 0;
2554              
2555 13401 100       24943 if (exists $self->{strmap}->{_LEVEL}) {
2556 12681         20725 $self->{strmap}->{_LEVEL} += 1;
2557             } else {
2558 720         1739 $self->{strmap}->{_LEVEL} = 1;
2559             }
2560 13401         19538 $level = $self->{strmap}->{_LEVEL};
2561              
2562             # show next 10 tokens to process
2563             #
2564 13401 100       24047 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       32367 my $tab = ($level <= 1) ? '' : ('....' x ($level-2)) . '... ';
2567 13401 0       25446 $self->{log}->('PARSE', "$tab%s%s", join(' ', @$tok[0..$tl-1]), (scalar @$tok > 10) ? ' ..['.(scalar @$tok - 10).']' : '') if $self->{log};
    50          
2568              
2569 13401         27483 my $ret = $self->_read_statement($tok, $last_op);
2570 13401         23310 $self->{strmap}->{_LEVEL} -= 1;
2571 13401         26905 return $ret;
2572             }
2573              
2574             sub filter_bad_brace {
2575 3544     3544 0 6119 my ($stmt) = @_;
2576              
2577 3544 50       8921 if ($stmt =~ /^[\)\]\}]$/) {
2578 0         0 $stmt = "";
2579             }
2580 3544         6599 return $stmt;
2581             }
2582              
2583             sub read_index_block {
2584 416     416 0 873 my ($self, $tok, $close, $separator) = @_;
2585 416         699 my @out = ();
2586              
2587 416 50       934 $self->{debug}->('parse', "B+$close") if $self->{debug};
2588              
2589 416         975 while (scalar @$tok > 0) {
2590             # always resolve assignment in index to value
2591             #
2592 816         1821 my $stmt = $self->read_statement($tok, undef);
2593              
2594 816 50       1738 $self->{debug}->('parse', "B-$close $stmt") if $self->{debug};
2595              
2596 816 100 33     1979 if ($stmt eq $close) {
    50          
2597             # block end
2598             #
2599 416         1174 return \@out;
2600             } elsif (defined $separator && ($stmt eq $separator)) {
2601             #push(@out, $separator);
2602             } else {
2603 400         754 $stmt = filter_bad_brace($stmt);
2604 400         1222 push(@out, $stmt);
2605             }
2606             }
2607 0         0 return \@out;
2608             }
2609              
2610             sub read_block {
2611 1261     1261 0 2536 my ($self, $tok, $close, $separator) = @_;
2612 1261         1873 my @out = ();
2613 1261         1708 my $last;
2614              
2615 1261 50       2778 $self->{debug}->('parse', "B+$close") if $self->{debug};
2616              
2617 1261         2586 while (scalar @$tok > 0) {
2618 2526         5543 my $stmt = $self->read_statement($tok, undef);
2619              
2620 2526 50       4921 $self->{debug}->('parse', "B-$close $stmt") if $self->{debug};
2621              
2622 2526 100 100     6824 if ($stmt eq $close) {
    100          
2623             # block end
2624             #
2625 1261         3494 return \@out;
2626             } elsif (defined $separator && ($stmt eq $separator)) {
2627 147 50 33     562 if (defined $last && ($last eq $separator)) {
2628 0         0 push(@out, undef); # allow empty field
2629             }
2630             #push(@out, $separator);
2631             } else {
2632 1118         2104 $stmt = filter_bad_brace($stmt);
2633 1118         2356 push(@out, $stmt);
2634             }
2635 1265         2829 $last = $stmt;
2636             }
2637 0         0 return \@out;
2638             }
2639              
2640             sub read_code_block {
2641 1269     1269 0 2791 my ($self, $tok, $close, $separator) = @_;
2642 1269         1942 my @out = ();
2643              
2644 1269 50       2752 $self->{debug}->('parse', "B+$close") if $self->{debug};
2645              
2646 1269         3249 while (scalar @$tok > 0) {
2647 3558         7464 my $stmt = $self->read_statement($tok, undef);
2648              
2649 3558 50       7340 $self->{debug}->('parse', "B-$close $stmt") if $self->{debug};
2650              
2651 3558 100 66     11834 if ($stmt eq $close) {
    100          
2652             # block end
2653             #
2654 476         1377 return \@out;
2655             } elsif (defined $separator && ($stmt eq $separator)) {
2656             #push(@out, $separator);
2657             } else {
2658 2026         3763 $stmt = filter_bad_brace($stmt);
2659 2026         6249 push(@out, $stmt);
2660             }
2661             }
2662 793         1748 return \@out;
2663             }
2664              
2665             sub tokens {
2666 1     1 0 393 my ($self) = @_;
2667 1         4 return $self->{tok};
2668             }
2669              
2670             sub read_code {
2671 785     785 1 2052 my ($self, $tok) = @_;
2672 785         1060 my $in;
2673 785         1357 my @out = ();
2674              
2675 785         1596 $in = unspace_list($tok);
2676              
2677 785         2261 my $stmts = $self->read_code_block($in, '?>', ';');
2678 785 100       1837 if (scalar @$stmts == 1) {
2679 331         1348 return $stmts->[0];
2680             }
2681 454         1136 my $k = $self->setblk('flat', $stmts);
2682 454         1773 return $k;
2683             }
2684              
2685             sub map_stmt {
2686 3116     3116 0 6138 my ($self, $s, $cb, @params) = @_;
2687              
2688             #$self->{log}->('MAP', "$s") if $self->{log};
2689              
2690 3116         6238 my $k = $cb->($s, @params);
2691 3116 100       5755 if (defined $k) {
2692 286         597 return $k;
2693             }
2694 2830         4042 my $s0 = $s;
2695              
2696 2830 50       24914 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         255 my $arr = $self->{strmap}{$s};
2709 133         376 my $keys = $arr->get_keys();
2710 133         216 my %newmap;
2711 133         201 my @newkeys = ();
2712 133         214 my $changed = 0;
2713              
2714 133         269 foreach my $k (@$keys) {
2715 236         568 my $val = $arr->val($k);
2716 236 50 33     519 if ((is_int_index($k) || is_strval($k)) && (!defined $val
      33        
      33        
2717             || (defined $val && is_strval($val)))) {
2718 236         406 push(@newkeys, $k);
2719 236         616 $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       465 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         25 my ($f, $a, $b, $p) = @{$self->{strmap}->{$s}};
  14         42  
2746             # no context change here
2747             } elsif ($s =~ /^#call\d+$/) {
2748 87         156 my ($f, $a) = @{$self->{strmap}->{$s}};
  87         216  
2749 87         152 my @args = ();
2750 87         136 my $arg_changed = 0;
2751 87         132 my $name = $f;
2752              
2753 87 50       168 if ($f =~ /^#fun\d+$/) {
2754             # no context change here
2755             #$name = $self->map_stmt($f, $cb, @params);
2756             } else {
2757 87         187 $name = $self->map_stmt($f, $cb, @params);
2758             }
2759 87         217 foreach my $k (@$a) {
2760 65         121 my $v = $self->map_stmt($k, $cb, @params);
2761 65         141 push(@args, $v);
2762 65 50       160 if ($v ne $k) {
2763 0         0 $arg_changed = 1;
2764             }
2765             }
2766 87 50 33     347 if (($name ne $f) || $arg_changed) {
2767 0         0 $s = $self->setcall($name, \@args);
2768             }
2769             } elsif ($s =~ /^#elem\d+$/) {
2770 50         64 my ($v, $i) = @{$self->{strmap}->{$s}};
  50         127  
2771 50         221 my $vv = $self->map_stmt($v, $cb, @params);
2772 50         76 my $ii = $i;
2773              
2774 50 50       111 if (defined $i) {
2775 50         114 $ii = $self->map_stmt($i, $cb, @params);
2776             }
2777 50 50 33     256 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         428 my ($op, $v1, $v2) = @{$self->{strmap}->{$s}};
  282         756  
2784 282         512 my $vv1 = $v1;
2785 282         397 my $vv2 = $v2;
2786              
2787 282 100       549 if (defined $v1) {
2788 276         644 $vv1 = $self->map_stmt($v1, $cb, @params);
2789             }
2790 282 50       622 if (defined $v2) {
2791 282         589 $vv2 = $self->map_stmt($v2, $cb, @params);
2792             }
2793 282 100 100     1711 if ((defined $v1 && ($v1 ne $vv1)) || (defined $v2 && ($v2 ne $vv2))) {
      33        
      66        
2794 10         37 $s = $self->setexpr($op, $vv1, $vv2);
2795             }
2796             } elsif ($s =~ /^#pfx\d+$/) {
2797             # keep
2798             } elsif ($s =~ /^#obj\d+$/) {
2799 12         30 my ($o, $m) = @{$self->{strmap}->{$s}};
  12         34  
2800 12         22 my $oo = $o;
2801 12         20 my $mm = $m;
2802              
2803 12 50       30 unless ($o =~ /^#call\d+$/) {
2804             # not 'new'
2805 12         30 $oo = $self->map_stmt($o, $cb, @params);
2806             }
2807 12 50 33     40 unless (exists $self->{strmap}->{$m} && is_symbol($self->{strmap}->{$m})) {
2808             # not 'sym'
2809 12         26 $mm = $self->map_stmt($m, $cb, @params);
2810             }
2811 12 50 33     58 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         1005 my ($type, $a) = @{$self->{strmap}->{$s}};
  602         1708  
2860 602         1104 my @args = ();
2861 602         807 my $arg_changed = 0;
2862              
2863 602         1158 foreach my $k (@$a) {
2864 698         1639 my $v = $self->map_stmt($k, $cb, @params);
2865 698 100       1401 if ($v ne $k) {
2866 93 100       278 unless ($self->is_empty_block($v)) {
2867 18         34 push(@args, $v);
2868             }
2869 93         185 $arg_changed = 1;
2870             } else {
2871 605         1382 push(@args, $v);
2872             }
2873             }
2874 602 100       1482 if ($arg_changed) {
2875 85         204 $s = $self->setblk($type, \@args);
2876             }
2877             } elsif ($s =~ /^#stmt\d+$/) {
2878 529         1158 my $cmd = $self->{strmap}->{$s}->[0];
2879 529 100       2997 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         187 my $a = $self->{strmap}->{$s}->[1];
2881 108         181 my @args = ();
2882 108         145 my $arg_changed = 0;
2883              
2884 108         228 foreach my $k (@$a) {
2885 108         217 my $v = $self->map_stmt($k, $cb, @params);
2886 108         199 push(@args, $v);
2887 108 50       270 if ($v ne $k) {
2888 0         0 $arg_changed = 1;
2889             }
2890             }
2891 108 50       270 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         28 my $a = $self->{strmap}->{$s}->[1];
2936 8         15 my @args = ();
2937 8         12 my $arg_changed = 0;
2938              
2939 8         18 foreach my $k (@$a) {
2940 8         23 my $v = $self->map_stmt($k, $cb, @params);
2941 8         18 push(@args, $v);
2942 8 50       24 if ($v ne $k) {
2943 0         0 $arg_changed = 1;
2944             }
2945             }
2946 8 50       21 if ($arg_changed) {
2947 0         0 $s = $self->setstmt(['global', \@args]);
2948             }
2949             } elsif ($cmd eq 'static') {
2950 8         15 my ($a, $p) = @{$self->{strmap}->{$s}}[1..2];
  8         24  
2951 8         15 my @args = ();
2952 8         11 my $arg_changed = 0;
2953              
2954 8         18 foreach my $k (@$a) {
2955 8         18 my $v = $self->map_stmt($k, $cb, @params);
2956 8         21 push(@args, $v);
2957 8 50       21 if ($v ne $k) {
2958 0         0 $arg_changed = 1;
2959             }
2960             }
2961 8 50       31 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         731 my $arg = $self->{strmap}->{$s}->[1];
2996 386         603 my $v = $arg;
2997              
2998 386 50       757 if (defined $v) {
2999 386         841 $v = $self->map_stmt($arg, $cb, @params);
3000             }
3001 386 50 33     1520 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         35 my ($cond, $then, $else) = @{$self->{strmap}->{$s}}[1..3];
  15         47  
3027 15         40 my $cond1 = $self->map_stmt($cond, $cb, @params);
3028 15         43 my $then1 = $self->map_stmt($then, $cb, @params);
3029 15         30 my $else1 = $else;
3030              
3031 15 50       41 if (defined $else) {
3032 0         0 $else1 = $self->map_stmt($else, $cb, @params);
3033             }
3034 15 100 66     83 if (($cond ne $cond1) || ($then ne $then1) || (defined $else && ($else ne $else1))) {
      33        
      66        
3035 2 50 33     5 if ($self->is_empty_block($then1) && (!defined $else || $self->is_empty_block($else1))) {
      33        
3036 2         6 $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         8 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         8 my $key1 = $key;
3071              
3072 4 50       11 if (defined $key) {
3073 4         9 $key1 = $self->map_stmt($key, $cb, @params);
3074             }
3075 4         14 my $value1 = $self->map_stmt($value, $cb, @params);
3076 4         11 my $block1 = $self->map_stmt($block, $cb, @params);
3077              
3078 4 100 33     53 if (($expr ne $expr1) || (defined $key && ($key ne $key1)) || ($value ne $value1) || ($block ne $block1)) {
      33        
      33        
      66        
3079 1         5 $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       5138 if ($s ne $s0) {
3145 98 50       236 $self->{debug}->('map', "map %s -> %s", $s0, $s) if $self->{debug};
3146             }
3147 2830         5842 return $s;
3148             }
3149              
3150             sub escape_str {
3151 1173     1173 0 2036 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         2215 $s =~ s/\\/\\\\/sg;
3161 1173         1932 $s =~ s/'/\\'/sg;
3162              
3163 1173 50       2133 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         2461 $s = "'" . $s . "'";
3168             }
3169 1173         2687 return $s;
3170             }
3171              
3172             sub expand_stmt {
3173 8423     8423 0 14781 my ($self, $out, $s, $fmt) = @_;
3174              
3175             #$self->{log}->('EXPAND', "$s") if $self->{log};
3176              
3177 8423 50       60834 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         81 push(@$out, 'null');
3182             } elsif ($s =~ /^#num\d+$/) {
3183 570 50       1460 if (exists $self->{strmap}->{$s}) {
3184 570 50       1202 unless (exists $fmt->{unified}) {
3185 570         1132 $s = $self->{strmap}->{$s};
3186             }
3187             }
3188 570         1062 push(@$out, $s);
3189             } elsif ($s =~ /^#const\d+$/) {
3190 23 50       69 if (exists $self->{strmap}->{$s}) {
3191 23 50       51 unless (exists $fmt->{unified}) {
3192 23         82 $s = $self->{strmap}->{$s};
3193             }
3194             }
3195 23         47 push(@$out, $s);
3196             } elsif ($s =~ /^#str\d+$/) {
3197 1172 50       2693 if (exists $self->{strmap}->{$s}) {
3198 1172 50       2323 unless (exists $fmt->{unified}) {
3199 1172         2193 $s = $self->{strmap}->{$s};
3200 1172 50       2248 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     2358 if (exists $fmt->{max_strlen} && (length($s) > $fmt->{max_strlen})) {
3205 0         0 $s = substr($s, 0, $fmt->{max_strlen}-2).'..';
3206             }
3207 1172         2163 $s = escape_str($s, $fmt);
3208             }
3209             }
3210 1172         2232 push(@$out, $s);
3211             } elsif ($s =~ /^#arr\d+$/) {
3212 186         438 my $arr = $self->{strmap}{$s};
3213 186         584 my $keys = $arr->get_keys();
3214 186         414 push(@$out, 'array');
3215 186         283 push(@$out, '(');
3216              
3217 186         433 foreach my $k (@$keys) {
3218 278         639 my $val = $arr->val($k);
3219 278         1177 $self->expand_stmt($out, $k, $fmt);
3220 278         462 push(@$out, '=>');
3221 278 50       578 if (defined $val) {
3222 278         498 $self->expand_stmt($out, $val, $fmt);
3223             }
3224 278         604 push(@$out, ',');
3225             }
3226 186 100       457 if (scalar @$keys > 0) {
3227 162         273 pop(@$out);
3228             }
3229 186         409 push(@$out, ')');
3230             } elsif ($s =~ /^#fun\d+$/) {
3231 239         387 my ($f, $a, $b, $p) = @{$self->{strmap}->{$s}};
  239         1114  
3232              
3233 239         796 foreach my $k (sort grep { exists $php_modifiers{$_} } keys %$p) {
  25         90  
3234 25         49 push(@$out, $k);
3235             }
3236 239         483 push(@$out, 'function');
3237 239 100       469 if (defined $f) {
3238 213         403 push(@$out, $f);
3239             }
3240 239         401 push(@$out, '(');
3241 239         415 foreach my $k (@$a) {
3242             #push(@$out, $k);
3243 104         316 $self->expand_stmt($out, $k, $fmt);
3244 104         232 push(@$out, ',');
3245             }
3246 239 100       588 if (scalar @$a > 0) {
3247 100         205 pop(@$out);
3248             }
3249 239         481 push(@$out, ')');
3250 239         610 $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         563 my ($f, $a) = @{$self->{strmap}->{$s}};
  370         1149  
3262              
3263 370 100       827 if ($f =~ /^#fun\d+$/) {
3264             # anonymous function call requires braces around func
3265 4         23 push(@$out, '(');
3266 4         17 $self->expand_stmt($out, $f, $fmt);
3267 4         12 push(@$out, ')');
3268             } else {
3269 366         1280 $self->expand_stmt($out, $f, $fmt);
3270             }
3271 370         647 push(@$out, '(');
3272 370         794 foreach my $k (@$a) {
3273 198         531 $self->expand_stmt($out, $k, $fmt);
3274 198         457 push(@$out, ',');
3275             }
3276 370 100       780 if (scalar @$a > 0) {
3277 169         263 pop(@$out);
3278             }
3279 370         725 push(@$out, ')');
3280             } elsif ($s =~ /^#elem\d+$/) {
3281 275         456 my ($v, $i) = @{$self->{strmap}->{$s}};
  275         713  
3282              
3283 275         1014 $self->expand_stmt($out, $v, $fmt);
3284 275         504 push(@$out, '[');
3285 275 100       604 if (defined $i) {
3286 254         531 $self->expand_stmt($out, $i, $fmt);
3287             }
3288 275         526 push(@$out, ']');
3289             } elsif ($s =~ /^#expr\d+$/) {
3290             # if v1 missing: prefix op
3291             # if v2 missing: postfix op
3292 1323         2172 my ($op, $v1, $v2) = @{$self->{strmap}->{$s}};
  1323         3659  
3293              
3294 1323 100       2682 if (defined $v1) {
3295 1272 100 100     4496 if ($v1 =~ /^#expr\d+$/) {
    100          
3296 30         61 my ($vop, $vv1, $vv2) = @{$self->{strmap}->{$v1}};
  30         105  
3297 30         50 my $add_brace = 0;
3298 30 100 100     132 if (($op ne '=') && ($op ne $vop)) {
3299 6         11 $add_brace = 1;
3300             }
3301 30 0 33     100 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       70 if ($add_brace) {
3305 6         13 push(@$out, '(');
3306             }
3307 30         85 $self->expand_stmt($out, $v1, $fmt);
3308 30 100       67 if ($add_brace) {
3309 6         20 push(@$out, ')');
3310             }
3311             } elsif (($op eq '=') && ($v1 =~ /^#arr\d+$/)) {
3312             # output lhs array() as list() and allow empty elems
3313             #
3314 6         13 my $arr = $self->{strmap}{$v1};
3315 6         19 my $keys = $arr->get_keys();
3316 6         38 my $numerical = $arr->is_numerical();
3317 6         14 push(@$out, 'list');
3318 6         12 push(@$out, '(');
3319              
3320 6         12 foreach my $k (@$keys) {
3321 13         32 my $val = $arr->val($k);
3322 13 100       32 if (defined $val) {
3323 12 50       20 unless ($numerical) {
3324 0         0 $self->expand_stmt($out, $k, $fmt);
3325 0         0 push(@$out, '=>');
3326             }
3327 12         27 $self->expand_stmt($out, $val, $fmt);
3328             }
3329 13         44 push(@$out, ',');
3330             }
3331 6 50       49 if (scalar @$keys > 0) {
3332 6         12 pop(@$out);
3333             }
3334 6         14 push(@$out, ')');
3335             } else {
3336 1236         2890 $self->expand_stmt($out, $v1, $fmt);
3337             }
3338             }
3339 1323         2358 push(@$out, $op);
3340 1323 100       2406 if (defined $v2) {
3341 1288 100       2744 if ($op eq '$') {
3342 24         75 push(@$out, '{');
3343             }
3344 1288 100       2841 if ($v2 =~ /^#expr\d+$/) {
3345 96         209 my ($vop, $vv1, $vv2) = @{$self->{strmap}->{$v2}};
  96         344  
3346 96         183 my $add_brace = 0;
3347 96 100 100     442 if (($op ne '?') && ($op ne '=') && ($op ne $vop)) {
      100        
3348 8         17 $add_brace = 1;
3349             }
3350 96 100 66     274 if (exists $op_unary{$vop} && (is_variable($vv2) || ($vv2 =~ /^#elem\d+$/) || ($vv2 =~ /^#call\d+$/))) {
      100        
3351 8         18 $add_brace = 0;
3352             }
3353 96 100       198 if ($add_brace) {
3354 7         19 push(@$out, '(');
3355             }
3356 96         238 $self->expand_stmt($out, $v2, $fmt);
3357 96 100       262 if ($add_brace) {
3358 7         21 push(@$out, ')');
3359             }
3360             } else {
3361 1192         2408 $self->expand_stmt($out, $v2, $fmt);
3362             }
3363 1288 100       2917 if ($op eq '$') {
3364 24         49 push(@$out, '}');
3365             }
3366             }
3367             } elsif ($s =~ /^#pfx\d+$/) {
3368 16         47 my $pfx = $self->{strmap}->{$s};
3369 16         60 foreach my $k (sort keys %$pfx) {
3370 16         34 push(@$out, $k);
3371             }
3372             } elsif ($s =~ /^#obj\d+$/) {
3373 34         52 my ($o, $m) = @{$self->{strmap}->{$s}};
  34         108  
3374              
3375 34 50       79 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         84 $self->expand_stmt($out, $o, $fmt);
3381             }
3382 34         63 push(@$out, '->');
3383 34 50 33     108 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         71 $self->expand_stmt($out, $m, $fmt);
3396             }
3397             } elsif ($s =~ /^#scope\d+$/) {
3398 4         10 my ($c, $e) = @{$self->{strmap}->{$s}};
  4         20  
3399              
3400 4 50 33     21 if (exists $self->{strmap}->{$c} && is_symbol($self->{strmap}->{$c})) {
3401 0         0 push(@$out, $self->{strmap}->{$c});
3402             } else {
3403 4         15 $self->expand_stmt($out, $c, $fmt);
3404             }
3405 4         11 push(@$out, '::');
3406 4 50 33     20 if (exists $self->{strmap}->{$e} && is_symbol($self->{strmap}->{$e})) {
3407 0         0 push(@$out, $self->{strmap}->{$e});
3408             } else {
3409 4         14 $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         45 my ($c, $f, $i) = @{$self->{strmap}->{$s}};
  21         67  
3425              
3426 21         45 push(@$out, 'new');
3427 21         59 $self->expand_stmt($out, $f, $fmt);
3428             } elsif ($s =~ /^#ref\d+$/) {
3429 8         31 my ($v) = @{$self->{strmap}->{$s}};
  8         28  
3430              
3431 8         19 push(@$out, '&');
3432 8         22 $self->expand_stmt($out, $v, $fmt);
3433             } elsif ($s =~ /^#class\d+$/) {
3434 56         115 my ($c, $b, $p) = @{$self->{strmap}->{$s}};
  56         187  
3435              
3436 56         227 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         108 push(@$out, $c);
3441              
3442 56 50       149 if (exists $p->{parent}) {
3443 0         0 push(@$out, 'extends');
3444 0         0 push(@$out, $p->{parent});
3445             }
3446 56         134 $self->expand_stmt($out, $b, $fmt);
3447             } elsif ($s =~ /^#trait\d+$/) {
3448 1         3 my ($t, $b) = @{$self->{strmap}->{$s}};
  1         6  
3449              
3450 1         4 push(@$out, 'trait');
3451 1         3 push(@$out, $t);
3452 1         3 $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         1601 my ($type, $a) = @{$self->{strmap}->{$s}};
  1099         2658  
3465 1099 100       3797 if ($type eq 'expr') {
    100          
    100          
    100          
3466 93         183 foreach my $k (@$a) {
3467 86         204 $self->expand_stmt($out, $k, $fmt);
3468 86         185 push(@$out, ',');
3469             }
3470 93 100       192 if (scalar @$a > 0) {
3471 82         119 pop(@$out);
3472             }
3473             } elsif ($type eq 'flat') {
3474 500         1110 foreach my $k (@$a) {
3475 1295         3262 $self->expand_stmt($out, $k, $fmt);
3476 1295 50       2968 if ($k =~ /^#pfx\d+$/) {
3477 0         0 next; # avoid ;
3478             }
3479 1295 100 100     4288 if (($out->[-1] ne '}') && ($out->[-1] ne ':')) {
3480 1040         2093 push(@$out, ';');
3481             }
3482             }
3483 500 100 100     1919 if ((scalar @$a > 0) && ($out->[-1] eq ';')) {
3484 433 50       1014 pop(@$out) if $fmt->{avoid_semicolon};
3485             }
3486             } elsif ($type eq 'case') {
3487 8         15 foreach my $k (@$a) {
3488 8         84 $self->expand_stmt($out, $k, $fmt);
3489 8         22 push(@$out, ';');
3490             }
3491 8 50       26 if (scalar @$a > 0) {
3492 8         14 pop(@$out);
3493             }
3494             } elsif ($type eq 'brace') {
3495 1 50       4 if (scalar @$a == 1) {
3496 1         5 $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         829 push(@$out, '{');
3512 497         913 foreach my $k (@$a) {
3513 665         1768 $self->expand_stmt($out, $k, $fmt);
3514 665 100       1538 if ($k =~ /^#pfx\d+$/) {
3515 16         38 next; # avoid ;
3516             }
3517 649 100 66     2430 if (($out->[-1] ne '}') && ($out->[-1] ne ':')) {
3518 533         1120 push(@$out, ';');
3519             }
3520             }
3521 497 100 100     1923 if ((scalar @$a > 0) && ($out->[-1] eq ';')) {
3522 382 50       845 pop(@$out) if $fmt->{avoid_semicolon};
3523             }
3524 497         918 push(@$out, '}');
3525             }
3526             } elsif ($s =~ /^#stmt\d+$/) {
3527 537         1278 my $cmd = $self->{strmap}->{$s}->[0];
3528 537 100       3696 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         352 my $a = $self->{strmap}->{$s}->[1];
3530 183         318 push(@$out, $cmd);
3531 183         348 foreach my $k (@$a) {
3532 186         644 $self->expand_stmt($out, $k, $fmt);
3533 186         428 push(@$out, ',');
3534             }
3535 183 50       444 if (scalar @$a > 0) {
3536 183         325 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         24 my ($arg, $block) = @{$self->{strmap}->{$s}}[1..2];
  10         30  
3545 10         18 push(@$out, $cmd);
3546 10 100       21 if ($arg ne '') {
3547 9         15 push(@$out, $arg);
3548             }
3549 10 100       23 if (defined $block) {
3550 2         6 $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         17 my $a = $self->{strmap}->{$s}->[1];
3568 6         14 push(@$out, $cmd);
3569 6         13 foreach my $k (@$a) {
3570 6         24 $self->expand_stmt($out, $k, $fmt);
3571 6         24 push(@$out, ',');
3572             }
3573 6 50       20 if (scalar @$a > 0) {
3574 6         11 pop(@$out);
3575             }
3576             } elsif ($cmd eq 'static') {
3577 11         30 my ($a, $p) = @{$self->{strmap}->{$s}}[1..2];
  11         46  
3578              
3579             #push(@$out, join(' ', sort keys %$p));
3580 11         46 push(@$out, join(' ', (grep { $_ ne $cmd } sort keys %$p), $cmd));
  11         50  
3581             #push(@$out, $cmd);
3582 11         26 foreach my $k (@$a) {
3583 11         35 $self->expand_stmt($out, $k, $fmt);
3584 11         26 push(@$out, ',');
3585             }
3586 11 50       38 if (scalar @$a > 0) {
3587 11         24 pop(@$out);
3588             }
3589             } elsif ($cmd eq 'const') {
3590 9         17 my ($a, $p) = @{$self->{strmap}->{$s}}[1..2];
  9         25  
3591              
3592             #push(@$out, join(' ', sort keys %$p));
3593 9         42 push(@$out, join(' ', (grep { $_ ne $cmd } sort keys %$p), $cmd));
  10         41  
3594             #push(@$out, $cmd);
3595 9         24 foreach my $k (@$a) {
3596 9         29 $self->expand_stmt($out, $k, $fmt);
3597 9         19 push(@$out, ',');
3598             }
3599 9 50       25 if (scalar @$a > 0) {
3600 9         19 pop(@$out);
3601             }
3602             } elsif ($cmd eq 'unset') {
3603 5         11 my $a = $self->{strmap}->{$s}->[1];
3604 5         12 push(@$out, $cmd);
3605 5         11 push(@$out, '(');
3606 5         9 foreach my $k (@$a) {
3607 5         14 $self->expand_stmt($out, $k, $fmt);
3608 5         24 push(@$out, ',');
3609             }
3610 5 50       16 if (scalar @$a > 0) {
3611 5         10 pop(@$out);
3612             }
3613 5         12 push(@$out, ')');
3614             } elsif ($cmd eq 'return') {
3615 116         328 my $a = $self->{strmap}->{$s}->[1];
3616 116         239 push(@$out, $cmd);
3617 116         287 $self->expand_stmt($out, $a, $fmt);
3618             } elsif ($cmd eq 'goto') {
3619 1         4 my $a = $self->{strmap}->{$s}->[1];
3620 1         3 push(@$out, $cmd);
3621 1         4 $self->expand_stmt($out, $a, $fmt);
3622             } elsif ($cmd eq 'label') {
3623 1         3 my $a = $self->{strmap}->{$s}->[1];
3624 1         5 $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         210 my ($cond, $then, $else) = @{$self->{strmap}->{$s}}[1..3];
  103         345  
3632              
3633 103         215 push(@$out, $cmd);
3634 103         200 push(@$out, '(');
3635 103         303 $self->expand_stmt($out, $cond, $fmt);
3636 103         228 push(@$out, ')');
3637 103         315 $self->expand_stmt($out, $then, $fmt);
3638 103 100       262 if (defined $else) {
3639 14         50 push(@$out, 'else');
3640              
3641             # remove block around 'if else'
3642             #
3643 14 50       36 my $stmts = is_block($else) ? $self->{strmap}->{$else}->[1] : [];
3644 14 100 100     155 if ((@$stmts == 1) && ($stmts->[0] =~ /#stmt\d+$/) && ($self->{strmap}->{$stmts->[0]}->[0] eq 'if')) {
      100        
3645 5         17 $self->expand_stmt($out, $stmts->[0], $fmt);
3646             } else {
3647 9         32 $self->expand_stmt($out, $else, $fmt);
3648             }
3649             }
3650             } elsif ($cmd eq 'while') {
3651 16         30 my ($cond, $block) = @{$self->{strmap}->{$s}}[1..2];
  16         45  
3652              
3653 16         33 push(@$out, $cmd);
3654 16         28 push(@$out, '(');
3655 16         43 $self->expand_stmt($out, $cond, $fmt);
3656 16         27 push(@$out, ')');
3657 16         35 $self->expand_stmt($out, $block, $fmt);
3658             } elsif ($cmd eq 'do') {
3659 8         15 my ($cond, $block) = @{$self->{strmap}->{$s}}[1..2];
  8         24  
3660              
3661 8         19 push(@$out, $cmd);
3662 8         23 $self->expand_stmt($out, $block, $fmt);
3663 8         24 push(@$out, 'while');
3664 8         13 push(@$out, '(');
3665 8         26 $self->expand_stmt($out, $cond, $fmt);
3666 8         20 push(@$out, ')');
3667             } elsif ($cmd eq 'for') {
3668 31         48 my ($pre, $cond, $post, $block) = @{$self->{strmap}->{$s}}[1..4];
  31         100  
3669              
3670 31         69 push(@$out, $cmd);
3671 31         51 push(@$out, '(');
3672 31         80 $self->expand_stmt($out, $pre, $fmt);
3673 31         54 push(@$out, ';');
3674 31         85 $self->expand_stmt($out, $cond, $fmt);
3675 31         47 push(@$out, ';');
3676 31         81 $self->expand_stmt($out, $post, $fmt);
3677 31         57 push(@$out, ')');
3678 31         70 $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         63 push(@$out, $cmd);
3683 29         52 push(@$out, '(');
3684 29         76 $self->expand_stmt($out, $expr, $fmt);
3685 29         49 push(@$out, 'as');
3686 29 100       66 if (defined $key) {
3687 19         62 $self->expand_stmt($out, $key, $fmt);
3688 19         47 push(@$out, '=>');
3689             }
3690 29         89 $self->expand_stmt($out, $value, $fmt);
3691 29         59 push(@$out, ')');
3692 29         68 $self->expand_stmt($out, $block, $fmt);
3693             } elsif ($cmd eq 'switch') {
3694 6         16 my ($expr, $cases) = @{$self->{strmap}->{$s}}[1..2];
  6         18  
3695              
3696 6         14 push(@$out, $cmd);
3697 6         14 push(@$out, '(');
3698 6         21 $self->expand_stmt($out, $expr, $fmt);
3699 6         18 push(@$out, ')');
3700 6         13 push(@$out, '{');
3701 6         18 foreach my $e (@$cases) {
3702 8         16 my $c = $e->[0];
3703 8         17 my $b = $e->[1];
3704 8 50       16 if (defined $c) {
3705 8         21 push(@$out, 'case');
3706 8         25 $self->expand_stmt($out, $c, $fmt);
3707 8         30 push(@$out, ':');
3708             } else {
3709 0         0 push(@$out, 'default');
3710 0         0 push(@$out, ':');
3711             }
3712 8         24 $self->expand_stmt($out, $b, $fmt);
3713 8         19 push(@$out, ';');
3714             }
3715 6         15 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         4 my ($try, $catches, $finally) = @{$self->{strmap}->{$s}}[1..3];
  1         4  
3728              
3729 1         3 push(@$out, $cmd);
3730 1         6 $self->expand_stmt($out, $try, $fmt);
3731 1         3 foreach my $c (@$catches) {
3732 1         4 my $e = $c->[0];
3733 1         3 my $b = $c->[1];
3734 1         3 push(@$out, 'catch');
3735 1         2 push(@$out, '(');
3736 1         5 $self->expand_stmt($out, $e, $fmt);
3737 1         4 push(@$out, ')');
3738 1         4 $self->expand_stmt($out, $b, $fmt);
3739             }
3740 1 50       4 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         3435 my ($global) = global_split($s);
3749 1827 100       3854 if (defined $global) {
3750 35         136 my ($sym) = $global =~ /^\$(.*)$/;
3751 35         89 push(@$out, '$GLOBALS');
3752 35         70 push(@$out, '[');
3753 35         103 push(@$out, '\'' . $sym . '\'');
3754 35         63 push(@$out, ']');
3755             } else {
3756 1792         3333 my ($class, $sym) = inst_split($s);
3757 1792 100       4684 if (defined $class) {
    100          
    100          
3758 14         29 push(@$out, $class);
3759 14         25 push(@$out, '::');
3760 14         33 push(@$out, $sym);
3761             } elsif ($s eq '$') {
3762 4         11 push(@$out, '$');
3763 4         9 push(@$out, '{');
3764 4         8 push(@$out, 'null');
3765 4         7 push(@$out, '}');
3766             } elsif (!is_strict_variable($s)) {
3767 1         6 ($sym) = $s =~ /^\$(.*)$/;
3768 1         5 $sym = escape_str($sym, $fmt);
3769              
3770 1         3 push(@$out, '$');
3771 1         4 push(@$out, '{');
3772 1         2 push(@$out, $sym);
3773 1         3 push(@$out, '}');
3774             } else {
3775 1773         3758 push(@$out, $s);
3776             }
3777             }
3778             } else {
3779 632         1221 my ($class, $sym) = method_split($s);
3780 632 100       1245 if (defined $class) {
3781 12 50       29 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         27 push(@$out, $class);
3787 12         27 push(@$out, '::');
3788 12         19 push(@$out, $sym);
3789             }
3790             } else {
3791 620         1208 push(@$out, $s);
3792             }
3793             }
3794 8423         13158 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 2932 my ($self, $line, $fmt) = @_;
3936 783         1302 my @out = ();
3937 783 100       1837 $fmt = {} unless defined $fmt;
3938              
3939 783         2578 $self->expand_stmt(\@out, $line, $fmt);
3940              
3941 783 100 100     5207 if (!$fmt->{avoid_semicolon} && (scalar @out > 0) && ($out[-1] ne '}') && ($out[-1] ne ';')) {
      100        
      100        
3942 175         320 push(@out, ';');
3943             }
3944 783 50       1671 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         5338 return join(' ', @out);
3950             }
3951              
3952 6     6   84 use constant HINT_ASSIGN => 0x10000; # variable is assigned to
  6         36  
  6         511  
3953 6     6   58 use constant HINT_UNSET => 0x20000; # variable is unset
  6         17  
  6         56727  
3954              
3955             # if expression in block contains an unresolvable variable, then return it
3956             #
3957             sub stmt_info {
3958 5471     5471 0 10323 my ($self, $s, $info, $hint) = @_;
3959              
3960 5471 100       38214 if ($s =~ /^#blk\d+$/) {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    100          
3961 681         1042 my ($type, $a) = @{$self->{strmap}->{$s}};
  681         1703  
3962 681         1372 foreach my $stmt (@$a) {
3963 894         1745 $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         55 $info->{consts}{$s} = 1;
3974             } elsif ($s =~ /^#arr\d+$/) {
3975 286         649 my $arr = $self->{strmap}{$s};
3976 286         782 my $keys = $arr->get_keys();
3977 286         502 my $haskey = 0;
3978              
3979 286         592 foreach my $k (@$keys) {
3980 457         984 my $val = $arr->val($k);
3981 457 100       1282 unless (is_int_index($k)) {
3982 21         78 $self->stmt_info($k, $info);
3983             }
3984 457 50       905 if (defined $val) {
3985 457         1149 $self->stmt_info($val, $info);
3986 457         1004 $haskey = 1;
3987             }
3988             }
3989 286 100       645 if ($haskey) {
3990 264         939 $info->{arrays}{$s} = 'map';
3991             } else {
3992 22         78 $info->{arrays}{$s} = 'array';
3993             }
3994             } elsif ($s =~ /^#fun\d+$/) {
3995 23         39 my ($f, $a, $b, $p) = @{$self->{strmap}->{$s}};
  23         72  
3996 23 100       59 if (defined $f) {
3997 8         26 $info->{funcs}{$f} = 1;
3998             } else {
3999 15         39 $info->{funcs}{$s} = 1; # anon func
4000             }
4001             } elsif ($s =~ /^#expr\d+$/) {
4002 482         692 my ($op, $v1, $v2) = @{$self->{strmap}->{$s}};
  482         1440  
4003 482 100       1211 if (defined $v1) {
4004 450 100 100     3856 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         134  
4006              
4007 51 100       106 unless (defined $i) {
4008 17         46 $self->stmt_info($v1, $info, T_ARRAY|HINT_ASSIGN);
4009             } else {
4010 34         87 $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         45  
4014              
4015 14 50       40 if ($f eq 'range') {
4016 0         0 $self->stmt_info($v1, $info, T_ARRAY|HINT_ASSIGN);
4017             } else {
4018 14         40 $self->stmt_info($v1, $info, HINT_ASSIGN);
4019             }
4020             } elsif (($op eq '=') && defined $v2) {
4021 283         660 $self->stmt_info($v1, $info, HINT_ASSIGN);
4022             } elsif ($op eq '.') {
4023 30         72 $self->stmt_info($v1, $info, T_STR);
4024             } elsif (($op eq '++') || ($op eq '--')) {
4025 14         32 $self->stmt_info($v1, $info, HINT_ASSIGN);
4026             } else {
4027 58         131 $self->stmt_info($v1, $info);
4028             }
4029 450 100       1089 if ($op eq '=') {
    100          
    50          
4030 348         862 my $vb = $self->elem_base($v1);
4031 348         857 $info->{assigns}{$vb} = 1;
4032             } elsif ($op eq '++') {
4033 14         38 my $vb = $self->elem_base($v1);
4034 14         34 $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       1015 if (defined $v2) {
4041 468 100 66     1747 if ($op eq '.') {
    100          
4042 30         75 $self->stmt_info($v2, $info, T_STR);
4043             } elsif (($op eq '++') || ($op eq '--')) {
4044 1         4 $self->stmt_info($v2, $info, HINT_ASSIGN);
4045             } else {
4046 437         911 $self->stmt_info($v2, $info);
4047             }
4048 468 50       1350 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         4 my $vb = $self->elem_base($v2);
4053 1         5 $info->{assigns}{$vb} = 1;
4054             }
4055             }
4056             } elsif ($s =~ /^#elem\d+$/) {
4057 174         279 my ($v, $i) = @{$self->{strmap}->{$s}};
  174         455  
4058 174 50       420 if (defined $v) {
4059 174         277 my $hint_assign = 0;
4060 174 100 100     547 $hint_assign = HINT_ASSIGN if (defined $hint && ($hint & HINT_ASSIGN));
4061 174 100       305 if (defined $i) {
4062 157         436 $self->stmt_info($v, $info, $hint_assign);
4063             } else {
4064 17         46 $self->stmt_info($v, $info, T_STR|T_ARRAY|$hint_assign);
4065             }
4066             }
4067 174 100       392 if (defined $i) {
4068 157         412 $self->stmt_info($i, $info);
4069              
4070             # add resolvable globals
4071             #
4072 157         406 my $g = $self->globalvar_to_var($v, $i);
4073 157 100       347 if (defined $g) {
4074 22         59 $info->{globals}{$g} = 1;
4075             }
4076             }
4077             } elsif ($s =~ /^#obj\d+$/) {
4078 9         23 my ($o, $m) = @{$self->{strmap}->{$s}};
  9         29  
4079 9 100       35 if (lc($o) ne '$this') {
4080 4         10 $self->stmt_info($o, $info);
4081             }
4082 9 50       28 if (defined $m) {
4083 9         20 $self->stmt_info($m, $info);
4084             }
4085             } elsif ($s =~ /^#inst\d+$/) {
4086 19         38 my ($c, $f, $i) = @{$self->{strmap}->{$s}};
  19         63  
4087 19 50       52 if (defined $c) {
4088 19         47 $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         524 my ($f, $a) = @{$self->{strmap}->{$s}};
  295         756  
4107 295         559 my $narg = scalar @$a;
4108 295 100 66     897 if (exists $info->{state} && $info->{state}) {
4109 14         38 $info->{calls}{$f} = $info->{state};
4110             } else {
4111 281         614 $info->{calls}{$f} = 1;
4112             }
4113 295         949 $info->{callargs}{$f}{$narg} = 1; # track args count
4114              
4115 295         658 foreach my $k (@$a) {
4116 183 100       551 if ($f eq 'strlen') {
    100          
    50          
4117 3         13 $self->stmt_info($k, $info, T_STR);
4118             } elsif ($f eq 'base64_decode') {
4119 2         7 $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         394 $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         40 my ($c, $b, $p) = @{$self->{strmap}->{$s}};
  19         46  
4130 19         70 $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         1311 my $cmd = $self->{strmap}->{$s}->[0];
4141 582 100       3824 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         270 my $a = $self->{strmap}->{$s}->[1];
4143 128         261 foreach my $k (@$a) {
4144 128         286 $self->stmt_info($k, $info);
4145             }
4146 128         301 $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         22 my $a = $self->{strmap}->{$s}->[1];
4169 9         20 foreach my $v (@$a) {
4170 9         23 $info->{globals}{$v} = 1;
4171 9         20 $self->stmt_info($v, $info);
4172             }
4173             } elsif ($cmd eq 'static') {
4174 6         12 my $a = $self->{strmap}->{$s}->[1];
4175 6         12 foreach my $v (@$a) {
4176 6         16 $info->{statics}{$v} = 1;
4177 6         14 $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         552 my $a = $self->{strmap}->{$s}->[1];
4193 276         365 my $old;
4194 276 100       635 $old = $info->{state} if exists $info->{state};
4195 276         521 $info->{state} = 'return';
4196 276         673 $self->stmt_info($a, $info);
4197 276         512 $info->{state} = $old;
4198 276         836 $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         233 my ($cond, $then, $else) = @{$self->{strmap}->{$s}}[1..3];
  129         401  
4213              
4214 129         371 $self->stmt_info($cond, $info);
4215 129         315 $self->stmt_info($then, $info);
4216 129 100       348 if (defined $else) {
4217 15         46 $self->stmt_info($else, $info);
4218             }
4219 129         322 $info->{stmts}{$s} = 1;
4220             } elsif ($cmd eq 'while') {
4221 6         13 my ($cond, $block) = @{$self->{strmap}->{$s}}[1..2];
  6         20  
4222              
4223 6         20 $self->stmt_info($cond, $info);
4224 6         18 $self->stmt_info($block, $info);
4225 6         16 $info->{stmts}{$s} = 1;
4226             } elsif ($cmd eq 'do') {
4227 1         4 my ($cond, $block) = @{$self->{strmap}->{$s}}[1..2];
  1         5  
4228              
4229 1         5 $self->stmt_info($block, $info);
4230 1         6 $self->stmt_info($cond, $info);
4231 1         2 $info->{stmts}{$s} = 1;
4232             } elsif ($cmd eq 'for') {
4233 8         31 my ($pre, $cond, $post, $block) = @{$self->{strmap}->{$s}}[1..4];
  8         29  
4234              
4235 8         28 $self->stmt_info($pre, $info);
4236 8         28 $self->stmt_info($cond, $info);
4237 8         35 $self->stmt_info($post, $info);
4238 8         24 $self->stmt_info($block, $info);
4239 8         31 $info->{stmts}{$s} = 1;
4240             } elsif ($cmd eq 'foreach') {
4241 11         20 my ($expr, $key, $value, $block) = @{$self->{strmap}->{$s}}[1..4];
  11         39  
4242              
4243 11         37 $self->stmt_info($expr, $info);
4244 11 100       27 if (defined $key) {
4245 7         17 $self->stmt_info($key, $info);
4246 7         55 $info->{assigns}{$key} = 1;
4247             }
4248 11         34 $self->stmt_info($value, $info);
4249 11         31 $info->{assigns}{$value} = 1;
4250 11         34 $self->stmt_info($block, $info);
4251 11         32 $info->{stmts}{$s} = 1;
4252             } elsif ($cmd eq 'switch') {
4253 7         15 my ($expr, $cases) = @{$self->{strmap}->{$s}}[1..2];
  7         25  
4254              
4255 7         24 $self->stmt_info($expr, $info);
4256 7         15 foreach my $e (@$cases) {
4257 9         20 my $c = $e->[0];
4258 9         20 my $b = $e->[1];
4259 9 50       33 if (defined $c) {
4260 9         21 $self->stmt_info($c, $info);
4261             }
4262 9         18 $self->stmt_info($b, $info);
4263             }
4264 7         20 $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         5 $info->{breaks}{$s} = 1;
4286             } elsif ($cmd eq 'continue') {
4287 0         0 $info->{continues}{$s} = 1;
4288             }
4289             } elsif (is_variable($s)) {
4290 750         1432 my ($global) = global_split($s);
4291 750 100       1399 if (defined $global) {
4292 48         158 $info->{globals}{$global} = 1;
4293             } else {
4294 702 100       1174 if (defined $hint) {
4295 469         1295 $info->{vars}{$s} |= ($hint & T_MASK);
4296 469 100       1189 $info->{noassigns}{$s} |= ($hint & T_MASK) unless ($hint & HINT_ASSIGN);
4297             } else {
4298 233         581 $info->{vars}{$s} |= 0;
4299 233         485 $info->{noassigns}{$s} |= 0;
4300             }
4301             }
4302             }
4303 5471         9851 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__