File Coverage

blib/lib/HTML/Blitz/CodeGen.pm
Criterion Covered Total %
statement 507 534 94.9
branch 223 372 59.9
condition 36 83 43.3
subroutine 51 52 98.0
pod 0 31 0.0
total 817 1072 76.2


line stmt bran cond sub pod time code
1             # This code can be redistributed and modified under the terms of the GNU Affero
2             # General Public License as published by the Free Software Foundation, either
3             # version 3 of the License, or (at your option) any later version.
4             # See the "COPYING" file for details.
5             package HTML::Blitz::CodeGen;
6 11     11   75 use HTML::Blitz::pragma;
  11         22  
  11         68  
7 11         77 use HTML::Blitz::Atom qw(
8             OP_RAW
9             OP_VAR
10             OP_VAR_QQ
11             OP_VAR_HTML
12             OP_VAR_SCRIPT
13             OP_VAR_STYLE
14             OP_CALL
15             OP_CALL_QQ
16             OP_CALL_SCRIPT
17             OP_CALL_STYLE
18             OP_MANGLE_ATTR
19             OP_LOOP
20             OP_COND
21 11     11   8923 );
  11         29  
22 11     11   83 use Carp qw(croak);
  11         74  
  11         565  
23              
24             use constant {
25 11         2789 _REPR_VERSION => 1,
26             MAX_NESTED_CONCAT => 100,
27 11     11   67 };
  11         20  
28              
29             our $VERSION = '0.07';
30              
31 290 50 33 290 0 627 method new($class: :$_scope = 0, :$name = undef) {
  290 50       1190  
  290 100       480  
  290 50       716  
  290         670  
  290         521  
  290         685  
  290         392  
32 290 100       2008 bless {
33             name => defined($name) ? "$name" : undef,
34             depth => $_scope,
35             code => [
36             { type => OP_RAW, str => '' },
37             ],
38             }, $class
39             }
40              
41 1 50   1 0 4 method FREEZE($model) {
  1 50       9  
  1         3  
  1         2  
  1         2  
42 1         4 my @todo = [$self, \my @code];
43 1         3 while (@todo) {
44 4         7 my ($object, $target) = @{pop @todo};
  4         9  
45 4         6 @$target = @{$object->{code}};
  4         11  
46 4         7 for my $op (@$target) {
47 12 100 100     47 if ($op->{type} eq OP_LOOP || $op->{type} eq OP_COND) {
48 3         7 my $body = $op->{body};
49 3         7 push @todo, [$body, my $ref = []];
50 3         15 $op = { %$op, body => [$body->{depth}, $ref] };
51 3 100 66     28 if ($model eq 'JSON' && $op->{type} eq OP_COND) {
52 2 100       10 $op->{names} = [map ref($_->[1]) eq 'SCALAR' ? [$_->[0], [${$_->[1]}]] : $_, @{$op->{names}}];
  1         6  
  2         24  
53             }
54             }
55             }
56             }
57 1         29 _REPR_VERSION, [$self->{depth}, \@code, $self->{name}]
58             }
59              
60 1 50   1 0 20 method THAW($class: $model, $repr_version, $components) {
  1 50       5  
  1         3  
  1         3  
  1         2  
61 1 50       4 $repr_version <= _REPR_VERSION
62             or croak "Cannot deserialize data format $repr_version with $class v$VERSION, which only supports data format " . _REPR_VERSION;
63 1         4 my @todo = ['init', \my $self, @$components];
64 1         4 while (@todo) {
65 8         12 my ($type, $ref, $depth, $code, $name) = @{pop @todo};
  8         18  
66 8 100       22 if ($type eq 'exit') {
67 4         20 my $obj = $class->new(_scope => $depth, name => $name);
68 4         8 $obj->{code} = $code;
69 4         7 $$ref = $obj;
70 4         10 next;
71             }
72 4 50       16 $type eq 'init'
73             or die "Internal error: bad THAW stack type '$type'";
74 4         12 push @todo, ['exit', $ref, $depth, $code, $name];
75 4         9 for my $op (@$code) {
76 12 100 100     45 if ($op->{type} eq OP_LOOP || $op->{type} eq OP_COND) {
77 3 100 66     13 if ($model eq 'JSON' && $op->{type} eq OP_COND) {
78 2 100       5 $op->{names} = [map ref($_->[1]) eq 'ARRAY' ? [$_->[0], \$_->[1][0]] : $_, @{$op->{names}}];
  2         34  
79             }
80 3         8 my $body = $op->{body};
81 3         11 push @todo, ['init', \$op->{body}, $body->[0], $body->[1]];
82             }
83             }
84             }
85             $self
86 1         5 }
87              
88 746 50   746 0 1788 method scope() {
  746 50       1414  
  746         1166  
  746         942  
89             $self->{depth}
90 746         18205 }
91              
92 10027 50   10027   18215 method _emit_raw($str) {
  10027 50       16362  
  10027         13443  
  10027         16202  
  10027         11761  
93 10027 100       16771 return if $str eq '';
94 10023 100       20383 if ((my $op = $self->{code}[-1])->{type} eq OP_RAW) {
95 9937         30030 $op->{str} .= $str;
96             } else {
97 86         129 push @{$self->{code}}, { type => OP_RAW, str => $str };
  86         590  
98             }
99             }
100              
101 8 50   8 0 18 method emit_doctype() {
  8 50       16  
  8         13  
  8         15  
102 8         21 $self->_emit_raw('');
103             }
104              
105 30 50   30 0 62 method emit_comment($content) {
  30 50       74  
  30         47  
  30         58  
  30         38  
106 30 50       67 $content =~ /\A(-?>)/
107             and croak "HTML comment must not start with '$1': '$content'";
108 30 50       110 $content =~ /(");
111             }
112              
113 2192 50   2192 0 4199 method emit_text($text) {
  2192 50       3740  
  2192         2920  
  2192         3570  
  2192         2678  
114 2192 100       4404 $text =~ s{([<&])}{ $1 eq '<' ? '<' : '&' }eg;
  128         609  
115 2192         4160 $self->_emit_raw($text);
116             }
117              
118             my $assert_style_code = q{sub {
119             $_[0] =~ m{(])}aai
120             and Carp::croak "contents of