File Coverage

blib/lib/HTML/Blitz/CodeGen.pm
Criterion Covered Total %
statement 511 537 95.1
branch 228 376 60.6
condition 48 86 55.8
subroutine 51 52 98.0
pod 0 31 0.0
total 838 1082 77.4


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 0.1001;
6 11     11   107 use HTML::Blitz::pragma;
  11         47  
  11         91  
7 11         81 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   20331 );
  11         34  
22 11     11   91 use Carp qw(croak);
  11         23  
  11         977  
23              
24             use constant {
25 11         8283 _REPR_VERSION => 1,
26             MAX_NESTED_CONCAT => 100,
27 11     11   78 };
  11         23  
28              
29 300 50 33 300 0 796 method new($class: :$_scope = 0, :$name = undef) {
  300 50       1527  
  300 100       632  
  300 50       971  
  300         1041  
  300         1374  
  300         804  
  300         510  
30 300 100       4605 bless {
31             name => defined($name) ? "$name" : undef,
32             depth => $_scope,
33             code => [
34             { type => OP_RAW, str => '' },
35             ],
36             }, $class
37             }
38              
39 2 50   2 0 8 method FREEZE($model) {
  2 50       10  
  2         4  
  2         7  
  2         4  
40 2         9 my @todo = [$self, \my @code];
41 2         11 while (@todo) {
42 8         13 my ($object, $target) = @{pop @todo};
  8         20  
43 8         16 @$target = @{$object->{code}};
  8         30  
44 8         19 for my $op (@$target) {
45 24 100 100     124 if ($op->{type} eq OP_LOOP || $op->{type} eq OP_COND) {
46 6         12 my $body = $op->{body};
47 6         16 push @todo, [$body, my $ref = []];
48 6         53 $op = { %$op, body => [$body->{depth}, $ref] };
49 6 100 100     34 if ($model eq 'JSON' && $op->{type} eq OP_COND) {
50 2 100       5 $op->{names} = [map ref($_->[1]) eq 'SCALAR' ? [$_->[0], [${$_->[1]}]] : $_, @{$op->{names}}];
  1         8  
  2         14  
51             }
52             }
53             }
54             }
55 2         88 _REPR_VERSION, [$self->{depth}, \@code, $self->{name}]
56             }
57              
58 2 50   2 0 9 method THAW($class: $model, $repr_version, $components) {
  2 50       8  
  2         5  
  2         6  
  2         4  
59 2         4 our $VERSION;
60 2 50       10 $repr_version <= _REPR_VERSION
61             or croak "Cannot deserialize data format $repr_version with $class v$VERSION, which only supports data format " . _REPR_VERSION;
62 2         13 my @todo = ['init', \my $self, @$components];
63 2         40 while (@todo) {
64 16         29 my ($type, $ref, $depth, $code, $name) = @{pop @todo};
  16         46  
65 16 100       46 if ($type eq 'exit') {
66 8         26 my $obj = $class->new(_scope => $depth, name => $name);
67 8         23 $obj->{code} = $code;
68 8         18 $$ref = $obj;
69 8         23 next;
70             }
71 8 50       33 $type eq 'init'
72             or die "Internal error: bad THAW stack type '$type'";
73 8         24 push @todo, ['exit', $ref, $depth, $code, $name];
74 8         17 for my $op (@$code) {
75 24 100 100     115 if ($op->{type} eq OP_LOOP || $op->{type} eq OP_COND) {
76 6 100 100     30 if ($model eq 'JSON' && $op->{type} eq OP_COND) {
77 2 100       4 $op->{names} = [map ref($_->[1]) eq 'ARRAY' ? [$_->[0], \$_->[1][0]] : $_, @{$op->{names}}];
  2         17  
78             }
79 6         12 my $body = $op->{body};
80 6         32 push @todo, ['init', \$op->{body}, $body->[0], $body->[1]];
81             }
82             }
83             }
84             $self
85 2         9 }
86              
87 767 50   767 0 2060 method scope() {
  767 50       1762  
  767         1225  
  767         5146  
88             $self->{depth}
89 767         43359 }
90              
91 10152 50   10152   41765 method _emit_raw($str) {
  10152 50       32773  
  10152         15956  
  10152         38652  
  10152         20522  
92 10152 100       21096 return if $str eq '';
93 10147 100       32313 if ((my $op = $self->{code}[-1])->{type} eq OP_RAW) {
94 10059         61939 $op->{str} .= $str;
95             } else {
96 88         154 push @{$self->{code}}, { type => OP_RAW, str => $str };
  88         878  
97             }
98             }
99              
100 9 50   9 0 33 method emit_doctype() {
  9 50       48  
  9         19  
  9         17  
101 9         32 $self->_emit_raw('');
102             }
103              
104 34 50   34 0 94 method emit_comment($content) {
  34 50       82  
  34         81  
  34         100  
  34         46  
105 34 50       102 $content =~ /\A(-?>)/
106             and croak "HTML comment must not start with '$1': '$content'";
107 34 50       158 $content =~ /(");
110             }
111              
112 2219 50   2219 0 5543 method emit_text($text) {
  2219 50       8521  
  2219         7989  
  2219         6645  
  2219         4341  
113 2219 100       14195 $text =~ s{([<&])}{ $1 eq '<' ? '<' : '&' }eg;
  130         805  
114 2219         18997 $self->_emit_raw($text);
115             }
116              
117             my $assert_style_code = q{sub {
118             $_[0] =~ m{(])}aai
119             and Carp::croak "contents of