Filename | /home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/Spreadsheet/ParseExcel/Utility.pm |
Statements | Executed 13 statements in 3.20ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 9µs | 10µs | BEGIN@19 | Spreadsheet::ParseExcel::Utility::
1 | 1 | 1 | 4µs | 21µs | BEGIN@23 | Spreadsheet::ParseExcel::Utility::
1 | 1 | 1 | 3µs | 16µs | BEGIN@20 | Spreadsheet::ParseExcel::Utility::
0 | 0 | 0 | 0s | 0s | AddComma | Spreadsheet::ParseExcel::Utility::
0 | 0 | 0 | 0s | 0s | ExcelFmt | Spreadsheet::ParseExcel::Utility::
0 | 0 | 0 | 0s | 0s | ExcelLocaltime | Spreadsheet::ParseExcel::Utility::
0 | 0 | 0 | 0s | 0s | LeapYear | Spreadsheet::ParseExcel::Utility::
0 | 0 | 0 | 0s | 0s | LocaltimeExcel | Spreadsheet::ParseExcel::Utility::
0 | 0 | 0 | 0s | 0s | MakeE | Spreadsheet::ParseExcel::Utility::
0 | 0 | 0 | 0s | 0s | MakeFraction | Spreadsheet::ParseExcel::Utility::
0 | 0 | 0 | 0s | 0s | col2int | Spreadsheet::ParseExcel::Utility::
0 | 0 | 0 | 0s | 0s | int2col | Spreadsheet::ParseExcel::Utility::
0 | 0 | 0 | 0s | 0s | sheetRef | Spreadsheet::ParseExcel::Utility::
0 | 0 | 0 | 0s | 0s | xls2csv | Spreadsheet::ParseExcel::Utility::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Spreadsheet::ParseExcel::Utility; | ||||
2 | |||||
3 | ############################################################################### | ||||
4 | # | ||||
5 | # Spreadsheet::ParseExcel::Utility - Utility functions for ParseExcel. | ||||
6 | # | ||||
7 | # Used in conjunction with Spreadsheet::ParseExcel. | ||||
8 | # | ||||
9 | # Copyright (c) 2014 Douglas Wilson | ||||
10 | # Copyright (c) 2009-2013 John McNamara | ||||
11 | # Copyright (c) 2006-2008 Gabor Szabo | ||||
12 | # Copyright (c) 2000-2006 Kawai Takanori | ||||
13 | # | ||||
14 | # perltidy with standard settings. | ||||
15 | # | ||||
16 | # Documentation after __END__ | ||||
17 | # | ||||
18 | |||||
19 | 2 | 16µs | 2 | 11µs | # spent 10µs (9+1) within Spreadsheet::ParseExcel::Utility::BEGIN@19 which was called:
# once (9µs+1µs) by Spreadsheet::ParseExcel::FmtDefault::BEGIN@22 at line 19 # spent 10µs making 1 call to Spreadsheet::ParseExcel::Utility::BEGIN@19
# spent 1µs making 1 call to strict::import |
20 | 2 | 17µs | 2 | 28µs | # spent 16µs (3+12) within Spreadsheet::ParseExcel::Utility::BEGIN@20 which was called:
# once (3µs+12µs) by Spreadsheet::ParseExcel::FmtDefault::BEGIN@22 at line 20 # spent 16µs making 1 call to Spreadsheet::ParseExcel::Utility::BEGIN@20
# spent 12µs making 1 call to warnings::import |
21 | |||||
22 | 1 | 500ns | require Exporter; | ||
23 | 2 | 3.15ms | 2 | 38µs | # spent 21µs (4+17) within Spreadsheet::ParseExcel::Utility::BEGIN@23 which was called:
# once (4µs+17µs) by Spreadsheet::ParseExcel::FmtDefault::BEGIN@22 at line 23 # spent 21µs making 1 call to Spreadsheet::ParseExcel::Utility::BEGIN@23
# spent 17µs making 1 call to vars::import |
24 | 1 | 5µs | @ISA = qw(Exporter); | ||
25 | 1 | 700ns | @EXPORT_OK = qw(ExcelFmt LocaltimeExcel ExcelLocaltime | ||
26 | col2int int2col sheetRef xls2csv); | ||||
27 | |||||
28 | 1 | 200ns | our $VERSION = '0.66'; | ||
29 | |||||
30 | 1 | 5µs | 1 | 2µs | my $qrNUMBER = qr/(^[+-]?\d+(\.\d+)?$)|(^[+-]?\d+\.?(\d*)[eE][+-](\d+))$/; # spent 2µs making 1 call to CORE::qr |
31 | |||||
32 | ############################################################################### | ||||
33 | # | ||||
34 | # ExcelFmt() | ||||
35 | # | ||||
36 | # This function takes an Excel style number format and converts a number into | ||||
37 | # that format. for example: 'hh:mm:ss AM/PM' + 0.01023148 = '12:14:44 AM'. | ||||
38 | # | ||||
39 | # It does this with a type of templating mechanism. The format string is parsed | ||||
40 | # to identify tokens that need to be replaced and their position within the | ||||
41 | # string is recorded. These can be thought of as placeholders. The number is | ||||
42 | # then converted to the required formats and substituted into the placeholders. | ||||
43 | # | ||||
44 | # Interested parties should refer to the Excel documentation on cell formats for | ||||
45 | # more information: http://office.microsoft.com/en-us/excel/HP051995001033.aspx | ||||
46 | # The Microsoft documentation for the Excel Binary File Format, [MS-XLS].pdf, | ||||
47 | # also contains a ABNF grammar for number format strings. | ||||
48 | # | ||||
49 | # Maintainers notes: | ||||
50 | # ================== | ||||
51 | # | ||||
52 | # Note on format subsections: | ||||
53 | # A format string can contain 4 possible sub-sections separated by semi-colons: | ||||
54 | # Positive numbers, negative numbers, zero values, and text. | ||||
55 | # For example: _(* #,##0_);_(* (#,##0);_(* "-"_);_(@_) | ||||
56 | # | ||||
57 | # Note on conditional formats. | ||||
58 | # A number format in Excel can have a conditional expression such as: | ||||
59 | # [>9999999](000)000-0000;000-0000 | ||||
60 | # This is equivalent to the following in Perl: | ||||
61 | # $format = $number > 9999999 ? '(000)000-0000' : '000-0000'; | ||||
62 | # Nested conditionals are also possible but we don't support them. | ||||
63 | # | ||||
64 | # Efficiency: The excessive use of substr() isn't very efficient. However, | ||||
65 | # it probably doesn't merit rewriting this function with a parser or regular | ||||
66 | # expressions and \G. | ||||
67 | # | ||||
68 | # TODO: I think the single quote handling may not be required. Check. | ||||
69 | # | ||||
70 | sub ExcelFmt { | ||||
71 | |||||
72 | my ( $format_str, $number, $is_1904, $number_type, $want_subformats ) = @_; | ||||
73 | |||||
74 | # Return text strings without further formatting. | ||||
75 | return $number unless $number =~ $qrNUMBER; | ||||
76 | |||||
77 | # Handle OpenOffice.org GENERAL format. | ||||
78 | $format_str = '@' if uc($format_str) eq "GENERAL"; | ||||
79 | |||||
80 | # Check for a conditional at the start of the format. See notes above. | ||||
81 | my $conditional_op; | ||||
82 | my $conditional_value; | ||||
83 | if ( $format_str =~ /^\[([<>=]+)([^\]]+)\](.*)$/ ) { | ||||
84 | $conditional_op = $1; | ||||
85 | $conditional_value = $2; | ||||
86 | $format_str = $3; | ||||
87 | } | ||||
88 | |||||
89 | # Ignore the underscore token which is used to indicate a padding space. | ||||
90 | $format_str =~ s/_/ /g; | ||||
91 | |||||
92 | # Split the format string into 4 possible sub-sections: positive numbers, | ||||
93 | # negative numbers, zero values, and text. See notes above. | ||||
94 | my @formats; | ||||
95 | my $section = 0; | ||||
96 | my $double_quote = 0; | ||||
97 | my $single_quote = 0; | ||||
98 | |||||
99 | # Initial parsing of the format string to remove escape characters. This | ||||
100 | # also handles quoted strings. See note about single quotes above. | ||||
101 | CHARACTER: | ||||
102 | for my $char ( split //, $format_str ) { | ||||
103 | |||||
104 | if ( $double_quote or $single_quote ) { | ||||
105 | $formats[$section] .= $char; | ||||
106 | $double_quote = 0 if $char eq '"'; | ||||
107 | $single_quote = 0; | ||||
108 | next CHARACTER; | ||||
109 | } | ||||
110 | |||||
111 | if ( $char eq ';' ) { | ||||
112 | $section++; | ||||
113 | next CHARACTER; | ||||
114 | } | ||||
115 | elsif ( $char eq '"' ) { | ||||
116 | $double_quote = 1; | ||||
117 | } | ||||
118 | elsif ( $char eq '!' ) { | ||||
119 | $single_quote = 1; | ||||
120 | } | ||||
121 | elsif ( $char eq '\\' ) { | ||||
122 | $single_quote = 1; | ||||
123 | } | ||||
124 | elsif ( $char eq '(' ) { | ||||
125 | next CHARACTER; # Ignore. | ||||
126 | } | ||||
127 | elsif ( $char eq ')' ) { | ||||
128 | next CHARACTER; # Ignore. | ||||
129 | } | ||||
130 | |||||
131 | # Convert upper case OpenOffice.org date/time formats to lowercase.. | ||||
132 | $char = lc($char) if $char =~ /[DMYHS]/; | ||||
133 | |||||
134 | $formats[$section] .= $char; | ||||
135 | } | ||||
136 | |||||
137 | # Select the appropriate format from the 4 possible sub-sections: | ||||
138 | # positive numbers, negative numbers, zero values, and text. | ||||
139 | # We ignore the Text section since non-numeric values are returned | ||||
140 | # unformatted at the start of the function. | ||||
141 | my $format; | ||||
142 | $section = 0; | ||||
143 | |||||
144 | if ( @formats == 1 ) { | ||||
145 | $section = 0; | ||||
146 | } | ||||
147 | elsif ( @formats == 2 ) { | ||||
148 | if ( $number < 0 ) { | ||||
149 | $section = 1; | ||||
150 | } | ||||
151 | else { | ||||
152 | $section = 0; | ||||
153 | } | ||||
154 | } | ||||
155 | elsif ( @formats == 3 ) { | ||||
156 | if ( $number == 0 ) { | ||||
157 | $section = 2; | ||||
158 | } | ||||
159 | elsif ( $number < 0 ) { | ||||
160 | $section = 1; | ||||
161 | } | ||||
162 | else { | ||||
163 | $section = 0; | ||||
164 | } | ||||
165 | } | ||||
166 | else { | ||||
167 | $section = 0; | ||||
168 | } | ||||
169 | |||||
170 | # Override the previous choice if the format is conditional. | ||||
171 | if ($conditional_op) { | ||||
172 | if ($conditional_op eq '>') { | ||||
173 | $section = $number > $conditional_value ? 0 : 1; | ||||
174 | } elsif ($conditional_op eq '>=') { | ||||
175 | $section = $number >= $conditional_value ? 0 : 1; | ||||
176 | } elsif ($conditional_op eq '<') { | ||||
177 | $section = $number < $conditional_value ? 0 : 1; | ||||
178 | } elsif ($conditional_op eq '<=') { | ||||
179 | $section = $number <= $conditional_value ? 0 : 1; | ||||
180 | } elsif ($conditional_op eq '=') { | ||||
181 | $section = $number == $conditional_value ? 0 : 1; | ||||
182 | } elsif ($conditional_op eq '==') { | ||||
183 | $section = $number == $conditional_value ? 0 : 1; | ||||
184 | } elsif ($conditional_op eq '<>') { | ||||
185 | $section = $number != $conditional_value ? 0 : 1; | ||||
186 | } | ||||
187 | } | ||||
188 | # We now have the required format. | ||||
189 | $format = $formats[$section]; | ||||
190 | |||||
191 | # The format string can contain one of the following colours: | ||||
192 | # [Black] [Blue] [Cyan] [Green] [Magenta] [Red] [White] [Yellow] | ||||
193 | # or the string [ColorX] where x is a colour index from 1 to 56. | ||||
194 | # We don't use the colour but we return it to the caller. | ||||
195 | # | ||||
196 | my $color = ''; | ||||
197 | if ( $format =~ s/^(\[[A-Za-z]{3,}(\d{1,2})?\])// ) { | ||||
198 | $color = $1; | ||||
199 | } | ||||
200 | |||||
201 | # Remove the locale, such as [$-409], from the format string. | ||||
202 | my $locale = ''; | ||||
203 | if ( $format =~ s/^(\[\$?-F?\d+\])// ) { | ||||
204 | $locale = $1; | ||||
205 | } | ||||
206 | |||||
207 | # Replace currency locale, such as [$$-409], with $ in the format string. | ||||
208 | # See the RT#60547 test cases in 21_number_format_user.t. | ||||
209 | if ( $format =~ s/(\[\$([^-]+)(-\d+)?\])/$2/s ) { | ||||
210 | $locale = $1; | ||||
211 | } | ||||
212 | |||||
213 | |||||
214 | # Remove leading # from '# ?/?', '# ??/??' fraction formats. | ||||
215 | $format =~ s{# \?}{?}g; | ||||
216 | |||||
217 | # Parse the format string and create an AoA of placeholders that contain | ||||
218 | # the parts of the string to be replaced. The format of the information | ||||
219 | # stored is: [ $token, $start_pos, $end_pos, $option_info ]. | ||||
220 | # | ||||
221 | my $format_mode = ''; # Either: '', 'number', 'date' | ||||
222 | my $pos = 0; # Character position within format string. | ||||
223 | my @placeholders = (); # Arefs with parts of the format to be replaced. | ||||
224 | my $token = ''; # The actual format extracted from the total str. | ||||
225 | my $start_pos; # A position variable. Initial parser position. | ||||
226 | my $token_start = -1; # A position variable. | ||||
227 | my $decimal_pos = -1; # Position of the punctuation char "." or ",". | ||||
228 | my $comma_count = 0; # Count of the commas in the format. | ||||
229 | my $is_fraction = 0; # Number format is a fraction. | ||||
230 | my $is_currency = 0; # Number format is a currency. | ||||
231 | my $is_percent = 0; # Number format is a percentage. | ||||
232 | my $is_12_hour = 0; # Time format is using 12 hour clock. | ||||
233 | my $seen_dot = 0; # Treat only the first "." as the decimal point. | ||||
234 | |||||
235 | # Parse the format. | ||||
236 | PARSER: | ||||
237 | while ( $pos < length $format ) { | ||||
238 | $start_pos = $pos; | ||||
239 | my $char = substr( $format, $pos, 1 ); | ||||
240 | |||||
241 | # Ignore control format characters such as '#0+-.?eE,%'. However, | ||||
242 | # only ignore '.' if it is the first one encountered. RT 45502. | ||||
243 | if ( ( !$seen_dot && $char !~ /[#0\+\-\.\?eE\,\%]/ ) | ||||
244 | || $char !~ /[#0\+\-\?eE\,\%]/ ) | ||||
245 | { | ||||
246 | |||||
247 | if ( $token_start != -1 ) { | ||||
248 | push @placeholders, | ||||
249 | [ | ||||
250 | substr( $format, $token_start, $pos - $token_start ), | ||||
251 | $decimal_pos, $pos - $token_start | ||||
252 | ]; | ||||
253 | $token_start = -1; | ||||
254 | } | ||||
255 | } | ||||
256 | |||||
257 | # Processing for quoted strings within the format. See notes above. | ||||
258 | if ( $char eq '"' ) { | ||||
259 | $double_quote = $double_quote ? 0 : 1; | ||||
260 | $pos++; | ||||
261 | next PARSER; | ||||
262 | } | ||||
263 | elsif ( $char eq '!' ) { | ||||
264 | $single_quote = 1; | ||||
265 | $pos++; | ||||
266 | next PARSER; | ||||
267 | } | ||||
268 | elsif ( $char eq '\\' ) { | ||||
269 | if ( $single_quote != 1 ) { | ||||
270 | $single_quote = 1; | ||||
271 | $pos++; | ||||
272 | next PARSER; | ||||
273 | } | ||||
274 | } | ||||
275 | |||||
276 | if ( ( defined($double_quote) and ($double_quote) ) | ||||
277 | or ( defined($single_quote) and ($single_quote) ) | ||||
278 | or ( $seen_dot && $char eq '.' ) ) | ||||
279 | { | ||||
280 | $single_quote = 0; | ||||
281 | if ( | ||||
282 | ( $format_mode ne 'date' ) | ||||
283 | and ( ( substr( $format, $pos, 2 ) eq "\x81\xA2" ) | ||||
284 | || ( substr( $format, $pos, 2 ) eq "\x81\xA3" ) | ||||
285 | || ( substr( $format, $pos, 2 ) eq "\xA2\xA4" ) | ||||
286 | || ( substr( $format, $pos, 2 ) eq "\xA2\xA5" ) ) | ||||
287 | ) | ||||
288 | { | ||||
289 | |||||
290 | # The above matches are currency symbols. | ||||
291 | push @placeholders, | ||||
292 | [ substr( $format, $pos, 2 ), length($token), 2 ]; | ||||
293 | $is_currency = 1; | ||||
294 | $pos += 2; | ||||
295 | } | ||||
296 | else { | ||||
297 | $pos++; | ||||
298 | } | ||||
299 | } | ||||
300 | elsif ( | ||||
301 | ( $char =~ /[#0\+\.\?eE\,\%]/ ) | ||||
302 | || ( ( $format_mode ne 'date' ) | ||||
303 | and ( ( $char eq '-' ) || ( $char eq '(' ) || ( $char eq ')' ) ) | ||||
304 | ) | ||||
305 | ) | ||||
306 | { | ||||
307 | $format_mode = 'number' unless $format_mode; | ||||
308 | if ( substr( $format, $pos, 1 ) =~ /[#0]/ ) { | ||||
309 | if ( | ||||
310 | substr( $format, $pos ) =~ | ||||
311 | /^([#0]+[\.]?[0#]*[eE][\+\-][0#]+)/ ) | ||||
312 | { | ||||
313 | push @placeholders, [ $1, $pos, length($1) ]; | ||||
314 | $pos += length($1); | ||||
315 | } | ||||
316 | else { | ||||
317 | if ( $token_start == -1 ) { | ||||
318 | $token_start = $pos; | ||||
319 | $decimal_pos = length($token); | ||||
320 | } | ||||
321 | } | ||||
322 | } | ||||
323 | elsif ( substr( $format, $pos, 1 ) eq '?' ) { | ||||
324 | |||||
325 | # Look for a fraction format like ?/? or ??/?? | ||||
326 | if ( $token_start != -1 ) { | ||||
327 | push @placeholders, | ||||
328 | [ | ||||
329 | substr( | ||||
330 | $format, $token_start, $pos - $token_start + 1 | ||||
331 | ), | ||||
332 | $decimal_pos, | ||||
333 | $pos - $token_start + 1 | ||||
334 | ]; | ||||
335 | } | ||||
336 | $token_start = $pos; | ||||
337 | |||||
338 | # Find the end of the fraction format. | ||||
339 | FRACTION: | ||||
340 | while ( $pos < length($format) ) { | ||||
341 | if ( substr( $format, $pos, 1 ) eq '/' ) { | ||||
342 | $is_fraction = 1; | ||||
343 | } | ||||
344 | elsif ( substr( $format, $pos, 1 ) eq '?' ) { | ||||
345 | $pos++; | ||||
346 | next FRACTION; | ||||
347 | } | ||||
348 | else { | ||||
349 | if ( $is_fraction | ||||
350 | && ( substr( $format, $pos, 1 ) =~ /[0-9]/ ) ) | ||||
351 | { | ||||
352 | |||||
353 | # TODO: Could invert if() logic and remove this. | ||||
354 | $pos++; | ||||
355 | next FRACTION; | ||||
356 | } | ||||
357 | else { | ||||
358 | last FRACTION; | ||||
359 | } | ||||
360 | } | ||||
361 | $pos++; | ||||
362 | } | ||||
363 | $pos--; | ||||
364 | |||||
365 | push @placeholders, | ||||
366 | [ | ||||
367 | substr( $format, $token_start, $pos - $token_start + 1 ), | ||||
368 | length($token), $pos - $token_start + 1 | ||||
369 | ]; | ||||
370 | $token_start = -1; | ||||
371 | } | ||||
372 | elsif ( substr( $format, $pos, 3 ) =~ /^[eE][\+\-][0#]$/ ) { | ||||
373 | if ( substr( $format, $pos ) =~ /([eE][\+\-][0#]+)/ ) { | ||||
374 | push @placeholders, [ $1, $pos, length($1) ]; | ||||
375 | $pos += length($1); | ||||
376 | } | ||||
377 | $token_start = -1; | ||||
378 | } | ||||
379 | else { | ||||
380 | if ( $token_start != -1 ) { | ||||
381 | push @placeholders, | ||||
382 | [ | ||||
383 | substr( $format, $token_start, $pos - $token_start ), | ||||
384 | $decimal_pos, $pos - $token_start | ||||
385 | ]; | ||||
386 | $token_start = -1; | ||||
387 | } | ||||
388 | if ( substr( $format, $pos, 1 ) =~ /[\+\-]/ ) { | ||||
389 | push @placeholders, | ||||
390 | [ substr( $format, $pos, 1 ), length($token), 1 ]; | ||||
391 | $is_currency = 1; | ||||
392 | } | ||||
393 | elsif ( substr( $format, $pos, 1 ) eq '.' ) { | ||||
394 | push @placeholders, | ||||
395 | [ substr( $format, $pos, 1 ), length($token), 1 ]; | ||||
396 | $seen_dot = 1; | ||||
397 | } | ||||
398 | elsif ( substr( $format, $pos, 1 ) eq ',' ) { | ||||
399 | $comma_count++; | ||||
400 | push @placeholders, | ||||
401 | [ substr( $format, $pos, 1 ), length($token), 1 ]; | ||||
402 | } | ||||
403 | elsif ( substr( $format, $pos, 1 ) eq '%' ) { | ||||
404 | $is_percent = 1; | ||||
405 | } | ||||
406 | elsif (( substr( $format, $pos, 1 ) eq '(' ) | ||||
407 | || ( substr( $format, $pos, 1 ) eq ')' ) ) | ||||
408 | { | ||||
409 | push @placeholders, | ||||
410 | [ substr( $format, $pos, 1 ), length($token), 1 ]; | ||||
411 | $is_currency = 1; | ||||
412 | } | ||||
413 | } | ||||
414 | $pos++; | ||||
415 | } | ||||
416 | elsif ( $char =~ /[ymdhsapg]/i ) { | ||||
417 | $format_mode = 'date' unless $format_mode; | ||||
418 | if ( substr( $format, $pos, 5 ) =~ /am\/pm/i ) { | ||||
419 | push @placeholders, [ 'am/pm', length($token), 5 ]; | ||||
420 | $is_12_hour = 1; | ||||
421 | $pos += 5; | ||||
422 | } | ||||
423 | elsif ( substr( $format, $pos, 3 ) =~ /a\/p/i ) { | ||||
424 | push @placeholders, [ 'a/p', length($token), 3 ]; | ||||
425 | $is_12_hour = 1; | ||||
426 | $pos += 3; | ||||
427 | } | ||||
428 | elsif ( substr( $format, $pos, 5 ) eq 'mmmmm' ) { | ||||
429 | push @placeholders, [ 'mmmmm', length($token), 5 ]; | ||||
430 | $pos += 5; | ||||
431 | } | ||||
432 | elsif (( substr( $format, $pos, 4 ) eq 'mmmm' ) | ||||
433 | || ( substr( $format, $pos, 4 ) eq 'dddd' ) | ||||
434 | || ( substr( $format, $pos, 4 ) eq 'yyyy' ) | ||||
435 | || ( substr( $format, $pos, 4 ) eq 'ggge' ) ) | ||||
436 | { | ||||
437 | push @placeholders, | ||||
438 | [ substr( $format, $pos, 4 ), length($token), 4 ]; | ||||
439 | $pos += 4; | ||||
440 | } | ||||
441 | elsif (( substr( $format, $pos, 3 ) eq 'ddd' ) | ||||
442 | || ( substr( $format, $pos, 3 ) eq 'mmm' ) | ||||
443 | || ( substr( $format, $pos, 3 ) eq 'yyy' ) ) | ||||
444 | { | ||||
445 | push @placeholders, | ||||
446 | [ substr( $format, $pos, 3 ), length($token), 3 ]; | ||||
447 | $pos += 3; | ||||
448 | } | ||||
449 | elsif (( substr( $format, $pos, 2 ) eq 'yy' ) | ||||
450 | || ( substr( $format, $pos, 2 ) eq 'mm' ) | ||||
451 | || ( substr( $format, $pos, 2 ) eq 'dd' ) | ||||
452 | || ( substr( $format, $pos, 2 ) eq 'hh' ) | ||||
453 | || ( substr( $format, $pos, 2 ) eq 'ss' ) | ||||
454 | || ( substr( $format, $pos, 2 ) eq 'ge' ) ) | ||||
455 | { | ||||
456 | if ( | ||||
457 | ( substr( $format, $pos, 2 ) eq 'mm' ) | ||||
458 | && (@placeholders) | ||||
459 | && ( ( $placeholders[-1]->[0] eq 'h' ) | ||||
460 | or ( $placeholders[-1]->[0] eq 'hh' ) ) | ||||
461 | ) | ||||
462 | { | ||||
463 | |||||
464 | # For this case 'm' is minutes not months. | ||||
465 | push @placeholders, [ 'mm', length($token), 2, 'minutes' ]; | ||||
466 | } | ||||
467 | else { | ||||
468 | push @placeholders, | ||||
469 | [ substr( $format, $pos, 2 ), length($token), 2 ]; | ||||
470 | } | ||||
471 | if ( ( substr( $format, $pos, 2 ) eq 'ss' ) | ||||
472 | && ( @placeholders > 1 ) ) | ||||
473 | { | ||||
474 | if ( ( $placeholders[-2]->[0] eq 'm' ) | ||||
475 | || ( $placeholders[-2]->[0] eq 'mm' ) ) | ||||
476 | { | ||||
477 | |||||
478 | # For this case 'm' is minutes not months. | ||||
479 | push( @{ $placeholders[-2] }, 'minutes' ); | ||||
480 | } | ||||
481 | } | ||||
482 | $pos += 2; | ||||
483 | } | ||||
484 | elsif (( substr( $format, $pos, 1 ) eq 'm' ) | ||||
485 | || ( substr( $format, $pos, 1 ) eq 'd' ) | ||||
486 | || ( substr( $format, $pos, 1 ) eq 'h' ) | ||||
487 | || ( substr( $format, $pos, 1 ) eq 's' ) ) | ||||
488 | { | ||||
489 | if ( | ||||
490 | ( substr( $format, $pos, 1 ) eq 'm' ) | ||||
491 | && (@placeholders) | ||||
492 | && ( ( $placeholders[-1]->[0] eq 'h' ) | ||||
493 | or ( $placeholders[-1]->[0] eq 'hh' ) ) | ||||
494 | ) | ||||
495 | { | ||||
496 | |||||
497 | # For this case 'm' is minutes not months. | ||||
498 | push @placeholders, [ 'm', length($token), 1, 'minutes' ]; | ||||
499 | } | ||||
500 | else { | ||||
501 | push @placeholders, | ||||
502 | [ substr( $format, $pos, 1 ), length($token), 1 ]; | ||||
503 | } | ||||
504 | if ( ( substr( $format, $pos, 1 ) eq 's' ) | ||||
505 | && ( @placeholders > 1 ) ) | ||||
506 | { | ||||
507 | if ( ( $placeholders[-2]->[0] eq 'm' ) | ||||
508 | || ( $placeholders[-2]->[0] eq 'mm' ) ) | ||||
509 | { | ||||
510 | |||||
511 | # For this case 'm' is minutes not months. | ||||
512 | push( @{ $placeholders[-2] }, 'minutes' ); | ||||
513 | } | ||||
514 | } | ||||
515 | $pos += 1; | ||||
516 | } | ||||
517 | } | ||||
518 | elsif ( ( substr( $format, $pos, 3 ) eq '[h]' ) ) { | ||||
519 | $format_mode = 'date' unless $format_mode; | ||||
520 | push @placeholders, [ '[h]', length($token), 3 ]; | ||||
521 | $pos += 3; | ||||
522 | } | ||||
523 | elsif ( ( substr( $format, $pos, 4 ) eq '[mm]' ) ) { | ||||
524 | $format_mode = 'date' unless $format_mode; | ||||
525 | push @placeholders, [ '[mm]', length($token), 4 ]; | ||||
526 | $pos += 4; | ||||
527 | } | ||||
528 | elsif ( $char eq '@' ) { | ||||
529 | push @placeholders, [ '@', length($token), 1 ]; | ||||
530 | $pos++; | ||||
531 | } | ||||
532 | elsif ( $char eq '*' ) { | ||||
533 | push @placeholders, | ||||
534 | [ substr( $format, $pos, 1 ), length($token), 1 ]; | ||||
535 | } | ||||
536 | else { | ||||
537 | $pos++; | ||||
538 | } | ||||
539 | $pos++ if ( $pos == $start_pos ); #No Format match | ||||
540 | $token .= substr( $format, $start_pos, $pos - $start_pos ); | ||||
541 | |||||
542 | } # End of parsing. | ||||
543 | |||||
544 | # Copy the located format string to a result string that we will perform | ||||
545 | # the substitutions on and return to the user. | ||||
546 | my $result = $token; | ||||
547 | |||||
548 | # Add a placeholder between the decimal/comma and end of the token, if any. | ||||
549 | if ( $token_start != -1 ) { | ||||
550 | push @placeholders, | ||||
551 | [ | ||||
552 | substr( $format, $token_start, $pos - $token_start + 1 ), | ||||
553 | $decimal_pos, $pos - $token_start + 1 | ||||
554 | ]; | ||||
555 | } | ||||
556 | |||||
557 | # | ||||
558 | # In the next sections we process date, number and text formats. We take a | ||||
559 | # format such as yyyy/mm/dd and replace it with something like 2008/12/25. | ||||
560 | # | ||||
561 | if ( ( $format_mode eq 'date' ) && ( $number =~ $qrNUMBER ) ) { | ||||
562 | |||||
563 | # The maximum allowable date in Excel is 9999-12-31T23:59:59.000 which | ||||
564 | # equates to 2958465.999+ in the 1900 epoch and 2957003.999+ in the | ||||
565 | # 1904 epoch. We use 0 as the minimum in both epochs. The 1904 system | ||||
566 | # actually supports negative numbers but that isn't worth the effort. | ||||
567 | my $min_date = 0; | ||||
568 | my $max_date = 2958466; | ||||
569 | $max_date = 2957004 if $is_1904; | ||||
570 | |||||
571 | if ( $number < $min_date || $number >= $max_date ) { | ||||
572 | return $number; # Return unformatted number. | ||||
573 | } | ||||
574 | |||||
575 | # Process date formats. | ||||
576 | my @time = ExcelLocaltime( $number, $is_1904 ); | ||||
577 | |||||
578 | # 0 1 2 3 4 5 6 7 | ||||
579 | my ( $sec, $min, $hour, $day, $month, $year, $wday, $msec ) = @time; | ||||
580 | |||||
581 | $month++; # localtime() zero indexed month. | ||||
582 | $year += 1900; # localtime() year. | ||||
583 | |||||
584 | my @full_month_name = qw( | ||||
585 | None January February March April May June July | ||||
586 | August September October November December | ||||
587 | ); | ||||
588 | my @short_month_name = qw( | ||||
589 | None Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec | ||||
590 | ); | ||||
591 | my @full_day_name = qw( | ||||
592 | Sunday Monday Tuesday Wednesday Thursday Friday Saturday | ||||
593 | ); | ||||
594 | my @short_day_name = qw( | ||||
595 | Sun Mon Tue Wed Thu Fri Sat | ||||
596 | ); | ||||
597 | |||||
598 | # Replace the placeholders in the template such as yyyy mm dd with | ||||
599 | # actual numbers or strings. | ||||
600 | my $replacement; | ||||
601 | for my $placeholder ( reverse @placeholders ) { | ||||
602 | |||||
603 | if ( $placeholder->[-1] eq 'minutes' ) { | ||||
604 | |||||
605 | # For this case 'm/mm' is minutes not months. | ||||
606 | if ( $placeholder->[0] eq 'mm' ) { | ||||
607 | $replacement = sprintf( "%02d", $min ); | ||||
608 | } | ||||
609 | else { | ||||
610 | $replacement = sprintf( "%d", $min ); | ||||
611 | } | ||||
612 | } | ||||
613 | elsif ( $placeholder->[0] eq 'yyyy' ) { | ||||
614 | |||||
615 | # 4 digit Year. 2000 -> 2000. | ||||
616 | $replacement = sprintf( '%04d', $year ); | ||||
617 | } | ||||
618 | elsif ( $placeholder->[0] eq 'yy' ) { | ||||
619 | |||||
620 | # 2 digit Year. 2000 -> 00. | ||||
621 | $replacement = sprintf( '%02d', $year % 100 ); | ||||
622 | } | ||||
623 | elsif ( $placeholder->[0] eq 'mmmmm' ) { | ||||
624 | |||||
625 | # First character of the month name. 1 -> J. | ||||
626 | $replacement = substr( $short_month_name[$month], 0, 1 ); | ||||
627 | } | ||||
628 | elsif ( $placeholder->[0] eq 'mmmm' ) { | ||||
629 | |||||
630 | # Full month name. 1 -> January. | ||||
631 | $replacement = $full_month_name[$month]; | ||||
632 | } | ||||
633 | elsif ( $placeholder->[0] eq 'mmm' ) { | ||||
634 | |||||
635 | # Short month name. 1 -> Jan. | ||||
636 | $replacement = $short_month_name[$month]; | ||||
637 | } | ||||
638 | elsif ( $placeholder->[0] eq 'mm' ) { | ||||
639 | |||||
640 | # 2 digit month. 1 -> 01. | ||||
641 | $replacement = sprintf( '%02d', $month ); | ||||
642 | } | ||||
643 | elsif ( $placeholder->[0] eq 'm' ) { | ||||
644 | |||||
645 | # 1 digit month. 1 -> 1. | ||||
646 | $replacement = sprintf( '%d', $month ); | ||||
647 | } | ||||
648 | elsif ( $placeholder->[0] eq 'dddd' ) { | ||||
649 | |||||
650 | # Full day name. Wednesday (for example.) | ||||
651 | $replacement = $full_day_name[$wday]; | ||||
652 | } | ||||
653 | elsif ( $placeholder->[0] eq 'ddd' ) { | ||||
654 | |||||
655 | # Short day name. Wed (for example.) | ||||
656 | $replacement = $short_day_name[$wday]; | ||||
657 | } | ||||
658 | elsif ( $placeholder->[0] eq 'dd' ) { | ||||
659 | |||||
660 | # 2 digit day. 1 -> 01. | ||||
661 | $replacement = sprintf( '%02d', $day ); | ||||
662 | } | ||||
663 | elsif ( $placeholder->[0] eq 'd' ) { | ||||
664 | |||||
665 | # 1 digit day. 1 -> 1. | ||||
666 | $replacement = sprintf( '%d', $day ); | ||||
667 | } | ||||
668 | elsif ( $placeholder->[0] eq 'hh' ) { | ||||
669 | |||||
670 | # 2 digit hour. | ||||
671 | if ($is_12_hour) { | ||||
672 | my $hour_tmp = $hour % 12; | ||||
673 | $hour_tmp = 12 if $hour % 12 == 0; | ||||
674 | $replacement = sprintf( '%d', $hour_tmp ); | ||||
675 | } | ||||
676 | else { | ||||
677 | $replacement = sprintf( '%02d', $hour ); | ||||
678 | } | ||||
679 | } | ||||
680 | elsif ( $placeholder->[0] eq 'h' ) { | ||||
681 | |||||
682 | # 1 digit hour. | ||||
683 | if ($is_12_hour) { | ||||
684 | my $hour_tmp = $hour % 12; | ||||
685 | $hour_tmp = 12 if $hour % 12 == 0; | ||||
686 | $replacement = sprintf( '%2d', $hour_tmp ); | ||||
687 | } | ||||
688 | else { | ||||
689 | $replacement = sprintf( '%d', $hour ); | ||||
690 | } | ||||
691 | } | ||||
692 | elsif ( $placeholder->[0] eq 'ss' ) { | ||||
693 | |||||
694 | # 2 digit seconds. | ||||
695 | $replacement = sprintf( '%02d', $sec ); | ||||
696 | } | ||||
697 | elsif ( $placeholder->[0] eq 's' ) { | ||||
698 | |||||
699 | # 1 digit seconds. | ||||
700 | $replacement = sprintf( '%d', $sec ); | ||||
701 | } | ||||
702 | elsif ( $placeholder->[0] eq 'am/pm' ) { | ||||
703 | |||||
704 | # AM/PM. | ||||
705 | $replacement = ( $hour >= 12 ) ? 'PM' : 'AM'; | ||||
706 | } | ||||
707 | elsif ( $placeholder->[0] eq 'a/p' ) { | ||||
708 | |||||
709 | # AM/PM. | ||||
710 | $replacement = ( $hour >= 12 ) ? 'P' : 'A'; | ||||
711 | } | ||||
712 | elsif ( $placeholder->[0] eq '.' ) { | ||||
713 | |||||
714 | # Decimal point for seconds. | ||||
715 | $replacement = '.'; | ||||
716 | } | ||||
717 | elsif ( $placeholder->[0] =~ /(^0+$)/ ) { | ||||
718 | |||||
719 | # Milliseconds. For example h:ss.000. | ||||
720 | my $length = length($1); | ||||
721 | $replacement = | ||||
722 | substr( sprintf( "%.${length}f", $msec / 1000 ), 2, $length ); | ||||
723 | } | ||||
724 | elsif ( $placeholder->[0] eq '[h]' ) { | ||||
725 | |||||
726 | # Hours modulus 24. 25 displays as 25 not as 1. | ||||
727 | $replacement = sprintf( '%d', int($number) * 24 + $hour ); | ||||
728 | } | ||||
729 | elsif ( $placeholder->[0] eq '[mm]' ) { | ||||
730 | |||||
731 | # Mins modulus 60. 72 displays as 72 not as 12. | ||||
732 | $replacement = | ||||
733 | sprintf( '%d', ( int($number) * 24 + $hour ) * 60 + $min ); | ||||
734 | } | ||||
735 | elsif ( $placeholder->[0] eq 'ge' ) { | ||||
736 | require Spreadsheet::ParseExcel::FmtJapan; | ||||
737 | # Japanese Nengo (aka Gengo) in initialism (abbr. name) | ||||
738 | $replacement = | ||||
739 | Spreadsheet::ParseExcel::FmtJapan::CnvNengo( abbr_name => @time ); | ||||
740 | } | ||||
741 | elsif ( $placeholder->[0] eq 'ggge' ) { | ||||
742 | require Spreadsheet::ParseExcel::FmtJapan; | ||||
743 | # Japanese Nengo (aka Gengo) in Kanji (full name) | ||||
744 | $replacement = | ||||
745 | Spreadsheet::ParseExcel::FmtJapan::CnvNengo( name => @time ); | ||||
746 | } | ||||
747 | elsif ( $placeholder->[0] eq '@' ) { | ||||
748 | |||||
749 | # Text format. | ||||
750 | $replacement = $number; | ||||
751 | } | ||||
752 | elsif ( $placeholder->[0] eq ',' ) { | ||||
753 | next; | ||||
754 | } | ||||
755 | |||||
756 | # Substitute the replacement string back into the template. | ||||
757 | substr( $result, $placeholder->[1], $placeholder->[2], | ||||
758 | $replacement ); | ||||
759 | } | ||||
760 | } | ||||
761 | elsif ( ( $format_mode eq 'number' ) && ( $number =~ $qrNUMBER ) ) { | ||||
762 | |||||
763 | # Process non date formats. | ||||
764 | if (@placeholders) { | ||||
765 | while ( $placeholders[-1]->[0] eq ',' ) { | ||||
766 | $comma_count--; | ||||
767 | substr( | ||||
768 | $result, | ||||
769 | $placeholders[-1]->[1], | ||||
770 | $placeholders[-1]->[2], '' | ||||
771 | ); | ||||
772 | $number /= 1000; | ||||
773 | pop @placeholders; | ||||
774 | } | ||||
775 | |||||
776 | my $number_format = join( '', map { $_->[0] } @placeholders ); | ||||
777 | my $number_result; | ||||
778 | my $str_length = 0; | ||||
779 | my $engineering = 0; | ||||
780 | my $is_decimal = 0; | ||||
781 | my $is_integer = 0; | ||||
782 | my $after_decimal = undef; | ||||
783 | |||||
784 | for my $token ( split //, $number_format ) { | ||||
785 | if ( $token eq '.' ) { | ||||
786 | $str_length++; | ||||
787 | $is_decimal = 1; | ||||
788 | } | ||||
789 | elsif ( ( $token eq 'E' ) || ( $token eq 'e' ) ) { | ||||
790 | $engineering = 1; | ||||
791 | } | ||||
792 | elsif ( $token eq '0' ) { | ||||
793 | $str_length++; | ||||
794 | $after_decimal++ if $is_decimal; | ||||
795 | $is_integer = 1; | ||||
796 | } | ||||
797 | elsif ( $token eq '#' ) { | ||||
798 | $after_decimal++ if $is_decimal; | ||||
799 | $is_integer = 1; | ||||
800 | } | ||||
801 | elsif ( $token eq '?' ) { | ||||
802 | $after_decimal++ if $is_decimal; | ||||
803 | } | ||||
804 | } | ||||
805 | |||||
806 | $number *= 100.0 if $is_percent; | ||||
807 | |||||
808 | my $data = ($is_currency) ? abs($number) : $number + 0; | ||||
809 | |||||
810 | if ($is_fraction) { | ||||
811 | $number_result = sprintf( "%0${str_length}d", int($data) ); | ||||
812 | } | ||||
813 | else { | ||||
814 | if ($is_decimal) { | ||||
815 | |||||
816 | if ( defined $after_decimal ) { | ||||
817 | $number_result = | ||||
818 | sprintf "%0${str_length}.${after_decimal}f", $data; | ||||
819 | } | ||||
820 | else { | ||||
821 | $number_result = sprintf "%0${str_length}f", $data; | ||||
822 | } | ||||
823 | |||||
824 | # Fix for Perl and sprintf not rounding up like Excel. | ||||
825 | # http://rt.cpan.org/Public/Bug/Display.html?id=45626 | ||||
826 | if ( $data =~ /^${number_result}5/ ) { | ||||
827 | $number_result = | ||||
828 | sprintf "%0${str_length}.${after_decimal}f", | ||||
829 | $data . '1'; | ||||
830 | } | ||||
831 | } | ||||
832 | else { | ||||
833 | $number_result = sprintf( "%0${str_length}.0f", $data ); | ||||
834 | } | ||||
835 | } | ||||
836 | |||||
837 | $number_result = AddComma($number_result) if $comma_count > 0; | ||||
838 | |||||
839 | my $number_length = length($number_result); | ||||
840 | my $decimal_pos = -1; | ||||
841 | my $replacement; | ||||
842 | |||||
843 | for ( my $i = @placeholders - 1 ; $i >= 0 ; $i-- ) { | ||||
844 | my $placeholder = $placeholders[$i]; | ||||
845 | |||||
846 | if ( $placeholder->[0] =~ | ||||
847 | /([#0]*)([\.]?)([0#]*)([eE])([\+\-])([0#]+)/ ) | ||||
848 | { | ||||
849 | substr( $result, $placeholder->[1], $placeholder->[2], | ||||
850 | MakeE( $placeholder->[0], $number ) ); | ||||
851 | } | ||||
852 | elsif ( $placeholder->[0] =~ /\// ) { | ||||
853 | substr( $result, $placeholder->[1], $placeholder->[2], | ||||
854 | MakeFraction( $placeholder->[0], $number, $is_integer ) | ||||
855 | ); | ||||
856 | } | ||||
857 | elsif ( $placeholder->[0] eq '.' ) { | ||||
858 | $number_length--; | ||||
859 | $decimal_pos = $number_length; | ||||
860 | } | ||||
861 | elsif ( $placeholder->[0] eq '+' ) { | ||||
862 | substr( $result, $placeholder->[1], $placeholder->[2], | ||||
863 | ( $number > 0 ) | ||||
864 | ? '+' | ||||
865 | : ( ( $number == 0 ) ? '+' : '-' ) ); | ||||
866 | } | ||||
867 | elsif ( $placeholder->[0] eq '-' ) { | ||||
868 | substr( $result, $placeholder->[1], $placeholder->[2], | ||||
869 | ( $number > 0 ) | ||||
870 | ? '' | ||||
871 | : ( ( $number == 0 ) ? '' : '-' ) ); | ||||
872 | } | ||||
873 | elsif ( $placeholder->[0] eq '@' ) { | ||||
874 | substr( $result, $placeholder->[1], $placeholder->[2], | ||||
875 | $number ); | ||||
876 | } | ||||
877 | elsif ( $placeholder->[0] eq '*' ) { | ||||
878 | substr( $result, $placeholder->[1], $placeholder->[2], '' ); | ||||
879 | } | ||||
880 | elsif (( $placeholder->[0] eq "\xA2\xA4" ) | ||||
881 | or ( $placeholder->[0] eq "\xA2\xA5" ) | ||||
882 | or ( $placeholder->[0] eq "\x81\xA2" ) | ||||
883 | or ( $placeholder->[0] eq "\x81\xA3" ) ) | ||||
884 | { | ||||
885 | substr( | ||||
886 | $result, $placeholder->[1], | ||||
887 | $placeholder->[2], $placeholder->[0] | ||||
888 | ); | ||||
889 | } | ||||
890 | elsif (( $placeholder->[0] eq '(' ) | ||||
891 | or ( $placeholder->[0] eq ')' ) ) | ||||
892 | { | ||||
893 | substr( | ||||
894 | $result, $placeholder->[1], | ||||
895 | $placeholder->[2], $placeholder->[0] | ||||
896 | ); | ||||
897 | } | ||||
898 | else { | ||||
899 | if ( $number_length > 0 ) { | ||||
900 | if ( $i <= 0 ) { | ||||
901 | $replacement = | ||||
902 | substr( $number_result, 0, $number_length ); | ||||
903 | $number_length = 0; | ||||
904 | } | ||||
905 | else { | ||||
906 | my $real_part_length = length( $placeholder->[0] ); | ||||
907 | if ( $decimal_pos >= 0 ) { | ||||
908 | my $format = $placeholder->[0]; | ||||
909 | $format =~ s/^#+//; | ||||
910 | $real_part_length = length $format; | ||||
911 | $real_part_length = | ||||
912 | ( $number_length <= $real_part_length ) | ||||
913 | ? $number_length | ||||
914 | : $real_part_length; | ||||
915 | } | ||||
916 | else { | ||||
917 | $real_part_length = | ||||
918 | ( $number_length <= $real_part_length ) | ||||
919 | ? $number_length | ||||
920 | : $real_part_length; | ||||
921 | } | ||||
922 | $replacement = | ||||
923 | substr( $number_result, | ||||
924 | $number_length - $real_part_length, | ||||
925 | $real_part_length ); | ||||
926 | $number_length -= $real_part_length; | ||||
927 | } | ||||
928 | } | ||||
929 | else { | ||||
930 | $replacement = ''; | ||||
931 | } | ||||
932 | substr( $result, $placeholder->[1], $placeholder->[2], | ||||
933 | "\x00" . $replacement ); | ||||
934 | } | ||||
935 | } | ||||
936 | $replacement = | ||||
937 | ( $number_length > 0 ) | ||||
938 | ? substr( $number_result, 0, $number_length ) | ||||
939 | : ''; | ||||
940 | $result =~ s/\x00/$replacement/; | ||||
941 | $result =~ s/\x00//g; | ||||
942 | } | ||||
943 | } | ||||
944 | else { | ||||
945 | |||||
946 | # Process text formats | ||||
947 | my $is_text = 0; | ||||
948 | for ( my $i = @placeholders - 1 ; $i >= 0 ; $i-- ) { | ||||
949 | my $placeholder = $placeholders[$i]; | ||||
950 | if ( $placeholder->[0] eq '@' ) { | ||||
951 | substr( $result, $placeholder->[1], $placeholder->[2], | ||||
952 | $number ); | ||||
953 | $is_text++; | ||||
954 | } | ||||
955 | else { | ||||
956 | substr( $result, $placeholder->[1], $placeholder->[2], '' ); | ||||
957 | } | ||||
958 | } | ||||
959 | |||||
960 | $result = $number unless $is_text; | ||||
961 | |||||
962 | } # End of placeholder substitutions. | ||||
963 | |||||
964 | # Trim the leading and trailing whitespace from the results. | ||||
965 | $result =~ s/^\s+//; | ||||
966 | $result =~ s/\s+$//; | ||||
967 | |||||
968 | # Fix for negative currency. | ||||
969 | $result =~ s/^\$\-/\-\$/; | ||||
970 | $result =~ s/^\$ \-/\-\$ /; | ||||
971 | |||||
972 | # Return color and locale strings if required. | ||||
973 | if ($want_subformats) { | ||||
974 | return ( $result, $color, $locale ); | ||||
975 | } | ||||
976 | else { | ||||
977 | return $result; | ||||
978 | } | ||||
979 | } | ||||
980 | |||||
981 | #------------------------------------------------------------------------------ | ||||
982 | # AddComma (for Spreadsheet::ParseExcel::Utility) | ||||
983 | #------------------------------------------------------------------------------ | ||||
984 | sub AddComma { | ||||
985 | my ($sNum) = @_; | ||||
986 | |||||
987 | if ( $sNum =~ /^([^\d]*)(\d\d\d\d+)(\.*.*)$/ ) { | ||||
988 | my ( $sPre, $sObj, $sAft ) = ( $1, $2, $3 ); | ||||
989 | for ( my $i = length($sObj) - 3 ; $i > 0 ; $i -= 3 ) { | ||||
990 | substr( $sObj, $i, 0, ',' ); | ||||
991 | } | ||||
992 | return $sPre . $sObj . $sAft; | ||||
993 | } | ||||
994 | else { | ||||
995 | return $sNum; | ||||
996 | } | ||||
997 | } | ||||
998 | |||||
999 | #------------------------------------------------------------------------------ | ||||
1000 | # MakeFraction (for Spreadsheet::ParseExcel::Utility) | ||||
1001 | #------------------------------------------------------------------------------ | ||||
1002 | sub MakeFraction { | ||||
1003 | my ( $sFmt, $iData, $iFlg ) = @_; | ||||
1004 | my $iBunbo; | ||||
1005 | my $iShou; | ||||
1006 | |||||
1007 | #1. Init | ||||
1008 | # print "FLG: $iFlg\n"; | ||||
1009 | if ($iFlg) { | ||||
1010 | $iShou = $iData - int($iData); | ||||
1011 | return '' if ( $iShou == 0 ); | ||||
1012 | } | ||||
1013 | else { | ||||
1014 | $iShou = $iData; | ||||
1015 | } | ||||
1016 | $iShou = abs($iShou); | ||||
1017 | my $sSWk; | ||||
1018 | |||||
1019 | #2.Calc BUNBO | ||||
1020 | #2.1 BUNBO defined | ||||
1021 | if ( $sFmt =~ /\/(\d+)$/ ) { | ||||
1022 | $iBunbo = $1; | ||||
1023 | return sprintf( "%d/%d", $iShou * $iBunbo, $iBunbo ); | ||||
1024 | } | ||||
1025 | else { | ||||
1026 | |||||
1027 | #2.2 Calc BUNBO | ||||
1028 | $sFmt =~ /\/(\?+)$/; | ||||
1029 | my $iKeta = length($1); | ||||
1030 | my $iSWk = 1; | ||||
1031 | my $sSWk = ''; | ||||
1032 | my $iBunsi; | ||||
1033 | for ( my $iBunbo = 2 ; $iBunbo < 10**$iKeta ; $iBunbo++ ) { | ||||
1034 | $iBunsi = int( $iShou * $iBunbo + 0.5 ); | ||||
1035 | my $iCmp = abs( $iShou - ( $iBunsi / $iBunbo ) ); | ||||
1036 | if ( $iCmp < $iSWk ) { | ||||
1037 | $iSWk = $iCmp; | ||||
1038 | $sSWk = sprintf( "%d/%d", $iBunsi, $iBunbo ); | ||||
1039 | last if ( $iSWk == 0 ); | ||||
1040 | } | ||||
1041 | } | ||||
1042 | return $sSWk; | ||||
1043 | } | ||||
1044 | } | ||||
1045 | |||||
1046 | #------------------------------------------------------------------------------ | ||||
1047 | # MakeE (for Spreadsheet::ParseExcel::Utility) | ||||
1048 | #------------------------------------------------------------------------------ | ||||
1049 | sub MakeE { | ||||
1050 | my ( $sFmt, $iData ) = @_; | ||||
1051 | |||||
1052 | $sFmt =~ /(([#0]*)[\.]?[#0]*)([eE])([\+\-][0#]+)/; | ||||
1053 | my ( $sKari, $iKeta, $sE, $sSisu ) = ( $1, length($2), $3, $4 ); | ||||
1054 | $iKeta = 1 if ( $iKeta <= 0 ); | ||||
1055 | |||||
1056 | my $iLog10 = 0; | ||||
1057 | $iLog10 = ( $iData == 0 ) ? 0 : ( log( abs($iData) ) / log(10) ); | ||||
1058 | $iLog10 = ( | ||||
1059 | int( $iLog10 / $iKeta ) + | ||||
1060 | ( ( ( $iLog10 - int( $iLog10 / $iKeta ) ) < 0 ) ? -1 : 0 ) ) * $iKeta; | ||||
1061 | |||||
1062 | my $sUe = ExcelFmt( $sKari, $iData * ( 10**( $iLog10 * -1 ) ), 0 ); | ||||
1063 | my $sShita = ExcelFmt( $sSisu, $iLog10, 0 ); | ||||
1064 | return $sUe . $sE . $sShita; | ||||
1065 | } | ||||
1066 | |||||
1067 | #------------------------------------------------------------------------------ | ||||
1068 | # LeapYear (for Spreadsheet::ParseExcel::Utility) | ||||
1069 | #------------------------------------------------------------------------------ | ||||
1070 | sub LeapYear { | ||||
1071 | my ($iYear) = @_; | ||||
1072 | return 1 if ( $iYear == 1900 ); #Special for Excel | ||||
1073 | return ( ( ( $iYear % 4 ) == 0 ) | ||||
1074 | && ( ( $iYear % 100 ) || ( $iYear % 400 ) == 0 ) ) | ||||
1075 | ? 1 | ||||
1076 | : 0; | ||||
1077 | } | ||||
1078 | |||||
1079 | #------------------------------------------------------------------------------ | ||||
1080 | # LocaltimeExcel (for Spreadsheet::ParseExcel::Utility) | ||||
1081 | #------------------------------------------------------------------------------ | ||||
1082 | sub LocaltimeExcel { | ||||
1083 | my ( $iSec, $iMin, $iHour, $iDay, $iMon, $iYear, $iwDay, $iMSec, $flg1904 ) | ||||
1084 | = @_; | ||||
1085 | |||||
1086 | #0. Init | ||||
1087 | $iMon++; | ||||
1088 | $iYear += 1900; | ||||
1089 | |||||
1090 | #1. Calc Time | ||||
1091 | my $iTime; | ||||
1092 | $iTime = $iHour; | ||||
1093 | $iTime *= 60; | ||||
1094 | $iTime += $iMin; | ||||
1095 | $iTime *= 60; | ||||
1096 | $iTime += $iSec; | ||||
1097 | $iTime += $iMSec / 1000.0 if ( defined($iMSec) ); | ||||
1098 | $iTime /= 86400.0; #3600*24(1day in seconds) | ||||
1099 | my $iY; | ||||
1100 | my $iYDays; | ||||
1101 | |||||
1102 | #2. Calc Days | ||||
1103 | if ($flg1904) { | ||||
1104 | $iY = 1904; | ||||
1105 | $iTime--; #Start from Jan 1st | ||||
1106 | $iYDays = 366; | ||||
1107 | } | ||||
1108 | else { | ||||
1109 | $iY = 1900; | ||||
1110 | $iYDays = 366; #In Excel 1900 is leap year (That's not TRUE!) | ||||
1111 | } | ||||
1112 | while ( $iY < $iYear ) { | ||||
1113 | $iTime += $iYDays; | ||||
1114 | $iY++; | ||||
1115 | $iYDays = ( LeapYear($iY) ) ? 366 : 365; | ||||
1116 | } | ||||
1117 | for ( my $iM = 1 ; $iM < $iMon ; $iM++ ) { | ||||
1118 | if ( $iM == 1 | ||||
1119 | || $iM == 3 | ||||
1120 | || $iM == 5 | ||||
1121 | || $iM == 7 | ||||
1122 | || $iM == 8 | ||||
1123 | || $iM == 10 | ||||
1124 | || $iM == 12 ) | ||||
1125 | { | ||||
1126 | $iTime += 31; | ||||
1127 | } | ||||
1128 | elsif ( $iM == 4 || $iM == 6 || $iM == 9 || $iM == 11 ) { | ||||
1129 | $iTime += 30; | ||||
1130 | } | ||||
1131 | elsif ( $iM == 2 ) { | ||||
1132 | $iTime += ( LeapYear($iYear) ) ? 29 : 28; | ||||
1133 | } | ||||
1134 | } | ||||
1135 | $iTime += $iDay; | ||||
1136 | return $iTime; | ||||
1137 | } | ||||
1138 | |||||
1139 | 1 | 800ns | my @month_days = qw( | ||
1140 | 0 31 28 31 30 31 30 31 31 30 31 30 31 | ||||
1141 | ); | ||||
1142 | |||||
1143 | #------------------------------------------------------------------------------ | ||||
1144 | # ExcelLocaltime (for Spreadsheet::ParseExcel::Utility) | ||||
1145 | #------------------------------------------------------------------------------ | ||||
1146 | sub ExcelLocaltime { | ||||
1147 | |||||
1148 | my ( $dObj, $flg1904 ) = @_; | ||||
1149 | my ( $iSec, $iMin, $iHour, $iDay, $iMon, $iYear, $iwDay, $iMSec ); | ||||
1150 | my ( $iDt, $iTime, $iYDays, $iMD ); | ||||
1151 | |||||
1152 | $iDt = int($dObj); | ||||
1153 | $iTime = $dObj - $iDt; | ||||
1154 | |||||
1155 | #1. Calc Days | ||||
1156 | if ($flg1904) { | ||||
1157 | $iYear = 1904; | ||||
1158 | $iDt++; #Start from Jan 1st | ||||
1159 | $iYDays = 366; | ||||
1160 | $iwDay = ( ( $iDt + 4 ) % 7 ); | ||||
1161 | } | ||||
1162 | else { | ||||
1163 | $iYear = 1900; | ||||
1164 | $iYDays = 366; #In Excel 1900 is leap year (That's not TRUE!) | ||||
1165 | $iwDay = ( ( $iDt + 6 ) % 7 ); | ||||
1166 | } | ||||
1167 | while ( $iDt > $iYDays ) { | ||||
1168 | $iDt -= $iYDays; | ||||
1169 | $iYear++; | ||||
1170 | $iYDays = | ||||
1171 | ( ( ( $iYear % 4 ) == 0 ) | ||||
1172 | && ( ( $iYear % 100 ) || ( $iYear % 400 ) == 0 ) ) ? 366 : 365; | ||||
1173 | } | ||||
1174 | $iYear -= 1900; # Localtime year is relative to 1900. | ||||
1175 | |||||
1176 | for ( $iMon = 1 ; $iMon <= 12 ; $iMon++ ) { | ||||
1177 | $iMD = $month_days[$iMon]; | ||||
1178 | $iMD++ if $iMon == 2 and $iYear % 4 == 0; | ||||
1179 | |||||
1180 | last if ( $iDt <= $iMD ); | ||||
1181 | $iDt -= $iMD; | ||||
1182 | } | ||||
1183 | |||||
1184 | #2. Calc Time | ||||
1185 | $iDay = $iDt; | ||||
1186 | $iTime += ( 0.0005 / 86400.0 ); | ||||
1187 | if ($iTime >= 1.0) | ||||
1188 | { | ||||
1189 | $iTime -= int($iTime); | ||||
1190 | $iwDay = ($iwDay == 6) ? 0 : $iwDay + 1; | ||||
1191 | if ($iDay == $iMD) | ||||
1192 | { | ||||
1193 | if ($iMon == 12) | ||||
1194 | { | ||||
1195 | $iMon = 1; | ||||
1196 | $iYear++; | ||||
1197 | } | ||||
1198 | else | ||||
1199 | { | ||||
1200 | $iMon++; | ||||
1201 | } | ||||
1202 | $iDay = 1; | ||||
1203 | } | ||||
1204 | else | ||||
1205 | { | ||||
1206 | $iDay++; | ||||
1207 | } | ||||
1208 | } | ||||
1209 | |||||
1210 | # Localtime month is 0 based. | ||||
1211 | $iMon -= 1; | ||||
1212 | $iTime *= 24.0; | ||||
1213 | $iHour = int($iTime); | ||||
1214 | $iTime -= $iHour; | ||||
1215 | $iTime *= 60.0; | ||||
1216 | $iMin = int($iTime); | ||||
1217 | $iTime -= $iMin; | ||||
1218 | $iTime *= 60.0; | ||||
1219 | $iSec = int($iTime); | ||||
1220 | $iTime -= $iSec; | ||||
1221 | $iTime *= 1000.0; | ||||
1222 | $iMSec = int($iTime); | ||||
1223 | |||||
1224 | return ( $iSec, $iMin, $iHour, $iDay, $iMon, $iYear, $iwDay, $iMSec ); | ||||
1225 | } | ||||
1226 | |||||
1227 | # ----------------------------------------------------------------------------- | ||||
1228 | # col2int (for Spreadsheet::ParseExcel::Utility) | ||||
1229 | #------------------------------------------------------------------------------ | ||||
1230 | # converts a excel row letter into an int for use in an array | ||||
1231 | sub col2int { | ||||
1232 | my $result = 0; | ||||
1233 | my $str = shift; | ||||
1234 | my $incr = 0; | ||||
1235 | |||||
1236 | for ( my $i = length($str) ; $i > 0 ; $i-- ) { | ||||
1237 | my $char = substr( $str, $i - 1 ); | ||||
1238 | my $curr += ord( lc($char) ) - ord('a') + 1; | ||||
1239 | $curr *= $incr if ($incr); | ||||
1240 | $result += $curr; | ||||
1241 | $incr += 26; | ||||
1242 | } | ||||
1243 | |||||
1244 | # this is one out as we range 0..x-1 not 1..x | ||||
1245 | $result--; | ||||
1246 | |||||
1247 | return $result; | ||||
1248 | } | ||||
1249 | |||||
1250 | # ----------------------------------------------------------------------------- | ||||
1251 | # int2col (for Spreadsheet::ParseExcel::Utility) | ||||
1252 | #------------------------------------------------------------------------------ | ||||
1253 | ### int2col | ||||
1254 | # convert a column number into column letters | ||||
1255 | # @note this is quite a brute force coarse method | ||||
1256 | # does not manage values over 701 (ZZ) | ||||
1257 | # @arg number, to convert | ||||
1258 | # @returns string, column name | ||||
1259 | # | ||||
1260 | sub int2col { | ||||
1261 | my $out = ""; | ||||
1262 | my $val = shift; | ||||
1263 | |||||
1264 | do { | ||||
1265 | $out .= chr( ( $val % 26 ) + ord('A') ); | ||||
1266 | $val = int( $val / 26 ) - 1; | ||||
1267 | } while ( $val >= 0 ); | ||||
1268 | |||||
1269 | return scalar reverse $out; | ||||
1270 | } | ||||
1271 | |||||
1272 | # ----------------------------------------------------------------------------- | ||||
1273 | # sheetRef (for Spreadsheet::ParseExcel::Utility) | ||||
1274 | #------------------------------------------------------------------------------ | ||||
1275 | # ----------------------------------------------------------------------------- | ||||
1276 | ### sheetRef | ||||
1277 | # convert an excel letter-number address into a useful array address | ||||
1278 | # @note that also Excel uses X-Y notation, we normally use Y-X in arrays | ||||
1279 | # @args $str, excel coord eg. A2 | ||||
1280 | # @returns an array - 2 elements - column, row, or undefined | ||||
1281 | # | ||||
1282 | sub sheetRef { | ||||
1283 | my $str = shift; | ||||
1284 | my @ret; | ||||
1285 | |||||
1286 | $str =~ m/^(\D+)(\d+)$/; | ||||
1287 | |||||
1288 | if ( $1 && $2 ) { | ||||
1289 | push( @ret, $2 - 1, col2int($1) ); | ||||
1290 | } | ||||
1291 | if ( $ret[0] < 0 ) { | ||||
1292 | undef @ret; | ||||
1293 | } | ||||
1294 | |||||
1295 | return @ret; | ||||
1296 | } | ||||
1297 | |||||
1298 | # ----------------------------------------------------------------------------- | ||||
1299 | # xls2csv (for Spreadsheet::ParseExcel::Utility) | ||||
1300 | #------------------------------------------------------------------------------ | ||||
1301 | ### xls2csv | ||||
1302 | # convert a chunk of an excel file into csv text chunk | ||||
1303 | # @args $param, sheet-colrow:colrow (1-A1:B2 or A1:B2 for sheet 1 | ||||
1304 | # @args $rotate, 0 or 1 decides if output should be rotated or not | ||||
1305 | # @returns string containing a chunk of csv | ||||
1306 | # | ||||
1307 | sub xls2csv { | ||||
1308 | my ( $filename, $regions, $rotate ) = @_; | ||||
1309 | my $sheet = 0; | ||||
1310 | |||||
1311 | # We need Text::CSV_XS for proper CSV handling. | ||||
1312 | require Text::CSV_XS; | ||||
1313 | |||||
1314 | # extract any sheet number from the region string | ||||
1315 | $regions =~ m/^(\d+)-(.*)/; | ||||
1316 | |||||
1317 | if ($2) { | ||||
1318 | $sheet = $1 - 1; | ||||
1319 | $regions = $2; | ||||
1320 | } | ||||
1321 | |||||
1322 | # now extract the start and end regions | ||||
1323 | $regions =~ m/(.*):(.*)/; | ||||
1324 | |||||
1325 | if ( !$1 || !$2 ) { | ||||
1326 | print STDERR "Bad Params"; | ||||
1327 | return ""; | ||||
1328 | } | ||||
1329 | |||||
1330 | my @start = sheetRef($1); | ||||
1331 | my @end = sheetRef($2); | ||||
1332 | if ( !@start ) { | ||||
1333 | print STDERR "Bad coorinates - $1"; | ||||
1334 | return ""; | ||||
1335 | } | ||||
1336 | if ( !@end ) { | ||||
1337 | print STDERR "Bad coorinates - $2"; | ||||
1338 | return ""; | ||||
1339 | } | ||||
1340 | |||||
1341 | if ( $start[1] > $end[1] ) { | ||||
1342 | print STDERR "Bad COLUMN ordering\n"; | ||||
1343 | print STDERR "Start column " . int2col( $start[1] ); | ||||
1344 | print STDERR " after end column " . int2col( $end[1] ) . "\n"; | ||||
1345 | return ""; | ||||
1346 | } | ||||
1347 | if ( $start[0] > $end[0] ) { | ||||
1348 | print STDERR "Bad ROW ordering\n"; | ||||
1349 | print STDERR "Start row " . ( $start[0] + 1 ); | ||||
1350 | print STDERR " after end row " . ( $end[0] + 1 ) . "\n"; | ||||
1351 | exit; | ||||
1352 | } | ||||
1353 | |||||
1354 | # start the excel object now | ||||
1355 | my $oExcel = new Spreadsheet::ParseExcel; | ||||
1356 | my $oBook = $oExcel->Parse($filename); | ||||
1357 | |||||
1358 | # open the sheet | ||||
1359 | my $oWkS = $oBook->{Worksheet}[$sheet]; | ||||
1360 | |||||
1361 | # now check that the region exists in the file | ||||
1362 | # if not truncate to the possible region | ||||
1363 | # output a warning msg | ||||
1364 | if ( $start[1] < $oWkS->{MinCol} ) { | ||||
1365 | print STDERR int2col( $start[1] ) | ||||
1366 | . " < min col " | ||||
1367 | . int2col( $oWkS->{MinCol} ) | ||||
1368 | . " Resetting\n"; | ||||
1369 | $start[1] = $oWkS->{MinCol}; | ||||
1370 | } | ||||
1371 | if ( $end[1] > $oWkS->{MaxCol} ) { | ||||
1372 | print STDERR int2col( $end[1] ) | ||||
1373 | . " > max col " | ||||
1374 | . int2col( $oWkS->{MaxCol} ) | ||||
1375 | . " Resetting\n"; | ||||
1376 | $end[1] = $oWkS->{MaxCol}; | ||||
1377 | } | ||||
1378 | if ( $start[0] < $oWkS->{MinRow} ) { | ||||
1379 | print STDERR "" | ||||
1380 | . ( $start[0] + 1 ) | ||||
1381 | . " < min row " | ||||
1382 | . ( $oWkS->{MinRow} + 1 ) | ||||
1383 | . " Resetting\n"; | ||||
1384 | $start[0] = $oWkS->{MinCol}; | ||||
1385 | } | ||||
1386 | if ( $end[0] > $oWkS->{MaxRow} ) { | ||||
1387 | print STDERR "" | ||||
1388 | . ( $end[0] + 1 ) | ||||
1389 | . " > max row " | ||||
1390 | . ( $oWkS->{MaxRow} + 1 ) | ||||
1391 | . " Resetting\n"; | ||||
1392 | $end[0] = $oWkS->{MaxRow}; | ||||
1393 | |||||
1394 | } | ||||
1395 | |||||
1396 | my $x1 = $start[1]; | ||||
1397 | my $y1 = $start[0]; | ||||
1398 | my $x2 = $end[1]; | ||||
1399 | my $y2 = $end[0]; | ||||
1400 | |||||
1401 | my @cell_data; | ||||
1402 | my $row = 0; | ||||
1403 | |||||
1404 | if ( !$rotate ) { | ||||
1405 | for ( my $y = $y1 ; $y <= $y2 ; $y++ ) { | ||||
1406 | for ( my $x = $x1 ; $x <= $x2 ; $x++ ) { | ||||
1407 | my $cell = $oWkS->{Cells}[$y][$x]; | ||||
1408 | |||||
1409 | my $value; | ||||
1410 | if ( defined $cell ) { | ||||
1411 | $value .= $cell->value(); | ||||
1412 | } | ||||
1413 | else { | ||||
1414 | $value = ''; | ||||
1415 | } | ||||
1416 | |||||
1417 | push @{ $cell_data[$row] }, $value; | ||||
1418 | } | ||||
1419 | $row++; | ||||
1420 | } | ||||
1421 | } | ||||
1422 | else { | ||||
1423 | for ( my $x = $x1 ; $x <= $x2 ; $x++ ) { | ||||
1424 | for ( my $y = $y1 ; $y <= $y2 ; $y++ ) { | ||||
1425 | my $cell = $oWkS->{Cells}[$y][$x]; | ||||
1426 | |||||
1427 | my $value; | ||||
1428 | if ( defined $cell ) { | ||||
1429 | $value .= $cell->value(); | ||||
1430 | } | ||||
1431 | else { | ||||
1432 | $value = ''; | ||||
1433 | } | ||||
1434 | |||||
1435 | push @{ $cell_data[$row] }, $value; | ||||
1436 | } | ||||
1437 | $row++; | ||||
1438 | } | ||||
1439 | } | ||||
1440 | |||||
1441 | # Create the CSV output string. | ||||
1442 | my $csv = Text::CSV_XS->new( { binary => 1, eol => $/ } ); | ||||
1443 | my $output = ""; | ||||
1444 | |||||
1445 | for my $row (@cell_data) { | ||||
1446 | $csv->combine(@$row); | ||||
1447 | $output .= $csv->string(); | ||||
1448 | } | ||||
1449 | |||||
1450 | return $output; | ||||
1451 | } | ||||
1452 | |||||
1453 | 1 | 4µs | 1; | ||
1454 | |||||
1455 | __END__ |