File Coverage

blib/lib/HTML/Template/Compiled/Utils.pm
Criterion Covered Total %
statement 62 84 73.8
branch 8 20 40.0
condition 0 2 0.0
subroutine 17 19 89.4
pod 8 8 100.0
total 95 133 71.4


line stmt bran cond sub pod time code
1             package HTML::Template::Compiled::Utils;
2             our $VERSION = '1.003'; # VERSION
3 36     36   122 use strict;
  36         37  
  36         843  
4 36     36   110 use warnings;
  36         36  
  36         749  
5 36     36   99 use Data::Dumper qw(Dumper);
  36         39  
  36         1376  
6 36     36   130 use Digest::MD5;
  36         38  
  36         884  
7              
8 36     36   112 use base 'Exporter';
  36         34  
  36         3085  
9 36     36   129 use vars qw/@EXPORT_OK %EXPORT_TAGS/;
  36         34  
  36         3373  
10             my @paths = qw(PATH_METHOD PATH_DEREF PATH_FORMATTER PATH_ARRAY);
11             @EXPORT_OK = (
12             @paths, qw(
13             &log &stack
14             &escape_html &escape_html_all &escape_uri &escape_js
15             &md5
16             )
17             );
18             %EXPORT_TAGS = (
19             walkpath => \@paths,
20             log => [qw(&log &stack)],
21             escape => [qw(&escape_html &escape_uri &escape_js)],
22             );
23              
24             # These should be better documented
25             # these might be obsolete soon =)
26 36     36   137 use constant PATH_METHOD => 1;
  36         35  
  36         1776  
27 36     36   130 use constant PATH_DEREF => 2;
  36         44  
  36         1368  
28 36     36   119 use constant PATH_FORMATTER => 3;
  36         39  
  36         1379  
29 36     36   276 use constant PATH_ARRAY => 4;
  36         39  
  36         1463  
30              
31              
32             =pod
33              
34             =head1 NAME
35              
36             HTML::Template::Compiled::Utils - Utility functions for HTML::Template::Compiled
37              
38             =head1 SYNOPSIS
39            
40             # import log() and stack()
41             use HTML::Template::Compiled::Utils qw(:log);
42              
43             # import the escapign functions
44             use HTML::Template::Compiled::Utils qw(:escape);
45              
46              
47             =head1 DEBUGGING FUNCTIONS
48              
49             =cut
50              
51             =head2 stack
52              
53             $self->stack;
54              
55             For HTML::Template:Compiled developers, prints a stack trace to STDERR.
56              
57             =cut
58              
59             =head2 md5
60              
61             md5($text)
62              
63             If L is installed, returns the md5_base64 for C<$text>,
64             otherwise returns the empty string.
65              
66             =cut
67              
68 36     36   18299 use Encode ();
  36         262027  
  36         20929  
69             sub md5 {
70 88     88 1 133 my ($text) = @_;
71 88 100       455 if (Encode::is_utf8($text)) {
72 1         4 $text = Encode::encode_utf8($text);
73             }
74 88         506 return Digest::MD5::md5_base64($text);
75             }
76              
77             sub stack {
78 0     0 1 0 my ( $self, $force ) = @_;
79 0 0       0 return if !HTML::Template::Compiled::D() and !$force;
80 0         0 my $i = 0;
81 0         0 my $out;
82 0         0 while ( my @c = caller($i) ) {
83 0         0 $out .= "$i\t$c[0] l. $c[2] $c[3]\n";
84 0         0 $i++;
85             }
86 0         0 print STDERR $out;
87             }
88              
89             =head2 log
90              
91             $self->log(@msg)
92              
93             For HTML::Template::Compiled developers, print log from C<@msg> to STDERR.
94              
95             =cut
96              
97             sub log {
98             #return unless D;
99 0     0 1 0 my ( $self, @msg ) = @_;
100 0         0 my @c = caller();
101 0         0 my @c2 = caller(1);
102 0         0 print STDERR "----------- ($c[0] line $c[2] $c2[3])\n";
103 0         0 for (@msg) {
104 0 0       0 if ( !defined $_ ) {
    0          
105 0         0 print STDERR "--- UNDEF\n";
106             }
107             elsif ( !ref $_ ) {
108 0         0 print STDERR "--- $_\n";
109             }
110             else {
111 0 0       0 if ( ref $_ eq __PACKAGE__ ) {
112 0         0 print STDERR "DUMP HTC\n";
113 0         0 for my $m (qw(file perl)) {
114 0         0 my $s = "get" . ucfirst $m;
115 0   0     0 print STDERR "\t$m:\t", $_->$s || "UNDEF", "\n";
116             }
117             }
118             else {
119 0         0 print STDERR "--- DUMP ---: " . Dumper $_;
120             }
121             }
122             }
123             }
124              
125             =head1 ESCAPING FUNCTIONS
126              
127             =head2 escape_html
128              
129             my $escaped_html = escape_html($raw_html);
130              
131             HTML-escapes the input string (only &, ", single quotes, C<<> and C<>> and returns it;
132              
133             =cut
134              
135             sub escape_html {
136 8     8 1 1787 my ($str) = @_;
137 8 50       20 return $str unless defined $str;
138 8         19 $str =~ s/&/&/g;
139 8         10 $str =~ s/"/"/g;
140 8         25 $str =~ s/'/'/g;
141 8         25 $str =~ s/>/>/g;
142 8         15 $str =~ s/
143 8         133 return $str;
144             }
145              
146             =head2 escape_html_all
147              
148             my $escaped_html = escape_html_all($raw_html);
149              
150             HTML-escapes the input string (with HTML::Entities) and returns it;
151              
152             =cut
153              
154             sub escape_html_all {
155 1 50   1 1 3 return $_[0] unless defined $_[0];
156             # hopefully encode_entities() works correct
157             # and doesn't change its arg when called in scalar context
158 1         4 require HTML::Entities;
159 1         5 return HTML::Entities::encode_entities($_[0]);
160             }
161              
162             =head2 escape_uri
163              
164             my $escaped_uri = escape_uri($raw_uri);
165              
166             URI-escapes the input string and returns it;
167              
168             =cut
169              
170             sub escape_uri {
171             # if we want to use utf8 we require Encode.pm to be installed
172 6 100   6 1 49 my $x = (Encode::is_utf8($_[0]))
173             ? URI::Escape::uri_escape_utf8( $_[0] )
174             : URI::Escape::uri_escape( $_[0] );
175 6         364 return $x;
176             }
177              
178             =head2 escape_js
179              
180             my $escaped_js = escape_js($raw_js);
181              
182             JavaScript-escapes the input string and returns it;
183              
184             =cut
185              
186             sub escape_js {
187 2     2 1 3 my ($var) = @_;
188 2 50       4 return $var unless defined $var;
189 2         8 $var =~ s/(["'\\])/\\$1/g;
190 2         4 $var =~ s/\r/\\r/g;
191 2         2 $var =~ s/\n/\\n/g;
192 2         41 return $var;
193             }
194              
195             =head2 escape_ijson
196              
197             my $escaped_js = escape_ijson($raw_js);
198              
199             JavaScript-escapes the input string except for the apostrophe and returns it,
200             so it can be used within a JSON element.
201              
202             =cut
203              
204             sub escape_ijson {
205 2     2 1 8 my ($var) = @_;
206 2 50       6 return $var unless defined $var;
207 2         26 $var =~ s/([\\"])/\\$1/g;
208 2         5 $var =~ s/\r/\\r/g;
209 2         3 $var =~ s/\n/\\n/g;
210 2         40 return $var;
211             }
212              
213             1;
214             __END__