line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Templ::Parser; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
6
|
use strict; |
|
1
|
|
|
|
|
10
|
|
|
1
|
|
|
|
|
27
|
|
4
|
1
|
|
|
1
|
|
4
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
31
|
|
5
|
|
|
|
|
|
|
|
6
|
1
|
|
|
1
|
|
5
|
use Carp qw(cluck croak); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
52
|
|
7
|
1
|
|
|
1
|
|
5
|
use Data::Dumper; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
48
|
|
8
|
1
|
|
|
1
|
|
514
|
use Templ::Util qw(quote attempt default number_lines); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
1416
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
my $can_tidy = attempt { require Perl::Tidy; require File::Temp }; |
11
|
|
|
|
|
|
|
my $can_say = attempt { require v5.10; }; |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
sub new { |
14
|
4
|
|
|
4
|
0
|
34
|
my $class = shift; |
15
|
4
|
0
|
33
|
|
|
16
|
if ( not defined $class || ref $class || $class !~ m/^(\w+\:\:)*\w+$/ ) { |
|
|
|
33
|
|
|
|
|
16
|
0
|
|
|
|
|
0
|
croak "Can only be called as Templ::Parser::...->new"; |
17
|
|
|
|
|
|
|
} |
18
|
4
|
50
|
|
|
|
15
|
if ($class eq __PACKAGE__) { |
19
|
0
|
|
|
|
|
0
|
croak "__PACKAGE__ cannot be instantiated directly, use a subclass"; |
20
|
|
|
|
|
|
|
} |
21
|
4
|
|
|
|
|
9
|
my $self = bless {@_}, $class; |
22
|
4
|
|
|
|
|
24
|
return $self; |
23
|
|
|
|
|
|
|
} |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
sub parse { |
26
|
4
|
|
|
4
|
0
|
5
|
my $self = shift; |
27
|
4
|
|
|
|
|
10
|
my $templ = shift; |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
# The template is assumed to be starting as printing output, so |
30
|
|
|
|
|
|
|
# wrap the whole template in a header/footer, escaping the contents |
31
|
4
|
|
|
|
|
5
|
my $perl = ''; |
32
|
4
|
50
|
|
|
|
18
|
if ($self->prettify) { $perl .= $self->pretty_header; } |
|
0
|
|
|
|
|
0
|
|
33
|
4
|
|
|
|
|
26
|
$perl .= $templ->header; |
34
|
4
|
|
|
|
|
17
|
$perl .= $self->header; |
35
|
4
|
|
|
|
|
88
|
$perl .= "'".quote($templ->templ_code)."'"; |
36
|
4
|
|
|
|
|
16
|
$perl .= $self->footer; |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
# Loop over all of the remaining <* ... *> tag types, performing the |
39
|
|
|
|
|
|
|
# prescribed replacements... run in reverse to process latest / deepest |
40
|
|
|
|
|
|
|
# subclass tags first |
41
|
|
|
|
|
|
|
# |
42
|
|
|
|
|
|
|
# $self->debug && print Data::Dumper->Dump([[$templ->tags]],['tags']); |
43
|
|
|
|
|
|
|
# $self->debug && print Data::Dumper->Dump([$templ],['templ']); |
44
|
4
|
|
|
|
|
18
|
foreach my $tag ( $templ->tags ) { |
45
|
21
|
|
|
|
|
85
|
$perl = $tag->process( $perl, $self ); |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
|
48
|
4
|
50
|
|
|
|
21
|
if ( $self->prettify ) { |
49
|
|
|
|
|
|
|
# Change any standalone single-quote print statements with |
50
|
|
|
|
|
|
|
# literal newlines in them to a series of individual print |
51
|
|
|
|
|
|
|
# or say statements for readability |
52
|
0
|
|
|
|
|
0
|
$perl =~ s{ |
53
|
|
|
|
|
|
|
(?: |
54
|
|
|
|
|
|
|
# $1 = Previous statement separator |
55
|
|
|
|
|
|
|
( (?: ^ | \; | \{ | \} ) [ \t]*? (?:\r?\n)? ) |
56
|
|
|
|
|
|
|
# $2 = Print statement indentation |
57
|
|
|
|
|
|
|
( \s*? ) |
58
|
|
|
|
|
|
|
# $3 = Double quote contents |
59
|
|
|
|
|
|
|
print \s* '(.*?)(?
|
60
|
|
|
|
|
|
|
# $4 = Closing brace or semicolon |
61
|
|
|
|
|
|
|
( \s* (?: (?:\;|\}) (?:\r?\n)? | $ ) ) |
62
|
|
|
|
|
|
|
) |
63
|
|
|
|
|
|
|
} |
64
|
0
|
|
|
|
|
0
|
{ $self->prettify_lines($1, $2, $3, $4) }egsx; |
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
|
67
|
4
|
50
|
|
|
|
13
|
if ( $self->tidy ) { |
68
|
0
|
0
|
|
|
|
0
|
if ($can_tidy) { |
69
|
0
|
|
|
|
|
0
|
require File::Temp; |
70
|
0
|
|
|
|
|
0
|
require Perl::Tidy; |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
# Using a temp file because the output is weird when we don't |
73
|
0
|
|
|
|
|
0
|
( undef, my $tmp ) = File::Temp::tempfile(); |
74
|
0
|
|
|
|
|
0
|
Perl::Tidy::perltidy( |
75
|
|
|
|
|
|
|
'source' => \$perl, |
76
|
|
|
|
|
|
|
'destination' => $tmp, |
77
|
|
|
|
|
|
|
'argv' => [ split /\s+/, $self->tidy_options ], |
78
|
|
|
|
|
|
|
); |
79
|
0
|
|
0
|
|
|
0
|
open my $FH, '<', $tmp |
80
|
|
|
|
|
|
|
|| die "Unable to open file for reading $tmp: $!"; |
81
|
0
|
|
|
|
|
0
|
local $/ = undef; |
82
|
0
|
|
|
|
|
0
|
$perl = <$FH>; |
83
|
0
|
|
|
|
|
0
|
close $FH; |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
else { |
86
|
0
|
|
|
|
|
0
|
warn "Unable to load Perl::Tidy and/or File::Temp\n"; |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
4
|
50
|
33
|
|
|
10
|
if ( $self->tidy || $self->prettify ) { |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
# Remove blank append statements |
93
|
0
|
|
|
|
|
0
|
my $append = $self->append; |
94
|
0
|
|
|
|
|
0
|
$perl =~ s/(?:^|(?<=\n)[ \t]*)\Q$append\E'';[ \t]*(?:\r?\n|$)//; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
4
|
50
|
|
|
|
19
|
if ( $self->debug ) { |
98
|
0
|
|
|
|
|
0
|
print STDERR number_lines($perl); |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
4
|
|
|
|
|
335
|
return $perl; |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
# Breaks a print statement with newlines in it into multiple statements |
105
|
|
|
|
|
|
|
# Helps with formatting code to preserve indentation (used when prettify is |
106
|
|
|
|
|
|
|
# enabled) |
107
|
|
|
|
|
|
|
sub prettify_lines { |
108
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
109
|
0
|
|
|
|
|
0
|
my $pre = shift; # Previous opening brace or semicolon |
110
|
0
|
|
|
|
|
0
|
my $indent = shift; # Indentation spacing of the print statement |
111
|
0
|
|
|
|
|
0
|
my $contents = shift; # Contents of the single quotes of the print |
112
|
0
|
|
|
|
|
0
|
my $post = shift; # Closing brace or semicolon |
113
|
|
|
|
|
|
|
|
114
|
0
|
|
|
|
|
0
|
my $out = $pre; |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
# Create a list of lines (and the ending partial line) in the print |
117
|
0
|
|
|
|
|
0
|
my @chunks = split /(.*?\n)/, $contents; |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
# print "CHUNK <<$_>>\n" foreach @chunks; |
120
|
0
|
|
|
|
|
0
|
foreach ( 0 .. $#chunks ) { |
121
|
0
|
|
|
|
|
0
|
my $is_last_chunk = ( $_ == $#chunks ); |
122
|
0
|
|
|
|
|
0
|
my $chunk = $chunks[$_]; |
123
|
0
|
0
|
0
|
|
|
0
|
next if ( ( $chunk eq '' ) && ( not $is_last_chunk ) ); |
124
|
|
|
|
|
|
|
|
125
|
0
|
|
|
|
|
0
|
my $nl = ''; |
126
|
0
|
0
|
|
|
|
0
|
if ( $chunk =~ s/\r\n$// ) { $nl = '\r\n'; } |
|
0
|
0
|
|
|
|
0
|
|
127
|
0
|
|
|
|
|
0
|
elsif ( $chunk =~ s/\n$// ) { $nl = '\n'; } |
128
|
|
|
|
|
|
|
|
129
|
0
|
|
|
|
|
0
|
my $statement; |
130
|
0
|
0
|
|
|
|
0
|
if ($nl) { |
131
|
0
|
0
|
|
|
|
0
|
if ($self->append_pretty) { |
132
|
0
|
|
|
|
|
0
|
$statement = $self->append_pretty . "'$chunk'"; |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
else { |
135
|
0
|
|
|
|
|
0
|
$statement = $self->append . "'$chunk'" . '."$nl"'; |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
else { |
139
|
0
|
|
|
|
|
0
|
$statement = $self->append . "'$chunk'"; |
140
|
|
|
|
|
|
|
} |
141
|
0
|
0
|
|
|
|
0
|
$statement .= $is_last_chunk ? $post : ";\n"; |
142
|
|
|
|
|
|
|
|
143
|
0
|
|
|
|
|
0
|
$out .= $statement; |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
|
146
|
0
|
|
|
|
|
0
|
return $out; |
147
|
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
############################################################################## |
150
|
|
|
|
|
|
|
# Some override-able functions for subclasses |
151
|
|
|
|
|
|
|
|
152
|
0
|
|
|
0
|
0
|
0
|
sub pretty_header { return ''; } |
153
|
0
|
|
|
0
|
0
|
0
|
sub header { die "Subclass must override Templ::Parser->header"; } |
154
|
0
|
|
|
0
|
0
|
0
|
sub append { die "Subclass must override Templ::Parser->append"; } |
155
|
0
|
|
|
0
|
0
|
0
|
sub append_pretty { return ''; } |
156
|
0
|
|
|
0
|
0
|
0
|
sub footer { die "Subclass must override Templ::Parser->footer"; } |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
############################################################################## |
159
|
|
|
|
|
|
|
# Accessors... |
160
|
|
|
|
|
|
|
sub debug { |
161
|
4
|
|
|
4
|
0
|
8
|
my $self = shift; |
162
|
4
|
50
|
|
|
|
11
|
if ( defined $_[0] ) { $self->{'debug'} = shift; } |
|
0
|
|
|
|
|
0
|
|
163
|
4
|
|
|
|
|
15
|
return default $self->{'debug'}, $Templ::Parser::debug, 0; |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
sub tidy { |
167
|
20
|
|
|
20
|
0
|
30
|
my $self = shift; |
168
|
20
|
50
|
|
|
|
43
|
if ( defined $_[0] ) { $self->{'tidy'} = shift; } |
|
0
|
|
|
|
|
0
|
|
169
|
20
|
|
|
|
|
71
|
return default $self->{'tidy'}, $Templ::Parser::tidy, 0; |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
sub tidy_options { |
173
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
174
|
0
|
0
|
|
|
|
0
|
if ( defined $_[0] ) { $self->{'tidy_options'} = shift; } |
|
0
|
|
|
|
|
0
|
|
175
|
0
|
|
|
|
|
0
|
return default $self->{'tidy_options'}, $Templ::Parser::tidy_options, |
176
|
|
|
|
|
|
|
'-pbp -nst -b -aws -dws -dsm -nbbc -kbl=0 -asc -npro -sbl'; |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
sub prettify { |
180
|
12
|
|
|
12
|
0
|
16
|
my $self = shift; |
181
|
12
|
50
|
|
|
|
28
|
if ( defined $_[0] ) { $self->{'prettify'} = shift; } |
|
0
|
|
|
|
|
0
|
|
182
|
12
|
50
|
|
|
|
56
|
return default $self->{'prettify'}, $Templ::Parser::prettify, |
183
|
|
|
|
|
|
|
( $self->tidy ? 1 : 0 ); |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
1; |