File Coverage

lib/Spreadsheet/Engine/Sheet.pm
Criterion Covered Total %
statement 1186 2643 44.8
branch 666 1680 39.6
condition 169 431 39.2
subroutine 35 53 66.0
pod 50 50 100.0
total 2106 4857 43.3


tag), number%, or blank (use default)
line stmt bran cond sub pod time code
1             package Spreadsheet::Engine::Sheet;
2              
3             =head1 NAME
4              
5             Spreadsheet::Engine::Sheet - Spreadsheet basics
6              
7             =head1 SYNOPSIS
8              
9             parse_sheet_save(\@lines, \my %sheetdata);
10             my $outstr = create_sheet_save(\%sheetdata);
11            
12             add_to_editlog(\%headerdata, $str);
13              
14             parse_header_save(\@lines, my \%headerdata);
15             my $outstr = create_header_save(\%headerdata);
16              
17             execute_sheet_command($sheetdata, $command);
18              
19             recalc_sheet(\%sheetdata);
20              
21             =head1 DESCRIPTION
22              
23             This is a motley bunch of functions for dealing with a spreadsheet file
24             and/or data structure. If you plan to use any of these directly, be
25             aware that they may move, vanish, or have significant interface changes
26             in future releases.
27              
28             =cut
29              
30 34     34   79370 use strict;
  34         59  
  34         1524  
31 34     34   50313 use utf8;
  34         415  
  34         187  
32              
33             require Exporter;
34             our @ISA = qw(Exporter);
35             our @EXPORT = qw(
36             parse_sheet_save
37             create_sheet_save
38             execute_sheet_command
39             recalc_sheet
40             parse_header_save
41             create_header_save
42             add_to_editlog
43              
44             convert_date_gregorian_to_julian
45             convert_date_julian_to_gregorian
46             determine_value_type
47             test_criteria
48             lookup_result_type
49             copy_function_args
50             function_args_error
51             function_specific_error
52             top_of_stack_value_and_type
53             operand_as_number
54             operand_as_text
55             operand_value_and_type
56             decode_range_parts
57             coord_to_cr
58             cr_to_coord
59             encode_for_save
60             decode_from_save
61             special_chars
62             special_chars_nl
63              
64             %sheetfields
65             %formathints
66             $julian_offset
67             $seconds_in_a_day
68             $seconds_in_an_hour
69             );
70              
71             # Were exporte, but no longer used from outside:
72             # format_number_for_display url_encode_plain
73              
74             #
75             # Locals and Globals
76             #
77              
78             our %sheetfields = (
79             lastcol => "c",
80             lastrow => "r",
81             defaultcolwidth => "w",
82             defaultrowheight => "h",
83             defaulttextformat => "tf",
84             defaultnontextformat => "ntf",
85             defaulttextvalueformat => "tvf",
86             defaultnontextvalueformat => "ntvf",
87             defaultlayout => "layout",
88             defaultfont => "font",
89             defaultcolor => "color",
90             defaultbgcolor => "bgcolor",
91             circularreferencecell => "circularreferencecell",
92             recalc => "recalc",
93             needsrecalc => "needsrecalc"
94             );
95              
96             my @headerfieldnames = qw(
97             version fullname templatetext templatefile lastmodified
98             lastauthor basefiledt backupfiledt reverted editcomments
99             publishhtml publishsource publishjs viewwithoutlogin
100             );
101              
102             # Date/time constants
103              
104             our $julian_offset = 2415019;
105             our $seconds_in_a_day = 24 * 60 * 60;
106             our $seconds_in_an_hour = 60 * 60;
107              
108             # Input values that have special values, e.g., "TRUE", "FALSE", etc.
109             # Form is: uppercasevalue => "value,type"
110              
111             my %input_constants = (
112             'TRUE' => '1,nl',
113             'FALSE' => '0,nl',
114             '#N/A' => '0,e#N/A',
115             '#NULL!' => '0,e#NULL!',
116             '#NUM!' => '0,e#NUM!',
117             '#DIV/0!' => '0,e#DIV/0!',
118             '#VALUE!' => '0,e#VALUE!',
119             '#REF!' => '0,e#REF!',
120             '#NAME?' => '0,e#NAME?',
121             );
122              
123             # Formula constants for parsing:
124              
125             my $token_num = 1;
126             my $token_coord = 2;
127             my $token_op = 3;
128             my $token_name = 4;
129             my $token_error = 5;
130             my $token_string = 6;
131             my $token_space = 7;
132              
133             my $char_class_num = 1;
134             my $char_class_numstart = 2;
135             my $char_class_op = 3;
136             my $char_class_eof = 4;
137             my $char_class_alpha = 5;
138             my $char_class_incoord = 6;
139             my $char_class_error = 7;
140             my $char_class_quote = 8;
141             my $char_class_space = 9;
142              
143             my @char_class = (
144              
145             # 0 1 2 3 4 5 6 7 8 9 A B C D E F
146             # sp ! " # $ % & ' ( ) * + , - . /
147             9, 3, 8, 4, 6, 3, 3, 0, 3, 3, 3, 3, 3, 3, 2, 3,
148              
149             # 0 1 2 3 4 5 6 7 8 9 : ; < = > ?
150             1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 3, 0, 3, 3, 3, 0,
151              
152             # @ A B C D E F G H I J K L M N O
153             0, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
154              
155             # P Q R S T U V W X Y Z [ \ ] ^ _
156             5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 0, 0, 0, 3, 0,
157              
158             # ` a b c d e f g h i j k l m n o
159             0, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
160              
161             # p q r s t u v w x y z { | } ~ DEL
162             5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 0, 0, 0, 0, 0
163             );
164              
165             # Convert one char token text to input text
166              
167             my %token_op_expansion =
168             ('G' => '>=', 'L' => '<=', 'M' => '-', 'N' => '<>', 'P' => '+');
169              
170             # Operator Precedence:
171             # 1 !
172             # 2 : ,
173             # 3 M P
174             # 4 %
175             # 5 ^
176             # 6 * /
177             # 7 + -
178             # 8 &
179             # 9 < > = G(>=) L(<=) N(<>)
180             # Negative value means Right Associative
181              
182             my @token_precedence = (
183              
184             # 0 1 2 3 4 5 6 7 8 9 A B C D E F
185             # sp ! " # $ % & ' ( ) * + , - . /
186             0, 1, 0, 0, 0, 4, 8, 0, 0, 0, 6, 7, 2, 7, 0, 6,
187              
188             # 0 1 2 3 4 5 6 7 8 9 : ; < = > ?
189             0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 9, 9, 9, 0,
190              
191             # @ A B C D E F G H I J K L M N O
192             0, 0, 0, 0, 0, 0, 0, 9, 0, 0, 0, 0, 9, -3, 9, 0,
193              
194             # P Q R S T U V W X Y Z [ \ ] ^ _
195             -3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 5, 0
196             );
197              
198             #
199             # Information about the resulting value types when doing operations on values
200             #
201             # Each hash entry is a hash with specific types with result type info as follows:
202             #
203             # 'type1a' => '|type2a:resulta|type2b:resultb|...
204             # Type of t* or n* matches any of those types not listed
205             # Results may be a type or the numbers 1 or 2 specifying to return type1 or type2
206             #
207              
208             my %typelookup = (
209             unaryminus => {
210             'n*' => '|n*:1|',
211             'e*' => '|e*:1|',
212             't*' => '|t*:e#VALUE!|',
213             'b' => '|b:n|'
214             },
215             unaryplus => {
216             'n*' => '|n*:1|',
217             'e*' => '|e*:1|',
218             't*' => '|t*:e#VALUE!|',
219             'b' => '|b:n|'
220             },
221             unarypercent => {
222             'n*' => '|n:n%|n*:n|',
223             'e*' => '|e*:1|',
224             't*' => '|t*:e#VALUE!|',
225             'b' => '|b:n|'
226             },
227             plus => {
228             'n%' => '|n%:n%|nd:n|nt:n|ndt:n|n$:n|n:n|n*:n|b:n|e*:2|t*:e#VALUE!|',
229             'nd' => '|n%:n|nd:nd|nt:ndt|ndt:ndt|n$:n|n:nd|n*:n|b:n|e*:2|t*:e#VALUE!|',
230             'nt' => '|n%:n|nd:ndt|nt:nt|ndt:ndt|n$:n|n:nt|n*:n|b:n|e*:2|t*:e#VALUE!|',
231             'ndt' =>
232             '|n%:n|nd:ndt|nt:ndt|ndt:ndt|n$:n|n:ndt|n*:n|b:n|e*:2|t*:e#VALUE!|',
233             'n$' => '|n%:n|nd:n|nt:n|ndt:n|n$:n$|n:n$|n*:n|b:n|e*:2|t*:e#VALUE!|',
234             'n' => '|n%:n|nd:nd|nt:nt|ndt:ndt|n$:n$|n:n|n*:n|b:n|e*:2|t*:e#VALUE!|',
235             'b' => '|n%:n%|nd:nd|nt:nt|ndt:ndt|n$:n$|n:n|n*:n|b:n|e*:2|t*:e#VALUE!|',
236             't*' => '|n*:e#VALUE!|t*:e#VALUE!|b:e#VALUE!|e*:2|',
237             'e*' => '|e*:1|n*:1|t*:1|b:1|',
238             },
239             concat => {
240             't' => '|t:t|th:th|tw:tw|t*:2|e*:2|',
241             'th' => '|t:th|th:th|tw:t|t*:t|e*:2|',
242             'tw' => '|t:tw|th:t|tw:tw|t*:t|e*:2|',
243             'e*' => '|e*:1|n*:1|t*:1|',
244             },
245             oneargnumeric => {
246             'n*' => '|n*:n|',
247             'e*' => '|e*:1|',
248             't*' => '|t*:e#VALUE!|',
249             'b' => '|b:n|'
250             },
251             twoargnumeric => {
252             'n*' => '|n*:n|t*:e#VALUE!|e*:2|',
253             'e*' => '|e*:1|n*:1|t*:1|',
254             't*' => '|t*:e#VALUE!|n*:e#VALUE!|e*:2|'
255             },
256             propagateerror => {
257             'n*' => '|n*:2|e*:2|',
258             'e*' => '|e*:2|',
259             't*' => '|t*:2|e*:2|',
260             'b' => '|b:2|e*:2|'
261             },
262             );
263              
264             my %old_formats_map = (
265             'default' => "default"
266             , # obsolete: converts from early beta versions, used only one place
267             'none' => 'General',
268             '%1.0f' => "0",
269             ',' => '[,]General',
270             ',%1.0f' => '#,##0',
271             ',%1.1f' => '#,##0.0',
272             ',%1.2f' => '#,##0.00',
273             ',%1.3f' => '#,##0.000',
274             ',%1.4f' => '#,##0.0000',
275             '$,%1.0f' => '$#,##0',
276             '$,%1.1f' => '$#,##0.0',
277             '$,%1.2f' => '$#,##0.00',
278             '(,%1.0f' => '#,##0_);(#,##0)',
279             '(,%1.1f' => '#,##0.0_);(#,##0.0)',
280             '(,%1.2f' => '#,##0.00_);(#,##0.00)',
281             '($,%1.0f' => '$#,##0_);($#,##0)',
282             '($,%1.1f' => '$#,##0.0_);($#,##0.0)',
283             '($,%1.2f' => '$#,##0.00_);($#,##0.00)',
284             ',%1.0f%%' => '0%',
285             ',%1.1f%%' => '0.0%',
286             '(,%1.0f%%' => '0%_);(0%)',
287             '(,%1.1f%%' => '0.0%_);(0.0%)',
288             '%02.0f' => '00',
289             '%03.0f' => '000',
290             '%04.0f' => '0000',
291             );
292              
293             =head1 EXPORTS
294              
295             =head2 parse_sheet_save
296              
297             parse_sheet_save(\@lines, \my %sheetdata);
298              
299             Sheet input routine. Fills %sheetdata given lines of text @lines.
300              
301             Currently always returns nothing.
302              
303             Sheet save format:
304              
305             linetype:param1:param2:...
306              
307             Linetypes are:
308              
309             version:versionname - version of this format. Currently 1.3.
310              
311             cell:coord:type:value...:type:value... - Types are as follows:
312              
313             v:value - straight numeric value
314             t:value - straight text/wiki-text in cell, encoded to handle \, :, newlines
315             vt:fulltype:value - value with value type/subtype
316             vtf:fulltype:value:formulatext - formula resulting in value with value type/subtype, value and text encoded
317             vtc:fulltype:value:valuetext - formatted text constant resulting in value with value type/subtype, value and text encoded
318             vf:fvalue:formulatext - formula resulting in value, value and text encoded (obsolete: only pre format version 1.1)
319             fvalue - first char is "N" for numeric value, "T" for text value, "H" for HTML value, rest is the value
320             e:errortext - Error text. Non-blank means formula parsing/calculation results in error.
321             b:topborder#:rightborder#:bottomborder#:leftborder# - border# in sheet border list or blank if none
322             l:layout# - number in cell layout list
323             f:font# - number in sheet fonts list
324             c:color# - sheet color list index for text
325             bg:color# - sheet color list index for background color
326             cf:format# - sheet cell format number for explicit format (align:left, etc.)
327             cvf:valueformat# - sheet cell value format number (obsolete: only pre format v1.2)
328             tvf:valueformat# - sheet cell text value format number
329             ntvf:valueformat# - sheet cell non-text value format number
330             colspan:numcols - number of columns spanned in merged cell
331             rowspan:numrows - number of rows spanned in merged cell
332             cssc:classname - name of CSS class to be used for cell when published instead of one calculated here
333             csss:styletext - explicit CSS style information, encoded to handle :, etc.
334             mod:allow - if "y" allow modification of cell for live "view" recalc
335              
336             col:
337             w:widthval - number, "auto" (no width in
338             hide: - yes/no, no is assumed if missing
339             row:
340             hide - yes/no, no is assumed if missing
341              
342             sheet:
343             c:lastcol - number
344             r:lastrow - number
345             w:defaultcolwidth - number, "auto", number%, or blank (default->80)
346             h:defaultrowheight - not used
347             tf:format# - cell format number for sheet default for text values
348             ntf:format# - cell format number for sheet default for non-text values (i.e., numbers)
349             layout:layout# - default cell layout number in cell layout list
350             font:font# - default font number in sheet font list
351             vf:valueformat# - default number value format number in sheet valueformat list (obsolete: only pre format version 1.2)
352             ntvf:valueformat# - default non-text (number) value format number in sheet valueformat list
353             tvf:valueformat# - default text value format number in sheet valueformat list
354             color:color# - default number for text color in sheet color list
355             bgcolor:color# - default number for background color in sheet color list
356             circularreferencecell:coord - cell coord with a circular reference
357             recalc:value - on/off (on is default). If "on", appropriate changes to the sheet cause a recalc
358             needsrecalc:value - yes/no (no is default). If "yes", formula values are not up to date
359              
360             name:name:description:value - name definition, name in uppercase, with value being "B5", "A1:B7", or "=formula"
361             font:fontnum:value - text of font definition (style weight size family) for font fontnum
362             "*" for "style weight", size, or family, means use default (first look to sheet, then builtin)
363             color:colornum:rgbvalue - text of color definition (e.g., rgb(255,255,255)) for color colornum
364             border:bordernum:value - text of border definition (thickness style color) for border bordernum
365             layout:layoutnum:value - text of vertical alignment and padding style for cell layout layoutnum:
366             vertical-alignment:vavalue;padding topval rightval bottomval leftval;
367             cellformat:cformatnum:value - text of cell alignment (left/center/right) for cellformat cformatnum
368             valueformat:vformatnum:value - text of number format (see format_value_for_display) for valueformat vformatnum (changed in v1.2)
369             clipboardrange:upperleftcoord:bottomrightcoord - origin of clipboard data. Not present if clipboard empty.
370             There must be a clipboardrange before any clipboard lines
371             clipboard:coord:type:value:... - clipboard data, in same format as cell data
372              
373             The resulting $sheetdata data structure is as follows:
374              
375             $sheetdata{version} - version of save file read in
376             $sheetdata{datatypes}->{$coord} - Origin of {datavalues} value:
377             v - typed in numeric value of some sort, constant, no formula
378             t - typed in text, constant, no formula
379             f - result of formula calculation ({formulas} has formula to calculate)
380             c - constant of some sort with typed in text in {formulas} and value in {datavalues}
381             $sheetdata{formulas}->{$coord} - Text of formula if {datatypes} is "f", no leading "=", or text of constant if "c"
382             $sheetdata{datavalues}->{$coord} - a text or numeric value ready to be formatted for display or used in calculation
383             $sheetdata{valuetypes}->{$coord} - the value type of the datavalue as 1 or more characters
384             First char is "n" for numeric or "t" for text
385             Second chars, if present, are sub-type, like "l" for logical (0=false, 1=true)
386             $sheetdata{cellerrors}->{$coord} - If non-blank, error text for error in formula calculation
387             $sheetdata{cellattribs}->{$coord}->
388             {coord} - coord of cell - existence means non-blank cell
389             {bt}, {br}, {bb}, {bl} - border number or null if no border
390             {layout} - cell layout number or blank for default
391             {font} - font number or blank for default
392             {color} - color number for text or blank for default
393             {bgcolor} - color number for the cell background or blank for default
394             {cellformat} - cell format number if not default - controls horizontal alignment
395             {textvalueformat} - value format number if not default - controls how the cell's text values are formatted into text for display
396             {nontextvalueformat} - value format number if not default - controls how the cell's non-text values are turned into text for display
397             {colspan}, {rowspan} - column span and row span for merged cells or blank for 1
398             {cssc}, {csss} - explicit CSS class and CSS style for cell
399             {mod} - if "y" allow modification in live view
400             $sheetdata{colattribs}->{$colcoord}->
401             {width} - column width if not default
402             {hide} - hide column if yes
403             $sheetdata{rowattribs}->{$rowcoord}->
404             {height} - ignored
405             {hide} - hide row if yes
406             $sheetdata{sheetattribs}->{$attrib}->
407             {lastcol} - number of columns in sheet
408             {lastrow} - number of rows in sheet (more may be displayed when editing)
409             {defaultcolwidth} - number, "auto", number%, or blank (default->80)
410             {defaultrowheight} - not used
411             {defaulttextformat} - cell format number for sheet default for text values
412             {defaultnontextformat} - cell format number for sheet default for non-text values (i.e., numbers)
413             {defaultlayout} - default cell layout number in sheet cell layout list
414             {defaultfont} - default font number in sheet font list
415             {defaulttextvalueformat} - default text value format number in sheet valueformat list
416             {defaultnontextvalueformat} - default number value format number in sheet valueformat list
417             {defaultcolor} - default number for text color in sheet color list
418             {defaultbgcolor} - default number for background color in sheet color list
419             {circularreferencecell} - cell coord with a circular reference
420             {recalc} - on/off (on is default). If "on", appropriate changes to the sheet cause a recalc
421             {needsrecalc} - yes/no (no is default). If "yes", formula values are not up to date
422             $sheetdata{names}->{$name}-> - name is uppercase
423             {desc} - description (optional)
424             {definiton} - in the form of B5, A1:B7, or =formula
425             $sheetdata{fonts}->[$index] - font specifications addressable by array position
426             $sheetdata{fonthash}->{$value} - hash with font specification as keys and {fonts}->[] index position as values
427             $sheetdata{colors}->[$index] - color specifications addressable by array position
428             $sheetdata{colorhash}->{$value} - hash with color specification as keys and {colors}->[] index position as values
429             $sheetdata{borderstyles}->[$index] - border style specifications addressable by array position
430             $sheetdata{borderstylehash}->{$value} - hash with border style specification as keys and {borderstyles}->[] index position as values
431             $sheetdata{layoutstyles}->[$index] - cell layout specifications addressable by array position
432             $sheetdata{layoutstylehash}->{$value} - hash with cell layout specification as keys and {layoutstyle}->[] index position as values
433             $sheetdata{cellformats}->[$index] - cell format specifications addressable by array position
434             $sheetdata{cellformathash}->{$value} - hash with cell format specification as keys and {cellformats}->[] index position as values
435             $sheetdata{valueformats}->[$index] - value format specifications addressable by array position
436             $sheetdata{valueformathash}->{$value} - hash with value format specification as keys and {valueformats}->[] index position as values
437             $sheetdata{clipboard}-> - the sheet's clipboard
438             {range} - coord:coord range of where the clipboard contents came from or null if empty
439             {datavalues} - like $sheetdata{datavalues} but for clipboard copy of cells
440             {datatypes} - like $sheetdata{datatypes} but for clipboard copy of cells
441             {valuetypes} - like $sheetdata{valuetypes} but for clipboard copy of cells
442             {formulas} - like $sheetdata{formulas} but for clipboard copy of cells
443             {cellerrors} - like $sheetdata{cellerrors} but for clipboard copy of cells
444             {cellattribs} - like $sheetdata{cellattribs} but for clipboard copy of cells
445             $sheetdata{loaderror} - if non-blank, there was an error loading this sheet and this is the text of that error
446              
447             =cut
448              
449             sub parse_sheet_save {
450              
451 114     114 1 237 my ($lines, $sheetdata) = @_;
452              
453             # Initialize sheetdata structure
454 114         313 $sheetdata->{datavalues} = {};
455 114         284 $sheetdata->{datatypes} = {};
456 114         277 $sheetdata->{valuetypes} = {};
457 114         317 $sheetdata->{formulas} = {};
458 114         267 $sheetdata->{cellerrors} = {};
459 114         280 $sheetdata->{cellattribs} = {};
460 114         307 $sheetdata->{colattribs} = {};
461 114         344 $sheetdata->{rowattribs} = {};
462 114         283 $sheetdata->{sheetattribs} = {};
463 114         311 $sheetdata->{layoutstyles} = [];
464 114         360 $sheetdata->{layoutstylehash} = {};
465 114         340 $sheetdata->{names} = {};
466 114         383 $sheetdata->{fonts} = [];
467 114         438 $sheetdata->{fonthash} = {};
468 114         308 $sheetdata->{colors} = [];
469 114         409 $sheetdata->{colorhash} = {};
470 114         303 $sheetdata->{borderstyles} = [];
471 114         319 $sheetdata->{borderstylehash} = {};
472 114         324 $sheetdata->{cellformats} = [];
473 114         287 $sheetdata->{cellformathash} = {};
474 114         287 $sheetdata->{valueformats} = [];
475 114         250 $sheetdata->{valueformathash} = {};
476              
477             # Get references to the parts
478              
479 114         204 my $datavalues = $sheetdata->{datavalues};
480 114         236 my $datatypes = $sheetdata->{datatypes};
481 114         210 my $valuetypes = $sheetdata->{valuetypes};
482 114         247 my $dataformulas = $sheetdata->{formulas};
483 114         215 my $cellerrors = $sheetdata->{cellerrors};
484 114         242 my $cellattribs = $sheetdata->{cellattribs};
485 114         239 my $colattribs = $sheetdata->{colattribs};
486 114         230 my $rowattribs = $sheetdata->{rowattribs};
487 114         209 my $sheetattribs = $sheetdata->{sheetattribs};
488 114         250 my $layoutstyles = $sheetdata->{layoutstyles};
489 114         217 my $layoutstylehash = $sheetdata->{layoutstylehash};
490 114         211 my $names = $sheetdata->{names};
491 114         531 my $fonts = $sheetdata->{fonts};
492 114         232 my $fonthash = $sheetdata->{fonthash};
493 114         207 my $colors = $sheetdata->{colors};
494 114         187 my $colorhash = $sheetdata->{colorhash};
495 114         404 my $borderstyles = $sheetdata->{borderstyles};
496 114         213 my $borderstylehash = $sheetdata->{borderstylehash};
497 114         203 my $cellformats = $sheetdata->{cellformats};
498 114         195 my $cellformathash = $sheetdata->{cellformathash};
499 114         207 my $valueformats = $sheetdata->{valueformats};
500 114         300 my $valueformathash = $sheetdata->{valueformathash};
501              
502 114         198 my ($coord, $type, $rest);
503 0         0 my ($linetype, $value, $valuetype, $formula, $style, $namename, $namedesc);
504 0         0 my ($fontnum, $layoutnum, $colornum, $check, $row, $col);
505 0         0 my $errortext;
506             my (
507 0         0 $clipdatavalues, $clipdatatypes, $clipvaluetypes,
508             $clipdataformulas, $clipcellerrors, $clipcellattribs
509             );
510 114         246 my ($maxcol, $maxrow) = (0, 0);
511              
512 114         299 foreach my $line (@$lines) {
513 5170         6022 chomp $line;
514 5170         6098 $line =~ s/\r//g;
515              
516             # assumed already done in read. # $line =~ s/^\x{EF}\x{BB}\x{BF}//; # remove UTF-8 Byte Order Mark if present
517 5170         12402 my ($linetype, $rest) = split (/:/, $line, 2);
518 5170 100       9687 next unless $linetype;
519              
520 5150 100       8807 if ($linetype eq "cell") {
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    0          
    0          
    0          
521 5067         17179 ($coord, $type, $rest) = split (/:/, $rest, 3);
522 5067         16866 $coord = uc($coord);
523 5067 50       21384 $cellattribs->{$coord} = { 'coord' => $coord }
524             if $type; # Must have this if cell has anything
525 5067         9699 ($col, $row) = coord_to_cr($coord);
526 5067 100       10973 $maxcol = $col if $col > $maxcol;
527 5067 100       10507 $maxrow = $row if $row > $maxrow;
528 5067         9431 while ($type) {
529 5087 100       11624 if ($type eq "v") {
    100          
    50          
    100          
    100          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
530 2423         5672 ($value, $type, $rest) = split (/:/, $rest, 3);
531 2423         4284 $datavalues->{$coord} = decode_from_save($value);
532 2423         3774 $datatypes->{$coord} = "v";
533 2423         8004 $valuetypes->{$coord} = "n";
534             } elsif ($type eq "t") {
535 1352         3228 ($value, $type, $rest) = split (/:/, $rest, 3);
536 1352         2718 $datavalues->{$coord} = decode_from_save($value);
537 1352         2393 $datatypes->{$coord} = "t";
538 1352         4536 $valuetypes->{$coord} =
539             "tw"; # Typed in text is treated as wiki text by default
540             } elsif ($type eq "vt") {
541 0         0 ($valuetype, $value, $type, $rest) = split (/:/, $rest, 4);
542 0         0 $datavalues->{$coord} = decode_from_save($value);
543 0 0       0 if (substr($valuetype, 0, 1) eq "n") {
544 0         0 $datatypes->{$coord} = "v";
545             } else {
546 0         0 $datatypes->{$coord} = "t";
547             }
548 0         0 $valuetypes->{$coord} = $valuetype;
549             } elsif ($type eq "vtf") {
550 632         2184 ($valuetype, $value, $formula, $type, $rest) =
551             split (/:/, $rest, 5);
552 632         1323 $datavalues->{$coord} = decode_from_save($value);
553 632         1025 $dataformulas->{$coord} = decode_from_save($formula);
554 632         1021 $datatypes->{$coord} = "f";
555 632         2204 $valuetypes->{$coord} = $valuetype;
556             } elsif ($type eq "vtc") {
557 660         2324 ($valuetype, $value, $formula, $type, $rest) =
558             split (/:/, $rest, 5);
559 660         1328 $datavalues->{$coord} = decode_from_save($value);
560 660         1133 $dataformulas->{$coord} = decode_from_save($formula);
561 660         1015 $datatypes->{$coord} = "c";
562 660         2203 $valuetypes->{$coord} = $valuetype;
563             } elsif ($type eq "vf") { # old format
564 0         0 ($value, $formula, $type, $rest) = split (/:/, $rest, 4);
565 0         0 $datavalues->{$coord} = decode_from_save($value);
566 0         0 $dataformulas->{$coord} = decode_from_save($formula);
567 0         0 $datatypes->{$coord} = "f";
568 0 0       0 if (substr($value, 0, 1) eq "N") {
    0          
    0          
569 0         0 $valuetypes->{$coord} = "n";
570 0         0 $datavalues->{$coord} =
571             substr($datavalues->{$coord}, 1); # remove initial type code
572             } elsif (substr($value, 0, 1) eq "T") {
573 0         0 $valuetypes->{$coord} = "t";
574 0         0 $datavalues->{$coord} =
575             substr($datavalues->{$coord}, 1); # remove initial type code
576             } elsif (substr($value, 0, 1) eq "H") {
577 0         0 $valuetypes->{$coord} = "th";
578 0         0 $datavalues->{$coord} =
579             substr($datavalues->{$coord}, 1); # remove initial type code
580             } else {
581 0 0       0 $valuetypes->{$coord} =
582             $valuetypes->{$coord} =~ m/[^0-9+\-\.]/ ? "t" : "n";
583             }
584             } elsif ($type eq "e") {
585 20         83 ($value, $type, $rest) = split (/:/, $rest, 3);
586 20         65 $cellerrors->{$coord} = decode_from_save($value);
587             } elsif ($type eq "b") {
588 0         0 my ($t, $r, $b, $l);
589 0         0 ($t, $r, $b, $l, $type, $rest) = split (/:/, $rest, 6);
590 0         0 $cellattribs->{$coord}->{bt} = $t;
591 0         0 $cellattribs->{$coord}->{br} = $r;
592 0         0 $cellattribs->{$coord}->{bb} = $b;
593 0         0 $cellattribs->{$coord}->{bl} = $l;
594             } elsif ($type eq "l") {
595 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
596 0         0 $cellattribs->{$coord}->{layout} = $value;
597             } elsif ($type eq "f") {
598 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
599 0         0 $cellattribs->{$coord}->{font} = $value;
600             } elsif ($type eq "c") {
601 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
602 0         0 $cellattribs->{$coord}->{color} = $value;
603             } elsif ($type eq "bg") {
604 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
605 0         0 $cellattribs->{$coord}->{bgcolor} = $value;
606             } elsif ($type eq "cf") {
607 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
608 0         0 $cellattribs->{$coord}->{cellformat} = $value;
609             } elsif ($type eq "cvf") { # obsolete - only pre 1.2 format
610 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
611 0         0 $cellattribs->{$coord}->{nontextvalueformat} = $value;
612             } elsif ($type eq "ntvf") {
613 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
614 0         0 $cellattribs->{$coord}->{nontextvalueformat} = $value;
615             } elsif ($type eq "tvf") {
616 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
617 0         0 $cellattribs->{$coord}->{textvalueformat} = $value;
618             } elsif ($type eq "colspan") {
619 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
620 0         0 $cellattribs->{$coord}->{colspan} = $value;
621             } elsif ($type eq "rowspan") {
622 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
623 0         0 $cellattribs->{$coord}->{rowspan} = $value;
624             } elsif ($type eq "cssc") {
625 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
626 0         0 $cellattribs->{$coord}->{cssc} = $value;
627             } elsif ($type eq "csss") {
628 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
629 0         0 $cellattribs->{$coord}->{csss} = decode_from_save($value);
630             } elsif ($type eq "mod") {
631 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
632 0         0 $cellattribs->{$coord}->{mod} = $value;
633             } else {
634 0         0 $errortext = "Unknown type '$type' in line:\n$_\n";
635 0         0 last;
636             }
637             }
638             } elsif ($linetype eq "col") {
639 0         0 ($coord, $type, $rest) = split (/:/, $rest, 3);
640 0         0 $coord = uc($coord); # normalize to upper case
641 0         0 $colattribs->{$coord} = { 'coord' => $coord };
642 0         0 while ($type) {
643 0 0       0 if ($type eq "w") {
644 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
645 0         0 $colattribs->{$coord}->{width} = $value;
646             }
647 0 0       0 if ($type eq "hide") {
648 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
649 0         0 $colattribs->{$coord}->{hide} = $value;
650             } else {
651 0         0 $errortext = "Unknown type '$type' in line:\n$_\n";
652 0         0 last;
653             }
654             }
655             } elsif ($linetype eq "row") {
656 0         0 ($coord, $type, $rest) = split (/:/, $rest, 3);
657 0         0 $rowattribs->{$coord} = { 'coord' => $coord };
658 0         0 while ($type) {
659 0 0       0 if ($type eq "h") {
660 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
661 0         0 $rowattribs->{$coord}->{height} = $value;
662             }
663 0 0       0 if ($type eq "hide") {
664 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
665 0         0 $rowattribs->{$coord}->{hide} = $value;
666             } else {
667 0         0 $errortext = "Unknown type '$type' in line:\n$_\n";
668 0         0 last;
669             }
670             }
671             } elsif ($linetype eq "sheet") {
672 21         89 ($type, $rest) = split (/:/, $rest, 2);
673 21         99 while ($type) {
674 42 100       242 if ($type eq "c") { # number of columns
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
675 21         73 ($value, $type, $rest) = split (/:/, $rest, 3);
676 21         101 $sheetattribs->{lastcol} = $value;
677             } elsif ($type eq "r") { # number of rows
678 21         97 ($value, $type, $rest) = split (/:/, $rest, 3);
679 21         111 $sheetattribs->{lastrow} = $value;
680             } elsif ($type eq "w") { # default col width
681 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
682 0         0 $sheetattribs->{defaultcolwidth} = $value;
683             } elsif ($type eq "h") { #default row height
684 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
685 0         0 $sheetattribs->{defaultrowheight} = $value;
686             } elsif ($type eq "tf") { #default text format
687 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
688 0         0 $sheetattribs->{defaulttextformat} = $value;
689             } elsif ($type eq "ntf") { #default not text format
690 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
691 0         0 $sheetattribs->{defaultnontextformat} = $value;
692             } elsif ($type eq "layout") { #default layout number
693 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
694 0         0 $sheetattribs->{defaultlayout} = $value;
695             } elsif ($type eq "font") { #default font number
696 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
697 0         0 $sheetattribs->{defaultfont} = $value;
698             } elsif ($type eq "vf") { #default value format number (old)
699 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
700 0         0 $sheetattribs->{defaultnontextvalueformat} = $value;
701 0         0 $sheetattribs->{defaulttextvalueformat} = "";
702             } elsif ($type eq "tvf") { #default text value format number
703 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
704 0         0 $sheetattribs->{defaulttextvalueformat} = $value;
705             } elsif ($type eq "ntvf")
706             { #default non-text (number) value format number
707 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
708 0         0 $sheetattribs->{defaultnontextvalueformat} = $value;
709             } elsif ($type eq "color") { #default text color
710 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
711 0         0 $sheetattribs->{defaultcolor} = $value;
712             } elsif ($type eq "bgcolor") { #default cell background color
713 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
714 0         0 $sheetattribs->{defaultbgcolor} = $value;
715             } elsif ($type eq "circularreferencecell")
716             { #cell with a circular reference
717 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
718 0         0 $sheetattribs->{circularreferencecell} = $value;
719             } elsif ($type eq "recalc") { #recalc on or off
720 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
721 0         0 $sheetattribs->{recalc} = $value;
722             } elsif ($type eq "needsrecalc")
723             { #recalculation needed, computed values may not be correct
724 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
725 0         0 $sheetattribs->{needsrecalc} = $value;
726             } else {
727 0         0 $errortext = "Unknown type '$type' in line:\n$_\n";
728 0         0 last;
729             }
730             }
731             } elsif ($linetype eq "name") {
732 41         137 ($namename, $namedesc, $value) = split (/:/, $rest, 3);
733 41         102 $namename = uc(decode_from_save($namename));
734 41         94 $names->{$namename}->{desc} = decode_from_save($namedesc);
735 41         133 $names->{$namename}->{definition} = decode_from_save($value);
736             } elsif ($linetype eq "layout") {
737 0         0 ($layoutnum, $value) = split (/:/, $rest, 2);
738 0         0 $layoutstyles->[$layoutnum] = $value;
739 0         0 $layoutstylehash->{$value} = $layoutnum;
740             } elsif ($linetype eq "font") {
741 0         0 ($fontnum, $value) = split (/:/, $rest, 2);
742 0         0 $fonts->[$fontnum] = $value;
743 0         0 $fonthash->{$value} = $fontnum;
744             } elsif ($linetype eq "color") {
745 0         0 ($colornum, $value) = split (/:/, $rest, 2);
746 0         0 $colors->[$colornum] = $value;
747 0         0 $colorhash->{$value} = $colornum;
748             } elsif ($linetype eq "border") {
749 0         0 ($style, $value) = split (/:/, $rest, 2);
750 0         0 $borderstyles->[$style] = $value;
751 0         0 $borderstylehash->{$value} = $style;
752             } elsif ($linetype eq "cellformat") {
753 0         0 ($style, $value) = split (/:/, $rest, 2);
754 0         0 $cellformats->[$style] = decode_from_save($value);
755 0         0 $cellformathash->{$value} = $style;
756             } elsif ($linetype eq "valueformat") {
757 0         0 ($style, $value) = split (/:/, $rest, 2);
758 0         0 $value = decode_from_save($value);
759 0 0       0 if ($sheetdata->{version} < 1.2) { # old format definitions - convert
760 0 0       0 $value =
761             length($old_formats_map{$value}) >= 1
762             ? $old_formats_map{$value}
763             : $value;
764             }
765 0 0       0 if ($value eq "General-separator") { # convert from 0.91
766 0         0 $value = "[,]General";
767             }
768 0         0 $valueformats->[$style] = $value;
769 0         0 $valueformathash->{$value} = $style;
770             } elsif ($linetype eq "version") {
771 21         70 $sheetdata->{version} = $rest;
772             } elsif ($linetype eq "") {
773             } elsif ($linetype eq "clipboardrange") {
774 0         0 $sheetdata->{clipboard} = {}; # clear and create clipboard
775 0         0 $sheetdata->{clipboard}->{datavalues} = {};
776 0         0 $clipdatavalues = $sheetdata->{clipboard}->{datavalues};
777 0         0 $sheetdata->{clipboard}->{datatypes} = {};
778 0         0 $clipdatatypes = $sheetdata->{clipboard}->{datatypes};
779 0         0 $sheetdata->{clipboard}->{valuetypes} = {};
780 0         0 $clipvaluetypes = $sheetdata->{clipboard}->{valuetypes};
781 0         0 $sheetdata->{clipboard}->{formulas} = {};
782 0         0 $clipdataformulas = $sheetdata->{clipboard}->{formulas};
783 0         0 $sheetdata->{clipboard}->{cellerrors} = {};
784 0         0 $clipcellerrors = $sheetdata->{clipboard}->{cellerrors};
785 0         0 $sheetdata->{clipboard}->{cellattribs} = {};
786 0         0 $clipcellattribs = $sheetdata->{clipboard}->{cellattribs};
787              
788 0         0 $coord = uc($rest);
789 0         0 $sheetdata->{clipboard}->{range} = $coord;
790             } elsif ($linetype eq "clipboard")
791             { # must have a clipboardrange command somewhere before it
792 0         0 ($coord, $type, $rest) = split (/:/, $rest, 3);
793 0         0 $coord = uc($coord);
794 0 0       0 if (!$sheetdata->{clipboard}->{range}) {
795 0         0 $errortext = "Missing clipboardrange before clipboard data in file\n";
796 0         0 $type = "norange";
797             }
798 0         0 $clipcellattribs->{$coord} = { 'coord', $coord };
799 0         0 while ($type) {
800 0 0       0 if ($type eq "v") {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
801 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
802 0         0 $clipdatavalues->{$coord} = decode_from_save($value);
803 0         0 $clipdatatypes->{$coord} = "v";
804 0         0 $clipvaluetypes->{$coord} = "n";
805             } elsif ($type eq "t") {
806 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
807 0         0 $clipdatavalues->{$coord} = decode_from_save($value);
808 0         0 $clipdatatypes->{$coord} = "t";
809 0         0 $clipvaluetypes->{$coord} =
810             "tw"; # Typed in text is treated as wiki text by default
811             } elsif ($type eq "vt") {
812 0         0 ($valuetype, $value, $type, $rest) = split (/:/, $rest, 4);
813 0         0 $clipdatavalues->{$coord} = decode_from_save($value);
814 0 0       0 if (substr($valuetype, 0, 1) eq "n") {
815 0         0 $clipdatatypes->{$coord} = "v";
816             } else {
817 0         0 $clipdatatypes->{$coord} = "t";
818             }
819 0         0 $clipvaluetypes->{$coord} = $valuetype;
820             } elsif ($type eq "vtf") {
821 0         0 ($valuetype, $value, $formula, $type, $rest) =
822             split (/:/, $rest, 5);
823 0         0 $clipdatavalues->{$coord} = decode_from_save($value);
824 0         0 $clipdataformulas->{$coord} = decode_from_save($formula);
825 0         0 $clipdatatypes->{$coord} = "f";
826 0         0 $clipvaluetypes->{$coord} = $valuetype;
827             } elsif ($type eq "vtc") {
828 0         0 ($valuetype, $value, $formula, $type, $rest) =
829             split (/:/, $rest, 5);
830 0         0 $clipdatavalues->{$coord} = decode_from_save($value);
831 0         0 $clipdataformulas->{$coord} = decode_from_save($formula);
832 0         0 $clipdatatypes->{$coord} = "c";
833 0         0 $clipvaluetypes->{$coord} = $valuetype;
834             } elsif ($type eq "vf") { # old format
835 0         0 ($value, $formula, $type, $rest) = split (/:/, $rest, 4);
836 0         0 $clipdatavalues->{$coord} = decode_from_save($value);
837 0         0 $clipdataformulas->{$coord} = decode_from_save($formula);
838 0         0 $clipdatatypes->{$coord} = "f";
839 0 0       0 if (substr($value, 0, 1) eq "N") {
    0          
    0          
840 0         0 $clipvaluetypes->{$coord} = "n";
841 0         0 $clipdatavalues->{$coord} =
842             substr($clipdatavalues->{$coord}, 1); # remove initial type code
843             } elsif (substr($value, 0, 1) eq "T") {
844 0         0 $clipvaluetypes->{$coord} = "t";
845 0         0 $clipdatavalues->{$coord} =
846             substr($clipdatavalues->{$coord}, 1); # remove initial type code
847             } elsif (substr($value, 0, 1) eq "H") {
848 0         0 $clipvaluetypes->{$coord} = "th";
849 0         0 $clipdatavalues->{$coord} =
850             substr($clipdatavalues->{$coord}, 1); # remove initial type code
851             } else {
852 0 0       0 $clipvaluetypes->{$coord} =
853             $clipvaluetypes->{$coord} =~ m/[^0-9+\-\.]/ ? "t" : "n";
854             }
855             } elsif ($type eq "e") {
856 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
857 0         0 $clipcellerrors->{$coord} = decode_from_save($value);
858             } elsif ($type eq "b") {
859 0         0 my ($t, $r, $b, $l);
860 0         0 ($t, $r, $b, $l, $type, $rest) = split (/:/, $rest, 6);
861 0         0 $clipcellattribs->{$coord}->{bt} = $t;
862 0         0 $clipcellattribs->{$coord}->{br} = $r;
863 0         0 $clipcellattribs->{$coord}->{bb} = $b;
864 0         0 $clipcellattribs->{$coord}->{bl} = $l;
865             } elsif ($type eq "l") {
866 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
867 0         0 $clipcellattribs->{$coord}->{layout} = $value;
868             } elsif ($type eq "f") {
869 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
870 0         0 $clipcellattribs->{$coord}->{font} = $value;
871             } elsif ($type eq "c") {
872 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
873 0         0 $clipcellattribs->{$coord}->{color} = $value;
874             } elsif ($type eq "bg") {
875 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
876 0         0 $clipcellattribs->{$coord}->{bgcolor} = $value;
877             } elsif ($type eq "cf") {
878 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
879 0         0 $clipcellattribs->{$coord}->{cellformat} = $value;
880             } elsif ($type eq "cvf") { # old
881 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
882 0         0 $clipcellattribs->{$coord}->{nontextvalueformat} = $value;
883             } elsif ($type eq "ntvf") {
884 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
885 0         0 $clipcellattribs->{$coord}->{nontextvalueformat} = $value;
886             } elsif ($type eq "tvf") {
887 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
888 0         0 $clipcellattribs->{$coord}->{textvalueformat} = $value;
889             } elsif ($type eq "colspan") {
890 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
891 0         0 $clipcellattribs->{$coord}->{colspan} = $value;
892             } elsif ($type eq "rowspan") {
893 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
894 0         0 $clipcellattribs->{$coord}->{rowspan} = $value;
895             } elsif ($type eq "cssc") {
896 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
897 0         0 $clipcellattribs->{$coord}->{cssc} = $value;
898             } elsif ($type eq "csss") {
899 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
900 0         0 $clipcellattribs->{$coord}->{csss} = decode_from_save($value);
901             } elsif ($type eq "mod") {
902 0         0 ($value, $type, $rest) = split (/:/, $rest, 3);
903 0         0 $clipcellattribs->{$coord}->{mod} = $value;
904             } elsif ($type eq "norange") {
905 0         0 last;
906             } else {
907 0         0 $errortext = "Unknown type '$type' in line:\n$_\n";
908 0         0 last;
909             }
910             }
911             } else {
912              
913             #!!!!!!
914 0 0       0 $errortext = "Unknown linetype: $linetype\n"
915             unless $linetype =~ m/^\s*#/;
916             }
917             }
918              
919 114   50     1095 $sheetattribs->{lastcol} ||= $maxcol || 1;
      66        
920 114   50     1158 $sheetattribs->{lastrow} ||= $maxrow || 1;
      66        
921             }
922              
923             =head2 create_sheet_save
924              
925             my $outstr = create_sheet_save(\%sheetdata)
926              
927             Sheet output routine. Returns a string ready to be saved in a file.
928              
929             =cut
930              
931             sub create_sheet_save {
932              
933             my (
934 0     0 1 0 $rest, $linetype, $coord, $type, $value, $formula, $style,
935             $colornum, $check, $maxrow, $maxcol, $row, $col
936             );
937              
938 0         0 my $sheetdata = shift @_;
939 0         0 my $outstr;
940              
941             # Get references to the parts
942              
943 0         0 my $datavalues = $sheetdata->{datavalues};
944 0         0 my $datatypes = $sheetdata->{datatypes};
945 0         0 my $valuetypes = $sheetdata->{valuetypes};
946 0         0 my $dataformulas = $sheetdata->{formulas};
947 0         0 my $cellerrors = $sheetdata->{cellerrors};
948 0         0 my $cellattribs = $sheetdata->{cellattribs};
949 0         0 my $colattribs = $sheetdata->{colattribs};
950 0         0 my $rowattribs = $sheetdata->{rowattribs};
951 0         0 my $sheetattribs = $sheetdata->{sheetattribs};
952 0         0 my $layoutstyles = $sheetdata->{layoutstyles};
953 0         0 my $layoutstylehash = $sheetdata->{layoutstylehash};
954 0         0 my $names = $sheetdata->{names};
955 0         0 my $fonts = $sheetdata->{fonts};
956 0         0 my $fonthash = $sheetdata->{fonthash};
957 0         0 my $colors = $sheetdata->{colors};
958 0         0 my $colorhash = $sheetdata->{colorhash};
959 0         0 my $borderstyles = $sheetdata->{borderstyles};
960 0         0 my $borderstylehash = $sheetdata->{borderstylehash};
961 0         0 my $cellformats = $sheetdata->{cellformats};
962 0         0 my $cellformathash = $sheetdata->{cellformathash};
963 0         0 my $valueformats = $sheetdata->{valueformats};
964 0         0 my $valueformathash = $sheetdata->{valueformathash};
965              
966 0         0 $outstr .= "version:1.3\n"; # sheet save version
967              
968 0         0 for (my $row = 1 ; $row <= $sheetattribs->{lastrow} ; $row++) {
969 0         0 for (my $col = 1 ; $col <= $sheetattribs->{lastcol} ; $col++) {
970 0         0 $coord = cr_to_coord($col, $row);
971             next
972 0 0       0 unless $cellattribs->{$coord}
973             ->{coord}; # skip if nothing set for this one
974 0         0 $outstr .= "cell:$coord";
975 0 0       0 if ($datatypes->{$coord} eq "v") {
    0          
    0          
    0          
976 0         0 $value = encode_for_save($datavalues->{$coord});
977 0 0 0     0 if (!$valuetypes->{$coord} || $valuetypes->{$coord} eq "n")
978             { # use simpler version
979 0         0 $outstr .= ":v:$value";
980             } else { # if we do fancy parsing to determine a type
981 0         0 $outstr .= ":vt:$valuetypes->{$coord}:$value";
982             }
983             } elsif ($datatypes->{$coord} eq "t") {
984 0         0 $value = encode_for_save($datavalues->{$coord});
985 0 0 0     0 if (!$valuetypes->{$coord} || $valuetypes->{$coord} eq "tw")
986             { # use simpler version
987 0         0 $outstr .= ":t:$value";
988             } else { # if we do fancy parsing to determine a type
989 0         0 $outstr .= ":vt:$valuetypes->{$coord}:$value";
990             }
991             } elsif ($datatypes->{$coord} eq "f") {
992 0         0 $value = encode_for_save($datavalues->{$coord});
993 0         0 $formula = encode_for_save($dataformulas->{$coord});
994 0         0 $outstr .= ":vtf:$valuetypes->{$coord}:$value:$formula";
995             } elsif ($datatypes->{$coord} eq "c") {
996 0         0 $value = encode_for_save($datavalues->{$coord});
997 0         0 $formula = encode_for_save($dataformulas->{$coord});
998 0         0 $outstr .= ":vtc:$valuetypes->{$coord}:$value:$formula";
999             }
1000              
1001 0 0       0 if ($cellerrors->{$coord}) {
1002 0         0 $value = encode_for_save($cellerrors->{$coord});
1003 0         0 $outstr .= ":e:$value";
1004             }
1005              
1006 0         0 my ($t, $r, $b, $l);
1007 0         0 $t = $cellattribs->{$coord}->{bt};
1008 0         0 $r = $cellattribs->{$coord}->{br};
1009 0         0 $b = $cellattribs->{$coord}->{bb};
1010 0         0 $l = $cellattribs->{$coord}->{bl};
1011 0 0 0     0 $outstr .= ":b:$t:$r:$b:$l" if ($t || $r || $b || $l);
      0        
      0        
1012              
1013 0 0       0 $outstr .= ":l:$cellattribs->{$coord}->{layout}"
1014             if $cellattribs->{$coord}->{layout};
1015 0 0       0 $outstr .= ":f:$cellattribs->{$coord}->{font}"
1016             if $cellattribs->{$coord}->{font};
1017 0 0       0 $outstr .= ":c:$cellattribs->{$coord}->{color}"
1018             if $cellattribs->{$coord}->{color};
1019 0 0       0 $outstr .= ":bg:$cellattribs->{$coord}->{bgcolor}"
1020             if $cellattribs->{$coord}->{bgcolor};
1021 0 0       0 $outstr .= ":cf:$cellattribs->{$coord}->{cellformat}"
1022             if $cellattribs->{$coord}->{cellformat};
1023 0 0       0 $outstr .= ":tvf:$cellattribs->{$coord}->{textvalueformat}"
1024             if $cellattribs->{$coord}->{textvalueformat};
1025 0 0       0 $outstr .= ":ntvf:$cellattribs->{$coord}->{nontextvalueformat}"
1026             if $cellattribs->{$coord}->{nontextvalueformat};
1027 0 0       0 $outstr .= ":colspan:$cellattribs->{$coord}->{colspan}"
1028             if $cellattribs->{$coord}->{colspan};
1029 0 0       0 $outstr .= ":rowspan:$cellattribs->{$coord}->{rowspan}"
1030             if $cellattribs->{$coord}->{rowspan};
1031 0 0       0 $outstr .= ":cssc:$cellattribs->{$coord}->{cssc}"
1032             if $cellattribs->{$coord}->{cssc};
1033 0 0       0 $outstr .= ":csss:" . encode_for_save($cellattribs->{$coord}->{csss})
1034             if $cellattribs->{$coord}->{csss};
1035 0 0       0 $outstr .= ":mod:$cellattribs->{$coord}->{mod}"
1036             if $cellattribs->{$coord}->{mod};
1037              
1038 0         0 $outstr .= "\n";
1039             }
1040             }
1041              
1042 0         0 for (my $col = 1 ; $col <= $sheetattribs->{lastcol} ; $col++) {
1043 0         0 $coord = cr_to_coord($col, 1);
1044 0         0 $coord =~ s/\d+//;
1045 0 0       0 $outstr .= "col:$coord:w:$colattribs->{$coord}->{width}\n"
1046             if $colattribs->{$coord}->{width};
1047 0 0       0 $outstr .= "col:$coord:hide:$colattribs->{$coord}->{hide}\n"
1048             if $colattribs->{$coord}->{hide};
1049             }
1050              
1051 0         0 for (my $row = 1 ; $row <= $sheetattribs->{lastrow} ; $row++) {
1052 0 0       0 $outstr .= "row:$row:w:$rowattribs->{$row}->{height}\n"
1053             if $rowattribs->{$row}->{height};
1054 0 0       0 $outstr .= "row:$row:hide:$rowattribs->{$row}->{hide}\n"
1055             if $rowattribs->{$row}->{hide};
1056             }
1057              
1058 0         0 $outstr .= "sheet";
1059 0         0 foreach my $field (keys %sheetfields) {
1060 0         0 my $value = encode_for_save($sheetattribs->{$field});
1061 0 0       0 $outstr .= ":$sheetfields{$field}:$value" if $value;
1062             }
1063 0         0 $outstr .= "\n";
1064              
1065 0         0 foreach my $namename (sort keys %$names) {
1066 0         0 my $namesc = encode_for_save(uc $namename);
1067 0         0 my $namedescsc = encode_for_save($names->{$namename}->{desc});
1068 0         0 my $namedefinitionsc = encode_for_save($names->{$namename}->{definition});
1069 0         0 $outstr .= "name:$namesc:$namedescsc:$namedefinitionsc\n";
1070             }
1071              
1072 0         0 for (my $i = 1 ; $i < @$layoutstyles ; $i++) {
1073 0         0 $outstr .= "layout:$i:$layoutstyles->[$i]\n";
1074             }
1075              
1076 0         0 for (my $i = 1 ; $i < @$fonts ; $i++) {
1077 0         0 $outstr .= "font:$i:$fonts->[$i]\n";
1078             }
1079              
1080 0         0 for (my $i = 1 ; $i < @$colors ; $i++) {
1081 0         0 $outstr .= "color:$i:$colors->[$i]\n";
1082             }
1083              
1084 0         0 for (my $i = 1 ; $i < @$borderstyles ; $i++) {
1085 0         0 $outstr .= "border:$i:$borderstyles->[$i]\n";
1086             }
1087              
1088 0         0 for (my $i = 1 ; $i < @$cellformats ; $i++) {
1089 0         0 $style = encode_for_save($cellformats->[$i]);
1090 0         0 $outstr .= "cellformat:$i:$style\n";
1091             }
1092              
1093 0         0 for (my $i = 1 ; $i < @$valueformats ; $i++) {
1094 0         0 $style = encode_for_save($valueformats->[$i]);
1095 0         0 $outstr .= "valueformat:$i:$style\n";
1096             }
1097              
1098 0 0       0 if ($sheetdata->{clipboard}) {
1099 0         0 my $clipdatavalues = $sheetdata->{clipboard}->{datavalues};
1100 0         0 my $clipdatatypes = $sheetdata->{clipboard}->{datatypes};
1101 0         0 my $clipvaluetypes = $sheetdata->{clipboard}->{valuetypes};
1102 0         0 my $clipdataformulas = $sheetdata->{clipboard}->{formulas};
1103 0         0 my $clipcellerrors = $sheetdata->{clipboard}->{cellerrors};
1104 0         0 my $clipcellattribs = $sheetdata->{clipboard}->{cellattribs};
1105              
1106 0         0 $outstr .= "clipboardrange:$sheetdata->{clipboard}->{range}\n";
1107              
1108 0         0 foreach my $coord (sort keys %$clipcellattribs) {
1109 0         0 $outstr .= "clipboard:$coord";
1110 0 0       0 if ($clipdatatypes->{$coord} eq "v") {
    0          
    0          
    0          
1111 0         0 $value = encode_for_save($clipdatavalues->{$coord});
1112 0 0 0     0 if (!$clipvaluetypes->{$coord} || $clipvaluetypes->{$coord} eq "n")
1113             { # use simpler version
1114 0         0 $outstr .= ":v:$value";
1115             } else { # if we do fancy parsing to determine a type
1116 0         0 $outstr .= ":vt:$clipvaluetypes->{$coord}:$value";
1117             }
1118             } elsif ($clipdatatypes->{$coord} eq "t") {
1119 0         0 $value = encode_for_save($clipdatavalues->{$coord});
1120 0 0 0     0 if (!$clipvaluetypes->{$coord} || $clipvaluetypes->{$coord} eq "tw")
1121             { # use simpler version
1122 0         0 $outstr .= ":t:$value";
1123             } else { # if we do fancy parsing to determine a type
1124 0         0 $outstr .= ":vt:$clipvaluetypes->{$coord}:$value";
1125             }
1126             } elsif ($clipdatatypes->{$coord} eq "f") {
1127 0         0 $value = encode_for_save($clipdatavalues->{$coord});
1128 0         0 $formula = encode_for_save($clipdataformulas->{$coord});
1129 0         0 $outstr .= ":vtf:$clipvaluetypes->{$coord}:$value:$formula";
1130             } elsif ($clipdatatypes->{$coord} eq "c") {
1131 0         0 $value = encode_for_save($clipdatavalues->{$coord});
1132 0         0 $formula = encode_for_save($clipdataformulas->{$coord});
1133 0         0 $outstr .= ":vtc:$clipvaluetypes->{$coord}:$value:$formula";
1134             }
1135              
1136 0 0       0 if ($clipcellerrors->{$coord}) {
1137 0         0 $value = encode_for_save($clipcellerrors->{$coord});
1138 0         0 $outstr .= ":e:$value";
1139             }
1140              
1141 0         0 my ($t, $r, $b, $l);
1142 0         0 $t = $clipcellattribs->{$coord}->{bt};
1143 0         0 $r = $clipcellattribs->{$coord}->{br};
1144 0         0 $b = $clipcellattribs->{$coord}->{bb};
1145 0         0 $l = $clipcellattribs->{$coord}->{bl};
1146 0 0 0     0 $outstr .= ":b:$t:$r:$b:$l" if ($t || $r || $b || $l);
      0        
      0        
1147              
1148 0 0       0 $outstr .= ":l:$clipcellattribs->{$coord}->{layout}"
1149             if $clipcellattribs->{$coord}->{layout};
1150 0 0       0 $outstr .= ":f:$clipcellattribs->{$coord}->{font}"
1151             if $clipcellattribs->{$coord}->{font};
1152 0 0       0 $outstr .= ":c:$clipcellattribs->{$coord}->{color}"
1153             if $clipcellattribs->{$coord}->{color};
1154 0 0       0 $outstr .= ":bg:$clipcellattribs->{$coord}->{bgcolor}"
1155             if $clipcellattribs->{$coord}->{bgcolor};
1156 0 0       0 $outstr .= ":cf:$clipcellattribs->{$coord}->{cellformat}"
1157             if $clipcellattribs->{$coord}->{cellformat};
1158 0 0       0 $outstr .= ":tvf:$clipcellattribs->{$coord}->{textvalueformat}"
1159             if $clipcellattribs->{$coord}->{textvalueformat};
1160 0 0       0 $outstr .= ":ntvf:$clipcellattribs->{$coord}->{nontextvalueformat}"
1161             if $clipcellattribs->{$coord}->{nontextvalueformat};
1162 0 0       0 $outstr .= ":colspan:$clipcellattribs->{$coord}->{colspan}"
1163             if $clipcellattribs->{$coord}->{colspan};
1164 0 0       0 $outstr .= ":rowspan:$clipcellattribs->{$coord}->{rowspan}"
1165             if $clipcellattribs->{$coord}->{rowspan};
1166 0 0       0 $outstr .= ":cssc:$clipcellattribs->{$coord}->{cssc}"
1167             if $clipcellattribs->{$coord}->{cssc};
1168 0 0       0 $outstr .=
1169             ":csss:" . encode_for_save($clipcellattribs->{$coord}->{csss})
1170             if $clipcellattribs->{$coord}->{csss};
1171 0 0       0 $outstr .= ":mod:$clipcellattribs->{$coord}->{mod}"
1172             if $clipcellattribs->{$coord}->{mod};
1173              
1174 0         0 $outstr .= "\n";
1175             }
1176              
1177             }
1178              
1179 0         0 return $outstr;
1180             }
1181              
1182             =head2 execute_sheet_command
1183              
1184             $ok = execute_sheet_command($sheetdata, $command);
1185              
1186             Executes commands that modify the sheet data. Sets sheet "needsrecalc" as needed.
1187              
1188             The commands are in the forms:
1189              
1190             set sheet attributename value (plus lastcol and lastrow)
1191             set 22 attributename value
1192             set B attributename value
1193             set A1 attributename value1 value2... (see each attribute below for details)
1194             set A1:B5 attributename value1 value2...
1195             erase/copy/cut/paste/fillright/filldown A1:B5 all/formulas/format
1196             clearclipboard
1197             merge C3:F3
1198             unmerge C3
1199             insertcol/insertrow C5
1200             deletecol/deleterow C5:E7
1201             name define NAME definition
1202             name desc NAME description
1203             name delete NAME
1204              
1205             =cut
1206              
1207             sub execute_sheet_command {
1208              
1209 679     679 1 1546 my ($sheetdata, $command) = @_;
1210              
1211             # Get references to the parts
1212              
1213 679         1609 my $datavalues = $sheetdata->{datavalues};
1214 679         1657 my $datatypes = $sheetdata->{datatypes};
1215 679         1294 my $valuetypes = $sheetdata->{valuetypes};
1216 679         1349 my $dataformulas = $sheetdata->{formulas};
1217 679         1280 my $cellerrors = $sheetdata->{cellerrors};
1218 679         1338 my $cellattribs = $sheetdata->{cellattribs};
1219 679         1239 my $colattribs = $sheetdata->{colattribs};
1220 679         1432 my $rowattribs = $sheetdata->{rowattribs};
1221 679         1165 my $sheetattribs = $sheetdata->{sheetattribs};
1222 679         1298 my $layoutstyles = $sheetdata->{layoutstyles};
1223 679         1357 my $layoutstylehash = $sheetdata->{layoutstylehash};
1224 679         1283 my $names = $sheetdata->{names};
1225 679         1240 my $fonts = $sheetdata->{fonts};
1226 679         1314 my $fonthash = $sheetdata->{fonthash};
1227 679         1161 my $colors = $sheetdata->{colors};
1228 679         1141 my $colorhash = $sheetdata->{colorhash};
1229 679         1557 my $borderstyles = $sheetdata->{borderstyles};
1230 679         1084 my $borderstylehash = $sheetdata->{borderstylehash};
1231 679         1154 my $cellformats = $sheetdata->{cellformats};
1232 679         3096 my $cellformathash = $sheetdata->{cellformathash};
1233 679         1235 my $valueformats = $sheetdata->{valueformats};
1234 679         1118 my $valueformathash = $sheetdata->{valueformathash};
1235              
1236             my (
1237 679         1092 $what, $coord1, $coord2, $attrib, $name,
1238             $value, $v1, $v2, $v3, $errortext
1239             );
1240              
1241 679         3150 my ($cmd1, $rest) = split (/ /, $command, 2);
1242 679 50       2014 return unless $cmd1;
1243              
1244 679 100 33     2008 if ($cmd1 eq "set") {
    100 33        
    50          
    50          
    50          
    50          
    50          
    100          
1245 673         3129 ($what, $attrib, $rest) = split (/ /, $rest, 3);
1246 673 50       10511 if ($what eq "sheet") { # sheet attributes
    50          
    50          
    50          
1247 0 0 0     0 if ($attrib eq "defaultcolwidth") {
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
1248 0         0 $sheetattribs->{defaultcolwidth} = $rest;
1249             } elsif ($attrib eq "defaultcolor" || $attrib eq "defaultbgcolor") {
1250 0         0 my $colordef = 0;
1251 0 0       0 $colordef = $colorhash->{$rest} if $rest;
1252 0 0       0 if (!$colordef) {
1253 0 0       0 if ($rest) {
1254 0 0       0 push @$colors, "" unless scalar @$colors;
1255 0         0 $colordef = (push @$colors, $rest) - 1;
1256 0         0 $colorhash->{$rest} = $colordef;
1257             }
1258             }
1259 0         0 $sheetattribs->{$attrib} = $colordef;
1260             } elsif ($attrib eq "defaultlayout") {
1261 0         0 my $layoutdef = 0;
1262 0 0       0 $layoutdef = $layoutstylehash->{$rest} if $rest;
1263 0 0       0 if (!$layoutdef) {
1264 0 0       0 if ($rest) {
1265 0 0       0 push @$layoutstyles, "" unless scalar @$layoutstyles;
1266 0         0 $layoutdef = (push @$layoutstyles, $rest) - 1;
1267 0         0 $layoutstylehash->{$rest} = $layoutdef;
1268             }
1269             }
1270 0         0 $sheetattribs->{$attrib} = $layoutdef;
1271             } elsif ($attrib eq "defaultfont") {
1272 0         0 my $fontdef = 0;
1273 0 0       0 $rest = "" if $rest eq "* * *";
1274 0 0       0 $fontdef = $fonthash->{$rest} if $rest;
1275 0 0       0 if (!$fontdef) {
1276 0 0       0 if ($rest) {
1277 0 0       0 push @$fonts, "" unless scalar @$fonts;
1278 0         0 $fontdef = (push @$fonts, $rest) - 1;
1279 0         0 $fonthash->{$rest} = $fontdef;
1280             }
1281             }
1282 0         0 $sheetattribs->{$attrib} = $fontdef;
1283             } elsif ($attrib eq "defaulttextformat"
1284             || $attrib eq "defaultnontextformat") {
1285 0         0 my $formatdef = 0;
1286 0 0       0 $formatdef = $cellformathash->{$rest} if $rest;
1287 0 0       0 if (!$formatdef) {
1288 0 0       0 if ($rest) {
1289 0 0       0 push @$cellformats, "" unless scalar @$cellformats;
1290 0         0 $formatdef = (push @$cellformats, $rest) - 1;
1291 0         0 $cellformathash->{$rest} = $formatdef;
1292             }
1293             }
1294 0         0 $sheetattribs->{$attrib} = $formatdef;
1295             } elsif ($attrib eq "defaulttextvalueformat"
1296             || $attrib eq "defaultnontextvalueformat") {
1297 0         0 my $formatdef = 0;
1298 0 0       0 $formatdef = $valueformathash->{$rest} if length($rest);
1299 0 0       0 if (!$formatdef) {
1300 0 0       0 if (length($rest)) {
1301 0 0       0 push @$valueformats, "" unless scalar @$valueformats;
1302 0         0 $formatdef = (push @$valueformats, $rest) - 1;
1303 0         0 $valueformathash->{$rest} = $formatdef;
1304             }
1305             }
1306 0         0 $sheetattribs->{$attrib} = $formatdef;
1307             } elsif ($attrib eq "lastcol") {
1308 0         0 $sheetattribs->{lastcol} = $rest + 0;
1309 0 0       0 $sheetattribs->{lastcol} = 1 if ($sheetattribs->{lastcol} <= 0);
1310             } elsif ($attrib eq "lastrow") {
1311 0         0 $sheetattribs->{lastrow} = $rest + 0;
1312 0 0       0 $sheetattribs->{lastrow} = 1 if ($sheetattribs->{lastrow} <= 0);
1313             }
1314             } elsif ($what =~ m/^(\d+)(\:(\d+)){0,1}$/) { # row attributes
1315 0         0 my ($row1, $row2);
1316 0 0       0 if ($what =~ m/^(.+?):(.+?)$/) {
1317 0         0 $row1 = $1;
1318 0         0 $row2 = $2;
1319             } else {
1320 0         0 $row1 = $what;
1321 0         0 $row2 = $row1;
1322             }
1323 0 0       0 if ($attrib eq "hide") {
1324 0         0 for (my $r = $row1 ; $r <= $row2 ; $r++) {
1325 0 0       0 $rowattribs->{$r} = { 'coord' => $r } unless $rowattribs->{$r};
1326 0         0 $rowattribs->{$r}->{hide} = $rest;
1327             }
1328             } else {
1329 0         0 $errortext = "Unknown attributename '$attrib' in line:\n$command\n";
1330 0         0 return 0;
1331             }
1332             } elsif ($what =~ m/(^[a-zA-Z])([a-zA-Z])?(:[a-zA-Z][a-zA-Z]?){0,1}$/)
1333             { # column attributes
1334 0         0 my ($col1, $col2);
1335 0 0       0 if ($what =~ m/(.+?):(.+?)/) {
1336 0         0 $col1 = col_to_number($1);
1337 0         0 $col2 = col_to_number($2);
1338             } else {
1339 0         0 $col1 = col_to_number($what);
1340 0         0 $col2 = $col1;
1341             }
1342 0 0       0 if ($attrib eq "width") {
1343 0         0 for (my $c = $col1 ; $c <= $col2 ; $c++) {
1344 0         0 my $colname = number_to_col($c);
1345 0 0       0 $colattribs->{$colname} = { 'coord' => $colname }
1346             unless $colattribs->{$colname};
1347 0         0 $colattribs->{$colname}->{width} = $rest;
1348             }
1349             }
1350 0 0       0 if ($attrib eq "hide") {
1351 0         0 for (my $c = $col1 ; $c <= $col2 ; $c++) {
1352 0         0 my $colname = number_to_col($c);
1353 0 0       0 $colattribs->{$colname} = { 'coord' => $colname }
1354             unless $colattribs->{$colname};
1355 0         0 $colattribs->{$colname}->{hide} = $rest;
1356             }
1357             } else {
1358 0         0 $errortext = "Unknown attributename '$attrib' in line:\n$command\n";
1359 0         0 return 0;
1360             }
1361             } elsif ($what =~ m/([a-z]|[A-Z])([a-z]|[A-Z])?(\d+)/) { # cell attributes
1362 673         1615 $what = uc($what);
1363 673         2204 ($coord1, $coord2) = split (/:/, $what);
1364 673         2608 my ($c1, $r1) = coord_to_cr($coord1);
1365 673         1285 my $c2 = $c1;
1366 673         1191 my $r2 = $r1;
1367 673 50       1601 ($c2, $r2) = coord_to_cr($coord2) if $coord2;
1368 673 100       2555 $sheetattribs->{lastcol} = $c2 if $c2 > $sheetattribs->{lastcol};
1369 673 100       3196 $sheetattribs->{lastrow} = $r2 if $r2 > $sheetattribs->{lastrow};
1370              
1371 673         2224 for (my $r = $r1 ; $r <= $r2 ; $r++) {
1372 673         2190 for (my $c = $c1 ; $c <= $c2 ; $c++) {
1373 673         2558 my $cr = cr_to_coord($c, $r);
1374 673 100 33     3477 if ($attrib eq "value") { # set coord value type numeric-value
    100 33        
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
1375 14 50       77 $cellattribs->{$cr} = { 'coord' => $cr }
1376             unless $cellattribs->{$cr}->{coord};
1377 14         42 ($v1, $v2) = split (/ /, $rest, 2);
1378 14         31 $datavalues->{$cr} = $v2;
1379 14         30 delete $cellerrors->{$cr};
1380 14         24 $datatypes->{$cr} = "v";
1381 14         26 $valuetypes->{$cr} = $v1;
1382 14         76 $sheetdata->{sheetattribs}->{needsrecalc} = "yes";
1383             } elsif ($attrib eq "text") { # set coord text type text-value
1384 8 50       69 $cellattribs->{$cr} = { 'coord' => $cr }
1385             unless $cellattribs->{$cr}->{coord};
1386 8         37 ($v1, $v2) = split (/ /, $rest, 2);
1387 8         24 $datavalues->{$cr} = $v2;
1388 8         27 delete $cellerrors->{$cr};
1389 8         31 $datatypes->{$cr} = "t";
1390 8         25 $valuetypes->{$cr} = $v1;
1391 8         58 $sheetdata->{sheetattribs}->{needsrecalc} = "yes";
1392             } elsif ($attrib eq "formula")
1393             { # set coord formula formula-body-less-initial-=
1394 648 100       5269 $cellattribs->{$cr} = { 'coord' => $cr }
1395             unless $cellattribs->{$cr}->{coord};
1396 648         2294 $datavalues->{$cr} = 0;
1397 648         1380 delete $cellerrors->{$cr};
1398 648         1999 $datatypes->{$cr} = "f";
1399 648         1708 $valuetypes->{$cr} = "n"; # until recalc'ed
1400 648         1718 $dataformulas->{$cr} = $rest;
1401 648         3804 $sheetdata->{sheetattribs}->{needsrecalc} = "yes";
1402             } elsif ($attrib eq "constant")
1403             { # set coord constant type numeric-value source-text
1404 1 50       6 $cellattribs->{$cr} = { 'coord' => $cr }
1405             unless $cellattribs->{$cr}->{coord};
1406 1         4 ($v1, $v2, $v3) = split (/ /, $rest, 3);
1407 1         4 $datavalues->{$cr} = $v2;
1408 1 50       3 if (substr($v1, 0, 1) eq "e") { # error
1409 0         0 $cellerrors->{$cr} = substr($v1, 1);
1410             } else {
1411 1         3 delete $cellerrors->{$cr};
1412             }
1413 1         3 $datatypes->{$cr} = "c";
1414 1         2 $valuetypes->{$cr} = $v1;
1415 1         3 $dataformulas->{$cr} = $v3;
1416 1         6 $sheetdata->{sheetattribs}->{needsrecalc} = "yes";
1417             } elsif ($attrib eq "empty") { # erase value
1418 1         2 delete $datavalues->{$cr};
1419 1         2 delete $cellerrors->{$cr};
1420 1         2 delete $datatypes->{$cr};
1421 1         31 delete $valuetypes->{$cr};
1422 1         6 $sheetdata->{sheetattribs}->{needsrecalc} = "yes";
1423             } elsif ($attrib =~ m/^b[trbl]$/) {
1424 0 0       0 $cellattribs->{$cr} = { 'coord' => $cr }
1425             unless $cellattribs->{$cr}->{coord};
1426 0         0 my $borderdef = 0;
1427 0 0       0 $borderdef = $borderstylehash->{$rest} if $rest;
1428 0 0       0 if (!$borderdef) {
1429 0 0       0 if ($rest) {
1430 0 0       0 push @$borderstyles, "" unless scalar @$borderstyles;
1431 0         0 $borderdef = (push @$borderstyles, $rest) - 1;
1432 0         0 $borderstylehash->{$rest} = $borderdef;
1433             }
1434             }
1435 0         0 $cellattribs->{$cr}->{$attrib} = $borderdef;
1436             } elsif ($attrib eq "color" || $attrib eq "bgcolor") {
1437 0 0       0 $cellattribs->{$cr} = { 'coord' => $cr }
1438             unless $cellattribs->{$cr}->{coord};
1439 0         0 my $colordef = 0;
1440 0 0       0 $colordef = $colorhash->{$rest} if $rest;
1441 0 0       0 if (!$colordef) {
1442 0 0       0 if ($rest) {
1443 0 0       0 push @$colors, "" unless scalar @$colors;
1444 0         0 $colordef = (push @$colors, $rest) - 1;
1445 0         0 $colorhash->{$rest} = $colordef;
1446             }
1447             }
1448 0         0 $cellattribs->{$cr}->{$attrib} = $colordef;
1449             } elsif ($attrib eq "layout") {
1450 0 0       0 $cellattribs->{$cr} = { 'coord' => $cr }
1451             unless $cellattribs->{$cr}->{coord};
1452 0         0 my $layoutdef = 0;
1453 0 0       0 $layoutdef = $layoutstylehash->{$rest} if $rest;
1454 0 0       0 if (!$layoutdef) {
1455 0 0       0 if ($rest) {
1456 0 0       0 push @$layoutstyles, "" unless scalar @$layoutstyles;
1457 0         0 $layoutdef = (push @$layoutstyles, $rest) - 1;
1458 0         0 $layoutstylehash->{$rest} = $layoutdef;
1459             }
1460             }
1461 0         0 $cellattribs->{$cr}->{$attrib} = $layoutdef;
1462             } elsif ($attrib eq "font") {
1463 0 0       0 $cellattribs->{$cr} = { 'coord' => $cr }
1464             unless $cellattribs->{$cr}->{coord};
1465 0         0 my $fontdef = 0;
1466 0 0       0 $rest = "" if $rest eq "* * *";
1467 0 0       0 $fontdef = $fonthash->{$rest} if $rest;
1468 0 0       0 if (!$fontdef) {
1469 0 0       0 if ($rest) {
1470 0 0       0 push @$fonts, "" unless scalar @$fonts;
1471 0         0 $fontdef = (push @$fonts, $rest) - 1;
1472 0         0 $fonthash->{$rest} = $fontdef;
1473             }
1474             }
1475 0         0 $cellattribs->{$cr}->{$attrib} = $fontdef;
1476             } elsif ($attrib eq "cellformat") {
1477 0 0       0 $cellattribs->{$cr} = { 'coord' => $cr }
1478             unless $cellattribs->{$cr}->{coord};
1479 0         0 my $formatdef = 0;
1480 0 0       0 $formatdef = $cellformathash->{$rest} if $rest;
1481 0 0       0 if (!$formatdef) {
1482 0 0       0 if ($rest) {
1483 0 0       0 push @$cellformats, "" unless scalar @$cellformats;
1484 0         0 $formatdef = (push @$cellformats, $rest) - 1;
1485 0         0 $cellformathash->{$rest} = $formatdef;
1486             }
1487             }
1488 0         0 $cellattribs->{$cr}->{$attrib} = $formatdef;
1489             } elsif ($attrib eq "textvalueformat"
1490             || $attrib eq "nontextvalueformat") {
1491 0 0       0 $cellattribs->{$cr} = { 'coord' => $cr }
1492             unless $cellattribs->{$cr}->{coord};
1493 0         0 my $formatdef = 0;
1494 0 0       0 $formatdef = $valueformathash->{$rest} if length($rest);
1495 0 0       0 if (!$formatdef) {
1496 0 0       0 if (length($rest)) {
1497 0 0       0 push @$valueformats, "" unless scalar @$valueformats;
1498 0         0 $formatdef = (push @$valueformats, $rest) - 1;
1499 0         0 $valueformathash->{$rest} = $formatdef;
1500             }
1501             }
1502 0         0 $cellattribs->{$cr}->{$attrib} = $formatdef;
1503             } elsif ($attrib eq "cssc") {
1504 0 0       0 $cellattribs->{$cr} = { 'coord' => $cr }
1505             unless $cellattribs->{$cr}->{coord};
1506 0         0 $rest =~ s/[^a-zA-Z0-9\-]//g;
1507 0         0 $cellattribs->{$cr}->{$attrib} = $rest;
1508             } elsif ($attrib eq "csss") {
1509 0 0       0 $cellattribs->{$cr} = { 'coord' => $cr }
1510             unless $cellattribs->{$cr}->{coord};
1511 0         0 $rest =~ s/\n//g;
1512 0         0 $cellattribs->{$cr}->{$attrib} = $rest;
1513             } elsif ($attrib eq "mod") {
1514 0 0       0 $cellattribs->{$cr} = { 'coord' => $cr }
1515             unless $cellattribs->{$cr}->{coord};
1516 0         0 $rest =~ s/[^yY]//g;
1517 0         0 $cellattribs->{$cr}->{$attrib} = lc $rest;
1518             } else {
1519 1         4 $errortext =
1520             "Unknown attributename '$attrib' in line:\n$command\n";
1521 1         5 return 0;
1522             }
1523             }
1524             }
1525             }
1526             }
1527              
1528             elsif ($cmd1 =~ m/^(?:erase|copy|cut|paste|fillright|filldown|sort)$/) {
1529 2         17 ($what, $rest) = split (/ /, $rest, 2);
1530 2         6 $what = uc($what);
1531 2         4 ($coord1, $coord2) = split (/:/, $what);
1532 2         21 my ($c1, $r1) = coord_to_cr($coord1);
1533 2         5 my $c2 = $c1;
1534 2         2 my $r2 = $r1;
1535 2 50       10 ($c2, $r2) = coord_to_cr($coord2) if $coord2;
1536 2 50       7 $sheetattribs->{lastcol} = $c2 if $c2 > $sheetattribs->{lastcol};
1537 2 100       8 $sheetattribs->{lastrow} = $r2 if $r2 > $sheetattribs->{lastrow};
1538              
1539 2 50 33     28 if ($cmd1 eq "erase") {
    50 66        
    100          
    50          
    0          
1540 0         0 for (my $r = $r1 ; $r <= $r2 ; $r++) {
1541 0         0 for (my $c = $c1 ; $c <= $c2 ; $c++) {
1542 0         0 my $cr = cr_to_coord($c, $r);
1543 0 0       0 if ($rest eq "all") {
    0          
    0          
1544 0         0 delete $cellattribs->{$cr};
1545 0         0 delete $datavalues->{$cr};
1546 0         0 delete $dataformulas->{$cr};
1547 0         0 delete $cellerrors->{$cr};
1548 0         0 delete $datatypes->{$cr};
1549 0         0 delete $valuetypes->{$cr};
1550             } elsif ($rest eq "formulas") {
1551 0         0 delete $datavalues->{$cr};
1552 0         0 delete $dataformulas->{$cr};
1553 0         0 delete $cellerrors->{$cr};
1554 0         0 delete $datatypes->{$cr};
1555 0         0 delete $valuetypes->{$cr};
1556             } elsif ($rest eq "formats") {
1557 0         0 $cellattribs->{$cr} = { 'coord' => $cr }; # Leave with minimal set
1558             }
1559             }
1560             }
1561 0         0 $sheetdata->{sheetattribs}->{needsrecalc} = "yes";
1562             }
1563              
1564             elsif ($cmd1 eq "fillright" || $cmd1 eq "filldown") {
1565 0         0 my ($fillright, $rowstart, $colstart);
1566 0 0       0 if ($cmd1 eq "fillright") {
1567 0         0 $fillright = 1;
1568 0         0 $rowstart = $r1;
1569 0         0 $colstart = $c1 + 1;
1570             } else {
1571 0         0 $rowstart = $r1 + 1;
1572 0         0 $colstart = $c1;
1573             }
1574 0         0 for (my $r = $rowstart ; $r <= $r2 ; $r++) {
1575 0         0 for (my $c = $colstart ; $c <= $c2 ; $c++) {
1576 0         0 my $cr = cr_to_coord($c, $r);
1577 0         0 my ($crbase, $rowoffset, $coloffset);
1578 0 0       0 if ($fillright) {
1579 0         0 $crbase = cr_to_coord($c1, $r);
1580 0         0 $coloffset = $c - $colstart + 1;
1581 0         0 $rowoffset = 0;
1582             } else {
1583 0         0 $crbase = cr_to_coord($c, $r1);
1584 0         0 $coloffset = 0;
1585 0         0 $rowoffset = $r - $rowstart + 1;
1586             }
1587 0 0 0     0 if ($rest eq "all" || $rest eq "formats") {
1588 0         0 $cellattribs->{$cr} = { 'coord' => $cr }; # Start with minimal set
1589 0         0 foreach my $attribtype (keys %{ $cellattribs->{$crbase} }) {
  0         0  
1590 0 0       0 if ($attribtype ne "coord") {
1591 0         0 $cellattribs->{$cr}->{$attribtype} =
1592             $cellattribs->{$crbase}->{$attribtype};
1593             }
1594             }
1595             }
1596 0 0 0     0 if ($rest eq "all" || $rest eq "formulas") {
1597 0 0       0 $cellattribs->{$cr} = { 'coord' => $cr }
1598             unless $cellattribs->{$cr}->{coord}; # Make sure this exists
1599 0         0 $datavalues->{$cr} = $datavalues->{$crbase};
1600 0         0 $datatypes->{$cr} = $datatypes->{$crbase};
1601 0         0 $valuetypes->{$cr} = $valuetypes->{$crbase};
1602 0 0       0 if ($datatypes->{$cr} eq "f")
1603             { # offset relative coords, even in sheet references
1604 0         0 $dataformulas->{$cr} =
1605             offset_formula_coords($dataformulas->{$crbase},
1606             $coloffset, $rowoffset);
1607             } else {
1608 0         0 $dataformulas->{$cr} = $dataformulas->{$crbase};
1609             }
1610 0         0 $cellerrors->{$cr} = $cellerrors->{$crbase};
1611             }
1612             }
1613             }
1614 0         0 $sheetdata->{sheetattribs}->{needsrecalc} = "yes";
1615             }
1616              
1617             elsif ($cmd1 eq "copy" || $cmd1 eq "cut") {
1618 1         3 $sheetdata->{clipboard} = {}; # clear and create clipboard
1619 1         2 $sheetdata->{clipboard}->{datavalues} = {};
1620 1         3 my $clipdatavalues = $sheetdata->{clipboard}->{datavalues};
1621 1         3 $sheetdata->{clipboard}->{datatypes} = {};
1622 1         2 my $clipdatatypes = $sheetdata->{clipboard}->{datatypes};
1623 1         2 $sheetdata->{clipboard}->{valuetypes} = {};
1624 1         3 my $clipvaluetypes = $sheetdata->{clipboard}->{valuetypes};
1625 1         2 $sheetdata->{clipboard}->{formulas} = {};
1626 1         3 my $clipdataformulas = $sheetdata->{clipboard}->{formulas};
1627 1         2 $sheetdata->{clipboard}->{cellerrors} = {};
1628 1         2 my $clipcellerrors = $sheetdata->{clipboard}->{cellerrors};
1629 1         2 $sheetdata->{clipboard}->{cellattribs} = {};
1630 1         2 my $clipcellattribs = $sheetdata->{clipboard}->{cellattribs};
1631              
1632 1         5 for (my $r = $r1 ; $r <= $r2 ; $r++) {
1633 3         16 for (my $c = $c1 ; $c <= $c2 ; $c++) {
1634 3         7 my $cr = cr_to_coord($c, $r);
1635 3         13 $clipcellattribs->{$cr}->{ 'coord' => $cr } =
1636             ''; # make sure something (used for save)
1637 3 50 33     10 if ($rest eq "all" || $rest eq "formats") {
1638 3         7 foreach my $attribtype (keys %{ $cellattribs->{$cr} }) {
  3         9  
1639 3         11 $clipcellattribs->{$cr}->{$attribtype} =
1640             $cellattribs->{$cr}->{$attribtype};
1641             }
1642 3 50       10 if ($cmd1 eq "cut") {
1643 0         0 delete $cellattribs->{$cr};
1644 0 0       0 $cellattribs->{$cr} = { 'coord' => $cr } if $rest eq "formats";
1645             }
1646             }
1647 3 50 33     9 if ($rest eq "all" || $rest eq "formulas") {
1648 3         8 $clipcellattribs->{$cr}->{coord} =
1649             $cellattribs->{$cr}->{coord}; # used by save
1650 3         6 $clipdatavalues->{$cr} = $datavalues->{$cr};
1651 3         6 $clipdataformulas->{$cr} = $dataformulas->{$cr};
1652 3         18 $clipcellerrors->{$cr} = $cellerrors->{$cr};
1653 3         7 $clipdatatypes->{$cr} = $datatypes->{$cr};
1654 3         7 $clipvaluetypes->{$cr} = $valuetypes->{$cr};
1655 3 50       17 if ($cmd1 eq "cut") {
1656 0         0 delete $datavalues->{$cr};
1657 0         0 delete $dataformulas->{$cr};
1658 0         0 delete $cellerrors->{$cr};
1659 0         0 delete $datatypes->{$cr};
1660 0         0 delete $valuetypes->{$cr};
1661             }
1662             }
1663             }
1664             }
1665 1 50       19 $sheetdata->{clipboard}->{range} =
1666             $coord2 ? "$coord1:$coord2" : "$coord1:$coord1";
1667 1 50       4 $sheetdata->{sheetattribs}->{needsrecalc} = "yes" if $cmd1 eq "cut";
1668             }
1669              
1670             elsif ($cmd1 eq "paste") {
1671 1         2 my $crbase = $sheetdata->{clipboard}->{range};
1672 1 50       3 if (!$crbase) {
1673 0         0 $errortext = "Empty clipboard\n";
1674 0         0 return 0;
1675             }
1676 1         2 my $clipdatavalues = $sheetdata->{clipboard}->{datavalues};
1677 1         1 my $clipdatatypes = $sheetdata->{clipboard}->{datatypes};
1678 1         2 my $clipvaluetypes = $sheetdata->{clipboard}->{valuetypes};
1679 1         2 my $clipdataformulas = $sheetdata->{clipboard}->{formulas};
1680 1         2 my $clipcellerrors = $sheetdata->{clipboard}->{cellerrors};
1681 1         2 my $clipcellattribs = $sheetdata->{clipboard}->{cellattribs};
1682              
1683 1         2 my ($clipcoord1, $clipcoord2) = split (/:/, $crbase);
1684 1 50       3 $clipcoord2 = $clipcoord1 unless $clipcoord2;
1685 1         3 my ($clipc1, $clipr1) = coord_to_cr($clipcoord1);
1686 1         3 my ($clipc2, $clipr2) = coord_to_cr($clipcoord2);
1687 1         2 my $coloffset = $c1 - $clipc1;
1688 1         2 my $rowoffset = $r1 - $clipr1;
1689 1         4 my $numcols = $clipc2 - $clipc1 + 1;
1690 1         1 my $numrows = $clipr2 - $clipr1 + 1;
1691 1 50       11 $sheetattribs->{lastcol} = $c1 + $numcols - 1
1692             if $c1 + $numcols - 1 > $sheetattribs->{lastcol};
1693 1 50       5 $sheetattribs->{lastrow} = $r1 + $numrows - 1
1694             if $r1 + $numrows - 1 > $sheetattribs->{lastrow};
1695              
1696 1         3 for (my $r = 0 ; $r < $numrows ; $r++) {
1697 3         8 for (my $c = 0 ; $c < $numcols ; $c++) {
1698 3         7 my $cr = cr_to_coord($c1 + $c, $r1 + $r);
1699 3         11 my $clipcr = cr_to_coord($clipc1 + $c, $clipr1 + $r);
1700 3 50 33     9 if ($rest eq "all" || $rest eq "formats") {
1701 3         8 $cellattribs->{$cr} = { 'coord' => $cr }; # Start with minimal set
1702 3         4 foreach my $attribtype (keys %{ $clipcellattribs->{$clipcr} }) {
  3         9  
1703 6 100       20 if ($attribtype ne "coord") {
1704 3         9 $cellattribs->{$cr}->{$attribtype} =
1705             $clipcellattribs->{$clipcr}->{$attribtype};
1706             }
1707             }
1708             }
1709 3 50 33     10 if ($rest eq "all" || $rest eq "formulas") {
1710 3 50       7 $cellattribs->{$cr} = { 'coord' => $cr }
1711             unless $cellattribs->{$cr}->{coord}; # Make sure this exists
1712 3         4 $datavalues->{$cr} = $clipdatavalues->{$clipcr};
1713 3         7 $datatypes->{$cr} = $clipdatatypes->{$clipcr};
1714 3         5 $valuetypes->{$cr} = $clipvaluetypes->{$clipcr};
1715 3 50       8 if ($datatypes->{$cr} eq "f")
1716             { # offset coord refs, even to *** relative *** coords in other sheets
1717 0         0 $dataformulas->{$cr} =
1718             offset_formula_coords($clipdataformulas->{$clipcr},
1719             $coloffset, $rowoffset);
1720             } else {
1721 3         5 $dataformulas->{$cr} = $clipdataformulas->{$clipcr};
1722             }
1723 3         13 $cellerrors->{$cr} = $clipcellerrors->{$clipcr};
1724             }
1725             }
1726             }
1727 1         3 $sheetdata->{sheetattribs}->{needsrecalc} = "yes";
1728             }
1729              
1730             elsif ($cmd1 eq "sort")
1731             { # sort cr1:cr2 col1 up/down col2 up/down col3 up/down
1732 0         0 my @col_dirs = split (/\s+/, $rest);
1733 0         0 my (@cols, @dirs);
1734 0         0 ($cols[1], $dirs[1], $cols[2], $dirs[2], $cols[3], $dirs[3]) =
1735             @col_dirs;
1736 0         0 my $nsortcols = int((scalar @col_dirs) / 2);
1737 0         0 my $sortdata = {}; # make a place to hold data to sort
1738 0         0 $sortdata->{datavalues} = {};
1739 0         0 my $sortdatavalues = $sortdata->{datavalues};
1740 0         0 $sortdata->{datatypes} = {};
1741 0         0 my $sortdatatypes = $sortdata->{datatypes};
1742 0         0 $sortdata->{valuetypes} = {};
1743 0         0 my $sortvaluetypes = $sortdata->{valuetypes};
1744 0         0 $sortdata->{formulas} = {};
1745 0         0 my $sortdataformulas = $sortdata->{formulas};
1746 0         0 $sortdata->{cellerrors} = {};
1747 0         0 my $sortcellerrors = $sortdata->{cellerrors};
1748 0         0 $sortdata->{cellattribs} = {};
1749 0         0 my $sortcellattribs = $sortdata->{cellattribs};
1750              
1751 0         0 my (@sortlist, @sortvalues, @sorttypes, @rowvalues, @rowtypes);
1752 0         0 for (my $r = $r1 ; $r <= $r2 ; $r++)
1753             { # make a copy to replace over original in new order
1754 0         0 for (my $c = $c1 ; $c <= $c2 ; $c++) {
1755 0         0 my $cr = cr_to_coord($c, $r);
1756 0 0       0 next if !$cellattribs->{$cr}->{coord}; # don't copy blank cells
1757 0         0 $sortcellattribs->{$cr}->{ 'coord' => $cr } = '';
1758 0         0 foreach my $attribtype (keys %{ $cellattribs->{$cr} }) {
  0         0  
1759 0         0 $sortcellattribs->{$cr}->{$attribtype} =
1760             $cellattribs->{$cr}->{$attribtype};
1761             }
1762 0         0 $sortcellattribs->{$cr}->{coord} =
1763             $cellattribs->{$cr}->{coord}; # used by save
1764 0         0 $sortdatavalues->{$cr} = $datavalues->{$cr};
1765 0         0 $sortdataformulas->{$cr} = $dataformulas->{$cr};
1766 0         0 $sortcellerrors->{$cr} = $cellerrors->{$cr};
1767 0         0 $sortdatatypes->{$cr} = $datatypes->{$cr};
1768 0         0 $sortvaluetypes->{$cr} = $valuetypes->{$cr};
1769             }
1770 0         0 push @sortlist, scalar @sortlist; # make list to sort (0..numrows-1)
1771 0         0 @rowvalues = ();
1772 0         0 @rowtypes = ();
1773 0         0 for (my $i = 1 ; $i <= $nsortcols ; $i++)
1774             { # save values and types for comparing
1775 0         0 my $cr = "$cols[$i]$r"; # get from each sorting column
1776 0         0 push @rowvalues, $datavalues->{$cr};
1777 0   0     0 push @rowtypes,
1778             (substr($valuetypes->{$cr}, 0, 1) || "b"); # just major type
1779             }
1780 0         0 push @sortvalues, [@rowvalues];
1781 0         0 push @sorttypes, [@rowtypes];
1782             }
1783              
1784             # Do the sort
1785              
1786 0         0 my ($a1, $b1, $ta, $tb, $cresult);
1787             @sortlist = sort {
1788 0         0 for (my $i = 0 ; $i < $nsortcols ; $i++) {
  0         0  
1789 0 0       0 if ($dirs[ $i + 1 ] eq "up") { # handle sort direction
1790 0         0 $a1 = $a;
1791 0         0 $b1 = $b;
1792             } else {
1793 0         0 $a1 = $b;
1794 0         0 $b1 = $a;
1795             }
1796 0         0 $ta = $sorttypes[$a1][$i];
1797 0         0 $tb = $sorttypes[$b1][$i];
1798 0 0       0 if ($ta eq "t")
    0          
    0          
    0          
1799             { # numbers < text < errors, blank always last no matter what dir
1800 0 0       0 if ($tb eq "t") {
    0          
    0          
    0          
1801 0         0 $cresult =
1802             (lc $sortvalues[$a1][$i]) cmp(lc $sortvalues[$b1][$i]);
1803             } elsif ($tb eq "n") {
1804 0         0 $cresult = 1;
1805             } elsif ($tb eq "b") {
1806 0 0       0 $cresult = $dirs[ $i + 1 ] eq "up" ? -1 : 1;
1807             } elsif ($tb eq "e") {
1808 0         0 $cresult = -1;
1809             }
1810             } elsif ($ta eq "n") {
1811 0 0       0 if ($tb eq "t") {
    0          
    0          
    0          
1812 0         0 $cresult = -1;
1813             } elsif ($tb eq "n") {
1814 0         0 $cresult = $sortvalues[$a1][$i] <=> $sortvalues[$b1][$i];
1815             } elsif ($tb eq "b") {
1816 0 0       0 $cresult = $dirs[ $i + 1 ] eq "up" ? -1 : 1;
1817             } elsif ($tb eq "e") {
1818 0         0 $cresult = -1;
1819             }
1820             } elsif ($ta eq "e") {
1821 0 0       0 if ($tb eq "e") {
    0          
1822 0         0 $cresult = $sortvalues[$a1][$i] <=> $sortvalues[$b1][$i];
1823             } elsif ($tb eq "b") {
1824 0 0       0 $cresult = $dirs[ $i + 1 ] eq "up" ? -1 : 1;
1825             } else {
1826 0         0 $cresult = 1;
1827             }
1828             } elsif ($ta eq "b") {
1829 0 0       0 if ($tb eq "b") {
1830 0         0 $cresult = 0;
1831             } else {
1832 0 0       0 $cresult = $dirs[ $i + 1 ] eq "up" ? 1 : -1;
1833             }
1834             }
1835 0 0       0 return $cresult if $cresult;
1836             }
1837 0         0 return $a cmp $b;
1838             } @sortlist;
1839              
1840 0         0 my $originalrow;
1841 0         0 for (my $r = $r1 ; $r <= $r2 ; $r++)
1842             { # copy original back over in new rows
1843 0         0 $originalrow = $sortlist[ $r - $r1 ];
1844 0         0 for (my $c = $c1 ; $c <= $c2 ; $c++) {
1845 0         0 my $cr = cr_to_coord($c, $r);
1846 0         0 my $sortedcr = cr_to_coord($c, $r1 + $originalrow);
1847 0 0       0 if (!$sortcellattribs->{$sortedcr}->{coord})
1848             { # copying an empty cell
1849 0         0 delete $cellattribs->{$cr};
1850 0         0 delete $datavalues->{$cr};
1851 0         0 delete $dataformulas->{$cr};
1852 0         0 delete $cellerrors->{$cr};
1853 0         0 delete $datatypes->{$cr};
1854 0         0 delete $valuetypes->{$cr};
1855 0         0 next;
1856             }
1857 0         0 $cellattribs->{$cr} = { 'coord' => $cr };
1858 0         0 foreach my $attribtype (keys %{ $sortcellattribs->{$sortedcr} }) {
  0         0  
1859 0 0       0 if ($attribtype ne "coord") {
1860 0         0 $cellattribs->{$cr}->{$attribtype} =
1861             $sortcellattribs->{$sortedcr}->{$attribtype};
1862             }
1863             }
1864 0         0 $datavalues->{$cr} = $sortdatavalues->{$sortedcr};
1865 0         0 $datatypes->{$cr} = $sortdatatypes->{$sortedcr};
1866 0         0 $valuetypes->{$cr} = $sortvaluetypes->{$sortedcr};
1867 0 0       0 if ($sortdatatypes->{$sortedcr} eq "f")
1868             { # offset coord refs, even to ***relative*** coords in other sheets
1869 0         0 $dataformulas->{$cr} =
1870             offset_formula_coords($sortdataformulas->{$sortedcr},
1871             0, ($r - $r1) - $originalrow);
1872             } else {
1873 0         0 $dataformulas->{$cr} = $sortdataformulas->{$sortedcr};
1874             }
1875 0         0 $cellerrors->{$cr} = $sortcellerrors->{$sortedcr};
1876             }
1877             }
1878 0         0 $sheetdata->{sheetattribs}->{needsrecalc} = "yes";
1879             }
1880             }
1881              
1882             elsif ($cmd1 eq "clearclipboard") {
1883 0         0 delete $sheetdata->{clipboard};
1884             }
1885              
1886             elsif ($cmd1 eq "merge") {
1887 0         0 ($what, $rest) = split (/ /, $rest, 2);
1888 0         0 $what = uc($what);
1889 0         0 ($coord1, $coord2) = split (/:/, $what);
1890 0         0 my ($c1, $r1) = coord_to_cr($coord1);
1891 0         0 my $c2 = $c1;
1892 0         0 my $r2 = $r1;
1893 0 0       0 ($c2, $r2) = coord_to_cr($coord2) if $coord2;
1894 0 0       0 $sheetattribs->{lastcol} = $c2 if $c2 > $sheetattribs->{lastcol};
1895 0 0       0 $sheetattribs->{lastrow} = $r2 if $r2 > $sheetattribs->{lastrow};
1896              
1897 0 0       0 $cellattribs->{$coord1} = { 'coord' => $coord1 }
1898             unless $cellattribs->{$coord1}->{coord};
1899              
1900 0         0 delete $cellattribs->{$coord1}->{colspan};
1901 0 0       0 $cellattribs->{$coord1}->{colspan} = $c2 - $c1 + 1 if $c2 > $c1;
1902 0         0 delete $cellattribs->{$coord1}->{rowspan};
1903 0 0       0 $cellattribs->{$coord1}->{rowspan} = $r2 - $r1 + 1 if $r2 > $r1;
1904             }
1905              
1906             elsif ($cmd1 eq "unmerge") {
1907 0         0 ($what, $rest) = split (/ /, $rest, 2);
1908 0         0 $what = uc($what);
1909 0         0 ($coord1, $coord2) = split (/:/, $what);
1910              
1911 0 0       0 $cellattribs->{$coord1} = { 'coord' => $coord1 }
1912             unless $cellattribs->{$coord1}->{coord};
1913              
1914 0         0 delete $cellattribs->{$coord1}->{colspan};
1915 0         0 delete $cellattribs->{$coord1}->{rowspan};
1916             }
1917              
1918             elsif ($cmd1 eq "insertcol" || $cmd1 eq "insertrow") {
1919 0         0 ($what, $rest) = split (/ /, $rest, 2);
1920 0         0 $what = uc($what);
1921 0         0 ($coord1, $coord2) = split (/:/, $what);
1922 0         0 my ($c1, $r1) = coord_to_cr($coord1);
1923 0         0 my $lastcol = $sheetattribs->{lastcol};
1924 0         0 my $lastrow = $sheetattribs->{lastrow};
1925             my (
1926 0         0 $coloffset, $rowoffset, $colend, $rowend,
1927             $newcolstart, $newcolend, $newrowstart, $newrowend
1928             );
1929 0 0       0 if ($cmd1 eq "insertcol") {
1930 0         0 $coloffset = 1;
1931 0         0 $colend = $c1;
1932 0         0 $rowend = 1;
1933 0         0 $newcolstart = $c1;
1934 0         0 $newcolend = $c1;
1935 0         0 $newrowstart = 1;
1936 0         0 $newrowend = $lastrow;
1937             } else {
1938 0         0 $rowoffset = 1;
1939 0         0 $rowend = $r1;
1940 0         0 $colend = 1;
1941 0         0 $newcolstart = 1;
1942 0         0 $newcolend = $lastcol;
1943 0         0 $newrowstart = $r1;
1944 0         0 $newrowend = $r1;
1945             }
1946              
1947 0         0 for (my $row = $lastrow ; $row >= $rowend ; $row--)
1948             { # copy the cells forward
1949 0         0 for (my $col = $lastcol ; $col >= $colend ; $col--) {
1950 0         0 my $coord = cr_to_coord($col, $row);
1951 0         0 my $coordnext = cr_to_coord($col + $coloffset, $row + $rowoffset);
1952 0 0       0 if (!$cellattribs->{$coord}) { # copying empty cell
1953 0         0 delete $cellattribs->{$coordnext};
1954 0         0 delete $datavalues->{$coordnext};
1955 0         0 delete $datatypes->{$coordnext};
1956 0         0 delete $valuetypes->{$coordnext};
1957 0         0 delete $dataformulas->{$coordnext};
1958 0         0 delete $cellerrors->{$coordnext};
1959 0         0 next;
1960             }
1961 0         0 $cellattribs->{$coordnext} =
1962             { 'coord' => $coordnext }; # Start with minimal set
1963 0         0 foreach my $attribtype (keys %{ $cellattribs->{$coord} }) {
  0         0  
1964 0 0       0 if ($attribtype ne "coord") {
1965 0         0 $cellattribs->{$coordnext}->{$attribtype} =
1966             $cellattribs->{$coord}->{$attribtype};
1967             }
1968             }
1969 0         0 $datavalues->{$coordnext} = $datavalues->{$coord};
1970 0         0 $datatypes->{$coordnext} = $datatypes->{$coord};
1971 0         0 $valuetypes->{$coordnext} = $valuetypes->{$coord};
1972 0         0 $dataformulas->{$coordnext} = $dataformulas->{$coord};
1973 0         0 $cellerrors->{$coordnext} = $cellerrors->{$coord};
1974             }
1975             }
1976 0         0 for (my $r = $newrowstart ; $r <= $newrowend ; $r++)
1977             { # fill the new cells
1978 0         0 for (my $c = $newcolstart ; $c <= $newcolend ; $c++) {
1979 0         0 my $cr = cr_to_coord($c, $r);
1980 0         0 delete $cellattribs->{$cr};
1981 0         0 delete $datavalues->{$cr};
1982 0         0 delete $datatypes->{$cr};
1983 0         0 delete $valuetypes->{$cr};
1984 0         0 delete $dataformulas->{$cr};
1985 0         0 delete $cellerrors->{$cr};
1986 0         0 my $crbase =
1987             cr_to_coord($c - $coloffset, $r - $rowoffset)
1988             ; # copy attribs of the one before (0 give you A or 1)
1989              
1990 0 0       0 if ($cellattribs->{$crbase}) {
1991 0         0 $cellattribs->{$cr} = { 'coord' => $cr };
1992 0         0 foreach my $attribtype (keys %{ $cellattribs->{$crbase} }) {
  0         0  
1993 0 0       0 if ($attribtype ne "coord") {
1994 0         0 $cellattribs->{$cr}->{$attribtype} =
1995             $cellattribs->{$crbase}->{$attribtype};
1996             }
1997             }
1998             }
1999             }
2000             }
2001 0         0 foreach my $cr (keys %$dataformulas)
2002             { # update cell references to moved cells in calculated formulas
2003 0 0       0 if ($datatypes->{$cr} eq "f") {
2004 0         0 $dataformulas->{$cr} =
2005             adjust_formula_coords($dataformulas->{$cr}, $c1, $coloffset, $r1,
2006             $rowoffset);
2007             }
2008             }
2009 0         0 foreach my $name (keys %$names)
2010             { # update cell references to moved cells in names
2011 0 0       0 if ($names->{$name}) { # works with "A1", "A1:A20", and "=formula" forms
2012 0         0 $v1 = $names->{$name}->{definition};
2013 0         0 $v2 = "";
2014 0 0       0 if (substr($v1, 0, 1) eq "=") {
2015 0         0 $v2 = "=";
2016 0         0 $v1 = substr($v1, 1);
2017             }
2018 0         0 $names->{$name}->{definition} =
2019             $v2 . adjust_formula_coords($v1, $c1, $coloffset, $r1, $rowoffset);
2020             }
2021             }
2022 0   0     0 for (my $row = $lastrow ;
2023             $row >= $rowend && $cmd1 eq "insertrow" ; $row--)
2024             { # copy the row attributes forward
2025 0         0 my $rownext = $row + $rowoffset;
2026 0         0 $rowattribs->{$rownext} = { 'coord' => $rownext }; # start clean
2027 0         0 foreach my $attribtype (keys %{ $rowattribs->{$row} }) {
  0         0  
2028 0 0       0 if ($attribtype ne "coord") {
2029 0         0 $rowattribs->{$rownext}->{$attribtype} =
2030             $rowattribs->{$row}->{$attribtype};
2031             }
2032             }
2033             }
2034 0   0     0 for (my $col = $lastcol ;
2035             $col >= $colend && $cmd1 eq "insertcol" ; $col--)
2036             { # copy the column attributes forward
2037 0         0 my $colthis = number_to_col($col);
2038 0         0 my $colnext = number_to_col($col + $coloffset);
2039 0         0 $colattribs->{$colnext} = { 'coord' => $colnext };
2040 0         0 foreach my $attribtype (keys %{ $colattribs->{$colthis} }) {
  0         0  
2041 0 0       0 if ($attribtype ne "coord") {
2042 0         0 $colattribs->{$colnext}->{$attribtype} =
2043             $colattribs->{$colthis}->{$attribtype};
2044             }
2045             }
2046             }
2047              
2048 0         0 $sheetattribs->{lastcol} += $coloffset;
2049 0         0 $sheetattribs->{lastrow} += $rowoffset;
2050 0         0 $sheetdata->{sheetattribs}->{needsrecalc} = "yes";
2051             }
2052              
2053             elsif ($cmd1 eq "deletecol" || $cmd1 eq "deleterow") {
2054 0         0 ($what, $rest) = split (/ /, $rest, 2);
2055 0         0 $what = uc($what);
2056 0         0 ($coord1, $coord2) = split (/:/, $what);
2057 0         0 my ($c1, $r1) = coord_to_cr($coord1);
2058 0         0 my $c2 = $c1;
2059 0         0 my $r2 = $r1;
2060 0 0       0 ($c2, $r2) = coord_to_cr($coord2) if $coord2;
2061 0         0 my $lastcol = $sheetattribs->{lastcol};
2062 0         0 my $lastrow = $sheetattribs->{lastrow};
2063 0         0 my ($coloffset, $rowoffset, $colstart, $rowstart);
2064              
2065 0 0       0 if ($cmd1 eq "deletecol") {
2066 0         0 $coloffset = $c1 - $c2 - 1;
2067 0         0 $colstart = $c2 + 1;
2068 0         0 $rowstart = 1;
2069             } else {
2070 0         0 $rowoffset = $r1 - $r2 - 1;
2071 0         0 $rowstart = $r2 + 1;
2072 0         0 $colstart = 1;
2073             }
2074              
2075 0         0 for (my $row = $rowstart ; $row <= $lastrow - $rowoffset ; $row++)
2076             { # copy the cells backwards - extra so no dup of last set
2077 0         0 for (my $col = $colstart ; $col <= $lastcol - $coloffset ; $col++) {
2078 0         0 my $coord = cr_to_coord($col, $row);
2079 0         0 my $coordbefore = cr_to_coord($col + $coloffset, $row + $rowoffset);
2080 0 0       0 if (!$cellattribs->{$coord}) { # copying empty cell
2081 0         0 delete $cellattribs->{$coordbefore};
2082 0         0 delete $datavalues->{$coordbefore};
2083 0         0 delete $datatypes->{$coordbefore};
2084 0         0 delete $valuetypes->{$coordbefore};
2085 0         0 delete $dataformulas->{$coordbefore};
2086 0         0 delete $cellerrors->{$coordbefore};
2087 0         0 next;
2088             }
2089 0         0 $cellattribs->{$coordbefore} =
2090             { 'coord' => $coordbefore }; # Start with minimal set
2091 0         0 foreach my $attribtype (keys %{ $cellattribs->{$coord} }) {
  0         0  
2092 0 0       0 if ($attribtype ne "coord") {
2093 0         0 $cellattribs->{$coordbefore}->{$attribtype} =
2094             $cellattribs->{$coord}->{$attribtype};
2095             }
2096             }
2097 0         0 $datavalues->{$coordbefore} = $datavalues->{$coord};
2098 0         0 $datatypes->{$coordbefore} = $datatypes->{$coord};
2099 0         0 $valuetypes->{$coordbefore} = $valuetypes->{$coord};
2100 0         0 $dataformulas->{$coordbefore} = $dataformulas->{$coord};
2101 0         0 $cellerrors->{$coordbefore} = $cellerrors->{$coord};
2102             }
2103             }
2104 0         0 foreach my $cr (keys %$dataformulas)
2105             { # update references to moved cells in calculated formulas
2106 0 0       0 if ($datatypes->{$cr} eq "f") {
2107 0         0 $dataformulas->{$cr} =
2108             adjust_formula_coords($dataformulas->{$cr}, $c1, $coloffset, $r1,
2109             $rowoffset);
2110             }
2111             }
2112 0         0 foreach my $name (keys %$names)
2113             { # update cell references to moved cells in names
2114 0 0       0 if ($names->{$name}) { # works with "A1", "A1:A20", and "=formula" forms
2115 0         0 $v1 = $names->{$name}->{definition};
2116 0         0 $v2 = "";
2117 0 0       0 if (substr($v1, 0, 1) eq "=") {
2118 0         0 $v2 = "=";
2119 0         0 $v1 = substr($v1, 1);
2120             }
2121 0         0 $names->{$name}->{definition} =
2122             $v2 . adjust_formula_coords($v1, $c1, $coloffset, $r1, $rowoffset);
2123             }
2124             }
2125 0   0     0 for (
2126             my $row = $rowstart ;
2127             $row <= $lastrow - $rowoffset && $cmd1 eq "deleterow" ;
2128             $row++
2129             ) { # copy the row attributes backward
2130 0         0 my $rowbefore = $row + $rowoffset;
2131 0         0 $rowattribs->{$rowbefore} =
2132             { 'coord' => $rowbefore }; # start with only coord
2133 0         0 foreach my $attribtype (keys %{ $rowattribs->{$row} }) {
  0         0  
2134 0 0       0 if ($attribtype ne "coord") {
2135 0         0 $rowattribs->{$rowbefore}->{$attribtype} =
2136             $rowattribs->{$row}->{$attribtype};
2137             }
2138             }
2139             }
2140 0   0     0 for (
2141             my $col = $colstart ;
2142             $col <= $lastcol - $coloffset && $cmd1 eq "deletecol" ;
2143             $col++
2144             ) { # copy the column attributes backward
2145 0         0 my $colthis = number_to_col($col);
2146 0         0 my $colbefore = number_to_col($col + $coloffset);
2147 0         0 $colattribs->{$colbefore} = { 'coord' => $colbefore };
2148 0         0 foreach my $attribtype (keys %{ $colattribs->{$colthis} }) {
  0         0  
2149 0 0       0 if ($attribtype ne "coord") {
2150 0         0 $colattribs->{$colbefore}->{$attribtype} =
2151             $colattribs->{$colthis}->{$attribtype};
2152             }
2153             }
2154             }
2155              
2156 0 0       0 if ($cmd1 eq "deletecol") {
2157 0 0       0 if ($c1 <= $lastcol)
2158             { # shrink sheet unless deleted phantom cols off the end
2159 0 0       0 if ($c2 <= $lastcol) {
2160 0         0 $sheetattribs->{lastcol} += $coloffset;
2161             } else {
2162 0         0 $sheetattribs->{lastcol} = $c1 - 1;
2163             }
2164             }
2165             } else {
2166 0 0       0 if ($r1 <= $lastrow)
2167             { # shrink sheet unless deleted phantom rows off the end
2168 0 0       0 if ($r2 <= $lastrow) {
2169 0         0 $sheetattribs->{lastrow} += $rowoffset;
2170             } else {
2171 0         0 $sheetattribs->{lastrow} = $r1 - 1;
2172             }
2173             }
2174             }
2175 0         0 $sheetdata->{sheetattribs}->{needsrecalc} = "yes";
2176             }
2177              
2178             elsif ($cmd1 eq "name") {
2179 1         5 ($what, $name, $rest) = split (/ /, $rest, 3);
2180 1         3 $name = uc $name;
2181 1 50       3 if ($what eq "define") {
    0          
    0          
2182 1 50       3 $value = $names->{$name} ? $names->{$name}->{desc} : "";
2183 1         6 $names->{$name} = { definition => $rest, desc => $value };
2184             } elsif ($what eq "desc") {
2185 0 0       0 if ($names->{$name}) {
2186 0         0 $names->{$name}->{desc} = $rest;
2187             } else {
2188 0         0 $names->{$name} = { definition => "", desc => $rest };
2189             }
2190             } elsif ($what eq "delete") {
2191 0         0 delete $names->{$name};
2192             }
2193             }
2194              
2195             else {
2196 3         13 $errortext = "Unknown command '$cmd1' in line:\n$command\n";
2197 3         12 return 0;
2198             }
2199              
2200 675         2480 return $command;
2201             }
2202              
2203             =head2 recalc_sheet
2204              
2205             recalc_sheet(\%sheetdata);
2206              
2207             Recalculates the entire spreadsheet
2208              
2209             =cut
2210              
2211             sub recalc_sheet {
2212 680     680 1 1021 my $Sheet = shift;
2213              
2214 680         2011 $Sheet->{checked} = {};
2215 680         1808 delete $Sheet->{sheetattribs}->{circularreferencecell};
2216              
2217 680         1023 foreach my $coord (keys %{ $Sheet->{formulas} }) {
  680         15146  
2218 52629 50       149700 my $err = check_and_calc_cell($Sheet, $coord) if $coord;
2219             }
2220              
2221 680         20489 delete $Sheet
2222             ->{checked}; # save memory and clear out for name lookup formula evaluation
2223 680         4555 delete $Sheet->{sheetattribs}->{needsrecalc}; # remember recalc done
2224             }
2225              
2226             =head2 parse_header_save
2227              
2228             parse_header_save(\@lines, my \%headerdata);
2229              
2230             Returns "" if OK, otherwise error string.
2231              
2232             Fills in %headerdata:
2233              
2234             $headerdata{version} - version number, currently 1.1
2235             $headerdata{fullname} - title of page
2236             $headerdata{templatetext} - template HTML
2237             $headerdata{templatefile} - where to get template (location:name), see get_template
2238             $headerdata{lastmodified} - date/time last modified
2239             $headerdata{lastauthor} - author when last modified
2240             $headerdata{basefiledt} - date/time of backup file before this set of edits or blank if new file first edits (survives rename)
2241             $headerdata{backupfiledt} - date/time of backup file holding this data (blank during edits, yyyy-mm-... in published/backup/archive)
2242             $headerdata{reverted} - if non-blank, name of backup file this came from (only during initial editing)
2243             $headerdata{editcomments} - comment text about this series of edits, used when listing backups and RSS
2244             $headerdata{publishhtml} - publish the HTML for this page - sometimes you only want access-controlled live view (yes/no - default yes)
2245             $headerdata{publishsource} - put a copy of the published .txt file along with HTML and allow live view of source (yes/no - default no)
2246             $headerdata{publishjs} - put an embeddable copy of the published HTML as a .js file along with HTML (yes/no - default no)
2247             $headerdata{publishlive} - (ignored and removed after 0.91) make the HTML be a redirect to the recalc code (yes/no - default no)
2248             $headerdata{viewwithoutlogin} - allow live view without being logged in (ignore login for this page)
2249             $headerdata{editlog} - array of entries about edits made since editing started (cleared on new open for edit)
2250             [0] - log entry: command string to execute_sheet_command or comment (starts with "# ")
2251              
2252             =cut
2253              
2254             sub parse_header_save {
2255 1     1 1 30 my ($lines, $headerdata) = @_;
2256 1         3 foreach my $line (@$lines) {
2257 9         38 chomp $line;
2258 9         13 $line =~ s/\r//g;
2259 9         25 my ($linetype, $rest) = split (/:/, $line, 2);
2260 9 100 100     80 next if !$linetype or $linetype =~ /^#/ or $linetype !~ /\S/;
      100        
2261              
2262 6 100       15 if ($linetype eq 'edit') {
2263 3         4 push @{ $headerdata->{editlog} }, decode_from_save($rest);
  3         16  
2264             } else {
2265 3         9 $headerdata->{$linetype} = decode_from_save($rest);
2266             }
2267             }
2268              
2269 1         3 return "";
2270             }
2271              
2272             =head2 create_header_save
2273              
2274             my $outstr = create_header_save(\%headerdata);
2275              
2276             Header output routine
2277              
2278             =cut
2279              
2280             sub create_header_save {
2281              
2282 0     0 1 0 my $headerdata = shift @_;
2283              
2284 0         0 my $outstr;
2285              
2286 0         0 $headerdata->{version} = "1.1"; # this is the current version
2287              
2288 0         0 foreach my $val (@headerfieldnames) {
2289 0         0 my $valstr = encode_for_save($headerdata->{$val});
2290 0         0 $outstr .= "$val:$valstr\n";
2291             }
2292              
2293 0         0 foreach my $logentry (@{ $headerdata->{editlog} }) {
  0         0  
2294 0         0 my $valstr = encode_for_save($logentry);
2295 0         0 $outstr .= "edit:$valstr\n";
2296             }
2297              
2298 0         0 return $outstr;
2299              
2300             }
2301              
2302             =head2 add_to_editlog
2303              
2304             add_to_editlog(\%headerdata, $str);
2305              
2306             Adds $str to the header editlog. This should be either a string
2307             acceptable to execute_sheet_command or start with "# "
2308              
2309             =cut
2310              
2311             sub add_to_editlog {
2312 0     0 1 0 my ($headerdata, $str) = @_;
2313 0   0     0 $headerdata->{editlog} ||= (); # make sure array exists
2314 0         0 push @{ $headerdata->{editlog} }, $str;
  0         0  
2315 0         0 return;
2316             }
2317              
2318             =head1 OTHER EXPORTS
2319              
2320             These are currently exported, as they are used from multiple places. You
2321             shouldn't rely on this, however, as they will likely move somewhere else
2322             RSN.
2323              
2324             =head2 convert_date_gregorian_to_julian
2325              
2326             $juliandate = convert_date_gregorian_to_julian($year, $month, $day);
2327              
2328             From: http://aa.usno.navy.mil/faq/docs/JD_Formula.html
2329              
2330             Uses: Fliegel, H. F. and van Flandern, T. C. (1968). Communications of the ACM, Vol. 11, No. 10 (October, 1968).
2331             Translated from the FORTRAN.
2332              
2333             =cut
2334              
2335             sub convert_date_gregorian_to_julian {
2336              
2337 1852     1852 1 2817 my ($year, $month, $day) = @_;
2338              
2339 1852         6421 my $juliandate =
2340             $day - 32075 + int(1461 * ($year + 4800 + int(($month - 14) / 12)) / 4);
2341 1852         4322 $juliandate += int(367 * ($month - 2 - int(($month - 14) / 12) * 12) / 12);
2342 1852         4124 $juliandate = $juliandate -
2343             int(3 * int(($year + 4900 + int(($month - 14) / 12)) / 100) / 4);
2344              
2345 1852         40790 return $juliandate;
2346              
2347             }
2348              
2349             =head2 convert_date_julian_to_gregorian
2350              
2351             ($year, $month, $day) = convert_date_julian_to_gregorian($juliandate)
2352              
2353             From: http://aa.usno.navy.mil/faq/docs/JD_Formula.html
2354              
2355             Uses: Fliegel, H. F. and van Flandern, T. C. (1968). Communications of the ACM, Vol. 11, No. 10 (October, 1968).
2356             Translated from the FORTRAN.
2357              
2358             =cut
2359              
2360             sub convert_date_julian_to_gregorian {
2361              
2362 215     215 1 431 my $juliandate = shift @_;
2363              
2364 215         354 my ($L, $N, $I, $J, $K);
2365              
2366 215         470 $L = $juliandate + 68569;
2367 215         587 $N = int(4 * $L / 146097);
2368 215         505 $L = $L - int((146097 * $N + 3) / 4);
2369 215         699 $I = int(4000 * ($L + 1) / 1461001);
2370 215         466 $L = $L - int(1461 * $I / 4) + 31;
2371 215         391 $J = int(80 * $L / 2447);
2372 215         429 $K = $L - int(2447 * $J / 80);
2373 215         345 $L = int($J / 11);
2374 215         470 $J = $J + 2 - 12 * $L;
2375 215         383 $I = 100 * ($N - 49) + $I + $L;
2376              
2377 215         1161 return ($I, $J, $K);
2378             }
2379              
2380             =head2 determine_value_type
2381              
2382             $value = determine_value_type($rawvalue, \$type)
2383              
2384             Takes a value and looks for special formatting like $, %, numbers, etc.
2385             Returns the value as a number or string and the type.
2386             Tries to follow the spec for spreadsheet function VALUE(v).
2387              
2388             =cut
2389              
2390             sub determine_value_type {
2391              
2392 4008     4008 1 7298 my ($rawvalue, $type) = @_;
2393              
2394 4008   100     8682 my $value = $rawvalue || '';
2395              
2396 4008         5373 $$type = "t";
2397              
2398 4008         5554 my $fch = substr($value, 0, 1);
2399 4008         5742 my $tvalue = $value;
2400 4008         8926 $tvalue =~ s/^\s+//; # value with leading and trailing spaces removed
2401 4008         7167 $tvalue =~ s/\s+$//;
2402              
2403 4008 100 33     44510 if (length $value == 0) {
    50 33        
    100          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
2404 17         32 $$type = "";
2405             } elsif ($value =~ m/^\s+$/) { # just blanks
2406             ; # leave as is with type "t"
2407             } elsif ($tvalue =~ m/^[-+]?\d*(?:\.)?\d*(?:[eE][-+]?\d+)?$/)
2408             { # general number, including E
2409 3172         4705 $value = $tvalue + 0;
2410 3172         4489 $$type = "n";
2411             } elsif ($tvalue =~ m/^[-+]?\d*(?:\.)?\d*\s*%$/) { # 15.1%
2412 21         74 $value = substr($tvalue, 0, -1) / 100;
2413 21         41 $$type = "n%";
2414             } elsif ($tvalue =~ m/^[-+]?\$\s*\d*(?:\.)?\d*\s*$/ && $tvalue =~ m/\d/)
2415             { # $1.49
2416 0         0 $tvalue =~ s/\$//;
2417 0         0 $value = $tvalue;
2418 0         0 $$type = 'n$';
2419             } elsif ($tvalue =~ m/^[-+]?(\d*,\d*)+(?:\.)?\d*$/) { # 1,234.49
2420 0         0 $tvalue =~ s/,//g;
2421 0         0 $value = $tvalue;
2422 0         0 $$type = 'n';
2423             } elsif ($tvalue =~ m/^[-+]?(\d*,\d*)+(?:\.)?\d*\s*%$/) { # 1,234.49%
2424 0         0 $tvalue =~ s/,//g;
2425 0         0 $value = substr($tvalue, 0, -1) / 100;
2426 0         0 $$type = 'n%';
2427             } elsif ($tvalue =~ m/^[-+]?\$\s*(\d*,\d*)+(?:\.)?\d*$/ && $tvalue =~ m/\d/)
2428             { # $1,234.49
2429 0         0 $tvalue =~ s/,//g;
2430 0         0 $tvalue =~ s/\$//;
2431 0         0 $value = $tvalue;
2432 0         0 $$type = 'n$';
2433             } elsif ($value =~ m/^(\d{1,2})[\/\-](\d{1,2})[\/\-](\d{1,4})\s*$/)
2434             { # MM/DD/YYYY, MM/DD/YYYY
2435 32 100       174 my $year = $3 < 1000 ? $3 + 2000 : $3;
2436 32         118 $value = convert_date_gregorian_to_julian($year, $1, $2) - 2415019;
2437 32         81 $$type = 'nd';
2438             } elsif ($value =~ m/^(\d{4})[\/\-](\d{1,2})[\/\-](\d{1,2})\s*$/)
2439             { # YYYY-MM-DD, YYYY/MM/DD
2440 126 50       466 my $year = $1 < 1000 ? $1 + 2000 : $1;
2441 126         335 $value = convert_date_gregorian_to_julian($year, $2, $3) - 2415019;
2442 126         231 $$type = 'nd';
2443             } elsif ($value =~ m/^(\d{1,2}):(\d{1,2})\s*$/) { # HH:MM
2444 77         231 my $hour = $1;
2445 77         212 my $minute = $2;
2446 77 50 33     520 if ($hour < 24 && $minute < 60) {
2447 77         280 $value = $hour / 24 + $minute / (24 * 60);
2448 77         206 $$type = 'nt';
2449             }
2450             } elsif ($value =~ m/^(\d{1,2}):(\d{1,2}):(\d{1,2})\s*$/) { # HH:MM:SS
2451 12         34 my $hour = $1;
2452 12         32 my $minute = $2;
2453 12         34 my $second = $3;
2454 12 50 33     107 if ($hour < 24 && $minute < 60 && $second < 60) {
      33        
2455 12         37 $value = $hour / 24 + $minute / (24 * 60) + $second / (24 * 60 * 60);
2456 12         28 $$type = 'nt';
2457             }
2458             } elsif ($value =~ m/^\s*([-+]?\d+) (\d+)\/(\d+)\s*$/) { # 1 1/2
2459 54         213 my $int = $1;
2460 54         155 my $num = $2;
2461 54         115 my $denom = $3;
2462 54 50       199 if ($denom > 0) {
2463 54         194 $value = $int + $num / $denom;
2464 54         141 $$type = 'n';
2465             }
2466             } elsif ($input_constants{ uc($value) }) {
2467 0         0 ($value, $$type) = split (/,/, $input_constants{ uc($value) });
2468             }
2469              
2470 4008         12454 return $value;
2471              
2472             }
2473              
2474             =head2 test_criteria
2475              
2476             test_criteria($value, $type, $criteria);
2477              
2478             Determines whether a value/type meets the criteria. A criteria can
2479             be a numeric value, text beginning with <, <=, =, >=, >, <>, text
2480             by itself is start of text to match.
2481              
2482             Returns 1 or 0 for true or false.
2483              
2484             =cut
2485              
2486             sub test_criteria {
2487              
2488 2908     2908 1 4833 my ($value, $type, $criteria) = @_;
2489              
2490 2908         2886 my ($comparitor, $basevalue, $basetype);
2491              
2492 2908 50       5038 return 0
2493             unless defined $criteria; # undefined (e.g., error value) is always false
2494              
2495 2908 100       6804 if ($criteria =~ m/^(<=|<>|<|=|>=|>)(.+?)$/) { # has comparitor
2496 753         1238 $comparitor = $1;
2497 753         1339 $basevalue = $2;
2498             } else {
2499 2155         2351 $comparitor = "none";
2500 2155         8630 $basevalue = $criteria;
2501             }
2502              
2503 2908         5070 my $basevaluenum = determine_value_type($basevalue, \$basetype);
2504 2908 50       6217 if (!$basetype) { # no criteria base value given
2505 0 0       0 return 0 if $comparitor eq "none"; # blank criteria matches nothing
2506 0 0       0 if (substr($type, 0, 1) eq "b") { # empty cell
2507 0 0       0 return 1 if $comparitor eq "="; # empty equals empty
2508             } else {
2509 0 0       0 return 1 if $comparitor eq "<>"; # something does not equal empty
2510             }
2511 0         0 return 0; # otherwise false
2512             }
2513              
2514 2908         3110 my $cond = 0;
2515              
2516 2908 100 100     12772 if (substr($basetype, 0, 1) eq "n" && substr($type, 0, 1) eq "t")
2517             { # criteria is number, but value is text
2518 17         28 my $testtype;
2519 17         52 my $testvalue = determine_value_type($value, \$testtype);
2520 17 100       65 if (substr($testtype, 0, 1) eq "n") { # could be number - make it one
2521 15         27 $value = $testvalue;
2522 15         29 $type = $testtype;
2523             }
2524             }
2525              
2526 2908 100 66     11778 if (substr($type, 0, 1) eq "n" && substr($basetype, 0, 1) eq "n")
    50          
    50          
2527             { # compare two numbers
2528 2618 100 66     12630 if ($comparitor eq "<") { $cond = $value < $basevaluenum ? 1 : 0; }
  582 100       1286  
    100          
    100          
    100          
    50          
    0          
2529 52 100       148 elsif ($comparitor eq "<=") { $cond = $value <= $basevaluenum ? 1 : 0; }
2530             elsif ($comparitor eq "=" || $comparitor eq "none") {
2531 1865 100       3664 $cond = $value == $basevaluenum ? 1 : 0;
2532             } elsif ($comparitor eq ">=") {
2533 21 100       44 $cond = $value >= $basevaluenum ? 1 : 0;
2534             } elsif ($comparitor eq ">") {
2535 98 100       230 $cond = $value > $basevaluenum ? 1 : 0;
2536             } elsif ($comparitor eq "<>") {
2537 0 0       0 $cond = $value != $basevaluenum ? 1 : 0;
2538             }
2539             } elsif (substr($value, 0, 1) eq "e") { # error on left
2540 0         0 $cond = 0;
2541             } elsif (substr($basetype, 0, 1) eq "e") { # error on right
2542 0         0 $cond = 0;
2543             } else { # text maybe mixed with numbers or blank
2544 290 50       1007 if (substr($type, 0, 1) eq "n") {
2545 0         0 $value = format_number_for_display($value, "n", "");
2546             }
2547 290 100       541 if (substr($basetype, 0, 1) eq "n") {
2548 6         31 return 0; # if number and didn't match already, isn't a match
2549             }
2550              
2551 284         543 utf8::decode($value); # ignore case and use UTF-8 as chars not bytes
2552 284         352 $value = lc $value; # ignore case
2553 284         394 utf8::decode($basevalue);
2554 284         314 $basevalue = lc $basevalue;
2555              
2556 284 0       886 if ($comparitor eq "<") { $cond = $value lt $basevalue ? 1 : 0; }
  0 50       0  
    50          
    50          
    50          
    0          
    0          
    0          
2557 0 0       0 elsif ($comparitor eq "<=") { $cond = $value le $basevalue ? 1 : 0; }
2558 0 0       0 elsif ($comparitor eq "=") { $cond = $value eq $basevalue ? 1 : 0; }
2559             elsif ($comparitor eq "none") {
2560 284 100       1604 $cond = $value =~ m/^$basevalue/ ? 1 : 0;
2561             } elsif ($comparitor eq ">=") {
2562 0 0       0 $cond = $value ge $basevalue ? 1 : 0;
2563             } elsif ($comparitor eq ">") {
2564 0 0       0 $cond = $value gt $basevalue ? 1 : 0;
2565             } elsif ($comparitor eq "<>") {
2566 0 0       0 $cond = $value ne $basevalue ? 1 : 0;
2567             }
2568             }
2569              
2570 2902         15779 return $cond;
2571              
2572             }
2573              
2574             =head2 lookup_result_type
2575              
2576             $resulttype = lookup_result_type($type1, $type2, \%typelookup);
2577              
2578             %typelookup has values of the following form:
2579              
2580             $typelookup{"typespec1"} = "|typespec2A:resultA|typespec2B:resultB|..."
2581              
2582             First $type1 is looked up. If no match, then the first letter (major
2583             type) of $type1 plus "*" is looked up. $resulttype is $type1 if
2584             result is "1", $type2 if result is "2", otherwise the value of
2585             result.
2586              
2587             =cut
2588              
2589             sub lookup_result_type {
2590              
2591 24509     24509 1 81009 my ($type1, $type2, $typelookup) = @_;
2592              
2593 24509         29223 my $t2 = $type2;
2594              
2595 24509         42700 my $table1 = $typelookup->{$type1};
2596 24509 100       49150 if (!$table1) {
2597 8622         22621 $table1 = $typelookup->{ substr($type1, 0, 1) . '*' };
2598 8622 100       18605 return "e#VALUE! (missing)"
2599             unless $table1; # missing from table -- please add it
2600             }
2601 24283 100       203632 if ($table1 =~ m/\Q|$type2:\E(.*?)\|/) {
2602 15961 50       41034 return $type1 if $1 eq '1';
2603 15961 50       33780 return $type2 if $1 eq '2';
2604 15961         63708 return $1;
2605             }
2606 8322         14427 $t2 = substr($t2, 0, 1) . '*';
2607 8322 50       63259 if ($table1 =~ m/\Q|$t2:\E(.*?)\|/) {
2608 8322 100       29009 return $type1 if $1 eq '1';
2609 6018 100       17485 return $type2 if $1 eq '2';
2610 5325         33452 return $1;
2611             }
2612 0         0 return "e#VALUE!";
2613             }
2614              
2615             =head2 copy_function_args
2616              
2617             copy_function_args(\@operand, \@foperand)
2618              
2619             Pops operands from @operand and pushes on @foperand up to function start
2620             reversing order in the process.
2621              
2622             =cut
2623              
2624             sub copy_function_args {
2625              
2626 18496     18496 1 120004 my ($operand, $foperand) = @_;
2627              
2628 18496   66     108125 while (@$operand && $operand->[ @$operand - 1 ]->{type} ne "start")
2629             { # get each arg
2630 27694         52009 push @$foperand, $operand->[ @$operand - 1 ]; # copy it
2631 27694         135253 pop @$operand;
2632             }
2633 18496         22179 pop @$operand; # get rid of "start"
2634              
2635 18496         69422 return;
2636             }
2637              
2638             =head2 function_args_error
2639              
2640             function_args_error($fname, \@operand, $$errortext)
2641              
2642             Pushes appropriate error on operand stack and sets errortext, including $fname
2643              
2644             =cut
2645              
2646             sub function_args_error {
2647              
2648 5     5 1 15 my ($fname, $operand, $errortext) = @_;
2649              
2650 5         15 $$errortext = qq!Incorrect arguments to function "$fname". !;
2651 5         24 push @$operand, { type => "e#VALUE!", value => $$errortext };
2652              
2653 5         15 return;
2654             }
2655              
2656             =head2 function_specific_error
2657              
2658             function_specific_error($fname, \@operand, $errortext, $errortype, $text)
2659              
2660             Pushes specified error and text on operand stack
2661              
2662             =cut
2663              
2664             sub function_specific_error {
2665              
2666 0     0 1 0 my ($fname, $operand, $errortext, $errortype, $text) = @_;
2667              
2668 0         0 $$errortext = $text;
2669 0         0 push @$operand, { type => $errortype, value => $$errortext };
2670              
2671 0         0 return;
2672             }
2673              
2674             =head2 top_of_stack_value_and_type
2675              
2676             ($value, $type) = top_of_stack_value_and_type(\%sheetdata, \@operand, \$errortext,)
2677              
2678             Returns top of stack value and type and then pops the stack
2679              
2680             =cut
2681              
2682             sub top_of_stack_value_and_type {
2683 827     827 1 3145 my ($sheetdata, $operand, $errortext) = @_;
2684 827 100       1675 if (@$operand) {
2685 773         2283 my ($value, $type) = (
2686             $operand->[ @$operand - 1 ]->{value},
2687             $operand->[ @$operand - 1 ]->{type}
2688             );
2689 773         970 pop @$operand;
2690 773 100       2262 if ($type eq "name") {
2691 186         368 $value = uc $value;
2692 186         514 $value = lookup_name($sheetdata, $value, \$type, $errortext);
2693             }
2694 773         2806 return ($value, $type);
2695             } else {
2696 54         150 return ();
2697             }
2698             }
2699              
2700             =head2 operand_as_number
2701              
2702             $value = operand_as_number(\%sheetdata, \@operand, \$errortext, \$tostype)
2703              
2704             Uses operand_value_and_type to get top of stack and pops it.
2705             Returns numeric value and type.
2706             Text values are treated as 0 if they can't be converted somehow.
2707              
2708             =cut
2709              
2710             sub operand_as_number {
2711              
2712 48898     48898 1 149559 my ($sheetdata, $operand, $errortext, $tostype) = @_;
2713              
2714 48898         80192 my $value =
2715             operand_value_and_type($sheetdata, $operand, $errortext, $tostype);
2716              
2717 48898 100       143734 if (substr($$tostype, 0, 1) eq "n") {
    50          
    100          
2718 48009         112379 return 0 + $value;
2719             } elsif (substr($$tostype, 0, 1) eq "b") { # blank cell
2720 0         0 $$tostype = "n";
2721 0         0 return 0;
2722             } elsif (substr($$tostype, 0, 1) eq "e") { # error
2723 97         250 return 0;
2724             } else {
2725 792         2208 $value = determine_value_type($value, $tostype);
2726 792 100       2165 if (substr($$tostype, 0, 1) eq "n") {
2727 604         1835 return 0 + $value;
2728             } else {
2729 188         668 return 0;
2730             }
2731             }
2732             }
2733              
2734             =head2 operand_as_text
2735              
2736             $value = operand_as_text(\%sheetdata, \@operand, \$errortext, \$tostype)
2737              
2738             Uses operand_value_and_type to get top of stack and pops it.
2739             Returns text value, preserving sub-type.
2740              
2741             =cut
2742              
2743             sub operand_as_text {
2744              
2745 2935     2935 1 16677 my ($sheetdata, $operand, $errortext, $tostype) = @_;
2746              
2747 2935         5978 my $value =
2748             operand_value_and_type($sheetdata, $operand, $errortext, $tostype);
2749              
2750 2935 100       8314 if (substr($$tostype, 0, 1) eq "t") {
    100          
    50          
    0          
2751 2708         7675 return $value;
2752             } elsif (substr($$tostype, 0, 1) eq "n") {
2753 157         301 $value = "$value";
2754 157         314 $$tostype = "t";
2755 157         487 return $value;
2756             } elsif (substr($$tostype, 0, 1) eq "b") { # blank
2757 70         102 $$tostype = "t";
2758 70         175 return "";
2759             } elsif (substr($$tostype, 0, 1) eq "e") { # error
2760 0         0 return "";
2761             } else {
2762 0         0 $$tostype = "t";
2763 0         0 return "$value";
2764             }
2765             }
2766              
2767             =head2 operand_value_and_type
2768              
2769             $value = operand_value_and_type(\%sheetdata, \@operand, \$errortext, \$operandtype)
2770              
2771             Pops the top of stack and returns it, following a coord reference
2772             if necessary. Ranges are returned as if they were pushed onto the
2773             stack first coord first. Also sets $operandtype with "t", "n",
2774             "th", etc., as appropriate. Errortext is set if there is a reference
2775             to a cell with error.
2776              
2777             =cut
2778              
2779             sub operand_value_and_type {
2780              
2781 75829     75829 1 161495 my ($sheetdata, $operand, $errortext, $operandtype) = @_;
2782              
2783 75829         88884 my $stacklen = scalar @$operand;
2784 75829 50       148941 if (!$stacklen) { # make sure something is there
2785 0         0 $$operandtype = "";
2786 0         0 return "";
2787             }
2788 75829         140657 my $value = $operand->[ $stacklen - 1 ]->{value}; # get top of stack
2789 75829         117845 my $tostype = $operand->[ $stacklen - 1 ]->{type};
2790 75829         94236 pop @$operand; # we have data - pop stack
2791              
2792 75829 100       209085 if ($tostype eq "name") {
2793 32         61 $value = uc $value;
2794 32         89 $value = lookup_name($sheetdata, $value, \$tostype, $errortext);
2795             }
2796              
2797 75829 100       131074 if ($tostype eq "range") {
2798 3165         8472 $value = step_through_range_down($operand, $value, \$tostype);
2799             }
2800              
2801 75829 100       139391 if ($tostype eq "coord") { # value is a coord reference
2802 19894         23000 my $coordsheetdata = $sheetdata;
2803 19894 50       44807 if ($value =~ m/^([^!]+)!(.+)$/) { # sheet reference
2804 0         0 $value = $1;
2805 0         0 my $othersheet = $2;
2806 0         0 $coordsheetdata = find_in_sheet_cache($sheetdata, $othersheet);
2807 0 0       0 if ($coordsheetdata->{loaderror}) { # this sheet is unavailable
2808 0         0 $$operandtype = "e#REF!";
2809 0         0 return 0;
2810             }
2811             }
2812 19894         44343 my $cellvtype =
2813             $coordsheetdata->{valuetypes}
2814             ->{$value}; # get type of value in the cell it points to
2815 19894         36576 $value = $coordsheetdata->{datavalues}->{$value};
2816 19894   100     40347 $tostype = $cellvtype || "b";
2817 19894 100       43769 if ($tostype eq "b") { # blank
2818 260         601 $value = 0;
2819             }
2820             }
2821              
2822 75829         97997 $$operandtype = $tostype; # return information
2823 75829         171063 return $value;
2824              
2825             }
2826              
2827             =head2 decode_range_parts
2828              
2829             ($sheetdata, $col1num, $ncols, $row1num, $nrows) = decode_range_parts(\@sheetdata, $rangevalue, $rangetype)
2830              
2831             Returns \@sheetdata for the sheet where the range is, as well as
2832             the number of the first column in the range, the number of columns,
2833             and equivalent row information.
2834              
2835             If any errors, $sheetdata is returned as null.
2836              
2837             =cut
2838              
2839             sub decode_range_parts {
2840              
2841 620     620 1 1130 my ($sheetdata, $rangevalue, $rangetype) = @_;
2842              
2843 620         2488 my ($value1, $value2, $sequence) = split (/\|/, $rangevalue);
2844 620         823 my ($sheet1, $sheet2);
2845 620         1441 ($value1, $sheet1) = split (/!/, $value1);
2846 620         1465 ($value2, $sheet2) = split (/!/, $value2);
2847 620         843 my $coordsheetdata = $sheetdata;
2848 620 50       1164 if ($sheet1) { # sheet reference
2849 0         0 $coordsheetdata = find_in_sheet_cache($sheetdata, $sheet1);
2850 0 0       0 if ($coordsheetdata->{loaderror}) { # this sheet is unavailable
2851 0         0 $coordsheetdata = undef;
2852             }
2853             }
2854              
2855 620         1104 my ($c1, $r1) = coord_to_cr($value1);
2856 620         1186 my ($c2, $r2) = coord_to_cr($value2);
2857 620 50       1372 ($c2, $c1) = ($c1, $c2) if ($c1 > $c2);
2858 620 50       1481 ($r2, $r1) = ($r1, $r2) if ($r1 > $r2);
2859 620         2938 return ($coordsheetdata, $c1, $c2 - $c1 + 1, $r1, $r2 - $r1 + 1);
2860             }
2861              
2862             =head2 coord_to_cr
2863              
2864             ($col, $row) = coord_to_cr($coord)
2865              
2866             Turns B3 into (2, 3). The default for both is 1.
2867             If range, only do this to first coord.
2868              
2869             =cut
2870              
2871             sub coord_to_cr {
2872 16280     16280 1 43421 my $coord = shift @_;
2873 16280         23673 $coord = lc($coord);
2874 16280         22405 $coord =~ s/\$//g;
2875 16280         45883 $coord =~ m/([a-z])([a-z])?(\d+)/;
2876 16280         31409 my $col = ord($1) - ord('a') + 1;
2877 16280 50       36499 $col = 26 * $col + ord($2) - ord('a') + 1 if $2;
2878 16280         49865 return ($col, $3);
2879             }
2880              
2881             =head2 cr_to_coord
2882              
2883             $coord = cr_to_coord($col, $row)
2884              
2885             Turns (2, 3) into B3. The default for both is 1.
2886              
2887             =cut
2888              
2889             sub cr_to_coord {
2890 51087     51087 1 68722 my ($col, $row) = @_;
2891 51087 100       118384 $row = 1 unless $row > 1;
2892 51087 100       88576 $col = 1 unless $col > 1;
2893 51087         76496 my $col_high = int(($col - 1) / 26);
2894 51087         69779 my $col_low = ($col - 1) % 26;
2895 51087         67677 my $coord = chr(ord('A') + $col_low);
2896 51087 50       85073 $coord = chr(ord('A') + $col_high - 1) . $coord if $col_high;
2897 51087         59598 $coord .= $row;
2898 51087         117537 return $coord;
2899             }
2900              
2901             =head2 encode_for_save
2902              
2903             my $estring = encode_for_save($string)
2904              
2905             Returns $estring where :, \n, and \ are escaped
2906              
2907             =cut
2908              
2909             sub encode_for_save {
2910 0     0 1 0 my $string = shift @_;
2911 0         0 $string =~ s/\\/\\b/g; # \ to \b
2912 0         0 $string =~ s/:/\\c/g; # : to \c
2913 0         0 $string =~ s/\n/\\n/g; # line end to \n
2914 0         0 return $string;
2915             }
2916              
2917             =head2 decode_from_save
2918              
2919             my $estring = decode_from_save($string)
2920              
2921             Returns $estring with \c, \n, \b and \\ un-escaped
2922              
2923             =cut
2924              
2925             sub decode_from_save {
2926 6508     6508 1 9074 my $string = shift @_;
2927 6508         7508 $string =~ s/\\\\/\\/g; # Old -- shouldn't get this, replace with \b
2928 6508         7829 $string =~ s/\\c/:/g;
2929 6508         6862 $string =~ s/\\n/\n/g;
2930 6508         6312 $string =~ s/\\b/\\/g;
2931 6508         15869 return $string;
2932             }
2933              
2934             =head2 html_escape / special_chars
2935              
2936             my $estring = html_escape($string)
2937              
2938             Returns $estring where &, <, >, " are HTML escaped.
2939              
2940             This used to be known as special_chars() but that usage is deprecated.
2941              
2942             =cut
2943              
2944             sub html_escape {
2945 0     0 1 0 my $string = shift @_;
2946 0         0 $string =~ s/&/&/g;
2947 0         0 $string =~ s/
2948 0         0 $string =~ s/>/>/g;
2949 0         0 $string =~ s/"/"/g;
2950 0         0 return $string;
2951             }
2952             *special_chars = \&html_escape;
2953              
2954             =head2 special_chars_nl
2955              
2956             my $estring = special_chars_nl($string)
2957              
2958             Returns $estring where &, <, >, ", and LF are HTML escaped, CR's are removed
2959              
2960             =cut
2961              
2962             sub special_chars_nl {
2963 0     0 1 0 my $string = shift @_;
2964 0         0 $string =~ s/&/&/g;
2965 0         0 $string =~ s/
2966 0         0 $string =~ s/>/>/g;
2967 0         0 $string =~ s/"/"/g;
2968 0         0 $string =~ s/\r//gs;
2969 0         0 $string =~ s/\n/ /gs;
2970 0         0 return $string;
2971             }
2972              
2973             =head1 HELPERS
2974              
2975             These are 'private' functions, not exported, and should not be relied
2976             on. The interface to any of these is subject to change at any time.
2977              
2978             =head2 offset_formula_coords
2979              
2980             $updatedformula = offset_formula_coords($formula, $coloffset, $rowoffset);
2981              
2982             Change relative cell references by offsets (even those to other
2983             worksheets so fill, paste, sort work as expected). If not what you
2984             want, use absolute references.
2985              
2986             =cut
2987              
2988             sub offset_formula_coords {
2989              
2990 0     0 1 0 my ($formula, $coloffset, $rowoffset, $othersheets) = @_;
2991              
2992 0         0 my $parseinfo = parse_formula_into_tokens($formula);
2993              
2994 0         0 my $parsed_token_text = $parseinfo->{tokentext};
2995 0         0 my $parsed_token_type = $parseinfo->{tokentype};
2996 0         0 my $parsed_token_opcode = $parseinfo->{tokenopcode};
2997              
2998 0         0 my ($ttype, $ttext, $sheetref, $updatedformula);
2999 0         0 for (my $i = 0 ; $i < scalar @$parsed_token_text ; $i++) {
3000 0         0 $ttype = $parsed_token_type->[$i];
3001 0         0 $ttext = $parsed_token_text->[$i];
3002 0 0       0 if ($ttype == $token_coord) {
    0          
    0          
3003 0         0 my ($c, $r) = coord_to_cr($ttext);
3004 0         0 my $abscol = $ttext =~ m/^\$/;
3005 0 0       0 $c += $coloffset unless $abscol;
3006 0         0 my $absrow = $ttext =~ m/^\${0,1}[a-zA-Z]{1,2}\$\d+$/;
3007 0 0       0 $r += $rowoffset unless $absrow;
3008 0         0 $ttext = cr_to_coord($c, $r);
3009 0 0       0 $ttext =~ s/^/\$/ if $abscol;
3010 0 0       0 $ttext =~ s/(\d+)$/\$$1/ if $absrow;
3011              
3012 0 0 0     0 if ($r < 1 || $c < 1) {
3013 0         0 $ttext = "ERRCELL";
3014             }
3015             } elsif ($ttype == $token_string) {
3016 0         0 $ttext =~ s/"/""/g;
3017 0         0 $ttext = '"' . $ttext . '"';
3018             } elsif ($ttype == $token_op) {
3019 0   0     0 $ttext = $token_op_expansion{$ttext}
3020             || $ttext; # make sure short tokens (e.g., "G") go back full (">=")
3021             }
3022 0         0 $updatedformula .= $ttext;
3023             }
3024              
3025 0         0 return $updatedformula;
3026             }
3027              
3028             =head2 adjust_formula_coords
3029              
3030             $updatedformula = adjust_formula_coords($formula, $col, $coloffset, $row, $rowoffset)
3031              
3032             Change all cell references to cells starting with $col/$row by offsets
3033              
3034             =cut
3035              
3036             sub adjust_formula_coords {
3037              
3038 0     0 1 0 my ($formula, $col, $coloffset, $row, $rowoffset) = @_;
3039              
3040 0         0 my $parseinfo = parse_formula_into_tokens($formula);
3041              
3042 0         0 my $parsed_token_text = $parseinfo->{tokentext};
3043 0         0 my $parsed_token_type = $parseinfo->{tokentype};
3044 0         0 my $parsed_token_opcode = $parseinfo->{tokenopcode};
3045              
3046 0         0 my ($ttype, $ttext, $sheetref, $updatedformula);
3047 0         0 for (my $i = 0 ; $i < scalar @$parsed_token_text ; $i++) {
3048 0         0 $ttype = $parsed_token_type->[$i];
3049 0         0 $ttext = $parsed_token_text->[$i];
3050 0 0       0 if ($ttype == $token_op)
3051             { # references with sheet specifier are not offset
3052 0 0       0 if ($ttext eq "!") {
    0          
3053 0         0 $sheetref = 1; # found a sheet reference
3054             } elsif ($ttext ne ":") { # for everything but a range, reset
3055 0         0 $sheetref = 0;
3056             }
3057 0   0     0 $ttext = $token_op_expansion{$ttext}
3058             || $ttext; # make sure short tokens (e.g., "G") go back full (">=")
3059             }
3060 0 0       0 if ($ttype == $token_coord) {
    0          
3061 0         0 my ($c, $r) = coord_to_cr($ttext);
3062 0 0 0     0 if (($c == $col && $coloffset < 0) || ($r == $row && $rowoffset < 0))
      0        
      0        
3063             { # refs to deleted cells become invalid
3064 0 0       0 $c = 0 unless $sheetref;
3065 0 0       0 $r = 0 unless $sheetref;
3066             }
3067 0         0 my $abscol = $ttext =~ m/^\$/;
3068 0 0 0     0 $c += $coloffset if $c >= $col && !$sheetref;
3069 0         0 my $absrow = $ttext =~ m/^\${0,1}[a-zA-Z]{1,2}\$\d+$/;
3070 0 0 0     0 $r += $rowoffset if $r >= $row && !$sheetref;
3071 0         0 $ttext = cr_to_coord($c, $r);
3072 0 0       0 $ttext =~ s/^/\$/ if $abscol;
3073 0 0       0 $ttext =~ s/(\d+)$/\$$1/ if $absrow;
3074              
3075 0 0 0     0 if ($r < 1 || $c < 1) {
3076 0         0 $ttext = "ERRCELL";
3077             }
3078             } elsif ($ttype == $token_string) {
3079 0         0 $ttext =~ s/"/""/g;
3080 0         0 $ttext = '"' . $ttext . '"';
3081             }
3082 0         0 $updatedformula .= $ttext;
3083             }
3084              
3085 0         0 return $updatedformula;
3086              
3087             }
3088              
3089             =head2 format_value_for_display
3090              
3091             $displayvalue = format_value_for_display(\%sheetdata, $value, $cr, $linkstyle)
3092              
3093             =cut
3094              
3095             sub format_value_for_display {
3096 0     0 1 0 my ($sheetdata, $value, $cr, $linkstyle) = @_;
3097              
3098             # Get references to the parts
3099 0         0 my $datavalues = $sheetdata->{datavalues};
3100 0         0 my $valuetypes = $sheetdata->{valuetypes};
3101 0         0 my $cellerrors = $sheetdata->{cellerrors};
3102 0         0 my $cellattribs = $sheetdata->{cellattribs};
3103 0         0 my $sheetattribs = $sheetdata->{sheetattribs};
3104 0         0 my $valueformats = $sheetdata->{valueformats};
3105 0         0 my $datatypes = $sheetdata->{datatypes};
3106 0         0 my $dataformulas = $sheetdata->{formulas};
3107              
3108 0         0 my $displayvalue = $value;
3109              
3110 0         0 my $valuetype =
3111             $valuetypes->{$cr}; # get type of value to determine formatting
3112 0         0 my $valuesubtype = substr($valuetype, 1);
3113 0         0 $valuetype = substr($valuetype, 0, 1);
3114              
3115 0 0       0 if ($cellerrors->{$cr}) {
3116              
3117             # TODO check this, now that expand_markup no longer exists
3118             # $displayvalue = expand_markup($cellerrors->{$cr}, $sheetdata, $linkstyle) || $valuesubtype || "Error in cell";
3119 0   0     0 $displayvalue = $cellerrors->{$cr} || $valuesubtype || "Error in cell";
3120 0         0 return $displayvalue;
3121             }
3122              
3123 0 0       0 if ($valuetype eq "t") {
    0          
3124 0   0     0 my $valueformat = $valueformats->[
3125             ( $cellattribs->{$cr}->{textvalueformat}
3126             || $sheetattribs->{defaulttextvalueformat})
3127             ]
3128             || "";
3129 0 0       0 if ($valueformat eq "formula") {
3130 0 0       0 if ($datatypes->{$cr} eq "f") {
    0          
3131 0   0     0 $displayvalue = html_escape("=$dataformulas->{$cr}") || " ";
3132             } elsif ($datatypes->{$cr} eq "c") {
3133 0   0     0 $displayvalue = html_escape("'$dataformulas->{$cr}") || " ";
3134             } else {
3135 0   0     0 $displayvalue = html_escape("'$displayvalue") || " ";
3136             }
3137 0         0 return $displayvalue;
3138             }
3139             $displayvalue =
3140 0         0 format_text_for_display($displayvalue, $valuetypes->{$cr}, $valueformat,
3141             $sheetdata, $linkstyle);
3142             }
3143              
3144             elsif ($valuetype eq "n") {
3145 0         0 my $valueformat = $cellattribs->{$cr}->{nontextvalueformat};
3146 0 0       0 if (length($valueformat) == 0) { # "0" is a legal value format
3147 0         0 $valueformat = $sheetattribs->{defaultnontextvalueformat};
3148             }
3149 0         0 $valueformat = $valueformats->[$valueformat];
3150 0 0       0 if (length($valueformat) == 0) {
3151 0         0 $valueformat = "";
3152             }
3153 0 0       0 $valueformat = "" if $valueformat eq "none";
3154 0 0       0 if ($valueformat eq "formula") {
    0          
3155 0 0       0 if ($datatypes->{$cr} eq "f") {
    0          
3156 0   0     0 $displayvalue = html_escape("=$dataformulas->{$cr}") || " ";
3157             } elsif ($datatypes->{$cr} eq "c") {
3158 0   0     0 $displayvalue = html_escape("'$dataformulas->{$cr}") || " ";
3159             } else {
3160 0   0     0 $displayvalue = html_escape("'$displayvalue") || " ";
3161             }
3162 0         0 return $displayvalue;
3163             } elsif ($valueformat eq "forcetext") {
3164 0 0       0 if ($datatypes->{$cr} eq "f") {
    0          
3165 0   0     0 $displayvalue = html_escape("=$dataformulas->{$cr}") || " ";
3166             } elsif ($datatypes->{$cr} eq "c") {
3167 0   0     0 $displayvalue = html_escape($dataformulas->{$cr}) || " ";
3168             } else {
3169 0   0     0 $displayvalue = html_escape($displayvalue) || " ";
3170             }
3171 0         0 return $displayvalue;
3172             }
3173             $displayvalue =
3174 0         0 format_number_for_display($displayvalue, $valuetypes->{$cr},
3175             $valueformat);
3176             }
3177              
3178             else { # unknown type - probably blank
3179 0         0 $displayvalue = " ";
3180             }
3181              
3182 0         0 return $displayvalue;
3183              
3184             }
3185              
3186             =head2 format_text_for_display
3187              
3188             $displayvalue = format_text_for_display($rawvalue, $valuetype, $valueformat, $sheetdata, $linkstyle)
3189              
3190             =cut
3191              
3192             sub format_text_for_display {
3193              
3194 0     0 1 0 my ($rawvalue, $valuetype, $valueformat, $sheetdata, $linkstyle) = @_;
3195              
3196 0         0 my $valuesubtype = substr($valuetype, 1);
3197              
3198 0         0 my $displayvalue = $rawvalue;
3199              
3200 0 0       0 $valueformat = "" if $valueformat eq "none";
3201 0 0       0 $valueformat = "" unless $valueformat =~ m/^(text-|custom|hidden)/;
3202 0 0 0     0 if (!$valueformat || $valueformat eq "General")
3203             { # determine format from type
3204 0 0       0 $valueformat = "text-html" if ($valuesubtype eq "h");
3205 0 0       0 $valueformat = "text-wiki" if ($valuesubtype eq "w");
3206 0 0       0 $valueformat = "text-plain" unless $valuesubtype;
3207             }
3208 0 0       0 if ($valueformat eq "text-html") { # HTML - output as it as is
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3209             ;
3210             } elsif ($valueformat eq "text-wiki") { # wiki text
3211 0         0 die "Wiki text not handled";
3212             } elsif ($valueformat eq "text-url") { # text is a URL for a link
3213 0         0 my $dvsc = html_escape($displayvalue);
3214 0         0 my $dvue = url_encode($displayvalue);
3215 0         0 $dvue =~ s/\Q{{amp}}/%26/g;
3216 0         0 $displayvalue = qq!$dvsc!;
3217             } elsif ($valueformat eq "text-link")
3218             { # text is a URL for a link shown as Link
3219 0         0 my $dvsc = html_escape($displayvalue);
3220 0         0 my $dvue = url_encode($displayvalue);
3221 0         0 $dvue =~ s/\Q{{amp}}/%26/g;
3222 0         0 $displayvalue = qq!Link!;
3223             } elsif ($valueformat eq "text-image") { # text is a URL for an image
3224 0         0 my $dvue = url_encode($displayvalue);
3225 0         0 $dvue =~ s/\Q{{amp}}/%26/g;
3226 0         0 $displayvalue = qq!!;
3227             } elsif ($valueformat =~ m/^text-custom\:/)
3228             { # construct a custom text format: @r = text raw, @s = special chars, @u = url encoded
3229 0         0 my $dvsc = html_escape($displayvalue); # do special chars
3230 0         0 $dvsc =~ s/ /  /g; # keep multiple spaces
3231 0         0 $dvsc =~ s/\n/
/g; # keep line breaks
3232 0         0 my $dvue = url_encode($displayvalue);
3233 0         0 $dvue =~ s/\Q{{amp}}/%26/g;
3234 0         0 my %textval;
3235 0         0 $textval{r} = $displayvalue;
3236 0         0 $textval{s} = $dvsc;
3237 0         0 $textval{u} = $dvue;
3238 0         0 $displayvalue = $valueformat;
3239 0         0 $displayvalue =~ s/^text-custom\://;
3240 0         0 $displayvalue =~ s/@(r|s|u)/$textval{$1}/ge;
  0         0  
3241             } elsif ($valueformat =~ m/^custom/) { # custom
3242 0         0 $displayvalue = html_escape($displayvalue); # do special chars
3243 0         0 $displayvalue =~ s/ /  /g; # keep multiple spaces
3244 0         0 $displayvalue =~ s/\n/
/g; # keep line breaks
3245 0         0 $displayvalue .= " (custom format)";
3246             } elsif ($valueformat eq "hidden") {
3247 0         0 $displayvalue = " ";
3248             } else { # plain text
3249 0         0 $displayvalue = html_escape($displayvalue); # do special chars
3250 0         0 $displayvalue =~ s/ /  /g; # keep multiple spaces
3251 0         0 $displayvalue =~ s/\n/
/g; # keep line breaks
3252             }
3253              
3254 0         0 return $displayvalue;
3255              
3256             }
3257              
3258             =head2 format_number_for_display
3259              
3260             $displayvalue = format_number_for_display($rawvalue, $valuetype, $valueformat)
3261              
3262             =cut
3263              
3264             sub format_number_for_display {
3265              
3266 85     85 1 14177 my ($rawvalue, $valuetype, $valueformat) = @_;
3267              
3268 85         141 my ($has_parens, $has_commas);
3269              
3270 85         193 my $displayvalue = $rawvalue;
3271 85         204 my $valuesubtype = substr($valuetype, 1);
3272              
3273 85 100 66     491 if ($valueformat eq "Auto" || length($valueformat) == 0)
3274             { # cases with default format
3275 63 50       507 if ($valuesubtype eq "%") { # will display a % character
    50          
    50          
    50          
    50          
    50          
3276 0         0 $valueformat = "#,##0.0%";
3277             } elsif ($valuesubtype eq '$') {
3278 0         0 $valueformat = '[$]#,##0.00';
3279             } elsif ($valuesubtype eq 'dt') {
3280 0         0 $valueformat = 'd-mmm-yyyy h:mm:ss';
3281             } elsif ($valuesubtype eq 'd') {
3282 0         0 $valueformat = 'd-mmm-yyyy';
3283             } elsif ($valuesubtype eq 't') {
3284 0         0 $valueformat = '[h]:mm:ss';
3285             } elsif ($valuesubtype eq 'l') {
3286 0         0 $valueformat = 'logical';
3287             } else {
3288 63         123 $valueformat = "General";
3289             }
3290             }
3291              
3292 85 50       381 if ($valueformat eq "logical") { # do logical format
3293 0 0       0 return $rawvalue ? 'TRUE' : 'FALSE';
3294             }
3295              
3296 85 50       174 if ($valueformat eq "hidden") { # do hidden format
3297 0         0 return " ";
3298             }
3299              
3300             # Use format
3301              
3302 85         240 return format_number_with_format_string($rawvalue, $valueformat);
3303              
3304             }
3305              
3306             =head2 format_number_with_format_string
3307              
3308             $result = format_number_with_format_string($value, $format_string, $currency_char)
3309              
3310             Use a format string to format a numeric value. Returns a string with the result.
3311             This is a subset of the normal styles accepted by many other spreadsheets, without fractions, E format, and @,
3312             and with any number of comparison fields and with [style=style-specification] (e.g., [style=color:red])
3313              
3314             =cut
3315              
3316             my %allowedcolors = (
3317             BLACK => "#000000",
3318             BLUE => "#0000FF",
3319             CYAN => "#00FFFF",
3320             GREEN => "#00FF00",
3321             MAGENTA => "#FF00FF",
3322             RED => "#FF0000",
3323             WHITE => "#FFFFFF",
3324             YELLOW => "#FFFF00"
3325             );
3326              
3327             my %alloweddates =
3328             (H => "h]", M => "m]", MM => "mm]", "S" => "s]", "SS" => "ss]");
3329              
3330             my %format_definitions;
3331             my $cmd_copy = 1;
3332             my $cmd_color = 2;
3333             my $cmd_integer_placeholder = 3;
3334             my $cmd_fraction_placeholder = 4;
3335             my $cmd_decimal = 5;
3336             my $cmd_currency = 6;
3337             my $cmd_general = 7;
3338             my $cmd_separator = 8;
3339             my $cmd_date = 9;
3340             my $cmd_comparison = 10;
3341             my $cmd_section = 11;
3342             my $cmd_style = 12;
3343              
3344             sub format_number_with_format_string {
3345              
3346 85     85 1 160 my ($rawvalue, $format_string, $currency_char) = @_;
3347              
3348 85   50     337 $currency_char ||= '$';
3349              
3350 85         119 my ($op, $operandstr, $fromend, $cval, $operandstrlc);
3351 0         0 my ($yr, $mn, $dy, $hrs, $mins, $secs, $ehrs, $emins, $esecs, $ampmstr);
3352 0         0 my $result;
3353              
3354 85         167 my $value = $rawvalue + 0; # get a working copy that's numeric
3355              
3356 85 100       204 my $negativevalue = $value < 0 ? 1 : 0; # determine sign, etc.
3357 85 100       199 $value = -$value if $negativevalue;
3358 85 50       172 my $zerovalue = $value == 0 ? 1 : 0;
3359              
3360 85         327 parse_format_string(\%format_definitions, $format_string)
3361             ; # make sure format is parsed
3362 85         176 my $thisformat = $format_definitions{$format_string}; # Get format structure
3363              
3364 85 50       222 return "Format error!" unless $thisformat;
3365              
3366 85         210 my $section =
3367 85         106 (scalar @{ $thisformat->{sectioninfo} }) - 1; # get number of sections - 1
3368              
3369 85 50       295 if ($thisformat->{hascomparison})
    100          
3370             { # has comparisons - determine which section
3371 0         0 $section = 0; # set to which section we will use
3372 0         0 my $gotcomparison = 0; # this section has no comparison
3373 0         0 for (my $cpos ; ; $cpos++) { # scan for comparisons
3374 0         0 $op = $thisformat->{operators}->[$cpos];
3375 0         0 $operandstr =
3376             $thisformat->{operands}->[$cpos]; # get next operator and operand
3377 0 0       0 if (!$op) { # at end with no match
3378 0 0       0 if ($gotcomparison) { # if comparison but no match
3379 0         0 $format_string = "General"; # use default of General
3380 0         0 parse_format_string(\%format_definitions, $format_string);
3381 0         0 $thisformat = $format_definitions{$format_string};
3382 0         0 $section = 0;
3383             }
3384 0         0 last; # if no comparision, matchines on this section
3385             }
3386 0 0       0 if ($op == $cmd_section) { # end of section
3387 0 0       0 if (!$gotcomparison) { # no comparison, so it's a match
3388 0         0 last;
3389             }
3390 0         0 $gotcomparison = 0;
3391 0         0 $section++; # check out next one
3392 0         0 next;
3393             }
3394 0 0       0 if ($op == $cmd_comparison) { # found a comparison - do we meet it?
3395 0         0 my ($compop, $compval) = split (/:/, $operandstr, 2);
3396 0         0 $compval = 0 + $compval;
3397 0 0 0     0 if ( ($compop eq "<" && $rawvalue < $compval)
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
3398             || ($compop eq "<=" && $rawvalue <= $compval)
3399             || ($compop eq "<>" && $rawvalue != $compval)
3400             || ($compop eq ">=" && $rawvalue >= $compval)
3401             || ($compop eq ">" && $rawvalue > $compval)) { # a match
3402 0         0 last;
3403             }
3404 0         0 $gotcomparison = 1;
3405             }
3406             }
3407             } elsif ($section > 0) { # more than one section (separated by ";")
3408 2 50       5 if ($section == 1) { # two sections
    0          
3409 2 100       5 if ($negativevalue) {
3410 1         2 $negativevalue = 0; # sign will provided by section, not automatically
3411 1         2 $section = 1; # use second section for negative values
3412             } else {
3413 1         2 $section = 0; # use first for all others
3414             }
3415             } elsif ($section == 2) { # three sections
3416 0 0       0 if ($negativevalue) {
    0          
3417 0         0 $negativevalue = 0; # sign will provided by section, not automatically
3418 0         0 $section = 1; # use second section for negative values
3419             } elsif ($zerovalue) {
3420 0         0 $section = 2; # use third section for zero values
3421             } else {
3422 0         0 $section = 0; # use first for positive
3423             }
3424             }
3425             }
3426              
3427             # Get values for our section
3428 85         3065 my ($sectionstart, $integerdigits, $fractiondigits, $commas, $percent,
3429             $thousandssep)
3430             = map $_ || 0,
3431 85   100     145 @{ $thisformat->{sectioninfo}->[$section] }
3432             {qw(sectionstart integerdigits fractiondigits commas percent thousandssep)
3433             };
3434              
3435 85 100       316 if ($commas > 0) { # scale by thousands
3436 3         10 for (my $i = 0 ; $i < $commas ; $i++) {
3437 4         12 $value /= 1000;
3438             }
3439             }
3440 85 100       202 if ($percent > 0) { # do percent scaling
3441 2         7 for (my $i = 0 ; $i < $percent ; $i++) {
3442 2         7 $value *= 100;
3443             }
3444             }
3445              
3446 85         123 my $decimalscale = 1; # cut down to required number of decimal digits
3447 85         272 for (my $i = 0 ; $i < $fractiondigits ; $i++) {
3448 8         17 $decimalscale *= 10;
3449             }
3450 85         220 my $scaledvalue = int($value * $decimalscale + 0.5);
3451 85         142 $scaledvalue = $scaledvalue / $decimalscale;
3452              
3453 85 0 0     206 $negativevalue = 0
      33        
3454             if ($scaledvalue == 0 && ($fractiondigits || $integerdigits))
3455             ; # no "-0" unless using multiple sections or General
3456              
3457 85         211 my $strvalue = "$scaledvalue"; # convert to string
3458 85 50       268 if ($strvalue =~ m/e/) { # converted to scientific notation
3459 0         0 return "$rawvalue"; # Just return plain converted raw value
3460             }
3461 85         426 $strvalue =~ m/^\+{0,1}(\d*)(?:\.(\d*)){0,1}$/
3462             ; # get integer and fraction as character arrays
3463 85   100     344 my $integervalue = $1 || "";
3464 85         326 my @integervalue = split (//, $integervalue);
3465 85   100     432 my $fractionvalue = $2 || "";
3466 85         204 my @fractionvalue = split (//, $fractionvalue);
3467              
3468 85 100       282 if ($thisformat->{sectioninfo}->[$section]->{hasdate})
3469             { # there are date placeholders
3470 12 50       24 if ($rawvalue < 0) { # bad date
3471 0         0 return "??-???-?? ??:??:??";
3472             }
3473 12         21 my $startval =
3474             ($rawvalue - int($rawvalue)) * $seconds_in_a_day; # get date/time parts
3475 12         13 my $estartval =
3476             $rawvalue * $seconds_in_a_day; # do elapsed time version, too
3477 12         15 $hrs = int($startval / $seconds_in_an_hour);
3478 12         14 $ehrs = int($estartval / $seconds_in_an_hour);
3479 12         16 $startval = $startval - $hrs * $seconds_in_an_hour;
3480 12         16 $mins = int($startval / 60);
3481 12         14 $emins = int($estartval / 60);
3482 12         14 $secs = $startval - $mins * 60;
3483 12         13 $decimalscale = 1; # round appropriately depending if there is ss.0
3484              
3485 12         29 for (my $i = 0 ; $i < $fractiondigits ; $i++) {
3486 0         0 $decimalscale *= 10;
3487             }
3488 12         21 $secs = int($secs * $decimalscale + 0.5);
3489 12         13 $secs = $secs / $decimalscale;
3490 12         24 $esecs = int($estartval * $decimalscale + 0.5);
3491 12         14 $esecs = $esecs / $decimalscale;
3492 12 50       24 if ($secs >= 60) { # handle round up into next second, minute, etc.
3493 0         0 $secs = 0;
3494 0         0 $mins++;
3495 0         0 $emins++;
3496 0 0       0 if ($mins >= 60) {
3497 0         0 $mins = 0;
3498 0         0 $hrs++;
3499 0         0 $ehrs++;
3500 0 0       0 if ($hrs >= 24) {
3501 0         0 $hrs = 0;
3502 0         0 $rawvalue++;
3503             }
3504             }
3505             }
3506 12         39 @fractionvalue = split (//, $secs - int($secs)); # for "hh:mm:ss.00"
3507 12         16 shift @fractionvalue;
3508 12         18 shift @fractionvalue;
3509 12         34 ($yr, $mn, $dy) =
3510             convert_date_julian_to_gregorian(int($rawvalue + $julian_offset));
3511              
3512 12         17 my $minOK; # says "m" can be minutes
3513 12         15 my $mspos = $sectionstart; # m scan position in ops
3514 12         15 for (; ; $mspos++)
3515             { # scan for "m" and "mm" to see if any minutes fields, and am/pm
3516 31         41 $op = $thisformat->{operators}->[$mspos];
3517 31         41 $operandstr =
3518             $thisformat->{operands}->[$mspos]; # get next operator and operand
3519 31 100       63 last unless $op; # don't go past end
3520 19 50       34 last if $op == $cmd_section;
3521 19 100       35 if ($op == $cmd_date) {
    50          
3522 15 50 33     76 if ((lc($operandstr) eq "am/pm" || lc($operandstr) eq "a/p")
      33        
3523             && !$ampmstr) {
3524 0 0       0 if ($hrs >= 12) {
3525 0         0 $hrs -= 12;
3526 0 0       0 $ampmstr = lc($operandstr) eq "a/p" ? "P" : "PM";
3527             } else {
3528 0 0       0 $ampmstr = lc($operandstr) eq "a/p" ? "A" : "AM";
3529             }
3530 0 0       0 $ampmstr = lc $ampmstr if $operandstr !~ m/$ampmstr/;
3531             }
3532 15 0 0     30 if ($minOK && ($operandstr eq "m" || $operandstr eq "mm")) {
      33        
3533 0         0 $thisformat->{operands}->[$mspos] .=
3534             "in"; # turn into "min" or "mmin"
3535             }
3536 15 50       32 if (substr($operandstr, 0, 1) eq "h") {
3537 0         0 $minOK = 1; # m following h or hh or [h] is minutes not months
3538             } else {
3539 15         27 $minOK = 0;
3540             }
3541             } elsif ($op != $cmd_copy) { # copying chars can be between h and m
3542 0         0 $minOK = 0;
3543             }
3544             }
3545 12         13 $minOK = 0;
3546 12         16 for (--$mspos ; ; $mspos--) { # scan other way for s after m
3547 50         67 $op = $thisformat->{operators}->[$mspos];
3548 50         63 $operandstr =
3549             $thisformat->{operands}->[$mspos]; # get next operator and operand
3550 50 100       79 last unless $op; # don't go past end
3551 38 50       57 last if $op == $cmd_section;
3552 38 100       65 if ($op == $cmd_date) {
    50          
3553 30 0 0     53 if ($minOK && ($operandstr eq "m" || $operandstr eq "mm")) {
      33        
3554 0         0 $thisformat->{operands}->[$mspos] .=
3555             "in"; # turn into "min" or "mmin"
3556             }
3557 30 50       48 if ($operandstr eq "ss") {
3558 0         0 $minOK = 1; # m before ss is minutes not months
3559             } else {
3560 30         35 $minOK = 0;
3561             }
3562             } elsif ($op != $cmd_copy) { # copying chars can be between ss and m
3563 0         0 $minOK = 0;
3564             }
3565             }
3566             }
3567              
3568 85         133 my $integerdigits2 = 0; # init counters, etc.
3569 85         144 my $integerpos = 0;
3570 85         106 my $fractionpos = 0;
3571 85         235 my $textcolor = "";
3572 85         105 my $textstyle = "";
3573 85         109 my $separatorchar = ",";
3574 85         152 my $decimalchar = '.';
3575              
3576 85         111 my $oppos = $sectionstart;
3577              
3578 85         276 while ($op = $thisformat->{operators}->[$oppos]) { # execute format
3579 126         257 $operandstr =
3580             $thisformat->{operands}->[ $oppos++ ]; # get next operator and operand
3581 126 100       865 if ($op == $cmd_copy) { # put char in result
    50          
    50          
    100          
    100          
    100          
    50          
    100          
    100          
    50          
    0          
3582 8         19 $result .= $operandstr;
3583             }
3584              
3585             elsif ($op == $cmd_color) { # set color
3586 0         0 $textcolor = $operandstr;
3587             }
3588              
3589             elsif ($op == $cmd_style) { # set style
3590 0         0 $textstyle = $operandstr;
3591             }
3592              
3593             elsif ($op == $cmd_integer_placeholder) { # insert number part
3594 28 50       48 if ($negativevalue) {
3595 0         0 $result .= "-";
3596 0         0 $negativevalue = 0;
3597             }
3598 28         27 $integerdigits2++;
3599 28 100       50 if ($integerdigits2 == 1) { # first one
3600 10 100       21 if ((scalar @integervalue) > $integerdigits)
3601             { # see if integer wider than field
3602 2         6 for (
3603             ;
3604             $integerpos < ((scalar @integervalue) - $integerdigits) ;
3605             $integerpos++
3606             ) {
3607 2         4 $result .= $integervalue[$integerpos];
3608 2 50       9 if ($thousandssep) { # see if this is a separator position
3609 0         0 $fromend = (scalar @integervalue) - $integerpos - 1;
3610 0 0 0     0 if ($fromend > 2 && $fromend % 3 == 0) {
3611 0         0 $result .= $separatorchar;
3612             }
3613             }
3614             }
3615             }
3616             }
3617 28 100 100     95 if ((scalar @integervalue) < $integerdigits
3618             && $integerdigits2 <= $integerdigits - (scalar @integervalue))
3619             { # field is wider than value
3620 9 100 66     45 if ($operandstr eq "0" || $operandstr eq "?")
3621             { # fill with appropriate characters
3622 4 50       9 $result .= $operandstr eq "0" ? "0" : " ";
3623 4 50       15 if ($thousandssep) { # see if this is a separator position
3624 0         0 $fromend = $integerdigits - $integerdigits2;
3625 0 0 0     0 if ($fromend > 2 && $fromend % 3 == 0) {
3626 0         0 $result .= $separatorchar;
3627             }
3628             }
3629             }
3630             } else { # normal integer digit - add it
3631 19         24 $result .= $integervalue[$integerpos];
3632 19 100       47 if ($thousandssep) { # see if this is a separator position
3633 15         19 $fromend = (scalar @integervalue) - $integerpos - 1;
3634 15 100 66     52 if ($fromend > 2 && $fromend % 3 == 0) {
3635 3         5 $result .= $separatorchar;
3636             }
3637             }
3638 19         58 $integerpos++;
3639             }
3640             } elsif ($op == $cmd_fraction_placeholder) { # add fraction part of number
3641 8 50       15 if ($fractionpos >= scalar @fractionvalue) {
3642 0 0 0     0 if ($operandstr eq "0" || $operandstr eq "?") {
3643 0 0       0 $result .= $operandstr eq "0" ? "0" : " ";
3644             }
3645             } else {
3646 8         12 $result .= $fractionvalue[$fractionpos];
3647             }
3648 8         21 $fractionpos++;
3649             }
3650              
3651             elsif ($op == $cmd_decimal) { # decimal point
3652 3 50       8 if ($negativevalue) {
3653 0         0 $result .= "-";
3654 0         0 $negativevalue = 0;
3655             }
3656 3         9 $result .= $decimalchar;
3657             }
3658              
3659             elsif ($op == $cmd_currency) { # currency symbol
3660 0 0       0 if ($negativevalue) {
3661 0         0 $result .= "-";
3662 0         0 $negativevalue = 0;
3663             }
3664 0         0 $result .= $operandstr;
3665             }
3666              
3667             elsif ($op == $cmd_general) { # insert "General" conversion
3668 63         101 my $gvalue = $rawvalue + 0; # make sure it's numeric
3669 63 50       121 if ($negativevalue) {
3670 0         0 $result .= "-";
3671 0         0 $negativevalue = 0;
3672 0         0 $gvalue = -$gvalue;
3673             }
3674 63         108 $strvalue = "$gvalue"; # convert original value to string
3675 63 50       170 if ($strvalue =~ m/e/) { # converted to scientific notation
3676 0         0 $result .= "$strvalue";
3677 0         0 next;
3678             }
3679 63         263 $strvalue =~ m/^\+{0,1}(\d*)(?:\.(\d*)){0,1}$/;
3680 63         122 $integervalue = $1;
3681 63 50       158 $integervalue = "" if ($integervalue == 0);
3682 63         199 @integervalue = split (//, $integervalue);
3683 63         119 $fractionvalue = $2;
3684 63   50     230 $fractionvalue ||= "";
3685 63         150 @fractionvalue = split (//, $fractionvalue);
3686 63         99 $integerpos = 0;
3687 63         101 $fractionpos = 0;
3688              
3689 63 50       159 if (scalar @integervalue) {
3690 63         178 for (; $integerpos < scalar @integervalue ; $integerpos++) {
3691 63         122 $result .= $integervalue[$integerpos];
3692 63 50       244 if ($thousandssep) { # see if this is a separator position
3693 0         0 $fromend = (scalar @integervalue) - $integerpos - 1;
3694 0 0 0     0 if ($fromend > 2 && $fromend % 3 == 0) {
3695 0         0 $result .= $separatorchar;
3696             }
3697             }
3698             }
3699             } else {
3700 0         0 $result .= "0";
3701             }
3702 63 50       300 if (scalar @fractionvalue) {
3703 0         0 $result .= $decimalchar;
3704 0         0 for (; $fractionpos < scalar @fractionvalue ; $fractionpos++) {
3705 0         0 $result .= $fractionvalue[$fractionpos];
3706             }
3707             }
3708             }
3709              
3710             elsif ($op == $cmd_date) { # date placeholder
3711 15         20 $operandstrlc = lc $operandstr;
3712 15 100 66     126 if ($operandstrlc eq "y" || $operandstrlc eq "yy") {
    100 0        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3713 1         5 $result .= substr("$yr", -2);
3714             } elsif ($operandstrlc eq "yyyy") {
3715 2         6 $result .= "$yr";
3716             } elsif ($operandstrlc eq "d") {
3717 2         7 $result .= "$dy";
3718             } elsif ($operandstrlc eq "dd") {
3719 1         3 $cval = 1000 + $dy;
3720 1         17 $result .= substr("$cval", -2);
3721             } elsif ($operandstrlc eq "ddd") {
3722 2         9 my @names = qw/Sun Mon Tue Wed Thu Fri Sat/;
3723 2         5 $cval = int($rawvalue + 6) % 7;
3724 2         8 $result .= $names[$cval];
3725             } elsif ($operandstrlc eq "dddd") {
3726 1         4 my @names =
3727             qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/;
3728 1         3 $cval = int($rawvalue + 6) % 7;
3729 1         6 $result .= $names[$cval];
3730             } elsif ($operandstrlc eq "m") {
3731 1         5 $result .= "$mn";
3732             } elsif ($operandstrlc eq "mm") {
3733 1         2 $cval = 1000 + $mn;
3734 1         5 $result .= substr("$cval", -2);
3735             } elsif ($operandstrlc eq "mmm") {
3736 1         4 my @names = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
3737 1         4 $result .= $names[ $mn - 1 ];
3738             } elsif ($operandstrlc eq "mmmm") {
3739 2         9 my @names = qw/
3740             January February March April May June
3741             July August September October November December
3742             /;
3743 2         8 $result .= $names[ $mn - 1 ];
3744             } elsif ($operandstrlc eq "mmmmm") {
3745 1         7 my @names = qw/J F M A M J J A S O N D/;
3746 1         6 $result .= $names[ $mn - 1 ];
3747             } elsif ($operandstrlc eq "h") {
3748 0         0 $result .= "$hrs";
3749             } elsif ($operandstrlc eq "h]") {
3750 0         0 $result .= "$ehrs";
3751             } elsif ($operandstrlc eq "mmin") {
3752 0         0 $cval = 1000 + $mins;
3753 0         0 $result .= substr("$cval", -2);
3754             } elsif ($operandstrlc eq "mm]") {
3755 0 0       0 if ($emins < 100) {
3756 0         0 $cval = 1000 + $emins;
3757 0         0 $result .= substr("$cval", -2);
3758             } else {
3759 0         0 $result .= "$emins";
3760             }
3761             } elsif ($operandstrlc eq "min") {
3762 0         0 $result .= "$mins";
3763             } elsif ($operandstrlc eq "m]") {
3764 0         0 $result .= "$emins";
3765             } elsif ($operandstrlc eq "hh") {
3766 0         0 $cval = 1000 + $hrs;
3767 0         0 $result .= substr("$cval", -2);
3768             } elsif ($operandstrlc eq "s") {
3769 0         0 $cval = int($secs);
3770 0         0 $result .= "$cval";
3771             } elsif ($operandstrlc eq "ss") {
3772 0         0 $cval = 1000 + int($secs);
3773 0         0 $result .= substr("$cval", -2);
3774             } elsif ($operandstrlc eq "am/pm" || $operandstrlc eq "a/p") {
3775 0         0 $result .= $ampmstr;
3776             } elsif ($operandstrlc eq "ss]") {
3777 0 0       0 if ($esecs < 100) {
3778 0         0 $cval = 1000 + int($esecs);
3779 0         0 $result .= substr("$cval", -2);
3780             } else {
3781 0         0 $cval = int($esecs);
3782 0         0 $result = "$cval";
3783             }
3784             }
3785             }
3786              
3787             elsif ($op == $cmd_section) { # end of section
3788 1         2 last;
3789             }
3790              
3791             elsif ($op == $cmd_comparison) { # ignore
3792 0         0 next;
3793             }
3794              
3795             else {
3796 0         0 $result .= "!! Parse error !!";
3797             }
3798             }
3799              
3800 85 50       287 if ($textcolor) {
3801 0         0 $result = qq!$result!;
3802             }
3803 85 50       173 if ($textstyle) {
3804 0         0 $result = qq!$result!;
3805             }
3806              
3807 85         586 return $result;
3808             }
3809              
3810             =head2 parse_format_string
3811              
3812             parse_format_string(\%format_defs, $format_string)
3813              
3814             Takes a format string (e.g., "#,##0.00_);(#,##0.00)") and fills in %foramt_defs with the parsed info
3815              
3816             %format_defs
3817             {"#,##0.0"}->{} # elements in the hash are one hash for each format
3818             {operators}->[] # array of operators from parsing the format string (each a number)
3819             {operands}->[] # array of corresponding operators (each usually a string)
3820             {sectioninfo}->[] # one hash for each section of the format
3821             {start}
3822             {integerdigits}
3823             {fractiondigits}
3824             {commas}
3825             {percent}
3826             {thousandssep}
3827             {hasdates}
3828             {hascomparison} # true if any section has [<100], etc.
3829              
3830             =cut
3831              
3832             sub parse_format_string {
3833              
3834 85     85 1 132 my ($format_defs, $format_string) = @_;
3835              
3836             return
3837 85 100       279 if ($format_defs->{$format_string}); # already defined - nothing to do
3838              
3839 21         112 my $thisformat =
3840             { operators => [], operands => [],
3841             sectioninfo => [ {} ] }; # create info structure for this format
3842 21         48 $format_defs->{$format_string} =
3843             $thisformat; # add to other format definitions
3844              
3845 21         62 my $section = 0; # start with section 0
3846 21         37 my $sectioninfo =
3847             $thisformat->{sectioninfo}->[$section]
3848             ; # get reference to info for current section
3849 21         48 $sectioninfo->{sectionstart} =
3850             0; # position in operands that starts this section
3851              
3852 21         105 my @formatchars = split //,
3853             $format_string; # break into individual characters
3854              
3855 21         34 my $integerpart = 1; # start out in integer part
3856 21         27 my $lastwasinteger; # last char was an integer placeholder
3857             my $lastwasslash; # last char was a backslash - escaping following character
3858 0         0 my $lastwasasterisk; # repeat next char
3859 0         0 my $lastwasunderscore
3860             ; # last char was _ which picks up following char for width
3861 0         0 my ($inquote, $quotestr); # processing a quoted string
3862 0         0 my ($inbracket, $bracketstr, $cmd); # processing a bracketed string
3863 0         0 my ($ingeneral, $gpos); # checks for characters "General"
3864 0         0 my $ampmstr; # checks for characters "A/P" and "AM/PM"
3865 0         0 my $indate; # keeps track of date/time placeholders
3866              
3867 21         39 foreach my $ch (@formatchars) { # parse
3868 100 50       186 if ($inquote) {
3869 0 0       0 if ($ch eq '"') {
3870 0         0 $inquote = 0;
3871 0         0 push @{ $thisformat->{operators} }, $cmd_copy;
  0         0  
3872 0         0 push @{ $thisformat->{operands} }, $quotestr;
  0         0  
3873 0         0 next;
3874             }
3875 0         0 $quotestr .= $ch;
3876 0         0 next;
3877             }
3878 100 50       243 if ($inbracket) {
3879 0 0       0 if ($ch eq ']') {
3880 0         0 $inbracket = 0;
3881 0         0 ($cmd, $bracketstr) = parse_format_bracket($bracketstr);
3882 0 0       0 if ($cmd == $cmd_separator) {
3883 0         0 $sectioninfo->{thousandssep} = 1; # explicit [,]
3884 0         0 next;
3885             }
3886 0 0       0 if ($cmd == $cmd_date) {
3887 0         0 $sectioninfo->{hasdate} = 1;
3888             }
3889 0 0       0 if ($cmd == $cmd_comparison) {
3890 0         0 $thisformat->{hascomparison} = 1;
3891             }
3892 0         0 push @{ $thisformat->{operators} }, $cmd;
  0         0  
3893 0         0 push @{ $thisformat->{operands} }, $bracketstr;
  0         0  
3894 0         0 next;
3895             }
3896 0         0 $bracketstr .= $ch;
3897 0         0 next;
3898             }
3899 100 50       160 if ($lastwasslash) {
3900 0         0 push @{ $thisformat->{operators} }, $cmd_copy;
  0         0  
3901 0         0 push @{ $thisformat->{operands} }, $ch;
  0         0  
3902 0         0 $lastwasslash = 0;
3903 0         0 next;
3904             }
3905 100 50       163 if ($lastwasasterisk) {
3906 0         0 push @{ $thisformat->{operators} }, $cmd_copy;
  0         0  
3907 0         0 push @{ $thisformat->{operands} }, $ch x 5;
  0         0  
3908 0         0 $lastwasasterisk = 0;
3909 0         0 next;
3910             }
3911 100 50       151 if ($lastwasunderscore) {
3912 0         0 push @{ $thisformat->{operators} }, $cmd_copy;
  0         0  
3913 0         0 push @{ $thisformat->{operands} }, " ";
  0         0  
3914 0         0 $lastwasunderscore = 0;
3915 0         0 next;
3916             }
3917 100 100       177 if ($ingeneral) {
3918 6 50       15 if (substr("general", $ingeneral, 1) eq lc $ch) {
3919 6         7 $ingeneral++;
3920 6 100       11 if ($ingeneral == 7) {
3921 1         2 push @{ $thisformat->{operators} }, $cmd_general;
  1         3  
3922 1         7 push @{ $thisformat->{operands} }, $ch;
  1         3  
3923 1         3 $ingeneral = 0;
3924             }
3925 6         14 next;
3926             }
3927 0         0 $ingeneral = 0;
3928             }
3929 94 100       160 if ($indate) { # last char was part of a date placeholder
3930 30 100       64 if (substr($indate, 0, 1) eq $ch) { # another of the same char
3931 27         33 $indate .= $ch; # accumulate it
3932 27         49 next;
3933             }
3934 3         5 push @{ $thisformat->{operators} },
  3         9  
3935             $cmd_date; # something else, save date info
3936 3         4 push @{ $thisformat->{operands} }, $indate;
  3         8  
3937 3         9 $sectioninfo->{hasdate} = 1;
3938 3         4 $indate = "";
3939             }
3940 67 50       108 if ($ampmstr) {
3941 0         0 $ampmstr .= $ch;
3942 0 0 0     0 if ("am/pm" =~ m/^$ampmstr/i || "a/p" =~ m/^$ampmstr/i) {
3943 0 0 0     0 if (("am/pm" eq lc $ampmstr) || ("a/p" eq lc $ampmstr)) {
3944 0         0 push @{ $thisformat->{operators} }, $cmd_date;
  0         0  
3945 0         0 push @{ $thisformat->{operands} }, $ampmstr;
  0         0  
3946 0         0 $ampmstr = "";
3947             }
3948 0         0 next;
3949             }
3950 0         0 $ampmstr = "";
3951             }
3952 67 100 100     658 if ($ch eq "#" || $ch eq "0" || $ch eq "?") { # placeholder
    100 66        
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
3953 32 100       46 if ($integerpart) {
3954 24         33 $sectioninfo->{integerdigits}++;
3955 24 100       46 if ($sectioninfo->{commas}) { # comma inside of integer placeholders
3956 4         7 $sectioninfo->{thousandssep} =
3957             1; # any number is thousands separator
3958 4         8 $sectioninfo->{commas} = 0; # reset count of "thousand" factors
3959             }
3960 24         26 $lastwasinteger = 1;
3961 24         20 push @{ $thisformat->{operators} }, $cmd_integer_placeholder;
  24         46  
3962 24         26 push @{ $thisformat->{operands} }, $ch;
  24         63  
3963             } else {
3964 8         10 $sectioninfo->{fractiondigits}++;
3965 8         9 push @{ $thisformat->{operators} }, $cmd_fraction_placeholder;
  8         16  
3966 8         9 push @{ $thisformat->{operands} }, $ch;
  8         19  
3967             }
3968             } elsif ($ch eq ".") { # decimal point
3969 3         4 $lastwasinteger = 0;
3970 3         4 push @{ $thisformat->{operators} }, $cmd_decimal;
  3         6  
3971 3         5 push @{ $thisformat->{operands} }, $ch;
  3         5  
3972 3         6 $integerpart = 0;
3973             } elsif ($ch eq '$') { # currency char
3974 0         0 $lastwasinteger = 0;
3975 0         0 push @{ $thisformat->{operators} }, $cmd_currency;
  0         0  
3976 0         0 push @{ $thisformat->{operands} }, $ch;
  0         0  
3977             } elsif ($ch eq ",") {
3978 8 100       19 if ($lastwasinteger) {
3979 7         16 $sectioninfo->{commas}++;
3980             } else {
3981 1         3 push @{ $thisformat->{operators} }, $cmd_copy;
  1         3  
3982 1         2 push @{ $thisformat->{operands} }, $ch;
  1         4  
3983             }
3984             } elsif ($ch eq "%") {
3985 2         3 $lastwasinteger = 0;
3986 2         4 $sectioninfo->{percent}++;
3987 2         3 push @{ $thisformat->{operators} }, $cmd_copy;
  2         3  
3988 2         3 push @{ $thisformat->{operands} }, $ch;
  2         8  
3989             } elsif ($ch eq '"') {
3990 0         0 $lastwasinteger = 0;
3991 0         0 $inquote = 1;
3992 0         0 $quotestr = "";
3993             } elsif ($ch eq '[') {
3994 0         0 $lastwasinteger = 0;
3995 0         0 $inbracket = 1;
3996 0         0 $bracketstr = "";
3997             } elsif ($ch eq '\\') {
3998 0         0 $lastwasslash = 1;
3999 0         0 $lastwasinteger = 0;
4000             } elsif ($ch eq '*') {
4001 0         0 $lastwasasterisk = 1;
4002 0         0 $lastwasinteger = 0;
4003             } elsif ($ch eq '_') {
4004 0         0 $lastwasunderscore = 1;
4005 0         0 $lastwasinteger = 0;
4006             } elsif ($ch eq ";") {
4007 1         2 $section++; # start next section
4008 1         3 $thisformat->{sectioninfo}->[$section] = {}; # create a new section
4009 1         3 $sectioninfo =
4010             $thisformat->{sectioninfo}->[$section]
4011             ; # set to point to the new section
4012 1         42 $sectioninfo->{sectionstart} =
4013 1         1 1 + scalar @{ $thisformat->{operators} }; # remember where it starts
4014 1         3 $integerpart = 1; # reset for new section
4015 1         1 $lastwasinteger = 0;
4016 1         2 push @{ $thisformat->{operators} }, $cmd_section;
  1         3  
4017 1         2 push @{ $thisformat->{operands} }, $ch;
  1         3  
4018             } elsif ((lc $ch) eq "g") {
4019 1         1 $ingeneral = 1;
4020 1         3 $lastwasinteger = 0;
4021             } elsif ((lc $ch) eq "a") {
4022 0         0 $ampmstr = $ch;
4023 0         0 $lastwasinteger = 0;
4024             } elsif ($ch =~ m/[dmyhHs]/) {
4025 15         31 $indate = $ch;
4026             } else {
4027 5         8 $lastwasinteger = 0;
4028 5         7 push @{ $thisformat->{operators} }, $cmd_copy;
  5         13  
4029 5         8 push @{ $thisformat->{operands} }, $ch;
  5         14  
4030             }
4031             }
4032              
4033 21 100       58 if ($indate) { # last char was part of unsaved date placeholder
4034 12         14 push @{ $thisformat->{operators} }, $cmd_date; # save what we got
  12         101  
4035 12         17 push @{ $thisformat->{operands} }, $indate;
  12         25  
4036 12         22 $sectioninfo->{hasdate} = 1;
4037             }
4038              
4039 21         63 return;
4040              
4041             }
4042              
4043             =head2 parse_format_bracket
4044              
4045             ($operator, $operand) = parse_format_bracket($bracketstr)
4046              
4047             =cut
4048              
4049             sub parse_format_bracket {
4050              
4051 0     0 1 0 my $bracketstr = shift @_;
4052              
4053 0         0 my ($operator, $operand);
4054              
4055 0 0       0 if (substr($bracketstr, 0, 1) eq '$') { # currency
    0          
    0          
    0          
    0          
    0          
    0          
4056 0         0 $operator = $cmd_currency;
4057 0 0       0 if ($bracketstr =~ m/^\$(.+?)(\-.+?){0,1}$/) {
4058 0   0     0 $operand = $1 || '$';
4059             } else {
4060 0   0     0 $operand = substr($bracketstr, 1) || '$';
4061             }
4062             } elsif ($bracketstr eq '?$') {
4063 0         0 $operator = $cmd_currency;
4064 0         0 $operand = '[?$]';
4065             } elsif ($allowedcolors{ uc $bracketstr }) {
4066 0         0 $operator = $cmd_color;
4067 0         0 $operand = $allowedcolors{ uc $bracketstr };
4068             } elsif ($bracketstr =~ m/^style=([^"]*)$/) { # [style=...]
4069 0         0 $operator = $cmd_style;
4070 0         0 $operand = $1;
4071             } elsif ($bracketstr eq ",") {
4072 0         0 $operator = $cmd_separator;
4073 0         0 $operand = $bracketstr;
4074             } elsif ($alloweddates{ uc $bracketstr }) {
4075 0         0 $operator = $cmd_date;
4076 0         0 $operand = $alloweddates{ uc $bracketstr };
4077             } elsif ($bracketstr =~ m/^[<>=]/) { # comparison operator
4078 0         0 $bracketstr =~ m/^([<>=]+)(.+)$/; # split operator and value
4079 0         0 $operator = $cmd_comparison;
4080 0         0 $operand = "$1:$2";
4081             } else { # unknown bracket
4082 0         0 $operator = $cmd_copy;
4083 0         0 $operand = "[$bracketstr]";
4084             }
4085              
4086 0         0 return ($operator, $operand);
4087              
4088             }
4089              
4090             =head2 check_and_calc_cell
4091              
4092             $circref = check_and_calc_cell(\%sheetdata, $coord)
4093              
4094             Recalculates one cell after making sure dependencies are calc'ed, too.
4095             If circular reference, returns non-null.
4096             Circular referenced detected by using $sheetdata->{checked}->{$coord}:
4097             null - not evaluated
4098             1 - cell is being recursed into -- if get back here => circular reference
4099             2 - cell was fully recursed into and calculated this recalc cycle
4100              
4101             =cut
4102              
4103             sub check_and_calc_cell {
4104              
4105 106850     106850 1 145497 my ($Sheet, $coord) = @_;
4106              
4107 106850         149599 my $coordchecked = $Sheet->{checked};
4108              
4109 106850 100 100     634671 return ""
4110             if !$Sheet->{datatypes}->{$coord}
4111             or $Sheet->{datatypes}->{$coord} ne 'f';
4112              
4113 50015 100       115081 if ($Sheet->{checked}->{$coord}) {
4114 16538 100       40737 return $Sheet->{cellerrors}->{$coord} = "Circular reference to $coord"
4115             if $Sheet->{checked}->{$coord} == 1;
4116 16537         37888 return "";
4117             }
4118 33477         72638 $Sheet->{checked}->{$coord} = 1;
4119              
4120 33477         70725 my $line = $Sheet->{formulas}->{$coord};
4121 33477         69529 my $parseinfo = parse_formula_into_tokens($line);
4122              
4123 33477         58708 my $parsed_token_text = $parseinfo->{tokentext};
4124 33477         47439 my $parsed_token_type = $parseinfo->{tokentype};
4125 33477         45494 my ($ttype, $ttext, $sheetref);
4126 33477         80991 for (my $i = 0 ; $i < @$parsed_token_text ; $i++) {
4127 160574         195300 $ttype = $parsed_token_type->[$i];
4128 160574         189657 $ttext = $parsed_token_text->[$i];
4129 160574 100       289613 if ($ttype == $token_op)
4130             { # references with sheet specifier are not recursed into
4131 74497 100       179705 if ($ttext eq "!") {
    100          
4132 83         172 $sheetref = 1; # found a sheet reference
4133             } elsif ($ttext ne ":") { # for everything but a range, reset
4134 73120         91661 $sheetref = 0;
4135             }
4136             }
4137 160574 100       262814 if ($ttype == $token_name) { # look for named range
4138 18891         20878 my ($valuetype, $errortext);
4139 18891         50233 my $value = lookup_name($Sheet, $ttext, \$valuetype, \$errortext);
4140 18891 100       52390 if ($valuetype eq "range")
4141             { # only need to recurse for range, which may be just one cell
4142 198         919 my ($cr1, $cr2) = split (/\|/, $value);
4143 198   33     637 $cr2 ||= $cr1;
4144 198         495 my ($c1, $r1) = coord_to_cr($cr1);
4145 198         425 my ($c2, $r2) = coord_to_cr($cr2);
4146 198 50       525 ($c2, $c1) = ($c1, $c2) if ($c1 > $c2);
4147 198 50       504 ($r2, $r1) = ($r1, $r2) if ($r1 > $r2);
4148 198         528 for (my $r = $r1 ; $r <= $r2 ; $r++) {
4149 2596         5173 for (my $c = $c1 ; $c <= $c2 ; $c++) {
4150 22980         40294 my $rangecoord = cr_to_coord($c, $r);
4151 22980         42448 my $circref = check_and_calc_cell($Sheet, $rangecoord);
4152 22980 50       70952 $Sheet->{sheetattribs}->{circularreferencecell} =
4153             "$coord|$rangecoord"
4154             if $circref;
4155             }
4156             }
4157             }
4158             }
4159 160574 100       424420 if ($ttype == $token_coord) {
4160 19285 100 100     97605 if ( $i >= 2
    100 100        
      66        
      100        
4161             && $parsed_token_type->[ $i - 1 ] == $token_op
4162             && $parsed_token_text->[ $i - 1 ] eq ':'
4163             && $parsed_token_type->[ $i - 2 ] == $token_coord
4164             && !$sheetref) { # Range -- check each cell
4165 1272         4506 my ($c1, $r1) = coord_to_cr($parsed_token_text->[ $i - 2 ]);
4166 1272         3469 my ($c2, $r2) = coord_to_cr($ttext);
4167 1272 50       3836 ($c2, $c1) = ($c1, $c2) if ($c1 > $c2);
4168 1272 50       3635 ($r2, $r1) = ($r1, $r2) if ($r1 > $r2);
4169 1272         3832 for (my $r = $r1 ; $r <= $r2 ; $r++)
4170             { # Checks first cell a second time, but that should just return
4171 5276         11288 for (my $c = $c1 ; $c <= $c2 ; $c++) {
4172 13260         22497 my $rangecoord = cr_to_coord($c, $r);
4173 13260         23140 my $circref = check_and_calc_cell($Sheet, $rangecoord);
4174 13260 100       49599 $Sheet->{sheetattribs}->{circularreferencecell} =
4175             "$coord|$rangecoord"
4176             if $circref;
4177             }
4178             }
4179             } elsif (!$sheetref) { # Single cell reference
4180 17981         29573 $ttext =~ s/\$//g;
4181 17981         37280 my $circref = check_and_calc_cell($Sheet, $ttext);
4182 17981 50       71031 $Sheet->{sheetattribs}->{circularreferencecell} = "$coord|$ttext"
4183             if $circref; # remember at least one circ ref
4184             }
4185             }
4186             }
4187 33477         67639 my ($value, $valuetype, $errortext) =
4188             evaluate_parsed_formula($parseinfo, $Sheet);
4189 33477         93341 $Sheet->{datavalues}->{$coord} = $value;
4190 33477         68315 $Sheet->{valuetypes}->{$coord} = $valuetype;
4191 33477 100       97224 if ($errortext) {
    100          
4192 2244         5540 $Sheet->{cellerrors}->{$coord} = $errortext;
4193             } elsif ($Sheet->{cellerrors}->{$coord}) {
4194 1         4 delete $Sheet->{cellerrors}->{$coord};
4195             }
4196 33477         57441 $Sheet->{checked}->{$coord} = 2; # Remember we were here
4197 33477         184223 return "";
4198             }
4199              
4200             =head2 parse_formula_into_tokens
4201              
4202             \%parseinfo = parse_formula_into_tokens($line)
4203              
4204             Parses a text string as if it was a spreadsheet formula
4205              
4206             This uses a simple state machine run on each character in turn.
4207             States remember whether a number is being gathered, etc.
4208             The result is %parseinfo which has the following arrays with one entry for each token:
4209             {tokentext}->[] - the characters making up the parsed token,
4210             {tokentype}->[] - the type of the token,
4211             {tokenopcode}->[] - a single character version of an operator suitable for use in the
4212             precedence table and distinguishing between unary and binary + and -.
4213              
4214             =cut
4215              
4216             sub parse_formula_into_tokens {
4217              
4218 33477     33477 1 45936 my $line = shift @_;
4219              
4220 33477         119796 my @ch = unpack("C*", $line);
4221 33477         59017 push @ch, ord('#'); # add eof at end
4222              
4223 33477         35802 my $state = 0;
4224 33477         35831 my $state_num = 1;
4225 33477         35395 my $state_alpha = 2;
4226 33477         34595 my $state_coord = 3;
4227 33477         42439 my $state_string = 4;
4228 33477         34406 my $state_stringquote = 5;
4229 33477         33691 my $state_numexp1 = 6;
4230 33477         33440 my $state_numexp2 = 7;
4231 33477         33022 my $state_alphanumeric = 8;
4232              
4233 33477         30619 my $str;
4234 33477         39863 my ($cclass, $chrc, $ucchrc, $last_token_type, $last_token_text, $t);
4235              
4236 0         0 my %parseinfo;
4237              
4238 33477         73149 $parseinfo{tokentext} = [];
4239 33477         58764 $parseinfo{tokentype} = [];
4240 33477         59779 $parseinfo{tokenopcode} = [];
4241 33477         47296 my $parsed_token_text = $parseinfo{tokentext};
4242 33477         42180 my $parsed_token_type = $parseinfo{tokentype};
4243 33477         38735 my $parsed_token_opcode = $parseinfo{tokenopcode};
4244              
4245 33477         50689 foreach my $c (@ch) {
4246 327791         414411 $chrc = chr($c);
4247 327791         426230 $ucchrc = uc $chrc;
4248 327791 50       813814 $cclass = $char_class[ ($c <= 127 ? (($c >= 32) ? $c : 32) : 32) - 32 ];
    50          
4249              
4250 327791 100       567447 if ($state == $state_num) {
4251 52495 100 66     165417 if ($cclass == $char_class_num) {
    100          
    100          
4252 14022         19153 $str .= $chrc;
4253             } elsif ($cclass == $char_class_numstart && index($str, '.') == -1) {
4254 1711         3355 $str .= $chrc;
4255             } elsif ($ucchrc eq 'E') {
4256 6         7 $str .= $chrc;
4257 6         10 $state = $state_numexp1;
4258             } else { # end of number - save it
4259 36756         66113 push @$parsed_token_text, $str;
4260 36756         52595 push @$parsed_token_type, $token_num;
4261 36756         46758 push @$parsed_token_opcode, 0;
4262 36756         55823 $state = 0;
4263             }
4264             }
4265              
4266 327791 100       546205 if ($state == $state_numexp1) {
4267 17 100 100     80 if ($cclass == $state_num) {
    100 66        
    50          
4268 6         8 $state = $state_numexp2;
4269             } elsif (($chrc eq '+' || $chrc eq '-') && (uc substr($str, -1)) eq 'E')
4270             {
4271 5         6 $str .= $chrc;
4272             } elsif ($ucchrc eq 'E') {
4273             ;
4274             } else {
4275 0         0 push @$parsed_token_text, "Improperly formed number exponent";
4276 0         0 push @$parsed_token_type, $token_error;
4277 0         0 push @$parsed_token_opcode, 0;
4278 0         0 $state = 0;
4279             }
4280             }
4281              
4282 327791 100       526655 if ($state == $state_numexp2) {
4283 12 100       15 if ($cclass == $char_class_num) {
4284 6         10 $str .= $chrc;
4285             } else { # end of number - save it
4286 6         12 push @$parsed_token_text, $str;
4287 6         7 push @$parsed_token_type, $token_num;
4288 6         9 push @$parsed_token_opcode, 0;
4289 6         8 $state = 0;
4290             }
4291             }
4292              
4293 327791 100       539619 if ($state == $state_alpha) {
4294 93530 100 66     251968 if ($cclass == $char_class_num) {
    100 100        
    100 66        
    100          
4295 20212         26602 $state = $state_coord;
4296             } elsif ($cclass == $char_class_alpha) {
4297 55162         76780 $str .=
4298             $ucchrc; # coords and functions are uppercase, names ignore case
4299             } elsif ($cclass == $char_class_incoord) {
4300 6         9 $state = $state_coord;
4301             } elsif ($cclass == $char_class_op
4302             || $cclass == $char_class_numstart
4303             || $cclass == $char_class_space
4304             || $cclass == $char_class_eof) {
4305 18135         37616 push @$parsed_token_text, $str;
4306 18135         26577 push @$parsed_token_type, $token_name;
4307 18135         27194 push @$parsed_token_opcode, 0;
4308 18135         27881 $state = 0;
4309             } else {
4310 15         38 push @$parsed_token_text, $str;
4311 15         31 push @$parsed_token_type, $token_error;
4312 15         26 push @$parsed_token_opcode, 0;
4313 15         31 $state = 0;
4314             }
4315             }
4316              
4317 327791 100       542429 if ($state == $state_coord) {
4318 55226 100 66     174554 if ($cclass == $char_class_num) {
    100 100        
    50          
    100          
4319 35002         46847 $str .= $chrc;
4320             } elsif ($cclass == $char_class_incoord) {
4321 6         7 $str .= $chrc;
4322             } elsif ($cclass == $char_class_alpha) {
4323 0         0 $state = $state_alphanumeric;
4324             } elsif ($cclass == $char_class_op
4325             || $cclass == $char_class_numstart
4326             || $cclass == $char_class_eof) {
4327 20041 100       89370 if ($str =~ m/^\$?[A-Z]{1,2}\$?[1-9]\d*$/) {
4328 19285         26043 $t = $token_coord;
4329             } else {
4330 756         1260 $t = $token_name;
4331             }
4332 20041         36449 push @$parsed_token_text, $str;
4333 20041         34054 push @$parsed_token_type, $t;
4334 20041         28736 push @$parsed_token_opcode, 0;
4335 20041         24951 $state = 0;
4336             } else {
4337 177         450 push @$parsed_token_text, $str;
4338 177         358 push @$parsed_token_type, $token_error;
4339 177         332 push @$parsed_token_opcode, 0;
4340 177         315 $state = 0;
4341             }
4342             }
4343              
4344 327791 50       581136 if ($state == $state_alphanumeric) {
4345 0 0 0     0 if ($cclass == $char_class_num || $cclass == $char_class_alpha) {
    0 0        
      0        
      0        
4346 0         0 $str .=
4347             $ucchrc; # coords and functions are uppercase, names ignore case
4348             } elsif ($cclass == $char_class_op
4349             || $cclass == $char_class_numstart
4350             || $cclass == $char_class_space
4351             || $cclass == $char_class_eof) {
4352 0         0 push @$parsed_token_text, $str;
4353 0         0 push @$parsed_token_type, $token_name;
4354 0         0 push @$parsed_token_opcode, 0;
4355 0         0 $state = 0;
4356             } else {
4357 0         0 push @$parsed_token_text, $str;
4358 0         0 push @$parsed_token_type, $token_error;
4359 0         0 push @$parsed_token_opcode, 0;
4360 0         0 $state = 0;
4361             }
4362             }
4363              
4364 327791 100       708784 if ($state == $state_string) {
    100          
4365 27450 100       43611 if ($cclass == $char_class_quote) {
4366 6250         8185 $state =
4367             $state_stringquote
4368             ; # got quote in string: is it doubled (quote in string) or by itself (end of string)?
4369             } else {
4370 21200         26994 $str .= $chrc;
4371             }
4372             } elsif ($state == $state_stringquote) { # note elseif here
4373 6250 100       10466 if ($cclass == $char_class_quote) {
4374 2         4 $str .= '"';
4375 2         5 $state =
4376             $state_string; # double quote: add one then continue getting string
4377             } else { # something else -- end of string
4378 6248         13097 push @$parsed_token_text, $str;
4379 6248         9388 push @$parsed_token_type, $token_string;
4380 6248         8508 push @$parsed_token_opcode, 0;
4381 6248         8599 $state = 0; # drop through to process
4382             }
4383             }
4384              
4385 327791 100       618964 if ($state == 0) {
4386 194419 100 100     1237150 if ($cclass == $char_class_num || $cclass == $char_class_numstart) {
    100 100        
    100          
    100          
    100          
    100          
4387 36762         47505 $str = $chrc;
4388 36762         54177 $state = $state_num;
4389             } elsif ($cclass == $char_class_alpha || $cclass == $char_class_incoord)
4390             {
4391 38368         49122 $str = $ucchrc;
4392 38368         60680 $state = $state_alpha;
4393             } elsif ($cclass == $char_class_op) {
4394 74759         92297 $str = chr($c);
4395 74759 100       123762 if (@$parsed_token_type) {
4396 74505         114381 $last_token_type = $parsed_token_type->[ @$parsed_token_type - 1 ];
4397 74505         113668 $last_token_text = $parsed_token_text->[ @$parsed_token_text - 1 ];
4398 74505 100       145224 if ($last_token_type == $char_class_op) {
4399 13637 100 100     59583 if ($last_token_text eq '<' || $last_token_text eq ">") {
4400 166         341 $str = $last_token_text . $str;
4401 166         260 pop @$parsed_token_text;
4402 166         234 pop @$parsed_token_type;
4403 166         216 pop @$parsed_token_opcode;
4404 166 50       361 if (@$parsed_token_type) {
4405 166         272 $last_token_type =
4406             $parsed_token_type->[ @$parsed_token_type - 1 ];
4407 166         312 $last_token_text =
4408             $parsed_token_text->[ @$parsed_token_text - 1 ];
4409             } else {
4410 0         0 $last_token_type = $char_class_eof;
4411 0         0 $last_token_text = "EOF";
4412             }
4413             }
4414             }
4415             } else {
4416 254         363 $last_token_type = $char_class_eof;
4417 254         446 $last_token_text = "EOF";
4418             }
4419 74759         78165 $t = $token_op;
4420 74759 100 100     396238 if (
    100 100        
      66        
4421             (@$parsed_token_type == 0)
4422             || ( $last_token_type == $char_class_op
4423             && $last_token_text ne ')'
4424             && $last_token_text ne '%')
4425             ) { # Unary operator
4426 6608 100 100     33594 if ($str eq '-') { # M is unary minus
    100          
    100          
    100          
4427 2284         3239 $str = "M";
4428 2284         3743 $c = ord($str);
4429             } elsif ($str eq '+') { # P is unary plus
4430 9         15 $str = "P";
4431 9         15 $c = ord($str);
4432             } elsif ($str eq ')' && $last_token_text eq '(')
4433             { # null arg list OK
4434             ;
4435             } elsif ($str ne '(') { # binary-op open-paren OK, others no
4436 96         167 $t = $token_error;
4437 96         167 $str =
4438             "Error in formula (two operators inappropriately in a row)";
4439             }
4440             } elsif (length $str > 1) {
4441 166 100       775 if ($str eq '>=') { # G is >=
    100          
    50          
4442 23         48 $str = "G";
4443 23         53 $c = ord($str);
4444             } elsif ($str eq '<=') { # L is <=
4445 25         52 $str = "L";
4446 25         49 $c = ord($str);
4447             } elsif ($str eq '<>') { # N is <>
4448 118         200 $str = "N";
4449 118         157 $c = ord($str);
4450             } else {
4451 0         0 $t = $token_error;
4452 0         0 $str =
4453             "Error in formula (two operators inappropriately in a row)";
4454             }
4455             }
4456 74759         133603 push @$parsed_token_text, $str;
4457 74759         95232 push @$parsed_token_type, $t;
4458 74759         106884 push @$parsed_token_opcode, $c;
4459 74759         122157 $state = 0;
4460             } elsif ($cclass == $char_class_quote) { # starting a string
4461 6248         9481 $str = "";
4462 6248         13496 $state = $state_string;
4463             } elsif ($cclass == $char_class_space)
4464             { # store so can reconstruct spacing
4465 4603         9466 push @$parsed_token_text, " ";
4466 4603         7286 push @$parsed_token_type, $token_space;
4467 4603         8638 push @$parsed_token_opcode, 0;
4468             } elsif ($cclass == $char_class_eof) { # ignore
4469             }
4470             }
4471             }
4472              
4473 33477         130205 return \%parseinfo;
4474             }
4475              
4476             =head2 evaluate_parsed_formula
4477              
4478             ($value, $valuetype, $errortext) = evaluate_parsed_formula(\%parseinfo, \%sheetdata, $allowrangereturn)
4479              
4480             Does the calculation expressed in a parsed formula, returning a value,
4481             its type, and error info.
4482              
4483             If $allowrangereturn is present and true, can return a range (e.g., "A1:A10" - translated from "A1|A10|")
4484              
4485             =cut
4486              
4487             sub evaluate_parsed_formula {
4488              
4489 33477     33477 1 46669 my ($parseinfo, $sheetdata, $allowrangereturn) = @_;
4490              
4491 33477         60599 my $parsed_token_text = $parseinfo->{tokentext};
4492 33477         43482 my $parsed_token_type = $parseinfo->{tokentype};
4493 33477         41422 my $parsed_token_opcode = $parseinfo->{tokenopcode};
4494              
4495             # # # # # # #
4496             #
4497             # Convert infix to reverse polish notation
4498             #
4499             # Based upon the algorithm shown in Wikipedia "Reverse Polish notation" article
4500             # and then enhanced for additional spreadsheet things
4501             #
4502             # The @revpolish array ends up with a sequence of references to tokens by number
4503             #
4504              
4505 33477         37616 my @revpolish;
4506             my @parsestack;
4507              
4508 33477         38007 my $function_start = -1;
4509              
4510 33477         35647 my ($ttype, $ttext, $tprecedence, $tstackprecedence, $errortext);
4511              
4512 33477         76618 for (my $i = 0 ; $i < scalar @$parsed_token_text ; $i++) {
4513 160174         181316 $ttype = $parsed_token_type->[$i];
4514 160174         194722 $ttext = $parsed_token_text->[$i];
4515 160174 100 100     1380646 if ( $ttype == $token_num
    100 100        
    100          
    100          
    100          
    100          
    100          
    50          
4516             || $ttype == $token_coord
4517             || $ttype == $token_string) {
4518 62224         151157 push @revpolish, $i;
4519             } elsif ($ttype == $token_name) {
4520 18891         25732 push @parsestack, $i;
4521 18891         51939 push @revpolish, $function_start;
4522             } elsif ($ttype == $token_space) { # ignore
4523 4360         11384 next;
4524             } elsif ($ttext eq ',') {
4525 12867   66     65723 while (@parsestack
4526             && $parsed_token_text->[ $parsestack[ @parsestack - 1 ] ] ne '(') {
4527 2208         10787 push @revpolish, pop @parsestack;
4528             }
4529 12867 50       44002 if (@parsestack == 0) { # no ( -- error
4530 0         0 $errortext = "Missing open parenthesis in list with comma(s).";
4531 0         0 last;
4532             }
4533             } elsif ($ttext eq '(') {
4534 19499         47454 push @parsestack, $i;
4535             } elsif ($ttext eq ')') {
4536 19377   66     95733 while (@parsestack
4537             && $parsed_token_text->[ $parsestack[ @parsestack - 1 ] ] ne '(') {
4538 4448         21754 push @revpolish, pop @parsestack;
4539             }
4540 19377 50       43521 if (@parsestack == 0) { # no ( -- error
4541 0         0 $errortext = "Closing parenthesis without open parenthesis.";
4542 0         0 last;
4543             }
4544 19377         23242 pop @parsestack;
4545 19377 100 100     85816 if ( @parsestack
4546             && $parsed_token_type->[ $parsestack[ @parsestack - 1 ] ] ==
4547             $token_name) {
4548 18470         53454 push @revpolish, pop @parsestack;
4549             }
4550             } elsif ($ttype == $token_op) {
4551 22668 100 100     77792 if ( @parsestack
4552             && $parsed_token_type->[ $parsestack[ @parsestack - 1 ] ] ==
4553             $token_name) {
4554 81         140 push @revpolish, pop @parsestack;
4555             }
4556 22668   66     106173 while (@parsestack
      100        
4557             && $parsed_token_type->[ $parsestack[ @parsestack - 1 ] ] == $token_op
4558             && $parsed_token_text->[ $parsestack[ @parsestack - 1 ] ] ne '(') {
4559 3537         7546 $tprecedence = $token_precedence[ $parsed_token_opcode->[$i] - 32 ];
4560 3537         6532 $tstackprecedence =
4561             $token_precedence[ $parsed_token_opcode
4562             ->[ $parsestack[ @parsestack - 1 ] ] - 32 ];
4563 3537 100 100     16483 if ($tprecedence >= 0 && $tprecedence < $tstackprecedence) {
    100          
4564 570         1021 last;
4565             } elsif ($tprecedence < 0) {
4566 113         210 $tprecedence = -$tprecedence;
4567 113 50       261 $tstackprecedence = -$tstackprecedence if $tstackprecedence < 0;
4568 113 50       286 if ($tprecedence <= $tstackprecedence) {
4569 113         210 last;
4570             }
4571             }
4572 2854         11830 push @revpolish, pop @parsestack;
4573             }
4574 22668         58885 push @parsestack, $i;
4575             } elsif ($ttype == $token_error) {
4576 288         493 $errortext = $ttext;
4577 288         611 last;
4578             } else {
4579 0         0 $errortext = "Internal error while processing parsed formula. ";
4580 0         0 last;
4581             }
4582             }
4583 33477         69435 while (@parsestack) {
4584 13498 100       34146 if ($parsed_token_text->[ $parsestack[ @parsestack - 1 ] ] eq '(') {
4585 122         180 $errortext = "Missing close parenthesis.";
4586 122         183 last;
4587             }
4588 13376         32042 push @revpolish, pop @parsestack;
4589             }
4590              
4591             # # # # # # #
4592             #
4593             # Execute it
4594             #
4595              
4596             # Operand values are hashes with {value} and {type}
4597             # Type can have these values (many are type and sub-type as two or more letters):
4598             # "tw", "th", "t", "n", "nt", "coord", "range", "start", "eErrorType", "b" (blank)
4599             # The value of a coord is in the form A57 or A57!sheetname
4600             # The value of a range is coord|coord|number where number starts at 0 and is
4601             # the offset of the next item to fetch if you are going through the range one by one
4602             # The number starts as a null string ("A1|B3|")
4603             #
4604              
4605 33477         39240 my @operand;
4606              
4607 33477         38459 my ($value1, $value2, $tostype, $tostype2, $resulttype);
4608              
4609 33477         83044 for (my $i = 0 ; $i < scalar @revpolish ; $i++) {
4610 122552 100       232192 if ($revpolish[$i] == $function_start)
4611             { # Remember the start of a function argument list
4612 18891         52569 push @operand, { type => "start" };
4613 18891         50455 next;
4614             }
4615              
4616 103661         128621 $ttype = $parsed_token_type->[ $revpolish[$i] ];
4617 103661         134851 $ttext = $parsed_token_text->[ $revpolish[$i] ];
4618              
4619 103661 100       260842 if ($ttype == $token_num) {
    100          
    100          
    100          
    50          
4620              
4621             # TODO t/date.t gives lots of warnings here. Work out why.
4622 34     34   1449256 no warnings;
  34         134  
  34         182595  
4623 36713         391491 push @operand, { type => "n", value => 0 + $ttext };
4624             }
4625              
4626             elsif ($ttype == $token_coord) {
4627 19263         36616 $ttext =~ s/[^0-9A-Z]//g;
4628 19263         92239 push @operand, { type => "coord", value => $ttext };
4629             }
4630              
4631             elsif ($ttype == $token_string) {
4632 6248         29946 push @operand, { type => "t", value => $ttext };
4633             }
4634              
4635             elsif ($ttype == $token_op) {
4636 22668 50       46490 if (@operand <= 0) { # Nothing on the stack...
4637 0         0 $errortext = "Missing operand. "; # remember error
4638 0         0 push @operand, { type => "n", value => 0 }; # put something there
4639             }
4640              
4641             # Unary minus
4642              
4643 22668 100       130748 if ($ttext eq 'M') {
    100          
    100          
    100          
    100          
    100          
    100          
4644 2284         7842 $value1 =
4645             operand_as_number($sheetdata, \@operand, \$errortext, \$tostype);
4646 2284         7740 $resulttype =
4647             lookup_result_type($tostype, $tostype, $typelookup{unaryminus});
4648 2284         12729 push @operand, { type => $resulttype, value => -$value1 };
4649             }
4650              
4651             # Unary plus
4652              
4653             elsif ($ttext eq 'P') {
4654 9         29 $value1 =
4655             operand_as_number($sheetdata, \@operand, \$errortext, \$tostype);
4656 9         35 $resulttype =
4657             lookup_result_type($tostype, $tostype, $typelookup{unaryplus});
4658 9         57 push @operand, { type => $resulttype, value => $value1 };
4659             }
4660              
4661             # Unary % - percent, left associative
4662              
4663             elsif ($ttext eq '%') {
4664 252         735 $value1 =
4665             operand_as_number($sheetdata, \@operand, \$errortext, \$tostype);
4666 252         798 $resulttype =
4667             lookup_result_type($tostype, $tostype, $typelookup{unarypercent});
4668 252         1405 push @operand, { type => $resulttype, value => 0.01 * $value1 };
4669             }
4670              
4671             # & - string concatenate
4672              
4673             elsif ($ttext eq '&') {
4674 378 50       953 if (@operand == 1) { # Need at least two things on the stack...
4675 0         0 $errortext = "Missing operand. "; # remember error
4676 0         0 push @operand, { type => "t",
4677             value => "" }; # put something there as second operand
4678             }
4679             $value2 =
4680 378         1199 operand_as_text($sheetdata, \@operand, \$errortext, \$tostype2);
4681 378         1012 $value1 =
4682             operand_as_text($sheetdata, \@operand, \$errortext, \$tostype);
4683 378         1309 $resulttype =
4684             lookup_result_type($tostype, $tostype2, $typelookup{concat});
4685 378         2566 push @operand, { type => $resulttype, value => ($value1 . $value2) };
4686             }
4687              
4688             # : - Range constructor
4689              
4690             elsif ($ttext eq ':') {
4691 1283 50       3485 if (@operand == 1) { # Need at least two things on the stack...
4692 0         0 $errortext = "Missing operand. "; # remember error
4693 0         0 push @operand, { type => "n",
4694             value => 0 }; # put something there as second operand
4695             }
4696             $value1 =
4697 1283         5178 operands_as_range_on_sheet($sheetdata, \@operand, \$tostype,
4698             \$errortext); # get coords even if use name on other sheet
4699 1283         7261 push @operand, { type => $tostype,
4700             value => $value1 }; # push sheetname with range on that sheet
4701             }
4702              
4703             # ! - sheetname!coord
4704              
4705             elsif ($ttext eq '!') {
4706 83 50       280 if (@operand == 1) { # Need at least two things on the stack...
4707 0         0 $errortext = "Missing operand. "; # remember error
4708 0         0 push @operand, { type => "e#REF!",
4709             value => 0 }; # put something there as second operand
4710             }
4711             $value1 =
4712 83         317 operands_as_coord_on_sheet($sheetdata, \@operand, \$tostype,
4713             \$errortext); # get coord even if name on other sheet
4714 83         648 push @operand,
4715             { type => $tostype, value =>
4716             $value1 }; # push sheetname with coord or range on that sheet
4717             }
4718              
4719             # Comparison operators: < L = G > N (< <= = >= > <>)
4720              
4721             elsif ($ttext =~ m/[N]/) {
4722 2718 50       7104 if (@operand == 1) { # Need at least two things on the stack...
4723 0         0 $errortext = "Missing operand. "; # remember error
4724 0         0 push @operand, { type => "n",
4725             value => 0 }; # put something there as second operand
4726             }
4727             $value2 =
4728 2718         7859 operand_value_and_type($sheetdata, \@operand, \$errortext,
4729             \$tostype2);
4730 2718         7526 $value1 =
4731             operand_value_and_type($sheetdata, \@operand, \$errortext,
4732             \$tostype);
4733 2718 100 100     18006 if (substr($tostype, 0, 1) eq "n" && substr($tostype2, 0, 1) eq "n")
    100          
    50          
4734             { # compare two numbers
4735 2346         3164 my $cond = 0;
4736 2346 50       10722 if ($ttext eq "<") { $cond = $value1 < $value2 ? 1 : 0; }
  102 100       411  
    100          
    100          
    100          
    100          
    50          
4737 25 50       85 elsif ($ttext eq "L") { $cond = $value1 <= $value2 ? 1 : 0; }
4738 1987 100       4493 elsif ($ttext eq "=") { $cond = $value1 == $value2 ? 1 : 0; }
4739 23 50       62 elsif ($ttext eq "G") { $cond = $value1 >= $value2 ? 1 : 0; }
4740 148 100       514 elsif ($ttext eq ">") { $cond = $value1 > $value2 ? 1 : 0; }
4741 61 100       182 elsif ($ttext eq "N") { $cond = $value1 != $value2 ? 1 : 0; }
4742 2346         12252 push @operand, { type => "nl", value => $cond };
4743             } elsif (substr($tostype, 0, 1) eq "e") { # error on left
4744 146         859 push @operand, { type => $tostype, value => 0 };
4745             } elsif (substr($tostype2, 0, 1) eq "e") { # error on right
4746 0         0 push @operand, { type => $tostype2, value => 0 };
4747             } else { # text maybe mixed with numbers or blank
4748 226 100       625 if (substr($tostype, 0, 1) eq "n") {
4749 29         124 $value1 = format_number_for_display($value1, "n", "");
4750             }
4751 226 100       566 if (substr($tostype2, 0, 1) eq "n") {
4752 34         139 $value2 = format_number_for_display($value2, "n", "");
4753             }
4754 226         293 my $cond = 0;
4755 226         329 my $value1u8 = $value1;
4756 226         285 my $value2u8 = $value2;
4757 226         782 utf8::decode($value1u8); # handle UTF-8
4758 226         394 utf8::decode($value2u8);
4759 226         364 $value1u8 = lc $value1u8; # ignore case
4760 226         5964 $value2u8 = lc $value2u8;
4761 226 50       1049 if ($ttext eq "<") { $cond = $value1u8 lt $value2u8 ? 1 : 0; }
  43 100       170  
    50          
    100          
    50          
    100          
    50          
4762 0 0       0 elsif ($ttext eq "L") { $cond = $value1u8 le $value2u8 ? 1 : 0; }
4763 106 100       211 elsif ($ttext eq "=") { $cond = $value1u8 eq $value2u8 ? 1 : 0; }
4764 0 0       0 elsif ($ttext eq "G") { $cond = $value1u8 ge $value2u8 ? 1 : 0; }
4765 20 50       59 elsif ($ttext eq ">") { $cond = $value1u8 gt $value2u8 ? 1 : 0; }
4766 57 50       148 elsif ($ttext eq "N") { $cond = $value1u8 ne $value2u8 ? 1 : 0; }
4767 226         1167 push @operand, { type => "nl", value => $cond };
4768             }
4769             }
4770              
4771             # Normal infix arithmethic operators: +, -. *, /, ^
4772              
4773             else { # what's left are the normal infix arithmetic operators
4774 15661 100       32997 if (@operand == 1) { # Need at least two things on the stack...
4775 231         601 $errortext = "Missing operand. "; # remember error
4776 231         771 push @operand, { type => "n",
4777             value => 0 }; # put something there as second operand
4778             }
4779             $value2 =
4780 15661         39148 operand_as_number($sheetdata, \@operand, \$errortext, \$tostype2);
4781 15661         38845 $value1 =
4782             operand_as_number($sheetdata, \@operand, \$errortext, \$tostype);
4783 15661 100       55095 if ($ttext eq '+') {
    100          
    100          
    100          
    50          
4784 2397         6149 $resulttype =
4785             lookup_result_type($tostype, $tostype2, $typelookup{plus});
4786 2397         13551 push @operand, { type => $resulttype, value => $value1 + $value2 };
4787             } elsif ($ttext eq '-') {
4788 760         2483 $resulttype =
4789             lookup_result_type($tostype, $tostype2, $typelookup{plus});
4790 760         4537 push @operand, { type => $resulttype, value => $value1 - $value2 };
4791             } elsif ($ttext eq '*') {
4792 8831         23436 $resulttype =
4793             lookup_result_type($tostype, $tostype2, $typelookup{plus});
4794 8831         47963 push @operand, { type => $resulttype, value => $value1 * $value2 };
4795             } elsif ($ttext eq '/') {
4796 2961 100       6397 if ($value2 != 0) {
4797 2044         11872 push @operand, { type => "n",
4798             value => $value1 / $value2 }; # gives plain numeric result type
4799             } else {
4800 917         4563 push @operand, { type => "e#DIV/0!", value => 0 };
4801             }
4802             } elsif ($ttext eq '^') {
4803 712         4219 push @operand, { type => "n",
4804             value => $value1**$value2 }; # gives plain numeric result type
4805             }
4806             }
4807             }
4808              
4809             # function or name
4810              
4811             elsif ($ttype == $token_name) {
4812              
4813             # TODO fix cyclic dependency
4814 18769         146744 require Spreadsheet::Engine::Functions;
4815 18769         82602 Spreadsheet::Engine::Functions::calculate_function($ttext, \@operand,
4816             \$errortext, \%typelookup, $sheetdata);
4817             }
4818              
4819             else {
4820 0         0 $errortext = "Unknown token $ttype ($ttext). ";
4821             }
4822             }
4823              
4824             # look at final value and handle special cases
4825              
4826 33477         64751 my $value = $operand[0]->{value};
4827 33477         34189 my $valuetype;
4828 33477   50     83746 $tostype = $operand[0]->{type} || '';
4829              
4830 33477 100       75365 if ($tostype eq "name") { # name - expand it
4831 1         3 $value = lc $value;
4832 1         5 $value = lookup_name($sheetdata, $value, \$tostype, \$errortext);
4833             }
4834              
4835 33477 100       62214 if ($tostype eq "coord")
4836             { # the value is a coord reference, get its value and type
4837 6975         17588 $value =
4838             operand_value_and_type($sheetdata, \@operand, \$errortext, \$tostype);
4839 6975 50       17408 $tostype = "n" if ($tostype eq "b");
4840             }
4841              
4842 33477 100       65888 if (scalar @operand > 1) { # something left - error
4843 34         91 $errortext .= "Error in formula.";
4844             }
4845              
4846             # set return type
4847              
4848 33477         47996 $valuetype = $tostype;
4849              
4850 33477 100       122307 if (substr($tostype, 0, 1) eq "e") { # error value
    50          
4851 1945   50     11999 $errortext ||= substr($tostype, 1) || "Error value in formula";
      66        
4852             } elsif ($tostype eq "range") {
4853 0         0 $value =~ m/^(.*)\|(.*)\|/;
4854 0         0 $value = uc "$1:$2";
4855 0 0       0 if (!$allowrangereturn) {
4856 0         0 $errortext = "Formula results in range value: $value.";
4857             }
4858             }
4859              
4860 33477 100 100     78604 if ($errortext && substr($valuetype, 0, 1) ne "e") {
4861 299         452 $value = $errortext;
4862 299         414 $valuetype = "e";
4863             }
4864              
4865             # look for overflow
4866              
4867 33477 50 66     199618 if (substr($tostype, 0, 1) eq "n" && defined $value && $value =~ m/1\.#INF/)
      66        
4868             {
4869 0         0 $value = 0;
4870 0         0 $valuetype = "e#NUM!";
4871 0         0 $errortext = "Numeric overflow";
4872             }
4873 33477         177975 return ($value, $valuetype, $errortext);
4874             }
4875              
4876             =head2 operand_as_coord
4877              
4878             $value = operand_as_coord(\%sheetdata, \@operand, \$errortext)
4879              
4880             Gets top of stack and pops it. Returns coord value. All others are
4881             treated as an error.
4882              
4883             =cut
4884              
4885             sub operand_as_coord {
4886              
4887 1283     1283 1 2082 my ($sheetdata, $operand, $errortext) = @_;
4888              
4889 1283         3811 my $stacklen = scalar @$operand;
4890 1283         2951 my $value = $operand->[ $stacklen - 1 ]->{value}; # get top of stack
4891 1283         2426 my $tostype = $operand->[ $stacklen - 1 ]->{type};
4892 1283         1678 pop @$operand; # we have data - pop stack
4893              
4894 1283 50       4049 if ($tostype eq "name") {
4895 0         0 $value = uc $value;
4896 0         0 $value = lookup_name($sheetdata, $value, \$tostype, $errortext);
4897             }
4898              
4899 1283 100       2773 if ($tostype eq "coord") { # value is a coord reference
4900 1234         4339 return $value;
4901             } else {
4902 49         106 $$errortext = "Cell reference missing when expected.";
4903 49         128 return 0;
4904             }
4905             }
4906              
4907             =head2 operands_as_coord_on_sheet
4908              
4909             $value = operands_as_coord_on_sheet(\%sheetdata, \@operand, \$returntype, \$errortext)
4910              
4911             Gets 2 at top of stack and pops them, treating them as sheetname!coord-or-name.
4912             Returns stack-style coord value (coord!sheetname, or coord!sheetname|coord|) and
4913             sets $returntype to coord or range. All others are treated as an error.
4914              
4915             =cut
4916              
4917             sub operands_as_coord_on_sheet {
4918              
4919 83     83 1 152 my ($sheetdata, $operand, $returntype, $errortext) = @_;
4920              
4921 83         167 my $stacklen = scalar @$operand;
4922 83         209 my $value =
4923             $operand->[ $stacklen - 1 ]->{value}; # get top of stack - coord or name
4924 83         176 my $tostype = $operand->[ $stacklen - 1 ]->{type};
4925 83         124 pop @$operand; # we have data - pop stack
4926              
4927 83         309 my $sheetname =
4928             operand_as_sheetname($sheetdata, $operand, $errortext)
4929             ; # get sheetname as text
4930 83         305 my $othersheetdata = find_in_sheet_cache($sheetdata, $sheetname);
4931 83 50       227 if ($othersheetdata->{loaderror}) { # this sheet is unavailable
4932 83         121 $$errortext = "Cell reference missing when expected.";
4933 83         125 $$returntype = "e#REF!";
4934 83         569 return "";
4935             }
4936              
4937 0 0       0 if ($tostype eq "name") {
4938 0         0 $value = uc $value;
4939 0         0 $value = lookup_name($othersheetdata, $value, \$tostype, $errortext);
4940             }
4941 0         0 $$returntype = $tostype;
4942 0 0       0 if ($tostype eq "coord") { # value is a coord reference
    0          
4943 0         0 return "$value!$sheetname"; # return in the format as used on stack
4944             } elsif ($tostype eq "range") { # value is a range reference
4945 0         0 my ($c1, $c2, $c3) = split (/\|/, $value, 3);
4946 0         0 return "$c1!$sheetname|$c2|";
4947             } else {
4948 0         0 $$errortext = "Cell reference missing when expected.";
4949 0         0 $$returntype = "e#REF!";
4950 0         0 return "";
4951             }
4952             }
4953              
4954             =head2 operands_as_range_on_sheet
4955              
4956             $value = operands_as_range_on_sheet(\%sheetdata, \@operand, \$returntype, \$errortext)
4957              
4958             Gets 2 at top of stack and pops them, treating them as
4959             coord2-or-name:coord1. Name is evaluated on sheet of coord1.
4960             Returns stack-style range value (coord!sheetname|coord|) and sets
4961             $returntype to range. All others are treated as an error.
4962              
4963             =cut
4964              
4965             sub operands_as_range_on_sheet {
4966              
4967 1283     1283 1 2418 my ($sheetdata, $operand, $returntype, $errortext) = @_;
4968              
4969 1283         1992 my $stacklen = scalar @$operand;
4970 1283         3111 my $value2 =
4971             $operand->[ $stacklen - 1 ]
4972             ->{value}; # get top of stack - coord or name for "right" side
4973 1283         2327 my $tostype = $operand->[ $stacklen - 1 ]->{type};
4974 1283         1813 pop @$operand; # we have data - pop stack
4975              
4976 1283         4790 my $value1 =
4977             operand_as_coord($sheetdata, $operand, $errortext); # get "left" coord
4978 1283 100       3285 if (!$value1) { # not a coord, which it must be
4979 49         76 $$returntype = "e#REF!";
4980 49         125 return "";
4981             }
4982              
4983 1234         2246 my $othersheetdata = $sheetdata;
4984              
4985 1234 50       3884 if ($value1 =~ m/^.*!([^\|]+)$/) { #
4986 0         0 $othersheetdata = find_in_sheet_cache($sheetdata, $1);
4987 0 0       0 if ($othersheetdata->{loaderror}) { # this sheet is unavailable
4988 0         0 $$errortext = "Cell reference missing when expected.";
4989 0         0 $$returntype = "e#REF!";
4990 0         0 return "";
4991             }
4992             }
4993              
4994 1234 50       2964 if ($tostype eq "name") { # coord:name is allowed, if name is just one cell
4995 0         0 $value2 = uc $value2;
4996 0         0 $value2 = lookup_name($othersheetdata, $value2, \$tostype, $errortext);
4997             }
4998 1234 100       2720 if ($tostype eq "coord")
4999             { # value is a coord reference, so return the combined range
5000 1223         1955 $$returntype = "range";
5001 1223         4292 return "$value1|$value2|"; # return in the format as used on stack
5002             } else { # bad form
5003 11         20 $$errortext = "Cell reference missing when expected.";
5004 11         19 $$returntype = "e#REF!";
5005 11         27 return "";
5006             }
5007             }
5008              
5009             =head2 operand_as_sheetname
5010              
5011             $value = operand_as_sheetname(\%sheetdata, \@operand, \$errortext)
5012              
5013             Gets top of stack and pops it.
5014             Returns sheetname value. All others are treated as an error.
5015             Accepts text, cell reference, and named value which is one of those two.
5016              
5017             =cut
5018              
5019             sub operand_as_sheetname {
5020              
5021 83     83 1 130 my ($sheetdata, $operand, $errortext) = @_;
5022              
5023 83         145 my $stacklen = scalar @$operand;
5024 83         180 my $value = $operand->[ $stacklen - 1 ]->{value}; # get top of stack
5025 83         157 my $tostype = $operand->[ $stacklen - 1 ]->{type};
5026 83         105 pop @$operand; # we have data - pop stack
5027 83 100       252 if ($tostype eq "name") { # either a named cell or a sheet name bare
5028 17         30 my $ignoreerror;
5029 17         46 my $lookupname =
5030             lookup_name($sheetdata, $value, \$tostype, \$ignoreerror);
5031 17 50       45 if (!$lookupname)
5032             { # not a known name - return bare name as the name value
5033 17         55 return $value;
5034             }
5035 0         0 $value = $lookupname; # try this value and type
5036             }
5037 66 100       231 if ($tostype eq "coord")
5038             { # value is a coord reference, follow it to find sheet name
5039 21         262 my $cellvtype =
5040             $sheetdata->{valuetypes}
5041             ->{$value}; # get type of value in the cell it points to
5042 21         66 $value = $sheetdata->{datavalues}->{$value};
5043 21   50     60 $tostype = $cellvtype || "b";
5044             }
5045 66 50       220 if (substr($tostype, 0, 1) eq "t")
5046             { # value is a string which could be a sheet name
5047 0         0 return $value;
5048             } else {
5049 66         118 $$errortext = "Sheet name missing when expected.";
5050 66         192 return "";
5051             }
5052             }
5053              
5054             =head2 lookup_name
5055              
5056             $value = lookup_name(\%sheetdata, $name, \$valuetype, \$errortext)
5057              
5058             Returns value and type of a named value.
5059             Names are case insensitive.
5060             Names may have a definition which is a coord (A1), a range (A1:B7), or a formula (=OFFSET(A1,0,0,5,1))
5061              
5062             =cut
5063              
5064             sub lookup_name {
5065              
5066 19127     19127 1 32462 my ($sheetdata, $name, $valuetype, $errortext) = @_;
5067              
5068 19127         38579 my $names = $sheetdata->{names};
5069              
5070 19127 100       44608 if (defined $names->{ uc $name }) { # is name defined?
5071              
5072 399         872 my $value = $names->{ uc $name }->{definition}; # yes
5073              
5074 399 50       1090 if (substr($value, 0, 1) eq "=") { # formula
5075 0         0 my $startedwalk;
5076 0 0       0 if (!$sheetdata->{checknamecirc})
5077             { # are we possibly walking the name tree?
5078 0         0 $sheetdata->{checknamecirc} = {}; # not yet
5079 0         0 $startedwalk = 1; # remember we started it
5080             } else {
5081 0 0       0 if ($sheetdata->{checknamecirc}->{$name}) { # circular reference
5082 0         0 $$valuetype = "e#NAME?";
5083 0         0 $$errortext = qq!Circular name reference to name "$name".!;
5084 0         0 return "";
5085             }
5086             }
5087 0         0 $sheetdata->{checknamecirc}->{$name} = 1;
5088              
5089 0         0 my $parseinfo = parse_formula_into_tokens(substr($value, 1));
5090 0         0 ($value, $$valuetype, $$errortext) =
5091             evaluate_parsed_formula($parseinfo, $sheetdata, 1)
5092             ; # parse formula, allowing range return
5093              
5094 0         0 delete $sheetdata->{checknamecirc}->{$name}; # done with us
5095 0 0       0 delete $sheetdata->{checknamecirc} if $startedwalk; # done with walk
5096              
5097 0 0       0 if ($$valuetype ne "range") {
5098 0         0 return $value;
5099             }
5100             }
5101              
5102 399 100       1911 if ($value =~ m/^(.*)\:(.*)$/) { # range
5103 396         548 $$valuetype = "range";
5104 396         1444 $value = uc "$1|$2|";
5105             } else {
5106 3         5 $$valuetype = "coord";
5107 3         4 $value = uc $value;
5108             }
5109 399         971 return $value;
5110             } else {
5111 18728         25866 $$valuetype = "e#NAME?";
5112 18728         35276 $$errortext = qq!Unknown name "$name".!;
5113 18728         42882 return "";
5114             }
5115             }
5116              
5117             =head2 step_through_range_up
5118              
5119             $value = step_through_range_up(\@operand, $rangevalue, \$operandtype)
5120              
5121             Returns next coord in a range, keeping track on the operand stack.
5122             Goes from bottom right across and up to upper left.
5123              
5124             =cut
5125              
5126             sub step_through_range_up {
5127              
5128 0     0 1 0 my ($operand, $value, $operandtype) = @_;
5129              
5130 0         0 my ($value1, $value2, $sequence) = split (/\|/, $value);
5131 0         0 my ($sheet1, $sheet2);
5132 0         0 ($value1, $sheet1) = split (/!/, $value1);
5133 0 0       0 $sheet1 = "!$sheet1" if $sheet1;
5134 0         0 ($value2, $sheet2) = split (/!/, $value2);
5135 0         0 my ($c1, $r1) = coord_to_cr($value1);
5136 0         0 my ($c2, $r2) = coord_to_cr($value2);
5137 0 0       0 ($c2, $c1) = ($c1, $c2) if ($c1 > $c2);
5138 0 0       0 ($r2, $r1) = ($r1, $r2) if ($r1 > $r2);
5139 0         0 my $count;
5140 0 0       0 $sequence = ($r2 - $r1 + 1) * ($c2 - $c1 + 1) - 1
5141             if length($sequence) == 0; # start at the end
5142              
5143 0         0 for (my $r = $r1 ; $r <= $r2 ; $r++) {
5144 0         0 for (my $c = $c1 ; $c <= $c2 ; $c++) {
5145 0         0 $count++;
5146 0 0       0 if ($count > $sequence) {
5147 0         0 $sequence--;
5148 0 0       0 push @$operand,
5149             { type => "range", value => "$value1$sheet1|$value2|$sequence" }
5150             unless $sequence < 0;
5151 0         0 $$operandtype = "coord";
5152 0         0 return cr_to_coord($c, $r) . $sheet1;
5153             }
5154             }
5155             }
5156             }
5157              
5158             =head2 step_through_range_down
5159              
5160             $value = step_through_range_down(\@operand, $rangevalue, \$operandtype)
5161              
5162             Returns next coord in a range, keeping track on the operand stack.
5163             Goes from upper left across and down to bottom right.
5164              
5165             =cut
5166              
5167             sub step_through_range_down {
5168              
5169 3165     3165 1 5005 my ($operand, $value, $operandtype) = @_;
5170              
5171 3165         11729 my ($v1, $v2, $sequence) = split (/\|/, $value);
5172 3165   100     8871 $sequence ||= 0;
5173              
5174 3165         6854 my ($value1, $sheet1) = split (/!/, $v1);
5175 3165   33     15891 ($sheet1 &&= "!$sheet1") ||= '';
      50        
5176 3165         6734 my ($value2, $sheet2) = split (/!/, $v2);
5177              
5178 3165         7053 my ($c1, $r1) = coord_to_cr($value1);
5179 3165         6584 my ($c2, $r2) = coord_to_cr($value2);
5180 3165 50       8706 ($c2, $c1) = ($c1, $c2) if ($c1 > $c2);
5181 3165 50       12588 ($r2, $r1) = ($r1, $r2) if ($r1 > $r2);
5182              
5183 3165         3766 my $count = 0;
5184 3165         10138 for (my $r = $r1 ; $r <= $r2 ; $r++) {
5185 8627         18724 for (my $c = $c1 ; $c <= $c2 ; $c++) {
5186 8627         8721 $count++;
5187 8627 100       1053847 if ($count > $sequence) {
5188 3165 100 66     18314 push @$operand,
5189             { type => "range", value => "$value1$sheet1|$value2|$count" }
5190             unless ($r == $r2 && $c == $c2);
5191 3165         5169 $$operandtype = "coord";
5192 3165         6670 return cr_to_coord($c, $r) . $sheet1;
5193             }
5194             }
5195             }
5196             }
5197              
5198             =head2 col_to_number
5199              
5200             $col = col_to_number($colname)
5201              
5202             Turns B into 2. The default is 1.
5203              
5204             =cut
5205              
5206             sub col_to_number {
5207 0     0 1 0 my $coord = shift @_;
5208 0         0 $coord = lc($coord);
5209 0         0 $coord =~ m/([a-z])([a-z])?/;
5210 0 0       0 return 1 unless $1;
5211 0         0 my $col = ord($1) - ord('a') + 1;
5212 0 0       0 $col = 26 * $col + ord($2) - ord('a') + 1 if $2;
5213 0         0 return $col;
5214             }
5215              
5216             =head2 number_to_col
5217              
5218             $coord = number_to_col($col)
5219              
5220             Turns 2 into B. The default is 1.
5221              
5222             =cut
5223              
5224             sub number_to_col {
5225 0     0 1 0 my $col = shift @_;
5226 0 0       0 $col = $col > 1 ? $col : 1;
5227 0         0 my $col_high = int(($col - 1) / 26);
5228 0         0 my $col_low = ($col - 1) % 26;
5229 0         0 my $coord = chr(ord('A') + $col_low);
5230 0 0       0 $coord = chr(ord('A') + $col_high - 1) . $coord if $col_high;
5231 0         0 return $coord;
5232             }
5233              
5234             =head2 special_chars_markup
5235              
5236             my $estring = special_chars_markup($string)
5237              
5238             Returns $estring where &, <, >, " are HTML escaped ready for expand markup
5239              
5240             =cut
5241              
5242             sub special_chars_markup {
5243 0     0 1 0 my $string = shift @_;
5244 0         0 $string =~ s/&/{{amp}}amp;/g;
5245 0         0 $string =~ s/
5246 0         0 $string =~ s/>/{{amp}}gt;/g;
5247 0         0 $string =~ s/"/{{amp}}quot;/g;
5248 0         0 return $string;
5249             }
5250              
5251             =head2 url_encode
5252              
5253             my $estring = url_encode($string)
5254              
5255             Returns $estring with special chars URL encoded.
5256              
5257             Based on Mastering Regular Expressions, Jeffrey E. F. Friedl,
5258             additional legal characters added
5259              
5260             =cut
5261              
5262             sub url_encode {
5263 0     0 1 0 my $string = shift @_;
5264 0         0 $string =~ s!([^a-zA-Z0-9_\-;/?:@=#.])!sprintf('%%%02X', ord($1))!ge;
  0         0  
5265 0         0 $string =~
5266             s/%26/{{amp}}/gs; # let ampersands in URLs through -- convert to {{amp}}
5267 0         0 return $string;
5268             }
5269              
5270             =head2 url_encode_plain
5271              
5272             my $estring = url_encode_plain($string)
5273              
5274             Returns $estring with special chars URL encoded for sending to others by
5275             HTTP, not publishing.
5276              
5277             Based on Mastering Regular Expressions, Jeffrey E. F. Friedl, additional
5278             legal characters added.
5279              
5280             =cut
5281              
5282             sub url_encode_plain {
5283 0     0 1 0 my $string = shift @_;
5284 0         0 $string =~ s!([^a-zA-Z0-9_\-/?:@=#.])!sprintf('%%%02X', ord($1))!ge;
  0         0  
5285 0         0 return $string;
5286             }
5287              
5288             =head2 find_in_sheet_cache
5289              
5290             my $othersheet_sheetdata = find_in_sheet_cache(\%sheetdata, $datafilename)
5291              
5292             Load additional sheet's information for worksheet references as a sheetdata structure
5293             stored in $sheetdata->{sheetcache}->{sheets}->{$datafilename} if necessary.
5294             Return that structure as \%othersheet_sheetdata
5295              
5296             =cut
5297              
5298             sub find_in_sheet_cache {
5299              
5300             # TODO have a way for applications to specify how this should work
5301              
5302 83     83 1 138 my ($sheetdata, $datafilename) = @_;
5303              
5304 83         194 my $sdsc = $sheetdata->{sheetcache};
5305              
5306 83 50       249 if ($datafilename !~ m/^http:/i) { # not URL
5307 83         162 $datafilename = lc $datafilename; # lower case for consistency
5308             }
5309              
5310 83 50       321 if ($sdsc->{sheets}->{$datafilename}) { # already in cache
5311 0         0 return $sdsc->{sheets}->{$datafilename};
5312             }
5313              
5314 83         112 my (@headerlines, @sheetlines, $loaderror);
5315              
5316 83         122 $loaderror = "Cross-sheet references are not yet supported";
5317              
5318             # assume local pagename
5319             # my $editpath = get_page_published_datafile_path($sdsc->{params}, $sdsc->{hostinfo}, $sdsc->{sitename}, $datafilename);
5320             # $loaderror = load_page($editpath, \@headerlines, \@sheetlines);
5321              
5322 83         232 $sdsc->{sheets}->{$datafilename} = {}; # start fresh
5323 83         333 my $ok = parse_sheet_save(\@sheetlines, $sdsc->{sheets}->{$datafilename});
5324              
5325 83 50       372 $sdsc->{sheets}->{$datafilename}->{loaderror} = $loaderror if $loaderror;
5326              
5327 83         339 return $sdsc->{sheets}->{$datafilename};
5328              
5329             }
5330              
5331             1;
5332              
5333             __END__