File Coverage

blib/lib/SWF/Builder/ActionScript/Compiler.pm
Criterion Covered Total %
statement 428 2054 20.8
branch 162 932 17.3
condition 48 320 15.0
subroutine 52 254 20.4
pod 0 38 0.0
total 690 3598 19.1


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             package SWF::Builder::ActionScript::Compiler;
4              
5 1     1   23083 use strict;
  1         4  
  1         88  
6              
7 1     1   8 use Carp;
  1         2  
  1         95  
8 1     1   4750 use SWF::Element;
  1         356069  
  1         137  
9 1     1   1371 use SWF::Builder::ExElement;
  1         2102  
  1         1557  
10              
11             @SWF::Builder::ActionScript::Compiler::ISA = ('SWF::Builder::ActionScript::Compiler::Error');
12              
13             our $VERSION = '0.01';
14             $VERSION = eval $VERSION; # see L
15              
16             my $nl = "\x0a\x0d\x{2028}\x{2029}";
17             my $BE = (CORE::pack('s',1) eq CORE::pack('n',1));
18             my $INF = "\x00\x00\x00\x00\x00\x00\xf0\x7f";
19             my $NINF = "\x00\x00\x00\x00\x00\x00\xf0\xff";
20             if ($BE) {
21             $INF = reverse $INF;
22             $NINF = reverse $NINF;
23             }
24             my $MANTISSA = ~$NINF;
25             my $INFINITY = unpack('d', $INF);
26              
27             our %O;
28              
29             BEGIN {
30 1     1   47 %O =
31             ( O_ALL => ~0,
32             O_PEEPHOLE => 1<<0, # peephole optimization
33             O_CONSTEXP => 1<<1, # calculate constant expressions
34             O_CONSTMATH => 1<<2, # calculate math funcs with constant args and constant properties
35             O_LEFTONCE => 1<<3, # evaluate the lefthand side of assignment expression only once
36             O_REGISTER => 1<<4, # assign local variables to registers.
37             O_LOCALREG => 1<<5, # assign local variables to local registers using ActionDefineFunction2. Need O_REGISTER. Flash player 6.0.65 and above only.
38             O_6R65 => 1<<5,
39              
40             );
41             }
42              
43 1     1   13 use constant \%O;
  1         2  
  1         4004  
44              
45             our %GLOBAL_OPTIONS;
46              
47             sub new {
48 2     2 0 293 my $class = shift;
49 2         5 my $text = shift;
50 2         9 my %option = (%GLOBAL_OPTIONS, @_);
51              
52 2         60 my $new = bless {
53             text => $text,
54             line => 1,
55             ungets => [],
56             scope => [],
57             regvars => [],
58             stat => {
59             code => [],
60             label => 'A',
61             loop => [],
62             with => 0,
63             Trace => 'eval',
64             Warning => 1,
65             Optimize => O_ALL & ~O_REGISTER & ~O_LOCALREG,
66             Version => 6,
67             },
68             }, $class;
69 2         61 my $stat = $new->{stat};
70              
71 2         8 for my $o (qw/Warning Version Trace/) {
72 6 50       32 $stat->{$o} = $option{$o} if defined $option{$o};
73             }
74 2 50       10 if (defined(my $opt = $option{Optimize})) {
75 0 0       0 if ($opt =~ /^\d+$/) {
76 0         0 $stat->{Optimize} = $opt;
77             } else {
78 0         0 my $o = $stat->{Optimize};
79 0         0 my @o = split /[\s|]+/, $opt;
80              
81 0         0 for (@o) {
82 0 0       0 if (/^-/) {
83 0         0 s/^-//;
84 0 0       0 carp "Unknown optimize option '$_'" unless exists $O{$_};
85 0         0 $o &= ~$O{$_};
86             } else {
87 0 0       0 carp "Unknown optimize option '$_'" unless exists $O{$_};
88 0         0 $o |= $O{$_};
89             }
90             }
91 0         0 $stat->{Optimize} = $o;
92             }
93             }
94 2 50       10 if ($stat->{Optimize} & O_LOCALREG) {
95 0         0 $stat->{Optimize} |= O_REGISTER;
96 0 0       0 if ($new->{stat}{Version} < 6) {
97 0         0 $new->_error('O_LOCALREG can use SWF version 6 or later.');
98             }
99             }
100              
101 2         8 return $new;
102             }
103              
104             sub compile {
105 2     2 0 33 my ($self, $actions) = @_;
106 2         11 my $tree = $self->source_elements;
107 2   50     12 my $option = $actions||'';
108              
109 2 50       13 $tree->_tree_dump, return if $option eq 'tree';
110 2         13 $tree->compile;
111 2         11 $self->_tidy_up;
112 2 50       7 $self->_code_print, return if $option eq 'text';
113 2 50       36 $actions = SWF::Element::Array::ACTIONRECORDARRAY->new unless ref($actions);
114 2         51 $self->_encode($actions);
115 2 50       6 $actions->dumper, return if $option eq 'dump';
116 2         133 $actions;
117             }
118              
119             sub assemble {
120 0     0 0 0 my ($self, $actions) = @_;
121 0   0     0 my $option = $actions||'';
122              
123 0         0 push @{$self->{stat}{code}}, grep /[^#]/, split /[$nl]/, $self->{text};
  0         0  
124 0         0 $self->_tidy_up;
125 0 0       0 $self->_code_print, return if $option eq 'text';
126 0 0       0 $actions = SWF::Element::Array::ACTIONRECORDARRAY->new unless ref($actions);
127 0         0 $self->_encode($actions);
128 0 0       0 $actions->dumper, return if $option eq 'dump';
129 0         0 $actions;
130             }
131              
132             ### parser
133              
134              
135             my %reserved = (
136             null => ['', 'NULLLiteral'],
137             undefined => ['', 'UNDEFLiteral'],
138             true => [1, 'BooleanLiteral'],
139             false => [0, 'BooleanLiteral'],
140             newline => ["\n", 'StringLiteral'],
141              
142             add => 'AddOp',
143             and => 'AndOp',
144             break => 'Statement',
145             case => 'Label',
146             continue => 'Statement',
147             default => 'Label',
148             delete => 'DeleteOp',
149             do => 'Statement',
150             else => 'Else',
151             eq => 'EqOp',
152             for => 'Statement',
153             function => 'Function',
154             ge => 'Relop',
155             gt => 'Relop',
156             if => 'Statement',
157             ifFrameLoaded
158             => 'Statement',
159             in => 'In',
160             instanceof => 'RelOp',
161             le => 'Relop',
162             lt => 'Relop',
163             ne => 'Eqop',
164             new => 'New',
165             not => 'UnaryOp',
166             or => 'OrOp',
167             return => 'Statement',
168             switch => 'Statement',
169             tellTarget => 'Statement',
170             typeof => 'UnaryOp',
171             var => 'Statement',
172             void => 'UnaryOp',
173             while => 'Statement',
174             with => 'Statement',
175              
176             abstract => 'Reserved',
177             # boolean => 'Reserved',
178             byte => 'Reserved',
179             catch => 'Reserved',
180             char => 'Reserved',
181             class => 'Reserved',
182             const => 'Reserved',
183             debugger => 'Reserved',
184             double => 'Reserved',
185             enum => 'Reserved',
186             export => 'Reserved',
187             extends => 'Reserved',
188             finally => 'Reserved',
189             final => 'Reserved',
190             float => 'Reserved',
191             goto => 'Reserved',
192             implements => 'Reserved',
193             import => 'Reserved',
194             # int => 'Reserved',
195             interface => 'Reserved',
196             long => 'Reserved',
197             native => 'Reserved',
198             package => 'Reserved',
199             private => 'Reserved',
200             protected => 'Reserved',
201             public => 'Reserved',
202             short => 'Reserved',
203             static => 'Reserved',
204             synchronized
205             => 'Reserved',
206             throws => 'Reserved',
207             throw => 'Reserved',
208             transient => 'Reserved',
209             try => 'Reserved',
210             volatile => 'Reserved',
211             );
212              
213             my %property;
214             @property{ qw / _x _y _xscale _yscale
215             _currentframe _totalframes _alpha _visible
216             _width _height _rotation _target
217             _framesloaded _name _droptarget _url
218             _highquality _focusrect _soundbuftime _quality
219             _xmouse _ymouse /
220             } = (0..21);
221              
222             my %ops = ('=' => 'AssignmentOp',
223             '+' => 'AddOp',
224             '-' => 'AddOp',
225             '<' => 'RelOp',
226             '>' => 'RelOp',
227             '*' => 'MultOp',
228             '/' => 'MultOp',
229             '%' => 'MultOp',
230             '&' => 'BitAndOp',
231             '^' => 'BitXorOp',
232             '|' => 'BitOrOp',
233             '~' => 'UnaryOp',
234             '!' => 'UnaryOp',
235             '?' => 'ConditionalOp',
236             ':' => ':',
237             );
238              
239             =begin comment
240              
241             $self->_get_token(@token);
242              
243             get the next token. return ($token_text, $token_type, $line_terminator_count).
244             $num_line_terminator is a number of skipped line terminator or newline.
245             it is used for automatic semicolon insertion.
246              
247             =cut
248              
249             sub _get_token {
250 91     91   128 my $self = shift;
251 91         112 my $ln = 0;
252 91         104 my @token;
253              
254 91 100       97 if (@{$self->{ungets}}) {
  91         252  
255 78         92 @token = @{pop @{$self->{ungets}}};
  78         80  
  78         230  
256 78         176 $self->{line}+=$token[2];
257 78         366 return @token;
258             }
259              
260 13         30 for ($self->{text}) {
261 13 50       81 s/\A(?:[\x09\x0b\x0c\x20\xa0\p{IsZs}]|\/\/.+?(?=[$nl])|\/\*[^$nl]*?\*\/)+//o
262             and redo;
263             s/\A((?:\/\*.*?[$nl].*?\*\/|[$nl])(?:\/\*.*?\*\/|\/\/.*?[$nl]|\s)*)//os
264 13 50       1134 and do {
265 1     1   14197 my $ln1 = scalar($1=~tr/\x0a\x0d\x{2028}\x{2029}/\x0a\x0d\x{2028}\x{2029}/);
  1         15  
  1         23  
  0         0  
266 0         0 $self->{line} += $ln1;
267 0         0 $ln += $ln1;
268 0         0 redo;
269             };
270             s/\A([_\$\p{IsLl}\p{IsLu}\p{IsLt}\p{IsLm}\p{IsLo}\p{IsNl}][\$\w]*)//
271 13 100       43 and do {
272 3         9 my $key = $1;
273 3 50 33     40 return ((ref($reserved{$key})? @{$reserved{$key}} : ($key, $reserved{$key}||(exists $property{lc($key)} ? 'Property' : 'Identifier'))), $ln);
  0         0  
274             };
275             s/\A\"((?>(?:[^\"\\]|\\.)*))\"//s
276 10 50       26 and do {
277 0         0 my $s = $1;
278 0         0 $self->{line}+=scalar($s=~tr/\x0a\x0d\x{2028}\x{2029}/\x0a\x0d\x{2028}\x{2029}/);
279 0 0       0 $s=~s/(\\*)\'/$1.(length($1)%2==1?"'":"\\'")/ge;
  0         0  
280 0         0 return ($s, 'StringLiteral', $ln);
281             };
282             s/\A\'((?>(?:[^\'\\]|\\.)*))\'//s
283 10 50       26 and do {
284 0         0 my $s = $1;
285 0         0 $self->{line}+=scalar($s=~tr/\x0a\x0d\x{2028}\x{2029}/\x0a\x0d\x{2028}\x{2029}/);
286 0         0 return ($s, 'StringLiteral', $ln);
287             };
288              
289 10 50 33     39 m/\A0/ and
      66        
290             ( s/\A(0[0-7]+)//i or
291             s/\A(0x[0-9a-f]+)//i or
292             s/\A(0b[01]+)//i ) and return (oct($1), 'NumberLiteral', $ln);
293 10 100       66 s/\A((?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)//
294             and return ($1, 'NumberLiteral', $ln);
295              
296 7 50       20 s/\A\;// and return (';', 'StatementTerminator', $ln);
297 7 100       38 s/\A([.,(){}\[\]])// and return ($1, $1, $ln);
298 4 50       11 s/\A\&&// and return ('&&', 'AndOp', $ln);
299 4 50       10 s/\A\|\|// and return ('||', 'OrOp', $ln);
300 4 50       10 s/\A\+\+// and return ('++', 'PrefixOp', $ln);
301 4 50       29 s/\A\-\-// and return ('--', 'PrefixOp', $ln);
302 4 50       17 s/\A([*\/%+\-&^|]=)// and return ($1, 'AssignmentOp', $ln);
303 4 50       10 s/\A\<<=// and return ('<<=', 'AssignmentOp', $ln);
304 4 50       9 s/\A\>>>=// and return ('>>>=', 'AssignmentOp', $ln);
305 4 50       11 s/\A\>>=// and return ('>>=', 'AssignmentOp', $ln);
306 4 50       11 s/\A\<
307 4 50       15 s/\A\>>>// and return ('>>>', 'ShiftOp', $ln);
308 4 50       8 s/\A\>>// and return ('>>', 'ShiftOp', $ln);
309 4 50       11 s/\A\<=// and return ('<=', 'RelOp', $ln);
310 4 50       11 s/\A\>=// and return ('>=', 'RelOp', $ln);
311 4 50       8 s/\A([!=]==?)// and return ($1, 'EqOp', $ln);
312 4 100       25 s/\A([=+\-<>*\/%&^|~!?:])//
313             and return ($1, $ops{$1}, $ln);
314              
315             s/\A\#([^$nl]+)[$nl]//os
316 2 50       53 and do {
317 0         0 $self->{line}++;
318 0         0 return ($1, 'Pragma', $ln);
319             };
320             }
321              
322 2         9 return ('', '', $ln);
323              
324             }
325              
326             sub identifier {
327 1     1 0 2 my $self = shift;
328 1         3 my @token = $self->_get_token;
329 1         4 my $t = $token[1];
330              
331 1 0 33     6 unless ($t eq 'Identifier' or $t eq 'Property' or $t eq 'Reserved') {
      33        
332 0         0 $self->_unget_token(@token);
333 0         0 return;
334             }
335 1 50       7 if ($t eq 'Reserved') {
336 0         0 $self->_warn(2, '"%s" should not use as an identifier because it is reserved future', $token[0]);
337             }
338 1         6 return $token[0];
339             }
340              
341             =begin comment
342              
343             $self->_unget_token(@token);
344              
345             unget the token.
346              
347             =cut
348              
349             sub _unget_token {
350 78     78   173 my ($self, @token) = @_;
351              
352 78         90 push @{$self->{ungets}}, [@token];
  78         206  
353 78         193 $self->{line}-=$token[2];
354             }
355              
356             =begin comment
357              
358             $self->_check_token($tokens);
359              
360             take $tokens for the token type(s) to check. text for one token,
361             and arrayref for two or more tokens.
362             if $tokens matched the next token, read(skip) and return the token.
363             if not match, unget the token and return undef.
364              
365             =cut
366              
367             sub _check_token {
368 14     14   23 my ($self, $tokens) = @_;
369              
370 14 50       49 $tokens = [$tokens] unless ref($tokens);
371 14         39 my @token = $self->_get_token;
372 14 50       42 if (@token) {
373 14         27 for my $c (@$tokens) {
374 14 100       152 return @token if $c eq $token[1];
375             }
376 13         37 $self->_unget_token(@token);
377             }
378 13         87 return;
379             }
380              
381             sub _check_token_fatal {
382 0     0   0 my @token = &_check_token;
383 0 0 0     0 $_[0]->_error($_[2]||'Syntax error') unless $token[1];
384 0         0 return @token;
385             }
386              
387             =begin comment
388              
389             $keep = $self->_keep_context;
390              
391             keep the compiler context to $keep.
392              
393             =cut
394              
395 1     1   66590 use Storable 'dclone';
  1         14696  
  1         23656  
396              
397             sub _keep_context {
398 0     0   0 my $self = shift;
399             return {
400 0         0 text => $self->{text},
401             line => $self->{line},
402             scope => $self->{scope}[-1] ? dclone($self->{scope}) : [],
403 0 0       0 ungets => [@{$self->{ungets}}],
404             };
405             }
406              
407             =begin comment
408              
409             $self->_restore_context($keep);
410              
411             restore the kept context.
412              
413             =cut
414              
415             sub _restore_context {
416 0     0   0 my ($self, $keep) = @_;
417 0         0 $self->{text} = $keep->{text};
418 0         0 $self->{line} = $keep->{line};
419 0         0 $self->{scope} = $keep->{scope};
420 0         0 $self->{ungets} = $keep->{ungets};
421             }
422              
423             sub new_node {
424 54     54 0 90 my ($self, $node) = @_;
425              
426 54         405 bless { line => $self->{line}, stat => $self->{stat}, node => [], regvars => $self->{regvars}[-1]}, "SWF::Builder::ActionScript::SyntaxNode::$node";
427             }
428              
429             sub new_scope {
430 0     0 0 0 my $self = shift;
431 0 0       0 return unless $self->{stat}{Optimize} & O_REGISTER;
432              
433 0         0 my $scope = {
434             vars => {
435             this => { count => 0, start => 0, end => 0, preload => 1 },
436             arguments => { count => 0, start => 0, end => 0, preload => 1 },
437             super => { count => 0, start => 0, end => 0, preload => 1 },
438             _root => { count => 0, start => 0, end => 0, preload => 1 },
439             _parent => { count => 0, start => 0, end => 0, preload => 1 },
440             _global => { count => 0, start => 0, end => 0, preload => 1 },
441             },
442             count => 0, # node count
443             preload => [], # variables to need to preload
444             };
445 0         0 push @{$self->{scope}}, $scope;
  0         0  
446 0         0 push @{$self->{regvars}}, {};
  0         0  
447             }
448              
449             sub exit_scope { # assign local variables to registers.
450 0     0 0 0 my $self = shift;
451 0 0       0 return unless $self->{stat}{Optimize} & O_REGISTER;
452 0         0 my $scope = pop @{$self->{scope}};
  0         0  
453 0         0 my $regvars = pop @{$self->{regvars}};
  0         0  
454 0 0       0 my $reg_count = ($self->{stat}{Optimize} & O_LOCALREG) ? 255 : 3;
455 0         0 my $node_count = $scope->{count};
456 0         0 my $vars = $scope->{vars};
457              
458 0         0 my @vars;
459 0         0 my $null = pack("b$node_count", '0' x $node_count);
460 0         0 my @regmap = ($null) x $reg_count;
461 0         0 my $regno = 0;
462              
463 0 0       0 if ($self->{stat}{Optimize} & O_LOCALREG) {
464 0         0 for my $prevar (qw/ this arguments super _root _parent _global /) {
465 0 0       0 next if $vars->{$prevar}{count} <= 0;
466 0         0 my $v_start = $vars->{$prevar}{start};
467 0         0 my $v_end = $vars->{$prevar}{end};
468 0         0 $regmap[$regno] |= pack("b$node_count", '0' x $v_start . '1' x ($v_end - $v_start + 1));
469 0         0 $regvars->{$prevar} = ++$regno;
470             }
471 0 0       0 @vars = sort{$vars->{$b}{count}<=>$vars->{$a}{count}} grep {$vars->{$_}{count} > 0 and !exists($regvars->{$_})} keys %$vars;
  0         0  
  0         0  
472             } else {
473 0         0 @vars = sort{$vars->{$b}{count}<=>$vars->{$a}{count}} grep {$vars->{$_}{count} > $vars->{$_}{preload}} keys %$vars;
  0         0  
  0         0  
474             }
475              
476 0         0 for my $v (@vars) {
477 0         0 my $v_start = $vars->{$v}{start};
478 0         0 my $v_end = $vars->{$v}{end};
479 0         0 my $v_bits = pack("b$node_count", '0' x $v_start . '1' x ($v_end - $v_start + 1));
480 0         0 for (my $i = 0; $i < $reg_count; $i++) {
481 0 0       0 next if (($regmap[$i] & $v_bits) ne $null) ;
482 0         0 $regmap[$i] |= $v_bits;
483 0         0 $regvars->{$v} = $i+1;
484 0         0 last;
485             }
486             }
487              
488 0         0 my $i = 0;
489 0         0 while ( $i < $reg_count ) {
490 0 0       0 last if ($regmap[$i++] eq $null) ;
491             }
492 0         0 $regvars->{' regcount'} = $i;
493             }
494              
495             sub countup_node {
496 0     0 0 0 my $self = shift;
497 0 0       0 return unless $self->{stat}{Optimize} & O_REGISTER;
498 0         0 $self->{scope}[-1]{count}++;
499             }
500              
501             sub add_var {
502 0     0 0 0 my ($self, $var, $initcount, $preload) = @_;
503 0 0       0 return unless $self->{stat}{Optimize} & O_REGISTER;
504 0         0 my $scope = $self->{scope}[-1];
505 0 0       0 return unless defined $scope; # top level (not in function).
506 0         0 my $vars = $scope->{vars};
507 0 0       0 $self->_error("Variable '%s' is already declared", $var) if exists $vars->{$var};
508 0         0 $vars->{$var} = {count => $initcount, start => $scope->{count}, end => $scope->{count}, preload => $preload};
509             }
510              
511             sub use_var {
512 2     2 0 5 my ($self, $var) = @_;
513 2 50       11 return unless $self->{stat}{Optimize} & O_REGISTER;
514 0         0 my $scope = $self->{scope}[-1];
515 0 0       0 return unless defined $scope; # top level (not in function).
516              
517 0         0 my $vars = $scope->{vars};
518 0 0       0 if (exists $vars->{$var}) { # if $var is declared in the current scope...
519              
520             # negative count means the var should not be assigned to register
521             # (using in the inner scope).
522              
523 0 0       0 return if ($vars->{$var}{count} < 0);
524              
525             # count up $var.
526             # $_x are treated as register variables. weighted.
527              
528 0         0 $vars->{$var}{end} = $scope->{count};
529 0 0 0     0 if ($vars->{$var}{count} == 0 and !(($self->{stat}{Optimize} & O_LOCALREG) and $vars->{$var}{preload}) ) {
      0        
530 0         0 $vars->{$var}{start} = $scope->{count};
531 0         0 push @{$scope->{preload}}, $var;
  0         0  
532             }
533 0 0       0 if ($var =~ /^\$_/) {
534 0         0 $vars->{$var}{count} += 100;
535             } else {
536 0         0 $vars->{$var}{count}++;
537             }
538             } else { # search outer scope.
539 0         0 my $i = -1;
540 0         0 while (defined($scope = $self->{scope}[--$i])) {
541 0         0 my $vars = $scope->{vars};
542 0 0 0     0 if (exists $vars->{$var} and $vars->{$var}{count} >= 0) {
543              
544             # If the var is declared in the outer scope,
545             # it should not be assigned to register. negate.
546              
547 0         0 $vars->{$var}{count} = -$vars->{$var}{count}-1;
548 0         0 last;
549             }
550             }
551             }
552             }
553              
554             sub source_elements {
555 2     2 0 4 my $self = shift;
556 2         3 my ($c, $cf);
557 2         13 my $node = $self->new_node('SourceElements');
558              
559 2   66     10 while($c = ($self->function_declaration || $self->statement)) {
560 2 50       11 if (ref($c)=~/:Function$/) {
561 0         0 $node->unshift_node($c);
562             } else {
563 2         12 $node->add_node($c);
564             }
565 2         8 $cf = 1;
566             }
567 2 50       10 return ((defined $cf) ? $node : undef);
568             }
569              
570             sub function_declaration {
571 4     4 0 9 my $self = shift;
572              
573 4 50       14 $self->_check_token('Function') or return;
574              
575 0         0 my $name = $self->identifier;
576 0 0       0 $self->_error('Function name is necessary to declare function') unless $name;
577              
578 0         0 $self->function_expression($name);
579             }
580              
581              
582             sub statement {
583 4     4 0 7 my $self = shift;
584 4         10 my @token = $self->_get_token;
585 4 100       19 return unless $token[1];
586 2         5 for($token[1]) {
587 2 50       10 /^\{$/ and do {
588 0         0 my $statements = $self->new_node('StatementBlock');
589 0         0 $statements->add_node($self->statement) until $self->_check_token('}');
590 0         0 return $statements;
591             };
592 2 50       8 /^StatementTerminator$/ and return $self->new_node('NullStatement');
593 2 50       7 /^Statement$/ and do {
594 0         0 for ($token[0]) {
595 0 0       0 /^var$/ and do {
596 0         0 my $r = $self->variable_declaration_list;
597 0         0 $self->_statement_terminator;
598 0         0 return $r;
599             };
600 0 0       0 /^if$/ and return $self->if_statement;
601 0 0       0 /^for$/ and return $self->for_statement;
602 0 0       0 /^do$/ and return $self->do_while_statement;
603 0 0       0 /^while$/ and return $self->while_statement;
604 0 0       0 /^with$/ and return $self->with_statement;
605 0 0       0 /^switch$/ and return $self->switch_statement;
606              
607 0 0       0 /^ifFrameLoaded$/ and return $self->ifframeloaded_statement;
608 0 0       0 /^tellTarget$/ and return $self->telltarget_statement;
609              
610             # simple actions.
611 0 0       0 /^continue$/ and do {
612 0         0 $self->_statement_terminator;
613 0         0 return $self->new_node('ContinueStatement');
614              
615             };
616 0 0       0 /^break$/ and do {
617 0         0 $self->_statement_terminator;
618 0         0 return $self->new_node('BreakStatement');
619             };
620 0 0       0 /^return$/ and do {
621 0         0 my $n = $self->new_node('ReturnStatement');
622 0         0 eval{$self->_statement_terminator};
  0         0  
623 0 0       0 if ($@) {
624 0 0       0 die if $@!~/^Syntax/;
625 0 0       0 my $e = $self->expression or $self->_error('Syntax error.');
626 0         0 $n->add_node($e);
627 0         0 $self->_statement_terminator;
628             }
629 0         0 return $n;
630             };
631              
632 0         0 $self->_error('Syntax error');
633             }
634             };
635 2 50       9 /^Pragma$/ and do {
636 0         0 $self->_warn(2, 'Pragma is not supported');
637             };
638             }
639 2         9 $self->_unget_token(@token);
640 2         11 $self->expression_statement;
641             }
642              
643             sub variable_declaration_list {
644 0     0 0 0 my $self = shift;
645 0         0 my $node = $self->new_node('VariableDeclarationList');
646 0         0 do {
647 0         0 my $v = $self->variable_declaration;
648 0         0 $node->add_node($v);
649             } while ($self->_check_token(','));
650 0         0 return $node;
651             }
652              
653             sub variable_declaration {
654 0     0 0 0 my $self = shift;
655 0 0       0 my $i = $self->identifier or $self->_error("Error token '%s', identifier expected.", ($self->_get_token)[0]);
656 0         0 my $n = $self->new_node('VariableDeclaration');
657 0 0       0 if (my @op = $self->_check_token('AssignmentOp')) {
658 0 0       0 $self->_error("Syntax error") if $op[0] ne '=';
659 0         0 $self->add_var($i, 1);
660 0 0       0 my $e = $self->assignment_expression or $self->_error("Syntax error");
661 0         0 $n->add_node($i, $e);
662 0         0 return bless $n, 'SWF::Builder::ActionScript::SyntaxNode::VariableDeclarationWithParam';
663             } else {
664 0         0 $self->add_var($i, 0);
665 0         0 $n->add_node($i);
666 0         0 return $n;
667             }
668             }
669              
670             sub telltarget_statement {
671 0     0 0 0 my $self = shift;
672              
673 0         0 $self->_warn_not_recommend("'tellTarget' action", "'with'");
674 0         0 $self->_check_token_fatal('(');
675 0 0       0 my $e = $self->expression or $self->_error("Target movieclip is needed in 'tellTarget'.");
676 0         0 my $n = $self->new_node('TellTargetStatement');
677 0         0 $n->add_node($e);
678 0         0 $self->_check_token_fatal(')');
679 0         0 $n->add_node($self->statement);
680 0         0 return $n;
681             }
682              
683             sub ifframeloaded_statement {
684 0     0 0 0 my $self = shift;
685              
686 0         0 $self->_warn_not_recommend("'ifFrameLoaded' action", " property");
687 0         0 $self->_check_token_fatal('(');
688 0 0       0 my $e = $self->expression or $self->_error("Frame number is needed in 'ifFrameLoaded'.");
689 0         0 my $n = $self->new_node('IfFrameLoadedStatement');
690 0         0 $n->add_node($e);
691 0         0 $self->_check_token_fatal(')');
692 0         0 $n->add_node($self->statement);
693 0         0 return $n;
694             }
695              
696             sub switch_statement {
697 0     0 0 0 my $self = shift;
698 0         0 my $default;
699 0         0 $self->_check_token_fatal('(');
700 0 0       0 my $e = $self->expression or $self->_error("Object expression is needed in 'switch'.");
701 0         0 $self->_check_token_fatal(')');
702 0         0 $self->_check_token_fatal('{');
703 0         0 my $n = $self->new_node('SwitchStatement');
704 0         0 $n->add_node($e);
705              
706 0         0 while (my @token = $self->_check_token('Label')) {
707 0 0       0 if ($token[0] eq 'case') {
708 0 0       0 my $e = $self->expression or $self->_error('Missing case expression.');
709 0         0 $self->_check_token_fatal(':');
710 0         0 my $case = $self->new_node('CaseClause');
711 0         0 $case->add_node($e);
712 0         0 my $statements = $self->new_node('StatementBlock');
713 0         0 my @token;
714 0         0 until (@token = $self->_check_token(['Label', '}'])) {
715 0         0 $statements->add_node($self->statement);
716             }
717 0         0 $self->_unget_token(@token);
718 0         0 $case->add_node($statements);
719 0         0 $n->add_node($case);
720             } else {
721 0         0 $self->_check_token_fatal(':');
722 0         0 $default = $self->new_node('StatementBlock');
723 0         0 my @token;
724 0         0 until (@token = $self->_check_token(['Label', '}'])) {
725 0         0 $default->add_node($self->statement);
726             }
727 0         0 $self->_unget_token(@token);
728 0         0 last;
729             }
730             }
731 0         0 $self->_check_token_fatal('}');
732 0         0 $n->add_node($default);
733 0         0 return $n;
734             }
735              
736             sub with_statement {
737 0     0 0 0 my $self = shift;
738 0         0 $self->_check_token_fatal('(');
739 0 0       0 my $e = $self->expression or $self->_error("Object expression is needed in 'with'.");
740 0         0 $self->_check_token_fatal(')');
741 0         0 my $n = $self->new_node('WithStatement');
742 0         0 $n->add_node($e);
743 0         0 $self->{stat}{with}++;
744 0         0 $n->add_node($self->statement);
745 0         0 $self->{stat}{with}--;
746 0         0 return $n;
747             }
748              
749             sub while_statement {
750 0     0 0 0 my $self = shift;
751 0         0 $self->_check_token_fatal('(');
752 0         0 my $e = undef;
753 0 0       0 unless ($self->_check_token(')')) {
754 0 0       0 $e = $self->expression or $self->_error('Syntax error');
755 0         0 $self->_check_token_fatal(')');
756             }
757 0         0 my $s = $self->statement;
758 0 0 0     0 if ($self->{stat}{Optimize} & O_CONSTEXP and $e and $e->isa('SWF::Builder::ActionScript::SyntaxNode::Literal')) {
      0        
759 0 0       0 if ($e->istrue) {
760 0         0 $e = undef;
761             } else {
762 0         0 return $self->new_node('NullStatement');
763             }
764             }
765 0         0 my $n = $self->new_node('WhileStatement');
766 0         0 $n->add_node($e, $s);
767 0         0 return $n;
768             }
769              
770             sub do_while_statement {
771 0     0 0 0 my $self = shift;
772              
773 0         0 my $s = $self->statement;
774 0         0 my @token = $self->_check_token_fatal('Statement');
775 0 0       0 $self->_error("'do' without 'while'.") if $token[0] ne 'while';
776 0         0 $self->_check_token_fatal('(');
777 0         0 my $e = undef;
778 0 0       0 unless ($self->_check_token(')')) {
779 0 0       0 $e = $self->expression or $self->_error('Syntax error');
780 0         0 $self->_check_token_fatal(')');
781             }
782 0 0 0     0 if ($self->{stat}{Optimize} & O_CONSTEXP and $e and $e->isa('SWF::Builder::ActionScript::SyntaxNode::Literal')) {
      0        
783 0 0       0 if ($e->istrue) {
784 0         0 $e = undef;
785             } else {
786 0         0 return $s;
787             }
788             }
789 0         0 my $n = $self->new_node('DoWhileStatement');
790 0         0 $n->add_node($s, $e);
791              
792 0         0 return $n;
793             }
794              
795             sub if_statement {
796 0     0 0 0 my $self = shift;
797 0         0 my $line = $self->{line};
798              
799 0         0 $self->_check_token_fatal('(');
800 0         0 my $e = undef;
801 0 0       0 unless ($self->_check_token(')')) {
802 0 0       0 $e = $self->expression or $self->_error('Syntax error');
803 0         0 $self->_check_token_fatal(')');
804             }
805 0         0 my $then = $self->statement;
806 0         0 my $else;
807 0 0       0 if ($self->_check_token('Else')) {
808 0         0 $else = $self->statement;
809             }
810 0 0 0     0 if ($self->{stat}{Optimize} & O_CONSTEXP and $e and $e->isa('SWF::Builder::ActionScript::SyntaxNode::Literal')) {
      0        
811 0 0       0 if ($e->istrue) {
812 0         0 return $then;
813             } else {
814 0   0     0 return ($else || $self->new_node('NullStatement'));
815             }
816             } else {
817 0         0 my $n = $self->new_node('IfStatement');
818 0         0 $n->add_node($e, $then);
819 0 0       0 $n->add_node($else) if $else;
820 0         0 return $n;
821             }
822             }
823              
824             sub for_statement {
825 0     0 0 0 my $self = shift;
826              
827 0         0 $self->_check_token_fatal('(');
828 0         0 my $keep = $self->_keep_context;
829             {
830 0         0 my $n = $self->new_node('ForStatement');
  0         0  
831 0 0       0 if (my @token = $self->_check_token('Statement')) {
832 0 0       0 $self->_error('Syntax error.') if $token[0] ne 'var';
833 0         0 $n->add_node($self->variable_declaration_list);
834 0 0       0 $self->_check_token('StatementTerminator') or last;
835             } else {
836 0 0       0 unless ($self->_check_token('StatementTerminator')) {
837 0         0 $n->add_node($self->expression);
838 0 0       0 $self->_check_token('StatementTerminator') or last;
839             } else {
840 0         0 $n->add_node(undef);
841             }
842             }
843 0 0       0 unless ($self->_check_token('StatementTerminator')) {
844 0         0 $n->add_node($self->expression);
845 0         0 $self->_check_token_fatal('StatementTerminator');
846             } else {
847 0         0 $n->add_node(undef);
848             }
849 0 0       0 unless ($self->_check_token(')')) {
850 0         0 $n->add_node($self->expression);
851 0         0 $self->_check_token_fatal(')');
852             } else {
853 0         0 $n->add_node(undef);
854             }
855 0         0 $n->add_node($self->statement);
856 0         0 return $n;
857             }
858             {
859 0         0 $self->_restore_context($keep);
  0         0  
860              
861 0         0 my $n = $self->new_node('ForEachStatement');
862 0 0       0 if (my @token = $self->_check_token('Statement')) {
863 0 0       0 $self->_error('Syntax error.') if $token[0] ne 'var';
864 0         0 $n->add_node($self->variable_declaration);
865             } else {
866 0         0 my $l = ($self->call_or_member_expression);
867 0   0     0 for (defined($l) and ref($l->{node}[-1])||ref($l)) {
      0        
868 0 0 0     0 $self->_error("Left hand side of 'in' must be a variable or a property.") unless /:Variable$/ or /:Property$/ or /:Member$/ or ($self->{stat}{Version}<=5 and /:Arguments$/ and $l->{node}[0]{node}[0] eq 'eval');
      0        
      0        
      0        
      0        
869             }
870 0         0 $n->add_node($l);
871             }
872 0         0 $self->_check_token_fatal('In');
873 0 0       0 my $e = $self->expression or $self->_error('Syntax error.');
874 0         0 $n->add_node($e);
875 0         0 $self->_check_token_fatal(')');
876 0         0 $n->add_node($self->statement);
877 0         0 return $n;
878             }
879             }
880              
881             sub assignment_expression {
882 4     4 0 9 my $self = shift;
883              
884 4 50       21 if (my $l = $self->conditional_expression) {
885 4         11 my @op = $self->_get_token;
886 4 100       15 if ($op[1] eq 'AssignmentOp') {
887 1 50       7 $self->_error("$_ Left hand side of '%s' must be a variable or a property.", $op[0]) unless $l->_lhs;
888 1 50       5 my $v = $self->assignment_expression or $self->_error("Operator '%s' needs an operand.", $op[0]);
889 1         4 my $n = $self->new_node('AssignmentExpression');
890 1         9 $n->add_node($l, $op[0], $v);
891 1         3 return $n;
892             } else {
893 3         10 $self->_unget_token(@op);
894 3         15 return $l;
895             }
896             }
897 0         0 return;
898             }
899              
900             sub conditional_expression {
901 4     4 0 8 my $self = shift;
902              
903 4 50       15 my $e = $self->binary_op_expression or return;
904 4 50       13 $self->_check_token('ConditionalOp') or return $e;
905 0 0 0     0 ( my $a1 = $self->assignment_expression and
      0        
906             $self->_check_token(':') and
907             my $a2 = $self->assignment_expression )
908             or $self->_error('Syntax error');
909 0 0 0     0 if ($self->{stat}{Optimize} & O_CONSTEXP and $e->isa('SWF::Builder::ActionScript::SyntaxNode::Literal')) {
910 0 0       0 return $e->istrue ? $a1 : $a2;
911             }
912 0         0 my $n = $self->new_node('ConditionalExpression');
913 0         0 $n->add_node($e, $a1, $a2);
914 0         0 return $n;
915             }
916              
917             {
918             my @bin_op = (qw/ OrOp AndOp BitOrOp BitXorOp BitAndOp EqOp RelOp ShiftOp AddOp MultOp /);
919             my %literal_op_sub =
920             ( '*' => ['_binop_numbers', sub{$_[0] * $_[1]}],
921             '/' => ['_binop_numbers',
922             sub{
923             my ($dividend, $divisor) = @_;
924             if ($divisor == 0) {
925             return $INFINITY * ($dividend <=> 0);
926             } else {
927             return $dividend / $divisor;
928             }
929             }
930             ],
931             '%' => ['_binop_numbers', sub{$_[0] % $_[1]}],
932             '+' => ['_binop_Add2'],
933             '-' => ['_binop_numbers', sub{$_[0] - $_[1]}],
934             '<<' => ['_binop_numbers', sub{(abs($_[0])<<$_[1])*($_[0]<=>0)}],
935             '>>>' => ['_binop_numbers', sub{$_[0] >> $_[1]}],
936             '>>' => ['_binop_numbers', sub{(abs($_[0])>>$_[1])*($_[0]<=>0)}],
937             '<=' => ['_binop_rel', sub {$_[0] <= $_[1]}, sub {$_[0] le $_[1]}],
938             '>=' => ['_binop_rel', sub {$_[0] >= $_[1]}, sub {$_[0] ge $_[1]}],
939             '<' => ['_binop_rel', sub {$_[0] < $_[1]}, sub {$_[0] lt $_[1]}],
940             '>' => ['_binop_rel', sub {$_[0] > $_[1]}, sub {$_[0] gt $_[1]}],
941             '===' => ['_binop_StrictEquals'],
942             '!==' => ['_binop_StrictEqualsNot'],
943             '==' => ['_binop_Equals2'],
944             '!=' => ['_binop_Equals2Not'],
945             '&' => ['_binop_numbers', sub{$_[0] & $_[1]}],
946             '^' => ['_binop_numbers', sub{$_[0] ^ $_[1]}],
947             '|' => ['_binop_numbers', sub{$_[0] | $_[1]}],
948             '&&' => ['_binop_LogicalAnd'],
949             '||' => ['_binop_LogicalOr'],
950            
951             'add' => ['_binop_strings', sub{$_[0].$_[1]}],
952             'eq' => ['_binop_strings', sub{$_[0] eq $_[1]}],
953             'ne' => ['_binop_strings', sub{$_[0] ne $_[1]}],
954             'ge' => ['_binop_strings', sub{$_[0] ge $_[1]}],
955             'gt' => ['_binop_strings', sub{$_[0] gt $_[1]}],
956             'le' => ['_binop_strings', sub{$_[0] le $_[1]}],
957             'lt' => ['_binop_strings', sub{$_[0] lt $_[1]}],
958             'and' => ['_binop_booleans', sub{$_[0] && $_[1]}],
959             'or' => ['_binop_booleans', sub{$_[0] || $_[1]}],
960             );
961              
962             sub binary_op_expression {
963 40     40 0 65 my ($self, $step) = @_;
964 40   100     88 $step ||= 0;
965             {
966 40         48 my (@op, $f);
  40         44  
967 40 100       78 my $next = ($step >= 9) ? 'unary_expression' : 'binary_op_expression';
968 40 50       156 my $e1 = $self->$next($step+1) or return;
969 40         92 my $n = $self->new_node('BinaryOpExpression');
970 40         101 $n->add_node($e1);
971 40         98 while((@op = $self->_get_token)[1] eq $bin_op[$step]) {
972 1 50       6 my $e = $self->$next($step+1) or last;
973 1 50 33     45 if (!$f and $self->{stat}{Optimize} & O_CONSTEXP and
      33        
      33        
      33        
974             $e1->isa('SWF::Builder::ActionScript::SyntaxNode::Literal') and
975             (
976             $e ->isa('SWF::Builder::ActionScript::SyntaxNode::Literal') or
977             $op[0] eq '&&' or
978             $op[0] eq '||')) {
979 1         2 my ($op, @op_param) = @{$literal_op_sub{$op[0]}};
  1         11  
980 1         12 $e1 = $e1->$op($e, @op_param);
981 1         5 next;
982             } else {
983 0         0 $f = 1;
984             }
985 0         0 $n->add_node($e, $op[0]);
986 0         0 $e1=$e;
987             }
988 40         152 $self->_unget_token(@op);
989 40 50       76 unless ($f) {
    0          
990 40         219 return $e1;
991             } elsif ($step <= 1) {
992 0         0 return bless $n, 'SWF::Builder::ActionScript::SyntaxNode::'.$bin_op[$step].'Expression';
993             } else {
994 0         0 return $n;
995             }
996             }
997 0         0 return;
998             }
999             }
1000              
1001             {
1002             my %literal_unaryop =
1003             ( '!' => sub {
1004             my $l = shift->toboolean;
1005             $l->{node}[0] = -($l->{node}[0] - 1);
1006             return $l;
1007             },
1008             '~' => sub {
1009             my $l = shift->tonumber;
1010             return $l if $l->isa('SWF::Builder::ActionScript::SyntaxNode::NaN');
1011             if ($l->isa('SWF::Builder::ActionScript::SyntaxNode::Infinity')) {
1012             $l->{node}[0] = -1;
1013             return bless $l, 'SWF::Builder::ActionScript::SyntaxNode::NumberLiteral';
1014             } else {
1015             $l->{node}[0] = ~($l->{node}[0]);
1016             return $l;
1017             }
1018             },
1019             '-' => sub {
1020             my $l = shift->tonumber;
1021             return $l if $l->isa('SWF::Builder::ActionScript::SyntaxNode::NaN');
1022             $l->{node}[0] = -($l->{node}[0]);
1023             return $l;
1024             },
1025             '+' => sub {
1026             return shift->tonumber;
1027             },
1028             );
1029            
1030             sub unary_expression {
1031 5     5 0 7 my $self = shift;
1032 5         17 my @unaryop = $self->_get_token;
1033              
1034 5 50 33     53 if ($unaryop[1] eq 'UnaryOp' or $unaryop[0] eq '-' or $unaryop[0] eq '+') {
    50 33        
    50          
1035 0 0       0 my $e = $self->unary_expression or $self->_error('Syntax error');
1036 0 0 0     0 if ($self->{stat}{Optimize} & O_CONSTEXP and
1037             $e->isa('SWF::Builder::ActionScript::SyntaxNode::Literal')) {
1038 0         0 return $literal_unaryop{$unaryop[0]}->($e);
1039             } else {
1040 0         0 my $n = $self->new_node('UnaryExpression');
1041 0         0 $n->add_node($e, $unaryop[0]);
1042 0         0 return $n;
1043             }
1044             } elsif ($unaryop[1] eq 'PrefixOp') {
1045 0         0 my $e = $self->unary_expression;
1046 0 0       0 $self->_error("Operator '%s' can modify only a variable or a property.", $unaryop[0]) unless $e->_lhs;
1047 0         0 my $n = $self->new_node('PrefixExpression');
1048 0         0 $n->add_node($e, $unaryop[0]);
1049 0         0 return $n;
1050             } elsif ($unaryop[1] eq 'DeleteOp') {
1051 0         0 my $n = $self->new_node('DeleteExpression');
1052 0         0 $n->add_node($self->unary_expression, $unaryop[0]);
1053 0         0 return $n;
1054             } else {
1055 5         14 $self->_unget_token(@unaryop);
1056 5         17 return $self->postfix_expression;
1057             }
1058             }
1059             }
1060              
1061             sub postfix_expression {
1062 5     5 0 7 my $self = shift;
1063              
1064 5 50       21 my $e = ($self->call_or_member_expression) or return;
1065 5         17 my @postop = $self->_get_token;
1066 5 50 33     28 if ($postop[0] eq '++' or $postop[0] eq '--') {
1067 0 0       0 if ($postop[2]>=1) {
1068 0         0 $self->_unget_token(@postop);
1069 0         0 $self->_unget_token(';', 'StatementTerminator', 0);
1070 0         0 return $e;
1071             } else {
1072 0         0 my $n = $self->new_node('PostfixExpression');
1073 0         0 $n->add_node($e, $postop[0]);
1074 0         0 return $n;
1075             }
1076             } else {
1077 5         13 $self->_unget_token(@postop);
1078 5         23 return $e;
1079             }
1080             }
1081              
1082             sub call_or_member_expression {
1083 5     5 0 8 my $self = shift;
1084              
1085 5 50       17 my $name = $self->member_expression or return;
1086              
1087 5 100       14 return $name unless ($self->_check_token('('));
1088              
1089 1 50       6 my $args = $self->arguments or $self->_error('Syntax error');
1090 1         2 my (@members, @methods, @token);
1091              
1092             CALL_MEMBER_LOOP:
1093 1         2 for(;;) {
1094 1         2 my $m;
1095 1         3 @token = $self->_get_token;
1096 1         4 for ($token[1]) {
1097 1 50       5 /^\($/ and do {
1098 0 0       0 $m = $self->arguments or $self->_error('Arguments are needed');
1099 0         0 push @methods, $m;
1100 0 0 0     0 if (@members == 0 or ref($members[-1])=~/:MethodCall$/) {
1101 0         0 push @members, $self->new_node('MethodCall');
1102 0         0 $members[-1]->add_node('');
1103             } else {
1104 0         0 bless $members[-1], 'SWF::Builder::ActionScript::SyntaxNode::MethodCall';
1105             }
1106 0         0 last;
1107             };
1108 1 50       3 /^\.$/ and do {
1109 0 0       0 $m = $self->member or $self->_error('Member identifier is needed');
1110 0         0 push @members, $m;
1111 0         0 last;
1112             };
1113 1 50       4 /^\[$/ and do {
1114 0 0       0 $m = $self->subscript or $self->_error('Member expression is needed');
1115 0         0 push @members, $m;
1116 0         0 last;
1117             };
1118 1         4 last CALL_MEMBER_LOOP;
1119             }
1120             }
1121 1         5 $self->_unget_token(@token);
1122            
1123             FUNCtoLITERAL:
1124             {
1125 1 50 33     1 if (@members == 0 and @methods == 0 and $self->{stat}{Optimize} & O_CONSTMATH) {
  1   33     24  
1126 1         2 my $sub;
1127 1 50 33     19 if (ref($name)=~/:Variable$/) {
  0 50 33     0  
1128 0         0 $sub = '_f_'.lc($name->{node}[0]);
1129             } elsif (ref($name)=~/:MemberExpression/ and lc($name->{node}[0]{node}[0]) eq 'math' and @{$name->{node}} == 2) {
1130 0         0 $sub = '_math_'.lc($name->{node}[1]{node}[0]);
1131             } else {
1132 1         3 last FUNCtoLITERAL;
1133             }
1134 0         0 my @args;
1135 0         0 for my $a (@{$args->{node}}) {
  0         0  
1136 0 0       0 last FUNCtoLITERAL unless ($a->isa('SWF::Builder::ActionScript::SyntaxNode::Literal'));
1137 0         0 push @args, $a;
1138             }
1139 0 0       0 last FUNCtoLITERAL if @args<=0;
1140 0 0       0 last FUNCtoLITERAL unless $sub = $args[0]->can($sub);
1141 0         0 return &$sub(@args);
1142             }
1143             }
1144 1         4 my $n = $self->new_node('CallExpression');
1145 1         13 $n->add_node($name, $args, \@members, \@methods);
1146 1         5 return $n;
1147             }
1148              
1149             {
1150             my %const_prop = (
1151             key_backspace => 8,
1152             key_capslock => 20,
1153             key_control => 17,
1154             key_deletekey => 46,
1155             key_down => 40,
1156             key_end => 35,
1157             key_enter => 13,
1158             key_escape => 27,
1159             key_home => 36,
1160             key_insert => 45,
1161             key_left => 37,
1162             key_pgdn => 34,
1163             key_pgup => 33,
1164             key_right => 39,
1165             key_shift => 16,
1166             key_space => 32,
1167             key_tab => 9,
1168             key_up => 38,
1169              
1170             math_e => 2.71828182845905,
1171             math_ln2 => 0.693147180559945,
1172             math_ln10 => 2.30258509299405,
1173             math_log2e => 1.44269504088896,
1174             math_log10e => 0.434294481903252,
1175             math_pi => 3.14159265358979,
1176             math_sqrt1_2 => 0.707106781186548,
1177             math_sqrt2 => 1.4142135623731,
1178              
1179             number_max_value => 1.79769313486231e+308,
1180             number_min_value => 4.94065645841247e-324,
1181             number_nan => 'NaN',
1182             number_negative_infinity => -$INFINITY,
1183             number_positive_infinity => $INFINITY,
1184            
1185             );
1186              
1187             sub member_expression {
1188 5     5 0 9 my $self = shift;
1189            
1190 5         7 my @tree;
1191 5         10 my @token = $self->_get_token;
1192 5         13 for ($token[1]) {
1193 5 100 66     47 (/^Identifier$/ or /^Reserved$/) and do {
1194 2         9 my $n = $self->new_node('Variable');
1195 2         18 $n->add_node($token[0]);
1196 2         11 $self->use_var($token[0]);
1197 2         4 push @tree, $n;
1198 2         5 last;
1199             };
1200 3 50       19 /Literal$/ and do {
1201 3         9 my $n = $self->new_node($token[1]);
1202 3         19 $n->add_node($token[0]);
1203 3         7 push @tree, $n;
1204 3         5 last;
1205             };
1206 0 0       0 /^Function$/ and do{
1207 0         0 push @tree, $self->function_expression('');
1208 0         0 last;
1209             };
1210 0 0       0 /^New$/ and do {
1211 0 0       0 my $m = $self->member_expression or $self->_error("Invalid expression in 'new'");
1212 0         0 my $newex = $self->new_node('NewExpression');
1213 0 0       0 if ($self->_check_token('(')) {
1214 0 0       0 my $args = $self->arguments or $self->_error('Syntax error00');
1215 0         0 $newex->add_node($m, $args);
1216             } else {
1217 0         0 $newex->add_node($m, $self->new_node('Arguments'));
1218             }
1219 0         0 push @tree, $newex;
1220 0         0 last;
1221             };
1222 0 0       0 /^\(/ and do {
1223 0         0 my $e = $self->expression;
1224 0         0 $self->_check_token_fatal(')');
1225 0         0 push @tree, $e;
1226 0         0 last;
1227             };
1228 0 0       0 /^\{/ and do {
1229 0         0 push @tree, $self->object_literal;
1230 0         0 last;
1231             };
1232 0 0       0 /^\[/ and do {
1233 0         0 push @tree, $self->array_literal;
1234 0         0 last;
1235             };
1236 0 0       0 /^Property$/ and do {
1237 0 0       0 my $n = $self->new_node($self->{stat}{with}>0 ? 'Variable' : 'Property');
1238 0         0 $n->add_node($token[0]);
1239 0         0 push @tree, $n;
1240 0         0 last;
1241             };
1242 0         0 $self->_unget_token(@token);
1243 0         0 return;
1244             }
1245            
1246             MEMBER_LOOP:
1247 5         7 for (;;){
1248 6         14 @token = $self->_get_token;
1249 6         11 my $m;
1250 6         11 for ($token[1]) {
1251 6 100       18 /^\.$/ and do {
1252 1 50       5 $m = $self->member or $self->_error('Syntax error');
1253 1         2 last;
1254             };
1255 5 50       15 /^\[$/ and do {
1256 0 0       0 $m = $self->subscript or $self->_error('Syntax error');
1257 0         0 last;
1258             };
1259 5         11 last MEMBER_LOOP;
1260             }
1261 1         3 push @tree, $m;
1262             }
1263 5         14 $self->_unget_token(@token);
1264            
1265 5 100 66     20 PROPERTYtoLITERAL:
1266             {
1267 5         7 last if @tree != 2 or !($self->{stat}{Optimize} & O_CONSTMATH);
1268 1 50 33     12 last unless (ref($tree[0])=~/:Variable/ and ref($tree[1])=~/:Member/);
1269 1         5 my $prop = lc($tree[0]->{node}[0].'_'.$tree[1]->{node}[0]);
1270 1 50       6 last unless exists $const_prop{$prop};
1271 0         0 my $n = $self->new_node('NumberLiteral');
1272 0         0 $n->add_node($const_prop{$prop});
1273 0         0 $n->_chk_inf_nan;
1274 0         0 return $n;
1275             }
1276 5 100       116 return $tree[0] if @tree <= 1;
1277 1         3 my $n = $self->new_node('MemberExpression');
1278 1         8 $n->add_node(@tree);
1279 1         6 return $n;
1280             }
1281             }
1282              
1283             sub subscript {
1284 0     0 0 0 my $self = shift;
1285 0 0       0 my $e = $self->expression or return;
1286 0         0 my $n = $self->new_node('Member');
1287 0         0 $n->add_node($e);
1288 0   0     0 return ($self->_check_token(']') and $n);
1289             }
1290              
1291             sub arguments {
1292 1     1 0 3 my $self = shift;
1293 1         5 my $n = $self->new_node('Arguments');
1294              
1295 1         2 ARGUMENTS:
1296             {
1297 1         3 my @token;
1298 1 50       9 $self->_check_token(')')
1299             and return $n;
1300 1         3 do {
1301 1 50       7 my $e = $self->assignment_expression or last ARGUMENTS;
1302 1         9 $n->add_node($e);
1303 1         3 @token = $self->_get_token;
1304             } while ($token[1] eq ',');
1305 1 50       5 last ARGUMENTS unless $token[1] eq ')';
1306 1         5 return $n;
1307             }
1308 0         0 $self->_error('Syntax error');
1309             }
1310              
1311             sub member {
1312 1     1 0 3 my $self = shift;
1313              
1314 1 50       4 if (my $i = $self->identifier) {
1315 1         4 my $n = $self->new_node('Member');
1316 1         8 $n->add_node($i);
1317 1         5 return $n;
1318             } else {
1319 0         0 return;
1320             }
1321             }
1322              
1323             sub function_expression {
1324 0     0 0 0 my ($self, $name) = @_;
1325              
1326 0         0 $self->_check_token_fatal('(', "'(' is needed after 'function'");
1327              
1328 0         0 $self->new_scope;
1329              
1330 0         0 my $params = $self->new_node('FunctionParameter');
1331 0         0 my @token;
1332 0 0       0 unless ($self->_check_token(')')) {
1333 0         0 do {
1334 0 0       0 my $i = $self->identifier or $self->_error('Identifier is needed in the argument list');
1335 0         0 $params->add_node($i);
1336 0         0 $self->add_var($i, 0, 1);
1337 0         0 @token = $self->_get_token;
1338             } while ($token[1] eq ',');
1339 0 0       0 $self->_error("Missing ')'") unless $token[1] eq ')';
1340             }
1341 0         0 $self->_check_token_fatal('{', "Missing '{' for function '$name'");
1342              
1343 0         0 my $statements = $self->new_node('SourceElements');
1344 0         0 until($self->_check_token('}')) {
1345 0 0 0     0 my $c = ($self->function_declaration || $self->statement)
1346             or $self->_error("Syntax error. Missing '}' for function.");
1347 0 0       0 if ($self->{scope}[-1]) {
1348 0         0 for my $var (@{$self->{scope}[-1]{preload}}) {
  0         0  
1349 0         0 my $n = $self->new_node('PreloadVar');
1350 0         0 $n->add_node($var);
1351 0         0 $statements->add_node($n);
1352             }
1353 0         0 $self->{scope}[-1]{preload} = [];
1354             }
1355 0 0       0 if (ref($c)=~/:Function$/) {
1356 0         0 $statements->unshift_node($c);
1357             } else {
1358 0         0 $statements->add_node($c);
1359             }
1360 0         0 $self->countup_node;
1361             }
1362 0         0 my $node = $self->new_node('Function');
1363 0         0 $node->add_node($name, $params, $statements);
1364 0         0 $self->exit_scope($node);
1365              
1366 0         0 return $node;
1367             }
1368              
1369             sub object_literal {
1370 0     0 0 0 my $self = shift;
1371 0         0 my $n = $self->new_node('ObjectLiteral');
1372              
1373 0         0 OBJECT:
1374             {
1375 0         0 my @tree;
1376             my @token;
1377 0 0       0 $self->_check_token('}')
1378             and $self->_get_token, return $n;
1379 0         0 do {
1380 0         0 my $i = $self->identifier;
1381 0 0       0 last OBJECT unless $i;
1382 0 0       0 last OBJECT unless ($self->_get_token)[1] eq ':';
1383 0         0 my $e = $self->assignment_expression;
1384 0 0       0 last OBJECT unless $e;
1385 0         0 $n->add_node($i, $e);
1386 0         0 @token = $self->_get_token;
1387             } while ($token[1] eq ',');
1388 0 0       0 last OBJECT unless $token[1] eq '}';
1389 0         0 return $n;
1390             }
1391 0         0 $self->_error('Syntax error');
1392             }
1393              
1394             sub array_literal {
1395 0     0 0 0 my $self = shift;
1396 0         0 my $n = $self->new_node('ArrayLiteral');
1397              
1398 0         0 ARRAY:
1399             {
1400 0         0 my @tree;
1401             my @token;
1402 0 0       0 $self->_check_token(']')
1403             and $self->_get_token, return $n;
1404 0         0 do {
1405 0 0       0 my $e = $self->assignment_expression or last ARRAY;
1406 0         0 $n->add_node($e);
1407 0         0 @token = $self->_get_token;
1408             } while ($token[1] eq ',');
1409 0 0       0 last ARRAY unless $token[1] eq ']';
1410 0         0 return $n;
1411             }
1412 0         0 $self->_error('Syntax error');
1413             }
1414              
1415             sub expression {
1416 2     2 0 5 my $self = shift;
1417 2         5 my @tree;
1418             my @comma;
1419              
1420 2         12 my $e = $self->assignment_expression;
1421 2         9 while((@comma = $self->_get_token)[1] eq ',' ) {
1422 0         0 push @tree, $self->assignment_expression;
1423             }
1424 2         6 $self->_unget_token(@comma);
1425 2 50       10 if (@tree <= 0) {
1426 2         10 return $e;
1427             } else {
1428 0         0 my $n = $self->new_node('Expression');
1429 0         0 $n->add_node($e, @tree);
1430 0         0 return $n;
1431             }
1432             }
1433              
1434             sub expression_statement {
1435 2     2 0 4 my $self = shift;
1436 2 50       10 my $e = $self->expression or $self->_error('Syntax error');
1437 2         17 $self->_statement_terminator;
1438 2         5 my $n = $self->new_node('ExpressionStatement');
1439 2         13 $n->add_node($e);
1440 2         13 return $n;
1441             }
1442              
1443             sub _statement_terminator {
1444 2     2   6 my $self = shift;
1445 2         7 my @token = $self->_get_token;
1446 2 50       9 unless ($token[1] eq 'StatementTerminator') {
1447 2 50 33     20 if ($token[1] eq '}' or $token[2]>=1 or $token[1] eq '') {
      33        
1448 2         7 $self->_unget_token(@token);
1449 2         5 return 1;
1450             }
1451 0         0 $self->_unget_token(@token);
1452 0         0 $self->_error("Syntax error. ';' is expected.");
1453             }
1454 0         0 return 1;
1455             }
1456              
1457             ### code generator
1458              
1459             sub _code_print {
1460 0     0   0 my $self = shift;
1461 0         0 my $code = $self->{stat}{code};
1462 0         0 for (@$code) {
1463 0         0 print "$_\n";
1464             }
1465             }
1466              
1467             {
1468             my %encode = (
1469             GotoFrame => [qw/ Frame /],
1470             GetURL => [qw/ $UrlString $TargetString /],
1471             WaitForFrame => [qw/ Frame : SkipCount /],
1472             SetTarget => [qw/ $TargetName /],
1473             GotoLabel => [qw/ $Label /],
1474             WaitForFrame2 => [qw/ : SkipCount /],
1475             Jump => [qw/ : BranchOffset /],
1476             GetURL2 => [qw/ Method /],
1477             If => [qw/ : BranchOffset /],
1478             GotoFrame2 => [qw/ PlayFlag /],
1479             StoreRegister => [qw/ Register /],
1480             With => [qw/ : CodeSize /],
1481             );
1482              
1483             sub _encode {
1484 2     2   6 my ($self, $actions) = @_;
1485 2         7 my $code = $self->{stat}{code};
1486 2         5 my $lhash = $self->{stat}{labelhash};
1487 2         5 my @constant = map {_unescape($_)} grep {$self->{stat}{strings}{$_} >=2} keys %{$self->{stat}{strings}};
  0         0  
  3         15  
  2         10  
1488 2         5 my %constant;
1489 2         7 @constant{@constant} = (0..$#constant);
1490              
1491 2 50       9 if (@constant > 0) {
1492 0         0 push @$actions, SWF::Element::ACTIONRECORD->new
1493             ( Tag=>'ActionConstantPool',
1494             ConstantPool => \@constant
1495             );
1496             }
1497              
1498 2         3 my $labelf = 0;
1499 2         5 my $p = 0;
1500              
1501 2         5 for my $c (@$code) {
1502 7         43 my ($action, $param) = ($c=~/^([^ ]+) *(.+)?$/);
1503 7         10 my $tag;
1504              
1505 7 50       49 if ($action =~ /^:/) {
    100          
    50          
    50          
    50          
1506 0         0 $labelf = 1;
1507 0         0 next;
1508             } elsif ($action eq 'Push') {
1509 3         22 $tag = SWF::Element::ACTIONRECORD->new( Tag => 'ActionPush');
1510 3         484 my $dl = $tag->DataList;
1511 3         95 while(($param =~ / *([^ ]+) +\'((:?\\.|[^\'])*)\' */g)) {
1512 6         227 my ($type, $value) = ($1, $2);
1513 6 100       32 if ($type eq 'String') {
    50          
1514 3         10 $value = _unescape($value);
1515 3 50       10 if (exists $constant{$value}) {
1516 0         0 push @$dl, SWF::Element::ACTIONDATA::Lookup->new($constant{$value});
1517             } else {
1518 3         18 push @$dl, SWF::Element::ACTIONDATA::String->new($value);
1519             }
1520             } elsif ($type eq 'Number') {
1521 3 100 66     31 if ( $value=~/^-?\d+$/ and -2147483648<=$value and $value<2147483648 ) {
      66        
1522 2         19 push @$dl, SWF::Element::ACTIONDATA::Integer->new($value);
1523             } else {
1524 1         14 push @$dl, SWF::Element::ACTIONDATA::Double->new($value);
1525             }
1526             } else {
1527 0         0 push @$dl, "SWF::Element::ACTIONDATA::$type"->new($value);
1528             }
1529             }
1530             } elsif ($action eq 'DefineFunction') {
1531 0         0 $tag = SWF::Element::ACTIONRECORD->new( Tag => 'ActionDefineFunction');
1532 0         0 $param =~ s/ *\'((?:\\.|[^\'])*)\' *//;
1533 0         0 my $fname = $1;
1534 0         0 utf2bin($fname);
1535 0         0 my @args = split ' ', $param;
1536 0         0 utf2bin($_) for @args;
1537 0         0 $tag->CodeSize( $self->{stat}{labelhash}{$self->{stat}{labelhash}{pop @args}} );
1538 0         0 $tag->FunctionName($fname);
1539 0         0 $tag->Params(\@args);
1540             } elsif ($action eq 'DefineFunction2') {
1541 0         0 $tag = SWF::Element::ACTIONRECORD->new( Tag => 'ActionDefineFunction2');
1542 0         0 $param =~ s/ *\'((?:\\.|[^\'])*)\' *//;
1543 0         0 my $fname = $1;
1544 0         0 utf2bin($fname);
1545 0         0 my ($regcount, $flag, @args) = split ' ', $param;
1546 0         0 utf2bin($_) for @args;
1547 0         0 $tag->CodeSize( $self->{stat}{labelhash}{$self->{stat}{labelhash}{pop @args}} );
1548 0         0 $tag->FunctionName($fname);
1549 0         0 $tag->RegisterCount($regcount);
1550 0         0 $tag->Flags($flag);
1551 0         0 my $regp = $tag->Parameters;
1552 0         0 for my $arg (@args) {
1553 0         0 my $n = $regp->new_element;
1554 0         0 my @r = split /=/, $arg;
1555 0         0 $n->ParamName($r[0]);
1556 0         0 $n->Register($r[1]);
1557 0         0 push @$regp, $n;
1558             }
1559             } elsif (exists $encode{$action}) {
1560 0         0 my @args = ($param =~ /\'((?:\\.|[^\'])*)\'/g);
1561 0         0 $tag = SWF::Element::ACTIONRECORD->new( Tag => $action);
1562 0         0 for my $e (@{$encode{$action}}) {
  0         0  
1563 0 0       0 if ($e eq ':') {
    0          
1564 0         0 $args[0] = $self->{stat}{labelhash}{$self->{stat}{labelhash}{$args[0]}};
1565             } elsif ($e=~/^\$/) {
1566 0         0 $e=~s/^\$//;
1567 0         0 my $str = shift @args;
1568 0         0 utf2bin($str);
1569 0         0 $tag->$e($str);
1570             } else {
1571 0         0 $tag->$e(shift @args);
1572             }
1573             }
1574             } else {
1575 4         15 $tag = SWF::Element::ACTIONRECORD->new( Tag => $action);
1576             }
1577              
1578 7 50       689 if ($labelf) {
1579 0         0 $tag->LocalLabel($self->{stat}{labelhash}{$p});
1580 0         0 $labelf = 0;
1581             }
1582 7         17 push @$actions, $tag;
1583             } continue {
1584 7         16 $p++;
1585             }
1586 2         10 my $tag = SWF::Element::ACTIONRECORD->new ( Tag => 'ActionEnd' );
1587 2 50       117 if ($labelf) {
1588 0         0 $tag->LocalLabel($self->{stat}{labelhash}{$p});
1589             }
1590 2         6 push @$actions, $tag;
1591 2         5 return $actions;
1592             }
1593             }
1594              
1595             {
1596             my %escchar = (
1597             'b' => "\x08",
1598             'f' => "\x0c",
1599             'n' => "\x0a",
1600             'r' => "\x0d",
1601             't' => "\x09",
1602             'u' => 'u',
1603             'x' => 'x',
1604             '"' => '"',
1605             "'" => "'",
1606             );
1607              
1608             sub _unescape {
1609 3     3   7 my $str = shift;
1610              
1611 3         6 $str =~s[\\(u([0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F])|x([0-9a-fA-F][0-9a-fA-F])|([0-3][0-7][0-7])|.)][
1612 0 0 0     0 if ($2||$3) {
    0          
1613 0   0     0 eval(qq("\\x{).($2||$3).qq(}"));
1614             } elsif ($4) {
1615 0         0 eval(qq("\\$4"));
1616             } else {
1617 0 0       0 $escchar{$1} || '\\';
1618             }
1619             ]eg;
1620 3         9 utf2bin($str);
1621 3         7 $str;
1622             }
1623             }
1624              
1625             sub _tidy_up {
1626 2     2   3 my $self = shift;
1627 2         7 my $code = $self->{stat}{code};
1628              
1629             TIDYUP:
1630 2         9 for (my $p = 0; $p < @$code; $p++) {
1631 10         21 for ($code->[$p]) {
1632 10 50       36 if ($self->{stat}{Optimize} & O_PEEPHOLE) {
1633             # delete double not
1634 10 50 33     30 (/^Not$/ and $code->[$p+1] eq 'Not') and do {
1635 0         0 splice(@$code, $p, 2);
1636 0 0       0 $p-- if $p>0;
1637 0         0 redo TIDYUP;
1638             };
1639             # delete push and following pop
1640 10 50 66     73 (/^Push / and $code->[$p+1] eq 'Pop') and do {
1641 0         0 s/ *[^ ]+ +\'(\\.|[^\'])*\' *$//;
1642 0 0       0 if (/^Push$/) {
1643 0         0 splice(@$code, $p, 2);
1644 0 0       0 $p-- if $p>0;
1645             } else {
1646 0         0 splice(@$code, $p+1, 1);
1647             }
1648 0         0 redo TIDYUP;
1649             };
1650             # delete jump to the next step
1651 10 50 33     28 (/^Jump\s+'(.+)'/ and $code->[$p+1] eq ":$1") and do {
1652 0         0 splice(@$code, $p, 1);
1653 0 0       0 $p-- if $p>0;
1654 0         0 redo TIDYUP;
1655             };
1656             # delete the actions after jump
1657 10 50 33     30 (/^Jump / and $code->[$p+1]!~/^:/) and do {
1658 0         0 splice(@$code, $p+1, 1) while($code->[$p+1]!~/^:/);
1659 0         0 redo TIDYUP;
1660             };
1661             }
1662              
1663 10 100 100     56 (/^Push / and $code->[$p+1]=~/^Push /) and do {
1664 3         22 (my $push = $code->[$p+1]) =~s/Push//;
1665 3         8 $code->[$p].=$push;
1666 3         7 splice(@$code, $p+1, 1);
1667 3         8 redo TIDYUP;
1668             };
1669 7 50       19 /^:(.+)$/ and do {
1670 0         0 my $q = $p;
1671 0         0 my $l = $1;
1672 0   0     0 $q++ until($code->[$q]!~/^:/ or $q >= @$code);
1673 0         0 $self->{stat}{labelhash}{$l} = $q;
1674 0         0 $self->{stat}{labelhash}{$q} = "L_$l";
1675 0         0 last;
1676             };
1677 7 100 66     47 (/^Push / and / String /) and do {
1678 3         23 my @strings = / String +'((?:\\.|[^'])*)\'/g;
1679 3         21 $self->{stat}{strings}{$_}++ for (@strings);
1680 3         14 last;
1681             };
1682 4 50       28 if ($self->{stat}{Version}<=5) {
1683 0 0       0 /^StrictEquals$/ and do{
1684 0         0 $self->_warn(0, "ActionStrictEquals is only available for version 6 or higher. ActionEquals2 is used instead.");
1685 0         0 $code->[$p] = 'Equals2';
1686 0         0 last;
1687             };
1688 0 0       0 /^Greater$/ and splice(@$code, $p, 1, 'StackSwap', 'Less2'), last;
1689 0 0       0 /^StringGreater$/ and splice(@$code, $p, 1, 'StackSwap', 'StringLess'), last;
1690 0 0       0 /^InstanceOf$/ and $self->_error("'instanceof' op is only available for version 6 or higher.");
1691             }
1692             }
1693             }
1694             }
1695              
1696             {
1697             package SWF::Builder::ActionScript::Compiler::Error;
1698              
1699             sub _error {
1700 0     0   0 my $self = shift;
1701 0         0 my $msgform = shift;
1702             # my ($t) = ($self->{text}=~/([^\n]+)/);
1703 0         0 die sprintf($msgform, @_)." in ".$self->{line}."\n";
1704             }
1705              
1706             sub _warn {
1707 0     0   0 my $self = shift;
1708 0         0 my $level = shift;
1709 0         0 my $msgform = shift;
1710            
1711 0 0       0 warn sprintf($msgform, @_)." in ".$self->{line}."\n" if $level >= $self->{stat}{Warning};
1712             }
1713              
1714             sub _warn_not_recommend {
1715 0     0   0 my ($self, $not, $instead) = @_;
1716              
1717 0         0 $self->_warn(0, "$not is not recommended to use. Use $instead instead.");
1718             }
1719              
1720             sub _error_param {
1721 0     0   0 my ($self, $command) = @_;
1722            
1723 0         0 $self->_error("Wrong parameter for '%s'.", $command);
1724             }
1725             }
1726              
1727             {
1728             package SWF::Builder::ActionScript::SyntaxNode;
1729             our @ISA = ('SWF::Builder::ActionScript::Compiler::Error');
1730              
1731             sub add_node {
1732 54     54   74 my $self = shift;
1733 54         61 push @{$self->{node}}, @_;
  54         240  
1734             }
1735              
1736             sub unshift_node {
1737 0     0   0 my $self = shift;
1738 0         0 unshift @{$self->{node}}, @_;
  0         0  
1739             }
1740              
1741              
1742             sub _tree_dump {
1743 0     0   0 my ($self, $indent, $line)=@_;
1744 0         0 my ($nodename) = (ref($self)=~/([^:]+)$/);
1745              
1746 0   0     0 $indent ||= 0;
1747 0 0       0 print ((($self->{line} != $line) ? sprintf('%3d: ', $self->{line}) : ' '), ' ' x ($indent*4), "$nodename [\n");
1748 0         0 for my $node (@{$self->{node}}) {
  0         0  
1749 0 0       0 if (ref($node)) {
1750 0         0 eval{$node->_tree_dump($indent+1, $self->{line})};
  0         0  
1751 0 0       0 if ($@) {
1752 0         0 print STDERR "\n",ref($self),"\n",ref($node),"\n";
1753 0         0 die;
1754             }
1755             } else {
1756 0         0 print ' ', ' ' x (($indent+1)*4), "'$node'\n";
1757             }
1758             }
1759 0         0 print ' ', ' ' x ($indent*4), "]\n";
1760             }
1761              
1762 0     0   0 sub _lhs {
1763             }
1764             }
1765              
1766             {
1767             package SWF::Builder::ActionScript::SyntaxNode::NullStatement;
1768             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
1769            
1770 0     0   0 sub compile {}
1771             }
1772              
1773             {
1774             package SWF::Builder::ActionScript::SyntaxNode::List;
1775             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
1776            
1777             sub compile {
1778 2     2   4 my $self = shift;
1779            
1780 2         3 for my $s (@{$self->{node}}) {
  2         8  
1781 2         9 $s->compile;
1782             }
1783             }
1784             }
1785             @SWF::Builder::ActionScript::SyntaxNode::SourceElements::ISA=('SWF::Builder::ActionScript::SyntaxNode::List');
1786             @SWF::Builder::ActionScript::SyntaxNode::StatementBlock::ISA=('SWF::Builder::ActionScript::SyntaxNode::List');
1787             @SWF::Builder::ActionScript::SyntaxNode::VariableDeclarationList::ISA=('SWF::Builder::ActionScript::SyntaxNode::List');
1788              
1789             {
1790             package SWF::Builder::ActionScript::SyntaxNode::VariableDeclaration;
1791             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
1792              
1793             sub compile {
1794 0     0   0 my ($self, $context) = @_; # $context = lvalue if 'for var x in ...'
1795 0         0 my $code = $self->{stat}{code};
1796 0         0 my $regvars = $self->{regvars};
1797 0         0 my $var = $self->{node}[0];
1798              
1799 0 0 0     0 if ($regvars and exists $regvars->{$var}) {
1800 0 0 0     0 push @$code, "StoreRegister '".$regvars->{$var}."'", 'Pop', -2 if defined($context) and $context eq 'lvalue';
1801             } else {
1802 0 0       0 push @$code, "Push String '$var'", ($context eq 'lvalue' ? ("DefineLocal", -1) : ("DefineLocal2"));
1803             }
1804             }
1805             }
1806              
1807             {
1808             package SWF::Builder::ActionScript::SyntaxNode::VariableDeclarationWithParam;
1809             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
1810            
1811             sub compile {
1812 0     0   0 my $self = shift;
1813 0         0 my $code = $self->{stat}{code};
1814 0         0 my $regvars = $self->{regvars};
1815 0         0 my $var = $self->{node}[0];
1816              
1817 0 0 0     0 if ($regvars and exists $regvars->{$var}) {
1818 0         0 $self->{node}[1]->compile('value');
1819 0         0 push @$code, "StoreRegister '".$regvars->{$var}."'", 'Pop';
1820             } else {
1821 0         0 push @$code, "Push String '$var'";
1822 0         0 $self->{node}[1]->compile('value');
1823 0         0 push @$code, "DefineLocal";
1824             }
1825             }
1826             }
1827              
1828             {
1829             package SWF::Builder::ActionScript::SyntaxNode::BinaryOpExpression;
1830             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
1831              
1832             my %bin_ops =
1833             ( '*' => ['Multiply'],
1834             '/' => ['Divide'],
1835             '%' => ['Modulo'],
1836             '+' => ['Add2'],
1837             '-' => ['Subtract'],
1838             '<<' => ['BitLShift'],
1839             '>>>' => ['BitURShift'],
1840             '>>' => ['BitRShift'],
1841             '<=' => ['Greater', 'Not'],
1842             '>=' => ['Less2', 'Not'],
1843             '<' => ['Less2'],
1844             '>' => ['Greater'],
1845             'instanceof' => ['InstanceOf'],
1846             '===' => ['StrictEquals'],
1847             '!==' => ['StrictEquals', 'Not'],
1848             '==' => ['Equals2'],
1849             '!=' => ['Equals2', 'Not'],
1850             '&' => ['BitAnd'],
1851             '^' => ['BitXor'],
1852             '|' => ['BitOr'],
1853              
1854             'add' => ['StringAdd'],
1855             'eq' => ['StringEquals'],
1856             'ne' => ['StringEquals', 'Not'],
1857             'ge' => ['StringLess', 'Not'],
1858             'gt' => ['StringGreater'],
1859             'le' => ['StringGreater', 'Not'],
1860             'lt' => ['StringLess'],
1861            
1862             );
1863             my %obsolete = (add=>'+', eq=>'==', ne=>'!=', ge=>'>=', gt=>'>', le=>'<=', lt=>'<');
1864              
1865             sub compile {
1866 0     0   0 my ($self, $context) = @_;
1867 0         0 my $node = $self->{node};
1868 0         0 my $code = $self->{stat}{code};
1869              
1870 0         0 shift(@$node)->compile($context);
1871              
1872 0         0 while(@$node) {
1873 0         0 my $term = shift(@$node);
1874 0         0 my $op = shift(@$node);
1875 0 0       0 $self->_warn_not_recommend("'$op' op", "'$obsolete{$op}'") if exists($obsolete{$op});
1876 0         0 $term->compile($context);
1877 0 0       0 if ($context) {
1878 0         0 push @$code, @{$bin_ops{$op}};
  0         0  
1879             } else {
1880 0         0 $self->_warn(1, "Useless use of '$op' in void context.");
1881             }
1882             }
1883             }
1884             }
1885              
1886             {
1887             package SWF::Builder::ActionScript::SyntaxNode::Expression;
1888             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
1889              
1890             sub compile {
1891 0     0   0 my ($self, $context) = @_;
1892 0         0 my $last = pop @{$self->{node}};
  0         0  
1893              
1894 0         0 for my $e (@{$self->{node}}) {
  0         0  
1895 0         0 $e->compile;
1896             }
1897 0         0 $last->compile($context);
1898             }
1899             }
1900              
1901             {
1902             package SWF::Builder::ActionScript::SyntaxNode::ExpressionStatement;
1903             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
1904              
1905             sub compile {
1906 2     2   3 my $self = shift;
1907              
1908 2         10 $self->{node}[0]->compile;
1909             }
1910             }
1911              
1912             {
1913             package SWF::Builder::ActionScript::SyntaxNode::Literal;
1914             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
1915              
1916             sub compile {
1917 1     1   3 my ($self, $context) = @_;
1918              
1919 1         18 my ($type) = (ref($self) =~/([A-Za-z]+)Literal/);
1920 1 50       4 ($context =~/lc?value/) and $self->_error("Can't modify literal item");
1921 1 50       4 push @{$self->{stat}{code}}, "Push $type '".$self->{node}[0]."'" if $context;
  1         8  
1922 1         3 $self;
1923             }
1924              
1925             sub toboolean {
1926 0     0   0 my $self = shift;
1927 0         0 $self->{node}[0] = $self->istrue;
1928 0         0 bless $self, 'SWF::Builder::ActionScript::SyntaxNode::BooleanLiteral';
1929             }
1930              
1931             sub _totrue {
1932 0     0   0 my $self = shift;
1933 0         0 $self->{node}[0] = 1;
1934 0         0 bless $self, 'SWF::Builder::ActionScript::SyntaxNode::BooleanLiteral';
1935             }
1936              
1937             sub _tofalse {
1938 0     0   0 my $self = shift;
1939 0         0 $self->{node}[0] = 0;
1940 0         0 bless $self, 'SWF::Builder::ActionScript::SyntaxNode::BooleanLiteral';
1941             }
1942              
1943 0     0   0 sub isvalue {1}
1944              
1945             sub _binop_numbers {
1946 1     1   2 my ($self, $term, $opsub) = @_;
1947 1         11 $self->tonumber;
1948 1         3 $term->tonumber;
1949 1 50       10 return $term if $term->isa('SWF::Builder::ActionScript::SyntaxNode::NaN');
1950 1         7 $self->{node}[0] = &$opsub($self->{node}[0], $term->{node}[0]);
1951 1         6 $self->_chk_inf_nan;
1952             }
1953              
1954             sub _binop_rel {
1955 0     0   0 my ($self) = @_;
1956 0         0 &_binop_numbers;
1957 0         0 $self->toboolean;
1958             }
1959              
1960             sub _binop_strings {
1961 0     0   0 my ($self, $term, $opsub) = @_;
1962 0         0 $self->tostring;
1963 0         0 $term->tostring;
1964              
1965 0         0 $self->{node}[0] = &$opsub($self->{node}[0], $term->{node}[0]);
1966 0         0 $self;
1967             }
1968              
1969             sub _binop_booleans {
1970 0     0   0 my ($self, $term, $opsub) = @_;
1971 0         0 $self->toboolean;
1972 0         0 $term->toboolean;
1973              
1974 0         0 $self->{node}[0] = &$opsub($self->{node}[0], $term->{node}[0]);
1975 0         0 $self;
1976             }
1977              
1978             sub _binop_Add2 {
1979 0     0   0 my ($self, $term) = @_;
1980              
1981 0 0       0 if ($term->isa('SWF::Builder::ActionScript::SyntaxNode::StringLiteral')) {
1982 0         0 $self->tostring->_binop_Add2($term);
1983             } else {
1984 0         0 $self->tonumber->_binop_Add2($term);
1985             }
1986             }
1987              
1988             sub _binop_LogicalAnd {
1989 0     0   0 my ($self, $term) = @_;
1990              
1991 0 0       0 if ($self->istrue) {
1992 0         0 $term;
1993             } else {
1994 0         0 $self->toboolean;
1995             }
1996             }
1997              
1998             sub _binop_LogicalOr {
1999 0     0   0 my ($self, $term) = @_;
2000              
2001 0 0       0 return ($self->istrue ? $self : $term);
2002             }
2003              
2004             sub _binop_Equals2Not {
2005 0     0   0 my ($self, $term) = @_;
2006 0         0 $self->_binop_Equals2($term);
2007 0         0 $self->{node}[0] = 1-$self->{node}[0];
2008 0         0 $self;
2009             }
2010              
2011             sub _binop_StrictEquals2Not {
2012 0     0   0 my ($self, $term) = @_;
2013 0         0 $self->_binop_StrictEquals2($term);
2014 0         0 $self->{node}[0] = 1-$self->{node}[0];
2015 0         0 $self;
2016             }
2017              
2018             sub _binop_StrictEquals {
2019 0     0   0 my ($self, $term) = @_;
2020 0         0 my ($t_self) = (ref($self)=~/([^:]+)$/);
2021 0         0 my ($t_term) = (ref($term)=~/([^:]+)$/);
2022              
2023 0 0 0     0 return $self->_tofalse if ($t_self ne $t_term) or ($t_self eq 'NaN') or ($t_term eq 'NaN');
      0        
2024 0 0       0 if ($t_self eq 'NumberLiteral') {
2025 0 0       0 if ($self->{node}[0] == $term->{node}[0]) {
2026 0         0 return $self->_totrue;
2027             } else {
2028 0         0 return $self->_tofalse;
2029             }
2030             } else {
2031 0 0       0 if ($self->{node}[0] eq $term->{node}[0]) {
2032 0         0 return $self->_totrue;
2033             } else {
2034 0         0 return $self->_tofalse;
2035             }
2036             }
2037             }
2038              
2039             sub __nf1 {
2040 0     0   0 my $fnn = shift;
2041 0         0 my $fns = shift;
2042 0         0 my $num = shift;
2043 0 0       0 $num->_error_param($fnn) if @_;
2044            
2045 0         0 $num->tonumber;
2046 0 0       0 return $num if $num->isa('SWF::Builder::ActionScript::SyntaxNode::NaN');
2047 0         0 $num->{node}[0] = &$fns($num->{node}[0]);
2048 0         0 $num->tostring->tonumber;
2049             }
2050              
2051 0     0   0 sub _f_int {__nf1('int', sub{int shift}, @_)}
  0     0   0  
2052              
2053 0     0   0 sub _math_abs {__nf1('Math.abs', sub{abs shift}, @_)}
  0     0   0  
2054             sub _math_acos {__nf1('Math.acos',
2055             sub{
2056 0     0   0 my $x = shift;
2057 0 0       0 return 'NaN' if abs($x)>1;
2058 0         0 return atan2(1-$x*$x, $x);
2059             },
2060 0     0   0 @_)}
2061             sub _math_asin {__nf1('Math.asin',
2062             sub{
2063 0     0   0 my $x = shift;
2064 0 0       0 return 'NaN' if abs($x)>1;
2065 0         0 return atan2($x, 1-$x*$x);
2066             },
2067 0     0   0 @_)}
2068 0     0   0 sub _math_atan {__nf1('Math.atan', sub{atan2(1, shift)}, @_)}
  0     0   0  
2069             sub _math_ceil {__nf1('Math.ceil',
2070             sub{
2071 0     0   0 my $x = shift;
2072 0         0 my $ix = int($x);
2073 0 0       0 return $x if $x == $ix;
2074 0         0 return $ix+($x>0);
2075             },
2076 0     0   0 @_)}
2077 0     0   0 sub _math_cos {__nf1('Math.cos', sub{cos shift}, @_)}
  0     0   0  
2078 0     0   0 sub _math_exp {__nf1('Math.exp', sub{exp shift}, @_)}
  0     0   0  
2079             sub _math_floor{__nf1('Math.floor',
2080             sub{
2081 0     0   0 my $x = shift;
2082 0         0 my $ix = int($x);
2083 0 0       0 return $x if $x == $ix;
2084 0         0 return $ix-($x<0);
2085             },
2086 0     0   0 @_)}
2087             sub _math_log {__nf1('Math.log',
2088             sub{
2089 0     0   0 my $x = shift;
2090 0 0       0 return 'NaN' if $x<0;
2091 0 0       0 return '-Infinity' if $x == 0;
2092 0         0 return log($x);
2093             },
2094 0     0   0 @_)}
2095             sub _math_round{__nf1('Math.round',
2096             sub{
2097 0     0   0 my $x = shift;
2098 0         0 my $ix = int($x+0.5*($x<=>0));
2099 0 0       0 return ($ix==$x-0.5)?int($x):$ix;
2100             },
2101 0     0   0 @_)}
2102 0     0   0 sub _math_sin {__nf1('Math.sin', sub{sin shift}, @_)}
  0     0   0  
2103             sub _math_sqrt {__nf1('Math.sqrt',
2104             sub{
2105 0     0   0 my $x = shift;
2106 0 0       0 return 'NaN' if $x<0;
2107 0         0 return sqrt($x);
2108             },
2109 0     0   0 @_)}
2110             sub _math_tan {__nf1('Math.tan',
2111             sub{
2112 0     0   0 my $r = shift;
2113 0 0       0 return ($r<0 ? '-Infinity':'Infinity') if cos($r)==0;
    0          
2114 0         0 return sin($r)/cos($r);
2115             },
2116 0     0   0 @_)}
2117              
2118             sub __nf2 {
2119 0     0   0 my $fnn = shift;
2120 0         0 my $fns = shift;
2121 0         0 my $num1 = shift;
2122 0         0 my $num2 = shift;
2123 0 0       0 $num1->_error_param($fnn) if @_;
2124            
2125 0         0 $num1->tonumber;
2126 0         0 $num2->tonumber;
2127 0 0 0     0 return $num1 if $num1->isa('SWF::Builder::ActionScript::SyntaxNode::NaN') or $num2->isa('SWF::Builder::ActionScript::SyntaxNode::NaN');
2128 0         0 $num1->{node}[0] = &$fns($num1->{node}[0], $num2->{node}[0]);
2129 0         0 $num1->tostring->tonumber;
2130             }
2131              
2132 0     0   0 sub _math_atan2 {__nf2('Math.atan2', sub{atan2($_[0], $_[1])}, @_)}
  0     0   0  
2133 0 0   0   0 sub _math_max {__nf2('Math.max', sub{my($a,$b)=@_;$a>$b?$a:$b}, @_)}
  0     0   0  
  0         0  
2134 0 0   0   0 sub _math_min {__nf2('Math.min', sub{my($a,$b)=@_;$a>$b?$b:$a}, @_)}
  0     0   0  
  0         0  
2135             sub _math_pow {__nf2('Math.pow',
2136             sub {
2137 0     0   0 my ($base, $exp) = @_;
2138 0 0 0     0 if ($base < 0 and $exp != int($exp)) {
2139 0         0 return 'NaN';
2140             } else {
2141 0         0 return $base ** $exp;
2142             }
2143             },
2144 0     0   0 @_)}
2145              
2146              
2147             }
2148              
2149             {
2150             package SWF::Builder::ActionScript::SyntaxNode::BooleanLiteral;
2151             our @ISA=('SWF::Builder::ActionScript::SyntaxNode::Literal');
2152              
2153             sub tonumber {
2154 0     0   0 bless shift, 'SWF::Builder::ActionScript::SyntaxNode::NumberLiteral';
2155             }
2156              
2157             sub tostring {
2158 0     0   0 my $self = shift;
2159 0 0       0 $self->{node}[0] = $self->{node}[0] ? 'true' : 'false';
2160 0         0 bless $self, 'SWF::Builder::ActionScript::SyntaxNode::StringLiteral';
2161             }
2162              
2163 0     0   0 sub toboolean {shift}
2164             sub istrue {
2165 0     0   0 my $self = shift;
2166 0 0       0 return ($self->{node}[0] != 0)? 1 : 0;
2167             }
2168              
2169             sub _binop_Equals2 {
2170 0     0   0 my ($self, $term) = @_;
2171              
2172 0 0       0 unless ($term->isvalue) {
    0          
2173 0         0 $self->{node}[0] = 0;
2174 0         0 $self;
2175             } elsif ($term->isa('SWF::Builder::ActionScript::SyntaxNode::BooleanLiteral')) {
2176 0 0       0 $self->{node}[0] = ($self->{node}[0] == $term->{node}[0]) ? 1:0;
2177 0         0 $self;
2178             } else {
2179 0         0 $self->tonumber->_binop_Equals2($term);
2180             }
2181             }
2182             }
2183              
2184             {
2185             package SWF::Builder::ActionScript::SyntaxNode::NaN;
2186             our @ISA=('SWF::Builder::ActionScript::SyntaxNode::NumberLiteral');
2187              
2188             sub compile {
2189 0     0   0 my ($self, $context) = @_;
2190              
2191 0 0       0 ($context =~/lc?value/) and $self->_error("Can't modify literal item");
2192 0 0       0 push @{$self->{stat}{code}}, "Push Number 'NaN'" if $context;
  0         0  
2193 0         0 $self;
2194             }
2195              
2196 0     0   0 sub istrue {0}
2197 0     0   0 sub isvalue {0}
2198 0     0   0 sub _binop_Equals2 {shift->_tofalse}
2199 0     0   0 sub _binop_numbers {shift}
2200 0     0   0 sub _binop_rel {shift->_tofalse}
2201              
2202             sub _binop_Add2 {
2203 0     0   0 my ($self, $term) = @_;
2204              
2205 0 0       0 if ($term->isa('SWF::Builder::ActionScript::SyntaxNode::StringLiteral')) {
2206 0         0 $self->tostring->_binop_Add2($term);
2207             } else {
2208 0         0 $self;
2209             }
2210             }
2211              
2212             }
2213              
2214             {
2215             package SWF::Builder::ActionScript::SyntaxNode::Infinity;
2216             our @ISA=('SWF::Builder::ActionScript::SyntaxNode::NumberLiteral');
2217              
2218             sub compile {
2219 1     1   3 my ($self, $context) = @_;
2220              
2221 1 50       4 ($context =~/lc?value/) and $self->_error("Can't modify literal item");
2222 1         4 my $value = $self->{node}[0];
2223 1         4 my $packed = pack('d', $value);
2224              
2225 1 50       8 if ($packed eq $NINF) {
    50          
2226 0         0 $value = '-Infinity';
2227             } elsif ($packed eq $INF) {
2228 1         4 $value = 'Infinity';
2229             }
2230 1 50       4 push @{$self->{stat}{code}}, "Push Number '$value'" if $context;
  1         4  
2231 1         10 $self;
2232             }
2233              
2234 0     0   0 sub istrue {1}
2235              
2236             sub _binop_Add2 {
2237 0     0   0 my ($self, $term) = @_;
2238              
2239 0 0 0     0 if ($term->isa('SWF::Builder::ActionScript::SyntaxNode::StringLiteral')) {
    0          
2240 0         0 return $self->tostring->_binop_Add2($term);
2241             } elsif ($term->isa('SWF::Builder::ActionScript::SyntaxNode::Infinity') &&
2242             $self->{node}[0] ne $term->{node}[0]) {
2243 0         0 $self->{node}[0] = 'NaN';
2244 0         0 bless $self, 'SWF::Builder::ActionScript::SyntaxNode::NaN';
2245             } else {
2246 0         0 $self;
2247             }
2248             }
2249              
2250             sub _binop_Equals2 {
2251 0     0   0 my ($self, $term) = @_;
2252 0         0 $term->tonumber;
2253 0 0       0 if ($self->{node}[0] eq $term->{node}[0]) {
2254 0         0 $self->_totrue;
2255             } else {
2256 0         0 $self->_tofalse;
2257             }
2258             }
2259             }
2260              
2261             {
2262             package SWF::Builder::ActionScript::SyntaxNode::NumberLiteral;
2263             our @ISA=('SWF::Builder::ActionScript::SyntaxNode::Literal');
2264            
2265 2     2   5 sub tonumber{shift}
2266              
2267             sub tostring {
2268 0     0   0 bless shift, 'SWF::Builder::ActionScript::SyntaxNode::StringLiteral';
2269             }
2270              
2271             sub istrue {
2272 0     0   0 my $self = shift;
2273 0 0       0 return ($self->{node}[0] != 0)? 1 : 0;
2274             }
2275              
2276             sub _chk_inf_nan {
2277 1     1   2 my $self = shift;
2278 1         3 my $value = $self->{node}[0];
2279              
2280 1 50       11 return bless $self, 'SWF::Builder::ActionScript::SyntaxNode::NaN' if $value eq 'NaN';
2281              
2282 1         5 my $packed = pack('d', $value);
2283 1 50       6 return $self if (($packed & $INF) ne $INF);
2284              
2285 1 50       5 if (($packed & $MANTISSA) ne "\x00" x 8) {
2286 0         0 $self->{node}[0] = 'NaN';
2287 0         0 bless $self, 'SWF::Builder::ActionScript::SyntaxNode::NaN';
2288             } else {
2289 1         5 bless $self, 'SWF::Builder::ActionScript::SyntaxNode::Infinity';
2290             }
2291 1         4 $self;
2292             }
2293              
2294             sub _binop_Add2 {
2295 0     0   0 my ($self, $term) = @_;
2296              
2297 0 0       0 if ($term->isa('SWF::Builder::ActionScript::SyntaxNode::StringLiteral')) {
2298 0         0 $self->tostring->_binop_Add2($term);
2299             } else {
2300 0         0 $term->tonumber;
2301 0 0 0     0 return $term
2302             if ($term->isa('SWF::Builder::ActionScript::SyntaxNode::NaN') ||
2303             $term->isa('SWF::Builder::ActionScript::SyntaxNode::Infinity'));
2304              
2305 0         0 $self->{node}[0] += $term->{node}[0];
2306 0         0 $self->_chk_inf_nan;
2307             }
2308             }
2309              
2310             sub _binop_Equals2 {
2311 0     0   0 my ($self, $term) = @_;
2312              
2313 0 0       0 unless ($term->isvalue) {
    0          
2314 0         0 return $self->_tofalse;
2315             } elsif ($term->isa('SWF::Builder::ActionScript::SyntaxNode::Infinity')) {
2316 0         0 return $self->_tofalse;
2317             } else {
2318 0         0 $term->tonumber;
2319 0 0       0 if ($self->{node}[0] == $term->{node}[0]) {
2320 0         0 return $self->_totrue;
2321             } else {
2322 0         0 return $self->_tofalse;
2323             }
2324             }
2325             }
2326             }
2327              
2328             {
2329             package SWF::Builder::ActionScript::SyntaxNode::StringLiteral;
2330             our @ISA=('SWF::Builder::ActionScript::SyntaxNode::Literal');
2331              
2332             sub compile {
2333 0     0   0 my ($self, $context) = @_;
2334              
2335 0 0       0 ($context =~/lc?value/) and $self->_error("Can't modify literal item");
2336 0         0 my $value = $self->{node}[0];
2337 0         0 $value =~ s/([\x00-\x1f\x7f-\xff])/sprintf('\\x%2.2x', ord($1))/eg;
  0         0  
2338 0 0       0 push @{$self->{stat}{code}}, "Push String '".$value."'" if $context;
  0         0  
2339 0         0 $self;
2340             }
2341              
2342 0     0   0 sub tostring{shift}
2343              
2344             sub _getnumber {
2345 0     0   0 my $self = shift;
2346 0         0 my $value = $self->{node}[0];
2347 0 0 0     0 if ($value=~/^0[0-7]+$/ or $value=~/^0x[0-9a-f]$/i) {
    0 0        
2348 0         0 $value = oct($value);
2349             } elsif ($value !~ /^(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/ and $value !~ /^[-+]?Infinity$/) {
2350 0         0 $value = '';
2351             }
2352 0         0 return $value;
2353             }
2354              
2355             sub tonumber {
2356 0     0   0 my $self = shift;
2357 0         0 my $value = $self->_getnumber;
2358 0         0 $self->{node}[0] = $value;
2359              
2360 0 0       0 if ($value =~ /^([-+]?)Infinity$/) {
    0          
2361 0 0       0 $self->{node}[0] = ($1 eq '-' ? -$INFINITY: $INFINITY);
2362 0         0 bless $self, 'SWF::Builder::ActionScript::SyntaxNode::Infinity';
2363             } elsif ($value eq '') {
2364 0         0 $self->{node}[0] = 'NaN';
2365 0         0 bless $self, 'SWF::Builder::ActionScript::SyntaxNode::NaN';
2366             } else {
2367 0         0 bless $self, 'SWF::Builder::ActionScript::SyntaxNode::NumberLiteral';
2368             }
2369             }
2370              
2371             sub istrue {
2372 0     0   0 my $self = shift;
2373 0 0       0 return ($self->_getnumber ? 1 : 0);
2374             }
2375              
2376             sub _binop_rel {
2377 0     0   0 my ($self, $term, $opsub, $opsub2) = @_;
2378              
2379 0 0       0 unless ($term->isa('SWF::Builder::ActionScript::SyntaxNode::StringLiteral')) {
2380 0         0 $self->tonumber->_binop_rel($term, $opsub);
2381             } else {
2382 0         0 $self->{node}[0] = &$opsub2($self->{node}[0], $term->{node}[0]);
2383 0         0 $self->toboolean;
2384             }
2385             }
2386              
2387             sub _binop_Equals2 {
2388 0     0   0 my ($self, $term) = @_;
2389              
2390 0 0       0 unless ($term->isvalue) {
    0          
2391 0         0 return $self->_tofalse;
2392             } elsif ($term->isa('SWF::Builder::ActionScript::SyntaxNode::StringLiteral')) {
2393 0 0       0 if ($self->{node}[0] eq $term->{node}[0]) {
2394 0         0 return $self->_totrue;
2395             } else {
2396 0         0 return $self->_tofalse;
2397             }
2398             } else {
2399 0         0 $self->tonumber->_binop_Equals2($term);
2400             }
2401             }
2402              
2403             sub _binop_Add2 {
2404 0     0   0 my ($self, $term) = @_;
2405 0         0 $self->{node}[0] .= $term->{node}[0];
2406 0         0 $self;
2407             }
2408             }
2409              
2410             {
2411             package SWF::Builder::ActionScript::SyntaxNode::NULLLiteral;
2412             our @ISA=('SWF::Builder::ActionScript::SyntaxNode::Literal');
2413              
2414             sub tostring {
2415 0     0   0 my $self = shift;
2416 0         0 $self->{node}[0] = 'null';
2417 0         0 bless $self, 'SWF::Builder::ActionScript::SyntaxNode::StringLiteral';
2418             }
2419              
2420             sub tonumber {
2421 0     0   0 my $self = shift;
2422 0         0 $self->{node}[0] = 0;
2423 0         0 bless $self, 'SWF::Builder::ActionScript::SyntaxNode::NumberLiteral';
2424             }
2425              
2426 0     0   0 sub istrue {0}
2427 0     0   0 sub isvalue {0}
2428             sub _binop_Equals2 {
2429 0     0   0 my ($self, $term) = @_;
2430 0 0 0     0 if ($term->isa('SWF::Builder::ActionScript::SyntaxNode::UNDEFLiteral') or
2431             $term->isa('SWF::Builder::ActionScript::SyntaxNode::NULLLiteral')) {
2432 0         0 $self->_totrue;
2433             } else {
2434 0         0 $self->_tofalse;
2435             }
2436             }
2437             }
2438              
2439             {
2440             package SWF::Builder::ActionScript::SyntaxNode::UNDEFLiteral;
2441             our @ISA=('SWF::Builder::ActionScript::SyntaxNode::Literal');
2442              
2443             sub tostring {
2444 0     0   0 bless shift, 'SWF::Builder::ActionScript::SyntaxNode::StringLiteral';
2445             }
2446              
2447             sub tonumber {
2448 0     0   0 my $self = shift;
2449 0         0 $self->{node}[0] = 0;
2450 0         0 bless $self, 'SWF::Builder::ActionScript::SyntaxNode::NumberLiteral';
2451             }
2452              
2453 0     0   0 sub istrue {0}
2454 0     0   0 sub isvalue {0}
2455             sub _binop_Equals2 {
2456 0     0   0 my ($self, $term) = @_;
2457 0 0 0     0 if ($term->isa('SWF::Builder::ActionScript::SyntaxNode::UNDEFLiteral') or
2458             $term->isa('SWF::Builder::ActionScript::SyntaxNode::NULLLiteral')) {
2459 0         0 $self->_totrue;
2460             } else {
2461 0         0 $self->_tofalse;
2462             }
2463             }
2464              
2465             }
2466              
2467              
2468             {
2469             package SWF::Builder::ActionScript::SyntaxNode::ObjectLiteral;
2470             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2471              
2472             sub compile {
2473 0     0   0 my ($self, $context) = @_;
2474 0         0 my $node = $self->{node};
2475              
2476 0 0       0 ($context =~/lc?value/) and SWF::Builder::ActionScript::SyntaxNode::_error("Can't modify literal item");
2477 0         0 my $code = $self->{stat}{code};
2478 0         0 my $count = @$node / 2;
2479 0         0 while (@$node) {
2480 0         0 my $prop = shift @$node;
2481 0         0 my $value = shift @$node;
2482 0         0 push @$code, "Push String '$prop'";
2483 0         0 $value->compile('value');
2484             }
2485 0         0 push @$code, "Push Number '$count'", "InitObject";
2486 0 0       0 push @$code, "Pop" unless $context;
2487             }
2488             }
2489             {
2490             package SWF::Builder::ActionScript::SyntaxNode::ArrayLiteral;
2491             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2492              
2493             sub compile {
2494 0     0   0 my ($self, $context) = @_;
2495 0 0       0 ($context =~/lc?value/) and SWF::Builder::ActionScript::SyntaxNode::_error("Can't modify literal item");
2496 0         0 my $code = $self->{stat}{code};
2497 0         0 my $count = @{$self->{node}};
  0         0  
2498 0         0 for my $value (reverse @{$self->{node}}) {
  0         0  
2499 0         0 $value->compile('value');
2500             }
2501 0         0 push @$code, "Push Number '$count'", "InitArray";
2502 0 0       0 push @$code, "Pop" unless $context;
2503             }
2504             }
2505             {
2506             package SWF::Builder::ActionScript::SyntaxNode::PreloadVar;
2507             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2508              
2509             sub compile {
2510 0     0   0 my $self = shift;
2511 0         0 my $var = $self->{node}[0];
2512 0         0 my $regvars = $self->{regvars};
2513 0 0 0     0 if ($regvars and exists $regvars->{$var}) {
2514 0         0 push @{$self->{stat}{code}}, "Push String '$var'"
  0         0  
2515             , "GetVariable"
2516             , "StoreRegister '".$regvars->{$var}."'"
2517             , "Pop";
2518             }
2519 0         0 $self;
2520             }
2521             }
2522             {
2523             package SWF::Builder::ActionScript::SyntaxNode::Variable;
2524             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2525              
2526             sub compile {
2527 2     2   5 my ($self, $context) = @_;
2528 2         7 my $code = $self->{stat}{code};
2529 2         4 my $regvars = $self->{regvars};
2530 2         6 my $var = $self->{node}[0];
2531              
2532 2 50 33     10 if ($regvars and exists $regvars->{$var}) {
2533 0 0       0 push @$code, "Push Register '".$regvars->{$var}."'" if $context ne 'lvalue';
2534 0 0 0     0 push @$code, "StoreRegister '".$regvars->{$var}."'", 'Pop', -2 if $context eq 'lvalue' or $context eq 'lcvalue';
2535             } else {
2536 2         92 push @$code, "Push String '$var'";
2537 2 100 66     15 push @$code, 'GetVariable' if $context eq 'value' or not $context;
2538 2 100       9 push @$code, 'SetVariable', -1 if $context eq 'lvalue';
2539 2 50       8 push @$code, 'PushDuplicate', 'GetVariable', 'SetVariable', -1 if $context eq 'lcvalue';
2540             }
2541 2 50       6 push @$code, "Pop" unless $context;
2542 2         6 $self;
2543             }
2544              
2545 1     1   5 sub _lhs {1}
2546             }
2547             {
2548             package SWF::Builder::ActionScript::SyntaxNode::Property;
2549             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2550              
2551             sub compile {
2552 0     0   0 my ($self, $context) = @_;
2553 0         0 my $code = $self->{stat}{code};
2554 0         0 push @$code, "Push String '' ";
2555 0         0 push @$code, "Push Property '".lc($self->{node}[0])."'";
2556 0 0 0     0 push @$code, 'GetProperty' if $context eq 'value' or not $context;
2557 0 0       0 push @$code, 'SetProperty', -1 if $context eq 'lvalue';
2558 0 0       0 push @$code, "Push String '' ", "Push Property '".lc($self->{node}[0])."'", 'GetProperty', 'SetProperty', -1 if $context eq 'lcvalue';
2559 0 0       0 push @$code, "Pop" unless $context;
2560 0         0 $self;
2561             }
2562              
2563 0     0   0 sub _lhs {1}
2564             }
2565              
2566             {
2567             package SWF::Builder::ActionScript::SyntaxNode::MemberExpression;
2568             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2569              
2570             sub compile {
2571 1     1   3 my ($self, $context) = @_;
2572 1         2 my @node = @{$self->{node}};
  1         5  
2573 1         3 my $code = $self->{stat}{code};
2574              
2575 1         7 shift(@node)->compile('value');
2576 1 50       3 return unless @node;
2577 1         3 my $last = pop @node;
2578 1         12 for my $member (@node){
2579 0         0 $member->compile('value');
2580             }
2581 1         6 $last->compile($context);
2582             }
2583              
2584 0     0   0 sub _lhs {1}
2585             }
2586              
2587             {
2588             package SWF::Builder::ActionScript::SyntaxNode::Member;
2589             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2590              
2591             sub compile {
2592 1     1   2 my ($self, $context) = @_;
2593 1         4 my $code = $self->{stat}{code};
2594 1         4 my $member = $self->{node}[0];
2595              
2596 1 50       5 push @$code, 'PushDuplicate' if $context eq 'lcvalue';
2597 1 50       3 if (ref($member)) {
2598 0         0 $member->compile('value');
2599             } else {
2600 1         6 push @$code, "Push String '".$member."'";
2601             }
2602 1 50       11 if ($context eq 'lvalue') {
    50          
    50          
    50          
2603 0         0 push @$code, 'SetMember', -1;
2604             } elsif ($context eq 'value') {
2605 0         0 push @$code, 'GetMember';
2606             } elsif ($context eq 'lcvalue') {
2607 0         0 push @$code, "StoreRegister '0'",'GetMember', "Push Register '0'", 'StackSwap', 'SetMember', -1;
2608             } elsif (not defined $context) {
2609 0         0 push @$code, 'GetMember', 'Pop';
2610             }
2611             }
2612             }
2613              
2614             {
2615             package SWF::Builder::ActionScript::SyntaxNode::AssignmentExpression;
2616             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2617 1     1   18 use constant \%O;
  1         2  
  1         1473  
2618              
2619             my %as_ops =
2620             ( '*=' => 'Multiply',
2621             '/=' => 'Divide',
2622             '%=' => 'Modulo',
2623             '+=' => 'Add2',
2624             '-=' => 'Subtract',
2625             '<<=' => 'BitLShift',
2626             '>>>=' => 'BitURShift',
2627             '>>=' => 'BitRShift',
2628             '&=' => 'BitAnd',
2629             '^=' => 'BitXor',
2630             '|=' => 'BitOr',
2631             );
2632              
2633             sub compile {
2634 1     1   3 my ($self, $context) = @_;
2635 1         2 my ($lhe, $op, $e) = @{$self->{node}};
  1         4  
2636 1         5 my $code = $self->{stat}{code};
2637 1         2 my $opt = $self->{stat}{Optimize} & O_LEFTONCE;
2638 1 50 33     7 my $as_context = ($op eq '=' or !$opt)? 'lvalue' : 'lcvalue';
2639              
2640 1         14 $lhe->compile($as_context);
2641 1         2 my $lv = pop @$code;
2642 1         5 my @lv = splice(@$code, $lv);
2643 1 50 33     5 $lhe->compile('value') if (!$opt and $op ne '=');
2644 1         14 $e->compile('value');
2645 1 50       4 push @$code, $as_ops{$op} if exists $as_ops{$op};
2646 1 50       4 push @$code, "StoreRegister '0'" if $context;
2647 1         2 push @$code, @lv;
2648 1 50       21 push @$code, "Push Register '0'" if $context;
2649             }
2650             }
2651              
2652             {
2653             package SWF::Builder::ActionScript::SyntaxNode::AndOpExpression;
2654             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2655              
2656             sub compile {
2657 0     0   0 my ($self, $context) = @_;
2658 0         0 my $node = $self->{node};
2659 0         0 my $label = $self->{stat}{label}++;
2660 0         0 my $code = $self->{stat}{code};
2661              
2662 0         0 shift(@$node)->compile('value');
2663              
2664 0         0 my ($term, $op);
2665 0         0 while(@$node) {
2666 0         0 $term = shift @$node;
2667 0         0 $op = shift @$node;
2668 0 0       0 if ($op eq '&&') {
2669 0         0 push @$code, 'PushDuplicate', 'Not', "If '$label'", 'Pop';
2670 0         0 $term->compile('value');
2671             } else { # $op eq 'and'
2672 0         0 $self->_warn_not_recommend("'and' op", "'&&'");
2673 0         0 $term->compile('value');
2674 0         0 push @$code, 'And';
2675             }
2676             }
2677 0         0 push @$code, ":$label";
2678 0 0       0 push @$code, "Pop" unless $context;
2679             }
2680             }
2681             {
2682             package SWF::Builder::ActionScript::SyntaxNode::OrOpExpression;
2683             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2684              
2685             sub compile {
2686 0     0   0 my ($self, $context) = @_;
2687 0         0 my $node = $self->{node};
2688 0         0 my $label = $self->{stat}{label}++;
2689 0         0 my $code = $self->{stat}{code};
2690              
2691 0         0 shift(@$node)->compile('value');
2692              
2693 0         0 my ($term, $op);
2694 0         0 while(@$node) {
2695 0         0 $term = shift @$node;
2696 0         0 $op = shift @$node;
2697 0 0       0 if ($op eq '||') {
2698 0         0 push @$code, 'PushDuplicate', "If '$label'", 'Pop';
2699 0         0 $term->compile('value');
2700             } else { # $op eq 'or'
2701 0         0 $self->_warn_not_recommend("'or' op", "'||'");
2702 0         0 $term->compile('value');
2703 0         0 push @$code, 'Or';
2704             }
2705             }
2706 0         0 push @$code, ":$label";
2707 0 0       0 push @$code, "Pop" unless $context;
2708             }
2709             }
2710             {
2711             package SWF::Builder::ActionScript::SyntaxNode::ConditionalExpression;
2712             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2713              
2714             sub compile {
2715 0     0   0 my ($self, $context) = @_;
2716 0         0 my $node = $self->{node};
2717 0         0 my $label1 = $self->{stat}{label}++;
2718 0         0 my $label2 = $self->{stat}{label}++;
2719 0         0 my $code = $self->{stat}{code};
2720              
2721 0         0 $node->[0]->compile('value');
2722 0         0 push @$code, "If '$label1'";
2723 0         0 $node->[2]->compile($context);
2724 0         0 push @$code, "Jump '$label2'", ":$label1";
2725 0         0 $node->[1]->compile($context);
2726 0         0 push @$code, ":$label2";
2727             }
2728             }
2729             {
2730             package SWF::Builder::ActionScript::SyntaxNode::ReturnStatement;
2731             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2732 1     1   10 use constant \%O;
  1         2  
  1         30735  
2733              
2734             sub compile {
2735 0     0   0 my $self = shift;
2736 0         0 my $ret = shift(@{$self->{node}});
  0         0  
2737 0         0 my $opt = $self->{stat}{Optimize};
2738 0         0 my $code = $self->{stat}{code};
2739              
2740              
2741 0 0       0 if (defined($ret)) {
2742 0         0 $ret->compile('value');
2743             } else {
2744 0         0 push @$code, "Push UNDEF ''";
2745             }
2746              
2747 0 0 0     0 if (($opt & O_REGISTER) and !($opt & O_LOCALREG) and (my $regcount = $self->{regvars}{' regcount'}) > 0) {
      0        
2748 0         0 push @$code, "StoreRegister '0'", "Pop";
2749 0         0 for (my $i = $regcount; $i >= 1; $i--) {
2750 0         0 push @$code, "StoreRegister '$i'", "Pop";
2751             }
2752 0         0 push @$code, "Push Register '0'";
2753             }
2754              
2755 0         0 push @$code, "Return";
2756             }
2757             }
2758              
2759             {
2760             package SWF::Builder::ActionScript::SyntaxNode::IfStatement;
2761             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2762              
2763             sub compile {
2764 0     0   0 my $self = shift;
2765 0         0 my $stat = $self->{stat};
2766 0         0 my $label1 = $stat->{label}++;
2767 0         0 my $code = $stat->{code};
2768 0         0 my $node = $self->{node};
2769              
2770 0         0 $node->[0]->compile('value');
2771 0 0       0 if ($node->[2]) { # else block
2772 0         0 my $label2 = $stat->{label}++;
2773 0         0 push @$code, "If '$label2'";
2774 0         0 $node->[2]->compile;
2775 0         0 push @$code, "Jump '$label1'", ":$label2";
2776             } else {
2777 0         0 push @$code, "Not", "If '$label1'";
2778             }
2779 0         0 $node->[1]->compile;
2780 0         0 push @$code, ":$label1";
2781             }
2782             }
2783             {
2784             package SWF::Builder::ActionScript::SyntaxNode::ContinueStatement;
2785             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2786              
2787             sub compile {
2788 0     0   0 my $self = shift;
2789 0         0 my $code = $self->{stat}{code};
2790 0         0 my $loop = $self->{stat}{loop};
2791 0         0 my $actions;
2792 0 0       0 $actions = $loop->[-1][0] if (defined $loop->[-1]);
2793 0 0       0 $self->_error("Can't \"continue\" outside a loop block ") unless defined $actions;
2794 0         0 push @$code, @$actions;
2795             }
2796             }
2797             {
2798             package SWF::Builder::ActionScript::SyntaxNode::BreakStatement;
2799             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2800              
2801             sub compile {
2802 0     0   0 my $self = shift;
2803 0         0 my $code = $self->{stat}{code};
2804 0         0 my $loop = $self->{stat}{loop};
2805 0         0 my $actions;
2806 0 0       0 if (defined $loop->[-1]) {
2807 0         0 $actions = $loop->[-1][1];
2808 0         0 $loop->[-1][-1]++;
2809             }
2810 0 0       0 $self->_error("Can't \"break\" outside a loop block ") unless defined $actions;
2811 0         0 push @$code, @$actions;
2812             }
2813             }
2814              
2815             {
2816             package SWF::Builder::ActionScript::SyntaxNode::WhileStatement;
2817             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2818              
2819             sub compile {
2820 0     0   0 my $self = shift;
2821 0         0 my $stat = $self->{stat};
2822 0         0 my ($cond, $block) = @{$self->{node}};
  0         0  
2823 0         0 my $enter_label = $stat->{label}++;
2824 0         0 my $break_label = $stat->{label}++;
2825 0         0 my $code = $stat->{code};
2826 0         0 my $loop = $stat->{loop};
2827              
2828 0         0 push @$loop, [["Jump '$enter_label'"], ["Jump '$break_label'"], 0 ];
2829 0         0 push @$code, ":$enter_label";
2830 0 0       0 if ($cond) {
2831 0         0 $cond->compile('value');
2832 0         0 push @$code, 'Not', "If '$break_label'";
2833             }
2834 0         0 $block->compile;
2835 0         0 push @$code, "Jump '$enter_label'", ":$break_label";
2836 0         0 pop @$loop;
2837             }
2838             }
2839             {
2840             package SWF::Builder::ActionScript::SyntaxNode::DoWhileStatement;
2841             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2842              
2843             sub compile {
2844 0     0   0 my $self = shift;
2845 0         0 my $stat = $self->{stat};
2846 0         0 my ($block, $cond) = @{$self->{node}};
  0         0  
2847 0         0 my $enter_label = $stat->{label}++;
2848 0         0 my $cont_label = $stat->{label}++;
2849 0         0 my $break_label = $stat->{label}++;
2850 0         0 my $code = $stat->{code};
2851 0         0 my $loop = $stat->{loop};
2852              
2853 0         0 push @$loop, [["Jump '$cont_label'"], ["Jump '$break_label'"], 0 ];
2854 0         0 push @$code, ":$enter_label";
2855 0         0 $block->compile;
2856 0         0 push @$code, ":$cont_label";
2857 0 0       0 if ($cond) {
2858 0         0 $cond->compile('value');
2859 0         0 push @$code, "If '$enter_label'";
2860             } else {
2861 0         0 push @$code, "Jump '$enter_label'";
2862             }
2863 0         0 push @$code, ":$break_label";
2864 0         0 pop @$loop;
2865             }
2866             }
2867             {
2868             package SWF::Builder::ActionScript::SyntaxNode::ForEachStatement;
2869             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2870              
2871             sub compile {
2872 0     0   0 my $self = shift;
2873 0         0 my $stat = $self->{stat};
2874 0         0 my ($var, $obj, $statements) = @{$self->{node}};
  0         0  
2875 0         0 my $loop_out = $stat->{label}++;
2876 0         0 my $break_label = $stat->{label}++;
2877 0         0 my $cont_label = $stat->{label}++;
2878 0         0 my $code = $stat->{code};
2879 0         0 my $loop = $stat->{loop};
2880              
2881 0         0 push @$loop, [["Jump '$cont_label'"], ["Jump '$break_label'"], 0];
2882              
2883 0         0 $obj->compile('value');
2884 0         0 push @$code, "Enumerate2", ":$cont_label", "StoreRegister '0'", "Push NULL ''", "Equals2", "If '$loop_out'";
2885 0         0 $var->compile('lvalue');
2886 0         0 my $lv = pop @$code;
2887 0         0 my @lv = splice(@$code, $lv);
2888 0         0 push @$code, "Push Register '0'", @lv;
2889 0         0 $statements->compile;
2890 0         0 push @$code, "Jump '$cont_label'";
2891 0 0       0 if ($loop->[-1][-1]>0) {
2892 0         0 push @$code, ":$break_label", "Push NULL ''", "Equals2", "Not", "If '$break_label'", ;
2893             }
2894 0         0 push @$code, ":$loop_out";
2895 0         0 pop @$loop;
2896             }
2897             }
2898              
2899             {
2900             package SWF::Builder::ActionScript::SyntaxNode::SwitchStatement;
2901             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2902              
2903             sub compile {
2904 0     0   0 my $self = shift;
2905 0         0 my $stat = $self->{stat};
2906 0         0 my ($cond, @cases) = @{$self->{node}};
  0         0  
2907 0         0 my $default = pop @cases;
2908 0         0 my $break_label = $stat->{label}++;
2909 0         0 my $code = $stat->{code};
2910 0         0 my $loop = $stat->{loop};
2911              
2912 0 0       0 push @$loop, [(defined ($loop->[-1]) ? [ "Pop", @{$loop->[-1][0]}] : undef), ["Jump '$break_label'"], 0 ];
  0         0  
2913 0         0 $cond->compile('value');
2914 0         0 for my $case (@cases) {
2915 0         0 my $label = $stat->{label}++;
2916 0         0 push @$code, "PushDuplicate";
2917 0         0 $case->{node}[0]->compile('value');
2918 0         0 push @$code, "StrictEquals", "If '$label'";
2919 0         0 $case->{label} = $label;
2920             }
2921 0         0 my $default_label = $stat->{label}++;
2922 0         0 push @$code, "Jump '$default_label'";
2923 0         0 for my $case (@cases) {
2924 0         0 push @$code, ":".$case->{label};
2925 0         0 $case->{node}[1]->compile;
2926             }
2927 0         0 push @$code, ":$default_label";
2928 0 0       0 $default->compile if $default;
2929 0         0 push @$code, ":$break_label", "Pop";
2930 0         0 pop @$loop;
2931             }
2932             }
2933             {
2934             package SWF::Builder::ActionScript::SyntaxNode::CaseClause;
2935             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2936              
2937             sub compile {
2938 0     0   0 my $self = shift;
2939 0         0 my $stat = $self->{stat};
2940 0         0 my ($cond, $statements) = @{$self->{node}};
  0         0  
2941 0         0 my $label = $stat->{label};
2942 0         0 my $code = $stat->{code};
2943              
2944 0         0 push @$code, "dup";
2945 0         0 $cond->compile('value');
2946 0         0 push @$code, "StrictEquals", "Not", "If '$label'";
2947 0 0       0 if (@$statements) {
2948 0         0 $statements->compile;
2949 0         0 push @$code, ":$label";
2950 0         0 $stat->{label}++;
2951             }
2952             }
2953             }
2954             {
2955             package SWF::Builder::ActionScript::SyntaxNode::ForStatement;
2956             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2957              
2958             sub compile {
2959 0     0   0 my $self = shift;
2960 0         0 my $stat = $self->{stat};
2961 0         0 my ($init, $cond, $rep, $block) = @{$self->{node}};
  0         0  
2962 0         0 my $enter_label = $stat->{label}++;
2963 0         0 my $cont_label = $stat->{label}++;
2964 0         0 my $break_label = $stat->{label}++;
2965 0         0 my $code = $stat->{code};
2966 0         0 my $loop = $stat->{loop};
2967              
2968 0         0 push @$loop, [["Jump '$cont_label'"], ["Jump '$break_label'"]];
2969 0 0       0 $init->compile if $init;
2970 0         0 push @$code, ":$enter_label";
2971 0 0       0 if ($cond) {
2972 0         0 $cond->compile('value');
2973 0         0 push @$code, 'Not';
2974 0         0 push @$code, "If '$break_label'";
2975             }
2976 0         0 $block->compile;
2977 0         0 push @$code, ":$cont_label";
2978 0 0       0 $rep->compile if $rep;
2979 0         0 push @$code, "Jump '$enter_label'", ":$break_label";
2980 0         0 pop @$loop;
2981             }
2982             }
2983              
2984             @SWF::Builder::ActionScript::SyntaxNode::FunctionParameter::ISA=('SWF::Builder::ActionScript::SyntaxNode');
2985             {
2986             package SWF::Builder::ActionScript::SyntaxNode::Function;
2987             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
2988 1     1   18 use constant \%O;
  1         2  
  1         24083  
2989              
2990             sub compile {
2991 0     0   0 my ($self, $context) = @_;
2992 0         0 my $stat = $self->{stat};
2993 0         0 my $code = $stat->{code};
2994 0         0 my $node = $self->{node};
2995              
2996 0 0 0     0 if ($context and $node->[0]) {
    0 0        
2997 0         0 $self->_error('Can\'t declare named function in the expression');
2998             } elsif(!$context and !$node->[0]) {
2999 0         0 $self->_error('Function name is necessary to declare function');
3000             }
3001              
3002 0         0 my $label = $stat->{label}++;
3003 0 0       0 my @args = (defined $node->[1]{node}) ? @{$node->[1]{node}} : ();
  0         0  
3004            
3005 0 0       0 if ($stat->{Optimize} & O_LOCALREG) {
3006 0         0 my $flags = 0;
3007 0         0 my $bit = 0;
3008 0         0 my $regvars = $self->{regvars};
3009 0         0 for my $prevar (qw/ this arguments super /) {
3010 0 0       0 if (exists $regvars->{$prevar}) {
3011 0         0 $flags |= 1<<$bit;
3012 0         0 $bit += 2;
3013             } else {
3014 0         0 $bit++;
3015 0         0 $flags |= 1<<$bit;
3016 0         0 $bit++;
3017             }
3018             }
3019 0         0 for my $prevar (qw/ _root _parent _global /) {
3020 0 0       0 if (exists $regvars->{$prevar}) {
3021 0         0 $flags |= 1<<$bit;
3022 0         0 $bit ++;
3023             }
3024             }
3025 0         0 for my $arg (@args) {
3026 0 0       0 $arg .= '='.$regvars->{$arg} if exists $regvars->{$arg};
3027             }
3028 0         0 push @$code, "DefineFunction2 '".$node->[0]."' ".join(' ', $regvars->{' regcount'}, $flags, @args, $label);
3029 0         0 $node->[2]->compile;
3030             } else {
3031 0         0 push @$code, "DefineFunction '".$node->[0]."' ".join(' ', @args, $label);
3032 0 0 0     0 if (($stat->{Optimize} & O_REGISTER) and (my $regcount = $self->{regvars}{' regcount'}) > 0) {
3033              
3034 0         0 my $push = 'Push ';
3035 0         0 for (1..$regcount) {
3036 0         0 $push .= "Register '$_', ";
3037             }
3038 0         0 $push =~ s/, $//;
3039 0         0 push @$code, $push;
3040              
3041 0         0 $node->[2]->compile;
3042              
3043 0         0 for (my $i = $regcount; $i >= 1; $i--) {
3044 0         0 push @$code, "StoreRegister '$i'", "Pop";
3045             }
3046             } else {
3047 0         0 $node->[2]->compile;
3048             }
3049             }
3050 0         0 push @$code, ":$label";
3051             }
3052             }
3053             {
3054             package SWF::Builder::ActionScript::SyntaxNode::MethodCall;
3055             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
3056              
3057             sub compile {
3058 0     0   0 my ($self, $context) = @_;
3059 0         0 my $code = $self->{stat}{code};
3060 0         0 my $method = $self->{node}[0];
3061              
3062 0 0       0 if (ref($method)) {
3063 0         0 $method->compile('value');
3064             } else {
3065 0 0       0 if ($method) {
3066 0         0 push @$code, "Push String '".$method."'";
3067             } else {
3068 0         0 push @$code, "Push UNDEF ''";
3069             }
3070             }
3071 0         0 push @$code, 'CallMethod';
3072 0 0       0 push @$code, 'Pop' unless $context;
3073             }
3074             }
3075             {
3076             package SWF::Builder::ActionScript::SyntaxNode::CallExpression;
3077             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
3078              
3079             sub compile {
3080 1     1   4 my ($self, $context) = @_;
3081 1         4 my $code = $self->{stat}{code};
3082 1         3 my $node = $self->{node};
3083 1         3 my ($func, $args, $members, $methods) = @$node;
3084              
3085 1         5 while (my $callarg = pop @$methods) {
3086 0         0 $callarg->compile('value');
3087             }
3088              
3089             { # special function call ?
3090 1 50       3 if (ref($func) =~/:Variable$/) {
  1         6  
3091 0         0 my $spf = 'spf_'.lc($func->{node}[0]);
3092 0 0       0 if ($self->can($spf)) {
3093 0 0 0     0 $self->$spf($args, (@$members == 0 and @$methods == 0) ? $context : 'value');
3094 0         0 last;
3095             }
3096             }
3097             # not special.
3098 1         5 $args->compile;
3099 1         6 $func->compile('name');
3100 1 50       6 if (ref($func) =~/:MemberExpression$/) {
3101 1         5 push @$code, "CallMethod";
3102             } else {
3103 0         0 push @$code, "CallFunction";
3104             }
3105             }
3106 1 50       4 unless (@$members) {
3107 1 50       6 push @$code, 'Pop' unless $context;
3108 1         4 return;
3109             }
3110              
3111 0         0 my $last = pop @$members;
3112              
3113 0         0 for my $member (@$members) {
3114 0         0 $member->compile('value');
3115             }
3116 0         0 $last->compile($context);
3117             }
3118              
3119             sub _lhs {
3120 0     0   0 my ($name, $args, $members, $methods) = @{shift->{node}};
  0         0  
3121              
3122 0 0 0     0 if (lc($name->{node}[0]) eq 'eval' and @$members == 0 and @$methods == 0) {
      0        
3123 0         0 return $name->{stat}{Version}<=5;
3124             }
3125 0         0 return (ref($members->[-1])=~/:Member$/);
3126             }
3127              
3128              
3129             sub spf_call {
3130 0     0   0 my ($self, $args) = @_;
3131 0         0 my $code = $self->{stat}{code};
3132 0 0       0 $self->_error_param('call') if @{$args->{node}} != 1;
  0         0  
3133              
3134 0         0 $args->{node}[0]->compile('value');
3135 0         0 push @$code, 'Call', "Push UNDEF ''";
3136             }
3137              
3138             sub spf_duplicatemovieclip {
3139 0     0   0 my ($self, $args) = @_;
3140 0         0 my $code = $self->{stat}{code};
3141 0 0       0 $self->_error_param('duplicateMovieClip') if @{$args->{node}} != 3;
  0         0  
3142 0         0 my ($target, $name, $depth) = @{$args->{node}};
  0         0  
3143              
3144 0         0 $target->compile('value');
3145 0         0 $name->compile('value');
3146 0 0       0 if (ref($depth)=~/:NumberLiteral$/) {
3147 0         0 my $d = $depth->{node}[0] + 16384;
3148 0         0 push @$code, "Push Number '$d'";
3149             } else {
3150 0         0 push @$code, "Push Number '16384'";
3151 0         0 $depth->compile('depth');
3152 0         0 push @$code, 'Add2';
3153             }
3154 0         0 push @$code, 'CloneSprite', "Push UNDEF ''";
3155             }
3156              
3157             sub spf_eval {
3158 0     0   0 my ($self, $args, $context) = @_;
3159 0         0 my $code = $self->{stat}{code};
3160 0 0       0 $self->_error_param('eval') if @{$args->{node}} != 1;
  0         0  
3161 0         0 $args->{node}[0]->compile('value');
3162 0 0 0     0 if ($context eq 'value' or not $context) {
    0          
    0          
3163 0         0 push @$code, 'GetVariable';
3164             } elsif ($context eq 'lvalue') {
3165 0         0 push @$code, 'SetVariable', -1;
3166             } elsif ($context eq 'lcvalue') {
3167 0         0 push @$code, 'PushDuplicate', 'GetVariable', 'SetVariable', -1;
3168             }
3169             }
3170              
3171             sub spf_set {
3172 0     0   0 my ($self, $args, $context) = @_;
3173              
3174 0         0 $self->_warn(0, "'set' is not recommended to use.");
3175              
3176 0         0 my $code = $self->{stat}{code};
3177 0 0       0 $self->_error_param('eval') if @{$args->{node}} != 2;
  0         0  
3178 0         0 $args->{node}[0]->compile('value');
3179 0         0 $args->{node}[1]->compile('value');
3180 0 0       0 push @$code, "StoreRegister '0'" if $context;
3181 0         0 push @$code, 'SetVariable';
3182 0 0       0 push @$code, "Push Register '0'" if $context;
3183             }
3184              
3185             sub spf_fscommand {
3186 0     0   0 my ($self, $args) = @_;
3187 0         0 my $code = $self->{stat}{code};
3188 0 0       0 $self->_error_param("fscommand") if @{$args->{node}} != 2;
  0         0  
3189 0         0 my ($command, $param) = @{$args->{node}};
  0         0  
3190              
3191 0 0 0     0 if ($command->isa('SWF::Builder::ActionScript::SyntaxNode::Literal') and
3192             $param->isa('SWF::Builder::ActionScript::SyntaxNode::Literal')) {
3193 0         0 push @$code, "GetURL 'FSCommand:".$command->{node}[0]."' '".$param->{node}[0]."'";
3194             } else {
3195 0 0       0 if ($command->isa('SWF::Builder::ActionScript::SyntaxNode::Literal')) {
3196 0         0 push @$code, "Push String 'FSCommand:".$command->{node}[0]."'";
3197             } else {
3198 0         0 push @$code, "Push String 'FSCommand:'";
3199 0         0 $command->compile('value');
3200 0         0 push @$code, 'StringAdd';
3201             }
3202 0         0 $param->compile('value');
3203 0         0 push @$code, "GetURL2 '0'";
3204             }
3205 0         0 push @$code, "Push UNDEF ''";
3206             }
3207              
3208             sub spf_getproperty {
3209 0     0   0 my ($self, $args) = @_;
3210 0         0 my $code = $self->{stat}{code};
3211 0         0 my $target = $args->{node}[0];
3212 0         0 my $property = lc($args->{node}[1]{node}[0]);
3213              
3214 0 0       0 $self->_error_param('getProperty') if @{$args->{node}} != 2;
  0         0  
3215 0 0       0 $self->_error("'%s' is not a property identifier.", $property) unless exists $property{$property};
3216 0         0 $self->_warn(0, "'getProperty' is not recommended to use.");
3217 0         0 $target->compile('value');
3218 0         0 push @$code, "Push Property '".$property."'", 'GetProperty';
3219             }
3220              
3221             sub spf_setproperty {
3222 0     0   0 my ($self, $args) = @_;
3223 0 0       0 $self->_error_param('setProperty') if @{$args->{node}} != 3;
  0         0  
3224              
3225 0         0 my $code = $self->{stat}{code};
3226 0         0 my $target = $args->{node}[0];
3227 0         0 my $property = lc($args->{node}[1]{node}[0]);
3228 0         0 my $value = $args->{node}[2];
3229              
3230 0 0       0 $self->_error("'%s' is not a property identifier.", $property) unless exists $property{$property};
3231 0         0 $self->_warn(0, "'setProperty' is not recommended to use.");
3232 0         0 $target->compile('value');
3233 0         0 push @$code, "Push Property '".$property."'";
3234 0         0 $value->compile('value');
3235 0         0 push @$code, 'SetProperty', "Push UNDEF ''";
3236             }
3237              
3238             sub spf_gettimer {
3239 0     0   0 my ($self, $args) = @_;
3240 0         0 my $code = $self->{stat}{code};
3241 0 0       0 $self->_error_param('getTimer') if @{$args->{node}} != 0;
  0         0  
3242 0         0 push @$code, "GetTime";
3243             }
3244              
3245             sub spf_geturl {
3246 0     0   0 my ($self, $args, $context, $fname, $ext) = @_;
3247 0         0 my $code = $self->{stat}{code};
3248 0 0 0     0 $self->_error_param($fname||'getURL') if @{$args->{node}} > 3 or @{$args->{node}} <= 0;
  0   0     0  
  0         0  
3249 0         0 my ($url, $target, $method) = @{$args->{node}};
  0         0  
3250              
3251 0 0 0     0 if (!$ext and !defined $method and $url->isa('SWF::Builder::ActionScript::SyntaxNode::Literal') and (!defined $target or $target->isa('SWF::Builder::ActionScript::SyntaxNode::Literal'))) {
      0        
      0        
      0        
3252 0 0       0 $target = $target->{node}[0] if defined $target;
3253 0         0 push @$code, "GetURL '".$url->{node}[0]."' '$target'";
3254             } else {
3255 0 0       0 if (defined $method) {
3256 0 0       0 $self->_error("Third parameter of 'getURL' must be 'GET' or 'POST'.") unless ref($method) =~/:StringLiteral/;
3257 0         0 $method = lc($method->{node}[0]);
3258 0 0 0     0 $self->_error("Third parameter of 'getURL' must be 'GET' or 'POST'.") unless $method eq 'get' or $method eq 'post';
3259 0 0       0 $method = $method eq 'get' ? 1 : 2;
3260             } else {
3261 0         0 $method = 0;
3262             }
3263 0         0 $method |= $ext;
3264 0         0 $url->compile('value');
3265 0 0       0 if (defined $target) {
3266 0         0 $target->compile('value');
3267             } else {
3268 0         0 push @$code, "Push String ''";
3269             }
3270 0         0 push @$code, "GetURL2 '$method'";
3271             }
3272 0         0 push @$code, "Push UNDEF ''";
3273             }
3274              
3275             sub spf_getversion {
3276 0     0   0 my ($self, $args) = @_;
3277 0         0 my $code = $self->{stat}{code};
3278 0 0       0 $self->_error_param('getVersion') if @{$args->{node}} != 0;
  0         0  
3279 0         0 push @$code, "Push String '/:\$version'", 'GetVariable';
3280             }
3281              
3282             sub spf_gotoandplay {
3283 0     0   0 my ($self, $args) = @_;
3284 0         0 my $code = $self->{stat}{code};
3285 0 0 0     0 $self->_error_param('gotoAndPlay') if @{$args->{node}} > 2 or @{$args->{node}} <= 0;
  0         0  
  0         0  
3286 0 0       0 $self->_error("Scene is not supported.") if @{$args->{node}} == 2;
  0         0  
3287 0         0 my $frame = $args->{node}[0];
3288              
3289 0 0       0 if (ref($frame) =~/:NumberLiteral/) {
    0          
3290 0         0 $frame = int($frame->{node}[0])-1;
3291 0 0       0 $frame = 0 if $frame < 0;
3292 0         0 push @$code, "GotoFrame '$frame'", "Play";
3293             } elsif (ref($frame) =~/:StringLiteral/) {
3294 0         0 push @$code, "GotoLabel '".$frame->{node}[0]."'", "Play";
3295             } else {
3296 0         0 $frame->compile('value');
3297 0         0 push @$code, "GotoFrame2 '1'";
3298             }
3299 0         0 push @$code, "Push UNDEF ''";
3300             }
3301              
3302             sub spf_gotoandstop {
3303 0     0   0 my ($self, $args) = @_;
3304 0         0 my $code = $self->{stat}{code};
3305 0 0 0     0 $self->_error_param('gotoAndStop') if @{$args->{node}} > 2 or @{$args->{node}} <= 0;
  0         0  
  0         0  
3306 0 0       0 $self->_error("Scene is not supported.") if @{$args->{node}} == 2;
  0         0  
3307 0         0 my $frame = $args->{node}[0];
3308              
3309 0 0       0 if (ref($frame) =~/:NumberLiteral/) {
    0          
3310 0         0 $frame = int($frame->{node}[0])-1;
3311 0 0       0 $frame = 0 if $frame < 0;
3312 0         0 push @$code, "GotoFrame '$frame'";
3313             } elsif (ref($frame) =~/:StringLiteral/) {
3314 0         0 push @$code, "GotoLabel '".$frame->{node}[0]."'";
3315             } else {
3316 0         0 $frame->compile('value');
3317 0         0 push @$code, "GotoFrame2 '0'";
3318             }
3319 0         0 push @$code, "Push UNDEF ''";
3320             }
3321              
3322             sub spf_loadmovie {
3323 0     0   0 push @_, 'loadMovie', 64;
3324 0         0 &spf_geturl;
3325             }
3326              
3327             sub spf_unloadmovie {
3328 0     0   0 my ($self, $args) = @_;
3329              
3330 0         0 unshift @{$args->{node}}, bless {stat=> $self->{stat}, node=>['']}, 'SWF::Builder::ActionScript::SyntaxNode::StringLiteral';
  0         0  
3331 0         0 push @_, 'unloadMovie', 64;
3332 0         0 &spf_geturl;
3333             }
3334              
3335             sub spf_loadmovienum {
3336 0     0   0 my ($self, $args) = @_;
3337              
3338 0         0 _level2target($args, 1);
3339 0 0       0 $_[3]='loadMovieNum' unless $_[3];;
3340 0         0 &spf_geturl;
3341             }
3342              
3343             sub spf_unloadmovienum {
3344 0     0   0 my ($self, $args) = @_;
3345              
3346 0         0 unshift @{$args->{node}}, bless {stat=> $self->{stat}, node=>['']}, 'SWF::Builder::ActionScript::SyntaxNode::StringLiteral';
  0         0  
3347 0         0 _level2target($args, 1);
3348 0 0       0 $_[3]='unloadMovieNum' unless $_[3];;
3349 0         0 &spf_geturl;
3350             }
3351              
3352             sub _level2target {
3353 0     0   0 my $args = shift;
3354 0         0 my $n = shift;
3355 0         0 my $num = $args->{node}[$n];
3356              
3357 0 0       0 if (ref($num)=~/:NumberLiteral/) {
3358 0         0 $args->{node}[$n] = bless {
3359             line => $num->{line},
3360             stat => $num->{stat},
3361             node => ['_level'.int($num->{node}[0])]
3362             }, 'SWF::Builder::ActionScript::SyntaxNode::StringLiteral';
3363             } else {
3364 0         0 $args->{node}[$n] = bless {
3365             line => $num->{line},
3366             stat => $num->{stat},
3367             node =>
3368             [
3369             (bless {
3370             line => $num->{line},
3371             stat => $num->{stat},
3372             node => ['_level']
3373             }, 'SWF::Builder::ActionScript::SyntaxNode::StringLiteral'),
3374             $num, 'add'
3375             ]
3376             }, 'SWF::Builder::ActionScript::SyntaxNode::BinaryOpExpression';
3377             }
3378              
3379             }
3380              
3381             sub spf_loadvariables {
3382 0     0   0 push @_, 'loadVariables', 192;
3383 0         0 &spf_geturl;
3384             }
3385              
3386             sub spf_loadvariablesnum {
3387 0     0   0 push @_, 'loadVariablesNum', 128;
3388 0         0 &spf_loadmovienum;
3389             }
3390              
3391             sub spf_nextframe {
3392 0     0   0 my ($self, $args) = @_;
3393 0         0 my $code = $self->{stat}{code};
3394 0 0       0 $self->_error_param('nextFrame') if @{$args->{node}} != 0;
  0         0  
3395 0         0 push @$code, "NextFrame", "Push UNDEF ''";
3396             }
3397              
3398             sub spf_prevframe {
3399 0     0   0 my ($self, $args) = @_;
3400 0         0 my $code = $self->{stat}{code};
3401 0 0       0 $self->_error_param('prevFrame') if @{$args->{node}} != 0;
  0         0  
3402 0         0 push @$code, "PrevFrame", "Push UNDEF ''";
3403             }
3404              
3405             sub spf_nextscene {
3406 0     0   0 shift->_error("Scene is not supported.");
3407             }
3408              
3409             sub spf_prevscene {
3410 0     0   0 shift->_error("Scene is not supported.");
3411             }
3412              
3413             sub spf_number {
3414 0     0   0 my ($self, $args) = @_;
3415 0         0 my $code = $self->{stat}{code};
3416 0 0       0 $self->_error_param('Number') if @{$args->{node}} != 1;
  0         0  
3417              
3418 0         0 $args->{node}[0]->compile('value');
3419 0         0 push @$code, 'ToNumber';
3420             }
3421             sub spf_play {
3422 0     0   0 my ($self, $args) = @_;
3423 0         0 my $code = $self->{stat}{code};
3424 0 0       0 $self->_error_param('play') if @{$args->{node}} != 0;
  0         0  
3425 0         0 push @$code, "Play", "Push UNDEF ''";
3426             }
3427              
3428             sub spf_stop {
3429 0     0   0 my ($self, $args) = @_;
3430 0         0 my $code = $self->{stat}{code};
3431 0 0       0 $self->_error_param('stop') if @{$args->{node}} != 0;
  0         0  
3432 0         0 push @$code, "Stop", "Push UNDEF ''";
3433             }
3434              
3435             sub spf_print {
3436 0     0   0 my ($self, $args, $context, $scheme) = @_;
3437 0   0     0 $scheme||='print';
3438 0         0 my $code = $self->{stat}{code};
3439 0 0       0 $self->_error_param($scheme) if @{$args->{node}} != 2;
  0         0  
3440 0         0 my ($target, $bbox) = @{$args->{node}};
  0         0  
3441              
3442 0 0       0 $self->_error("Second parameter of '$scheme' must be 'bframe', 'bmax' or 'bmovie'.") unless ref($bbox) =~/:StringLiteral/;
3443 0         0 $bbox = lc($bbox->{node}[0]);
3444 0 0 0     0 $self->_error("Second parameter of '$scheme' must be 'bframe', 'bmax' or 'bmovie'.") unless $bbox eq 'bframe' or $bbox eq 'bmax' or $bbox eq 'bmovie';
      0        
3445              
3446 0         0 ($scheme = lc($scheme)) =~s/num$//;
3447 0 0       0 if ($bbox eq 'bmovie') {
3448 0         0 push @$code, "Push String '$scheme:'";
3449             } else {
3450 0         0 push @$code, "Push String '$scheme:#$bbox'";
3451             }
3452 0         0 $target->compile('value');
3453 0         0 push @$code, "GetURL2 '0'", "Push UNDEF ''";
3454             }
3455              
3456             sub spf_printasbitmap {
3457 0     0   0 push @_, 'printAsBitmap';
3458 0         0 &spf_print;
3459             }
3460              
3461             sub spf_printnum {
3462 0     0   0 my ($self, $args) = @_;
3463              
3464 0         0 _level2target($args,0);
3465 0 0       0 $_[3]='printNum' unless $_[3];
3466 0         0 &spf_print;
3467             }
3468              
3469             sub spf_printasbitmapnum {
3470 0     0   0 push @_, 'printAsBitmapNum';
3471 0         0 &spf_printnum;
3472             }
3473              
3474             sub spf_removemovieclip {
3475 0     0   0 my ($self, $args) = @_;
3476 0         0 my $code = $self->{stat}{code};
3477 0 0       0 $self->_error_param('removeMovieClip') if @{$args->{node}} != 1;
  0         0  
3478              
3479 0         0 $args->{node}[0]->compile('value');
3480 0         0 push @$code, 'RemoveSprite', "Push UNDEF ''";
3481             }
3482              
3483             sub spf_startdrag {
3484 0     0   0 my ($self, $args) = @_;
3485 0         0 my $code = $self->{stat}{code};
3486 0         0 my $n = @{$args->{node}};
  0         0  
3487 0 0 0     0 $self->_error_param('startDrag') unless $n == 1 or $n == 2 or $n == 6;
      0        
3488              
3489 0         0 my $target = shift(@{$args->{node}});
  0         0  
3490 0         0 my $lockcenter = shift(@{$args->{node}});
  0         0  
3491              
3492 0 0       0 if ($n == 6) {
3493 0         0 for my $e(@{$args->{node}}) {
  0         0  
3494 0         0 $e->compile('value');
3495             }
3496 0         0 push @$code, "Push Boolean '1'";
3497             } else {
3498 0         0 push @$code, "Push Boolean '0'";
3499             }
3500 0 0       0 if ($n > 1) {
3501 0         0 $lockcenter->compile('value');
3502             } else {
3503 0         0 push @$code, "Push Boolean '0'";
3504             }
3505 0         0 $target->compile('value');
3506 0         0 push @$code, 'StartDrag', "Push UNDEF ''";
3507             }
3508              
3509             sub spf_stopallsounds {
3510 0     0   0 my ($self, $args) = @_;
3511 0         0 my $code = $self->{stat}{code};
3512 0 0       0 $self->_error_param('stopAllSounds') if @{$args->{node}} != 0;
  0         0  
3513 0         0 push @$code, "StopSounds", "Push UNDEF ''";
3514             }
3515              
3516             sub spf_stopdrag {
3517 0     0   0 my ($self, $args) = @_;
3518 0         0 my $code = $self->{stat}{code};
3519 0 0       0 $self->_error_param('stopDrag') if @{$args->{node}} != 0;
  0         0  
3520 0         0 push @$code, 'EndDrag', "Push UNDEF ''";
3521             }
3522              
3523             sub spf_string {
3524 0     0   0 my ($self, $args) = @_;
3525 0         0 my $code = $self->{stat}{code};
3526 0 0       0 $self->_error_param('String') if @{$args->{node}} != 1;
  0         0  
3527              
3528 0         0 $args->{node}[0]->compile('value');
3529 0         0 push @$code, 'ToString';
3530             }
3531              
3532             sub spf_targetpath {
3533 0     0   0 my ($self, $args) = @_;
3534 0         0 my $code = $self->{stat}{code};
3535 0 0       0 $self->_error_param('targetPath') if @{$args->{node}} != 1;
  0         0  
3536              
3537 0         0 $args->{node}[0]->compile('value');
3538 0         0 push @$code, 'TargetPath';
3539             }
3540              
3541             sub spf_togglehighquality {
3542 0     0   0 my ($self, $args) = @_;
3543 0         0 my $code = $self->{stat}{code};
3544 0 0       0 $self->_error_param('toggleHighQuality') if @{$args->{node}} != 0;
  0         0  
3545 0         0 $self->_warn_not_recommend("'toggleHighQuality'", "'_quality' property");
3546 0         0 push @$code, 'ToggleQuality', "Push UNDEF ''";
3547             }
3548              
3549             sub spf_trace {
3550 0     0   0 my ($self, $args) = @_;
3551 0         0 my $code = $self->{stat}{code};
3552 0         0 my $trace = $self->{stat}{Trace};
3553 0 0       0 $self->_error_param('trace') if @{$args->{node}} != 1;
  0         0  
3554              
3555 0 0       0 if ($trace eq 'none') {
3556 0         0 push @$code, "Push UNDEF ''";
3557 0         0 return;
3558             }
3559 0         0 $args->{node}[0]->compile('value');
3560 0 0       0 return if $trace eq 'eval';
3561 0 0       0 if ($trace eq 'lcwin') {
3562 0         0 push @$code, "Push String 'trace'", "Push String '__trace'", "Push Number '3'", "Push Number '0'", "Push String 'LocalConnection'", 'NewObject', "Push String 'send'", 'CallMethod';
3563             } else {
3564 0         0 push @$code, "Trace";
3565 0         0 push @$code, "Push UNDEF ''";
3566             }
3567              
3568             }
3569              
3570              
3571             # FLASH4 math/string functions
3572              
3573             sub _flash4_fn {
3574 0     0   0 my ($self, $args, $context, $fname, $bytecode, $replace) = @_;
3575 0         0 my $code = $self->{stat}{code};
3576 0 0       0 $self->_error_param($fname) if @{$args->{node}} != 1;
  0         0  
3577 0         0 $self->_warn_not_recommend("'$fname'", "'$replace'");
3578              
3579 0         0 $args->{node}[0]->compile('value');
3580 0         0 push @$code, $bytecode;
3581             }
3582              
3583             sub spf_chr {
3584 0     0   0 push @_, 'chr', 'AsciiToChar', 'String.fromCharCode';
3585 0         0 &_flash4_fn;
3586             }
3587              
3588             sub spf_int {
3589 0     0   0 push @_, 'int', 'ToInteger', 'Math.floor/ceil/round';
3590 0         0 &_flash4_fn;
3591             }
3592              
3593             sub spf_length {
3594 0     0   0 push @_, 'length', 'StringLength', 'String.length';
3595 0         0 &_flash4_fn;
3596             }
3597              
3598             sub spf_mbchr {
3599 0     0   0 push @_, 'mbchr', 'MBAsciiToChar', 'String.fromCharCode';
3600 0         0 &_flash4_fn;
3601             }
3602              
3603             sub spf_mblength {
3604 0     0   0 push @_, 'mblength', 'MBStringLength', 'String.length';
3605 0         0 &_flash4_fn;
3606             }
3607              
3608             sub spf_mbord {
3609 0     0   0 push @_, 'mbord', 'MBCharToAscii', 'String.charCodeAt';
3610 0         0 &_flash4_fn;
3611             }
3612              
3613             sub spf_ord {
3614 0     0   0 push @_, 'ord', 'CharToAscii', 'String.charCodeAt';
3615 0         0 &_flash4_fn;
3616             }
3617              
3618             sub spf_random {
3619 0     0   0 push @_, 'random', 'RandomNumber', 'Math.random';
3620 0         0 &_flash4_fn;
3621             }
3622              
3623             sub spf_substring {
3624 0     0   0 my ($self, $args) = @_;
3625 0         0 my $code = $self->{stat}{code};
3626 0 0       0 $self->_error_param('substring') if @{$args->{node}} != 3;
  0         0  
3627 0         0 $self->_warn_not_recommend("'substring'", "'String.substr'");
3628              
3629 0         0 for my $a (@{$args->{node}}) {
  0         0  
3630 0         0 $a->compile('value');
3631             }
3632 0         0 push @$code, 'StringExtract';
3633             }
3634              
3635             sub spf_mbsubstring {
3636 0     0   0 my ($self, $args) = @_;
3637 0         0 my $code = $self->{stat}{code};
3638 0 0       0 $self->_error_param('mbsubstring') if @{$args->{node}} != 3;
  0         0  
3639 0         0 $self->_warn_not_recommend("'mbsubstring'", "'String.substr'");
3640              
3641 0         0 for my $a (@{$args->{node}}) {
  0         0  
3642 0         0 $a->compile('value');
3643             }
3644 0         0 push @$code, 'MBStringExtract';
3645             }
3646              
3647              
3648             }
3649              
3650             {
3651             package SWF::Builder::ActionScript::SyntaxNode::NewExpression;
3652             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
3653              
3654             sub compile {
3655 0     0   0 my $self = shift;
3656 0         0 my $code = $self->{stat}{code};
3657 0         0 my $node = $self->{node};
3658 0         0 my $func = shift @$node;
3659 0         0 my $args = shift @$node;
3660              
3661 0         0 $args->compile;
3662 0         0 $func->compile('name');
3663 0 0       0 if ($func->isa('SWF::Builder::ActionScript::SyntaxNode::MemberExpression')) {
3664 0         0 push @$code, "NewMethod";
3665             } else {
3666 0         0 push @$code, "NewObject";
3667             }
3668             }
3669             }
3670              
3671             {
3672             package SWF::Builder::ActionScript::SyntaxNode::Arguments;
3673             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
3674              
3675             sub compile {
3676 1     1   2 my $self = shift;
3677 1         3 my $node = $self->{node};
3678              
3679 1         3 for my $s (reverse @$node) {
3680 1         11 $s->compile('value');
3681             }
3682 1         3 push @{$self->{stat}{code}}, "Push Number '".@$node."'";
  1         12  
3683             }
3684             }
3685              
3686             {
3687             package SWF::Builder::ActionScript::SyntaxNode::PrefixExpression;
3688             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
3689              
3690             sub compile {
3691 0     0     my ($self, $context) = @_;
3692 0           my $code = $self->{stat}{code};
3693              
3694 0           $self->{node}[0]->compile('lcvalue');
3695 0           my $lv = pop @$code;
3696 0           my @lv = splice(@$code, $lv);
3697 0 0         push @$code, $self->{node}[1] eq '++' ? 'Increment' : 'Decrement';
3698 0 0         push @$code, "StoreRegister '0'" if $context;
3699 0           push @$code, @lv;
3700 0 0         push @$code, "Push Register '0'" if $context;
3701             }
3702             }
3703              
3704             {
3705             package SWF::Builder::ActionScript::SyntaxNode::PostfixExpression;
3706             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
3707              
3708             sub compile {
3709 0     0     my ($self, $context) = @_;
3710 0           my $code = $self->{stat}{code};
3711              
3712 0           $self->{node}[0]->compile('lcvalue');
3713 0           my $lv = pop @$code;
3714 0           my @lv = splice(@$code, $lv);
3715 0 0         push @$code, "StoreRegister '0'" if $context;
3716 0 0         push @$code, $self->{node}[1] eq '++' ? 'Increment' : 'Decrement';
3717 0           push @$code, @lv;
3718 0 0         push @$code, "Push Register '0'" if $context;
3719             }
3720             }
3721              
3722             {
3723             package SWF::Builder::ActionScript::SyntaxNode::UnaryExpression;
3724             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
3725              
3726             my %unary_op = (
3727             'void' => ['Pop', "Push UNDEF ''"],
3728             'typeof' => ['TypeOf'],
3729             '-' => ['Subtract'],
3730             '~' => ["Push Number '4294967295'", 'BitXor'],
3731             '!' => ['Not'],
3732             );
3733              
3734             sub compile {
3735 0     0     my ($self, $context) = @_;
3736 0           my ($e, $op) = @{$self->{node}};
  0            
3737 0           my $code = $self->{stat}{code};
3738              
3739 0 0 0       push @$code, "Push Number '0'" if ($op eq '-' and $context);
3740 0           $e->compile($context);
3741 0 0 0       push @$code, @{$unary_op{$op}} if ($op ne '+' and $context);
  0            
3742             }
3743             }
3744             {
3745             package SWF::Builder::ActionScript::SyntaxNode::DeleteExpression;
3746             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
3747              
3748             sub compile {
3749 0     0     my ($self, $context) = @_;
3750 0           my $code = $self->{stat}{code};
3751              
3752 0           $self->{node}[0]->compile('name');
3753 0 0         if ($self->{node}[0]->isa('SWF::Builder::ActionScript::SyntaxNode::MemberExpression')) {
3754 0           push @$code, "Delete";
3755             } else {
3756 0           push @$code, "Delete2";
3757             }
3758 0 0         push @$code, "Pop" unless $context;
3759             }
3760             }
3761              
3762             {
3763             package SWF::Builder::ActionScript::SyntaxNode::IfFrameLoadedStatement;
3764             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
3765              
3766             sub compile {
3767 0     0     my $self = shift;
3768 0           my $code = $self->{stat}{code};
3769 0           my $node = $self->{node};
3770 0           my $label = $self->{stat}{label}++;
3771 0           my $e = $node->[0];
3772              
3773 0 0 0       if (ref($e) =~ /NumberLiteral$/ and $e->{node}[0] =~ /^\d+$/) {
3774 0           push @$code, "WaitForFrame '".$e->{node}[0]."' '$label'";
3775             } else {
3776 0           $e->compile('value');
3777 0           push @$code, "WaitForFrame2 '$label'";
3778             }
3779 0           $node->[1]->compile;
3780 0           push @$code, ":$label";
3781             }
3782             }
3783             {
3784             package SWF::Builder::ActionScript::SyntaxNode::TellTargetStatement;
3785             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
3786              
3787             sub compile {
3788 0     0     my $self = shift;
3789 0           my $code = $self->{stat}{code};
3790 0           my $node = $self->{node};
3791 0           my $e = $node->[0];
3792 0           my $refe = ref($e);
3793              
3794 0 0         if ($refe =~ /StringLiteral$/) {
3795 0           push @$code, "SetTarget '".$e->{node}[0]."'";
3796             } else {
3797 0           $e->compile('value');
3798 0           push @$code, "SetTarget2";
3799             }
3800 0           $node->[1]->compile;
3801 0           push @$code, "SetTarget ''";
3802             }
3803             }
3804              
3805             {
3806             package SWF::Builder::ActionScript::SyntaxNode::WithStatement;
3807             our @ISA = ('SWF::Builder::ActionScript::SyntaxNode');
3808              
3809             sub compile {
3810 0     0     my $self = shift;
3811 0           my $code = $self->{stat}{code};
3812 0           my $node = $self->{node};
3813 0           my $label = $self->{stat}{label}++;
3814              
3815 0           $node->[0]->compile('value');
3816 0           push @$code, "With '$label'";
3817 0           $node->[1]->compile;
3818 0           push @$code, ":$label";
3819             }
3820             }
3821              
3822             1;