blib/lib/Text/NeatTemplate.pm | |||
---|---|---|---|
Criterion | Covered | Total | % |
statement | 9 | 303 | 2.9 |
branch | 0 | 176 | 0.0 |
condition | 0 | 30 | 0.0 |
subroutine | 3 | 13 | 23.0 |
pod | 10 | 10 | 100.0 |
total | 22 | 532 | 4.1 |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package Text::NeatTemplate; | ||||||
2 | $Text::NeatTemplate::VERSION = '0.1400'; | ||||||
3 | 1 | 1 | 71889 | use strict; | |||
1 | 12 | ||||||
1 | 30 | ||||||
4 | 1 | 1 | 5 | use warnings; | |||
1 | 2 | ||||||
1 | 1480 | ||||||
5 | |||||||
6 | =head1 NAME | ||||||
7 | |||||||
8 | Text::NeatTemplate - a fast, middleweight template engine. | ||||||
9 | |||||||
10 | =head1 VERSION | ||||||
11 | |||||||
12 | version 0.1400 | ||||||
13 | |||||||
14 | =head1 SYNOPSIS | ||||||
15 | |||||||
16 | use Text::NeatTemplate; | ||||||
17 | |||||||
18 | my $tobj = Text::NeatTemplate->new(); | ||||||
19 | |||||||
20 | $result = $tobj->fill_in(data_hash=>\%data, | ||||||
21 | show_names=>\%names, | ||||||
22 | template=>$text); | ||||||
23 | |||||||
24 | =head1 DESCRIPTION | ||||||
25 | |||||||
26 | This module provides a simple, middleweight but fast template engine, | ||||||
27 | for when you need speed rather than complex features, yet need more features | ||||||
28 | than simple variable substitution. | ||||||
29 | |||||||
30 | =head2 Markup Format | ||||||
31 | |||||||
32 | The markup format is as follows: | ||||||
33 | |||||||
34 | =over | ||||||
35 | |||||||
36 | =item {$varname} | ||||||
37 | |||||||
38 | A variable; will display the value of the variable, or nothing if | ||||||
39 | that value is empty. | ||||||
40 | |||||||
41 | =item {$varname:format} | ||||||
42 | |||||||
43 | A formatted variable; will apply the formatting directive(s) to | ||||||
44 | the value before displaying it. | ||||||
45 | |||||||
46 | =item {?varname stuff [$varname] more stuff} | ||||||
47 | |||||||
48 | A conditional. If the value of 'varname' is not empty, this will | ||||||
49 | display "stuff value-of-variable more stuff"; otherwise it displays | ||||||
50 | nothing. | ||||||
51 | |||||||
52 | {?var1 stuff [$var1] thing [$var2]} | ||||||
53 | |||||||
54 | This would use both the values of var1 and var2 if var1 is not | ||||||
55 | empty. | ||||||
56 | |||||||
57 | =item {?varname stuff [$varname] more stuff!!other stuff} | ||||||
58 | |||||||
59 | A conditional with "else". If the value of 'varname' is not empty, this | ||||||
60 | will display "stuff value-of-variable more stuff"; otherwise it displays | ||||||
61 | "other stuff". | ||||||
62 | |||||||
63 | This version can likewise use multiple variables in its display parts. | ||||||
64 | |||||||
65 | {?var1 stuff [$var1] thing [$var2]!![$var3]} | ||||||
66 | |||||||
67 | =item {&funcname(arg1,...,argN)} | ||||||
68 | |||||||
69 | Call a function with the given args; the return value of the | ||||||
70 | function will be what is put in its place. | ||||||
71 | |||||||
72 | {&MyPackage::myfunc(stuff,[$var1])} | ||||||
73 | |||||||
74 | This would call the function myfunc in the package MyPackage, with the | ||||||
75 | arguments "stuff", and the value of var1. | ||||||
76 | |||||||
77 | Note, of course, that if you have a more complicated function and | ||||||
78 | are processing much data, this will slow things down. | ||||||
79 | |||||||
80 | =back | ||||||
81 | |||||||
82 | =head2 Limitations | ||||||
83 | |||||||
84 | To make the parsing simpler (and therefore faster) there are certain | ||||||
85 | restrictions in what this module can do: | ||||||
86 | |||||||
87 | =over | ||||||
88 | |||||||
89 | =item * | ||||||
90 | |||||||
91 | One cannot escape '{' '}' '[' or ']' characters. However, the substitution | ||||||
92 | is clever enough so that you may be able to use them inside conditional | ||||||
93 | constructs, provided the use does not resemble a variable. | ||||||
94 | |||||||
95 | For example, to get a value surrounded by {}, the following | ||||||
96 | will not work: | ||||||
97 | |||||||
98 | {{$Var1}} | ||||||
99 | |||||||
100 | However, this will: | ||||||
101 | |||||||
102 | {?Var1 {[$Var1]}} | ||||||
103 | |||||||
104 | =item * | ||||||
105 | |||||||
106 | One cannot have nested variables. | ||||||
107 | |||||||
108 | =item * | ||||||
109 | |||||||
110 | Conditionals are limited to testing whether or not the variable | ||||||
111 | has a value. If you want more elaborate tests, or tests on more | ||||||
112 | than one value, you'll have to write a function to do it, and | ||||||
113 | use the {&function()} construct. | ||||||
114 | |||||||
115 | =item * | ||||||
116 | |||||||
117 | Function arguments (as given with the {&funcname(arg1,arg2...)} format) | ||||||
118 | cannot have commas in them, since commas are used to separate the | ||||||
119 | arguments. | ||||||
120 | |||||||
121 | =back | ||||||
122 | |||||||
123 | =head2 Justification For Existence | ||||||
124 | |||||||
125 | When I was writing SQLite::Work, I originally tried using L |
||||||
126 | (my favourite template engine) and also tried L |
||||||
127 | of them had some lovely, powerful features. Unfortunately, they were | ||||||
128 | also relatively slow. In testing them with a 700-row table, using | ||||||
129 | Text::Template took about 15 seconds to generate the report, and using | ||||||
130 | Text::FillIn took 45 seconds! Rolling my own very simple template | ||||||
131 | engine cut the time down to about 7 seconds. | ||||||
132 | |||||||
133 | The reasons for this aren't that surprising. Because Text::Template | ||||||
134 | is basically an embedded Perl engine, it has to run the interpreter | ||||||
135 | on each substitution. And Text::FillIn has a lot to do, what with being | ||||||
136 | very generic and very recursive. | ||||||
137 | |||||||
138 | The trade-off for the speed-gain of Text::NeatTemplate is that | ||||||
139 | it is quite simple. There is no nesting or recursion, there are | ||||||
140 | no loops. But I do think I've managed to grab some of the nicer features | ||||||
141 | of other template engines, such as limited conditionals, and formatting, | ||||||
142 | and, the most powerful of all, calling external functions. | ||||||
143 | |||||||
144 | This is a middleweight engine rather than a lightweight one, because | ||||||
145 | I needed more than just simple variable substitution, such as one | ||||||
146 | has with L |
||||||
147 | and others might also, so I made this a separate module. | ||||||
148 | |||||||
149 | =head1 FORMATTING | ||||||
150 | |||||||
151 | As well as simple substitution, this module can apply formatting | ||||||
152 | to values before they are displayed. | ||||||
153 | |||||||
154 | For example: | ||||||
155 | |||||||
156 | {$Money:dollars} | ||||||
157 | |||||||
158 | will give the value of the I |
||||||
159 | |||||||
160 | Formatting directives are: | ||||||
161 | |||||||
162 | =over | ||||||
163 | |||||||
164 | =item alpha | ||||||
165 | |||||||
166 | Convert to a string containing only alphanumeric characters | ||||||
167 | (useful for anchors or filenames) | ||||||
168 | |||||||
169 | =item alphadash | ||||||
170 | |||||||
171 | Convert to a string containing alphanumeric characters, dashes | ||||||
172 | and underscores; spaces are converted to underscores. | ||||||
173 | (useful for anchors or filenames) | ||||||
174 | |||||||
175 | =item alphahash | ||||||
176 | |||||||
177 | Convert to a string containing only alphanumeric characters | ||||||
178 | and then prefix with a hash (#) character | ||||||
179 | (useful for anchors or tags) | ||||||
180 | |||||||
181 | =item alphahyphen | ||||||
182 | |||||||
183 | Convert to a string containing alphanumeric characters, dashes | ||||||
184 | and underscores; spaces are converted to hyphens. | ||||||
185 | (useful for anchors or filenames) | ||||||
186 | |||||||
187 | =item comma_front | ||||||
188 | |||||||
189 | Put anything after the last comma at the front (as with an author name) | ||||||
190 | For example, "Smith,Sarah Jane" becomes "Sarah Jane Smith". | ||||||
191 | |||||||
192 | =item dollars | ||||||
193 | |||||||
194 | Return as a dollar value (float of precision 2) | ||||||
195 | |||||||
196 | =item email | ||||||
197 | |||||||
198 | Convert to a HTML mailto link. | ||||||
199 | |||||||
200 | =item float | ||||||
201 | |||||||
202 | Convert to float. | ||||||
203 | |||||||
204 | =item hmail | ||||||
205 | |||||||
206 | Convert to a "humanized" version of the email, with the @ and '.' | ||||||
207 | replaced with "at" and "dot". This is useful to prevent spambots | ||||||
208 | harvesting email addresses. | ||||||
209 | |||||||
210 | =item html | ||||||
211 | |||||||
212 | Convert to simple HTML (simple formatting) | ||||||
213 | |||||||
214 | =item int | ||||||
215 | |||||||
216 | Convert to integer | ||||||
217 | |||||||
218 | =item itemI |
||||||
219 | |||||||
220 | Assume that the value is multiple values separated by the "pipe" symbol (|) and | ||||||
221 | select the item with an index of I |
||||||
222 | |||||||
223 | =item items_I |
||||||
224 | |||||||
225 | Assume that the value is multiple values separated by the "pipe" symbol (|) and | ||||||
226 | split the values into an array, apply the I |
||||||
227 | join them together with a space. | ||||||
228 | |||||||
229 | =item itemsjslash_I |
||||||
230 | |||||||
231 | Like items_I |
||||||
232 | |||||||
233 | =item itemslashI |
||||||
234 | |||||||
235 | Assume that the value is multiple values separated by the "slash" symbol (/) and | ||||||
236 | select the item with an index of I |
||||||
237 | Good for selecting out components of pathnames. | ||||||
238 | |||||||
239 | =item lower | ||||||
240 | |||||||
241 | Convert to lower case. | ||||||
242 | |||||||
243 | =item month | ||||||
244 | |||||||
245 | Convert the number value to an English month name. | ||||||
246 | |||||||
247 | =item namedalpha | ||||||
248 | |||||||
249 | Similar to 'alpha', but prepends the 'name' of the value. | ||||||
250 | Assumes that the name is only alphanumeric. | ||||||
251 | |||||||
252 | =item nth | ||||||
253 | |||||||
254 | Convert the number value to a N-th value. Numbers ending with 1 have 'st' | ||||||
255 | appended, 2 have 'nd' appended, 3 have 'rd' appended, and everything | ||||||
256 | else has 'th' appended. | ||||||
257 | |||||||
258 | =item percent | ||||||
259 | |||||||
260 | Show as if the value is a percentage. | ||||||
261 | |||||||
262 | =item pipetocomma | ||||||
263 | |||||||
264 | Assume that the value is multiple values separated by the "pipe" symbol (|) and replace | ||||||
265 | those with a comma and space. | ||||||
266 | |||||||
267 | =item pipetoslash | ||||||
268 | |||||||
269 | Assume that the value is multiple values separated by the "pipe" symbol (|) and replace | ||||||
270 | those with a forward slash (/). | ||||||
271 | |||||||
272 | =item proper | ||||||
273 | |||||||
274 | Convert to a Proper Noun. | ||||||
275 | |||||||
276 | =item string | ||||||
277 | |||||||
278 | Return the value with no change. | ||||||
279 | |||||||
280 | =item title | ||||||
281 | |||||||
282 | Put any trailing ",The" ",A" or ",An" at the front (as this is a title) | ||||||
283 | |||||||
284 | =item truncateI |
||||||
285 | |||||||
286 | Truncate to I |
||||||
287 | |||||||
288 | =item upper | ||||||
289 | |||||||
290 | Convert to upper case. | ||||||
291 | |||||||
292 | =item url | ||||||
293 | |||||||
294 | Convert to a HTML href link. | ||||||
295 | |||||||
296 | =item wikilink | ||||||
297 | |||||||
298 | Format the value as the most common kind of wikilink, that is [[I |
||||||
299 | |||||||
300 | =item wordsI |
||||||
301 | |||||||
302 | Give the first I |
||||||
303 | |||||||
304 | =back | ||||||
305 | |||||||
306 | =cut | ||||||
307 | |||||||
308 | |||||||
309 | =head1 CLASS METHODS | ||||||
310 | |||||||
311 | =head2 new | ||||||
312 | |||||||
313 | my $tobj = Text::NeatTemplate->new(); | ||||||
314 | |||||||
315 | Make a new template object. | ||||||
316 | |||||||
317 | =cut | ||||||
318 | |||||||
319 | sub new { | ||||||
320 | 0 | 0 | 1 | my $class = shift; | |||
321 | 0 | my %parameters = @_; | |||||
322 | 0 | 0 | my $self = bless ({%parameters}, ref ($class) || $class); | ||||
323 | |||||||
324 | 0 | return ($self); | |||||
325 | } # new | ||||||
326 | |||||||
327 | |||||||
328 | =head1 METHODS | ||||||
329 | |||||||
330 | =head2 fill_in | ||||||
331 | |||||||
332 | Fill in the given values. | ||||||
333 | |||||||
334 | $result = $tobj->fill_in(data_hash=>\%data, | ||||||
335 | show_names=>\%names, | ||||||
336 | template=>$text); | ||||||
337 | |||||||
338 | The 'data_hash' is a hash containing names and values. | ||||||
339 | |||||||
340 | The 'show_names' is a hash saying which of these "variable names" | ||||||
341 | ought to be displayed, and which suppressed. This can be useful | ||||||
342 | if you want to use a more generic template, and then dynamically | ||||||
343 | suppress certain values at runtime. | ||||||
344 | |||||||
345 | The 'template' is the text of the template. | ||||||
346 | |||||||
347 | =cut | ||||||
348 | sub fill_in { | ||||||
349 | 0 | 0 | 1 | my $self = shift; | |||
350 | 0 | my %args = ( | |||||
351 | data_hash=>undef, | ||||||
352 | show_names=>undef, | ||||||
353 | template=>undef, | ||||||
354 | @_ | ||||||
355 | ); | ||||||
356 | |||||||
357 | 0 | my $out = $args{template}; | |||||
358 | 0 | $out =~ s/{([^}]+)}/$self->do_replace(data_hash=>$args{data_hash},show_names=>$args{show_names},targ=>$1)/eg; | |||||
0 | |||||||
359 | |||||||
360 | 0 | return $out; | |||||
361 | } # fill_in | ||||||
362 | |||||||
363 | =head2 get_varnames | ||||||
364 | |||||||
365 | Find variable names inside the given template. | ||||||
366 | |||||||
367 | @varnames = $tobj->get_varnames(template=>$text); | ||||||
368 | |||||||
369 | =cut | ||||||
370 | sub get_varnames { | ||||||
371 | 0 | 0 | 1 | my $self = shift; | |||
372 | 0 | my %args = ( | |||||
373 | template=>undef, | ||||||
374 | @_ | ||||||
375 | ); | ||||||
376 | 0 | my $template = $args{template}; | |||||
377 | |||||||
378 | 0 | 0 | return '' if (!$template); | ||||
379 | |||||||
380 | 0 | my %varnames = (); | |||||
381 | # { (the regex below needs matching) | ||||||
382 | 0 | while ($template =~ m/{([^}]+)}/g) | |||||
383 | { | ||||||
384 | 0 | my $targ = $1; | |||||
385 | |||||||
386 | 0 | 0 | if ($targ =~ /^\$(\w+[-:\w]*)$/) | ||||
0 | |||||||
0 | |||||||
0 | |||||||
387 | { | ||||||
388 | 0 | my $val_id = $1; | |||||
389 | 0 | $varnames{$val_id} = 1; | |||||
390 | } | ||||||
391 | elsif ($targ =~ /^\?([-\w]+)\s(.*)!!(.*)$/) | ||||||
392 | { | ||||||
393 | 0 | my $val_id = $1; | |||||
394 | 0 | my $yes_t = $2; | |||||
395 | 0 | my $no_t = $3; | |||||
396 | |||||||
397 | 0 | $varnames{$val_id} = 1; | |||||
398 | |||||||
399 | 0 | foreach my $substr ($yes_t, $no_t) | |||||
400 | { | ||||||
401 | 0 | while ($substr =~ /\[(\$[^\]]+)\]/) | |||||
402 | { | ||||||
403 | 0 | $varnames{$1} = 1; | |||||
404 | } | ||||||
405 | } | ||||||
406 | } | ||||||
407 | elsif ($targ =~ /^\?([-\w]+)\s(.*)$/) | ||||||
408 | { | ||||||
409 | 0 | my $val_id = $1; | |||||
410 | 0 | my $yes_t = $2; | |||||
411 | |||||||
412 | 0 | $varnames{$val_id} = 1; | |||||
413 | 0 | while ($yes_t =~ /\[(\$[^\]]+)\]/) | |||||
414 | { | ||||||
415 | 0 | $varnames{$1} = 1; | |||||
416 | } | ||||||
417 | } | ||||||
418 | elsif ($targ =~ /^\&([-\w:]+)\((.*)\)$/) | ||||||
419 | { | ||||||
420 | # function | ||||||
421 | 0 | my $func_name = $1; | |||||
422 | 0 | my $fargs = $2; | |||||
423 | 0 | while ($fargs =~ /\[(\$[^\]]+)\]/) | |||||
424 | { | ||||||
425 | 0 | $varnames{$1} = 1; | |||||
426 | } | ||||||
427 | } | ||||||
428 | } | ||||||
429 | 0 | return sort keys %varnames; | |||||
430 | } # get_varnames | ||||||
431 | |||||||
432 | =head2 do_replace | ||||||
433 | |||||||
434 | Replace the given value. | ||||||
435 | |||||||
436 | $val = $tobj->do_replace(targ=>$targ, | ||||||
437 | data_hash=>$data_hashref, | ||||||
438 | show_names=>\%show_names); | ||||||
439 | |||||||
440 | Where 'targ' is the target value, which is either a variable target, | ||||||
441 | or a conditional target. | ||||||
442 | |||||||
443 | The 'data_hash' is a hash containing names and values. | ||||||
444 | |||||||
445 | The 'show_names' is a hash saying which of these "variable names" | ||||||
446 | ought to be displayed, and which suppressed. | ||||||
447 | |||||||
448 | This can do templating by using the exec ability of substitution, for | ||||||
449 | example: | ||||||
450 | |||||||
451 | $out =~ s/{([^}]+)}/$tobj->do_replace(data_hash=>$data_hash,targ=>$1)/eg; | ||||||
452 | |||||||
453 | =cut | ||||||
454 | sub do_replace { | ||||||
455 | 0 | 0 | 1 | my $self = shift; | |||
456 | 0 | my %args = ( | |||||
457 | targ=>'', | ||||||
458 | data_hash=>undef, | ||||||
459 | show_names=>undef, | ||||||
460 | @_ | ||||||
461 | ); | ||||||
462 | 0 | my $targ = $args{targ}; | |||||
463 | |||||||
464 | 0 | 0 | return '' if (!$targ); | ||||
465 | 0 | 0 | if ($targ =~ /^\$(\w+[-:\w]*)$/) | ||||
0 | |||||||
0 | |||||||
0 | |||||||
466 | { | ||||||
467 | my $val = $self->get_value(val_id=>$1, | ||||||
468 | data_hash=>$args{data_hash}, | ||||||
469 | 0 | show_names=>$args{show_names}); | |||||
470 | 0 | 0 | if (defined $val) | ||||
471 | { | ||||||
472 | 0 | return $val; | |||||
473 | } | ||||||
474 | else # not a variable -- return nothing | ||||||
475 | { | ||||||
476 | 0 | return ''; | |||||
477 | } | ||||||
478 | } | ||||||
479 | elsif ($targ =~ /^\?([-\w]+)\s(.*)!!(.*)$/) | ||||||
480 | { | ||||||
481 | 0 | my $val_id = $1; | |||||
482 | 0 | my $yes_t = $2; | |||||
483 | 0 | my $no_t = $3; | |||||
484 | my $val = $self->get_value(val_id=>$val_id, | ||||||
485 | data_hash=>$args{data_hash}, | ||||||
486 | 0 | show_names=>$args{show_names}); | |||||
487 | 0 | 0 | if ($val) | ||||
488 | { | ||||||
489 | 0 | $yes_t =~ s/\[(\$[^\]]+)\]/$self->do_replace(data_hash=>$args{data_hash},show_names=>$args{show_names},targ=>$1)/eg; | |||||
0 | |||||||
490 | 0 | return $yes_t; | |||||
491 | } | ||||||
492 | else # no value, return alternative | ||||||
493 | { | ||||||
494 | 0 | $no_t =~ s/\[(\$[^\]]+)\]/$self->do_replace(data_hash=>$args{data_hash},show_names=>$args{show_names},targ=>$1)/eg; | |||||
0 | |||||||
495 | 0 | return $no_t; | |||||
496 | } | ||||||
497 | } | ||||||
498 | elsif ($targ =~ /^\?([-\w]+)\s(.*)$/) | ||||||
499 | { | ||||||
500 | 0 | my $val_id = $1; | |||||
501 | 0 | my $yes_t = $2; | |||||
502 | my $val = $self->get_value(val_id=>$val_id, | ||||||
503 | data_hash=>$args{data_hash}, | ||||||
504 | 0 | show_names=>$args{show_names}); | |||||
505 | 0 | 0 | if ($val) | ||||
506 | { | ||||||
507 | 0 | $yes_t =~ s/\[(\$[^\]]+)\]/$self->do_replace(data_hash=>$args{data_hash},show_names=>$args{show_names},targ=>$1)/eg; | |||||
0 | |||||||
508 | 0 | return $yes_t; | |||||
509 | } | ||||||
510 | else # no value, return nothing | ||||||
511 | { | ||||||
512 | 0 | return ''; | |||||
513 | } | ||||||
514 | } | ||||||
515 | elsif ($targ =~ /^\&([-\w:]+)\((.*)\)$/) | ||||||
516 | { | ||||||
517 | # function | ||||||
518 | 0 | my $func_name = $1; | |||||
519 | 0 | my $fargs = $2; | |||||
520 | # split the args first, and replace each one separately | ||||||
521 | # just in case the data values have commas | ||||||
522 | 0 | my @fargs = split(/,/,$fargs); | |||||
523 | 0 | my @processed = (); | |||||
524 | 0 | foreach my $fa (@fargs) | |||||
525 | { | ||||||
526 | 0 | $fa =~ s/\[(\$[^\]]+)\]/$self->do_replace(data_hash=>$args{data_hash},show_names=>$args{show_names},targ=>$1)/eg; | |||||
0 | |||||||
527 | 0 | push @processed, $fa; | |||||
528 | } | ||||||
529 | { | ||||||
530 | 1 | 1 | 9 | no strict('refs'); | |||
1 | 2 | ||||||
1 | 3073 | ||||||
0 | |||||||
531 | 0 | return &{$func_name}(@processed); | |||||
0 | |||||||
532 | } | ||||||
533 | } | ||||||
534 | else | ||||||
535 | { | ||||||
536 | 0 | print STDERR "UNKNOWN ==$targ==\n"; | |||||
537 | } | ||||||
538 | 0 | return ''; | |||||
539 | } # do_replace | ||||||
540 | |||||||
541 | =head2 get_value | ||||||
542 | |||||||
543 | $val = $tobj->get_value(val_id=>$val_id, | ||||||
544 | data_hash=>$data_hashref, | ||||||
545 | show_names=>\%show_names); | ||||||
546 | |||||||
547 | Get and format the given value. | ||||||
548 | |||||||
549 | =cut | ||||||
550 | sub get_value { | ||||||
551 | 0 | 0 | 1 | my $self = shift; | |||
552 | 0 | my %args = ( | |||||
553 | val_id=>'', | ||||||
554 | data_hash=>undef, | ||||||
555 | show_names=>undef, | ||||||
556 | @_ | ||||||
557 | ); | ||||||
558 | 0 | my ($varname, @formats) = split(':', $args{val_id}); | |||||
559 | |||||||
560 | 0 | my $value; | |||||
561 | 0 | 0 | if (exists $args{data_hash}->{$varname}) | ||||
562 | { | ||||||
563 | 0 | 0 | 0 | if (!$args{show_names} | |||
564 | or $args{show_names}->{$varname}) | ||||||
565 | { | ||||||
566 | 0 | $value = $args{data_hash}->{$varname}; | |||||
567 | } | ||||||
568 | else | ||||||
569 | { | ||||||
570 | 0 | return ''; | |||||
571 | } | ||||||
572 | } | ||||||
573 | else | ||||||
574 | { | ||||||
575 | 0 | return undef; | |||||
576 | } | ||||||
577 | |||||||
578 | # we have a value to format | ||||||
579 | 0 | foreach my $format (@formats) { | |||||
580 | 0 | $value = $self->convert_value(value=>$value, | |||||
581 | format=>$format, | ||||||
582 | name=>$varname); | ||||||
583 | } | ||||||
584 | 0 | 0 | 0 | if ($value and $self->{escape_html}) | |||
585 | { | ||||||
586 | # filter out some HTML stuff | ||||||
587 | 0 | $value =~ s/ & / & /g; | |||||
588 | } | ||||||
589 | 0 | return $value; | |||||
590 | } # get_value | ||||||
591 | |||||||
592 | =head2 convert_value | ||||||
593 | |||||||
594 | my $val = $tobj->convert_value(value=>$val, | ||||||
595 | format=>$format, | ||||||
596 | name=>$name); | ||||||
597 | |||||||
598 | Convert a value according to the given formatting directive. | ||||||
599 | |||||||
600 | See L for details of all the formatting directives. | ||||||
601 | |||||||
602 | |||||||
603 | =cut | ||||||
604 | sub convert_value { | ||||||
605 | 0 | 0 | 1 | my $self = shift; | |||
606 | 0 | my %args = @_; | |||||
607 | 0 | my $value = $args{value}; | |||||
608 | 0 | my $style = $args{format}; | |||||
609 | 0 | my $name = $args{name}; | |||||
610 | |||||||
611 | 0 | 0 | $value ||= ''; | ||||
612 | 0 | 0 | ($_=$style) || ($_ = 'string'); | ||||
613 | SWITCH: { | ||||||
614 | 0 | 0 | /^upper/i && (return uc($value)); | ||||
0 | |||||||
615 | 0 | 0 | /^lower/i && (return lc($value)); | ||||
616 | 0 | 0 | /^int/i && (return (defined $value ? int($value) : 0)); | ||||
0 | |||||||
617 | 0 | 0 | 0 | /^float/i && (return (defined $value && sprintf('%f',($value || 0))) || ''); | |||
618 | 0 | 0 | /^string/i && (return $value); | ||||
619 | 0 | 0 | 0 | /^trunc(?:ate)?(\d+)/ && (return substr(($value||''), 0, $1)); | |||
620 | 0 | 0 | 0 | /^dollars/i && | |||
621 | (return (defined $value && length($value) | ||||||
622 | && sprintf('%.2f',($value || 0)) || '')); | ||||||
623 | 0 | 0 | 0 | /^percent/i && | |||
624 | (return (($value<0.2) && | ||||||
625 | sprintf('%.1f%%',($value*100)) | ||||||
626 | || sprintf('%d%%',int($value*100)))); | ||||||
627 | 0 | 0 | /^url/i && (return "$value"); | ||||
628 | 0 | 0 | /^wikilink/i && (return "[[$value]]"); | ||||
629 | 0 | 0 | /^email/i && (return "$value"); | ||||
630 | 0 | 0 | /^hmail/i && do { | ||||
631 | 0 | $value =~ s/@/ at /; | |||||
632 | 0 | $value =~ s/\./ dot /g; | |||||
633 | 0 | return $value; | |||||
634 | }; | ||||||
635 | 0 | 0 | /^html/i && (return $self->simple_html($value)); | ||||
636 | 0 | 0 | /^title/i && do { | ||||
637 | 0 | $value =~ s/(.*)[,;]\s*(A|An|The)$/$2 $1/; | |||||
638 | 0 | return $value; | |||||
639 | }; | ||||||
640 | 0 | 0 | /^comma_front/i && do { | ||||
641 | 0 | $value =~ s/(.*)[,]([^,]+)$/$2 $1/; | |||||
642 | 0 | return $value; | |||||
643 | }; | ||||||
644 | 0 | 0 | /^proper/i && do { | ||||
645 | 0 | $value =~ s/(^w|\b\w)/uc($1)/eg; | |||||
0 | |||||||
646 | 0 | return $value; | |||||
647 | }; | ||||||
648 | # YYYY-MM-DD dates | ||||||
649 | 0 | 0 | /^date_year/i && do { | ||||
650 | 0 | 0 | return $value if !$value; | ||||
651 | 0 | $value =~ s/^([0-9]+)-.*/$1/; | |||||
652 | 0 | return $value; | |||||
653 | }; | ||||||
654 | 0 | 0 | /^date_mth/i && do { | ||||
655 | 0 | 0 | return $value if !$value; | ||||
656 | 0 | $value =~ s/^([0-9]+)-([0-9]+)-([0-9]+)/$2/; | |||||
657 | 0 | return $value; | |||||
658 | }; | ||||||
659 | 0 | 0 | /^date_day/i && do { | ||||
660 | 0 | 0 | return $value if !$value; | ||||
661 | 0 | $value =~ s/^([0-9]+)-([0-9]+)-([0-9]+)/$3/; | |||||
662 | 0 | return $value; | |||||
663 | }; | ||||||
664 | 0 | 0 | /^date_month/i && do { | ||||
665 | 0 | 0 | return $value if !$value; | ||||
666 | 0 | 0 | if ($value =~ /^([0-9]+)-([0-9]+)-([0-9]+)/) | ||||
667 | { | ||||||
668 | 0 | my $mth = $2; | |||||
669 | 0 | $value = $self->number_to_month($mth); | |||||
670 | } | ||||||
671 | 0 | return $value; | |||||
672 | }; | ||||||
673 | 0 | 0 | /^month/i && do { | ||||
674 | 0 | return $self->number_to_month($value); | |||||
675 | }; | ||||||
676 | 0 | 0 | /^nth/i && do { | ||||
677 | 0 | 0 | return $value if !$value; | ||||
678 | 0 | 0 | return ($value =~ /1[123]$/ | ||||
0 | |||||||
0 | |||||||
0 | |||||||
679 | ? "${value}th" | ||||||
680 | : ($value =~ /1$/ | ||||||
681 | ? "${value}st" | ||||||
682 | : ($value =~ /2$/ | ||||||
683 | ? "${value}nd" | ||||||
684 | : ($value =~ /3$/ | ||||||
685 | ? "${value}rd" | ||||||
686 | : "${value}th" | ||||||
687 | ) | ||||||
688 | ) | ||||||
689 | ) | ||||||
690 | ); | ||||||
691 | }; | ||||||
692 | 0 | 0 | /^facettag/i && do { | ||||
693 | 0 | $value =~ s!/! !g; | |||||
694 | 0 | $value =~ s/^\s+//; | |||||
695 | 0 | $value =~ s/\s+$//; | |||||
696 | 0 | $value =~ s/[^\w\s:_-]//g; | |||||
697 | 0 | $value =~ s/\s\s+/ /g; | |||||
698 | 0 | $value =~ s/ /_/g; | |||||
699 | 0 | $value = join(':', $name, $value); | |||||
700 | 0 | return $value; | |||||
701 | }; | ||||||
702 | 0 | 0 | /^namedalpha/i && do { | ||||
703 | 0 | $value =~ s/[^a-zA-Z0-9]//g; | |||||
704 | 0 | $value = join('_', $name, $value); | |||||
705 | 0 | return $value; | |||||
706 | }; | ||||||
707 | 0 | 0 | /^alphadash/i && do { | ||||
708 | 0 | $value =~ s!/! !g; | |||||
709 | 0 | $value =~ s/[^a-zA-Z0-9_\s-]//g; | |||||
710 | 0 | $value =~ s/^\s+//; | |||||
711 | 0 | $value =~ s/\s+$//; | |||||
712 | 0 | $value =~ s/\s\s+/ /g; | |||||
713 | 0 | $value =~ s/ /_/g; | |||||
714 | 0 | return $value; | |||||
715 | }; | ||||||
716 | 0 | 0 | /^alphahyphen/i && do { | ||||
717 | 0 | $value =~ s!/! !g; | |||||
718 | 0 | $value =~ s/[^a-zA-Z0-9_\s-]//g; | |||||
719 | 0 | $value =~ s/^\s+//; | |||||
720 | 0 | $value =~ s/\s+$//; | |||||
721 | 0 | $value =~ s/\s\s+/ /g; | |||||
722 | 0 | $value =~ s/ /-/g; | |||||
723 | 0 | return $value; | |||||
724 | }; | ||||||
725 | 0 | 0 | /^alphahash/i && do { | ||||
726 | 0 | $value =~ s/[^a-zA-Z0-9]//g; | |||||
727 | 0 | $value = "#${value}"; | |||||
728 | 0 | return $value; | |||||
729 | }; | ||||||
730 | 0 | 0 | /^alpha/i && do { | ||||
731 | 0 | $value =~ s/[^a-zA-Z0-9]//g; | |||||
732 | 0 | return $value; | |||||
733 | }; | ||||||
734 | 0 | 0 | /^pipetocomma/i && do { | ||||
735 | 0 | $value =~ s/\|/, /g; | |||||
736 | 0 | return $value; | |||||
737 | }; | ||||||
738 | 0 | 0 | /^pipetoslash/i && do { | ||||
739 | 0 | $value =~ s/\|/\//g; | |||||
740 | 0 | return $value; | |||||
741 | }; | ||||||
742 | 0 | 0 | /^words(\d+)/ && do { | ||||
743 | 0 | my $ct = $1; | |||||
744 | 0 | 0 | ($ct>0) || return ''; | ||||
745 | 0 | my @sentence = split(/\s+/, $value); | |||||
746 | 0 | my (@words) = splice(@sentence,0,$ct); | |||||
747 | 0 | return join(' ', @words); | |||||
748 | }; | ||||||
749 | 0 | 0 | /^wlink_(\w+)/ && do { | ||||
750 | 0 | my $prefix = $1; | |||||
751 | 0 | return "[[$prefix/$value]]"; | |||||
752 | }; | ||||||
753 | 0 | 0 | /^tagify/i && do { | ||||
754 | 0 | $value =~ s/\|/,/g; | |||||
755 | 0 | $value =~ s!/! !g; | |||||
756 | 0 | $value =~ s/!/ /g; | |||||
757 | 0 | $value =~ s/^\s+//; | |||||
758 | 0 | $value =~ s/\s+$//; | |||||
759 | 0 | $value =~ s/[^\w,\s_-]//g; | |||||
760 | 0 | $value =~ s/\s\s+/ /g; | |||||
761 | 0 | $value =~ s/ /_/g; | |||||
762 | 0 | return $value; | |||||
763 | }; | ||||||
764 | 0 | 0 | /^item(\d+)/ && do { | ||||
765 | 0 | my $ct = $1; | |||||
766 | 0 | 0 | ($ct>=0) || return ''; | ||||
767 | 0 | my @items = split(/\|/, $value); | |||||
768 | 0 | return $items[$ct]; | |||||
769 | }; | ||||||
770 | 0 | 0 | /^itemslash(\d+)/ && do { | ||||
771 | 0 | my $ct = $1; | |||||
772 | 0 | 0 | ($ct>=0) || return ''; | ||||
773 | 0 | my @items = split(/\//, $value); | |||||
774 | 0 | return $items[$ct]; | |||||
775 | }; | ||||||
776 | 0 | 0 | /^items_(\w+)/ && do { | ||||
777 | 0 | my $next = $1; | |||||
778 | 0 | my @items = split(/[\|,]\s*/, $value); | |||||
779 | 0 | my @next_items = (); | |||||
780 | 0 | foreach my $item (@items) | |||||
781 | { | ||||||
782 | 0 | push @next_items, $self->convert_value(%args, value=>$item, format=>$next); | |||||
783 | } | ||||||
784 | 0 | return join(' ', @next_items); | |||||
785 | }; | ||||||
786 | 0 | 0 | /^itemsjslash_(\w+)/ && do { | ||||
787 | 0 | my $next = $1; | |||||
788 | 0 | my @items = split(/[\|,]\s*/, $value); | |||||
789 | 0 | my @next_items = (); | |||||
790 | 0 | foreach my $item (@items) | |||||
791 | { | ||||||
792 | 0 | push @next_items, $self->convert_value(%args, value=>$item, format=>$next); | |||||
793 | } | ||||||
794 | 0 | return join(' / ', @next_items); | |||||
795 | }; | ||||||
796 | 0 | 0 | /^itemsjcomma_(\w+)/ && do { | ||||
797 | 0 | my $next = $1; | |||||
798 | 0 | my @items = split(/[\|,]\s*/, $value); | |||||
799 | 0 | my @next_items = (); | |||||
800 | 0 | foreach my $item (@items) | |||||
801 | { | ||||||
802 | 0 | push @next_items, $self->convert_value(%args, value=>$item, format=>$next); | |||||
803 | } | ||||||
804 | 0 | return join(',', @next_items); | |||||
805 | }; | ||||||
806 | |||||||
807 | # otherwise, give up | ||||||
808 | 0 | return " {{{ style $style not supported }}} "; | |||||
809 | } | ||||||
810 | } # convert_value | ||||||
811 | |||||||
812 | =head2 simple_html | ||||||
813 | |||||||
814 | $val = $tobj->simple_html($val); | ||||||
815 | |||||||
816 | Do a simple HTML conversion of the value. | ||||||
817 | bold, italic, |
||||||
818 | |||||||
819 | =cut | ||||||
820 | sub simple_html { | ||||||
821 | 0 | 0 | 1 | my $self = shift; | |||
822 | 0 | my $value = shift; | |||||
823 | |||||||
824 | 0 | $value =~ s#\n[\s][\s][\s]+# \n #sg; |
|||||
825 | 0 | $value =~ s#\s*\n\s*\n# \n#sg; |
|||||
826 | 0 | $value =~ s#\*([^*]+)\*#$1#sg; | |||||
827 | 0 | $value =~ s/\^([^^]+)\^/$1<\/b>/sg; | |||||
828 | 0 | $value =~ s/\#([^#<>]+)\#/$1<\/b>/sg; | |||||
829 | 0 | $value =~ s/\s&\s/ & /sg; | |||||
830 | 0 | return $value; | |||||
831 | } # simple_html | ||||||
832 | |||||||
833 | =head2 number_to_month | ||||||
834 | |||||||
835 | $val = $tobj->number_to_month($val); | ||||||
836 | |||||||
837 | Give the month name for this month-number. | ||||||
838 | |||||||
839 | =cut | ||||||
840 | sub number_to_month { | ||||||
841 | 0 | 0 | 1 | my $self = shift; | |||
842 | 0 | my $value = shift; | |||||
843 | |||||||
844 | 0 | 0 | return $value if !$value; | ||||
845 | 0 | 0 | return ($value == 1 | ||||
0 | |||||||
0 | |||||||
0 | |||||||
0 | |||||||
0 | |||||||
0 | |||||||
0 | |||||||
0 | |||||||
0 | |||||||
0 | |||||||
0 | |||||||
846 | ? 'January' | ||||||
847 | : ($value == 2 | ||||||
848 | ? 'February' | ||||||
849 | : ($value == 3 | ||||||
850 | ? 'March' | ||||||
851 | : ($value == 4 | ||||||
852 | ? 'April' | ||||||
853 | : ($value == 5 | ||||||
854 | ? 'May' | ||||||
855 | : ($value == 6 | ||||||
856 | ? 'June' | ||||||
857 | : ($value == 7 | ||||||
858 | ? 'July' | ||||||
859 | : ($value == 8 | ||||||
860 | ? 'August' | ||||||
861 | : ($value == 9 | ||||||
862 | ? 'September' | ||||||
863 | : ($value == 10 | ||||||
864 | ? 'October' | ||||||
865 | : ($value == 11 | ||||||
866 | ? 'November' | ||||||
867 | : ($value == 12 | ||||||
868 | ? 'December' | ||||||
869 | : $value | ||||||
870 | ) | ||||||
871 | ) | ||||||
872 | ) | ||||||
873 | ) | ||||||
874 | ) | ||||||
875 | ) | ||||||
876 | ) | ||||||
877 | ) | ||||||
878 | ) | ||||||
879 | ) | ||||||
880 | ) | ||||||
881 | ); | ||||||
882 | # fallthrough | ||||||
883 | 0 | return $value; | |||||
884 | } # number_to_month | ||||||
885 | |||||||
886 | =head1 Callable Functions | ||||||
887 | |||||||
888 | =head2 safe_backtick | ||||||
889 | |||||||
890 | {&safe_backtick(myprog,arg1,arg2...argN)} | ||||||
891 | |||||||
892 | Return the results of a program, without risking evil shell calls. | ||||||
893 | This requires that the program and the arguments to that program | ||||||
894 | be given separately. | ||||||
895 | |||||||
896 | =cut | ||||||
897 | sub safe_backtick { | ||||||
898 | 0 | 0 | 1 | my @prog_and_args = @_; | |||
899 | 0 | my $progname = $prog_and_args[0]; | |||||
900 | |||||||
901 | # if they didn't give us anything, return | ||||||
902 | 0 | 0 | if (!$progname) | ||||
903 | { | ||||||
904 | 0 | return ''; | |||||
905 | } | ||||||
906 | # call the program | ||||||
907 | # do a fork and exec with an open; | ||||||
908 | # this should preserve the environment and also be safe | ||||||
909 | 0 | my $result = ''; | |||||
910 | 0 | my $fh; | |||||
911 | 0 | my $pid = open($fh, "-|"); | |||||
912 | 0 | 0 | if ($pid) # parent | ||||
913 | { | ||||||
914 | { | ||||||
915 | # slurp up the result all at once | ||||||
916 | 0 | local $/ = undef; | |||||
0 | |||||||
917 | 0 | $result = <$fh>; | |||||
918 | } | ||||||
919 | 0 | 0 | close($fh) || warn "$progname program script exited $?"; | ||||
920 | } | ||||||
921 | else # child | ||||||
922 | { | ||||||
923 | # call the program | ||||||
924 | # force exec to use an indirect object, | ||||||
925 | # so that evil shell stuff will die, even | ||||||
926 | # for a program with no arguments | ||||||
927 | 0 | 0 | exec { $progname } @prog_and_args or die "$progname failed: $!\n"; | ||||
0 | |||||||
928 | # NOTREACHED | ||||||
929 | } | ||||||
930 | 0 | return $result; | |||||
931 | } # safe_backtick | ||||||
932 | |||||||
933 | =head2 format_items | ||||||
934 | |||||||
935 | {&format_items(fieldname,value,delim,outdelim,format,prefix,suffix)} | ||||||
936 | |||||||
937 | Format a field made of multiple items. | ||||||
938 | |||||||
939 | =cut | ||||||
940 | sub format_items { | ||||||
941 | 0 | 0 | 1 | my $fieldname = shift; | |||
942 | 0 | my $value = shift; | |||||
943 | 0 | my @args = @_; | |||||
944 | |||||||
945 | # if they didn't give us anything, return | ||||||
946 | 0 | 0 | if (!$fieldname) | ||||
947 | { | ||||||
948 | 0 | return ''; | |||||
949 | } | ||||||
950 | 0 | 0 | if (!$value) | ||||
951 | { | ||||||
952 | 0 | return ''; | |||||
953 | } | ||||||
954 | |||||||
955 | 0 | 0 | my $delim = $args[0] || '|'; | ||||
956 | 0 | 0 | my $outdelim = $args[1] || ' '; | ||||
957 | 0 | 0 | my $format = $args[2] || 'raw'; | ||||
958 | 0 | 0 | my $prefix = $args[3] || ''; | ||||
959 | 0 | 0 | my $suffix = $args[4] || ''; | ||||
960 | 0 | $delim =~ s/comma/,/g; | |||||
961 | 0 | $delim =~ s/pipe/|/g; | |||||
962 | 0 | $delim =~ s!slash!/!g; | |||||
963 | 0 | $outdelim =~ s/comma/,/g; | |||||
964 | 0 | $outdelim =~ s/pipe/|/g; | |||||
965 | 0 | $outdelim =~ s!slash!/!g; | |||||
966 | 0 | my @items = split(/\Q$delim\E\s*/, $value); | |||||
967 | 0 | my @next_items = (); | |||||
968 | 0 | foreach my $item (@items) | |||||
969 | { | ||||||
970 | 0 | push @next_items, | |||||
971 | Text::NeatTemplate->convert_value(name=>$fieldname, | ||||||
972 | value=>$item, | ||||||
973 | format=>$format); | ||||||
974 | } | ||||||
975 | 0 | return $prefix . join($outdelim, @next_items) . $suffix; | |||||
976 | } # format_items | ||||||
977 | |||||||
978 | |||||||
979 | =head1 REQUIRES | ||||||
980 | |||||||
981 | Test::More | ||||||
982 | |||||||
983 | =head1 INSTALLATION | ||||||
984 | |||||||
985 | To install this module, run the following commands: | ||||||
986 | |||||||
987 | perl Build.PL | ||||||
988 | ./Build | ||||||
989 | ./Build test | ||||||
990 | ./Build install | ||||||
991 | |||||||
992 | Or, if you're on a platform (like DOS or Windows) that doesn't like the | ||||||
993 | "./" notation, you can do this: | ||||||
994 | |||||||
995 | perl Build.PL | ||||||
996 | perl Build | ||||||
997 | perl Build test | ||||||
998 | perl Build install | ||||||
999 | |||||||
1000 | In order to install somewhere other than the default, such as | ||||||
1001 | in a directory under your home directory, like "/home/fred/perl" | ||||||
1002 | go | ||||||
1003 | |||||||
1004 | perl Build.PL --install_base /home/fred/perl | ||||||
1005 | |||||||
1006 | as the first step instead. | ||||||
1007 | |||||||
1008 | This will install the files underneath /home/fred/perl. | ||||||
1009 | |||||||
1010 | You will then need to make sure that you alter the PERL5LIB variable to | ||||||
1011 | find the module. | ||||||
1012 | |||||||
1013 | Therefore you will need to change the PERL5LIB variable to add | ||||||
1014 | /home/fred/perl/lib | ||||||
1015 | |||||||
1016 | PERL5LIB=/home/fred/perl/lib:${PERL5LIB} | ||||||
1017 | |||||||
1018 | =head1 SEE ALSO | ||||||
1019 | |||||||
1020 | L |
||||||
1021 | L |
||||||
1022 | L |
||||||
1023 | L |
||||||
1024 | L |
||||||
1025 | L |
||||||
1026 | |||||||
1027 | =head1 BUGS | ||||||
1028 | |||||||
1029 | Please report any bugs or feature requests to the author. | ||||||
1030 | |||||||
1031 | =head1 AUTHOR | ||||||
1032 | |||||||
1033 | Kathryn Andersen (RUBYKAT) | ||||||
1034 | perlkat AT katspace dot com | ||||||
1035 | http://www.katspace.org/tools | ||||||
1036 | |||||||
1037 | =head1 COPYRIGHT AND LICENCE | ||||||
1038 | |||||||
1039 | Copyright (c) 2006 by Kathryn Andersen | ||||||
1040 | |||||||
1041 | This program is free software; you can redistribute it and/or modify it | ||||||
1042 | under the same terms as Perl itself. | ||||||
1043 | |||||||
1044 | =cut | ||||||
1045 | |||||||
1046 | 1; # End of Text::NeatTemplate | ||||||
1047 | __END__ |