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__ |