File Coverage

blib/lib/String/PictureFormat.pm
Criterion Covered Total %
statement 325 770 42.2
branch 145 714 20.3
condition 52 320 16.2
subroutine 8 10 80.0
pod 5 5 100.0
total 535 1819 29.4


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             String::PictureFormat - Functions to format and unformat strings based on a "Picture" format string
4              
5             =head1 AUTHOR
6              
7             Jim Turner
8              
9             (c) 2015, Jim Turner under the same license that Perl 5 itself is. All rights reserved.
10              
11             =head1 SYNOPSIS
12              
13             use String::PictureFormat;
14              
15             print "-formatted=".fmt('@"...-..-...."', 123456789)."=\n";
16             #RETURNS "123-45-6789".
17              
18             print "-unformatted=".unfmt('@"...-..-...."', '123-45-6789')."=\n";
19             #RETURNS "123456789".
20              
21             print "-formatted=".fmt('@$,12.2>', 123456789)."= \n";
22             #RETURNS " $123,456,789.00".
23              
24             print "-format size=".fmtsiz('@$,12.2>')."= \n";
25             #RETURNS 18.
26              
27             print "-formatted=".fmt('@$,12.2> CR', -123456789)."=\n";
28             #RETURNS " $123,456,789.00 CR".
29              
30             print "-formatted=".fmt('@$,12.2> CR', 123456789)."=\n";
31             #RETURNS " $123,456,789.00 ".
32              
33             print "-formatted=".fmt('@$,12.2>', -123456789)."=\n";
34             #RETURNS " $-123,456,789.00".
35              
36             print "-formatted=".fmt('@-$,12.2>', -123456789)."=\n";
37             #RETURNS " -$123,456,789.00".
38              
39             print "-formatted=".fmt('@$(,12.2>)', -123456789)."=\n";
40             #RETURNS " $(123,456,789.00)".
41              
42             $_ = fmt('=16<', 'Now is the time for all good men to come to the aid of their country');
43             print "-formatted=".join('|',@{$_})."=\n";
44             #RETURNS "Now is the time |for all good men |to come to the aid|of their country =".
45              
46             sub foo {
47             (my $data = shift) =~ tr/a-z/A-Z/;
48             return $data;
49             }
50              
51             print "-formatted=".fmt('@foo()', 'Now is the time for all')."=\n";
52             #RETURNS "NOW IS THE TIME FOR ALL"
53              
54             print "-formatted=".fmt('@tr/aeiou/AEIOU/', 'Now is the time for all')."=\n";
55             #RETURNS "NOw Is thE tImE fOr All"
56              
57             exit(0);
58              
59             =head1 DESCRIPTION
60              
61             String::PictureFormat provides functions to format and unformat character strings according to separate
62             format strings made up of special characters. Typical usage includes left and right justification,
63             centering, floating dollar signs, adding commas to numbers, formatting phone numbers, Social-Security
64             numbers, converting negative numbers to accounting notations, creating text files containing tables
65             of data in fixed-column format, etc.
66              
67             =head1 EXAMPLES
68              
69             See B
70              
71             =head1 FORMAT STRINGS
72              
73             Format strings consist of special characters, explained in detail below. Each format string begins
74             with one of the following characters: "@", "=", or "%". "@" indicates a standard format string that
75             can be any one of several different formats as described in detail below. "=" indicates a format
76             that will "wrap" the text to be formatted into multiple rows. "%" indicates a standard C-language
77             "printf" format string.
78              
79             =over 4
80              
81             =item "@"-format strings:
82              
83             The standard format strings that begin with an "@" sign can be in one of the following formats:
84              
85             1) @"literal-picture-string" or @'literal-picture-string' or @/literal-picture-string/ or @`literal-picture-string`
86              
87             =over 4
88              
89             This format does a character-by-character converstion of the data. They can be escaped with "\"
90             to include as literals, if needed. The special characters are:
91              
92             "." - return the next character in the data.
93             "^" - skip the next character in the data.
94             "+" - return all remaining characters in the string.
95              
96             For example, to convert an integer number to a phone number with area code, one could do:
97              
98             my $ph = fmt('@"(...) ...-.+"', '1234567890 x101');
99             print "-phone# $ph\n"; #-phone# (123) 456-7890 x101
100              
101             Or, to format a social security number and return a string of asterisks if it is too long:
102              
103             my $ss = fmt('@"...-..-...."', '123456789', {-truncate => 'error'});
104             print "-ssn: $ss\n" #-ssn: 123-45-6789
105              
106             Now suppose you had part numbers where the 3rd character was a letter and the rest were digits
107             and you want only the digits, you could do:
108              
109             my $partseq = fmt('@"..^.+"', '12N345');
110             print "-part# $partseq\n" #-part# 12345
111              
112             =back
113              
114             2) @justification-string
115              
116             =over 4
117              
118             This consists of the special characters "<", "|", and ">", with optional numbers preceeding them
119             to indicate repetition, an optional decimal point, an optional prefix of "floating" characters,
120             and / or an optional suffix of literal characters. Each of the first three characters shown above
121             represent a single character of data to be returned and correspond to "left-justify", "center", or
122             "right-justify" the data returned. For example, the most basic format is:
123              
124             my $str = fmt('@>>>>>>>>>', 'Howdy');
125             print "-formatted=$str=\n"; #-formatted= Howdy=
126              
127             This returns a 10-character string right-justified (note that the "@" sign counts as one of the
128             characters representing the size of the field). This could've also been abbreviated as:
129              
130             my $str = fmt('@9>', 'Howdy');
131              
132             You can mix and match the three special characters, but the first one determines justification.
133             The only exception to this is if a decimal point is provided and the data is numeric. In that
134             case, if ">" is used after the decimal point, trailing decimal places will be rounded and removed
135             if necessary to get the string to fit, otherwise, either asterisks are returned if it won't fit
136             and the "-truncate => 'error'" option is specified. The decimal point is explicit, not implied.
137             This means that a number will be returned as that value with any excess decimal places removed or
138             zeros added to format it to the given format. For example:
139              
140             fmt('@6.2>', 123.456) will return " 123.46" (ten characters wide, right justified with two
141             decimal places). The total width is ten, due to the fact that there are 6 digits left of the
142             decimal + 2 decimal places + the decimal point + the "@" sign = 10. The full format could've
143             been given as "@>>>>>>.>>".
144              
145             Characters between the "@" sign and the first justification character are considered "floating"
146             characters and anything after the last one is a literal suffix. The main uses for the suffix
147             is to specify negative numbers in accounting format. Here's some examples:
148              
149             fmt('@$6.2>', 123.456) will return " $123.45" (eleven characters wide with a floating "$"-
150             sign. The field width is eleven instead of ten due to a space being provided for the floating
151             character.
152              
153             Commas are a special floating character, as they will be added to large numbers automatically
154             as needed, if specified. Consider:
155              
156             fmt('@$,8.2>', 1234567) will return " $1,234,567.00". Fifteen characters are returned:
157             9 for the whole number, 1 for the decimal point, 2 decimal places, the "@" sign, the "$" sign,
158             and one for each "," added.
159              
160             There are several ways to format egative numbers. For example, the default is to just leave
161             the negative number sign intact. In the case above, the result would've been:
162             " $-1,234,567.00". This could be changed to " -$1,234,567.00" by including the "-" sign as
163             a float character before the floating "$" sign, ie. fmt('@-$,8.2>', 1234567). Note that
164             the string is now sixteen characters long with the addition of another float character. Also
165             note that had the number been positive, the "-" would've been omitted automatically from the
166             returned result! You can force a sign to be displayed (either "+" or "-" depending on
167             whether the input data is a positive or negative number) by using a floating "+" instead of
168             the floating "-".
169              
170             If you are formatting numbers for accounting or tax purposes, there are special float and
171             suffix characters for that too. For examples:
172              
173             fmt('@$,8.2>CR', -123456.7) will return " $123,456.70CR". The "CR" is replaced by " " if
174             the input data is zero or positive. To get a space between the number and the "CR", simply
175             add a space to the suffix, ie. "@$,8.2> CR".
176              
177             Another common accounting format is parenthesis to indicate negative numbers. This is
178             accomplished by combining the special float character "(" with a suffix that starts with a
179             ")". For example:
180              
181             fmt('@($,8.2>)', -123456.7) will return " ($123,456.70)". The parenthesis will be replaced
182             by spaces if the number is zero or positive. However, the space in lieu of the "(" may
183             instead be replaced by an extra digit if the number is large and just barely fits. If one
184             desires to have the "$" sign before the parenthesis, simply do "fmt('@$(,8.2>)', -123456.7)"
185             instead! Note that "+" and "-" should not be floated when using parenthesis or "CR" notation.
186              
187             Since floating characters, particularly floating commas, and negative numbers can increase
188             the width of the returned value causing variations in width; if you are needing to create
189             columns of fixed width, an absolute width size can be specified (along with the
190             "{-truncate => 'error'}" option. This is given as a numeric value followed by a colon
191             immediately following the "@" sign, for example:
192              
193             fmt('@16:($,8.2>)', -123456.7, {-truncate => 'error'})
194              
195             This forces the returned value to be either 16 characters right-justified or 16 "*"'s to be
196             returned. You should be careful to anticipate the maximum size of your data including any
197             floating characters to be added.
198              
199             =back
200              
201             3) @^date/time-picture-string[^data-picture-string]^ (Date / Time Conversions):
202              
203             =over 4
204              
205             This format does a character-by-character converstion of date / time data based on certain
206             substrings of special characters. The list of special character strings are described in
207             L. If this optional module is not installed, then the following are
208             available:
209              
210             B - Year in 4 digits.
211              
212             B, B - Year in last 2 digits.
213              
214             B - Number of month (2 digits, left padded with a zero if needed), ie. "01" for January.
215              
216             B
- Day of month (2 digits, left padded with a zero if needed), ie. "01".
217              
218             B, B - Hour in 24-hour format, 2 digits, left padded with a zero if needed, ie. 00-23.
219              
220             B - Minute, ie. 00-59.
221              
222             B - Seconds since start of last minute (2 digits), ie. 00-59.
223              
224             A valid date string will be formatted / unformatted based on the I. If
225             B and B are installed, the "valid date string" being
226             processed by B() can be, and the output produced by B() will be a Perl/Unix time
227             integer. Otherwise, the other valid data strings processed by B() are
228             "yyyymmdd[ hhmmss]", "mm-dd-yyyy [hh:mm:ss]", etc. B() will return
229             "yyyymmdd[ hhmm[ss]" unless B is installed, in which case, it returns
230             a Perl/Unix time integer. This can be changed specifying either B<-outfmt> or a
231             I. NOTE: It is highly recommended that both of these modules be
232             installed if formatting or unformatting date / time values, as the manual workarounds used
233             do not always produce desired results.
234              
235             Examples:
236              
237             fmt('@^mm-dd-yy^, 20150108) will return "01-08-15".
238              
239             fmt('@^mm-dd-yy hh:mi^, '01-08-2015 10:25') will return "01-08-15 10:25".
240              
241             fmt('@^mm-dd-yy^, '2015/01/08') will return "01-08-15".
242              
243             fmt('@^mm-dd-yy^, 1420781025) will return "01-08-15", if B is installed.
244              
245             unfmt('@^mm-dd-yy^, '01-08-15') will return "20150108" unless B is
246             installed, in which case it will return 1420696800 (equivalent to "2015/01/08 00:00:00".
247              
248             unfmt('@^mm-dd-yy^, '01-08-15', {-outfmt => 'yyyymmdd'}) will always return "20150108",
249             if B is also installed.
250              
251             unfmt('@^mm-dd-yy^yyyymmdd^, '01-08-15') works the same way, always returning "20150108",
252             if B is also installed.
253              
254             NOTE: If using B() with either a I or I<-outfmt> is specified,
255             and B is not installed, then I or I<-outfmt> must be
256             set to "yyyymmdd[hhmm[ss]]" or it will fail.
257              
258             =back
259              
260             4) Regex substitution:
261              
262             =over 4
263              
264             This format specifies a Perl "regular expression" to perform in the input data and outputs
265             the result. For example:
266              
267             $s = fmt('@s/[aeiou]/\[VOWEL\]/ig;', 'Now is the time for all');
268             would return:
269             "N[VOWEL]w [VOWEL]s th[VOWEL] t[VOWEL]m[VOWEL] f[VOWEL]r [VOWEL]ll".
270              
271             The new string is returned as-is regardless of length. To truncate it to a maximum fixed
272             length, specify a length constraint. You can also specify the "-truncate => 'error'
273             option to return a row of "*" of that length if the resulting string is longer, ie:
274             $s = fmt('@50:s/[aeiou]/\[VOWEL\]/ig;', 'Now is the time for all', {-truncate => 'error'});
275              
276             Perl's Translate (tr) function is also supported, ie:
277              
278             $s = fmt('@tr/aeiou/AEIOU/', 'Now is the time for all');
279             would return "NOw Is thE tImE fOr All".
280              
281             =back
282              
283             5) User-supplied functions:
284              
285             =over 4
286              
287             You can write your own custum translate function for full control over the data translation.
288             You can also supply any arguments to it that you wish, however two special ones are
289             provided for your use: "*" and "#". If you do not pass any parameters to the function,
290             then it will be called with "(*,#)". "*" represents the input data string and "#"
291             represents the maximum length to be returned (if not specified, it is zero, which means
292             the returned string may be any length. For example:
293              
294             $s = fmt('@foo', 'Now is the time for all');
295             print "-s=$s=\n";
296             ...
297             sub foo {
298             my ($data, $maxlength) = @_;
299             print "-max. length=$maxlength= just=$just= data in=$data=\n";
300             $data =~ tr/a-z/A-Z/;
301             return $data;
302             }
303              
304             This would return "NOW IS THE TIME FOR ALL". This is the same as:
305             $s = fmt('@foo(*,#)', 'Now is the time for all');
306              
307             To call a function with just the $data parameter, do:
308              
309             $s = fmt('@foo(*)', 'Now is the time for all');
310              
311             To specify a maximum length, say "50" do:
312              
313             $s = fmt('@50:foo', 'Now is the time for all', {-truncate => 'error'});
314              
315             To append a suffix string ("suffix" in the example, not counted in the max. length) do:
316              
317             $s = fmt('@foo()suffix', 'Now is the time for all');
318              
319             which would return "NOW IS THE TIME FOR ALLsuffix".
320              
321             =back
322              
323             =item "="-format strings:
324              
325             These specify text "wrapping" for long strings of characters. Data can be wrapped at either
326             character or word boundaries. The default is to wrap by word. Consider:
327              
328             $s = fmt('=15<', 'Now is the time for all good men to come to the aid of their country');
329             print "-s=".join('|',@{$s})."=\n";
330              
331             This will print:
332             "-s=Now is the time |for all good men|to come to the |aid of their |country "
333             The function returned the data as a reference to an array, each element containing a "row"
334             or "line" of 16 characters of data broken on the nearest "word boundary" and left-justified.
335             Each "row" is right-padded with spaces to bring it to 16 characters (the "=" sign plus the
336             "15" represents a row width of 16 characters. I use "|" to show the boundary between each
337             row/line.
338              
339             $s = fmt('=15>', 'Now is the time for all good men to come to the aid of their country');
340             would've returned (right-justified):
341             " Now is the time|for all good men| to come to the| aid of their| country"
342              
343             $s = fmt('=15|', 'Now is the time for all good men to come to the aid of their country');
344             would've returned (centered):
345             " Now is the time|for all good men| to come to the | aid of their | country "
346              
347             To specify simple character wrapping (spaces remain intact), one can add "w" to the
348             format string like so:
349              
350             $s = fmt('=w14<', 'Now is the time for all good men to come to the aid of their country');
351             This would return:
352             "Now is the time |for all good men| to come to the |aid of their cou|ntry "
353             NOTE: The change of "15" to "14". This is due to the fact that the "w" adds one to the
354             row "size"!
355              
356             With "w" (character wrapping), justification is pretty meaningless since each row (except
357             the last) will always contain the full number of characters with spaces as-is (no
358             spaces added). However, the last row will be affected if spaces have to be added to fill
359             it out. To get the string represented "properly", it's usually best to use "<" (left-
360             justification).
361              
362             The default is "word" wrapping, so a format string of "=15<" is the same as "=W14<".
363              
364             =item "%" (C-language) format strings:
365              
366             You can specify a C/Perl language "printf" format string by preceeding it with a "%" sign.
367             For example:
368              
369             fmt('%-12.2d', -1234);
370              
371             returns "-1234 "
372              
373             There is the added capability of floating "$" sign and commas. For example:
374              
375             fmt('%$,12.2f', -1234) returns " $-1,234.00". Note the width is 14 instead of 12
376             characters, since the two floating characters add to the width of the final results.
377             The "$" sign and "," are the only floating character options.
378              
379             =back
380              
381             =head1 METHODS
382              
383             =over 4
384              
385             =item <$scalar> || <@array> = B(I, I [, I ]);
386              
387             Returns either a formatted string (scalar) or an array of values. The
388             is applied to the to convert it to a new format (see the myriad of
389             examples in this documentation). If the specified return value is in ARRAY
390             context, the elements are:
391              
392             [0] - The string or array reference returned in the scalar context ("wrap" formats
393             return an array reference, and all others return a string).
394              
395             [1] - The length (integer) of the data formatted - note that this is not always the actual
396             length of the returned data. It represents the maximum "format length", which is
397             the max. no. of characters the format can return. If the format is open-ended,
398             ie. if the last character in a fixed format is "+", or the length is indeterminate,
399             it will return zero. For "wrap" formats, it is the no. of characters in a row.
400             If a max. length specifier is given (ie. "@50:..."), then this value is returned.
401              
402             [2] - The justification (either "<", "|", ">", or "", if no justification is
403             involved).
404              
405             I is the format string (required).
406              
407             I is the data to be formatted (required).
408              
409             I is an optional hash-reference representing additional options. The
410             currently valid options are:
411              
412             =over 4
413              
414             B<-bad> => '' (default '*') - The character to fill the output string if the
415             output string exceeds the specified maximum length and <-truncate> => 'error' is
416             specified.
417              
418             B<-infmt> => I (default '') - Alternate format to expect the incoming
419             data to be in. If a I, it overrides this option. If specified,
420             in a B() call, it causes input data to be read in in this format layout (before
421             being formatted by the I) and returned. Otherwise (if neither this
422             option nor a I is specified), the data can be in a variety of
423             layouts that B() can recognize. This option is not particularly useful
424             except for some additional error-checking, and generally need not be used.
425              
426             NOTE: If this option is specified, and B is not installed, then
427             it must be set to "yyyymmdd[hhmm[ss]]" or the format will fail.
428              
429             B<-nonnumeric> => true | false (default false or 0) - whether or not to ignore
430             "numeric"-specific formatting, ie. adding commas, sign indicators, decimal places,
431             etc. even if the data is "numeric".
432              
433             B<-outfmt> => I (default '') - Alternate format to return the
434             "unformatted" result in. If a I, it overrides this option.
435             If specified in a B() call, it causes the result to be formatted according to
436             this format (after being unformatted by the I) and returned.
437             Otherwise (if not specified), the result is returned as a Perl / Unix Time integer
438             (if B is installed) or in "yyyymmdd[hhmm[ss]]" format if not.
439              
440             NOTE: If this option is specified, and B is not installed, then
441             it must be set to "yyyymmdd[hhmm[ss]]" or the unformat will fail.
442              
443             B<-sizefixed> => true | false (default false or 0) - If true, prevents expansion of
444             certain numeric formats when the number is positive or more than one comma is added.
445             What it actually does is set the format size to be fixed to the value returned by
446             B() for the specified I. This ensures that the format
447             size will be the same reguardless of what value is passed to it.
448              
449             B<-suffix> => '[yes]' | 'no' (default yes) - If 'no', then any suffix string is
450             ignored (not appended) when formatting and not removed when unformatting. Specifying
451             anything but "no" implies the default of yes.
452              
453             B<-truncate> => '[yes]' | 'no' | 'er[ror]' - Whether or not to truncate output
454             data that exceeds the maximum width. The default is 'yes'. Specifying 'no' means
455             return the entire output string regardless of length. 'er', 'err', 'error', etc.
456             means return a row of asterisks (changable by B<-bad>). If the string does not
457             begin with "no" or "er", it is assumed to be "yes".
458              
459             =back
460              
461             =item <$scalar> || <@array> = B(I, I [, I ]);
462              
463             For the most part, this is the opposite of the B() function. It takes a
464             string and attempts to "undo" the format and return the data as close as
465             possible to what the input data string would've looked like before the
466             was applied by assuming that the input is the
467             result of having previously had that applied to it by B().
468             It is not always possible to exactly undo the format, consider:
469              
470             my $partseq = fmt('@"..^.+"', '12N345');
471             my $partno = unfmt('@"..^.+"', $partseq);
472              
473             would return "12 345", since the original format IGNORED the third character
474             "N" in the original string. Since this is unknown, unfmt() interprets "^" as
475             insert a space character. Careful use of unfmt() can often produce desired
476             results. For example:
477              
478             $s = fmt('@$,10.2> CR', '-1234567.89');
479             print "-s4 formatted=$s=\n"; # $s =" $1,234,567.89 CR"
480             $s = unfmt('@$,10.2> CR', $s);
481             print "-s4 unformatted=$s=\n"; # $s ="-1234567.89" (The original number)
482              
483             =item <$integer> = B(I);
484              
485             Returns the format "size" represented by the , just like the
486             second element of the array returned by B() in array context, see above.
487             If a maximum length specifier is given, it returns that. Otherwise, attempts
488             to determine the length of the data string that would be returned by applying
489             the format. For "wrap" formats, this is the length of a single row. For
490             regular expressions and user-supplied functions, it is zero (indeterminate).
491              
492             =item <$character> = B(I);
493              
494             Returns a character indicating the justification (if any) represented by the
495             specified , just like the third element of the array returned
496             by B() in array context, see above. The result can be either "<", ">",
497             "|", or "", if not determinable.
498              
499             =item <$integer> = B(I, I [, I ]);
500              
501             Returns the "suffix" string, if any, included in the .
502              
503             =back
504              
505             =head1 KEYWORDS
506              
507             formatting, picture_clause, strings
508              
509             =cut
510              
511             package String::PictureFormat;
512              
513 2     2   42809 use strict;
  2         5  
  2         59  
514             #use warnings;
515 2     2   9 use vars qw(@ISA @EXPORT $VERSION);
  2         3  
  2         140  
516             $VERSION = '1.11';
517              
518 2     2   2327 use Time::Local;
  2         3404  
  2         30781  
519              
520             require Exporter;
521              
522             my $haveTime2fmtstr = 0;
523             my $haveFmtstr2time = 0;
524              
525             @ISA = qw(Exporter);
526             @EXPORT = qw(fmt fmtsiz fmtjust fmtsuffix unfmt);
527              
528             sub fmt { #FORMAT INPUT DATA STRING BASED ON "PICTURE" STRING:
529 8     8 1 4016 my $pic = shift;
530 8         14 my $v = shift;
531 8         13 my $ops = shift;
532              
533 8         11 my $leni = 0;
534 8         11 my $suffix;
535 8 50       25 my $errchar = $ops->{'-bad'} ? substr($ops->{'-bad'},0,1) : '*';
536 8 100       43 my $justify = ($pic =~ /^.*?([<|>])/o) ? $1 : '';
537 8 50       30 my $fixedLeni = $ops->{-sizefixed} ? fmtsiz($pic) : 0;
538 8 100       42 if ($pic =~ s/^\@//o) { #@-strings:
    50          
    0          
539 7 50       25 $leni = $1 if ($pic =~ s/^(\d+)\://o);
540 7 50       18 $leni = $fixedLeni if ($fixedLeni);
541 7 100       52 if ($pic =~ s#^([\'\"\/\`])##o) { #PICTURE LITERAL (@'foo'
    100          
    100          
    100          
542 1         4 my $regexDelimiter = $1; #REPLACE EACH DOT WITH NEXT CHAR. SKIP ONES CORRESPONDING WITH "^", ALL OTHER CHARS ARE LITERAL.
543 1 50       31 $suffix = ($pic =~ s#\Q$regexDelimiter\E(.*)$##) ? $1 : '';
544 1         4 my $cnt = 0; #EXAMPLE: fmt("@\"...-..-.+\";suffix", '123456789'); FORMATS AN SSN:
545 1         2 my $frompic = '';
546 1         2 my $graball = 0;
547 1         2 my $charsHandled = 0; #NO. OF CHARS IN THE INPUT STRING THAT CAN BE OUTPUT.
548 1         2 $pic =~ s/\\\+/\x02/go; #PROTECT ESCAPED METACHARACTERS.
549 1         3 $pic =~ s/\\\./\x03/go;
550 1         4 $pic =~ s/\\\^/\x04/go;
551 1         2 my $t = $pic;
552 1         8 while ($t =~ s/\^//o) {
553 0         0 $charsHandled++;
554             }
555 1         7 $pic =~ s/([\.]+[+*?]?|[\^]+)/
556 3         7 my $one = $1;
557 3 50       9 if ($one =~ s!\^!\.!go)
558             {
559 0         0 $frompic .= $one;
560 0         0 ''
561             }
562             else
563             {
564 3         8 my $catcher = '('.$1.')';
565 3 50       9 $graball = 1 if ($one =~ m#\+$#o);
566 3         5 $frompic .= $catcher;
567 3         4 ++$cnt;
568 3         14 '$'.$cnt
569             }
570             /eg;
571 1         4 my $evalstr = '$v =~ s"'.$frompic.'"'.$pic.'"';
572 1 50       4 if ($graball) {
573 0         0 $charsHandled = length($v);
574             } else {
575 1         8 my $l = 0;
576 1         2 $t = $frompic;
577 1         8 while ($t =~ s/\((\.+)\)//o) {
578 3         14 $l += length($1);
579             }
580 1         2 $charsHandled += $l;
581 1 50       4 unless ($leni) {
582 1         7 ($t = $pic) =~ s/\$\d+//og;
583 1         2 $l += length($t);
584 1         2 $leni = $l;
585             }
586             }
587 1         22 my $v0 = $v;
588 1         155 eval $evalstr;
589 1         4 $v =~ s/\x04/\^/go; #UNPROTECT METACHARACTERS.
590 1         3 $v =~ s/\x03/\./go;
591 1         2 $v =~ s/\x02/\+/go;
592 1 50 33     14 if ((length($v0) > $charsHandled || ($leni > 0 && length($v) > $leni)) && $ops->{'-truncate'} !~ /no/io) {
      33        
593 0 0       0 $v = ($ops->{'-truncate'} =~ /er/io) ? $errchar x $leni : substr($v, 0, $leni);
594             }
595 1 50       5 $v .= $suffix unless ($ops->{'-suffix'} =~ /no/io);
596 1 50       8 return wantarray ? ($v, $leni, $justify) : $v;
597             } elsif ($pic =~ s#^\^##o) { #DATE-CONVERSION
598 1 50   1   63 eval 'use Date::Time2fmtstr; $haveTime2fmtstr = 1; 1' unless ($haveTime2fmtstr);
  1         321  
  0            
  0            
599 1         3 $pic =~ s/\\\^/\x04/go; #PROTECT ESCAPED "^" IN FORMAT STRING!
600 1 50       8 $suffix = ($pic =~ s#\^([^\^]*)$##) ? $1 : '';
601 1         2 $suffix =~ s/\x04/\^/go; #UNPROTECT ESCAPED "^" IN FORMAT STRING!
602 1         2 my $inpic = '';
603 1 50       4 ($pic, $inpic) = split(/\^/, $pic) if ($pic =~ /\^/);
604 1         2 $pic =~ s/\x04/\^/go; #UNPROTECT ESCAPED "^" IN FORMAT STRING!
605 1 50 0     6 $inpic ||= $ops->{'-infmt'} if ($ops->{'-infmt'});
606 1         2 my $perltime = 0;
607 1 50       4 if ($inpic) {
608 0         0 $inpic =~ s/\x04/\^/go; #UNPROTECT ESCAPED "^" IN FORMAT STRING!
609 0 0       0 eval 'use Date::Fmtstr2time; $haveFmtstr2time = 1; 1' unless ($haveFmtstr2time);
610 0 0       0 $perltime = str2time($v, $inpic) if ($haveFmtstr2time);
611 0 0 0     0 unless ($perltime || (length($v) == length($inpic) && $inpic =~ /^yyyymmdd(?:hhmm(?:ss)?)?$/i)) {
      0        
612 0   0     0 $leni ||= $fixedLeni || length($inpic);
      0        
613 0         0 $v = $errchar x $leni;
614 0 0       0 return wantarray ? ($v, $leni, $justify) : $v;
615             }
616             }
617 1         2 my $t;
618 1 50 33     10 $perltime ||= ($v =~ /^\d{9,11}$/o) ? $v : 0;
619 1 50       3 unless ($perltime) { #WE HAVE A DATE STRING, IE. yyyy-dd-mm, etc. THAT CHKDATE CAN HANDLE:
620 1         5 ($t, $perltime) = _chkdate($v);
621 1 50 33     5 unless ($t || $perltime) { #chkdate() DID NOT RECOGNIZE THE INPUT STRING, SO PUNT.
622 0   0     0 $leni ||= $fixedLeni || length($pic);
      0        
623 0         0 $v = $errchar x $leni;
624 0 0       0 return wantarray ? ($v, $leni, $justify) : $v;
625             }
626 1 50       3 if ($haveTime2fmtstr) {
627 0   0     0 $v = $perltime || &timelocal(0,0,0,substr($t,6,2),
628             (substr($t,4,2)-1),substr($t,0,4),0,0,0);
629             }
630             }
631 1 50       3 $v = $perltime if ($perltime);
632 1 50       3 if ($perltime) { #WE HAVE A PERL "TIME" (EITHER GIVEN OR RETURNED BY chkdate():
633 1 50       3 if ($haveTime2fmtstr) { #WE ALSO HAVE Time2fmtstr!:
634 0         0 $t = time2str($v, $pic);
635 0   0     0 $leni ||= $fixedLeni || length($t);
      0        
636 0 0 0     0 if ($leni && length($t) > $leni && $ops->{'-truncate'} !~ /no/io) {
      0        
637 0 0       0 $v = ($ops->{'-truncate'} =~ /er/io) ? $errchar x $leni
638             : substr($t, 0, $leni);
639             } else {
640 0         0 $v = $t;
641             }
642 0 0       0 $v .= $suffix unless ($ops->{'-suffix'} =~ /no/io);
643 0 0       0 return wantarray ? ($v, $leni, $justify) : $v;
644             } else { #NO Time2fmtstr, SO WE'LL CONVERT PERL "TIME" TO "yyyymmdd hhmmss" FOR MANUAL CONVERSION:
645 1         16 my @tv = localtime($v); #NOTE: MANUAL CONVERSION DOESN'T HANDLE ALL THE FORMAT PICTURES THAT Time2fmtstr DOES!:
646 1         10 $t = sprintf('%4.4d',$tv[5]+1900) . sprintf('%2.2d',$tv[4]+1) . sprintf('%2.2d',$tv[3])
647             . ' ' . sprintf('%2.2d',$tv[2]) . sprintf('%2.2d',$tv[1]) . sprintf('%2.2d',$tv[0]);
648             }
649             }
650 1 50       10 if ($t =~ /^\d{8}(?: \d{4,6})?$/o) { #WE HAVE A DATE/TIME STRING WE CAN (TRY) TO CONVERT MANUALLY:
651 1         4 $pic =~ s/yyyy/substr($t,0,4)/ie;
  1         4  
652 1         3 $pic =~ s/yy/substr($t,2,4)/ie;
  0         0  
653 1         3 $pic =~ s/mm/substr($t,4,2)/ie;
  1         4  
654 1         3 $pic =~ s/dd/substr($t,6,2)/ie;
  1         3  
655 1         3 $pic =~ s/hh/substr($t,9,2)/ie;
  1         2  
656 1         4 $pic =~ s/mi/substr($t,11,2)/ie;
  1         3  
657 1         3 $pic =~ s/ss/substr($t,13,2)/ie;
  1         3  
658 1         2 $v = $pic;
659 1   33     9 $leni ||= $fixedLeni || length($v);
      33        
660 1 50 33     16 if ($leni && length($v) > $leni && $ops->{'-truncate'} !~ /no/io) {
      33        
661 0 0       0 $v = ($ops->{'-truncate'} =~ /er/io) ? $errchar x $leni
662             : substr($t, 0, $fixedLeni);
663             }
664 1 50       5 $v .= $suffix unless ($ops->{'-suffix'} =~ /no/io);
665 1 50       7 return wantarray ? ($v, $leni, $justify) : $v;
666             } else { #WE GOT NOTHING WE CAN WORK WITH, SO PUNT!
667 0   0     0 $leni ||= $fixedLeni || length($pic);
      0        
668 0         0 $v = $errchar x $leni;
669 0 0       0 return wantarray ? ($v, $leni, $justify) : $v;
670             }
671             } elsif ($pic =~ m#^(?:s|tr)(\W)#) { #REGEX SUBSTITUTION (@s/foo/bar/)
672 1         4 my $regexDelimiter = $1;
673 1 50       23 $suffix = ($pic =~ s#([^$regexDelimiter]+)$##) ? $1 : '';
674 1 50       4 my $regexPostOp = ($suffix =~ s/^(\w+)\;//) ? $1 : '';
675 1         4 my $evalstr = '$v =~ '.$pic.$regexPostOp;
676 1         65 eval $evalstr;
677 1 0 33     7 if ($leni && length($v) > $leni && $ops->{'-truncate'} !~ /no/io) {
      33        
678 0 0       0 $v = ($ops->{'-truncate'} =~ /er/io) ? $errchar x $leni : substr($v, 0, $leni);
679             }
680 1 50       5 $v .= $suffix unless ($ops->{'-suffix'} =~ /no/io);
681 1 50       6 return wantarray ? ($v, $leni, $justify) : $v;
682             } elsif ($pic =~ /^[a-zA-Z_]+/o) { #USER-SUPPLIED FUNCTION (@foo('*'))
683 1 50       8 $suffix = ($pic =~ s/\)([^\)]*)$/\)/) ? $1 : '';
684 1         4 $pic =~ s/\\\*/\x02/og; #PROTECT ESCAPED METACHARACTERS:
685 1         2 $pic =~ s/\\\#/\x03/og;
686 1         2 $pic =~ s/\\\(/\x04/og;
687 1         2 $pic =~ s/\\\)/\x05/og;
688 1         7 $pic =~ s/\(\s*\)/\(\*\,\#\)/o; #WE ALWAYS PASS IT THE INPUT STRING AND LENGTH WE'RE EXPECTING (OR ZERO)
689 1 50       4 if ($v =~ /^\d+$/o)
690             {
691 0         0 $pic =~ s/\*/$v/g;
692             }
693             else
694             {
695 1         8 $pic =~ s/\*/\'$v\'/g;
696             }
697 1         4 $pic =~ s/\#/$leni/g; #UNPROTECT ESCAPED METACHARACTERS:
698 1         2 $pic =~ s/\x05/\)/og;
699 1         2 $pic =~ s/\x04/\(/og;
700 1         3 $pic =~ s/\x03/\#/og;
701 1         2 $pic =~ s/\x02/\*/og;
702 1 50       5 $pic = 'main::' . $pic unless ($pic =~ /^\w+\:\:/o);
703 1         2 my $t;
704 1 50       5 $pic =~ s/(\w)(\W*)$/$1\(\'$v\',$leni\)$2/ unless ($pic =~ /\(.*\)/o);
705 1         79 eval "\$t = $pic";
706 1 50       16 $t = $@ if ($@);
707 1 0 33     4 if ($leni && length($t) > $leni && $ops->{'-truncate'} !~ /no/io) {
      33        
708 0 0       0 $t = ($ops->{'-truncate'} =~ /er/io) ? $errchar x $leni : substr($t, 0, $leni);
709             }
710 1 50       5 $t .= $suffix unless ($ops->{'-suffix'} =~ /no/io);
711 1 50       7 return wantarray ? ($t, $leni, $justify) : $t;
712             } else { #REGULAR JUSTIFY STUFF, IE. @12>.>>)
713 3         7 my $leniSpecified = $leni;
714 3 50       12 if ($pic =~ /^\*(.*)$/) { #WE'RE JUST AN ASTERISK, JUST RETURN THE INPUT STRING UNCHANGED:
715 0         0 $suffix = $1;
716 0 0 0     0 if ($leni && length($v) > $leni && $ops->{'-truncate'} !~ /no/io) {
      0        
717 0 0       0 $v = ($ops->{'-truncate'} =~ /er/io) ? $errchar x $leni : substr($v, 0, $leni);
718             }
719 0 0       0 $v .= $1 unless ($ops->{'-suffix'} =~ /no/io);
720 0 0       0 return wantarray ? ($v, 0, '<') : $v;
721             }
722 3 100       17 $suffix = ($pic =~ s/([^\<\|\>\.\^]+)$//o) ? $1 : '';
723 3         5 my ($special, $float, $t);
724 3         4 my $commatize = 0;
725 3         14 while ($pic =~ s/^([^\d\<\|\>\.\^])//o) { #STRIP OFF ALL CHARS BEFORE <, >, |, OR DIGIT AS "FLOATING CHARS".
726 7         14 $special = $1;
727 7 100       15 if ($special eq ',') { #COMMA (@,) = ADD COMMAS EVERY 3 DIGITS:
728 3 50       17 $commatize = 1 unless ($ops->{'-nonnumeric'});
729             } else {
730 4         17 $float .= $special; #OTHERS, IE. (@$) ARE FLOATERS:
731             }
732             }
733 3 50       9 my $switchFloat = ($float =~ /\+\$/o) ? 1 : 0; #SPECIAL CASE: USER WANTS SIGN *BEFORE* "$"
734 3 100       9 if ($float =~ /\(/o) #ONLY KEEP FLOATING "(" IF SUFFIX STARTS WITH A ")"!
735             {
736 1 50       12 $float =~ s/\(//o unless ($suffix =~ /^\)/o);
737             }
738 3 100       8 if ($v < 0)
739             {
740 2 50       8 $float =~ s/\+//go unless ($ops->{'-nonnumeric'}); #REMOVE FLOATING "+" IF VALUE IS NEGATIVE.
741 2 50 33     15 $leni = 1 + length($float) unless ($fixedLeni || $leniSpecified); #COUNT FLOATING CHARS IN FIELD SIZE:
742             }
743             else
744             {
745 1 50 33     8 $leni = 1 + length($float) unless ($fixedLeni || $leniSpecified); #COUNT FLOATING CHARS IN FIELD SIZE:
746 1 50       4 $float =~ s/\-//o unless ($ops->{'-nonnumeric'});
747 1 50 33     13 $leni++ if (!($fixedLeni || $leniSpecified) && $float =~ s/\(//o); #REMOVE FLOATING "(..)" IF VALUE IS NOT NEGATIVE.
      33        
748             }
749 3         17 $pic =~ s/(\d+)[<|>]?([\.\^]?)(\d*)([<|>])/
750 3         15 my ($one, $dec, $two, $three) = ($1, $2, $3, $4);
751 3   50     10 $dec ||= '.';
752 3         25 my $exp = ($three x $one);
753 3 50       13 $exp .= $dec . ($three x $two) if ($two > 0);
754 3         12 $exp
755             /e; #CONVERT STUFF LIKE "@12.2>" TO "@<<<<<<<<<<<<.<<".
756             #DEFAULT JUSTIFY: RIGHT IF COMMATIZING(NUMBER) OR FLOATING$ OR PICTURE CONTAINS DECIMAL;
757             #OTHERWISE, DEFAULT IS LEFT.
758 3 0 0     10 $justify ||= (!($ops->{'-nonnumeric'})
      33        
759             && ($commatize || $float =~ /\$/o || $pic =~ /[\.\,\^\$]/o)) ? '>' : '<';
760             #CALCULATE FIELD SIZE BASED ON NO. OF "<, >, |" AND PRECEEDING REPEATER DIGITS (UNLESS PRE-SPECIFIED BY "@##:":
761 3 50 33     18 unless ($fixedLeni || $leniSpecified)
762             {
763 3         5 $leni += length($pic); # && $pic =~ /([<|>\.]+)/o);
764             }
765 3         14 my ($wholePic, $decPic) = split(/[\.\^]/o, $pic);
766 3         4 my $decLeni = 0;
767 3         6 my $wholeLeni = $leni;
768 3         4 my $decJustify = $justify;
769 3 50 33     24 if ($decPic && !$ops->{'-nonnumeric'}) { #PICTURE CONTAINS A DECIMAL (REAL OR IMPLIED), CALCULATE SEPARATE LENGTHS, ETC.
770 3         5 $decLeni = 0;
771 3         4 $t = $decPic;
772 3         32 $decLeni += length($1) while ($t =~ s/([\<\|\>\.\^\,\$]+)//o);
773 3         8 $decLeni += $1 - 1 while ($t =~ s/(\d+)//o);
774 3 50       14 $decJustify = $1 if ($decPic =~ /([\<\|\>])$/o); #WE DON'T "JUSTIFY" DECIMALS, BUT USE FOR DETERMING TRUNCATION, IF NEEDED.
775 3         6 $wholeLeni = $leni - ($decLeni + 1);
776 3 0 33     11 if ($pic !~ /\./o && $v !~ /\./) { #WE HAVE AN "IMPLIED DECIMAL POINT!
777 0 0       0 $v = sprintf("%.${decLeni}f", $v / (10**$decLeni)) if ($v =~ /^[\+\-\d\. ]+$/o);
778             }
779 3         10 my ($whole, $decimal) = split(/\./o, $v); #SPLIT THE VALUE IN TWO:
780 3 50       9 unless ($float =~ /\+/o) {
781 3 100 100     27 $whole =~ s/^-//o if ($v >= 0 || $suffix =~ /^[\_ ]*CR\s*$/io)
782             }
783 3         6 my $l = length($whole);
784 3   33     9 while ($l > $wholeLeni && $float && $float ne '(') { #FIRST REMOVE FLOAT CHARACTERS IF WON'T FIT:
      33        
785 0 0       0 --$l if ($float =~ s/.(\(?)$/$1/);
786             }
787 3         8 $t = $whole . '.' . $decimal;
788 3 50       8 if ($decJustify eq '>') { #CHOP RIGHT-MOST DECIMAL PLACES AS NEEDED TO FIT IFF DECIMAL PART IS "RIGHT-JUSTIFIED"
789 3   33     10 while (length($t) > $leni && $t =~ /\./o) { #NOTE:WE DON'T "JUSTIFY" THE DECIMAL PART!
790 0         0 chop $t;
791 0         0 $decLeni--;
792             }
793             }
794 3 50       14 $decLeni = 0 if ($decLeni < 0);
795 3         9 $pic = '%.'.$decLeni.'f'; #BUILD SPRINTF TO ADD/ROUND DECIMAL PLACES.
796 3         40 $t = sprintf($pic, $v); #JUST THE NUMBER W/PROPER # OF DECIMAL PLACES.
797             } else {
798 0         0 $t = $v;
799 0         0 my $l = length($v);
800 0 0       0 unless ($ops->{'-nonnumeric'}) {
801 0   0     0 while ($l > $leni && $float) { #FIRST REMOVE FLOAT CHARACTERS IF WON'T FIT:
802 0         0 chop($float);
803 0         0 --$l;
804             }
805 0   0     0 while (length($t) > $leni && $t =~ /\./o) {
806 0         0 chop $t;
807             }
808             }
809             }
810 3 50       10 unless ($ops->{'-nonnumeric'})
811             {
812 3 100       11 if ($v >= 0) #SPECIAL ACCOUNTING SUFFIX "CR" OR " CR": REMOVE IF VALUE >= 0:
813             {
814 1         3 $suffix =~ s/^([\_ ]*)CR\s*$/' 'x(length($1)+2)/ei;
  0         0  
815             }
816             else #INCLUDE SPECIAL SUFFIX "CR" OR " CR" IF VALUE < 0 FOR ACCOUNTING:
817             {
818 2 100       8 $t =~ s/\-//o if ($suffix =~ s/^([\_ ]*)(CR\s*)$/(' 'x(length($1))).$2/ei);
  1         9  
819             }
820             }
821 3 100       14 $t =~ s/^\-//o if ($float =~ /[\(\-]/o);
822 3         6 my $l = length($t);
823 3         3 my $t2;
824 3   66     20 while ($l < $leni && $float) { #DIDN'T SPLIT ON ".", SO ONLY ADD FLOAT CHARS IF WILL STILL FIT:
825 4         9 $t2 = chop($float);
826 4 50 66     26 unless (!$ops->{'-nonnumeric'} && $t2 eq '(' && $v >= 0) {
      66        
827 4         7 $t = $t2 . $t;
828 4         22 ++$l;
829             }
830             }
831 3 0 33     9 $t =~ s/^[^ \d\<\|\>\.]([ \d\.\-\+]+)$/\($1/ if ($l == $leni && $v < 0 && $float =~ s/\(//o && !$ops->{'-nonnumeric'});
      33        
      0        
832 3 50       8 if ($commatize) { #ADD COMMAS TO LARGE NUMBERS EVERY PLACES, IF WILL FIT:
833 3         5 $l = length($t);
834 3 50       7 if ($decJustify eq '>') {
835 3   33     9 while ($l > $leni && $t =~ /\./o) { #CHOP OFF LOW-ORDER DECIMAL PLACES AS NEEDED TO FIT:
836 0         0 chop $t;
837             }
838             }
839 3   33     53 while ((!$leniSpecified || $l < $leni) && $t =~ s/(\d)(\d\d\d)\b/$1,$2/) { #ADD COMMAS AS NEEDED:
      66        
840 6         10 $l = length($t);
841 6 50 33     86 $leni++ unless ($fixedLeni || $leniSpecified);
842             }
843             }
844 3 50       8 $t =~ s/\$\-/\-\$/o if ($switchFloat);
845 3 50 33     19 if ($ops->{'-truncate'} =~ /er/io && length($t) > $leni) { #WON'T FIT AND USER WANTS ERROR IF SO:
    50 33        
846 0         0 $v = $errchar x $leni;
847             } elsif ($ops->{'-truncate'} !~ /no/io || length($t) <= $leni) { #USER WANTS TRUNCATED, IF WON'T FIT:
848 3 50 33     30 $leni-- if (!($fixedLeni || $leniSpecified) && $float =~ /\(/o);
      33        
849 3 50       11 if ($justify eq '|') { #JUSTIFY:
    50          
850 0         0 my $j = int(($leni - $l) / 2);
851 0         0 $v = sprintf("%-${leni}s", (' ' x $j . $t));
852 0 0       0 return wantarray ? ($v, $leni, $justify) : $v;
853             } elsif ($justify eq '<') {
854 0         0 $v = sprintf("%-${leni}s", $t);
855             } else {
856 3         13 $v = sprintf("%${leni}s", $t);
857             }
858             } else { #USER WANTS EVERYTHING, EVEN IF WON'T FIT:
859 0 0 0     0 $leni-- if (!($fixedLeni || $leniSpecified) && $float =~ /\(/o);
      0        
860 0         0 $v = $t;
861             }
862 3 100       11 $suffix =~ s/^\)/ /o unless ($v =~ /\(/o);
863 3 50       11 $v .= $suffix unless ($ops->{'-suffix'} =~ /no/io);
864 3 50       24 return wantarray ? ($v, $leni, $justify) : $v;
865             }
866             } elsif ($pic =~ s/^\=//o) { #FIELDS STARTING WITH "=" ARE TO BE WRAPPED TO MULTIPLE LINES AS NEEDED:
867 1 50       4 $leni = $fixedLeni if ($fixedLeni);
868 1         3 my ($justify, $wrapchar) = ('<', 'W'); #DEFAULTS.
869 1         2 my $j = 1;
870 1 50       4 $suffix = ($pic =~ s/([^wW<|>\d]+)$//o) ? $1 : '';
871 1 50       5 $wrapchar = 'w' if ($pic =~ /w/o); #LITTLE w=WRAP AT CHARACTER:
872 1 50       6 $justify = $1 if ($pic =~ /^.*([<|>])/o); #BIG W=WRAP AT WORD BOUNDARIES (Text::Wrap):
873 1         9 $j += length($1) while ($pic =~ s/([wW<|>]+)//o);
874 1         9 $j += $1 - 1 while ($pic =~ s/(\d+)//o);
875 1 50       4 $leni = $j unless ($fixedLeni); #WIDTH OF FIELD AREA TO WRAP WITHIN:
876 1         2 my $mylines = 0;
877 1         2 my $t;
878 1 50       4 if (length $pic) {
879 0 0       0 $suffix = ($ops->{'-suffix'} !~ /no/io) ? $pic . $suffix : $pic;
880 0         0 $pic = '';
881             }
882 1         4 my $suffixPadding = ' ' x length($suffix);
883 1 50       4 if ($wrapchar eq 'W') { #WRAP BY WORD (Text::Wrap):
884 1         1147 require Text::Wrap; Text::Wrap->import( qw(wrap) );
  1         3396  
885             #no warnings;
886 1         2 $Text::Wrap::columns = $leni + 1;
887             #use warnings;
888 1         3 eval {$t = wrap('','',$v);};
  1         3  
889 1 50       403 if ($@) {
890 0         0 $wrapchar = 'w'; #WRAP CRAPPED :-(, DO MANUALLY (BY CHARACTER)!
891             } else {
892 1         4 my @fli = split(/\n/o, $t); #@fli ELEMENTS EACH REPRESENT A LINE:
893 1 50       6 if ($justify eq '>') { #JUSTIFY:
    50          
894 0         0 for (my $i=0;$i<=$#fli;$i++) {
895 0         0 $fli[$i] = sprintf("%${leni}s", $fli[$i]);
896 0 0       0 unless ($ops->{'-suffix'} =~ /no/io) {
897 0 0 0     0 $fli[$i] .= (!$i || $ops->{'-suffix'} =~ /all/io)
898             ? $suffix : $suffixPadding
899             }
900             }
901             } elsif ($justify eq '|') {
902 0         0 my $l;
903 0         0 for (my $i=0;$i<=$#fli;$i++) {
904 0         0 $l = length($fli[$i]);
905 0         0 $j = int(($leni - $l) / 2);
906 0         0 $fli[$i] = sprintf("%${leni}s", ($fli[$i] . ' 'x$j));
907 0 0       0 unless ($ops->{'-suffix'} =~ /no/io) {
908 0 0 0     0 $fli[$i] .= (!$i || $ops->{'-suffix'} =~ /all/io)
909             ? $suffix : $suffixPadding
910             }
911             }
912             } else {
913 1         2 my $l;
914 1         5 for (my $i=0;$i<=$#fli;$i++) {
915 4         6 $l = length($fli[$i]);
916 4         10 $j = int(($leni - $l) / 2);
917 4         12 $fli[$i] = sprintf("%-${leni}s", $fli[$i]);
918 4 50       12 unless ($ops->{'-suffix'} =~ /no/io) {
919 4 100 66     27 $fli[$i] .= (!$i || $ops->{'-suffix'} =~ /all/io)
920             ? $suffix : $suffixPadding
921             }
922             }
923             }
924 1         4 $t = join("\n", @fli); #CAN RETURN #LINES AS 2ND ELEMENT:
925 1 50       8 return wantarray ? (\@fli, $leni, $justify, scalar(@fli)) : \@fli;
926             }
927             }
928 0 0       0 if ($wrapchar eq 'w') { #WRAP BY CHARACTER (WORDS MAY BE SPLIT):
929 0         0 $j = 0;
930 0         0 my $l = length($v);
931 0         0 my @fli = ();
932 0         0 while ($j < $l)
933             {
934 0         0 push (@fli, substr($v,$j,$leni));
935 0         0 $mylines += 1;
936 0 0       0 unless ($ops->{'-suffix'} =~ /no/io) {
937 0 0 0     0 $fli[$#fli] .= (!$j || $ops->{'-suffix'} =~ /all/io)
938             ? $suffix : $suffixPadding
939             }
940 0         0 $j += $leni;
941             }
942 0 0       0 if ($justify eq '>') {
    0          
943 0         0 $fli[$#fli] = sprintf("%${leni}s", $fli[$#fli]);
944             } elsif ($justify eq '|') {
945 0         0 $l = length($fli[$#fli]);
946 0         0 $j = int(($leni - $l) / 2);
947 0         0 $fli[$#fli] = sprintf("%${leni}s", ($fli[$#fli] . ' 'x$j));
948             } else {
949 0         0 $fli[$#fli] = sprintf("%-${leni}s", $fli[$#fli]);
950             }
951 0 0       0 return wantarray ? (\@fli, $leni, $justify, scalar(@fli)) : \@fli;
952             }
953             } elsif ($pic =~ s/^\%//o) { #C-PRINTF FORMAT STRINGS (%-STRINGS) (AS-IS, "%" NOT INCLUDED IN FIELD SIZE):
954 0 0       0 $leni = $fixedLeni if ($fixedLeni);
955 0 0       0 my $float = ($pic =~ s/^\$//o) ? '$' : ''; #EXCEPTION: FLOATING $, COMMA(COMMATIZE) ALLOWED AFTER "%":
956 0 0       0 my $commatize = ($pic =~ s/^\,//o) ? 1 : 0; #IE: "%$,-14.2f": FIELD SIZE=16!
957 0 0       0 $suffix = ($pic =~ s/^(\-?[\d\.]+\w)(.*)$/$1/o) ? $2 : '';
958 0 0       0 $leni = ($pic =~ /^\-?(\d+)/) ? $1 : length($v) unless ($fixedLeni);
    0          
959 0 0       0 my $lj = ($pic =~ /^\-/o) ? '-' : '';
960 0 0       0 $justify = ($lj eq '-') ? '<' : '>';
961 0         0 $pic = '%' . $pic;
962 0         0 my $t;
963 0 0       0 my $decimal = ($pic =~ /\.(\d+)/o) ? $1 : 0;
964 0 0       0 if ($float) {
965 0         0 $lj = '';
966 0 0       0 $lj = '-' if ($pic =~ s/^\%\-/\%/o);
967 0 0       0 unless ($fixedLeni) {
968 0 0       0 $leni += length($float) if ($pic =~ /^\%(\d+)/o);
969             }
970 0         0 $v = sprintf("%.${decimal}f", $v);
971             }
972 0         0 my $l;
973 0 0       0 if ($commatize) { #USER WANTS COMMAS ADDED TO LARGE NUMBERS:
974 0 0       0 unless ($fixedLeni) {
975 0 0       0 $leni++ if ($pic =~ /^\%(\d+)/o);
976             }
977 0         0 $l = length($v);
978 0   0     0 while ($l > $leni && $v =~ /\./o) {
979 0         0 chop $v;
980             }
981 0 0       0 if ($l > $leni) {
982 0         0 $v = $errchar x $leni;
983 0 0       0 return wantarray ? ($v, $leni, $justify) : $v;
984             }
985 0   0     0 while ($l < $leni && $v =~ s/(\d)(\d\d\d)\b/$1,$2/) {
986 0         0 $l = length($v);
987             }
988             } else {
989 0 0       0 $v = sprintf($pic, $v) unless ($float);
990 0         0 $l = length($v);
991             }
992 0 0 0     0 $v = $float . $v if ($float && $l < $leni);
993 0         0 $v = sprintf("%${lj}${leni}.${leni}s", $v);
994 0 0       0 $v .= $suffix unless ($ops->{'-suffix'} =~ /no/io);
995 0 0       0 return wantarray ? ($v, $leni, $justify) : $v;
996             } else {
997 0         0 return undef; #INVALID PICTURE STRING:
998             }
999             }
1000              
1001             sub unfmt { #UNFORMAT INPUT DATA STRING BASED ON "PICTURE" STRING (AS IF PREVIOUSLY FORMATTED BY SAME STRING:
1002 1     1 1 591 my $pic = shift;
1003 1         3 my $v = shift;
1004 1         2 my $ops = shift;
1005              
1006 1         2 my $leni = 0;
1007 1         5 my $leniSpecified = 0;
1008 1         2 my $suffix;
1009 1 50       5 my $errchar = $ops->{'-bad'} ? substr($ops->{'-bad'},0,1) : '*';
1010 1 50       7 my $justify = ($pic =~ /^.*?([<|>])/o) ? $1 : '';
1011 1 50       5 my $fixedLeni = $ops->{-sizefixed} ? fmtsiz($pic) : 0;
1012 1 50       7 if ($pic =~ s/^\@//o) { #@-strings:
    0          
    0          
1013 1 50       4 $leni = $fixedLeni if ($fixedLeni);
1014 1 50       4 $leni = $1 if ($pic =~ s/^(\d+)\://o);
1015 1         2 $leniSpecified = $leni;
1016 1 50       5 if ($pic =~ s/^([\'\"\/\`])//o) { #PICTURE LITERAL (@'foo'
    0          
    0          
    0          
1017 1         3 my $regexDelimiter = $1; #REPLACE EACH DOT WITH NEXT CHAR. SKIP ONES CORRESPONDING WITH "^", ALL OTHER CHARS ARE LITERAL.
1018 1 50       41 $v =~ s/$1$// if ($pic =~ s#\Q$regexDelimiter\E(.*)$##);
1019 1         2 my $r0 = $pic;
1020 1         3 $r0 =~ s/\\.//gso;
1021 1         11 $r0 =~ s/(\.+[\+\*]*)/\($1\)/gs;
1022 1         2 my $r = $r0;
1023 1         2 $r0 =~ s/\^//gso;
1024 1         3 my @QS;
1025 1         1 my $i = 0;
1026 1         5 $i++ while ($r0 =~ s/(\([^\)]+\))/
1027 3         8 $QS[$i] = "$1"; "P$i"/e);
  3         20  
1028              
1029 1         3 $r0 = "\Q$r0\E";
1030 1         8 $r0 =~ s/P(\d+)/$QS[$1]/gs;
1031 1         2 $i = 1;
1032 1         26 $i++ while ($r =~ s/\(.+?\)/\$$i/s);
1033 1         2 $r =~ s/\^/ /gso;
1034 1         5 $r =~ s/[^\$\d ]//gso;
1035 1         5 my $evalstr = "\$v =~ s\"$r0\"$r\"";
1036 1         114 eval $evalstr;
1037 1 0 33     7 if ($leni && length($v) > $leni && $ops->{'-truncate'} !~ /no/io) {
      33        
1038 0 0       0 $v = ($ops->{'-truncate'} =~ /er/io) ? $errchar x $leni : substr($v, 0, $leni);
1039             }
1040 1 50       10 return wantarray ? ($v, $leni, $justify) : $v;
1041             } elsif ($pic =~ s#^\^##o) { #DATE-CONVERSION
1042 0 0       0 eval 'use Date::Fmtstr2time; $haveFmtstr2time = 1; 1' unless ($haveFmtstr2time);
1043 0         0 $pic =~ s/\\\^/\x04/go; #PROTECT ESCAPED "^" IN FORMAT STRING!
1044 0 0       0 $suffix = ($pic =~ s#\^([^\^]*)$##) ? $1 : '';
1045 0         0 $suffix =~ s/\x04/\^/go; #UNPROTECT ESCAPED "^" IN FORMAT STRING!
1046 0         0 my $outpic = '';
1047 0 0       0 ($pic, $outpic) = split(/\^/o, $pic) if ($pic =~ /\^/);
1048 0         0 $pic =~ s/\x04/\^/go; #UNPROTECT ESCAPED "^" IN FORMAT STRING!
1049 0 0 0     0 $outpic ||= $ops->{'-outfmt'} if ($ops->{'-outfmt'});
1050 0 0       0 $v =~ s/\Q${suffix}\E$// unless ($ops->{'-suffix'} =~ /no/io);
1051 0         0 my $t = '';
1052 0 0       0 if ($haveFmtstr2time) { #CONVERT TO A PERL "TIME" USING Fmtstr2time IF IT'S AVAILABLE:
1053 0         0 $t = str2time($v, $pic);
1054 0 0 0     0 if ($t && $outpic) { #WE WANT THE TIME FORMATTED TO A STRING:
1055 0 0       0 eval 'use Date::Time2fmtstr; $haveTime2fmtstr = 1; 1' unless ($haveTime2fmtstr);
1056 0 0       0 $t = ($haveTime2fmtstr) ? time2str($t, $outpic) : '';
1057             }
1058             }
1059 0 0       0 unless ($t) { #ATTEMPT A MANUAL TRANSLATION TO AN INTEGER FORMATTED: yyyymmdd[hhmm[ss]]
1060 0 0 0     0 if ($outpic && $outpic !~ /^yyyymmdd(?:hhmm(?:ss)?)?$/i) { #IF WE DON'T HAVE Fmtstr2time & user specified an output format other than "yyyymmdd..." then FAIL!
1061 0         0 $t = $errchar x length($outpic);
1062 0 0       0 return wantarray ? ($t, $leni, $justify) : $t;
1063             }
1064 0         0 foreach my $i (qw(yyyy mm dd)) {
1065 0   0     0 $t .= substr($v,index($pic,$i),length($i)) || ' ' x length($i);
1066             }
1067 0         0 $t =~ s/^ /'20'.substr($v,index($pic,'yy'),2)/e;
  0         0  
1068 0         0 $t =~ s/ $/01/;
1069 0         0 $t =~ s/ /$errchar/g;
1070 0         0 foreach my $i (qw(HH hh mi ss)) {
1071 0 0       0 $t .= substr($v,index($pic,$i),length($i)) if (index($pic,$i) > 0);
1072             }
1073 0         0 $t =~ s/[^0-9 ]/ /go;
1074             }
1075 0 0 0     0 if ($leni && length($t) > $leni && $ops->{'-truncate'} !~ /no/io) {
      0        
1076 0 0       0 $t = ($ops->{'-truncate'} =~ /er/io) ? $errchar x $leni : substr($t, 0, $leni);
1077             }
1078 0 0       0 return wantarray ? ($t, $leni, $justify) : $t;
1079             } elsif ($pic =~ m#^(?:s|tr)(\W)#) { #REGEX SUBSTITUTION (@s/foo/bar/) #NOTE: unfmt() SAME AS fmt()!
1080 0         0 my $regexDelimiter = $2;
1081 0 0       0 $v =~ s/$1$// if ($pic =~ s#\Q$regexDelimiter\E(.*)$##);
1082 0         0 my $evalstr = '$v =~ '.$pic;
1083 0         0 eval $evalstr;
1084 0 0 0     0 if ($leni && length($v) > $leni && $ops->{'-truncate'} !~ /no/io) {
      0        
1085 0 0       0 $v = ($ops->{'-truncate'} =~ /er/io) ? $errchar x $leni : substr($v, 0, $leni);
1086             }
1087 0 0       0 return wantarray ? ($v, $leni, $justify) : $v;
1088             } elsif ($pic =~ /^[a-zA-Z_]+/o) { #USER-SUPPLIED FUNCTION (@foo('*')) #NOTE: unfmt() SAME AS fmt()!
1089 0 0       0 $v =~ s/$1$// if ($pic =~ s#\Q\;\E(.*)$##);
1090 0         0 $pic =~ s/\\\*/\x02/og; #PROTECT ESCAPED METACHARACTERS:
1091 0         0 $pic =~ s/\\\*/\x02/og;
1092 0         0 $pic =~ s/\\\#/\x03/og;
1093 0 0       0 if ($v =~ /^\d+$/o)
1094             {
1095 0         0 $pic =~ s/\*/$v/g;
1096             }
1097             else
1098             {
1099 0         0 $pic =~ s/\*/\'$v\'/g;
1100             }
1101 0         0 $pic =~ s/\#/$leni/g; #UNPROTECT ESCAPED METACHARACTERS:
1102 0         0 $pic =~ s/\x03/\#/og;
1103 0         0 $pic =~ s/\x02/\*/og;
1104 0 0       0 $pic = 'main::' . $pic unless ($pic =~ /^\w+\:\:/o);
1105 0         0 my $t;
1106 0 0       0 $pic =~ s/(\w)(\W*)$/$1\(\'$v\',$leni\)$2/ unless ($pic =~ /\(.*\)/o);
1107 0         0 eval "\$t = $pic";
1108 0 0       0 $t = $@ if ($@);
1109             #NO! $t .= $suffix unless ($ops->{'-suffix'} =~ /no/io);
1110 0 0 0     0 if ($leni && length($v) > $leni && $ops->{'-truncate'} !~ /no/io) {
      0        
1111 0 0       0 $v = ($ops->{'-truncate'} =~ /er/io) ? $errchar x $leni : substr($v, 0, $leni);
1112             }
1113 0 0       0 return wantarray ? ($t, $leni, $justify) : $t;
1114             } else { #REGULAR JUSTIFY STUFF, IE. @12>.>>)
1115 0 0       0 if ($pic =~ /^\*(.*)$/) { #WE'RE JUST AN ASTERISK, JUST RETURN THE INPUT STRING UNCHANGED:
1116 0         0 $suffix = $1;
1117 0 0 0     0 if ($leni && length($v) > $leni && $ops->{'-truncate'} !~ /no/io) {
      0        
1118 0 0       0 $v = ($ops->{'-truncate'} =~ /er/io) ? $errchar x $leni : substr($v, 0, $leni);
1119             }
1120 0 0       0 $v .= $1 unless ($ops->{'-suffix'} =~ /no/io);
1121 0 0       0 return wantarray ? ($v, 0, '<') : $v;
1122             }
1123 0 0       0 $suffix = $1 if ($pic =~ s/([^<|>.]+)$//o);
1124 0         0 my ($special, $isneg, $t);
1125 0         0 my $commatize = 0;
1126 0         0 while ($pic =~ s/^([^\d\<\|\>\.])//o) { #STRIP OFF ALL CHARS BEFORE <, >, |, OR DIGIT AS "FLOATING CHARS".
1127 0         0 $special .= $1;
1128             }
1129 0         0 $isneg = 0;
1130 0 0 0     0 if ($v =~ /^\D*\-/o) {
    0 0        
    0          
1131 0         0 $isneg = 1;
1132             } elsif ($special =~ /\(/o && $v =~ /\(/o) {
1133 0         0 $isneg = 1;
1134             } elsif ($suffix =~ /^[\_ ]*CR\s*$/o && $v =~ s/\s*CR\s*$//o) {
1135 0 0       0 unless ($ops->{-nonnumeric}) {
1136 0         0 $isneg = 1;
1137             }
1138             }
1139 0 0       0 $v =~ s/[\Q$special\E]//g if ($special);
1140 0         0 $v =~ s/^\s+//o;
1141 0         0 $v =~ s/\s+$//o;
1142 0 0       0 $v =~ s/\Q${suffix}\E$// unless ($ops->{'-suffix'} =~ /no/io);
1143 0         0 $v =~ s/\s+$//o;
1144 0 0       0 if ($isneg) {
1145 0 0       0 $v = '-' . $v unless ($v =~ /^\-/o);
1146             }
1147 0         0 $pic =~ s/(\d+)[<|>]?([\.\^]?)(\d*)([<|>])/
1148 0         0 my ($one, $dec, $two, $three) = ($1, $2, $3, $4);
1149 0   0     0 $dec ||= '.';
1150 0         0 my $exp = ($three x $one);
1151 0 0       0 $exp .= $dec . ($three x $two) if ($two > 0);
1152 0         0 $exp
1153             /e; #CONVERT STUFF LIKE "@12.2>" TO "@>>>>>>>>>>>>.>>>".
1154 0 0       0 my $justify = ($pic =~ /^.*?([<|>])/o) ? $1 : '';
1155 0         0 my $decJustify;
1156 0 0       0 if ($pic =~ /^([<|>]+)[\.\^]([<|>]+)/o) {
    0          
1157 0         0 my $two = $2;
1158 0         0 $leni = length($1) + length($two) + 2;
1159 0 0       0 unless ($ops->{'-nonnumeric'}) {
1160 0         0 my $decLen = length($two);
1161 0 0       0 $decJustify = ($two =~ /([\<\|\>])$/o) ? $1 : '';
1162 0 0 0     0 if ($pic !~ /\./o && $v =~ /\./ && $v =~ /^[\+\-\d\. ]+$/o) { #WE HAVE AN "IMPLIED DECIMAL POINT!
      0        
1163 0 0       0 $v = sprintf("%.0f", $v * (10**$decLen)) if ($v =~ /^[\+\-\d\. ]+$/o);
1164             } else {
1165 0         0 $v = sprintf("%.${decLen}f", $v);
1166             }
1167             }
1168             } elsif ($pic =~ /^([\[\<\|\>]+)/o) {
1169 0         0 $leni = length($1) + 1;
1170             } else {
1171 0         0 $leni = 1;
1172             }
1173 0 0 0     0 $leni = $leniSpecified if ($leniSpecified && $leni > $leniSpecified);
1174 0 0 0     0 if ($leni && length($v) > $leni) {
1175 0 0 0     0 if ($decJustify eq '>' && !$ops->{'-nonnumeric'} && $v =~ /^[0-9\+\-]*\.[0-9]+/o) { #(NUMERIC) CHOP OFF DECIMALS UNTIL IT EITHER FITS OR WE ARE A WHOLE NUMBER:
      0        
1176 0         0 while (length($v) > $leni) {
1177 0         0 chop($v);
1178 0 0       0 last unless ($v =~ /\./o);
1179             }
1180 0 0       0 $v = '0' unless (length($v));
1181             }
1182             }
1183 0 0 0     0 if ($leni && length($v) > $leni) {
1184 0 0       0 if ($ops->{'-truncate'} !~ /no/io) {
1185 0 0       0 if ($ops->{'-truncate'} =~ /er/io) {
1186 0         0 $v = $errchar x $leni;
1187             } else {
1188 0 0       0 if ($justify eq '>') { #CHOP LEADING CHARACTERS UNTIL FITS IF RIGHT-JUSTIFY:
1189 0         0 while (length($v) > $leni) {
1190 0         0 $v =~ s/^.(.+)$/$1/;
1191             }
1192             } else { #CHOP TRAILING CHARACTERS UNTIL FITS IF LEFT-JUSTIFY|CENTER:
1193 0         0 while (length($v) > $leni) {
1194 0         0 chop $v;
1195             }
1196             }
1197             }
1198             }
1199             }
1200 0         0 my $padcnt = $leniSpecified - length($v);
1201 0 0       0 if ($padcnt > 0) {
1202 0 0       0 if ($justify eq '>') {
    0          
1203 0         0 $v = (' ' x $padcnt) . $v;
1204             } elsif ($justify eq '|') {
1205 0         0 for (my $i=0;$i<$padcnt;$i++) {
1206 0 0       0 $v = ($i % 2) ? ' ' . $v : $v . ' ';
1207             }
1208             } else {
1209 0         0 $v .= ' ' x $padcnt;
1210             }
1211             }
1212 0 0       0 return wantarray ? ($v, length($v), $justify) : $v;
1213             }
1214             } elsif ($pic =~ s/^\=//o) { #FIELDS STARTING WITH "=" ARE TO BE WRAPPED TO MULTIPLE LINES AS NEEDED:
1215 0         0 my ($justify, $wrapchar) = ('<', 'W'); #DEFAULTS.
1216 0         0 my $j = 1;
1217 0 0       0 $suffix = ($pic =~ s/([^wW<|>\d]+)$//o) ? $1 : '';
1218 0 0       0 $wrapchar = 'w' if ($pic =~ /w/o); #LITTLE w=WRAP AT CHARACTER:
1219 0 0       0 $justify = $1 if ($pic =~ /^.*([<|>])/o); #BIG W=WRAP AT WORD BOUNDARIES (Text::Wrap):
1220 0         0 $v =~ s/${suffix}(\r?\n)/$1/gs;
1221 0 0       0 if ($justify eq '<') {
    0          
1222 0         0 $v =~ s/(\S)\r?\n\s*/$1 /gs;
1223             } elsif ($justify eq '>') {
1224 0         0 $v =~ s/\s*\r?\n(\S)/ $1/gs;
1225             } else {
1226 0         0 $v =~ s/\s*\r?\n\s*/ /gs;
1227             }
1228 0         0 $v =~ s/\r?\n//gs;
1229 0 0       0 $leni = $leniSpecified if ($leni > $leniSpecified);
1230 0 0 0     0 if ($leni && length($v) > $leni) {
    0 0        
1231 0 0       0 if ($ops->{'-truncate'} !~ /no/io) {
1232 0 0       0 $v = ($ops->{'-truncate'} =~ /er/io) ? $errchar x $leni : substr($v, 0, $leni);
1233             }
1234             } elsif ($leniSpecified && length($v) < $leniSpecified) {
1235 0         0 my $padcnt = $leniSpecified - length($v);
1236 0 0       0 if ($padcnt > 0) {
1237 0 0       0 $v = ($justify eq '>') ? (' ' x $padcnt) . $v : $v . (' ' x $padcnt);
1238             }
1239             }
1240 0 0       0 return wantarray ? ($v, length($v), $justify) : $v;
1241             } elsif ($pic =~ s/^\%//o) { #C-PRINTF FORMAT STRINGS (%-STRINGS) (AS-IS, "%" NOT INCLUDED IN FIELD SIZE):
1242 0 0       0 my $float = ($pic =~ s/^\$//o) ? '$' : ''; #EXCEPTION: FLOATING $, COMMA(COMMATIZE) ALLOWED AFTER "%":
1243 0 0       0 my $commatize = ($pic =~ s/^\,//o) ? 1 : 0; #IE: "%$,-14.2f": FIELD SIZE=16!
1244 0 0       0 $v =~ s/$2$// if ($pic =~ s/^(\-?[\d\.]+\w)(.*)$/$1/o);
1245 0 0       0 $leni = ($pic =~ /^\-?(\d+)/) ? $1 : length($v);
1246 0 0       0 my $lj = ($pic =~ /^\-/o) ? '-' : '';
1247 0 0       0 $justify = ($lj eq '-') ? '<' : '>';
1248 0         0 $pic = '%' . $pic;
1249 0         0 my $t;
1250 0 0       0 my $decimal = ($pic =~ /\.(\d+)/o) ? $1 : 0;
1251 0 0       0 if ($float) {
1252 0         0 $lj = '';
1253 0 0       0 $lj = '-' if ($pic =~ s/^\%\-/\%/o);
1254 0 0       0 $leni += length($float) if ($pic =~ /^\%(\d+)/o);
1255 0         0 $v = sprintf("%.${decimal}f", $v);
1256             }
1257 0         0 my $l;
1258 0 0       0 if ($commatize) {
1259 0 0       0 $leni++ if ($pic =~ /^\%(\d+)/o);
1260 0         0 $l = length($v);
1261 0   0     0 while ($l > $leni && $v =~ /\./o) {
1262 0         0 chop $v;
1263             }
1264 0 0       0 if ($l > $leni) {
1265 0         0 $v = '#'x$leni;
1266 0 0       0 return wantarray ? ($v, $leni, $justify) : $v;
1267             }
1268 0   0     0 while ($l < $leni && $v =~ s/(\d)(\d\d\d)\b/$1,$2/) {
1269 0         0 $l = length($v);
1270             }
1271             } else {
1272 0         0 $l = length($v);
1273 0   0     0 while ($l > $leni && $v =~ /\./o) { #CHOP OFF DECIMAL PLACES IF NEEDED TO GET TO FIT:
1274 0         0 chop $v;
1275             }
1276             }
1277 0 0 0     0 $v = $float . $v if ($float && $l < $leni);
1278 0         0 $v = sprintf("%${lj}${leni}.${leni}s", $v);
1279 0 0       0 return wantarray ? ($v, $leni, $justify) : $v;
1280             } else {
1281 0         0 return undef; #INVALID PICTURE STRING:
1282             }
1283             }
1284              
1285             sub fmtsiz { #RETURN THE "SIZE" STRING THE "PICTURE STRING" ARGUMENT REPRESENTS (NOT THE LENGTH ITSELF) - CAN BE ZERO IF VARIABLE:
1286 1     1 1 529 my $pic = shift;
1287 1         3 my $v = shift;
1288 1         2 my $leni;
1289             my $suffix;
1290 1 50       6 if ($pic =~ s/^\@//o) { #@-strings:
    0          
    0          
1291 1 50       16 if ($pic =~ /^(\d+)\:/o) {
    50          
    50          
    50          
    50          
1292 0         0 return $1;
1293             } elsif ($pic =~ s/^([\'\"\/\`])//o) { #PICTURE LITERAL (@'foo'
1294 0         0 my $regexDelimiter = $1; #REPLACE EACH DOT WITH NEXT CHAR. SKIP ONES CORRESPONDING WITH "^", ALL OTHER CHARS ARE LITERAL.
1295 0         0 $pic =~ s#\Q$regexDelimiter\E.*$##;
1296 0         0 my $cnt = 0; #EXAMPLE: fmt("@\"...-..-.+\";suffix", '123456789'); FORMATS AN SSN:
1297 0         0 my $frompic = '';
1298 0         0 $pic =~ s/\\\+/\x02/go;
1299 0         0 $pic =~ s/\\\./\x03/go;
1300 0         0 $pic =~ s/\\\^/\x04/go;
1301 0         0 return length($pic);
1302             } elsif ($pic =~ s#^\^##o) { #DATE-CONVERSION
1303 0         0 $pic =~ s/\\\^/\x04/go; #PROTECT ESCAPED "^" IN FORMAT STRING!
1304 0         0 $pic =~ s#\^.*$##;
1305 0         0 (my $t = $v) =~ s/\D//go;
1306 0         0 return length($pic);
1307             } elsif ($pic =~ m#^(?:s|tr)\W#o) { #REGEX SUBSTITUTION (@s/foo/bar/)
1308 0         0 return 0;
1309             } elsif ($pic =~ /^[a-zA-Z_]+/o) { #USER-SUPPLIED FUNCTION (@foo('*'))
1310 0         0 return 0;
1311             } else { #REGULAR STUFF, IE. @12>.>>)
1312 1 50       4 return 0 if ($pic =~ /^\*(.*)$/o);
1313 1         4 $pic =~ s/[^\<\|\>\.\^]+$//o;
1314 1         45 my ($special, $float, $t);
1315 1         2 my $commatize = 0;
1316 1         6 while ($pic =~ s/^([^\d\<\|\>\.\^])//o) { #STRIP OFF ALL CHARS BEFORE <, >, |, OR DIGIT AS "FLOATING CHARS".
1317 2         7 $special = $1;
1318 2 100       5 if ($special eq ',') { #COMMA (@,) = ADD COMMAS EVERY 3 DIGITS:
1319 1         4 $commatize = 1;
1320             } else {
1321 1         10 $float .= $special; #OTHERS, IE. (@$) ARE FLOATERS:
1322             }
1323             }
1324 1         3 $leni = 1 + length($float) + $commatize; #COUNT FLOATING CHARS IN FIELD SIZE:
1325 1         5 $pic =~ s/(\d+)[<|>]?([\.\^]?)(\d*)([<|>])/
1326 1         5 my ($one, $dec, $two, $three) = ($1, $2, $3, $4);
1327 1   50     4 $dec ||= '.';
1328 1         3 my $exp = ($three x $one);
1329 1 50       6 $exp .= $dec . ($three x $two) if ($two > 0);
1330 1         4 $exp
1331             /e; #CONVERT STUFF LIKE "@12.2>" TO "@>>>>>>>>>>>>.>>".
1332 1         2 $t = $pic;
1333             #CALCULATE FIELD SIZE BASED ON NO. OF "<, >, |" AND PRECEEDING REPEATER DIGITS:
1334 1         9 $leni += length($1) while ($t =~ s/([\<\|\>\.\^\,\$]+)//o);
1335 1         4 $leni += $1 - 1 while ($t =~ s/(\d+)//o);
1336 1         4 return $leni;
1337             }
1338             } elsif ($pic =~ s/^\=//o) { #FIELDS STARTING WITH "=" ARE TO BE WRAPPED TO MULTIPLE LINES AS NEEDED:
1339 0         0 my ($justify, $wrapchar) = ('<', 'W'); #DEFAULTS.
1340 0         0 my $j = 1;
1341 0 0       0 $suffix = $1 if ($pic =~ s/([^wW<|>\d]+)$//o);
1342 0 0       0 $wrapchar = 'w' if ($pic =~ /w/o); #LITTLE w=WRAP AT CHARACTER:
1343 0 0       0 $justify = $1 if ($pic =~ /^.*([<|>])/o); #BIG W=WRAP AT WORD BOUNDARIES (Text::Wrap):
1344 0         0 $j += length($1) while ($pic =~ s/([wW<|>]+)//o);
1345 0         0 $j += $1 - 1 while ($pic =~ s/(\d+)//o);
1346 0         0 return $j; #WIDTH OF FIELD AREA TO WRAP WITHIN:
1347             } elsif ($pic =~ s/^\%//o) { #C-PRINTF FORMAT STRINGS (%-STRINGS) (AS-IS, "%" NOT INCLUDED IN FIELD SIZE):
1348 0 0       0 my $float = ($pic =~ s/^\$//o) ? '$' : ''; #EXCEPTION: FLOATING $, COMMA(COMMATIZE) ALLOWED AFTER "%":
1349 0 0       0 my $commatize = ($pic =~ s/^\,//o) ? 1 : 0; #IE: "%$,-14.2f": FIELD SIZE=16!
1350 0 0       0 $suffix = ($pic =~ s/^(\-?[\d\.]+\w)(.*$)/$1/o) ? $2 : '';
1351 0 0       0 $leni = ($pic =~ /^\-?(\d+)/) ? $1 : length($v);
1352 0 0       0 my $lj = ($pic =~ /^\-/o) ? '-' : '';
1353 0         0 $pic = '%' . $pic;
1354 0         0 my $t;
1355 0 0       0 if ($float) {
1356 0         0 $pic =~ s/^\%\-/\%/o;
1357 0 0       0 $leni += length($float) if ($pic =~ /^\%(\d+)/o);
1358             }
1359 0 0       0 if ($commatize) {
1360 0 0       0 $leni++ if ($pic =~ /^\%(\d+)/o);
1361             }
1362 0         0 return $leni;
1363             } else {
1364 0         0 return undef; #INVALID PICTURE STRING:
1365             }
1366             }
1367              
1368             sub fmtjust { #RETURN THE "JUSTIFICATION" DIRECTION THE "PICTURE STRING" REPRESENTS ("<", ">", "|", OR "", IN INDETERMINATE)
1369 0     0 1 0 my $pic = shift;
1370 0         0 my $v = shift;
1371              
1372 0         0 my $leni;
1373             my $suffix;
1374 0 0       0 if ($pic =~ s/^\@//o) { #@-strings:
    0          
    0          
1375 0         0 $pic =~ s/(\d+)\://o;
1376 0 0       0 if ($pic =~ s/^[\'\"\/\`]//o) { #PICTURE LITERAL (@'foo'
    0          
    0          
    0          
1377 0         0 return '<';
1378             } elsif ($pic =~ s#^\^##o) { #DATE-CONVERSION
1379 0         0 return '<';
1380             } elsif ($pic =~ m#^(?:s|tr)\W#o) { #REGEX SUBSTITUTION (@s/foo/bar/)
1381 0         0 return '<';
1382             } elsif ($pic =~ /^[a-zA-Z_]+/o) { #USER-SUPPLIED FUNCTION (@foo('*'))
1383 0         0 return '<';
1384             } else { #REGULAR STUFF, IE. @12>.>>)
1385 0 0       0 return '<' if ($pic =~ /^\*(.*)$/);
1386 0 0       0 $suffix = $1 if ($pic =~ s/([^\<\|\>\.\^]+)$//o);
1387 0         0 my ($special, $float, $t);
1388 0         0 my $commatize = 0;
1389 0         0 while ($pic =~ s/^([^\d\<\|\>\.\^])//o) { #STRIP OFF ALL CHARS BEFORE <, >, |, OR DIGIT AS "FLOATING CHARS".
1390 0         0 $special = $1;
1391 0 0       0 if ($special eq ',') { #COMMA (@,) = ADD COMMAS EVERY 3 DIGITS:
1392 0         0 $commatize = 1;
1393             } else {
1394 0         0 $float .= $special; #OTHERS, IE. (@$) ARE FLOATERS:
1395             }
1396             }
1397 0 0       0 if ($float =~ /\(/o) #ONLY KEEP FLOATING "(" IF SUFFIX STARTS WITH A ")"!
1398             {
1399 0 0       0 $float =~ s/\(//o unless ($suffix =~ s/^\)//o);
1400             }
1401 0 0       0 if ($v < 0)
1402             {
1403 0         0 $float =~ s/\+//go; #REMOVE FLOATING "+" IF VALUE IS NEGATIVE.
1404             }
1405             else
1406             {
1407 0         0 $float =~ s/\(//go; #REMOVE FLOATING "(..)" IF VALUE IS NOT NEGATIVE.
1408             }
1409 0         0 $leni = 1 + length($float) + $commatize; #COUNT FLOATING CHARS IN FIELD SIZE:
1410 0 0       0 my $justify = ($pic =~ /^.*?([<|>])/o) ? $1 : '';
1411             #DEFAULT JUSTIFY: RIGHT IF COMMATIZING(NUMBER) OR FLOATING$ OR PICTURE CONTAINS DECIMAL;
1412             #OTHERWISE, DEFAULT IS LEFT.
1413 0 0 0     0 $justify ||= ($commatize || $float =~ /\$/o || $pic =~ /[.,\$]/o) ? '>' : '<';
      0        
1414 0         0 return $justify;
1415             }
1416             } elsif ($pic =~ s/^\=//o) { #FIELDS STARTING WITH "=" ARE TO BE WRAPPED TO MULTIPLE LINES AS NEEDED:
1417 0         0 my ($justify, $wrapchar) = ('<', 'W'); #DEFAULTS.
1418 0         0 my $j = 1;
1419 0 0       0 $suffix = $1 if ($pic =~ s/([^wW<|>\d]+)$//o);
1420 0 0       0 $wrapchar = 'w' if ($pic =~ /w/o); #LITTLE w=WRAP AT CHARACTER:
1421 0 0       0 $justify = $1 if ($pic =~ /^.*([<|>])/o); #BIG W=WRAP AT WORD BOUNDARIES (Text::Wrap):
1422 0         0 return $justify;
1423             } elsif ($pic =~ s/^\%//o) { #C-PRINTF FORMAT STRINGS (%-STRINGS) (AS-IS, "%" NOT INCLUDED IN FIELD SIZE):
1424 0 0       0 my $float = ($pic =~ s/^\$//o) ? '$' : ''; #EXCEPTION: FLOATING $, COMMA(COMMATIZE) ALLOWED AFTER "%":
1425 0 0       0 my $commatize = ($pic =~ s/^\,//o) ? 1 : 0; #IE: "%$,-14.2f": FIELD SIZE=16!
1426 0 0       0 $suffix = ($pic =~ s/^(\-?[\d\.]+\w)(.*$)/$1/o) ? $2 : '';
1427 0 0       0 $leni = ($pic =~ /^\-?(\d+)/) ? $1 : length($v);
1428 0 0       0 my $justify = ($pic =~ /^\-/o) ? '<' : '>';
1429 0         0 return $justify;
1430             } else {
1431 0         0 return undef; #INVALID PICTURE STRING:
1432             }
1433 0         0 return '<';
1434             }
1435              
1436             sub fmtsuffix { #RETURN JUST THE SUFFIX PART, IF ANY, IN THE PICTURE STRING (OR "") IF NONE.
1437 0     0 1 0 my $pic = shift; #ANY CHARACTERS AFTER THE "PICTURE STRING" METACHARACTERS IS TREATED AS THE "SUFFIX"
1438 0         0 my $v = shift;
1439 0         0 my $ops = shift;
1440              
1441 0         0 my $leni;
1442 0         0 my $suffix = '';
1443 0 0       0 if ($pic =~ s/^\@//o) { #@-strings:
    0          
    0          
1444 0         0 $pic =~ s/(\d+)\://o;
1445 0 0       0 if ($pic =~ s/^([\'\"\/\`])//o) { #PICTURE LITERAL (@'foo'
    0          
    0          
    0          
1446 0         0 my $regexDelimiter = $1; #REPLACE EACH DOT WITH NEXT CHAR. SKIP ONES CORRESPONDING WITH "^", ALL OTHER CHARS ARE LITERAL.
1447 0 0       0 $suffix = $1 if ($pic =~ s#\Q$regexDelimiter\E(.*)$##);
1448 0         0 return $suffix;
1449             } elsif ($pic =~ s#^\^##o) { #DATE-CONVERSION
1450 0         0 $pic =~ s/\\\^/\x04/go; #PROTECT ESCAPED "^" IN FORMAT STRING!
1451 0 0       0 $suffix = ($pic =~ s#\^([^\^]*)$##) ? $1 : '';
1452 0         0 $suffix =~ s/\x04/\^/go; #UNPROTECT ESCAPED "^" IN FORMAT STRING!
1453 0         0 return $suffix;
1454             } elsif ($pic =~ m#^(?:s|tr)(\W)#) { #REGEX SUBSTITUTION (@s/foo/bar/)
1455 0         0 my $regexDelimiter = $1;
1456 0 0       0 $suffix = $1 if ($pic =~ s#([^$regexDelimiter]+)$##);
1457 0         0 return $suffix;
1458             } elsif ($pic =~ /^[a-zA-Z_]+/o) { #USER-SUPPLIED FUNCTION (@foo('*'))
1459 0 0       0 $suffix = $1 if ($pic =~ s/\)([^\)]*)$/\)/o);
1460 0         0 return $suffix;
1461             } else { #REGULAR JUSTIFY STUFF, IE. @12>.>>)
1462 0 0       0 return $1 if ($pic =~ /^\*(.*)$/);
1463 0 0       0 $suffix = $1 if ($pic =~ s/([^<|>.]+)$//o);
1464 0         0 return $suffix;
1465             }
1466             } elsif ($pic =~ s/^\=//o) { #FIELDS STARTING WITH "=" ARE TO BE WRAPPED TO MULTIPLE LINES AS NEEDED:
1467 0         0 my ($justify, $wrapchar) = ('<', 'W'); #DEFAULTS.
1468 0         0 my $j = 1;
1469 0 0       0 $suffix = $1 if ($pic =~ s/([^wW<|>\d]+)$//o);
1470 0         0 return $suffix;
1471             } elsif ($pic =~ s/^\%//o) { #C-PRINTF FORMAT STRINGS (%-STRINGS) (AS-IS, "%" NOT INCLUDED IN FIELD SIZE):
1472 0         0 $pic =~ s/^\$//o;
1473 0         0 $pic =~ s/^\,//o;
1474 0 0       0 $suffix = ($pic =~ s/^(\-?[\d\.]+\w)(.*)$/$1/o) ? $2 : '';
1475 0         0 return $suffix;
1476             } else {
1477 0         0 return undef; #INVALID PICTURE STRING:
1478             }
1479             }
1480              
1481             sub _chkdate# #(INTERNAL) TRY TO PARSE OUT AND CONVERT USER-ENTERED DATE/TIME STRINGS TO "yyyymmdd [hhmm[ss]]".
1482             {
1483             #### Y2K COMPLIANT UNTIL 2080.
1484             #### NOTE: 6-DIGIT DATES W/SEPARATORS ARE HANDLED AS mmddyy!
1485             #### NOTE: 6-DIGIT INTEGER DATES ARE HANDLED AS yymmdd!
1486            
1487 1     1   3 my ($dt) = shift;
1488 1         1 my ($res);
1489 1 0       6 return wantarray ? ($dt,0) : $dt unless ($dt =~ /\S/o);
    50          
1490 1 50       6 $dt = substr($dt,0,8) . ' ' . substr($dt,8) if ($dt =~ /\d{9,14}\D*$/o);
1491 1 50 0     5 if ($dt =~ s#(\d+)[\/\-\.](\d+)[\/\-\.](\d+)##o) #DATE PART HAS SEPARATORS (ie. mm/dd/yyyy):
    0          
1492             {
1493 1         2 my $x;
1494 1 50 33     8 if ($1 < 1000 && $3 < 1000) #2-DIGIT YEAR: "mm/dd/yy"|"mm-dd-yy"|"mm.dd.yy" (MAKE ASSUMPTIONS):
    50          
1495             {
1496 0 0       0 my $century = ($3 < 80) ? 20 : 19; #Y2K:80-99=19##; 00-79=20##!
1497 0         0 $x = sprintf '%-2.2d%-2.2d%-2.2d%-2.2d',$century,$3,$1,$2
1498             }
1499             elsif ($1 > 1000) #4-DIGIT YEAR: "yyyy/mm/dd"|"yyyy-mm-dd"|"yyyy.mm.dd"
1500             {
1501 1         6 $x = sprintf '%-2.2d%-2.2d%-2.2d',$1,$2,$3;
1502             }
1503             else #4-DIGIT YEAR, ASSUME: "mm/dd/yyyy"|"mm-dd-yyyy"|"mm.dd.yyyy"
1504             {
1505 0         0 $x = sprintf '%-2.2d%-2.2d%-2.2d',$3,$1,$2;
1506             }
1507 1         2 my $then = 0;
1508 1 50       6 if ($dt =~ s#^\D+(\d\d?)\:?(\d\d?)##o) #STRING HAS A "TIME" PART:
1509             {
1510 1         5 $x .= ' ' . sprintf '%-2.2d%-2.2d',$1,$2;
1511 1 50       6 $x .= ($dt =~ s#\:?(\d\d?)##o) ? sprintf('%-2.2d',$1) : '00';
1512 1 50       6 if ($dt =~ m#(\s*[ap]m?)#i) #STRING HAS AM/PM SUFFIX (12-HOUR TIME)
1513             {
1514 1         3 my $indicator = $1;
1515 1 50       20 my $hr = $1 if ($x =~ /\d (\d\d)/);
1516 1 50 33     17 if ($indicator =~ /a/i && $hr == 12) #12 AM BECOMES 00:
    50 33        
1517             {
1518 0         0 $x =~ s/(\d) (\d\d)/$1 . ' 00'/e;
  0         0  
1519             }
1520             elsif ($indicator =~ /p/i && $hr != 12) #1-11 PM BECOMES 13-23:
1521             {
1522 1         5 $x =~ s/(\d) (\d\d)/$1 . ' ' . sprintf('%-2.2d',$hr+12)/e;
  1         6  
1523             }
1524 1         2 $x .= $indicator;
1525             }
1526             eval #TRY TO CONVERT DATE/TIME STRING TO A PERL/UNIX TIME INTEGER:
1527 1         2 {
1528 1         9 $then = &timelocal(substr($x,13,2),substr($x,11,2),substr($x,9,2),
1529             substr($x,6,2),(substr($x,4,2)-1),substr($x,0,4),0,0,0);
1530             };
1531             }
1532             else #STRING IS ONLY A DATE, WILL ASSUME MIDNITE (00:00:00) FOR THE TIME PART:
1533             {
1534             eval #TRY TO CONVERT DATE STRING TO A PERL/UNIX TIME INTEGER:
1535 0         0 {
1536 0         0 $then = &timelocal(0,0,0,substr($x,6,2),
1537             (substr($x,4,2)-1),substr($x,0,4),0,0,0);
1538             };
1539             }
1540 1         81 $dt = $x;
1541              
1542              
1543 1 50       4 $dt = '' unless ($then > 0); #INVALID DATE, BLANK OUT!
1544 1 50       6 return wantarray ? ($dt, $then) : $dt;
1545             }
1546             elsif ($dt =~ s/^(\d\d\d\d\d\d+)(\D+\d+\:?\d+.*)?$/$1/o || $dt =~ s/^(\d{8})(\d{4})/$1/o)
1547             { #STRING DATE PART HAS NO SEPARATORS:
1548 0   0     0 my $timepart = $2 || '';
1549 0 0       0 if (length($dt) == 6) #2-DIGIT YEAR: "yymmdd" (2-DIGIT YEAR, MAKE ASSUMPTIONS):
1550             {
1551 0 0       0 my $century = (substr($dt,0,2) < 80) ? 20 : 19; #Y2K:80-99=19##; 00-79=20##!
1552 0         0 $dt = $century . $dt;
1553             }
1554             else #4-DIGIT YEAR: "mmddyyyy":
1555             {
1556 0         0 my ($leftpart) = substr($dt,0,4);
1557 0 0       0 if ($leftpart < 1300) #ASSUME USER MEANT: "mmddyyyy":
1558             {
1559 0         0 $dt = substr($dt,4,4) . $leftpart;
1560             }
1561             }
1562 0         0 my $then = 0;
1563 0         0 $timepart =~ s/^\D+//o;
1564 0 0 0     0 if ($timepart =~ s#^(\d\d)(\d\d)##o || $timepart =~ s#^(\d\d?)\:(\d\d?)\:?##o)
1565             { #STRING INCLUDES A "TIME" PART (hhmm[ss] OR hh:mm[:ss]:
1566 0         0 $dt .= ' ' . sprintf('%-2.2d',$1) . sprintf('%-2.2d',$2);
1567 0 0       0 $dt .= ($timepart =~ s#(\d\d?)\s*##o) ? sprintf('%-2.2d',$1) : '00';
1568 0 0       0 if ($timepart =~ m#([ap]m?)#io) #STRING INCLUDES A[M]|P[M], CONVERT AS 12-HOUR TO 24-HOUR:
1569             {
1570 0         0 my $indicator = $1;
1571 0 0       0 my $hr = $1 if ($dt =~ /\d (\d\d)/);
1572 0 0 0     0 if ($indicator =~ /a/i && $hr == 12) #12 AM BECOMES 00:
    0 0        
1573             {
1574 0         0 $dt =~ s/(\d) (\d\d)/$1 . ' 00'/e;
  0         0  
1575             }
1576             elsif ($indicator =~ /p/i && $hr != 12) #1-11 PM BECOMES 13-23:
1577             {
1578 0         0 $dt =~ s/(\d) (\d\d)/$1 . sprintf('%-2.2d',$hr+12)/e;
  0         0  
1579             }
1580             }
1581             eval #TRY TO CONVERT DATE/TIME STRING TO A PERL/UNIX TIME INTEGER:
1582 0         0 {
1583 0         0 $then = &timelocal(substr($dt,13,2),substr($dt,11,2),substr($dt,9,2),
1584             substr($dt,6,2),(substr($dt,4,2)-1),substr($dt,0,4),0,0,0);
1585             };
1586             }
1587             else #STRING IS ONLY A DATE, WILL ASSUME MIDNITE (00:00:00) FOR THE TIME PART:
1588             {
1589             eval #TRY TO CONVERT DATE STRING TO A PERL/UNIX TIME INTEGER:
1590 0         0 {
1591 0         0 $then = &timelocal(0,0,0,substr($dt,6,2),
1592             (substr($dt,4,2)-1),substr($dt,0,4),0,0,0);
1593             };
1594             }
1595 0 0       0 $dt = '' unless ($then > 0); #INVALID DATE, BLANK OUT!
1596 0 0       0 return wantarray ? ($dt, $then) : $dt;
1597             }
1598             else
1599             {
1600 0 0       0 return wantarray ? ('', 0) : ''; #INVALID DATE, BLANK OUT!
1601             }
1602             }
1603              
1604             1
1605              
1606             __END__