File Coverage

blib/lib/HTML/Blitz/CodeGen.pm
Criterion Covered Total %
statement 510 536 95.1
branch 228 376 60.6
condition 46 86 53.4
subroutine 51 52 98.0
pod 0 31 0.0
total 835 1081 77.2


line stmt bran cond sub pod time code
1             # This code can be redistributed and modified under the terms of the GNU
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   80 use HTML::Blitz::pragma;
  11         25  
  11         69  
7 11         68 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   9205 );
  11         35  
22 11     11   86 use Carp qw(croak);
  11         67  
  11         587  
23              
24             use constant {
25 11         2573 _REPR_VERSION => 1,
26             MAX_NESTED_CONCAT => 100,
27 11     11   71 };
  11         25  
28              
29             our $VERSION = '0.09';
30              
31 296 50 33 296 0 660 method new($class: :$_scope = 0, :$name = undef) {
  296 50       1217  
  296 100       466  
  296 50       697  
  296         713  
  296         537  
  296         719  
  296         364  
32 296 100       2047 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 6 method FREEZE($model) {
  1 50       4  
  1         3  
  1         3  
  1         2  
42 1         4 my @todo = [$self, \my @code];
43 1         4 while (@todo) {
44 4         7 my ($object, $target) = @{pop @todo};
  4         9  
45 4         7 @$target = @{$object->{code}};
  4         12  
46 4         10 for my $op (@$target) {
47 12 100 100     45 if ($op->{type} eq OP_LOOP || $op->{type} eq OP_COND) {
48 3         4 my $body = $op->{body};
49 3         7 push @todo, [$body, my $ref = []];
50 3         25 $op = { %$op, body => [$body->{depth}, $ref] };
51 3 100 66     19 if ($model eq 'JSON' && $op->{type} eq OP_COND) {
52 2 100       3 $op->{names} = [map ref($_->[1]) eq 'SCALAR' ? [$_->[0], [${$_->[1]}]] : $_, @{$op->{names}}];
  1         7  
  2         14  
53             }
54             }
55             }
56             }
57 1         42 _REPR_VERSION, [$self->{depth}, \@code, $self->{name}]
58             }
59              
60 1 50   1 0 5 method THAW($class: $model, $repr_version, $components) {
  1 50       4  
  1         2  
  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         5 my @todo = ['init', \my $self, @$components];
64 1         4 while (@todo) {
65 8         9 my ($type, $ref, $depth, $code, $name) = @{pop @todo};
  8         19  
66 8 100       20 if ($type eq 'exit') {
67 4         13 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       18 $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         7 for my $op (@$code) {
76 12 100 100     54 if ($op->{type} eq OP_LOOP || $op->{type} eq OP_COND) {
77 3 100 66     14 if ($model eq 'JSON' && $op->{type} eq OP_COND) {
78 2 100       4 $op->{names} = [map ref($_->[1]) eq 'ARRAY' ? [$_->[0], \$_->[1][0]] : $_, @{$op->{names}}];
  2         23  
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         4 }
87              
88 764 50   764 0 1862 method scope() {
  764 50       1468  
  764         1122  
  764         981  
89             $self->{depth}
90 764         18792 }
91              
92 10152 50   10152   18155 method _emit_raw($str) {
  10152 50       16579  
  10152         13216  
  10152         15851  
  10152         11906  
93 10152 100       16742 return if $str eq '';
94 10147 100       20620 if ((my $op = $self->{code}[-1])->{type} eq OP_RAW) {
95 10059         30521 $op->{str} .= $str;
96             } else {
97 88         139 push @{$self->{code}}, { type => OP_RAW, str => $str };
  88         622  
98             }
99             }
100              
101 9 50   9 0 21 method emit_doctype() {
  9 50       19  
  9         11  
  9         14  
102 9         22 $self->_emit_raw('');
103             }
104              
105 34 50   34 0 77 method emit_comment($content) {
  34 50       63  
  34         51  
  34         64  
  34         41  
106 34 50       94 $content =~ /\A(-?>)/
107             and croak "HTML comment must not start with '$1': '$content'";
108 34 50       117 $content =~ /(");
111             }
112              
113 2219 50   2219 0 4355 method emit_text($text) {
  2219 50       3844  
  2219         3008  
  2219         3625  
  2219         2665  
114 2219 100       4517 $text =~ s{([<&])}{ $1 eq '<' ? '<' : '&' }eg;
  130         678  
115 2219         4431 $self->_emit_raw($text);
116             }
117              
118             my $assert_style_code = q{sub {
119             $_[0] =~ m{(])}aai
120             and Carp::croak "contents of