File Coverage

blib/lib/Text/Xslate/Util.pm
Criterion Covered Total %
statement 146 155 94.1
branch 65 78 83.3
condition 12 17 70.5
subroutine 19 19 100.0
pod 4 12 33.3
total 246 281 87.5


line stmt bran cond sub pod time code
1             package Text::Xslate::Util;
2 181     181   43801 use strict;
  181         339  
  181         6226  
3 181     180   957 use warnings;
  181         305  
  181         4555  
4              
5 181     180   1334 use Carp ();
  181         435  
  181         3865  
6              
7 181     180   120137 use parent qw(Exporter);
  181         48609  
  181         2351  
8             our @EXPORT_OK = qw(
9             mark_raw unmark_raw
10             html_escape escaped_string
11             uri_escape
12             p dump
13             html_builder
14             hash_with_default
15              
16             literal_to_value value_to_literal
17             import_from
18             neat
19             is_int any_in
20             read_around
21             make_error
22             $DEBUG
23             $STRING $NUMBER
24             );
25              
26             our $DEBUG;
27             defined($DEBUG) or $DEBUG = $ENV{XSLATE} || '';
28              
29             our $DisplayWidth = 76;
30             if($DEBUG =~ /display_width=(\d+)/) {
31             $DisplayWidth = $1;
32             }
33              
34             # cf. http://swtch.com/~rsc/regexp/regexp1.html
35             my $dquoted = qr/" [^"\\]* (?: \\. [^"\\]* )* "/xms;
36             my $squoted = qr/' [^'\\]* (?: \\. [^'\\]* )* '/xms;
37             our $STRING = qr/(?: $dquoted | $squoted )/xms;
38              
39             our $NUMBER = qr/ (?:
40             (?: [0-9][0-9_]* (?: \. [0-9_]+)? \b) # decimal
41             |
42             (?: 0 (?:
43             (?: [0-7_]+ ) # octal
44             |
45             (?: x [0-9a-fA-F_]+) # hex
46             |
47             (?: b [01_]+ ) # binary
48             )?)
49             )/xms;
50              
51             require Text::Xslate; # load XS stuff
52              
53             sub mark_raw; # XS
54             sub unmark_raw; # XS
55             sub html_escape; # XS
56             sub uri_escape; # XS
57             sub escaped_string; *escaped_string = \&mark_raw;
58             sub merge_hash; # XS
59              
60             sub html_builder (&){
61 5     5 1 572 my($code_ref) = @_;
62             return sub {
63 5     5   40 my $ret = $code_ref->(@_);
64             return ref($ret) eq 'CODE'
65 5 50       90 ? html_builder(\&{$ret})
  0         0  
66             : mark_raw($ret);
67 5         72 };
68             }
69              
70             sub hash_with_default {
71 5     5 1 599 my($hash_ref, $default) = @_;
72 5 50       22 ref($hash_ref) eq 'HASH'
73             or Carp::croak('Usage: hash_with_default(\%vars, $default)');
74 5         1982 require 'Text/Xslate/HashWithDefault.pm';
75 5         13 my %vars;
76 5         31 tie %vars, 'Text::Xslate::HashWithDefault', $hash_ref, $default;
77 5         37 return \%vars;
78             }
79              
80              
81             # for internals
82              
83             sub neat {
84 22     22 0 40 my($s) = @_;
85 22 100       64 if ( defined $s ) {
86 21 50 33     144 if ( ref($s) || Scalar::Util::looks_like_number($s) ) {
87 0         0 return $s;
88             }
89             else {
90 21         151 return "'$s'";
91             }
92             }
93             else {
94 1         5 return 'nil';
95             }
96             }
97              
98             sub is_int {
99 19396     19396 0 27543 my($s) = @_;
100             # XXX: '+1', '1.0', '00', must NOT be interpreted as an integer
101 19396   100     159975 return defined($s)
102             && $s =~ /\A -? [0-9]+ \z/xms
103             && int($s) eq $s
104             && abs(int($s)) < 0x7FFF_FFFF; # fits int32_t
105             }
106              
107             sub any_in {
108 3250     3250 0 4940 my $value = shift;
109 3250 50       6155 if(defined $value) {
110 3250 50       5237 return scalar grep { defined($_) && $value eq $_ } @_;
  6626         36548  
111             }
112             else {
113 0         0 return scalar grep { not defined($_) } @_;
  0         0  
114             }
115             }
116              
117             my %esc2char = (
118             't' => "\t",
119             'n' => "\n",
120             'r' => "\r",
121             );
122              
123             sub literal_to_value {
124 17717     17717 0 44425 my($value) = @_;
125 17717 50       40252 return $value if not defined $value;
126              
127 17717 100       103695 if($value =~ s/\A "(.*)" \z/$1/xms){
    100          
    100          
128 16408 100       51318 $value =~ s/\\(.)/$esc2char{$1} || $1/xmseg;
  8603         47085  
129             }
130             elsif($value =~ s/\A '(.*)' \z/$1/xms) {
131 115         259 $value =~ s/\\(['\\])/$1/xmsg; # ' for poor editors
132             }
133             elsif($value =~ /\A [+-]? $NUMBER \z/xmso) {
134 1129 100       3322 if($value =~ s/\A ([+-]?) (?= 0[0-7xb])//xms) {
135 37 100       140 $value = ($1 eq '-' ? -1 : +1)
136             * oct($value); # also grok hex and binary
137             }
138             else {
139 1092         1935 $value =~ s/_//xmsg;
140             }
141             }
142              
143 17717         87976 return $value;
144             }
145              
146             my %char2esc = (
147             "\\" => '\\\\',
148             "\n" => '\\n',
149             "\r" => '\\r',
150             '"' => '\\"',
151             '$' => '\\$',
152             '@' => '\\@',
153             );
154             my $value_chars = join '|', map { quotemeta } keys %char2esc;
155              
156             sub value_to_literal {
157 54     54 0 16925 my($value) = @_;
158 54 50       147 return 'undef' if not defined $value;
159              
160 54 100       105 if(is_int($value)){
161 16         50 return $value;
162             }
163             else {
164 38         236 $value =~ s/($value_chars)/$char2esc{$1}/xmsgeo;
  8         38  
165 38         154 return qq{"$value"};
166             }
167             }
168              
169             sub import_from {
170 18     18 0 4799 my $code = "# Text::Xslate::Util::import_from()\n"
171             . "package " . "Text::Xslate::Util::_import;\n"
172             . "use warnings FATAL => 'all';\n"
173             . 'my @args;' . "\n";
174              
175 18         68 for(my $i = 0; $i < @_; $i++) {
176 24         50 my $module = $_[$i];
177              
178 24 100       121 if($module =~ /[^a-zA-Z0-9_:]/) {
179 1         166 Carp::confess("Xslate: Invalid module name: $module");
180             }
181              
182 23         32 my $commands;
183 23 100       95 if(ref $_[$i+1]){
184 13         5872 require 'Data/Dumper.pm';
185 13         33897 my @args = ($_[++$i]);
186 13         33 my @protos = ('*data');
187 13         65 $commands = Data::Dumper->new(\@args, \@protos)->Terse(1)->Dump();
188             }
189              
190 23 100       1174 $code .= "use $module ();\n" if !$module->can('export_into_xslate');
191              
192 23 50 66     142 if(!defined($commands) or $commands ne '') {
193 23   100     284 $code .= sprintf <<'END_IMPORT', $module, $commands || '()';
194             @args = %2$s;
195             %1$s->can('export_into_xslate')
196             ? %1$s->export_into_xslate(\@funcs, @args) # bridge modules
197             : %1$s->import(@args); # function-based modules
198             END_IMPORT
199             }
200             }
201              
202 17         67 local $Text::Xslate::Util::{'_import::'};
203             #print STDERR $code;
204 17         25 my @funcs;
205 17         30 my $e = do {
206 17         29 local $@;
207 17         1622 eval qq{package}
  8         1194  
  7         15  
  7         363  
  2         10  
  2         3  
  2         99  
  2         11  
  2         3  
  2         115  
  2         10  
  2         2  
  2         111  
  1         6  
  1         1  
  1         42  
  1         5  
  1         2  
  1         49  
208             . qq{ Text::Xslate::Util::_import;\n}
209             . $code;
210 17         56 $@;
211             };
212 17 100       339 Carp::confess("Xslate: Failed to import:\n" . $e) if $e;
213             push @funcs, map {
214 16         51 my $entity_ref = \$Text::Xslate::Util::_import::{$_};
  49         77  
215 49         66 my $c;
216 49 50       120 if(ref($entity_ref) eq 'GLOB') { # normal symbols
    0          
217 49         75 $c = *{$entity_ref}{CODE};
  49         85  
218             }
219             elsif(ref($entity_ref) eq 'REF') { # special constants
220 180     180   295583 no strict 'refs';
  180         366  
  180         143985  
221 0         0 $c = \&{ 'Text::Xslate::Util::_import::' . $_ };
  0         0  
222             }
223 49 100       152 defined($c) ? ($_ => $c) : ();
224             } keys %Text::Xslate::Util::_import::;
225              
226 16         318 return {@funcs};
227             }
228              
229             sub make_error {
230 177     177 0 3293 my($self, $message, $file, $line, @extra) = @_;
231 177 50       707 if(ref $message eq 'SCALAR') { # re-thrown form virtual machines
232 0         0 return ${$message};
  0         0  
233             }
234              
235 177         713 my $lines = read_around($file, $line, 1, $self->input_layer);
236 177 100       501 if($lines) {
237 154 100       789 $lines .= "\n" if $lines !~ /\n\z/xms;
238 154         802 $lines = '-' x $DisplayWidth . "\n"
239             . $lines
240             . '-' x $DisplayWidth . "\n";
241             }
242              
243 177         374 local $Carp::CarpLevel = $Carp::CarpLevel + 1;
244 177   33     511 my $class = ref($self) || $self;
245 177 100       1860 $message =~ s/\A \Q$class: \E//xms and $message .= "\t...";
246              
247 177 100       638 if(defined $file) {
248 167 100       407 if(defined $line) {
249 164         314 unshift @extra, $line;
250             }
251 167 100       638 unshift @extra, ref($file) ? '' : $file;
252             }
253              
254 177 100       390 if(@extra) {
255 167         39990 $message = Carp::shortmess(sprintf '%s (%s)',
256             $message, join(':', @extra));
257             }
258             else {
259 10         1903 $message = Carp::shortmess($message);
260             }
261 177         17661 return sprintf "%s: %s%s",
262             $class, $message, $lines;
263             }
264              
265             sub read_around { # for error messages
266 182     182 0 370 my($file, $line, $around, $input_layer) = @_;
267              
268 182 100 100     978 defined($file) && defined($line) or return '';
269              
270 168 100       481 if (ref $file) { # if $file is a scalar ref, it must contain text strings
271 141         259 my $content = $$file;
272 141         379 utf8::encode($content);
273 141         239 $file = \$content;
274             }
275              
276 168 100       437 $around = 1 if not defined $around;
277 168 100       409 $input_layer = '' if not defined $input_layer;
278              
279 168 100   29   4070 open my $in, '<' . $input_layer, $file or return '';
  29         244  
  29         55  
  29         878  
280 157         28157 local $/ = "\n";
281 157         451 local $. = 0;
282              
283 157         288 my $s = '';
284 157         1032 while(defined(my $l = <$in>)) {
285 384 100       1030 if($. >= ($line - $around)) {
286 244         506 $s .= $l;
287             }
288 384 100       1656 if($. >= ($line + $around)) {
289 40         83 last;
290             }
291             }
292 157         1286 return $s;
293             }
294              
295             sub p { # for debugging, the guts of dump()
296 74     74 1 100817 require 'Data/Dumper.pm'; # we don't want to create its namespace
297 74         60986 my $dd = Data::Dumper->new(\@_);
298 74         2115 $dd->Indent(1);
299 74         835 $dd->Sortkeys(1);
300 74         504 $dd->Quotekeys(0);
301 74         433 $dd->Terse(1);
302 74 50       548 return $dd->Dump() if defined wantarray;
303 0         0 print $dd->Dump();
304             }
305              
306 3     3 1 15 sub dump :method { goto &p }
307              
308             1;
309             __END__