File Coverage

blib/lib/Text/Template/Simple/Util.pm
Criterion Covered Total %
statement 78 96 81.2
branch 20 46 43.4
condition 7 12 58.3
subroutine 18 20 90.0
pod 12 12 100.0
total 135 186 72.5


line stmt bran cond sub pod time code
1             package Text::Template::Simple::Util;
2 62     62   351 use strict;
  62         125  
  62         2496  
3 62     62   336 use warnings;
  62         119  
  62         14698  
4 62     62   338 use base qw( Exporter );
  62         116  
  62         6489  
5 62     62   835 use Carp qw( croak );
  62         155  
  62         5338  
6 62         42225 use Text::Template::Simple::Constants qw(
7             :info
8             DIGEST_MODS
9             EMPTY_STRING
10 62     62   464 );
  62         198  
11              
12             our $VERSION = '0.86';
13              
14             BEGIN {
15             # create a wrapper for binmode()
16 62     62   631 if ( NEW_PERL ) {
17             # older perl binmode() does not accept a second param
18             *binary_mode = sub {
19 2     2   5 my($fh, $layer) = @_;
20 2         21 binmode $fh, q{:} . $layer;
21 62         382 };
22             }
23             else {
24             *binary_mode = sub { binmode $_[0] };
25             }
26 62         520 our %EXPORT_TAGS = (
27             macro => [qw( isaref ishref iscref )],
28             util => [qw( binary_mode DIGEST trim rtrim ltrim escape )],
29             debug => [qw( fatal DEBUG LOG L )],
30             );
31 62         332 our @EXPORT_OK = map { @{ $EXPORT_TAGS{$_} } } keys %EXPORT_TAGS;
  186         271  
  186         827  
32 62         311 $EXPORT_TAGS{all} = \@EXPORT_OK;
33 62         181617 our @EXPORT = @EXPORT_OK;
34             }
35              
36             my $lang = {
37             error => {
38             q{tts.base.examine.notglob} => q{Unknown template parameter passed as %s reference! Supported types are GLOB, PATH and STRING.},
39             q{tts.base.examine.notfh} => q{This GLOB is not a filehandle},
40             q{tts.main.cdir} => q{Cache dir %s does not exist!},
41             q{tts.main.bogus_args} => q{Malformed add_args parameter! 'add_args' must be an arrayref!},
42             q{tts.main.bogus_delims} => q{Malformed delimiters parameter! 'delimiters' must be a two element arrayref!},
43             q{tts.cache.opendir} => q{Can not open cache dir (%s) for reading: %s},
44             q{tts.util.digest} => q{Can not load a digest module. Disable cache or install one of these (%s or %s). Last error was: %s},
45             q{tts.cache.dumper} => q{Can not dump in-memory cache! Your version of Data::Dumper (%s) does not implement the Deparse() method. Please upgrade this module!},
46             q{tts.cache.pformat} => q{Parameters must be in 'param => value' format},
47             q{tts.cache.incache} => q{I need an 'id' or a 'data' parameter for cache check!},
48             q{tts.main.dslen} => q{Start delimiter is smaller than 2 characters},
49             q{tts.main.delen} => q{End delimiter is smaller than 2 characters},
50             q{tts.main.dsws} => q{Start delimiter contains whitespace},
51             q{tts.main.dews} => q{End delimiter contains whitespace},
52             q{tts.main.import.invalid} => q{%s isn't a valid import parameter for %s},
53             q{tts.main.import.undef} => q{%s is not defined in %s},
54             q{tts.main.import.redefine} => q{%s is already defined in %s},
55             q{tts.main.tts.args} => q{Nothing to compile!},
56             q{tts.main.connector.args} => q{connector(): id is missing},
57             q{tts.main.connector.invalid} => q{connector(): invalid id: %s},
58             q{tts.main.init.thandler} => q{user_thandler parameter must be a CODE reference},
59             q{tts.main.init.include} => q{include_paths parameter must be a ARRAY reference},
60             q{tts.util.escape} => q{Missing the character to escape},
61             q{tts.tokenizer.new.ds} => q{Start delimiter is missing},
62             q{tts.tokenizer.new.de} => q{End delimiter is missing},
63             q{tts.tokenizer.tokenize.tmp} => q{Template string is missing},
64             q{tts.tokenizer._get_symbols.regex} => q{Regex is missing},
65             q{tts.io.validate.type} => q{No type specified},
66             q{tts.io.validate.path} => q{No path specified},
67             q{tts.io.validate.file} => q{validate(file) is not yet implemented},
68             q{tts.io.layer.fh} => q{Filehandle is absent},
69             q{tts.io.slurp.open} => q{Error opening '%s' for reading: %s},
70             q{tts.io.slurp.taint} => q{Can't untaint FH},
71             q{tts.io.hls.invalid} => q{FH is either absent or invalid},
72             q{tts.caller.stack.hash} => q{Parameters to stack() must be a HASH},
73             q{tts.caller.stack.type} => q{Unknown caller stack type: %s},
74             q{tts.caller._text_table.module} => q{Caller stack type 'text_table' requires Text::Table: %s},
75             q{tts.cache.new.parent} => q{Parent object is missing},
76             q{tts.cache.dumper.hash} => q{Parameters to dumper() must be a HASHref},
77             q{tts.cache.dumper.type} => q{Dumper type '%s' is not valid},
78             q{tts.cache.develsize.buggy} => q{Your Devel::Size version (%s) has a known bug. Upgrade Devel::Size to 0.72 or newer or do not use the size() method},
79             q{tts.cache.develsize.total} => q{Devel::Size::total_size(): %s},
80             q{tts.cache.hit.meta} => q{Can not get meta data: %s},
81             q{tts.cache.hit.cache} => q{Error loading from disk cache: %s},
82             q{tts.cache.populate.write} => q{Error writing disk-cache %s : %s},
83             q{tts.cache.populate.chmod} => q{Can not change file mode},
84             q{tts.base.compiler._compile.notmp} => q{No template specified},
85             q{tts.base.compiler._compile.param} => q{params must be an arrayref!},
86             q{tts.base.compiler._compile.opt} => q{opts must be a hashref!},
87             q{tts.base.compiler._wrap_compile.parsed} => q{nothing to compile},
88             q{tts.base.compiler._mini_compiler.notmp} => q{_mini_compiler(): missing the template},
89             q{tts.base.compiler._mini_compiler.noparam} => q{_mini_compiler(): missing the parameters},
90             q{tts.base.compiler._mini_compiler.opt} => q{_mini_compiler(): options must be a hash},
91             q{tts.base.compiler._mini_compiler.param} => q{_mini_compiler(): parameters must be a HASH},
92             q{tts.base.examine._examine_type.ftype} => q{ARRAY does not contain the type},
93             q{tts.base.examine._examine_type.fthing} => q{ARRAY does not contain the data},
94             q{tts.base.examine._examine_type.extra} => q{Type array has unknown extra fields},
95             q{tts.base.examine._examine_type.unknown} => q{Unknown first argument of %s type to compile()},
96             q{tts.base.include._include.unknown} => q{Unknown include type: %s},
97             q{tts.base.include._interpolate.bogus_share} => q{Only SCALARs can be shared. You have tried to share a variable }
98             .q{type of %s named "%s". Consider converting it to a SCALAR or try }
99             .q{the monolith option to enable automatic variable sharing. }
100             .q{But please read the fine manual first},
101             q{tts.base.include._interpolate.bogus_share_notbare} => q{It looks like you've tried to share an expression (%s) instead of a simple variable.},
102             q{tts.base.parser._internal.id} => q{_internal(): id is missing},
103             q{tts.base.parser._internal.rv} => q{_internal(): id is invalid},
104             q{tts.base.parser._parse.unbalanced} => q{%d unbalanced %s delimiter(s) in template %s},
105             q{tts.cache.id.generate.data} => q{Can't generate id without data!},
106             q{tts.cache.id._custom.data} => q{Can't generate id without data!},
107             },
108             warning => {
109             q{tts.base.include.dynamic.recursion} => q{%s Deep recursion (>=%d) detected in the included file: %s},
110             }
111             };
112              
113             my $DEBUG = 0; # Disabled by default
114             my $DIGEST; # Will hold digester class name.
115              
116 1208     1208 1 2820 sub isaref { my $x = shift; return ref($x) eq 'ARRAY' };
  1208         7117  
117 1102     1102 1 2984 sub ishref { my $x = shift; return ref($x) eq 'HASH' };
  1102         8358  
118 0     0 1 0 sub iscref { my $x = shift; return ref($x) eq 'CODE' };
  0         0  
119              
120             sub L {
121 6     6 1 22 my($type, $id, @param) = @_;
122 6 50       21 croak q{Type parameter to L() is missing} if ! $type;
123 6 50       21 croak q{ID parameter ro L() is missing} if ! $id;
124 6   33     29 my $root = $lang->{ $type } || croak "$type is not a valid L() type";
125 6   33     30 my $value = $root->{ $id } || croak "$id is not a valid L() ID";
126 6 50       833 return @param ? sprintf($value, @param) : $value;
127             }
128              
129             sub fatal {
130 4     4 1 241 my @args = @_;
131 4         16 return croak L( error => @args );
132             }
133              
134             sub escape {
135 1440     1440 1 3888 my($c, $s) = @_;
136 1440 50       3330 fatal('tts.util.escape') if ! $c;
137 1440 50       5859 return $s if ! $s; # false or undef
138 1440         13276 my $e = quotemeta $c;
139 1440         14335 $s =~ s{$e}{\\$c}xmsg;
140 1440         13092 return $s;
141             }
142              
143             sub trim {
144 332     332 1 1993 my $s = shift;
145 332 50       820 return $s if ! $s; # false or undef
146 332   50     1427 my $extra = shift || EMPTY_STRING;
147 332         1943 $s =~ s{\A \s+ }{$extra}xms;
148 332         2307 $s =~ s{ \s+ \z}{$extra}xms;
149 332         1530 return $s;
150             }
151              
152             sub ltrim {
153 46     46 1 81 my $s = shift;
154 46 50       142 return $s if ! $s; # false or undef
155 46   100     180 my $extra = shift || EMPTY_STRING;
156 46         250 $s =~ s{\A \s+ }{$extra}xms;
157 46         169 return $s;
158             }
159              
160             sub rtrim {
161 26     26 1 39 my $s = shift;
162 26 50       56 return $s if ! $s; # false or undef
163 26   100     94 my $extra = shift || EMPTY_STRING;
164 26         127 $s =~ s{ \s+ \z}{$extra}xms;
165 26         81 return $s;
166             }
167              
168             sub DEBUG {
169 10202     10202 1 21976 my $thing = shift;
170              
171             # so that one can use: $self->DEBUG or DEBUG
172 10202 100       33896 $thing = shift if _is_parent_object( $thing );
173              
174 10202 100       124968 $DEBUG = $thing+0 if defined $thing; # must be numeric
175 10202         61311 return $DEBUG;
176             }
177              
178             sub DIGEST {
179 26 100   26 1 228 return $DIGEST->new if $DIGEST;
180              
181 8         40 local $SIG{__DIE__};
182             # local $@;
183 8         38 foreach my $mod ( DIGEST_MODS ) {
184 8         58 (my $file = $mod) =~ s{::}{/}xmsog;
185 8         24 $file .= '.pm';
186 8         26 my $ok = eval { require $file; };
  8         507161  
187 8 50       45932 if ( ! $ok ) {
188 0 0       0 LOG( FAILED => "$mod - $file" ) if DEBUG;
189 0         0 next;
190             }
191 8         28 $DIGEST = $mod;
192 8         26 last;
193             }
194              
195 8 50       41 if ( not $DIGEST ) {
196 0         0 my @report = DIGEST_MODS;
197 0         0 my $last_error = pop @report;
198 0         0 fatal( 'tts.util.digest' => join(', ', @report), $last_error, $@ );
199             }
200              
201 8 50       52 LOG( DIGESTER => $DIGEST . ' v' . $DIGEST->VERSION ) if DEBUG;
202 8         49 return $DIGEST->new;
203             }
204              
205             sub LOG {
206 0     0 1 0 my @args = @_;
207 0 0       0 return MYLOG( @args ) if defined &MYLOG;
208 0 0       0 my $self = ref $args[0] ? shift @args : undef;
209 0         0 my $id = shift @args;
210 0         0 my $message = shift @args;
211 0 0       0 $id = 'DEBUG' if not defined $id;
212 0 0       0 $message = '<NO MESSAGE>' if not defined $message;
213 0         0 $id =~ s{_}{ }xmsg;
214 0         0 $message = sprintf q{[ % 15s ] %s}, $id, $message;
215 0         0 warn "$message\n";
216 0         0 return;
217             }
218              
219             sub _is_parent_object {
220 10202     10202   29478 my $test = shift;
221 10202 0       85475 return ! defined $test ? 0
    0          
    50          
    100          
222             : ref $test ? 1
223             : $test eq __PACKAGE__ ? 1
224             : $test eq PARENT ? 1
225             : 0
226             ;
227             }
228              
229             1;
230              
231             __END__
232              
233             =head1 NAME
234              
235             Text::Template::Simple::Util - Utility functions
236              
237             =head1 SYNOPSIS
238              
239             TODO
240              
241             =head1 DESCRIPTION
242              
243             This document describes version C<0.86> of C<Text::Template::Simple::Util>
244             released on C<5 March 2012>.
245              
246             Contains utility functions for Text::Template::Simple.
247              
248             =head1 FUNCTIONS
249              
250             =head2 DEBUG
251              
252             Returns the debug status.
253              
254             =head2 DIGEST
255              
256             Returns the digester object.
257              
258             =head2 binary_mode FH, LAYER
259              
260             Sets the I/O layer of FH in modern perls, only sets binmode on FH otherwise.
261              
262             =head2 L TYPE, ID [, PARAMS]
263              
264             Internal method.
265              
266             =head2 fatal ID [, PARAMS]
267              
268             Internal method.
269              
270             =head2 isaref THING
271              
272             Returns true if C<THING> is an ARRAY.
273              
274             =head2 ishref THING
275              
276             Returns true if C<THING> is a HASH.
277              
278             =head2 iscref THING
279              
280             Returns true if C<THING> is a CODE.
281              
282             =head2 trim STRING
283              
284             Returns the trimmed version of the C<STRING>.
285              
286             =head2 ltrim STRING
287              
288             Returns the left trimmed version of the C<STRING>.
289              
290             =head2 rtrim STRING
291              
292             Returns the right trimmed version of the C<STRING>.
293              
294             =head2 escape CHAR, STRING
295              
296             Escapes all occurrances of C<CHAR> in C<STRING> with backslashes.
297              
298             =head1 OVERRIDABLE FUNCTIONS
299              
300             =head2 LOG
301              
302             If debugging mode is enabled in Text::Template::Simple, all
303             debugging messages will be captured by this function and will
304             be printed to C<STDERR>.
305              
306             If a sub named C<Text::Template::Simple::Util::MYLOG> is defined,
307             then all calls to C<LOG> will be redirected to this sub. If you want to
308             save the debugging messages to a file or to a database, you must define
309             the C<MYLOG> sub.
310              
311             =head1 AUTHOR
312              
313             Burak Gursoy <burak@cpan.org>.
314              
315             =head1 COPYRIGHT
316              
317             Copyright 2004 - 2012 Burak Gursoy. All rights reserved.
318              
319             =head1 LICENSE
320              
321             This library is free software; you can redistribute it and/or modify
322             it under the same terms as Perl itself, either Perl version 5.12.3 or,
323             at your option, any later version of Perl 5 you may have available.
324              
325             =cut