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