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
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   82 use HTML::Blitz::pragma;
  11         22  
  11         67  
7 11         74 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   9062 );
  11         28  
22 11     11   84 use Carp qw(croak);
  11         64  
  11         628  
23              
24             use constant {
25 11         2678 _REPR_VERSION => 1,
26             MAX_NESTED_CONCAT => 100,
27 11     11   83 };
  11         20  
28              
29             our $VERSION = '0.08';
30              
31 291 50 33 291 0 611 method new($class: :$_scope = 0, :$name = undef) {
  291 50       1219  
  291 100       803  
  291 50       740  
  291         669  
  291         554  
  291         662  
  291         380  
32 291 100       2027 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       4  
  1         2  
  1         3  
  1         2  
42 1         5 my @todo = [$self, \my @code];
43 1         4 while (@todo) {
44 4         5 my ($object, $target) = @{pop @todo};
  4         9  
45 4         7 @$target = @{$object->{code}};
  4         11  
46 4         8 for my $op (@$target) {
47 12 100 100     60 if ($op->{type} eq OP_LOOP || $op->{type} eq OP_COND) {
48 3         5 my $body = $op->{body};
49 3         7 push @todo, [$body, my $ref = []];
50 3         14 $op = { %$op, body => [$body->{depth}, $ref] };
51 3 100 66     14 if ($model eq 'JSON' && $op->{type} eq OP_COND) {
52 2 100       4 $op->{names} = [map ref($_->[1]) eq 'SCALAR' ? [$_->[0], [${$_->[1]}]] : $_, @{$op->{names}}];
  1         6  
  2         11  
53             }
54             }
55             }
56             }
57 1         40 _REPR_VERSION, [$self->{depth}, \@code, $self->{name}]
58             }
59              
60 1 50   1 0 4 method THAW($class: $model, $repr_version, $components) {
  1 50       3  
  1         2  
  1         4  
  1         2  
61 1 50       3 $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         11 my ($type, $ref, $depth, $code, $name) = @{pop @todo};
  8         18  
66 8 100       18 if ($type eq 'exit') {
67 4         9 my $obj = $class->new(_scope => $depth, name => $name);
68 4         9 $obj->{code} = $code;
69 4         6 $$ref = $obj;
70 4         10 next;
71             }
72 4 50       8 $type eq 'init'
73             or die "Internal error: bad THAW stack type '$type'";
74 4         17 push @todo, ['exit', $ref, $depth, $code, $name];
75 4         9 for my $op (@$code) {
76 12 100 100     46 if ($op->{type} eq OP_LOOP || $op->{type} eq OP_COND) {
77 3 100 66     20 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         14  
79             }
80 3         7 my $body = $op->{body};
81 3         10 push @todo, ['init', \$op->{body}, $body->[0], $body->[1]];
82             }
83             }
84             }
85             $self
86 1         3 }
87              
88 749 50   749 0 1892 method scope() {
  749 50       1443  
  749         1152  
  749         955  
89             $self->{depth}
90 749         18592 }
91              
92 10109 50   10109   18751 method _emit_raw($str) {
  10109 50       17171  
  10109         13093  
  10109         15679  
  10109         12124  
93 10109 100       16762 return if $str eq '';
94 10104 100       20386 if ((my $op = $self->{code}[-1])->{type} eq OP_RAW) {
95 10018         30638 $op->{str} .= $str;
96             } else {
97 86         127 push @{$self->{code}}, { type => OP_RAW, str => $str };
  86         650  
98             }
99             }
100              
101 9 50   9 0 27 method emit_doctype() {
  9 50       22  
  9         13  
  9         13  
102 9         20 $self->_emit_raw('');
103             }
104              
105 34 50   34 0 69 method emit_comment($content) {
  34 50       61  
  34         50  
  34         56  
  34         51  
106 34 50       100 $content =~ /\A(-?>)/
107             and croak "HTML comment must not start with '$1': '$content'";
108 34 50       129 $content =~ /(");
111             }
112              
113 2214 50   2214 0 4313 method emit_text($text) {
  2214 50       3943  
  2214         3070  
  2214         3721  
  2214         2785  
114 2214 100       4756 $text =~ s{([<&])}{ $1 eq '<' ? '<' : '&' }eg;
  129         599  
115 2214         4420 $self->_emit_raw($text);
116             }
117              
118             my $assert_style_code = q{sub {
119             $_[0] =~ m{(])}aai
120             and Carp::croak "contents of