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