File Coverage

blib/lib/String/PictureFormat.pm
Criterion Covered Total %
statement 325 770 42.2
branch 143 710 20.1
condition 52 320 16.2
subroutine 8 10 80.0
pod 5 5 100.0
total 533 1815 29.3


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