File Coverage

blib/lib/Text/NeatTemplate.pm
Criterion Covered Total %
statement 9 318 2.8
branch 0 182 0.0
condition 0 30 0.0
subroutine 3 13 23.0
pod 10 10 100.0
total 22 553 3.9


line stmt bran cond sub pod time code
1             package Text::NeatTemplate;
2             $Text::NeatTemplate::VERSION = '0.1600';
3 1     1   68811 use strict;
  1         13  
  1         29  
4 1     1   5 use warnings;
  1         2  
  1         1473  
5              
6             =head1 NAME
7              
8             Text::NeatTemplate - a fast, middleweight template engine.
9              
10             =head1 VERSION
11              
12             version 0.1600
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. Both
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. I consider the trade-off worth it,
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 variable formatted as a dollar value.
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 camelise
188              
189             Convert the value into CamelCase.
190              
191             =item comma_front
192              
193             Put anything after the last comma at the front (as with an author name)
194             For example, "Smith,Sarah Jane" becomes "Sarah Jane Smith".
195              
196             =item date_day
197              
198             Return the day part of a YYYY-MM-DD date.
199              
200             =item date_mth
201              
202             Return the month part of a YYYY-MM-DD date.
203              
204             =item date_month
205              
206             Return the month part of a YYYY-MM-DD date as an English month name.
207              
208             =item date_year
209              
210             Return the year part of a YYYY-MM-DD date.
211              
212             =item dollars
213              
214             Return as a dollar value (float of precision 2)
215              
216             =item email
217              
218             Convert to a HTML mailto link.
219              
220             =item float
221              
222             Convert to float.
223              
224             =item facettag
225              
226             Convert to a "faceted" tag, that is, the words are joined by a colon.
227              
228             =item hmail
229              
230             Convert to a "humanized" version of the email, with the @ and '.'
231             replaced with "at" and "dot". This is useful to prevent spambots
232             harvesting email addresses.
233              
234             =item html
235              
236             Convert to simple HTML (simple formatting)
237              
238             =item int
239              
240             Convert to integer
241              
242             =item itemI
243              
244             Assume that the value is multiple values separated by the "pipe" symbol (|) and
245             select the item with an index of I (starting at zero)
246              
247             =item items_I
248              
249             Assume that the value is multiple values separated by the "pipe" symbol (|) and
250             split the values into an array, apply the I directive to them, and
251             join them together with a space.
252              
253             =item itemsjslash_I
254              
255             Like items_I, but the results are joined together with a slash between them.
256              
257             =item itemslashI
258              
259             Assume that the value is multiple values separated by the "slash" symbol (/) and
260             select the item with an index of I (starting at zero)
261             Good for selecting out components of pathnames.
262              
263             =item lower
264              
265             Convert to lower case.
266              
267             =item month
268              
269             Convert the number value to an English month name.
270              
271             =item namedalpha
272              
273             Similar to 'alpha', but prepends the 'name' of the value.
274             Assumes that the name is only alphanumeric.
275              
276             =item nth
277              
278             Convert the number value to a N-th value. Numbers ending with 1 have 'st'
279             appended, 2 have 'nd' appended, 3 have 'rd' appended, and everything
280             else has 'th' appended.
281              
282             =item percent
283              
284             Show as if the value is a percentage.
285              
286             =item pipetocomma
287              
288             Assume that the value is multiple values separated by the "pipe" symbol (|) and replace
289             those with a comma and space.
290              
291             =item pipetoslash
292              
293             Assume that the value is multiple values separated by the "pipe" symbol (|) and replace
294             those with a forward slash (/).
295              
296             =item proper
297              
298             Convert to a Proper Noun.
299              
300             =item string
301              
302             Return the value with no change.
303              
304             =item span
305              
306             Surround the value with HTML span tags. (Useful for CSS formatting.)
307              
308             =item tagify
309              
310             Converts the value into something suitable to use as a tag.
311             Replace pipe with comma, remove leading and trailing spaces,
312             remove hyphens and underscores,
313             replace slashes, ! and spaces with underscores.
314              
315             =item title
316              
317             Put any trailing ",The" ",A" or ",An" at the front (as this is a title)
318              
319             =item truncateI
320              
321             Truncate to I length.
322              
323             =item upper
324              
325             Convert to upper case.
326              
327             =item url
328              
329             Convert to a HTML href link.
330              
331             =item wikilink
332              
333             Format the value as the most common kind of wikilink, that is [[I]]
334              
335             =item wlink_I
336              
337             Format the value as the most common kind of wikilink with a prefix;
338             that is [[I/I]]
339              
340             =item wordsI
341              
342             Give the first I words of the value.
343              
344             =back
345              
346             =cut
347              
348              
349             =head1 CLASS METHODS
350              
351             =head2 new
352              
353             my $tobj = Text::NeatTemplate->new();
354              
355             Make a new template object.
356              
357             =cut
358              
359             sub new {
360 0     0 1   my $class = shift;
361 0           my %parameters = @_;
362 0   0       my $self = bless ({%parameters}, ref ($class) || $class);
363              
364 0           return ($self);
365             } # new
366              
367              
368             =head1 METHODS
369              
370             =head2 fill_in
371              
372             Fill in the given values.
373              
374             $result = $tobj->fill_in(data_hash=>\%data,
375             show_names=>\%names,
376             template=>$text);
377              
378             The 'data_hash' is a hash containing names and values.
379              
380             The 'show_names' is a hash saying which of these "variable names"
381             ought to be displayed, and which suppressed. This can be useful
382             if you want to use a more generic template, and then dynamically
383             suppress certain values at runtime.
384              
385             The 'template' is the text of the template.
386              
387             =cut
388             sub fill_in {
389 0     0 1   my $self = shift;
390 0           my %args = (
391             data_hash=>undef,
392             show_names=>undef,
393             template=>undef,
394             @_
395             );
396              
397 0           my $out = $args{template};
398 0           $out =~ s/{([^}]+)}/$self->do_replace(data_hash=>$args{data_hash},show_names=>$args{show_names},targ=>$1)/eg;
  0            
399              
400 0           return $out;
401             } # fill_in
402              
403             =head2 get_varnames
404              
405             Find variable names inside the given template.
406              
407             @varnames = $tobj->get_varnames(template=>$text);
408              
409             =cut
410             sub get_varnames {
411 0     0 1   my $self = shift;
412 0           my %args = (
413             template=>undef,
414             @_
415             );
416 0           my $template = $args{template};
417              
418 0 0         return '' if (!$template);
419              
420 0           my %varnames = ();
421             # { (the regex below needs matching)
422 0           while ($template =~ m/{([^}]+)}/g)
423             {
424 0           my $targ = $1;
425              
426 0 0         if ($targ =~ /^\$(\w+[-:\w]*)$/)
    0          
    0          
    0          
427             {
428 0           my $val_id = $1;
429 0           $varnames{$val_id} = 1;
430             }
431             elsif ($targ =~ /^\?([-\w]+)\s(.*)!!(.*)$/)
432             {
433 0           my $val_id = $1;
434 0           my $yes_t = $2;
435 0           my $no_t = $3;
436              
437 0           $varnames{$val_id} = 1;
438              
439 0           foreach my $substr ($yes_t, $no_t)
440             {
441 0           while ($substr =~ /\[(\$[^\]]+)\]/)
442             {
443 0           $varnames{$1} = 1;
444             }
445             }
446             }
447             elsif ($targ =~ /^\?([-\w]+)\s(.*)$/)
448             {
449 0           my $val_id = $1;
450 0           my $yes_t = $2;
451              
452 0           $varnames{$val_id} = 1;
453 0           while ($yes_t =~ /\[(\$[^\]]+)\]/)
454             {
455 0           $varnames{$1} = 1;
456             }
457             }
458             elsif ($targ =~ /^\&([-\w:]+)\((.*)\)$/)
459             {
460             # function
461 0           my $func_name = $1;
462 0           my $fargs = $2;
463 0           while ($fargs =~ /\[(\$[^\]]+)\]/)
464             {
465 0           $varnames{$1} = 1;
466             }
467             }
468             }
469 0           return sort keys %varnames;
470             } # get_varnames
471              
472             =head2 do_replace
473              
474             Replace the given value.
475              
476             $val = $tobj->do_replace(targ=>$targ,
477             data_hash=>$data_hashref,
478             show_names=>\%show_names);
479              
480             Where 'targ' is the target value, which is either a variable target,
481             or a conditional target.
482              
483             The 'data_hash' is a hash containing names and values.
484              
485             The 'show_names' is a hash saying which of these "variable names"
486             ought to be displayed, and which suppressed.
487              
488             This can do templating by using the exec ability of substitution, for
489             example:
490              
491             $out =~ s/{([^}]+)}/$tobj->do_replace(data_hash=>$data_hash,targ=>$1)/eg;
492              
493             =cut
494             sub do_replace {
495 0     0 1   my $self = shift;
496 0           my %args = (
497             targ=>'',
498             data_hash=>undef,
499             show_names=>undef,
500             @_
501             );
502 0           my $targ = $args{targ};
503              
504 0 0         return '' if (!$targ);
505 0 0         if ($targ =~ /^\$(\w+[-:\w]*)$/)
    0          
    0          
    0          
506             {
507             my $val = $self->get_value(val_id=>$1,
508             data_hash=>$args{data_hash},
509 0           show_names=>$args{show_names});
510 0 0         if (defined $val)
511             {
512 0           return $val;
513             }
514             else # not a variable -- return nothing
515             {
516 0           return '';
517             }
518             }
519             elsif ($targ =~ /^\?([-\w]+)\s(.*)!!(.*)$/)
520             {
521 0           my $val_id = $1;
522 0           my $yes_t = $2;
523 0           my $no_t = $3;
524             my $val = $self->get_value(val_id=>$val_id,
525             data_hash=>$args{data_hash},
526 0           show_names=>$args{show_names});
527 0 0         if ($val)
528             {
529 0           $yes_t =~ s/\[(\$[^\]]+)\]/$self->do_replace(data_hash=>$args{data_hash},show_names=>$args{show_names},targ=>$1)/eg;
  0            
530 0           return $yes_t;
531             }
532             else # no value, return alternative
533             {
534 0           $no_t =~ s/\[(\$[^\]]+)\]/$self->do_replace(data_hash=>$args{data_hash},show_names=>$args{show_names},targ=>$1)/eg;
  0            
535 0           return $no_t;
536             }
537             }
538             elsif ($targ =~ /^\?([-\w]+)\s(.*)$/)
539             {
540 0           my $val_id = $1;
541 0           my $yes_t = $2;
542             my $val = $self->get_value(val_id=>$val_id,
543             data_hash=>$args{data_hash},
544 0           show_names=>$args{show_names});
545 0 0         if ($val)
546             {
547 0           $yes_t =~ s/\[(\$[^\]]+)\]/$self->do_replace(data_hash=>$args{data_hash},show_names=>$args{show_names},targ=>$1)/eg;
  0            
548 0           return $yes_t;
549             }
550             else # no value, return nothing
551             {
552 0           return '';
553             }
554             }
555             elsif ($targ =~ /^\&([-\w:]+)\((.*)\)$/)
556             {
557             # function
558 0           my $func_name = $1;
559 0           my $fargs = $2;
560             # split the args first, and replace each one separately
561             # just in case the data values have commas
562 0           my @fargs = split(/,/,$fargs);
563 0           my @processed = ();
564 0           foreach my $fa (@fargs)
565             {
566 0           $fa =~ s/\[(\$[^\]]+)\]/$self->do_replace(data_hash=>$args{data_hash},show_names=>$args{show_names},targ=>$1)/eg;
  0            
567 0           push @processed, $fa;
568             }
569             {
570 1     1   8 no strict('refs');
  1         2  
  1         3349  
  0            
571 0           return &{$func_name}(@processed);
  0            
572             }
573             }
574             else
575             {
576 0           print STDERR "UNKNOWN ==$targ==\n";
577             }
578 0           return '';
579             } # do_replace
580              
581             =head2 get_value
582              
583             $val = $tobj->get_value(val_id=>$val_id,
584             data_hash=>$data_hashref,
585             show_names=>\%show_names);
586              
587             Get and format the given value.
588              
589             =cut
590             sub get_value {
591 0     0 1   my $self = shift;
592 0           my %args = (
593             val_id=>'',
594             data_hash=>undef,
595             show_names=>undef,
596             @_
597             );
598 0           my ($varname, @formats) = split(':', $args{val_id});
599              
600 0           my $value;
601 0 0         if (exists $args{data_hash}->{$varname})
602             {
603 0 0 0       if (!$args{show_names}
604             or $args{show_names}->{$varname})
605             {
606 0           $value = $args{data_hash}->{$varname};
607             }
608             else
609             {
610 0           return '';
611             }
612             }
613             else
614             {
615 0           return undef;
616             }
617              
618             # we have a value to format
619 0           foreach my $format (@formats) {
620 0           $value = $self->convert_value(value=>$value,
621             format=>$format,
622             name=>$varname);
623             }
624 0 0 0       if ($value and $self->{escape_html})
625             {
626             # filter out some HTML stuff
627 0           $value =~ s/ & / & /g;
628             }
629 0           return $value;
630             } # get_value
631              
632             =head2 convert_value
633              
634             my $val = $tobj->convert_value(value=>$val,
635             format=>$format,
636             name=>$name);
637              
638             Convert a value according to the given formatting directive.
639              
640             See L for details of all the formatting directives.
641              
642              
643             =cut
644             sub convert_value {
645 0     0 1   my $self = shift;
646 0           my %args = @_;
647 0           my $value = $args{value};
648 0           my $style = $args{format};
649 0           my $name = $args{name};
650              
651 0   0       $value ||= '';
652 0 0         ($_=$style) || ($_ = 'string');
653             SWITCH: {
654 0 0         /^upper/i && (return uc($value));
  0            
655 0 0         /^lower/i && (return lc($value));
656 0 0         /^int/i && (return (defined $value ? int($value) : 0));
    0          
657 0 0 0       /^float/i && (return (defined $value && sprintf('%f',($value || 0))) || '');
658 0 0         /^string/i && (return $value);
659 0 0 0       /^trunc(?:ate)?(\d+)/ && (return substr(($value||''), 0, $1));
660 0 0 0       /^dollars/i &&
661             (return (defined $value && length($value)
662             && sprintf('%.2f',($value || 0)) || ''));
663 0 0 0       /^percent/i &&
664             (return (($value<0.2) &&
665             sprintf('%.1f%%',($value*100))
666             || sprintf('%d%%',int($value*100))));
667 0 0         /^url/i && (return "$value");
668 0 0         /^wikilink/i && (return "[[$value]]");
669 0 0         /^span/i && (return "$value");
670 0 0         /^email/i && (return "$value");
671 0 0         /^hmail/i && do {
672 0           $value =~ s/@/ at /;
673 0           $value =~ s/\./ dot /g;
674 0           return $value;
675             };
676 0 0         /^html/i && (return $self->simple_html($value));
677 0 0         /^title/i && do {
678 0           $value =~ s/(.*)[,;]\s*(A|An|The)$/$2 $1/;
679 0           return $value;
680             };
681 0 0         /^comma_front/i && do {
682 0           $value =~ s/(.*)[,]([^,]+)$/$2 $1/;
683 0           return $value;
684             };
685 0 0         /^proper/i && do {
686 0           $value =~ s/(^w|\b\w)/uc($1)/eg;
  0            
687 0           return $value;
688             };
689             # YYYY-MM-DD dates
690 0 0         /^date_year/i && do {
691 0 0         return $value if !$value;
692 0           $value =~ s/^([0-9]+)-.*/$1/;
693 0           return $value;
694             };
695 0 0         /^date_mth/i && do {
696 0 0         return $value if !$value;
697 0           $value =~ s/^([0-9]+)-([0-9]+)-([0-9]+)/$2/;
698 0           return $value;
699             };
700 0 0         /^date_day/i && do {
701 0 0         return $value if !$value;
702 0           $value =~ s/^([0-9]+)-([0-9]+)-([0-9]+)/$3/;
703 0           return $value;
704             };
705 0 0         /^date_month/i && do {
706 0 0         return $value if !$value;
707 0 0         if ($value =~ /^([0-9]+)-([0-9]+)-([0-9]+)/)
708             {
709 0           my $mth = $2;
710 0           $value = $self->number_to_month($mth);
711             }
712 0           return $value;
713             };
714 0 0         /^month/i && do {
715 0           return $self->number_to_month($value);
716             };
717 0 0         /^nth/i && do {
718 0 0         return $value if !$value;
719 0 0         return ($value =~ /1[123]$/
    0          
    0          
    0          
720             ? "${value}th"
721             : ($value =~ /1$/
722             ? "${value}st"
723             : ($value =~ /2$/
724             ? "${value}nd"
725             : ($value =~ /3$/
726             ? "${value}rd"
727             : "${value}th"
728             )
729             )
730             )
731             );
732             };
733 0 0         /^facettag/i && do {
734 0           $value =~ s!/! !g;
735 0           $value =~ s/^\s+//;
736 0           $value =~ s/\s+$//;
737 0           $value =~ s/[^\w\s:_-]//g;
738 0           $value =~ s/\s\s+/ /g;
739 0           $value =~ s/ /_/g;
740 0           $value = join(':', $name, $value);
741 0           return $value;
742             };
743 0 0         /^namedalpha/i && do {
744 0           $value =~ s/[^a-zA-Z0-9]//g;
745 0           $value = join('_', $name, $value);
746 0           return $value;
747             };
748 0 0         /^alphadash/i && do {
749 0           $value =~ s!/! !g;
750 0           $value =~ s/[^a-zA-Z0-9_\s-]//g;
751 0           $value =~ s/^\s+//;
752 0           $value =~ s/\s+$//;
753 0           $value =~ s/\s\s+/ /g;
754 0           $value =~ s/ /_/g;
755 0           return $value;
756             };
757 0 0         /^alphahyphen/i && do {
758 0           $value =~ s!/! !g;
759 0           $value =~ s/[^a-zA-Z0-9_\s-]//g;
760 0           $value =~ s/^\s+//;
761 0           $value =~ s/\s+$//;
762 0           $value =~ s/\s\s+/ /g;
763 0           $value =~ s/ /-/g;
764 0           return $value;
765             };
766 0 0         /^alphahash/i && do {
767 0           $value =~ s/[^a-zA-Z0-9]//g;
768 0           $value = "#${value}";
769 0           return $value;
770             };
771 0 0         /^alpha/i && do {
772 0           $value =~ s/[^a-zA-Z0-9]//g;
773 0           return $value;
774             };
775 0 0         /^pipetocomma/i && do {
776 0           $value =~ s/\|/, /g;
777 0           return $value;
778             };
779 0 0         /^pipetoslash/i && do {
780 0           $value =~ s/\|/\//g;
781 0           return $value;
782             };
783 0 0         /^words(\d+)/ && do {
784 0           my $ct = $1;
785 0 0         ($ct>0) || return '';
786 0           my @sentence = split(/\s+/, $value);
787 0           my (@words) = splice(@sentence,0,$ct);
788 0           return join(' ', @words);
789             };
790 0 0         /^wlink_(\w+)/ && do {
791 0           my $prefix = $1;
792 0           return "[[$prefix/$value]]";
793             };
794 0 0         /^tagify/i && do {
795 0           $value =~ s/\|/,/g;
796 0           $value =~ s!/! !g;
797 0           $value =~ s/!/ /g;
798 0           $value =~ s/^\s+//;
799 0           $value =~ s/\s+$//;
800 0           $value =~ s/[^\w,\s_-]//g;
801 0           $value =~ s/\s\s+/ /g;
802 0           $value =~ s/ /_/g;
803 0           return $value;
804             };
805 0 0         /^camelise/i && do {
806             $value = join('',
807 0           map{ ucfirst $_ }
  0            
808             split(/(?<=[A-Za-z0-9+])[-_\s](?=[A-Za-z0-9'+])/,
809             $value));
810 0           return $value;
811             };
812 0 0         /^item(\d+)/ && do {
813 0           my $ct = $1;
814 0 0         ($ct>=0) || return '';
815 0           my @items = split(/\|/, $value);
816 0           return $items[$ct];
817             };
818 0 0         /^itemslash(\d+)/ && do {
819 0           my $ct = $1;
820 0 0         ($ct>=0) || return '';
821 0           my @items = split(/\//, $value);
822 0           return $items[$ct];
823             };
824 0 0         /^items_(\w+)/ && do {
825 0           my $next = $1;
826 0           my @items = split(/[\|,]\s*/, $value);
827 0           my @next_items = ();
828 0           foreach my $item (@items)
829             {
830 0           push @next_items, $self->convert_value(%args, value=>$item, format=>$next);
831             }
832 0           return join(' ', @next_items);
833             };
834 0 0         /^itemss_(\w+)/ && do {
835 0           my $next = $1;
836 0           my @formats = split('_', $next);
837 0           my @items = split(/[\|,]\s*/, $value);
838 0           my @fmt_items = ();
839 0           foreach my $item (@items)
840             {
841 0           foreach my $fmt (@formats)
842             {
843 0           $item = $self->convert_value(%args, value=>$item, format=>$fmt);
844             }
845 0           push @fmt_items, $item;
846             }
847 0           return join(' ', @fmt_items);
848             };
849 0 0         /^itemsjslash_(\w+)/ && do {
850 0           my $next = $1;
851 0           my @items = split(/[\|,]\s*/, $value);
852 0           my @next_items = ();
853 0           foreach my $item (@items)
854             {
855 0           push @next_items, $self->convert_value(%args, value=>$item, format=>$next);
856             }
857 0           return join(' / ', @next_items);
858             };
859 0 0         /^itemsjcomma_(\w+)/ && do {
860 0           my $next = $1;
861 0           my @items = split(/[\|,]\s*/, $value);
862 0           my @next_items = ();
863 0           foreach my $item (@items)
864             {
865 0           push @next_items, $self->convert_value(%args, value=>$item, format=>$next);
866             }
867 0           return join(',', @next_items);
868             };
869              
870             # otherwise, give up
871 0           return " {{{ style $style not supported }}} ";
872             }
873             } # convert_value
874              
875             =head2 simple_html
876              
877             $val = $tobj->simple_html($val);
878              
879             Do a simple HTML conversion of the value.
880             bold, italic,
881              
882             =cut
883             sub simple_html {
884 0     0 1   my $self = shift;
885 0           my $value = shift;
886              
887 0           $value =~ s#\n[\s][\s][\s]+#
\n    #sg;
888 0           $value =~ s#\s*\n\s*\n#

\n#sg;
889 0           $value =~ s#\*([^*]+)\*#$1#sg;
890 0           $value =~ s/\^([^^]+)\^/$1<\/b>/sg;
891 0           $value =~ s/\#([^#<>]+)\#/$1<\/b>/sg;
892 0           $value =~ s/\s&\s/ & /sg;
893 0           return $value;
894             } # simple_html
895              
896             =head2 number_to_month
897              
898             $val = $tobj->number_to_month($val);
899              
900             Give the month name for this month-number.
901              
902             =cut
903             sub number_to_month {
904 0     0 1   my $self = shift;
905 0           my $value = shift;
906              
907 0 0         return $value if !$value;
908 0 0         return ($value == 1
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
909             ? 'January'
910             : ($value == 2
911             ? 'February'
912             : ($value == 3
913             ? 'March'
914             : ($value == 4
915             ? 'April'
916             : ($value == 5
917             ? 'May'
918             : ($value == 6
919             ? 'June'
920             : ($value == 7
921             ? 'July'
922             : ($value == 8
923             ? 'August'
924             : ($value == 9
925             ? 'September'
926             : ($value == 10
927             ? 'October'
928             : ($value == 11
929             ? 'November'
930             : ($value == 12
931             ? 'December'
932             : $value
933             )
934             )
935             )
936             )
937             )
938             )
939             )
940             )
941             )
942             )
943             )
944             );
945             # fallthrough
946 0           return $value;
947             } # number_to_month
948              
949             =head1 Callable Functions
950              
951             =head2 safe_backtick
952              
953             {&safe_backtick(myprog,arg1,arg2...argN)}
954              
955             Return the results of a program, without risking evil shell calls.
956             This requires that the program and the arguments to that program
957             be given separately.
958              
959             =cut
960             sub safe_backtick {
961 0     0 1   my @prog_and_args = @_;
962 0           my $progname = $prog_and_args[0];
963              
964             # if they didn't give us anything, return
965 0 0         if (!$progname)
966             {
967 0           return '';
968             }
969             # call the program
970             # do a fork and exec with an open;
971             # this should preserve the environment and also be safe
972 0           my $result = '';
973 0           my $fh;
974 0           my $pid = open($fh, "-|");
975 0 0         if ($pid) # parent
976             {
977             {
978             # slurp up the result all at once
979 0           local $/ = undef;
  0            
980 0           $result = <$fh>;
981             }
982 0 0         close($fh) || warn "$progname program script exited $?";
983             }
984             else # child
985             {
986             # call the program
987             # force exec to use an indirect object,
988             # so that evil shell stuff will die, even
989             # for a program with no arguments
990 0 0         exec { $progname } @prog_and_args or die "$progname failed: $!\n";
  0            
991             # NOTREACHED
992             }
993 0           return $result;
994             } # safe_backtick
995              
996             =head2 format_items
997              
998             {&format_items(fieldname,value,delim,outdelim,format,prefix,suffix)}
999              
1000             Format a field made of multiple items.
1001              
1002             =cut
1003             sub format_items {
1004 0     0 1   my $fieldname = shift;
1005 0           my $value = shift;
1006 0           my @args = @_;
1007              
1008             # if they didn't give us anything, return
1009 0 0         if (!$fieldname)
1010             {
1011 0           return '';
1012             }
1013 0 0         if (!$value)
1014             {
1015 0           return '';
1016             }
1017              
1018 0   0       my $delim = $args[0] || '|';
1019 0   0       my $outdelim = $args[1] || ' ';
1020 0   0       my $format = $args[2] || 'raw';
1021 0   0       my $prefix = $args[3] || '';
1022 0   0       my $suffix = $args[4] || '';
1023 0           $delim =~ s/comma/,/g;
1024 0           $delim =~ s/pipe/|/g;
1025 0           $delim =~ s!slash!/!g;
1026 0           $outdelim =~ s/comma/,/g;
1027 0           $outdelim =~ s/pipe/|/g;
1028 0           $outdelim =~ s!slash!/!g;
1029 0           my @items = split(/\Q$delim\E\s*/, $value);
1030 0           my @next_items = ();
1031 0           foreach my $item (@items)
1032             {
1033 0           push @next_items,
1034             Text::NeatTemplate->convert_value(name=>$fieldname,
1035             value=>$item,
1036             format=>$format);
1037             }
1038 0           return $prefix . join($outdelim, @next_items) . $suffix;
1039             } # format_items
1040              
1041              
1042             =head1 REQUIRES
1043              
1044             Test::More
1045              
1046             =head1 INSTALLATION
1047              
1048             To install this module, run the following commands:
1049              
1050             perl Build.PL
1051             ./Build
1052             ./Build test
1053             ./Build install
1054              
1055             Or, if you're on a platform (like DOS or Windows) that doesn't like the
1056             "./" notation, you can do this:
1057              
1058             perl Build.PL
1059             perl Build
1060             perl Build test
1061             perl Build install
1062              
1063             In order to install somewhere other than the default, such as
1064             in a directory under your home directory, like "/home/fred/perl"
1065             go
1066              
1067             perl Build.PL --install_base /home/fred/perl
1068              
1069             as the first step instead.
1070              
1071             This will install the files underneath /home/fred/perl.
1072              
1073             You will then need to make sure that you alter the PERL5LIB variable to
1074             find the module.
1075              
1076             Therefore you will need to change the PERL5LIB variable to add
1077             /home/fred/perl/lib
1078              
1079             PERL5LIB=/home/fred/perl/lib:${PERL5LIB}
1080              
1081             =head1 SEE ALSO
1082              
1083             L
1084             L
1085             L
1086             L
1087             L
1088             L
1089              
1090             =head1 BUGS
1091              
1092             Please report any bugs or feature requests to the author.
1093              
1094             =head1 AUTHOR
1095              
1096             Kathryn Andersen (RUBYKAT)
1097             perlkat AT katspace dot com
1098             http://www.katspace.org/tools
1099              
1100             =head1 COPYRIGHT AND LICENCE
1101              
1102             Copyright (c) 2006 by Kathryn Andersen
1103              
1104             This program is free software; you can redistribute it and/or modify it
1105             under the same terms as Perl itself.
1106              
1107             =cut
1108              
1109             1; # End of Text::NeatTemplate
1110             __END__