blib/lib/Text/Merge.pm | |||
---|---|---|---|
Criterion | Covered | Total | % |
statement | 235 | 317 | 74.1 |
branch | 89 | 170 | 52.3 |
condition | 147 | 305 | 48.2 |
subroutine | 30 | 37 | 81.0 |
pod | 8 | 34 | 23.5 |
total | 509 | 863 | 58.9 |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | #!/usr/local/bin/perl -Tw | ||||||
2 | 20 | 20 | 9908 | use strict; | |||
20 | 35 | ||||||
20 | 2636 | ||||||
3 | |||||||
4 | # | ||||||
5 | # Text::Merge.pm - v.0.36 BETA | ||||||
6 | # | ||||||
7 | # (C)1997-2004 by Steven D. Harris. | ||||||
8 | # | ||||||
9 | # This software is released under the Perl Artistic License | ||||||
10 | # | ||||||
11 | |||||||
12 | =head1 NAME | ||||||
13 | |||||||
14 | Text::Merge - v.0.36 General purpose text/data merging methods in Perl. | ||||||
15 | |||||||
16 | =head1 SYNOPSIS | ||||||
17 | |||||||
18 | $merge = new Text::Merge; | ||||||
19 | |||||||
20 | $merge->line_by_line(); # query | ||||||
21 | $merge->line_by_line(0); # turn off | ||||||
22 | $merge->line_by_line(1); # turn on | ||||||
23 | |||||||
24 | $merge->set_delimiters('<<', '>>'); # user defined delims | ||||||
25 | |||||||
26 | $success = $merge->publish($template, \%data); | ||||||
27 | $success = $merge->publish($template, \%data, \%actions); | ||||||
28 | $success = $merge->publish($template, $item); | ||||||
29 | |||||||
30 | $success = $merge->publish_to($handle, $template, \%data); | ||||||
31 | $success = $merge->publish_to($handle, $template, \%data, \%actions); | ||||||
32 | $success = $merge->publish_to($handle, $template, $item); | ||||||
33 | |||||||
34 | $text = $merge->publish_text($template, \%data); | ||||||
35 | $text = $merge->publish_text($template, \%data, \%actions); | ||||||
36 | $text = $merge->publish_text($template, $item); | ||||||
37 | |||||||
38 | $success = $merge->publish_email($mailer, $headers, $template, \%data); | ||||||
39 | $success = $merge->publish_email($mailer, $headers, $template, | ||||||
40 | \%data, \%actions); | ||||||
41 | $success = $merge->publish_email($mailer, $headers, $template, $item); | ||||||
42 | |||||||
43 | $datahash = $merge->cgi2data(); # if you used "CGI(:standard)" | ||||||
44 | $datahash = $merge->cgi2data($cgi); # if you just used CGI.pm | ||||||
45 | |||||||
46 | |||||||
47 | =head1 DESCRIPTION | ||||||
48 | |||||||
49 | The C |
||||||
50 | templates and data structures. The C |
||||||
51 | constructed with text and that objects consist of data and functions that operate on that data. C |
||||||
52 | is very simple, in that it works on one file and one object at a time, although an extension exists to display | ||||||
53 | lists (C |
||||||
54 | |||||||
55 | This is not XML and is intended merely to "flatten" the learning curve for non-programmers who design display | ||||||
56 | pages for programmers or to provide programmers with a quick way of merging page templates with data sets or | ||||||
57 | objects without extensive research. | ||||||
58 | |||||||
59 | The templates can be interpreted "line by line" or taken as a whole. | ||||||
60 | |||||||
61 | |||||||
62 | =head2 Technical Details | ||||||
63 | |||||||
64 | This object is normally inherited and so the new() function is the constructor. It just blesses an | ||||||
65 | anonymous HASH reference, sets two flags within that HASH, and returns it. I'm am acutely aware | ||||||
66 | of the criticisms of the overuse of OOP (Object Oriented Programming). This module needs to be OO | ||||||
67 | because of its extensibility and encapsulation; I wanted to impose classification of the objects to allow | ||||||
68 | the greatest flexibility in context of implementation. C |
||||||
69 | can become integrated quickly into the httpd using mod_perl, hence the encapsulation and inheritance provided | ||||||
70 | by the Perl OO model clearly outweighed the constraints thereby imposed. That's my excuse...what's yours? | ||||||
71 | |||||||
72 | There are four public methods for the C |
||||||
73 | C |
||||||
74 | STDOUT). The second method, C |
||||||
75 | C |
||||||
76 | |||||||
77 | Support is provided to merge the data and the functions performed on that data with a text template that | ||||||
78 | contains substitution tag markup used to designate the action or data conversion. Data is stored in a HASH | ||||||
79 | that is passed by reference to the publishing methods. The keys of the data hash correspond to the field | ||||||
80 | names of the data, and they are associated with their respective values. Actions (methods) are similarly | ||||||
81 | referenced in a hash, keyed by the action name used in the template. | ||||||
82 | |||||||
83 | Here is a good example of a publishing call in Perl: | ||||||
84 | |||||||
85 | $obj = new Text::Merge; | ||||||
86 | %data = ( 'Name'=>'John Smith', 'Age'=>34, 'Sex'=>'not enough' ); | ||||||
87 | %actions = ( 'Mock' => \&mock_person, 'Laud' => \&laud_person ); | ||||||
88 | $obj->publish($template, \%data, \%actions); | ||||||
89 | |||||||
90 | In this example, C |
||||||
91 | the data set, as an argument. In this way you can create dynamic or complex composite components and reference | ||||||
92 | them with a single tag in the template. The actions HASH has been found to be useful for default constructs | ||||||
93 | that can be difficult to code manually, giving page designers an option to work with quickly. | ||||||
94 | |||||||
95 | |||||||
96 | =head2 Markup Tags | ||||||
97 | |||||||
98 | Simply put, tags are replaced with what they designate. A tag generally consists of a prefix, followed by a | ||||||
99 | colon, then either an action name or a field name followed by zero or more formatting directives seperated | ||||||
100 | by colons. In addition, blocks of output can be contained within curly brackets | ||||||
101 | in certain contexts for conditional display. | ||||||
102 | |||||||
103 | =over 4 | ||||||
104 | |||||||
105 | =item REF: tags | ||||||
106 | |||||||
107 | Simple data substitution is achieved with the C |
||||||
108 | in context, assume we have a key-value pair in our data HASH associating the key 'Animal' with the value of | ||||||
109 | 'turtle': | ||||||
110 | |||||||
111 | The quick brown REF:Animal jumped over the lazy dog. | ||||||
112 | |||||||
113 | when filtered, becomes: | ||||||
114 | |||||||
115 | The quick brown turtle jumped over the lazy dog. | ||||||
116 | |||||||
117 | The C |
||||||
118 | to right, and act to convert the data before it is displayed. For example: | ||||||
119 | |||||||
120 | REF:Animal:lower:trunc3 | ||||||
121 | |||||||
122 | would result in the first three letters of the SCALAR data value associated with Animal in lower case. See | ||||||
123 | the section, C, for a list of the available SCALAR data formatting directives. Note | ||||||
124 | that some conversions may be incompatible or contradictory. The system will not necessarily warn you of such | ||||||
125 | cases, so be forewarned. | ||||||
126 | |||||||
127 | Any C |
||||||
128 | merged response only if the result of the designator is not empty (has a length). There must be no spaces between | ||||||
129 | the tag and the curly braced text. If line-by-line mode is turned off, then the conditional text block may span | ||||||
130 | multiple lines. For example: | ||||||
131 | |||||||
132 | The {quick brown }REF:Animal{ jumps over where the }lazy dog lies. | ||||||
133 | |||||||
134 | Might result in: | ||||||
135 | |||||||
136 | The quick brown fox jumps over where the lazy dog lies. | ||||||
137 | |||||||
138 | or, if the value associated with the data key 'Animal' was undefined, empty, or zero: | ||||||
139 | |||||||
140 | The lazy dog lies. | ||||||
141 | |||||||
142 | |||||||
143 | =item IF: tags | ||||||
144 | |||||||
145 | The C |
||||||
146 | |||||||
147 | IF:FieldName:formats{Text to display} | ||||||
148 | |||||||
149 | This designator would result in the string B |
||||||
150 | not empty. The curly braced portion is required, and no curly braces are allowed before the designator. | ||||||
151 | |||||||
152 | |||||||
153 | =item NEG: tags | ||||||
154 | |||||||
155 | The C |
||||||
156 | formatted data value is empty (zero length) or zero. Effectively the C |
||||||
157 | Here is an example: | ||||||
158 | |||||||
159 | NEG:FieldName:formats{Text to display if the result is empty.} | ||||||
160 | |||||||
161 | |||||||
162 | =item ACT: tags | ||||||
163 | |||||||
164 | The C |
||||||
165 | substition. The key name specified in the designator is used to look up the reference to the appropriate | ||||||
166 | subroutine, and the data HASH reference is passed as the sole argument to that subroutine. The returned | ||||||
167 | value is the value used for the substition. | ||||||
168 | |||||||
169 | C |
||||||
170 | action key names and has no equivalent tags to C |
||||||
171 | tag are exactly the same as those for the C |
||||||
172 | |||||||
173 | |||||||
174 | =item Conditional Text Braces | ||||||
175 | |||||||
176 | All tags support conditional text surrounded by curly braces. If the C |
||||||
177 | the entire tag degignator must be on a single line of text, but if the switch is OFF (default) then the | ||||||
178 | conditional text can span multiple lines. | ||||||
179 | |||||||
180 | The two conditional tags, C |
||||||
181 | braces, immediately following (suffixing) the field name or format string. For example: | ||||||
182 | |||||||
183 | IF:SomeField{this text will print} | ||||||
184 | |||||||
185 | The C |
||||||
186 | (suffixing). For example: | ||||||
187 | |||||||
188 | {Some optional text }REF:SomeValue{ more text.} | ||||||
189 | |||||||
190 | |||||||
191 | =item Command Braces | ||||||
192 | |||||||
193 | You may bracket entire constructs (along with any conditional text) with double square brackets to set them | ||||||
194 | off from the rest of the document. The square brackets would be removed during substitution: | ||||||
195 | |||||||
196 | The [[IF:VerboseVar{quick, brown }]]fox jumped over the lazy dog. | ||||||
197 | |||||||
198 | assuming that 'VerboseVar' represented some data value, the above example would result in one of: | ||||||
199 | |||||||
200 | The quick, brown fox jumped over the lazy dog. | ||||||
201 | or | ||||||
202 | The fox jumped over the lazy dog. | ||||||
203 | |||||||
204 | |||||||
205 | =item Data Conversion Formats | ||||||
206 | |||||||
207 | Here is a list of the data conversion format and the a summary. Details are undetermined in some cases for | ||||||
208 | exceptions, but all of the conversion to some satisfactory degree. These conversion methods will treat all | ||||||
209 | values as SCALAR values: | ||||||
210 | |||||||
211 | upper - converts all lowercase letters to uppercase | ||||||
212 | lower - converts all uppercase letters to lower | ||||||
213 | proper - treats the string as a Proper Noun | ||||||
214 | trunc## - truncate the scalar to ## characters (## is an integer) | ||||||
215 | words## - reduce to ## words seperated by spaces (## is an integer) | ||||||
216 | paragraph## - converts to a paragraph ## columns wide | ||||||
217 | indent## - indents plain text ## spaces | ||||||
218 | int - converts the value to an integer | ||||||
219 | float - converts the value to a floating point value | ||||||
220 | string - converts the numeric value to a string (does nothing) | ||||||
221 | detab - replaces tabs with spaces, aligned to 8-char columns | ||||||
222 | html - replaces newlines with HTML B tags |
||||||
223 | dollars - converts the value to 2 decimal places | ||||||
224 | percent - converts the value to a percentage | ||||||
225 | abbr - converts a time value to m/d/yy format | ||||||
226 | short - converts a time value to m/d/yy H:MMpm format | ||||||
227 | time - converts a time value to H:MMpm (localtime am/pm) | ||||||
228 | 24h - converts a time value to 24hour format (localtime) | ||||||
229 | dateonly - converts a time value to Jan. 1, 1999 format | ||||||
230 | date - same as 'dateonly' with 'time' | ||||||
231 | ext - converts a time value to extended format: | ||||||
232 | Monday, Januay 12th, 1999 at 12:20pm | ||||||
233 | unix - converts a time value to UNIX date string format | ||||||
234 | escape - performs a browser escape on the value ({) | ||||||
235 | unescape - performs a browser unescape (numeric only) | ||||||
236 | urlencode - performs a url encoding on the value (%3B) | ||||||
237 | urldecode - performs a url decoding (reverse of urlencode) | ||||||
238 | |||||||
239 | Most of the values are self-explanatory, however a few may need explanation: | ||||||
240 | |||||||
241 | The C |
||||||
242 | how many characters should be displayed, as in C |
||||||
243 | |||||||
244 | The C format just inserts a construct at every newline in the |
||||||
245 | string. This allows text to be displayed appropriately in some cases. | ||||||
246 | |||||||
247 | The C |
||||||
248 | of the string. This allows values to be displayed correctly on browsers in | ||||||
249 | most cases. If your data is not prefiltered, it is usually a good idea to | ||||||
250 | use B |
||||||
251 | a '$' value would be converted to '$'. | ||||||
252 | |||||||
253 | The C |
||||||
254 | does not operate on HTML mnemonic escapes, allowing special characters to | ||||||
255 | remain intact. This can be used to reverse escapes inherent in the use of | ||||||
256 | other packages. | ||||||
257 | |||||||
258 | The C |
||||||
259 | to url encoded format, converting special characters to their %xx equivalent, | ||||||
260 | or converting to the original code by decoding %xx characters respectively from | ||||||
261 | the url encoded value. | ||||||
262 | |||||||
263 | =back | ||||||
264 | |||||||
265 | |||||||
266 | =head2 Item Support | ||||||
267 | |||||||
268 | The publishing methods all require at the very least a template, a data set, and the action set; although | ||||||
269 | either the data set or the action set or both could be empty or null. You may also B |
||||||
270 | information into a single HASH (suitable for blessing as a class) with the key 'Data' associated with | ||||||
271 | the data HASH reference, and the key 'Actions' associated with the action HASH reference. A restatement of | ||||||
272 | a previous example might look like this: | ||||||
273 | |||||||
274 | $obj = new Text::Merge; | ||||||
275 | $data = { 'Name'=>'John Smith', 'Age'=>34, 'Sex'=>'not enough' }; | ||||||
276 | $actions = { 'Mock' => \&mock_person, 'Laud' => \&laud_person }; | ||||||
277 | $item = { 'Data' => $data, 'Actions' => $actions }; | ||||||
278 | $obj->publish($template, $item); | ||||||
279 | |||||||
280 | In addition, if you specify a key 'ItemType' in your C<$item> and give it a value, then the item reference | ||||||
281 | will be handed to any methods invoked by the C |
||||||
282 | you to construct B |
||||||
283 | |||||||
284 | %data = ( 'Author' => 'various', 'Title' => 'The Holy Bible' ); | ||||||
285 | %actions = ( 'Highlight' => \&highlight_item ); | ||||||
286 | $item = { 'ItemType'=>'book', 'Data'=>\%data, 'Actions'=>\%actions }; | ||||||
287 | bless $item, Some::Example::Class; | ||||||
288 | $obj->publish($template, $item); | ||||||
289 | |||||||
290 | In this last example, the designator C |
||||||
291 | as the only argument to the subroutine C |
||||||
292 | |||||||
293 | |||||||
294 | =head2 Line by Line Mode | ||||||
295 | |||||||
296 | By default, the publishing methods slurp in the entire template and process it as a text block. This | ||||||
297 | allows for multi-line conditional text blocks. However, in some cases the resulting output may be very | ||||||
298 | large, or you may want the output to be generated line by line for some other reason (such as unbuffered | ||||||
299 | output). This is accomplished through the C |
||||||
300 | which sets the current setting if specified or returns the current settingif not. Note that this has the | ||||||
301 | most notable impact on the C |
||||||
302 | are sent to a handle. If the line by line switch is set, then the C |
||||||
303 | by line, but will still return the entire merged document as a single text block (not line by line). | ||||||
304 | |||||||
305 | This is turned OFF by default. | ||||||
306 | |||||||
307 | |||||||
308 | =head2 Templates | ||||||
309 | |||||||
310 | Templates consist of text documents that contain special substitution designators as described previously. The | ||||||
311 | template arguments passed to the publishing functions can take one of three forms: | ||||||
312 | |||||||
313 | =over 4 | ||||||
314 | |||||||
315 | =item File Handle | ||||||
316 | |||||||
317 | This is a FileHandle object not a glob. You must use the C |
||||||
318 | for this type of template argument. Processing begins at the current file position and continues until the end of | ||||||
319 | file condition is reached. | ||||||
320 | |||||||
321 | =item File Path | ||||||
322 | |||||||
323 | If the argument is a scalar string with no whitespace, it is assumed to be a file path. The template at that | ||||||
324 | location will be used when merging the document. | ||||||
325 | |||||||
326 | =item Text Block | ||||||
327 | |||||||
328 | If the argument is a scalar string that contains whitespace, it is assumed to be the actual text template. | ||||||
329 | Substitution will be performed on a locally scoped copy of this argument. | ||||||
330 | |||||||
331 | Note that you should not use this type of template argument if your template is very large and you | ||||||
332 | are using line by line mode. In this case you should use a FileHandle or file path argument. | ||||||
333 | |||||||
334 | =back | ||||||
335 | |||||||
336 | =head2 Methods | ||||||
337 | |||||||
338 | =over 4 | ||||||
339 | |||||||
340 | =cut | ||||||
341 | |||||||
342 | package Text::Merge; | ||||||
343 | 20 | 20 | 19389 | use FileHandle; | |||
20 | 440625 | ||||||
20 | 130 | ||||||
344 | 20 | 20 | 41541 | use AutoLoader 'AUTOLOAD'; | |||
20 | 56891 | ||||||
20 | 129 | ||||||
345 | |||||||
346 | our $NAME = 'Text::Merge'; | ||||||
347 | our $VERSION = '0.36'; | ||||||
348 | |||||||
349 | our @mon = qw(Jan. Feb. Mar. Apr. May June July Aug. Sep. Oct. Nov. Dec.); | ||||||
350 | our @month = qw(January February March April May June July August September October November December); | ||||||
351 | our @weekday = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday); | ||||||
352 | our @hex = map { ($_<16) && '%0'.sprintf('%X',$_) || sprintf('%%%2X',$_) } ( 0..255 ); | ||||||
353 | |||||||
354 | 1; | ||||||
355 | |||||||
356 | |||||||
357 | =item new() | ||||||
358 | |||||||
359 | This method gives us a blessed hash reference, with the following attribute keys: | ||||||
360 | |||||||
361 | _Text_Merge_LineMode | ||||||
362 | |||||||
363 | Other keys can be added by objects which inherit C |
||||||
364 | |||||||
365 | =cut | ||||||
366 | sub new { | ||||||
367 | 19 | 19 | 1 | 56475 | my $class = shift; | ||
368 | 19 | 49 | my $ref = {}; | ||||
369 | 19 | 67 | $$ref{_Text_Merge_LineMode} = 0; | ||||
370 | 19 | 55 | $$ref{_Text_Merge_Delimiter1} = quotemeta('[['); | ||||
371 | 19 | 62 | $$ref{_Text_Merge_Delimiter2} = quotemeta(']]'); | ||||
372 | 19 | 86 | return bless $ref, $class; | ||||
373 | }; | ||||||
374 | |||||||
375 | |||||||
376 | =item line_by_line($setting) | ||||||
377 | |||||||
378 | This method returns the current setting if the C<$setting> argument is omitted. Otherwise it resets the | ||||||
379 | line-by-line mode to the setting requested. A non-zero value tells the publishing methods to process the | ||||||
380 | template line by line. For those methods that output results to a handle, then those results will also be | ||||||
381 | echoed line by line. | ||||||
382 | |||||||
383 | =cut | ||||||
384 | sub line_by_line { | ||||||
385 | 8 | 8 | 1 | 4024 | my ($self, $arg) = @_; | ||
386 | 8 | 50 | 77 | $$self{_Text_Merge_LineMode}=$arg if defined $arg; | |||
387 | 8 | 30 | return $$self{_Text_Merge_LineMode}; | ||||
388 | }; | ||||||
389 | |||||||
390 | |||||||
391 | =item set_delimiters($start, $end) | ||||||
392 | |||||||
393 | This method assigns a new command delimiter set for the tags (double | ||||||
394 | square brackets by default). The 'colon' character is not allowed within | ||||||
395 | the delimiter, and the delimiter may not be a single curly bracket. Both | ||||||
396 | the C<$start> and C<$end> delimiters must be provided, and they cannot be | ||||||
397 | identical. | ||||||
398 | |||||||
399 | =cut | ||||||
400 | sub set_delimiters { | ||||||
401 | 2 | 2 | 1 | 46838 | my ($self, $start, $end) = @_; | ||
402 | 2 | 50 | 33 | 87 | if (!defined $start || !defined $end || | ||
66 | |||||||
33 | |||||||
66 | |||||||
33 | |||||||
403 | ($start && !$end) || (!$start && $end)) { | ||||||
404 | 0 | 0 | warn "invalid delimiters provided to Text::Merge::set_delimiters().\n"; | ||||
405 | 0 | 0 | return 0; | ||||
406 | }; | ||||||
407 | 2 | 50 | 33 | 19 | if ($start =~ /\:/ || $end =~ /\:/) { | ||
408 | 0 | 0 | warn "The 'colon' character (:) is not allowed in Text::Merge delimiters.\n"; | ||||
409 | }; | ||||||
410 | 2 | 50 | 33 | 29 | if ($start =~ /^[\{\}]$/ || $end =~ /^[\{\}]$/) { | ||
411 | 0 | 0 | warn "Neither primary Text::Merge delimiter can be a curly bracket ({) or (}) in Text::Merge::set_delimiters().\n"; | ||||
412 | } | ||||||
413 | 2 | 50 | 66 | 13 | if ($start && !($start cmp $end)) { | ||
414 | 0 | 0 | warn "The start and end Text::Merge delmiters must differ in set_delimiters().\n"; | ||||
415 | }; | ||||||
416 | 2 | 19 | $$self{_Text_Merge_Delimiter1} = quotemeta($start); | ||||
417 | 2 | 7 | $$self{_Text_Merge_Delimiter2} = quotemeta($end); | ||||
418 | }; | ||||||
419 | |||||||
420 | |||||||
421 | # | ||||||
422 | # This is the core filtering engine. It consists of: | ||||||
423 | # text_process() - this method | ||||||
424 | # handle_cond() - for conditional text blocks | ||||||
425 | # convert_value() - for the formatting of values | ||||||
426 | # and assorted subordinate methods to convert_value() | ||||||
427 | # | ||||||
428 | sub text_process { | ||||||
429 | 402 | 402 | 0 | 15099 | my ($self, $text, $item) = @_; | ||
430 | 402 | 607 | my $ret = $text; | ||||
431 | 402 | 870 | my ($open, $close) = | ||||
432 | ($$self{_Text_Merge_Delimiter1},$$self{_Text_Merge_Delimiter2}); | ||||||
433 | 402 | 50 | 855 | defined $open || ($open = '\[\['); | |||
434 | 402 | 50 | 676 | defined $close || ($close = '\]\]'); | |||
435 | 402 | 50 | 795 | if (!$item) { warn "Improper call to text_process() in $0. no item.\n"; return $ret; }; | |||
0 | 0 | ||||||
0 | 0 | ||||||
436 | 402 | 50 | 687 | if (!$ret) { warn "Improper call to text_process() in $0. no text.\n"; return $ret; }; | |||
0 | 0 | ||||||
0 | 0 | ||||||
437 | 402 | 100 | 33 | 4888 | $ret && $ret =~ s/$open({(?:[^\{\}]*)\}(?:REF\:|ACT\:)|IF\:|NEG\:)(\w+(?:\:\w+)*)?\{((?:[^\}]|\}(?!$close))*)\}$close/$self-> | ||
317 | 66 | 903 | |||||
438 | handle_cond($1,$2,$3,$item)/eg if $open && $close; | ||||||
439 | 402 | 50 | 1428 | $ret && $ret =~ s/({(?:[^\{\}]*)\}(?:REF\:|ACT\:)|IF\:|NEG\:)(\w+(?:\:\w+)*)?\{([^\{\}]*)\}/$self-> | |||
365 | 870 | ||||||
440 | handle_cond($1,$2,$3,$item)/oeg; | ||||||
441 | 402 | 100 | 50 | 3232 | $ret && $ret =~ s/$open(REF|ACT)\:(\w+)((?:\:\w+)*)$close/$self->handle_tag($item,$1,$2,($3 || ''))/eg if $open && $close; | ||
109 | 33 | 582 | |||||
66 | |||||||
442 | 402 | 50 | 100 | 1556 | $ret && $ret =~ s/\b(REF|ACT)\:(\w+)((?:\:\w+)*)\b/$self->handle_tag($item,$1,$2,($3 || ''))/oeg; | ||
510 | 2609 | ||||||
443 | 402 | 2245 | return $ret; | ||||
444 | }; | ||||||
445 | |||||||
446 | |||||||
447 | sub handle_tag { | ||||||
448 | 1187 | 1187 | 0 | 2316 | my ($self, $item, $tag, $field, $formats) = @_; | ||
449 | 1187 | 100 | 3006 | if ($tag eq 'ACT') { | |||
450 | 114 | 237 | my $text = $self->handle_action($field, $item); | ||||
451 | 114 | 608 | return $text; | ||||
452 | }; | ||||||
453 | 1073 | 100 | 3037 | $formats && $formats =~ s/^\://g; | |||
454 | 1073 | 100 | 5645 | my @formats = split(/\:/, ($formats || '')); | |||
455 | 1073 | 1099 | my $format; | ||||
456 | 1073 | 100 | 4184 | my $value = $$item{Data}{$field} || ''; | |||
457 | 1073 | 100 | 100 | 3040 | $value=$$value[0] if ref $value eq 'ARRAY' && ((scalar @$value)==1); | ||
458 | 1073 | 1539 | foreach $format (@formats) { | ||||
459 | 380 | 921 | $value = $self->convert_value($value, $format, $item); | ||||
460 | }; | ||||||
461 | 1073 | 4817 | return $value; | ||||
462 | }; | ||||||
463 | |||||||
464 | sub handle_action { | ||||||
465 | 114 | 114 | 0 | 157 | my ($self, $field, $item) = @_; | ||
466 | 114 | 50 | 327 | my $sub = $$item{Actions}{$field} || return ''; | |||
467 | 114 | 66 | 515 | my $arg = $$item{ItemType} && $item || $$item{Data}; | |||
468 | 114 | 119 | my $result = &{$sub}($arg); | ||||
114 | 273 | ||||||
469 | 114 | 668 | return $result; | ||||
470 | }; | ||||||
471 | |||||||
472 | # args are: self, {prefix}TAG:, field+formats, suffix | ||||||
473 | sub handle_cond { | ||||||
474 | 682 | 682 | 0 | 2065 | my ($self, $pretag, $ident, $suffix, $item) = @_; | ||
475 | 682 | 1202 | my ($value,$prefix,$tag,$cond) = ('','','',''); | ||||
476 | 682 | 100 | 2217 | if ($pretag =~ /^\{(.*)\}(\w+\:)$/s) { $prefix=$1; $tag = $2; } | |||
234 | 960 | ||||||
234 | 1145 | ||||||
477 | 448 | 467 | else { $prefix = ''; $tag = $pretag; }; | ||||
448 | 518 | ||||||
478 | 682 | 100 | 1201 | if ($pretag !~ /ACT:/) { | |||
479 | 568 | 2122 | $value = $self->handle_tag($item, $tag, split(/\:/, $ident, 2)); | ||||
480 | } else { | ||||||
481 | 114 | 212 | my $func = $$item{Actions}{$ident}; | ||||
482 | 114 | 50 | 825 | $value = $func && &$func($$item{ItemType} && $item || $$item{Data}) || ''; | |||
483 | }; | ||||||
484 | 682 | 2097 | $cond = $value; | ||||
485 | 682 | 100 | 1877 | $tag eq 'NEG:' && ($cond = !$cond); | |||
486 | 682 | 100 | 100 | 2353 | ($tag eq 'NEG:' || $tag eq 'IF:') && ($value = ''); | ||
487 | 682 | 100 | 66 | 2669 | if ((defined $cond) && ($cond || length($cond))) { return $prefix.$value.$suffix; } | ||
458 | 33 | 3576 | |||||
488 | 224 | 1307 | else { return ''; }; | ||||
489 | }; | ||||||
490 | |||||||
491 | |||||||
492 | |||||||
493 | =item publish($template, $dataref, $actionref) | ||||||
494 | |||||||
495 | This is the normal publishing method. It merges the specified template with the data and | ||||||
496 | any provided actions. The output is sent to the currently selected handle, normally STDOUT. | ||||||
497 | |||||||
498 | =cut | ||||||
499 | |||||||
500 | 0 | 0 | 1 | 0 | sub publish { my ($self, @args)=@_; return $self->publish_to('',@args); }; | ||
0 | 0 | ||||||
501 | |||||||
502 | |||||||
503 | |||||||
504 | =item publish_to($handle, $template, $dataref, $actionref) | ||||||
505 | |||||||
506 | This is similar to the normal publishing method. It merges the specified template with the data | ||||||
507 | and any provided actions. The output is sent to the specified C<$handle> or to the currently | ||||||
508 | selected handle, normally STDOUT, if the C<$handle> argument is omitted. | ||||||
509 | |||||||
510 | =cut | ||||||
511 | |||||||
512 | sub publish_to { | ||||||
513 | 17 | 17 | 1 | 7220 | my ($self, $handle, $template, $data, $actions) = @_; | ||
514 | 17 | 37 | my ($fh,$line,$item); | ||||
515 | 17 | 100 | 66 | 298 | ($$data{Data} || $$data{Actions}) && ($item=$data) || ($item = { 'Data'=>$data, 'Actions'=>$actions }); | ||
66 | |||||||
516 | 17 | 50 | 66 | 547 | if (!$template) { | ||
100 | 33 | ||||||
50 | 66 | ||||||
517 | 0 | 0 | my ($pkg, $fname, $lineno, $sname) = caller; | ||||
518 | 0 | 0 | warn "No template provided to ".(ref $self)."->publish_to.\n"; | ||||
519 | 0 | 0 | warn "Called by $pkg\:\:$sname, line #$lineno in $fname.\n"; | ||||
520 | 0 | 0 | ($pkg, $fname, $lineno, $sname) = caller(1); | ||||
521 | 0 | 0 | warn "Called by $pkg\:\:$sname, line #$lineno in $fname.\n"; | ||||
522 | 0 | 0 | return 0; | ||||
523 | } elsif ($template =~ /\s/s) { | ||||||
524 | 3 | 50 | 11 | if ($handle) { | |||
525 | 3 | 18 | print $handle $self->text_process($template, $item); | ||||
526 | 0 | 0 | } else { print $self->text_process($template, $item); }; | ||||
527 | 3 | 23 | return 1; | ||||
528 | } elsif ((ref $template) =~ /FileHandle/ && ($fh=$template) | ||||||
529 | || (-f $template) && ($fh = new FileHandle('<'.$template))) { | ||||||
530 | 14 | 100 | 757 | if ($$self{_Text_Merge_LineMode}) { | |||
531 | 5 | 120 | foreach $_ (<$fh>) { | ||||
532 | 59 | 50 | 112 | if ($handle) { | |||
533 | 59 | 142 | print $handle $self->text_process($_, $item); | ||||
534 | 0 | 0 | } else { print $self->text_process($_, $item); }; | ||||
535 | }; | ||||||
536 | } else { | ||||||
537 | 9 | 50 | 630 | if ($handle) { | |||
538 | 9 | 50 | 755 | print $handle $self->text_process((join('',<$fh>) || ''), $item); | |||
539 | 0 | 0 | 0 | } else { print $self->text_process((join('',<$fh>) || ''), $item); }; | |||
540 | }; | ||||||
541 | 14 | 100 | 216 | ($template ne $fh) && $fh->close; | |||
542 | 14 | 265 | return 1; | ||||
543 | }; | ||||||
544 | 0 | 0 | 0 | if (length($template)>50) { $template = substr($template, -30, 30); }; | |||
0 | 0 | ||||||
545 | 0 | 0 | warn "Illegal template $template provided to ".(ref $self)."->filter.\n"; | ||||
546 | 0 | 0 | return 0; | ||||
547 | }; | ||||||
548 | |||||||
549 | |||||||
550 | |||||||
551 | =item publish_text($template, $dataref, $actionref) | ||||||
552 | |||||||
553 | This method works similar to the C |
||||||
554 | rather than sending it to the currently selected filehandle. | ||||||
555 | |||||||
556 | =cut | ||||||
557 | |||||||
558 | sub publish_text { | ||||||
559 | 81 | 81 | 1 | 370 | my ($self, $template, $data, $actions) = @_; | ||
560 | 81 | 108 | my $text = ''; | ||||
561 | 81 | 88 | my ($fh,$line,$item,$ref); | ||||
562 | 81 | 100 | 66 | 501 | ($$data{Data} || $$data{Actions}) && ($item=$data) || ($item = { 'Data'=>$data, 'Actions'=>$actions }); | ||
66 | |||||||
563 | 81 | 50 | 66 | 3323 | if (!$template) { | ||
100 | 66 | ||||||
50 | 33 | ||||||
33 | |||||||
33 | |||||||
33 | |||||||
564 | 0 | 0 | my ($pkg, $fname, $lineno, $sname) = caller; | ||||
565 | 0 | 0 | warn "No template provided to ".(ref $self)."->publish_text.\n"; | ||||
566 | 0 | 0 | warn "Called by $pkg\:\:$sname, line #$lineno in $fname.\n"; | ||||
567 | 0 | 0 | ($pkg, $fname, $lineno, $sname) = caller(1); | ||||
568 | 0 | 0 | warn "Called by $pkg\:\:$sname, line #$lineno in $fname.\n"; | ||||
569 | 0 | 0 | return 0; | ||||
570 | } elsif (($template=~/(?:(?:\r?\n)|\r)/) || (!($ref=ref($template)) && !(-f $template)) ) { | ||||||
571 | 18 | 41 | return $self->text_process($template, $item); | ||||
572 | } elsif ( $ref && $ref=~/FileHandle/ && ($fh=$template) || | ||||||
573 | (-f $template) && ($fh = new FileHandle($template))) { | ||||||
574 | 63 | 100 | 4539 | if ($$self{_Text_Merge_LineMode}) { | |||
575 | 62 | 1319 | foreach (<$fh>) { $text .= $self->text_process($_, $item); }; | ||||
152 | 415 | ||||||
576 | 1 | 50 | 74 | } else { $text = $self->text_process((join('',<$fh>) || ''), $item); }; | |||
577 | 63 | 50 | 341 | ($template ne $fh) && $fh->close; | |||
578 | 63 | 1163 | return $text; | ||||
579 | }; | ||||||
580 | 0 | 0 | warn "Invalid template $template provided to ".(ref $self)."->publish_text()\n"; | ||||
581 | 0 | 0 | return ''; | ||||
582 | }; | ||||||
583 | |||||||
584 | |||||||
585 | =item publish_email($mailer, $headers, $filepath, $data, $actions) | ||||||
586 | |||||||
587 | This method is similar to C |
||||||
588 | formatted as an e-mail message. C<$mailer> may contain the sequences C |
||||||
589 | If either does not exists, it will be echoed at the beginning of the email (in the form of a header), allowing | ||||||
590 | e-mail to be passed preformatted. This is the preferred method; use a mailer that can be told to | ||||||
591 | accept the "To:", "Subject:" and "Reply-To:" fields within the body of the passed message and do | ||||||
592 | not specify the C |
||||||
593 | true if succeeded. The recommended mail program is 'sendmail'. C<$headers> is a HASH reference, containing | ||||||
594 | the header information. Only the following header keys are recognized: | ||||||
595 | |||||||
596 | To | ||||||
597 | Subject | ||||||
598 | Reply-To | ||||||
599 | CC | ||||||
600 | From (works for privileged users only) | ||||||
601 | |||||||
602 | The values associated with these keys will be used to construct the desired e-mail message header. Secure | ||||||
603 | minded site administrators might put hooks in here, or even better clean the data, to protect access to | ||||||
604 | the system as a precaution, to avoid accidental mistakes perhaps. | ||||||
605 | |||||||
606 | Note: the C<$mailer> argument string should begin with the type of pipe required for your request. For | ||||||
607 | sendmail, this argument would look something like (note the vertical pipe): | ||||||
608 | |||||||
609 | '|/usr/bin/sendmail -t' | ||||||
610 | |||||||
611 | Be careful not to run this with write permission on the sendmail file and forget the process pipe!!! | ||||||
612 | |||||||
613 | =cut | ||||||
614 | sub publish_email { | ||||||
615 | 0 | 0 | 1 | 0 | my ($self, $mailer, $headers, $filepath, $data, $actions) = @_; | ||
616 | 0 | 0 | 0 | my ($recipient, $subject, $ccaddr, $replyto, $from, $ctype) = | |||
0 | |||||||
0 | |||||||
0 | |||||||
0 | |||||||
617 | ( ($$headers{To} || ''), ($$headers{Subject} || ''), ($$headers{CC} || ''), ($$headers{ReplyTo}), ($$headers{From} || ''), ($$headers{'Content-type'} || $$headers{'Content-Type'} || $$headers{'ContentType'} || '') ); | ||||||
618 | 0 | 0 | 0 | 0 | $mailer && $recipient || (return ''); | ||
619 | 0 | 0 | my ($toheader, $subheader, $ccheader, $repheader, $fromheader, $typeheader) = ('','','','','',''); | ||||
620 | 0 | 0 | 0 | $subject && $subject =~ s/[^\040-\176].*$//gs; # remove dangerous chars | |||
621 | 0 | 0 | 0 | $from && $from =~ s/[^\040-\176].*$//gs; # remove dangerous chars | |||
622 | 0 | 0 | 0 | $ccaddr && $ccaddr =~ s/[^\040-\176].*$//gs; # remove dangerous chars | |||
623 | 0 | 0 | 0 | $replyto && $replyto =~ s/[^\040-\176].*$//gs; # remove dangerous chars | |||
624 | 0 | 0 | 0 | $ctype && $ctype =~ s/[^\040-\176].*$//gs; # remove dangerous chars | |||
625 | 0 | 0 | 0 | $subject || ($subject = 'Web Notice'); | |||
626 | 0 | 0 | 0 | if ($mailer=~/RECIPIENT/) { $mailer =~ s/RECIPIENT/$recipient/g; } else { $toheader = "To: $recipient\n"; }; | |||
0 | 0 | ||||||
0 | 0 | ||||||
627 | 0 | 0 | 0 | if ($mailer=~/SUBJECT/) { $mailer =~ s/SUBJECT/$subject/g; } else { $subheader = "Subject: $subject\n"; }; | |||
0 | 0 | ||||||
0 | 0 | ||||||
628 | 0 | 0 | 0 | $from && ($fromheader = "From: $from\n"); | |||
629 | 0 | 0 | 0 | $ccaddr && ($ccheader="Cc: $ccaddr\n"); | |||
630 | 0 | 0 | 0 | $replyto && ($repheader="Reply-to: $replyto\n"); | |||
631 | 0 | 0 | 0 | $ctype && ($typeheader="Content-Type: $ctype\n"); | |||
632 | 0 | 0 | 0 | if ($mailer eq 'SMTP') { | |||
633 | # We will put an SMTP (require Net::SMTP) mailer here | ||||||
634 | 0 | 0 | return 0; | ||||
635 | } else { | ||||||
636 | 0 | 0 | my $fh = new FileHandle($mailer); | ||||
637 | 0 | 0 | 0 | if (!$fh) { return ''; }; | |||
0 | 0 | ||||||
638 | 0 | 0 | 0 | 0 | if ($toheader || $subheader || $typeheader || $ccheader) { print $fh $toheader.$fromheader.$subheader.$ccheader.$repheader.$typeheader."\n"; }; | ||
0 | 0 | 0 | |||||
0 | |||||||
639 | 0 | 0 | $self->publish_to($fh, $filepath, $data, $actions); | ||||
640 | 0 | 0 | $fh->close; | ||||
641 | 0 | 0 | return 1; | ||||
642 | }; | ||||||
643 | }; | ||||||
644 | |||||||
645 | sub enc_char { | ||||||
646 | 0 | 0 | 0 | 0 | my $c=shift; | ||
647 | 0 | 0 | my $v=ord($c); | ||||
648 | 0 | 0 | 0 | ($v<16) && return '%0'.sprintf("%x",$v); | |||
649 | 0 | 0 | return '%'.sprintf("%x",$v); | ||||
650 | }; | ||||||
651 | |||||||
652 | |||||||
653 | |||||||
654 | =item cgi2data($cgi) | ||||||
655 | |||||||
656 | This method converts C |
||||||
657 | for merging. The C<$cgi> parameter is a CGI object and is optional, but | ||||||
658 | you must have imported the C<:standard> methods from C |
||||||
659 | the C<$cgi> paramter. This method returns a hash reference containing the | ||||||
660 | parameters as data. Basically it turns list values into list references and | ||||||
661 | puts everything in a hash keyed by field name. | ||||||
662 | |||||||
663 | =cut | ||||||
664 | sub cgi2data { | ||||||
665 | 0 | 0 | 1 | 0 | my ($self, $cgi) = @_; | ||
666 | 0 | 0 | my $data = {}; | ||||
667 | 0 | 0 | my ($k,$v,@v); | ||||
668 | 0 | 0 | 0 | my @keys = $cgi ? $cgi->param : param(); | |||
669 | 0 | 0 | foreach $k ($cgi->param) { | ||||
670 | 0 | 0 | 0 | @v = $cgi ? $cgi->param($k) : param($k); | |||
671 | 0 | 0 | 0 | $v = (@v>1) ? [@v] : $v[0]; | |||
672 | 0 | 0 | $$data{$k} = $v; | ||||
673 | } | ||||||
674 | 0 | 0 | return $data; | ||||
675 | }; | ||||||
676 | |||||||
677 | |||||||
678 | # | ||||||
679 | # local conversion function for output of each of the various styles | ||||||
680 | # OK, this isn't going to "local" anymore, other programs all want to use | ||||||
681 | # it, so we have to let them. Don't forget to document! | ||||||
682 | # | ||||||
683 | sub convert_value { | ||||||
684 | 358 | 358 | 0 | 548 | my ($self, $value, $style) = @_; | ||
685 | 358 | 50 | 685 | $value ||= ''; | |||
686 | 358 | 50 | 770 | ($_=$style) || ($_ = 'string'); | |||
687 | 358 | 50 | 50 | 15183 | /^upper/i && (return uc($value || '')) || | ||
0 | 100 | ||||||
50 | |||||||
100 | |||||||
33 | |||||||
50 | |||||||
100 | |||||||
33 | |||||||
0 | |||||||
50 | |||||||
33 | |||||||
50 | |||||||
100 | |||||||
33 | |||||||
50 | |||||||
100 | |||||||
33 | |||||||
50 | |||||||
100 | |||||||
33 | |||||||
100 | |||||||
33 | |||||||
0 | |||||||
50 | |||||||
33 | |||||||
100 | |||||||
33 | |||||||
100 | |||||||
33 | |||||||
50 | |||||||
33 | |||||||
50 | |||||||
100 | |||||||
33 | |||||||
33 | |||||||
100 | |||||||
33 | |||||||
100 | |||||||
33 | |||||||
100 | |||||||
33 | |||||||
100 | |||||||
33 | |||||||
100 | |||||||
33 | |||||||
100 | |||||||
33 | |||||||
100 | |||||||
33 | |||||||
100 | |||||||
33 | |||||||
100 | |||||||
33 | |||||||
100 | |||||||
33 | |||||||
100 | |||||||
33 | |||||||
100 | |||||||
33 | |||||||
50 | |||||||
33 | |||||||
0 | |||||||
0 | |||||||
0 | |||||||
688 | /^lower/i && (return lc($value || '')) || | ||||||
689 | /^proper/i && (return propnoun($value || '')) || | ||||||
690 | /^trunc(?:ate)?(\d+)/ && (return substr(($value||''), 0, $1)) || | ||||||
691 | /^words(\d+)/ && (return frstword(($value||''), $1)) || | ||||||
692 | /^para(?:graph)?(\d+)/ && (return paratext(($value||''), $1)) || | ||||||
693 | /^indent(\d+)/ && (return indtext(($value||''), $1)) || | ||||||
694 | /^int/i && (return (defined $value ? int($value) : 0)) || | ||||||
695 | /^float/i && (return (defined $value && sprintf('%f',($value || 0))) || '') || | ||||||
696 | /^string/i && (return $value) || | ||||||
697 | /^detab/i && (return de_tab($value)) || # Convert tabs to spaces in a string | ||||||
698 | /^html/i && (return htmlconv($value)) || # Convert text to HTML | ||||||
699 | /^dollars/i && (return (defined $value && length($value) && sprintf('%.2f',($value || 0)) || '')) || | ||||||
700 | /^percent/i && (return (($value<0.2) && sprintf('%.1f%%',($value*100)) || sprintf('%d%%',int($value*100)))) || | ||||||
701 | /^abbr/i && (return abbrdate($value)) || # abbreviated date only | ||||||
702 | /^short/i && (return shrtdate($value)) || # short date/time | ||||||
703 | /^time/i && (return timeoday($value)) || # time of day only (localtime am/pm) | ||||||
704 | /^24h/i && (return time24hr($value)) || # time of day 23:59 format (localtime0 | ||||||
705 | /^dateonly/i && (return dateonly($value)) || # same as full date, but no meridian time | ||||||
706 | /^date/i && (return fulldate($value)) || # full date | ||||||
707 | /^ext/i && (return extdate($value)) || # extended date | ||||||
708 | /^unix/i && (return scalar localtime($value)) || | ||||||
709 | /^urlencode/i && (return urlenc($value)) || # URL encoded | ||||||
710 | /^urldecode/i && (return urldec($value)) || # URL decoded | ||||||
711 | /^escape/i && (return brsresc($value)) || # Browser Escape | ||||||
712 | /^unescape/i && (return brsruesc($value)) || # Browser Un-Escape | ||||||
713 | /^list$/ && (return (ref $value) && ' '.join("\n ", @$value)."\n" || ' '.$value."\n") || | ||||||
714 | return " {{{ style $style not supported }}} "; | ||||||
715 | }; | ||||||
716 | |||||||
717 | |||||||
718 | 0 | 0 | 0 | 0 | sub browser_escape { return brsresc(@_); }; | ||
719 | 0 | 0 | 0 | 0 | sub browser_unescape { return brsruesc(@_); }; | ||
720 | 0 | 0 | 0 | 0 | sub html_convert { return htmlconv(@_); }; | ||
721 | |||||||
722 | __END__ |