File Coverage

blib/lib/Templ/Parser.pm
Criterion Covered Total %
statement 44 98 44.9
branch 10 38 26.3
condition 3 14 21.4
subroutine 10 17 58.8
pod 0 12 0.0
total 67 179 37.4


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;