File Coverage

blib/lib/Spreadsheet/WriteExcel/Worksheet.pm
Criterion Covered Total %
statement 1937 2868 67.5
branch 474 908 52.2
condition 127 288 44.1
subroutine 122 185 65.9
pod 0 72 0.0
total 2660 4321 61.5


line stmt bran cond sub pod time code
1             package Spreadsheet::WriteExcel::Worksheet;
2              
3             ###############################################################################
4             #
5             # Worksheet - A writer class for Excel Worksheets.
6             #
7             #
8             # Used in conjunction with Spreadsheet::WriteExcel
9             #
10             # Copyright 2000-2010, John McNamara, jmcnamara@cpan.org
11             #
12             # Documentation after __END__
13             #
14              
15 32     32   214 use Exporter;
  32         69  
  32         1557  
16 32     32   233 use strict;
  32         62  
  32         1356  
17 32     32   202 use Carp;
  32         64  
  32         2206  
18 32     32   1647 use Spreadsheet::WriteExcel::BIFFwriter;
  32         65  
  32         1467  
19 32     32   38585 use Spreadsheet::WriteExcel::Format;
  32         98  
  32         2664  
20 32     32   30937 use Spreadsheet::WriteExcel::Formula;
  32         112  
  32         2198  
21              
22              
23              
24 32     32   336 use vars qw($VERSION @ISA);
  32         67  
  32         290446  
25             @ISA = qw(Spreadsheet::WriteExcel::BIFFwriter);
26              
27             $VERSION = '2.40';
28              
29             ###############################################################################
30             #
31             # new()
32             #
33             # Constructor. Creates a new Worksheet object from a BIFFwriter object
34             #
35             sub new {
36              
37 143     143 0 272 my $class = shift;
38 143         1213 my $self = Spreadsheet::WriteExcel::BIFFwriter->new();
39 143         303 my $rowmax = 65536;
40 143         234 my $colmax = 256;
41 143         235 my $strmax = 0;
42              
43 143         392 $self->{_name} = $_[0];
44 143         352 $self->{_index} = $_[1];
45 143         464 $self->{_encoding} = $_[2];
46 143         322 $self->{_activesheet} = $_[3];
47 143         296 $self->{_firstsheet} = $_[4];
48 143         296 $self->{_url_format} = $_[5];
49 143         280 $self->{_parser} = $_[6];
50 143         299 $self->{_tempdir} = $_[7];
51              
52 143         387 $self->{_str_total} = $_[8];
53 143         271 $self->{_str_unique} = $_[9];
54 143         1351 $self->{_str_table} = $_[10];
55 143         288 $self->{_1904} = $_[11];
56 143         287 $self->{_compatibility} = $_[12];
57 143         325 $self->{_palette} = $_[13];
58              
59 143         613 $self->{_sheet_type} = 0x0000;
60 143         492 $self->{_ext_sheets} = [];
61 143         332 $self->{_using_tmpfile} = 1;
62 143         366 $self->{_filehandle} = "";
63 143         269 $self->{_fileclosed} = 0;
64 143         241 $self->{_offset} = 0;
65 143         255 $self->{_xls_rowmax} = $rowmax;
66 143         282 $self->{_xls_colmax} = $colmax;
67 143         240 $self->{_xls_strmax} = $strmax;
68 143         266 $self->{_dim_rowmin} = undef;
69 143         283 $self->{_dim_rowmax} = undef;
70 143         2575 $self->{_dim_colmin} = undef;
71 143         620 $self->{_dim_colmax} = undef;
72 143         344 $self->{_colinfo} = [];
73 143         449 $self->{_selection} = [0, 0];
74 143         344 $self->{_panes} = [];
75 143         367 $self->{_active_pane} = 3;
76 143         283 $self->{_frozen} = 0;
77 143         262 $self->{_frozen_no_split} = 1;
78 143         303 $self->{_selected} = 0;
79 143         246 $self->{_hidden} = 0;
80 143         264 $self->{_active} = 0;
81 143         279 $self->{_tab_color} = 0;
82              
83 143         238 $self->{_first_row} = 0;
84 143         368 $self->{_first_col} = 0;
85 143         246 $self->{_display_formulas} = 0;
86 143         237 $self->{_display_headers} = 1;
87 143         279 $self->{_display_zeros} = 1;
88 143         264 $self->{_display_arabic} = 0;
89              
90 143         264 $self->{_paper_size} = 0x0;
91 143         282 $self->{_orientation} = 0x1;
92 143         295 $self->{_header} = '';
93 143         252 $self->{_footer} = '';
94 143         318 $self->{_header_encoding} = 0;
95 143         278 $self->{_footer_encoding} = 0;
96 143         236 $self->{_hcenter} = 0;
97 143         361 $self->{_vcenter} = 0;
98 143         279 $self->{_margin_header} = 0.50;
99 143         350 $self->{_margin_footer} = 0.50;
100 143         287 $self->{_margin_left} = 0.75;
101 143         265 $self->{_margin_right} = 0.75;
102 143         254 $self->{_margin_top} = 1.00;
103 143         254 $self->{_margin_bottom} = 1.00;
104              
105 143         274 $self->{_title_rowmin} = undef;
106 143         1352 $self->{_title_rowmax} = undef;
107 143         294 $self->{_title_colmin} = undef;
108 143         270 $self->{_title_colmax} = undef;
109 143         237 $self->{_print_rowmin} = undef;
110 143         235 $self->{_print_rowmax} = undef;
111 143         233 $self->{_print_colmin} = undef;
112 143         252 $self->{_print_colmax} = undef;
113              
114 143         262 $self->{_print_gridlines} = 1;
115 143         270 $self->{_screen_gridlines} = 1;
116 143         242 $self->{_print_headers} = 0;
117              
118 143         227 $self->{_page_order} = 0;
119 143         253 $self->{_black_white} = 0;
120 143         242 $self->{_draft_quality} = 0;
121 143         264 $self->{_print_comments} = 0;
122 143         245 $self->{_page_start} = 1;
123 143         320 $self->{_custom_start} = 0;
124              
125 143         239 $self->{_fit_page} = 0;
126 143         236 $self->{_fit_width} = 0;
127 143         255 $self->{_fit_height} = 0;
128              
129 143         314 $self->{_hbreaks} = [];
130 143         318 $self->{_vbreaks} = [];
131              
132 143         249 $self->{_protect} = 0;
133 143         269 $self->{_password} = undef;
134              
135 143         308 $self->{_col_sizes} = {};
136 143         305 $self->{_row_sizes} = {};
137              
138 143         303 $self->{_col_formats} = {};
139 143         298 $self->{_row_formats} = {};
140              
141 143         277 $self->{_zoom} = 100;
142 143         319 $self->{_print_scale} = 100;
143 143         300 $self->{_page_view} = 0;
144              
145 143         270 $self->{_leading_zeros} = 0;
146              
147 143         283 $self->{_outline_row_level} = 0;
148 143         247 $self->{_outline_style} = 0;
149 143         269 $self->{_outline_below} = 1;
150 143         264 $self->{_outline_right} = 1;
151 143         239 $self->{_outline_on} = 1;
152              
153 143         315 $self->{_write_match} = [];
154              
155 143         351 $self->{_object_ids} = [];
156 143         300 $self->{_images} = {};
157 143         398 $self->{_images_array} = [];
158 143         302 $self->{_charts} = {};
159 143         307 $self->{_charts_array} = [];
160 143         288 $self->{_comments} = {};
161 143         331 $self->{_comments_array} = [];
162 143         288 $self->{_comments_author} = '';
163 143         257 $self->{_comments_author_enc} = 0;
164 143         273 $self->{_comments_visible} = 0;
165              
166 143         335 $self->{_filter_area} = [];
167 143         273 $self->{_filter_count} = 0;
168 143         265 $self->{_filter_on} = 0;
169              
170 143         250 $self->{_writing_url} = 0;
171              
172 143         288 $self->{_db_indices} = [];
173              
174 143         280 $self->{_validations} = [];
175              
176 143         406 bless $self, $class;
177 143         473 $self->_initialize();
178 143         540 return $self;
179             }
180              
181              
182             ###############################################################################
183             #
184             # _initialize()
185             #
186             # Open a tmp file to store the majority of the Worksheet data. If this fails,
187             # for example due to write permissions, store the data in memory. This can be
188             # slow for large files.
189             #
190             sub _initialize {
191              
192 143     143   236 my $self = shift;
193 143         216 my $fh;
194             my $tmp_dir;
195              
196             # The following code is complicated by Windows limitations. Porters can
197             # choose a more direct method.
198              
199              
200              
201             # In the default case we use IO::File->new_tmpfile(). This may fail, in
202             # particular with IIS on Windows, so we allow the user to specify a temp
203             # directory via File::Temp.
204             #
205 143 50       671 if (defined $self->{_tempdir}) {
206              
207             # Delay loading File:Temp to reduce the module dependencies.
208 0         0 eval { require File::Temp };
  0         0  
209 0 0       0 die "The File::Temp module must be installed in order ".
210             "to call set_tempdir().\n" if $@;
211              
212              
213             # Trap but ignore File::Temp errors.
214 0         0 eval { $fh = File::Temp::tempfile(DIR => $self->{_tempdir}) };
  0         0  
215              
216             # Store the failed tmp dir in case of errors.
217 0 0 0     0 $tmp_dir = $self->{_tempdir} || File::Spec->tmpdir if not $fh;
218             }
219             else {
220              
221 143         25853 $fh = IO::File->new_tmpfile();
222              
223             # Store the failed tmp dir in case of errors.
224 143 50       657 $tmp_dir = "POSIX::tmpnam() directory" if not $fh;
225             }
226              
227              
228             # Check if the temp file creation was successful. Else store data in memory.
229 143 50       453 if ($fh) {
230              
231             # binmode file whether platform requires it or not.
232 143         357 binmode($fh);
233              
234             # Store filehandle
235 143         434 $self->{_filehandle} = $fh;
236             }
237             else {
238              
239             # Set flag to store data in memory if XX::tempfile() failed.
240 0         0 $self->{_using_tmpfile} = 0;
241              
242 0 0 0     0 if ($self->{_index} == 0 && $^W) {
243 0   0     0 my $dir = $self->{_tempdir} || File::Spec->tmpdir();
244              
245 0         0 warn "Unable to create temp files in $tmp_dir. Data will be ".
246             "stored in memory. Refer to set_tempdir() in the ".
247             "Spreadsheet::WriteExcel documentation.\n" ;
248             }
249             }
250             }
251              
252              
253             ###############################################################################
254             #
255             # _close()
256             #
257             # Add data to the beginning of the workbook (note the reverse order)
258             # and to the end of the workbook.
259             #
260             sub _close {
261              
262 133     133   229 my $self = shift;
263              
264             ################################################
265             # Prepend in reverse order!!
266             #
267              
268             # Prepend the sheet dimensions
269 133         458 $self->_store_dimensions();
270              
271             # Prepend the autofilter filters.
272 133         470 $self->_store_autofilters;
273              
274             # Prepend the sheet autofilter info.
275 133         430 $self->_store_autofilterinfo();
276              
277             # Prepend the sheet filtermode record.
278 133         404 $self->_store_filtermode();
279              
280             # Prepend the COLINFO records if they exist
281 133 100       168 if (@{$self->{_colinfo}}){
  133         537  
282 4         8 my @colinfo = @{$self->{_colinfo}};
  4         11  
283 4         15 while (@colinfo) {
284 5         9 my $arrayref = pop @colinfo;
285 5         20 $self->_store_colinfo(@$arrayref);
286             }
287             }
288              
289             # Prepend the DEFCOLWIDTH record
290 133         474 $self->_store_defcol();
291              
292             # Prepend the sheet password
293 133         428 $self->_store_password();
294              
295             # Prepend the sheet protection
296 133         404 $self->_store_protect();
297 133         444 $self->_store_obj_protect();
298              
299             # Prepend the page setup
300 133         439 $self->_store_setup();
301              
302             # Prepend the bottom margin
303 133         445 $self->_store_margin_bottom();
304              
305             # Prepend the top margin
306 133         424 $self->_store_margin_top();
307              
308             # Prepend the right margin
309 133         389 $self->_store_margin_right();
310              
311             # Prepend the left margin
312 133         349 $self->_store_margin_left();
313              
314             # Prepend the page vertical centering
315 133         406 $self->_store_vcenter();
316              
317             # Prepend the page horizontal centering
318 133         373 $self->_store_hcenter();
319              
320             # Prepend the page footer
321 133         387 $self->_store_footer();
322              
323             # Prepend the page header
324 133         389 $self->_store_header();
325              
326             # Prepend the vertical page breaks
327 133         461 $self->_store_vbreak();
328              
329             # Prepend the horizontal page breaks
330 133         392 $self->_store_hbreak();
331              
332             # Prepend WSBOOL
333 133         406 $self->_store_wsbool();
334              
335             # Prepend the default row height.
336 133         407 $self->_store_defrow();
337              
338             # Prepend GUTS
339 133         385 $self->_store_guts();
340              
341             # Prepend GRIDSET
342 133         396 $self->_store_gridset();
343              
344             # Prepend PRINTGRIDLINES
345 133         374 $self->_store_print_gridlines();
346              
347             # Prepend PRINTHEADERS
348 133         444 $self->_store_print_headers();
349              
350             #
351             # End of prepend. Read upwards from here.
352             ################################################
353              
354             # Append
355 133         412 $self->_store_table();
356 133         412 $self->_store_images();
357 133         408 $self->_store_charts();
358 133         375 $self->_store_filters();
359 133         379 $self->_store_comments();
360 133         565 $self->_store_window2();
361 133         465 $self->_store_page_view();
362 133         468 $self->_store_zoom();
363 133 50       191 $self->_store_panes(@{$self->{_panes}}) if @{$self->{_panes}};
  0         0  
  133         466  
364 133         316 $self->_store_selection(@{$self->{_selection}});
  133         523  
365 133         498 $self->_store_validation_count();
366 133         384 $self->_store_validations();
367 133         339 $self->_store_tab_color();
368 133         728 $self->_store_eof();
369              
370             # Prepend the BOF and INDEX records
371 133         482 $self->_store_index();
372 133         564 $self->_store_bof(0x0010);
373             }
374              
375              
376             ###############################################################################
377             #
378             # _compatibility_mode()
379             #
380             # Set the compatibility mode.
381             #
382             # See the explanation in Workbook::compatibility_mode(). This private method
383             # is mainly used for test purposes.
384             #
385             sub _compatibility_mode {
386              
387 0     0   0 my $self = shift;
388              
389 0 0       0 if (defined($_[0])) {
390 0         0 $self->{_compatibility} = $_[0];
391             }
392             else {
393 0         0 $self->{_compatibility} = 1;
394             }
395             }
396              
397              
398             ###############################################################################
399             #
400             # get_name().
401             #
402             # Retrieve the worksheet name.
403             #
404             # Note, there is no set_name() method because names are used in formulas and
405             # converted to internal indices. Allowing the user to change sheet names
406             # after they have been set in add_worksheet() is asking for trouble.
407             #
408             sub get_name {
409              
410 0     0 0 0 my $self = shift;
411              
412 0         0 return $self->{_name};
413             }
414              
415              
416             ###############################################################################
417             #
418             # get_data().
419             #
420             # Retrieves data from memory in one chunk, or from disk in $buffer
421             # sized chunks.
422             #
423             sub get_data {
424              
425 402     402 0 523 my $self = shift;
426 402         464 my $buffer = 4096;
427 402         757 my $tmp;
428              
429             # Return data stored in memory
430 402 100       967 if (defined $self->{_data}) {
431 135         252 $tmp = $self->{_data};
432 135         1376 $self->{_data} = undef;
433 135         278 my $fh = $self->{_filehandle};
434 135 100       6275 seek($fh, 0, 0) if $self->{_using_tmpfile};
435 135         893 return $tmp;
436             }
437              
438             # Return data stored on disk
439 267 100       806 if ($self->{_using_tmpfile}) {
440 264 100       3836 return $tmp if read($self->{_filehandle}, $tmp, $buffer);
441             }
442              
443             # No data to return
444 135         631 return undef;
445             }
446              
447              
448             ###############################################################################
449             #
450             # select()
451             #
452             # Set this worksheet as a selected worksheet, i.e. the worksheet has its tab
453             # highlighted.
454             #
455             sub select {
456              
457 0     0 0 0 my $self = shift;
458              
459 0         0 $self->{_hidden} = 0; # Selected worksheet can't be hidden.
460 0         0 $self->{_selected} = 1;
461             }
462              
463              
464             ###############################################################################
465             #
466             # activate()
467             #
468             # Set this worksheet as the active worksheet, i.e. the worksheet that is
469             # displayed when the workbook is opened. Also set it as selected.
470             #
471             sub activate {
472              
473 0     0 0 0 my $self = shift;
474              
475 0         0 $self->{_hidden} = 0; # Active worksheet can't be hidden.
476 0         0 $self->{_selected} = 1;
477 0         0 ${$self->{_activesheet}} = $self->{_index};
  0         0  
478             }
479              
480              
481             ###############################################################################
482             #
483             # hide()
484             #
485             # Hide this worksheet.
486             #
487             sub hide {
488              
489 0     0 0 0 my $self = shift;
490              
491 0         0 $self->{_hidden} = 1;
492              
493             # A hidden worksheet shouldn't be active or selected.
494 0         0 $self->{_selected} = 0;
495 0         0 ${$self->{_activesheet}} = 0;
  0         0  
496 0         0 ${$self->{_firstsheet}} = 0;
  0         0  
497             }
498              
499              
500             ###############################################################################
501             #
502             # set_first_sheet()
503             #
504             # Set this worksheet as the first visible sheet. This is necessary
505             # when there are a large number of worksheets and the activated
506             # worksheet is not visible on the screen.
507             #
508             sub set_first_sheet {
509              
510 0     0 0 0 my $self = shift;
511              
512 0         0 $self->{_hidden} = 0; # Active worksheet can't be hidden.
513 0         0 ${$self->{_firstsheet}} = $self->{_index};
  0         0  
514             }
515              
516              
517             ###############################################################################
518             #
519             # protect($password)
520             #
521             # Set the worksheet protection flag to prevent accidental modification and to
522             # hide formulas if the locked and hidden format properties have been set.
523             #
524             sub protect {
525              
526 0     0 0 0 my $self = shift;
527              
528 0         0 $self->{_protect} = 1;
529 0 0       0 $self->{_password} = $self->_encode_password($_[0]) if defined $_[0];
530              
531             }
532              
533              
534             ###############################################################################
535             #
536             # set_column($firstcol, $lastcol, $width, $format, $hidden, $level)
537             #
538             # Set the width of a single column or a range of columns.
539             # See also: _store_colinfo
540             #
541             sub set_column {
542              
543 5     5 0 1127 my $self = shift;
544 5         18 my @data = @_;
545 5         11 my $cell = $data[0];
546              
547             # Check for a cell reference in A1 notation and substitute row and column
548 5 100       27 if ($cell =~ /^\D/) {
549 3         17 @data = $self->_substitute_cellref(@_);
550              
551             # Returned values $row1 and $row2 aren't required here. Remove them.
552 3         7 shift @data; # $row1
553 3         10 splice @data, 1, 1; # $row2
554             }
555              
556 5 50       26 return if @data < 3; # Ensure at least $firstcol, $lastcol and $width
557 5 50       16 return if not defined $data[0]; # Columns must be defined.
558 5 50       15 return if not defined $data[1];
559              
560             # Assume second column is the same as first if 0. Avoids KB918419 bug.
561 5 50       16 $data[1] = $data[0] if $data[1] == 0;
562              
563             # Ensure 2nd col is larger than first. Also for KB918419 bug.
564 5 50       16 ($data[0], $data[1]) = ($data[1], $data[0]) if $data[0] > $data[1];
565              
566             # Limit columns to Excel max of 255.
567 5 50       15 $data[0] = 255 if $data[0] > 255;
568 5 50       14 $data[1] = 255 if $data[1] > 255;
569              
570 5         7 push @{$self->{_colinfo}}, [ @data ];
  5         20  
571              
572              
573             # Store the col sizes for use when calculating image vertices taking
574             # hidden columns into account. Also store the column formats.
575             #
576 5 50       16 my $width = $data[4] ? 0 : $data[2]; # Set width to zero if col is hidden
577 5   100     25 $width ||= 0; # Ensure width isn't undef.
578 5         8 my $format = $data[3];
579              
580 5         17 my ($firstcol, $lastcol) = @data;
581              
582 5         16 foreach my $col ($firstcol .. $lastcol) {
583 10         27 $self->{_col_sizes}->{$col} = $width;
584 10 100       50 $self->{_col_formats}->{$col} = $format if defined $format;
585             }
586             }
587              
588              
589             ###############################################################################
590             #
591             # set_selection()
592             #
593             # Set which cell or cells are selected in a worksheet: see also the
594             # sub _store_selection
595             #
596             sub set_selection {
597              
598 0     0 0 0 my $self = shift;
599              
600             # Check for a cell reference in A1 notation and substitute row and column
601 0 0       0 if ($_[0] =~ /^\D/) {
602 0         0 @_ = $self->_substitute_cellref(@_);
603             }
604              
605 0         0 $self->{_selection} = [ @_ ];
606             }
607              
608              
609             ###############################################################################
610             #
611             # freeze_panes()
612             #
613             # Set panes and mark them as frozen. See also _store_panes().
614             #
615             sub freeze_panes {
616              
617 0     0 0 0 my $self = shift;
618              
619             # Check for a cell reference in A1 notation and substitute row and column
620 0 0       0 if ($_[0] =~ /^\D/) {
621 0         0 @_ = $self->_substitute_cellref(@_);
622             }
623              
624             # Extra flag indicated a split and freeze.
625 0 0       0 $self->{_frozen_no_split} = 0 if $_[4];
626              
627 0         0 $self->{_frozen} = 1;
628 0         0 $self->{_panes} = [ @_ ];
629             }
630              
631              
632             ###############################################################################
633             #
634             # split_panes()
635             #
636             # Set panes and mark them as split. See also _store_panes().
637             #
638             sub split_panes {
639              
640 0     0 0 0 my $self = shift;
641              
642 0         0 $self->{_frozen} = 0;
643 0         0 $self->{_frozen_no_split} = 0;
644 0         0 $self->{_panes} = [ @_ ];
645             }
646              
647             # Older method name for backwards compatibility.
648             *thaw_panes = *split_panes;
649              
650              
651             ###############################################################################
652             #
653             # set_portrait()
654             #
655             # Set the page orientation as portrait.
656             #
657             sub set_portrait {
658              
659 0     0 0 0 my $self = shift;
660              
661 0         0 $self->{_orientation} = 1;
662             }
663              
664              
665             ###############################################################################
666             #
667             # set_landscape()
668             #
669             # Set the page orientation as landscape.
670             #
671             sub set_landscape {
672              
673 0     0 0 0 my $self = shift;
674              
675 0         0 $self->{_orientation} = 0;
676             }
677              
678              
679             ###############################################################################
680             #
681             # set_page_view()
682             #
683             # Set the page view mode for Mac Excel.
684             #
685             sub set_page_view {
686              
687 0     0 0 0 my $self = shift;
688              
689 0 0       0 $self->{_page_view} = defined $_[0] ? $_[0] : 1;
690             }
691              
692              
693             ###############################################################################
694             #
695             # set_tab_color()
696             #
697             # Set the colour of the worksheet colour.
698             #
699             sub set_tab_color {
700              
701 0     0 0 0 my $self = shift;
702              
703 0         0 my $color = &Spreadsheet::WriteExcel::Format::_get_color($_[0]);
704 0 0       0 $color = 0 if $color == 0x7FFF; # Default color.
705              
706 0         0 $self->{_tab_color} = $color;
707             }
708              
709              
710             ###############################################################################
711             #
712             # set_paper()
713             #
714             # Set the paper type. Ex. 1 = US Letter, 9 = A4
715             #
716             sub set_paper {
717              
718 0     0 0 0 my $self = shift;
719              
720 0   0     0 $self->{_paper_size} = $_[0] || 0;
721             }
722              
723              
724             ###############################################################################
725             #
726             # set_header()
727             #
728             # Set the page header caption and optional margin.
729             #
730             sub set_header {
731              
732 0     0 0 0 my $self = shift;
733 0   0     0 my $string = $_[0] || '';
734 0   0     0 my $margin = $_[1] || 0.50;
735 0   0     0 my $encoding = $_[2] || 0;
736              
737             # Handle utf8 strings in perl 5.8.
738 0 0       0 if ($] >= 5.008) {
739 0         0 require Encode;
740              
741 0 0       0 if (Encode::is_utf8($string)) {
742 0         0 $string = Encode::encode("UTF-16BE", $string);
743 0         0 $encoding = 1;
744             }
745             }
746              
747 0 0       0 my $limit = $encoding ? 255 *2 : 255;
748              
749 0 0       0 if (length $string >= $limit) {
750 0         0 carp 'Header string must be less than 255 characters';
751 0         0 return;
752             }
753              
754 0         0 $self->{_header} = $string;
755 0         0 $self->{_margin_header} = $margin;
756 0         0 $self->{_header_encoding} = $encoding;
757             }
758              
759              
760             ###############################################################################
761             #
762             # set_footer()
763             #
764             # Set the page footer caption and optional margin.
765             #
766             sub set_footer {
767              
768 0     0 0 0 my $self = shift;
769 0   0     0 my $string = $_[0] || '';
770 0   0     0 my $margin = $_[1] || 0.50;
771 0   0     0 my $encoding = $_[2] || 0;
772              
773             # Handle utf8 strings in perl 5.8.
774 0 0       0 if ($] >= 5.008) {
775 0         0 require Encode;
776              
777 0 0       0 if (Encode::is_utf8($string)) {
778 0         0 $string = Encode::encode("UTF-16BE", $string);
779 0         0 $encoding = 1;
780             }
781             }
782              
783 0 0       0 my $limit = $encoding ? 255 *2 : 255;
784              
785              
786 0 0       0 if (length $string >= $limit) {
787 0         0 carp 'Footer string must be less than 255 characters';
788 0         0 return;
789             }
790              
791 0         0 $self->{_footer} = $string;
792 0         0 $self->{_margin_footer} = $margin;
793 0         0 $self->{_footer_encoding} = $encoding;
794             }
795              
796              
797             ###############################################################################
798             #
799             # center_horizontally()
800             #
801             # Center the page horizontally.
802             #
803             sub center_horizontally {
804              
805 0     0 0 0 my $self = shift;
806              
807 0 0       0 if (defined $_[0]) {
808 0         0 $self->{_hcenter} = $_[0];
809             }
810             else {
811 0         0 $self->{_hcenter} = 1;
812             }
813             }
814              
815              
816             ###############################################################################
817             #
818             # center_vertically()
819             #
820             # Center the page horizontally.
821             #
822             sub center_vertically {
823              
824 0     0 0 0 my $self = shift;
825              
826 0 0       0 if (defined $_[0]) {
827 0         0 $self->{_vcenter} = $_[0];
828             }
829             else {
830 0         0 $self->{_vcenter} = 1;
831             }
832             }
833              
834              
835             ###############################################################################
836             #
837             # set_margins()
838             #
839             # Set all the page margins to the same value in inches.
840             #
841             sub set_margins {
842              
843 0     0 0 0 my $self = shift;
844              
845 0         0 $self->set_margin_left($_[0]);
846 0         0 $self->set_margin_right($_[0]);
847 0         0 $self->set_margin_top($_[0]);
848 0         0 $self->set_margin_bottom($_[0]);
849             }
850              
851              
852             ###############################################################################
853             #
854             # set_margins_LR()
855             #
856             # Set the left and right margins to the same value in inches.
857             #
858             sub set_margins_LR {
859              
860 0     0 0 0 my $self = shift;
861              
862 0         0 $self->set_margin_left($_[0]);
863 0         0 $self->set_margin_right($_[0]);
864             }
865              
866              
867             ###############################################################################
868             #
869             # set_margins_TB()
870             #
871             # Set the top and bottom margins to the same value in inches.
872             #
873             sub set_margins_TB {
874              
875 0     0 0 0 my $self = shift;
876              
877 0         0 $self->set_margin_top($_[0]);
878 0         0 $self->set_margin_bottom($_[0]);
879             }
880              
881              
882             ###############################################################################
883             #
884             # set_margin_left()
885             #
886             # Set the left margin in inches.
887             #
888             sub set_margin_left {
889              
890 0     0 0 0 my $self = shift;
891              
892 0 0       0 $self->{_margin_left} = defined $_[0] ? $_[0] : 0.75;
893             }
894              
895              
896             ###############################################################################
897             #
898             # set_margin_right()
899             #
900             # Set the right margin in inches.
901             #
902             sub set_margin_right {
903              
904 0     0 0 0 my $self = shift;
905              
906 0 0       0 $self->{_margin_right} = defined $_[0] ? $_[0] : 0.75;
907             }
908              
909              
910             ###############################################################################
911             #
912             # set_margin_top()
913             #
914             # Set the top margin in inches.
915             #
916             sub set_margin_top {
917              
918 0     0 0 0 my $self = shift;
919              
920 0 0       0 $self->{_margin_top} = defined $_[0] ? $_[0] : 1.00;
921             }
922              
923              
924             ###############################################################################
925             #
926             # set_margin_bottom()
927             #
928             # Set the bottom margin in inches.
929             #
930             sub set_margin_bottom {
931              
932 0     0 0 0 my $self = shift;
933              
934 0 0       0 $self->{_margin_bottom} = defined $_[0] ? $_[0] : 1.00;
935             }
936              
937              
938             ###############################################################################
939             #
940             # repeat_rows($first_row, $last_row)
941             #
942             # Set the rows to repeat at the top of each printed page. See also the
943             # _store_name_xxxx() methods in Workbook.pm.
944             #
945             sub repeat_rows {
946              
947 9     9 0 208 my $self = shift;
948              
949 9         18 $self->{_title_rowmin} = $_[0];
950 9   66     41 $self->{_title_rowmax} = $_[1] || $_[0]; # Second row is optional
951             }
952              
953              
954             ###############################################################################
955             #
956             # repeat_columns($first_col, $last_col)
957             #
958             # Set the columns to repeat at the left hand side of each printed page.
959             # See also the _store_names() methods in Workbook.pm.
960             #
961             sub repeat_columns {
962              
963 5     5 0 287 my $self = shift;
964              
965             # Check for a cell reference in A1 notation and substitute row and column
966 5 100       29 if ($_[0] =~ /^\D/) {
967 2         9 @_ = $self->_substitute_cellref(@_);
968              
969             # Returned values $row1 and $row2 aren't required here. Remove them.
970 2         3 shift @_; # $row1
971 2         6 splice @_, 1, 1; # $row2
972             }
973              
974 5         11 $self->{_title_colmin} = $_[0];
975 5   66     27 $self->{_title_colmax} = $_[1] || $_[0]; # Second col is optional
976             }
977              
978              
979             ###############################################################################
980             #
981             # print_area($first_row, $first_col, $last_row, $last_col)
982             #
983             # Set the area of each worksheet that will be printed. See also the
984             # _store_names() methods in Workbook.pm.
985             #
986             sub print_area {
987              
988 10     10 0 266 my $self = shift;
989              
990             # Check for a cell reference in A1 notation and substitute row and column
991 10 50       41 if ($_[0] =~ /^\D/) {
992 10         29 @_ = $self->_substitute_cellref(@_);
993             }
994              
995 10 50       29 return if @_ != 4; # Require 4 parameters
996              
997 10         22 $self->{_print_rowmin} = $_[0];
998 10         16 $self->{_print_colmin} = $_[1];
999 10         12 $self->{_print_rowmax} = $_[2];
1000 10         34 $self->{_print_colmax} = $_[3];
1001             }
1002              
1003              
1004             ###############################################################################
1005             #
1006             # autofilter($first_row, $first_col, $last_row, $last_col)
1007             #
1008             # Set the autofilter area in the worksheet.
1009             #
1010             sub autofilter {
1011              
1012 3     3 0 18 my $self = shift;
1013              
1014             # Check for a cell reference in A1 notation and substitute row and column
1015 3 50       14 if ($_[0] =~ /^\D/) {
1016 3         11 @_ = $self->_substitute_cellref(@_);
1017             }
1018              
1019 3 50       10 return if @_ != 4; # Require 4 parameters
1020              
1021 3         7 my ($row1, $col1, $row2, $col2) = @_;
1022              
1023             # Reverse max and min values if necessary.
1024 3 50       6 ($row1, $row2) = ($row2, $row1) if $row2 < $row1;
1025 3 50       8 ($col1, $col2) = ($col2, $col1) if $col2 < $col1;
1026              
1027             # Store the Autofilter information
1028 3         8 $self->{_filter_area} = [$row1, $row2, $col1, $col2];
1029 3         13 $self->{_filter_count} = 1+ $col2 -$col1;
1030             }
1031              
1032              
1033             ###############################################################################
1034             #
1035             # filter_column($column, $criteria, ...)
1036             #
1037             # Set the column filter criteria.
1038             #
1039             sub filter_column {
1040              
1041 0     0 0 0 my $self = shift;
1042 0         0 my $col = $_[0];
1043 0         0 my $expression = $_[1];
1044              
1045              
1046 0 0       0 croak "Must call autofilter() before filter_column()"
1047             unless $self->{_filter_count};
1048 0 0       0 croak "Incorrect number of arguments to filter_column()" unless @_ == 2;
1049              
1050              
1051             # Check for a column reference in A1 notation and substitute.
1052 0 0       0 if ($col =~ /^\D/) {
1053             # Convert col ref to a cell ref and then to a col number.
1054 0         0 (undef, $col) = $self->_substitute_cellref($col . '1');
1055             }
1056              
1057 0         0 my (undef, undef, $col_first, $col_last) = @{$self->{_filter_area}};
  0         0  
1058              
1059             # Reject column if it is outside filter range.
1060 0 0 0     0 if ($col < $col_first or $col > $col_last) {
1061 0         0 croak "Column '$col' outside autofilter() column range " .
1062             "($col_first .. $col_last)";
1063             }
1064              
1065              
1066 0         0 my @tokens = $self->_extract_filter_tokens($expression);
1067              
1068 0 0 0     0 croak "Incorrect number of tokens in expression '$expression'"
1069             unless (@tokens == 3 or @tokens == 7);
1070              
1071              
1072 0         0 @tokens = $self->_parse_filter_expression($expression, @tokens);
1073              
1074 0         0 $self->{_filter_cols}->{$col} = [@tokens];
1075 0         0 $self->{_filter_on} = 1;
1076             }
1077              
1078              
1079             ###############################################################################
1080             #
1081             # _extract_filter_tokens($expression)
1082             #
1083             # Extract the tokens from the filter expression. The tokens are mainly non-
1084             # whitespace groups. The only tricky part is to extract string tokens that
1085             # contain whitespace and/or quoted double quotes (Excel's escaped quotes).
1086             #
1087             # Examples: 'x < 2000'
1088             # 'x > 2000 and x < 5000'
1089             # 'x = "foo"'
1090             # 'x = "foo bar"'
1091             # 'x = "foo "" bar"'
1092             #
1093             sub _extract_filter_tokens {
1094              
1095 71     71   43871 my $self = shift;
1096 71         105 my $expression = $_[0];
1097              
1098 71 100       176 return unless $expression;
1099              
1100 69         573 my @tokens = ($expression =~ /"(?:[^"]|"")*"|\S+/g); #"
1101              
1102             # Remove leading and trailing quotes and unescape other quotes
1103 69         152 for (@tokens) {
1104 247         289 s/^"//; #"
1105 247         291 s/"$//; #"
1106 247         395 s/""/"/g; #"
1107             }
1108              
1109 69         314 return @tokens;
1110             }
1111              
1112              
1113             ###############################################################################
1114             #
1115             # _parse_filter_expression(@token)
1116             #
1117             # Converts the tokens of a possibly conditional expression into 1 or 2
1118             # sub expressions for further parsing.
1119             #
1120             # Examples:
1121             # ('x', '==', 2000) -> exp1
1122             # ('x', '>', 2000, 'and', 'x', '<', 5000) -> exp1 and exp2
1123             #
1124             sub _parse_filter_expression {
1125              
1126 53     53   223 my $self = shift;
1127 53         72 my $expression = shift;
1128 53         125 my @tokens = @_;
1129              
1130             # The number of tokens will be either 3 (for 1 expression)
1131             # or 7 (for 2 expressions).
1132             #
1133 53 100       122 if (@tokens == 7) {
1134              
1135 7         16 my $conditional = $tokens[3];
1136              
1137 7 100       49 if ($conditional =~ /^(and|&&)$/) {
    50          
1138 4         10 $conditional = 0;
1139             }
1140             elsif ($conditional =~ /^(or|\|\|)$/) {
1141 3         7 $conditional = 1;
1142             }
1143             else {
1144 0         0 croak "Token '$conditional' is not a valid conditional " .
1145             "in filter expression '$expression'";
1146             }
1147              
1148 7         28 my @expression_1 = $self->_parse_filter_tokens($expression,
1149             @tokens[0, 1, 2]);
1150 7         21 my @expression_2 = $self->_parse_filter_tokens($expression,
1151             @tokens[4, 5, 6]);
1152              
1153 7         45 return (@expression_1, $conditional, @expression_2);
1154             }
1155             else {
1156 46         128 return $self->_parse_filter_tokens($expression, @tokens);
1157             }
1158             }
1159              
1160              
1161             ###############################################################################
1162             #
1163             # _parse_filter_tokens(@token)
1164             #
1165             # Parse the 3 tokens of a filter expression and return the operator and token.
1166             #
1167             sub _parse_filter_tokens {
1168              
1169 60     60   75 my $self = shift;
1170 60         72 my $expression = shift;
1171 60         125 my @tokens = @_;
1172              
1173 60         406 my %operators = (
1174             '==' => 2,
1175             '=' => 2,
1176             '=~' => 2,
1177             'eq' => 2,
1178              
1179             '!=' => 5,
1180             '!~' => 5,
1181             'ne' => 5,
1182             '<>' => 5,
1183              
1184             '<' => 1,
1185             '<=' => 3,
1186             '>' => 4,
1187             '>=' => 6,
1188             );
1189              
1190 60         97 my $operator = $operators{$tokens[1]};
1191 60         100 my $token = $tokens[2];
1192              
1193              
1194             # Special handling of "Top" filter expressions.
1195 60 100       157 if ($tokens[0] =~ /^top|bottom$/i) {
1196              
1197 11         21 my $value = $tokens[1];
1198              
1199 11 50 33     124 if ($value =~ /\D/ or
      33        
1200             $value < 1 or
1201             $value > 500)
1202             {
1203 0         0 croak "The value '$value' in expression '$expression' " .
1204             "must be in the range 1 to 500";
1205             }
1206              
1207 11         24 $token = lc $token;
1208              
1209 11 50 66     47 if ($token ne 'items' and $token ne '%') {
1210 0         0 croak "The type '$token' in expression '$expression' " .
1211             "must be either 'items' or '%'";
1212             }
1213              
1214 11 100       40 if ($tokens[0] =~ /^top$/i) {
1215 7         13 $operator = 30;
1216             }
1217             else {
1218 4         8 $operator = 32;
1219             }
1220              
1221 11 100       42 if ($tokens[2] eq '%') {
1222 4         7 $operator++;
1223             }
1224              
1225 11         20 $token = $value;
1226             }
1227              
1228              
1229 60 0 33     138 if (not $operator and $tokens[0]) {
1230 0         0 croak "Token '$tokens[1]' is not a valid operator " .
1231             "in filter expression '$expression'";
1232             }
1233              
1234              
1235             # Special handling for Blanks/NonBlanks.
1236 60 100       133 if ($token =~ /^blanks|nonblanks$/i) {
1237              
1238             # Only allow Equals or NotEqual in this context.
1239 6 50 66     29 if ($operator != 2 and $operator != 5) {
1240 0         0 croak "The operator '$tokens[1]' in expression '$expression' " .
1241             "is not valid in relation to Blanks/NonBlanks'";
1242             }
1243              
1244 6         19 $token = lc $token;
1245              
1246             # The operator should always be 2 (=) to flag a "simple" equality in
1247             # the binary record. Therefore we convert <> to =.
1248 6 100       17 if ($token eq 'blanks') {
1249 3 100       10 if ($operator == 5) {
1250 1         3 $operator = 2;
1251 1         4 $token = 'nonblanks';
1252             }
1253             }
1254             else {
1255 3 100       14 if ($operator == 5) {
1256 1         4 $operator = 2;
1257 1         2 $token = 'blanks';
1258             }
1259             }
1260             }
1261              
1262              
1263             # if the string token contains an Excel match character then change the
1264             # operator type to indicate a non "simple" equality.
1265 60 100 100     223 if ($operator == 2 and $token =~ /[*?]/) {
1266 5         8 $operator = 22;
1267             }
1268              
1269              
1270 60         403 return ($operator, $token);
1271             }
1272              
1273              
1274             ###############################################################################
1275             #
1276             # hide_gridlines()
1277             #
1278             # Set the option to hide gridlines on the screen and the printed page.
1279             # There are two ways of doing this in the Excel BIFF format: The first is by
1280             # setting the DspGrid field of the WINDOW2 record, this turns off the screen
1281             # and subsequently the print gridline. The second method is to via the
1282             # PRINTGRIDLINES and GRIDSET records, this turns off the printed gridlines
1283             # only. The first method is probably sufficient for most cases. The second
1284             # method is supported for backwards compatibility. Porters take note.
1285             #
1286             sub hide_gridlines {
1287              
1288 0     0 0 0 my $self = shift;
1289 0         0 my $option = $_[0];
1290              
1291 0 0       0 $option = 1 unless defined $option; # Default to hiding printed gridlines
1292              
1293 0 0       0 if ($option == 0) {
    0          
1294 0         0 $self->{_print_gridlines} = 1; # 1 = display, 0 = hide
1295 0         0 $self->{_screen_gridlines} = 1;
1296             }
1297             elsif ($option == 1) {
1298 0         0 $self->{_print_gridlines} = 0;
1299 0         0 $self->{_screen_gridlines} = 1;
1300             }
1301             else {
1302 0         0 $self->{_print_gridlines} = 0;
1303 0         0 $self->{_screen_gridlines} = 0;
1304             }
1305             }
1306              
1307              
1308             ###############################################################################
1309             #
1310             # print_row_col_headers()
1311             #
1312             # Set the option to print the row and column headers on the printed page.
1313             # See also the _store_print_headers() method below.
1314             #
1315             sub print_row_col_headers {
1316              
1317 0     0 0 0 my $self = shift;
1318              
1319 0 0       0 if (defined $_[0]) {
1320 0         0 $self->{_print_headers} = $_[0];
1321             }
1322             else {
1323 0         0 $self->{_print_headers} = 1;
1324             }
1325             }
1326              
1327              
1328             ###############################################################################
1329             #
1330             # fit_to_pages($width, $height)
1331             #
1332             # Store the vertical and horizontal number of pages that will define the
1333             # maximum area printed. See also _store_setup() and _store_wsbool() below.
1334             #
1335             sub fit_to_pages {
1336              
1337 0     0 0 0 my $self = shift;
1338              
1339 0         0 $self->{_fit_page} = 1;
1340 0   0     0 $self->{_fit_width} = $_[0] || 0;
1341 0   0     0 $self->{_fit_height} = $_[1] || 0;
1342             }
1343              
1344              
1345             ###############################################################################
1346             #
1347             # set_h_pagebreaks(@breaks)
1348             #
1349             # Store the horizontal page breaks on a worksheet.
1350             #
1351             sub set_h_pagebreaks {
1352              
1353 0     0 0 0 my $self = shift;
1354              
1355 0         0 push @{$self->{_hbreaks}}, @_;
  0         0  
1356             }
1357              
1358              
1359             ###############################################################################
1360             #
1361             # set_v_pagebreaks(@breaks)
1362             #
1363             # Store the vertical page breaks on a worksheet.
1364             #
1365             sub set_v_pagebreaks {
1366              
1367 0     0 0 0 my $self = shift;
1368              
1369 0         0 push @{$self->{_vbreaks}}, @_;
  0         0  
1370             }
1371              
1372              
1373             ###############################################################################
1374             #
1375             # set_zoom($scale)
1376             #
1377             # Set the worksheet zoom factor.
1378             #
1379             sub set_zoom {
1380              
1381 0     0 0 0 my $self = shift;
1382 0   0     0 my $scale = $_[0] || 100;
1383              
1384             # Confine the scale to Excel's range
1385 0 0 0     0 if ($scale < 10 or $scale > 400) {
1386 0         0 carp "Zoom factor $scale outside range: 10 <= zoom <= 400";
1387 0         0 $scale = 100;
1388             }
1389              
1390 0         0 $self->{_zoom} = int $scale;
1391             }
1392              
1393              
1394             ###############################################################################
1395             #
1396             # set_print_scale($scale)
1397             #
1398             # Set the scale factor for the printed page.
1399             #
1400             sub set_print_scale {
1401              
1402 0     0 0 0 my $self = shift;
1403 0   0     0 my $scale = $_[0] || 100;
1404              
1405             # Confine the scale to Excel's range
1406 0 0 0     0 if ($scale < 10 or $scale > 400) {
1407 0         0 carp "Print scale $scale outside range: 10 <= zoom <= 400";
1408 0         0 $scale = 100;
1409             }
1410              
1411             # Turn off "fit to page" option
1412 0         0 $self->{_fit_page} = 0;
1413              
1414 0         0 $self->{_print_scale} = int $scale;
1415             }
1416              
1417              
1418             ###############################################################################
1419             #
1420             # keep_leading_zeros()
1421             #
1422             # Causes the write() method to treat integers with a leading zero as a string.
1423             # This ensures that any leading zeros such, as in zip codes, are maintained.
1424             #
1425             sub keep_leading_zeros {
1426              
1427 0     0 0 0 my $self = shift;
1428              
1429 0 0       0 if (defined $_[0]) {
1430 0         0 $self->{_leading_zeros} = $_[0];
1431             }
1432             else {
1433 0         0 $self->{_leading_zeros} = 1;
1434             }
1435             }
1436              
1437              
1438             ###############################################################################
1439             #
1440             # show_comments()
1441             #
1442             # Make any comments in the worksheet visible.
1443             #
1444             sub show_comments {
1445              
1446 0     0 0 0 my $self = shift;
1447              
1448 0 0       0 $self->{_comments_visible} = defined $_[0] ? $_[0] : 1;
1449             }
1450              
1451              
1452             ###############################################################################
1453             #
1454             # set_comments_author()
1455             #
1456             # Set the default author of the cell comments.
1457             #
1458             sub set_comments_author {
1459              
1460 0     0 0 0 my $self = shift;
1461              
1462 0 0       0 $self->{_comments_author} = defined $_[0] ? $_[0] : '';
1463 0 0       0 $self->{_comments_author_enc} = $_[1] ? 1 : 0;
1464             }
1465              
1466              
1467             ###############################################################################
1468             #
1469             # right_to_left()
1470             #
1471             # Display the worksheet right to left for some eastern versions of Excel.
1472             #
1473             sub right_to_left {
1474              
1475 0     0 0 0 my $self = shift;
1476              
1477 0 0       0 $self->{_display_arabic} = defined $_[0] ? $_[0] : 1;
1478             }
1479              
1480              
1481             ###############################################################################
1482             #
1483             # hide_zero()
1484             #
1485             # Hide cell zero values.
1486             #
1487             sub hide_zero {
1488              
1489 0     0 0 0 my $self = shift;
1490              
1491 0 0       0 $self->{_display_zeros} = defined $_[0] ? not $_[0] : 0;
1492             }
1493              
1494              
1495             ###############################################################################
1496             #
1497             # print_across()
1498             #
1499             # Set the order in which pages are printed.
1500             #
1501             sub print_across {
1502              
1503 0     0 0 0 my $self = shift;
1504              
1505 0 0       0 $self->{_page_order} = defined $_[0] ? $_[0] : 1;
1506             }
1507              
1508              
1509             ###############################################################################
1510             #
1511             # set_start_page()
1512             #
1513             # Set the start page number.
1514             #
1515             sub set_start_page {
1516              
1517 0     0 0 0 my $self = shift;
1518 0 0       0 return unless defined $_[0];
1519              
1520 0         0 $self->{_page_start} = $_[0];
1521 0         0 $self->{_custom_start} = 1;
1522             }
1523              
1524              
1525             ###############################################################################
1526             #
1527             # set_first_row_column()
1528             #
1529             # Set the topmost and leftmost visible row and column.
1530             # TODO: Document this when tested fully for interaction with panes.
1531             #
1532             sub set_first_row_column {
1533              
1534 0     0 0 0 my $self = shift;
1535              
1536 0   0     0 my $row = $_[0] || 0;
1537 0   0     0 my $col = $_[1] || 0;
1538              
1539 0 0       0 $row = 65535 if $row > 65535;
1540 0 0       0 $col = 255 if $col > 255;
1541              
1542 0         0 $self->{_first_row} = $row;
1543 0         0 $self->{_first_col} = $col;
1544             }
1545              
1546              
1547             ###############################################################################
1548             #
1549             # add_write_handler($re, $code_ref)
1550             #
1551             # Allow the user to add their own matches and handlers to the write() method.
1552             #
1553             sub add_write_handler {
1554              
1555 0     0 0 0 my $self = shift;
1556              
1557 0 0       0 return unless @_ == 2;
1558 0 0       0 return unless ref $_[1] eq 'CODE';
1559              
1560 0         0 push @{$self->{_write_match}}, [ @_ ];
  0         0  
1561             }
1562              
1563              
1564              
1565             ###############################################################################
1566             #
1567             # write($row, $col, $token, $format)
1568             #
1569             # Parse $token and call appropriate write method. $row and $column are zero
1570             # indexed. $format is optional.
1571             #
1572             # The write_url() methods have a flag to prevent recursion when writing a
1573             # string that looks like a url.
1574             #
1575             # Returns: return value of called subroutine
1576             #
1577             sub write {
1578              
1579 36     36 0 3466 my $self = shift;
1580              
1581             # Check for a cell reference in A1 notation and substitute row and column
1582 36 100       157 if ($_[0] =~ /^\D/) {
1583 7         30 @_ = $self->_substitute_cellref(@_);
1584             }
1585              
1586 36         59 my $token = $_[2];
1587              
1588             # Handle undefs as blanks
1589 36 50       80 $token = '' unless defined $token;
1590              
1591              
1592             # First try user defined matches.
1593 36         41 for my $aref (@{$self->{_write_match}}) {
  36         97  
1594 0         0 my $re = $aref->[0];
1595 0         0 my $sub = $aref->[1];
1596              
1597 0 0       0 if ($token =~ /$re/) {
1598 0         0 my $match = &$sub($self, @_);
1599 0 0       0 return $match if defined $match;
1600             }
1601             }
1602              
1603              
1604             # Match an array ref.
1605 36 50 33     514 if (ref $token eq "ARRAY") {
    50 66        
    50 33        
    50 33        
    50          
    50          
    50          
    50          
1606 0         0 return $self->write_row(@_);
1607             }
1608             # Match integer with leading zero(s)
1609             elsif ($self->{_leading_zeros} and $token =~ /^0\d+$/) {
1610 0         0 return $self->write_string(@_);
1611             }
1612             # Match number
1613             elsif ($token =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) {
1614 0         0 return $self->write_number(@_);
1615             }
1616             # Match http, https or ftp URL
1617             elsif ($token =~ m|^[fh]tt?ps?://| and not $self->{_writing_url}) {
1618 0         0 return $self->write_url(@_);
1619             }
1620             # Match mailto:
1621             elsif ($token =~ m/^mailto:/ and not $self->{_writing_url}) {
1622 0         0 return $self->write_url(@_);
1623             }
1624             # Match internal or external sheet link
1625             elsif ($token =~ m[^(?:in|ex)ternal:] and not $self->{_writing_url}) {
1626 0         0 return $self->write_url(@_);
1627             }
1628             # Match formula
1629             elsif ($token =~ /^=/) {
1630 0         0 return $self->write_formula(@_);
1631             }
1632             # Match blank
1633             elsif ($token eq '') {
1634 0         0 splice @_, 2, 1; # remove the empty string from the parameter list
1635 0         0 return $self->write_blank(@_);
1636             }
1637             else {
1638 36         109 return $self->write_string(@_);
1639             }
1640             }
1641              
1642              
1643             ###############################################################################
1644             #
1645             # write_row($row, $col, $array_ref, $format)
1646             #
1647             # Write a row of data starting from ($row, $col). Call write_col() if any of
1648             # the elements of the array ref are in turn array refs. This allows the writing
1649             # of 1D or 2D arrays of data in one go.
1650             #
1651             # Returns: the first encountered error value or zero for no errors
1652             #
1653             sub write_row {
1654              
1655 0     0 0 0 my $self = shift;
1656              
1657              
1658             # Check for a cell reference in A1 notation and substitute row and column
1659 0 0       0 if ($_[0] =~ /^\D/) {
1660 0         0 @_ = $self->_substitute_cellref(@_);
1661             }
1662              
1663             # Catch non array refs passed by user.
1664 0 0       0 if (ref $_[2] ne 'ARRAY') {
1665 0         0 croak "Not an array ref in call to write_row()$!";
1666             }
1667              
1668 0         0 my $row = shift;
1669 0         0 my $col = shift;
1670 0         0 my $tokens = shift;
1671 0         0 my @options = @_;
1672 0         0 my $error = 0;
1673 0         0 my $ret;
1674              
1675 0         0 foreach my $token (@$tokens) {
1676              
1677             # Check for nested arrays
1678 0 0       0 if (ref $token eq "ARRAY") {
1679 0         0 $ret = $self->write_col($row, $col, $token, @options);
1680             } else {
1681 0         0 $ret = $self->write ($row, $col, $token, @options);
1682             }
1683              
1684             # Return only the first error encountered, if any.
1685 0   0     0 $error ||= $ret;
1686 0         0 $col++;
1687             }
1688              
1689 0         0 return $error;
1690             }
1691              
1692              
1693             ###############################################################################
1694             #
1695             # write_col($row, $col, $array_ref, $format)
1696             #
1697             # Write a column of data starting from ($row, $col). Call write_row() if any of
1698             # the elements of the array ref are in turn array refs. This allows the writing
1699             # of 1D or 2D arrays of data in one go.
1700             #
1701             # Returns: the first encountered error value or zero for no errors
1702             #
1703             sub write_col {
1704              
1705 0     0 0 0 my $self = shift;
1706              
1707              
1708             # Check for a cell reference in A1 notation and substitute row and column
1709 0 0       0 if ($_[0] =~ /^\D/) {
1710 0         0 @_ = $self->_substitute_cellref(@_);
1711             }
1712              
1713             # Catch non array refs passed by user.
1714 0 0       0 if (ref $_[2] ne 'ARRAY') {
1715 0         0 croak "Not an array ref in call to write_col()$!";
1716             }
1717              
1718 0         0 my $row = shift;
1719 0         0 my $col = shift;
1720 0         0 my $tokens = shift;
1721 0         0 my @options = @_;
1722 0         0 my $error = 0;
1723 0         0 my $ret;
1724              
1725 0         0 foreach my $token (@$tokens) {
1726              
1727             # write() will deal with any nested arrays
1728 0         0 $ret = $self->write($row, $col, $token, @options);
1729              
1730             # Return only the first error encountered, if any.
1731 0   0     0 $error ||= $ret;
1732 0         0 $row++;
1733             }
1734              
1735 0         0 return $error;
1736             }
1737              
1738              
1739             ###############################################################################
1740             #
1741             # write_comment($row, $col, $comment)
1742             #
1743             # Write a comment to the specified row and column (zero indexed).
1744             #
1745             # Returns 0 : normal termination
1746             # -1 : insufficient number of arguments
1747             # -2 : row or column out of range
1748             #
1749             sub write_comment {
1750              
1751 22541     22541 0 100625 my $self = shift;
1752              
1753              
1754             # Check for a cell reference in A1 notation and substitute row and column
1755 22541 50       91141 if ($_[0] =~ /^\D/) {
1756 0         0 @_ = $self->_substitute_cellref(@_);
1757             }
1758              
1759 22541 50       52267 if (@_ < 3) { return -1 } # Check the number of args
  0         0  
1760              
1761              
1762 22541         33634 my $row = $_[0];
1763 22541         24090 my $col = $_[1];
1764              
1765             # Check for pairs of optional arguments, i.e. an odd number of args.
1766 22541 50       47182 croak "Uneven number of additional arguments" unless @_ % 2;
1767              
1768              
1769             # Check that row and col are valid and store max and min values
1770 22541 50       49575 return -2 if $self->_check_dimensions($row, $col);
1771              
1772              
1773             # We have to avoid duplicate comments in cells or else Excel will complain.
1774 22541         67219 $self->{_comments}->{$row}->{$col} = [ $self->_comment_params(@_) ];
1775              
1776             }
1777              
1778              
1779             ###############################################################################
1780             #
1781             # _XF()
1782             #
1783             # Returns an index to the XF record in the workbook.
1784             #
1785             # Note: this is a function, not a method.
1786             #
1787             sub _XF {
1788              
1789 59     59   81 my $self = $_[0];
1790 59         70 my $row = $_[1];
1791 59         70 my $col = $_[2];
1792 59         118 my $format = $_[3];
1793              
1794 59         77 my $error = "Error: refer to merge_range() in the documentation. " .
1795             "Can't use previously merged format in non-merged cell";
1796              
1797 59 100       215 if (ref($format)) {
    100          
    100          
1798             # Temp code to prevent merged formats in non-merged cells.
1799 22 100       352 croak $error if $format->{_used_merge} == 1;
1800 21         30 $format->{_used_merge} = -1;
1801              
1802 21         67 return $format->get_xf_index();
1803             }
1804             elsif (exists $self->{_row_formats}->{$row}) {
1805             # Temp code to prevent merged formats in non-merged cells.
1806 2 50       363 croak $error if $self->{_row_formats}->{$row}->{_used_merge} == 1;
1807 0         0 $self->{_row_formats}->{$row}->{_used_merge} = -1;
1808              
1809 0         0 return $self->{_row_formats}->{$row}->get_xf_index();
1810             }
1811             elsif (exists $self->{_col_formats}->{$col}) {
1812             # Temp code to prevent merged formats in non-merged cells.
1813 1 50       233 croak $error if $self->{_col_formats}->{$col}->{_used_merge} == 1;
1814 0         0 $self->{_col_formats}->{$col}->{_used_merge} = -1;
1815              
1816 0         0 return $self->{_col_formats}->{$col}->get_xf_index();
1817             }
1818             else {
1819 34         82 return 0x0F;
1820             }
1821             }
1822              
1823              
1824             ###############################################################################
1825             ###############################################################################
1826             #
1827             # Internal methods
1828             #
1829              
1830              
1831             ###############################################################################
1832             #
1833             # _append(), overridden.
1834             #
1835             # Store Worksheet data in memory using the base class _append() or to a
1836             # temporary file, the default.
1837             #
1838             sub _append {
1839              
1840 885     885   1215 my $self = shift;
1841 885         1194 my $data = '';
1842              
1843 885 100       2124 if ($self->{_using_tmpfile}) {
1844 562         1264 $data = join('', @_);
1845              
1846             # Add CONTINUE records if necessary
1847 562 50       1490 $data = $self->_add_continue($data) if length($data) > $self->{_limit};
1848              
1849             # Protect print() from -l on the command line.
1850 562         1610 local $\ = undef;
1851              
1852 562         661 print {$self->{_filehandle}} $data;
  562         4558  
1853 562         1594 $self->{_datasize} += length($data);
1854             }
1855             else {
1856 323         1782 $data = $self->SUPER::_append(@_);
1857             }
1858              
1859 885         2981 return $data;
1860             }
1861              
1862              
1863             ###############################################################################
1864             #
1865             # _substitute_cellref()
1866             #
1867             # Substitute an Excel cell reference in A1 notation for zero based row and
1868             # column values in an argument list.
1869             #
1870             # Ex: ("A4", "Hello") is converted to (3, 0, "Hello").
1871             #
1872             sub _substitute_cellref {
1873              
1874 83     83   7039 my $self = shift;
1875 83         234 my $cell = uc(shift);
1876              
1877             # Convert a column range: 'A:A' or 'B:G'.
1878             # A range such as A:A is equivalent to A1:65536, so add rows as required
1879 83 100       345 if ($cell =~ /\$?([A-I]?[A-Z]):\$?([A-I]?[A-Z])/) {
1880 6         37 my ($row1, $col1) = $self->_cell_to_rowcol($1 .'1');
1881 6         28 my ($row2, $col2) = $self->_cell_to_rowcol($2 .'65536');
1882 6         33 return $row1, $col1, $row2, $col2, @_;
1883             }
1884              
1885             # Convert a cell range: 'A1:B7'
1886 77 100       276 if ($cell =~ /\$?([A-I]?[A-Z]\$?\d+):\$?([A-I]?[A-Z]\$?\d+)/) {
1887 19         75 my ($row1, $col1) = $self->_cell_to_rowcol($1);
1888 19         74 my ($row2, $col2) = $self->_cell_to_rowcol($2);
1889 19         97 return $row1, $col1, $row2, $col2, @_;
1890             }
1891              
1892             # Convert a cell reference: 'A1' or 'AD2000'
1893 58 50       388 if ($cell =~ /\$?([A-I]?[A-Z]\$?\d+)/) {
1894 58         204 my ($row1, $col1) = $self->_cell_to_rowcol($1);
1895 58         271 return $row1, $col1, @_;
1896              
1897             }
1898              
1899 0         0 croak("Unknown cell reference $cell");
1900             }
1901              
1902              
1903             ###############################################################################
1904             #
1905             # _cell_to_rowcol($cell_ref)
1906             #
1907             # Convert an Excel cell reference in A1 notation to a zero based row and column
1908             # reference; converts C1 to (0, 2).
1909             #
1910             # Returns: row, column
1911             #
1912             sub _cell_to_rowcol {
1913              
1914 108     108   156 my $self = shift;
1915 108         235 my $cell = shift;
1916              
1917 108         359 $cell =~ /\$?([A-I]?[A-Z])\$?(\d+)/;
1918              
1919 108         206 my $col = $1;
1920 108         216 my $row = $2;
1921              
1922             # Convert base26 column string to number
1923             # All your Base are belong to us.
1924 108         351 my @chars = split //, $col;
1925 108         205 my $expn = 0;
1926 108         169 $col = 0;
1927              
1928 108         252 while (@chars) {
1929 112         220 my $char = pop(@chars); # LS char first
1930 112         353 $col += (ord($char) -ord('A') +1) * (26**$expn);
1931 112         289 $expn++;
1932             }
1933              
1934             # Convert 1-index to zero-index
1935 108         221 $row--;
1936 108         128 $col--;
1937              
1938 108         319 return $row, $col;
1939             }
1940              
1941              
1942             ###############################################################################
1943             #
1944             # _sort_pagebreaks()
1945             #
1946             #
1947             # This is an internal method that is used to filter elements of the array of
1948             # pagebreaks used in the _store_hbreak() and _store_vbreak() methods. It:
1949             # 1. Removes duplicate entries from the list.
1950             # 2. Sorts the list.
1951             # 3. Removes 0 from the list if present.
1952             #
1953             sub _sort_pagebreaks {
1954              
1955 0     0   0 my $self= shift;
1956              
1957 0         0 my %hash;
1958             my @array;
1959              
1960 0         0 @hash{@_} = undef; # Hash slice to remove duplicates
1961 0         0 @array = sort {$a <=> $b} keys %hash; # Numerical sort
  0         0  
1962 0 0       0 shift @array if $array[0] == 0; # Remove zero
1963              
1964             # 1000 vertical pagebreaks appears to be an internal Excel 5 limit.
1965             # It is slightly higher in Excel 97/200, approx. 1026
1966 0 0       0 splice(@array, 1000) if (@array > 1000);
1967              
1968             return @array
1969 0         0 }
1970              
1971              
1972             ###############################################################################
1973             #
1974             # _encode_password($password)
1975             #
1976             # Based on the algorithm provided by Daniel Rentz of OpenOffice.
1977             #
1978             #
1979             sub _encode_password {
1980              
1981 32     32   473 use integer;
  32         150  
  32         297  
1982              
1983 0     0   0 my $self = shift;
1984 0         0 my $plaintext = $_[0];
1985 0         0 my $password;
1986             my $count;
1987 0         0 my @chars;
1988 0         0 my $i = 0;
1989              
1990 0         0 $count = @chars = split //, $plaintext;
1991              
1992 0         0 foreach my $char (@chars) {
1993 0         0 my $low_15;
1994             my $high_15;
1995 0         0 $char = ord($char) << ++$i;
1996 0         0 $low_15 = $char & 0x7fff;
1997 0         0 $high_15 = $char & 0x7fff << 15;
1998 0         0 $high_15 = $high_15 >> 15;
1999 0         0 $char = $low_15 | $high_15;
2000             }
2001              
2002 0         0 $password = 0x0000;
2003 0         0 $password ^= $_ for @chars;
2004 0         0 $password ^= $count;
2005 0         0 $password ^= 0xCE4B;
2006              
2007 0         0 return $password;
2008             }
2009              
2010              
2011             ###############################################################################
2012             #
2013             # outline_settings($visible, $symbols_below, $symbols_right, $auto_style)
2014             #
2015             # This method sets the properties for outlining and grouping. The defaults
2016             # correspond to Excel's defaults.
2017             #
2018             sub outline_settings {
2019              
2020 0     0 0 0 my $self = shift;
2021              
2022 0 0       0 $self->{_outline_on} = defined $_[0] ? $_[0] : 1;
2023 0 0       0 $self->{_outline_below} = defined $_[1] ? $_[1] : 1;
2024 0 0       0 $self->{_outline_right} = defined $_[2] ? $_[2] : 1;
2025 0   0     0 $self->{_outline_style} = $_[3] || 0;
2026              
2027             # Ensure this is a boolean vale for Window2
2028 0 0       0 $self->{_outline_on} = 1 if $self->{_outline_on};
2029             }
2030              
2031              
2032              
2033              
2034             ###############################################################################
2035             ###############################################################################
2036             #
2037             # BIFF RECORDS
2038             #
2039              
2040              
2041             ###############################################################################
2042             #
2043             # write_number($row, $col, $num, $format)
2044             #
2045             # Write a double to the specified row and column (zero indexed).
2046             # An integer can be written as a double. Excel will display an
2047             # integer. $format is optional.
2048             #
2049             # Returns 0 : normal termination
2050             # -1 : insufficient number of arguments
2051             # -2 : row or column out of range
2052             #
2053             sub write_number {
2054              
2055 1     1 0 9 my $self = shift;
2056              
2057             # Check for a cell reference in A1 notation and substitute row and column
2058 1 50       8 if ($_[0] =~ /^\D/) {
2059 0         0 @_ = $self->_substitute_cellref(@_);
2060             }
2061              
2062 1 50       13 if (@_ < 3) { return -1 } # Check the number of args
  0         0  
2063              
2064 1         3 my $record = 0x0203; # Record identifier
2065 1         2 my $length = 0x000E; # Number of bytes to follow
2066              
2067 1         3 my $row = $_[0]; # Zero indexed row
2068 1         2 my $col = $_[1]; # Zero indexed column
2069 1         3 my $num = $_[2];
2070 1         4 my $xf = _XF($self, $row, $col, $_[3]); # The cell format
2071              
2072             # Check that row and col are valid and store max and min values
2073 1 50       5 return -2 if $self->_check_dimensions($row, $col);
2074              
2075 1         5 my $header = pack("vv", $record, $length);
2076 1         4 my $data = pack("vvv", $row, $col, $xf);
2077 1         4 my $xl_double = pack("d", $num);
2078              
2079 1 50       6 if ($self->{_byte_order}) { $xl_double = reverse $xl_double }
  0         0  
2080              
2081             # Store the data or write immediately depending on the compatibility mode.
2082 1 50       5 if ($self->{_compatibility}) {
2083 0         0 $self->{_table}->[$row]->[$col] = $header . $data . $xl_double;
2084             }
2085             else {
2086 1         5 $self->_append($header, $data, $xl_double);
2087             }
2088              
2089 1         4 return 0;
2090             }
2091              
2092              
2093             ###############################################################################
2094             #
2095             # write_string ($row, $col, $string, $format)
2096             #
2097             # Write a string to the specified row and column (zero indexed).
2098             # $format is optional.
2099             # Returns 0 : normal termination
2100             # -1 : insufficient number of arguments
2101             # -2 : row or column out of range
2102             # -3 : long string truncated to max chars
2103             #
2104             sub write_string {
2105              
2106 41     41 0 70 my $self = shift;
2107              
2108             # Check for a cell reference in A1 notation and substitute row and column
2109 41 50       123 if ($_[0] =~ /^\D/) {
2110 0         0 @_ = $self->_substitute_cellref(@_);
2111             }
2112              
2113 41 100       79 if (@_ < 3) { return -1 } # Check the number of args
  1         3  
2114              
2115 40         50 my $record = 0x00FD; # Record identifier
2116 40         48 my $length = 0x000A; # Bytes to follow
2117              
2118 40         61 my $row = $_[0]; # Zero indexed row
2119 40         45 my $col = $_[1]; # Zero indexed column
2120 40         48 my $strlen = length($_[2]);
2121 40         58 my $str = $_[2];
2122 40         134 my $xf = _XF($self, $row, $col, $_[3]); # The cell format
2123 36         59 my $encoding = 0x0;
2124 36         50 my $str_error = 0;
2125              
2126              
2127             # Handle utf8 strings in perl 5.8.
2128 36 50       106 if ($] >= 5.008) {
2129 36         211 require Encode;
2130              
2131 36 50       121 if (Encode::is_utf8($str)) {
2132 0         0 my $tmp = Encode::encode("UTF-16LE", $str);
2133 0         0 return $self->write_utf16le_string($row, $col, $tmp, $_[3]);
2134             }
2135             }
2136              
2137              
2138             # Check that row and col are valid and store max and min values
2139 36 100       94 return -2 if $self->_check_dimensions($row, $col);
2140              
2141             # Limit the string to the max number of chars.
2142 34 50       83 if ($strlen > 32767) {
2143 0         0 $str = substr($str, 0, 32767);
2144 0         0 $str_error = -3;
2145             }
2146              
2147              
2148             # Prepend the string with the type.
2149 34         112 my $str_header = pack("vC", length($str), $encoding);
2150 34         67 $str = $str_header . $str;
2151              
2152              
2153 34 100       40 if (not exists ${$self->{_str_table}}->{$str}) {
  34         109  
2154 5         9 ${$self->{_str_table}}->{$str} = ${$self->{_str_unique}}++;
  5         16  
  5         14  
2155             }
2156              
2157              
2158 34         46 ${$self->{_str_total}}++;
  34         53  
2159              
2160              
2161 34         73 my $header = pack("vv", $record, $length);
2162 34         73 my $data = pack("vvvV", $row, $col, $xf, ${$self->{_str_table}}->{$str});
  34         99  
2163              
2164              
2165             # Store the data or write immediately depending on the compatibility mode.
2166 34 100       81 if ($self->{_compatibility}) {
2167 12         42 $self->{_table}->[$row]->[$col] = $header . $data;
2168             }
2169             else {
2170 22         56 $self->_append($header, $data);
2171             }
2172              
2173 34         98 return $str_error;
2174             }
2175              
2176              
2177             ###############################################################################
2178             #
2179             # write_blank($row, $col, $format)
2180             #
2181             # Write a blank cell to the specified row and column (zero indexed).
2182             # A blank cell is used to specify formatting without adding a string
2183             # or a number.
2184             #
2185             # A blank cell without a format serves no purpose. Therefore, we don't write
2186             # a BLANK record unless a format is specified. This is mainly an optimisation
2187             # for the write_row() and write_col() methods.
2188             #
2189             # Returns 0 : normal termination (including no format)
2190             # -1 : insufficient number of arguments
2191             # -2 : row or column out of range
2192             #
2193             sub write_blank {
2194              
2195 14     14 0 24 my $self = shift;
2196              
2197             # Check for a cell reference in A1 notation and substitute row and column
2198 14 50       43 if ($_[0] =~ /^\D/) {
2199 0         0 @_ = $self->_substitute_cellref(@_);
2200             }
2201              
2202             # Check the number of args
2203 14 50       31 return -1 if @_ < 2;
2204              
2205             # Don't write a blank cell unless it has a format
2206 14 50       30 return 0 if not defined $_[2];
2207              
2208              
2209 14         18 my $record = 0x0201; # Record identifier
2210 14         15 my $length = 0x0006; # Number of bytes to follow
2211              
2212 14         18 my $row = $_[0]; # Zero indexed row
2213 14         14 my $col = $_[1]; # Zero indexed column
2214 14         30 my $xf = _XF($self, $row, $col, $_[2]); # The cell format
2215              
2216             # Check that row and col are valid and store max and min values
2217 14 50       32 return -2 if $self->_check_dimensions($row, $col);
2218              
2219 14         29 my $header = pack("vv", $record, $length);
2220 14         23 my $data = pack("vvv", $row, $col, $xf);
2221              
2222             # Store the data or write immediately depending on the compatibility mode.
2223 14 50       46 if ($self->{_compatibility}) {
2224 0         0 $self->{_table}->[$row]->[$col] = $header . $data;
2225             }
2226             else {
2227 14         33 $self->_append($header, $data);
2228             }
2229              
2230 14         39 return 0;
2231             }
2232              
2233              
2234             ###############################################################################
2235             #
2236             # write_formula($row, $col, $formula, $format, $value)
2237             #
2238             # Write a formula to the specified row and column (zero indexed).
2239             # The textual representation of the formula is passed to the parser in
2240             # Formula.pm which returns a packed binary string.
2241             #
2242             # $format is optional.
2243             #
2244             # $value is an optional result of the formula that can be supplied by the user.
2245             #
2246             # Returns 0 : normal termination
2247             # -1 : insufficient number of arguments
2248             # -2 : row or column out of range
2249             #
2250             sub write_formula {
2251              
2252 1     1 0 8 my $self = shift;
2253              
2254             # Check for a cell reference in A1 notation and substitute row and column
2255 1 50       7 if ($_[0] =~ /^\D/) {
2256 0         0 @_ = $self->_substitute_cellref(@_);
2257             }
2258              
2259 1 50       5 if (@_ < 3) { return -1 } # Check the number of args
  0         0  
2260              
2261 1 50       5 return if ! defined $_[2];
2262              
2263 1         2 my $record = 0x0006; # Record identifier
2264 1         1 my $length; # Bytes to follow
2265              
2266 1         2 my $row = $_[0]; # Zero indexed row
2267 1         2 my $col = $_[1]; # Zero indexed column
2268 1         2 my $formula = $_[2]; # The formula text string
2269 1         1 my $value = $_[4]; # The formula value.
2270              
2271              
2272 1         5 my $xf = _XF($self, $row, $col, $_[3]); # The cell format
2273 1         3 my $chn = 0x0000; # Must be zero
2274 1         1 my $is_string = 0; # Formula evaluates to str
2275 1         9 my $num; # Current value of formula
2276             my $grbit; # Option flags
2277              
2278              
2279             # Excel normally stores the last calculated value of the formula in $num.
2280             # Clearly we are not in a position to calculate this "a priori". Instead
2281             # we set $num to zero and set the option flags in $grbit to ensure
2282             # automatic calculation of the formula when the file is opened.
2283             # As a workaround for some non-Excel apps we also allow the user to
2284             # specify the result of the formula.
2285             #
2286 1         5 ($num, $grbit, $is_string) = $self->_encode_formula_result($value);
2287              
2288              
2289             # Check that row and col are valid and store max and min values
2290 1 50       4 return -2 if $self->_check_dimensions($row, $col);
2291              
2292             # Strip the = sign at the beginning of the formula string
2293 1         4 $formula =~ s(^=)();
2294              
2295 1         3 my $tmp = $formula;
2296              
2297             # Parse the formula using the parser in Formula.pm
2298 1         2 my $parser = $self->{_parser};
2299              
2300             # In order to raise formula errors from the point of view of the calling
2301             # program we use an eval block and re-raise the error from here.
2302             #
2303 1         2 eval { $formula = $parser->parse_formula($formula) };
  1         6  
2304              
2305 1 50       5 if ($@) {
2306 0         0 $@ =~ s/\n$//; # Strip the \n used in the Formula.pm die()
2307 0         0 croak $@; # Re-raise the error
2308             }
2309              
2310              
2311 1         3 my $formlen = length($formula); # Length of the binary string
2312 1         2 $length = 0x16 + $formlen; # Length of the record data
2313              
2314 1         4 my $header = pack("vv", $record, $length);
2315 1         3 my $data = pack("vvv", $row, $col, $xf);
2316 1         3 $data .= $num;
2317 1         5 $data .= pack("vVv", $grbit, $chn, $formlen);
2318              
2319             # The STRING record if the formula evaluates to a string.
2320 1         2 my $string = '';
2321 1 50       4 $string = $self->_get_formula_string($value) if $is_string;
2322              
2323              
2324             # Store the data or write immediately depending on the compatibility mode.
2325 1 50       5 if ($self->{_compatibility}) {
2326 0         0 $self->{_table}->[$row]->[$col] = $header . $data . $formula . $string;
2327             }
2328             else {
2329 1         6 $self->_append($header, $data, $formula, $string);
2330             }
2331              
2332 1         5 return 0;
2333             }
2334              
2335              
2336             ###############################################################################
2337             #
2338             # _encode_formula_result()
2339             #
2340             # Encode the user supplied result for a formula.
2341             #
2342             sub _encode_formula_result {
2343              
2344 2     2   5 my $self = shift;
2345              
2346 2         5 my $value = $_[0]; # Result to be encoded.
2347 2         3 my $is_string = 0; # Formula evaluates to str.
2348 2         3 my $num; # Current value of formula.
2349             my $grbit; # Option flags.
2350              
2351 2 50       8 if (not defined $value) {
2352 2         3 $grbit = 0x03;
2353 2         4 $num = pack "d", 0;
2354             }
2355             else {
2356             # The user specified the result of the formula. We turn off the recalc
2357             # flag and check the result type.
2358 0         0 $grbit = 0x00;
2359              
2360 0 0       0 if ($value =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) {
2361             # Value is a number.
2362 0         0 $num = pack "d", $value;
2363             }
2364             else {
2365              
2366 0         0 my %bools = (
2367             'TRUE' => [1, 1],
2368             'FALSE' => [1, 0],
2369             '#NULL!' => [2, 0],
2370             '#DIV/0!' => [2, 7],
2371             '#VALUE!' => [2, 15],
2372             '#REF!' => [2, 23],
2373             '#NAME?' => [2, 29],
2374             '#NUM!' => [2, 36],
2375             '#N/A' => [2, 42],
2376             );
2377              
2378 0 0       0 if (exists $bools{$value}) {
2379             # Value is a boolean.
2380 0         0 $num = pack "vvvv", $bools{$value}->[0],
2381             $bools{$value}->[1],
2382             0,
2383             0xFFFF;
2384             }
2385             else {
2386             # Value is a string.
2387 0         0 $num = pack "vvvv", 0,
2388             0,
2389             0,
2390             0xFFFF;
2391 0         0 $is_string = 1;
2392             }
2393             }
2394             }
2395              
2396 2         7 return ($num, $grbit, $is_string);
2397             }
2398              
2399              
2400             ###############################################################################
2401             #
2402             # _get_formula_string()
2403             #
2404             # Pack the string value when a formula evaluates to a string. The value cannot
2405             # be calculated by the module and thus must be supplied by the user.
2406             #
2407             sub _get_formula_string {
2408              
2409 0     0   0 my $self = shift;
2410              
2411 0         0 my $record = 0x0207; # Record identifier
2412 0         0 my $length = 0x00; # Bytes to follow
2413 0         0 my $string = $_[0]; # Formula string.
2414 0         0 my $strlen = length $_[0]; # Length of the formula string (chars).
2415 0         0 my $encoding = 0; # String encoding.
2416              
2417              
2418             # Handle utf8 strings in perl 5.8.
2419 0 0       0 if ($] >= 5.008) {
2420 0         0 require Encode;
2421              
2422 0 0       0 if (Encode::is_utf8($string)) {
2423 0         0 $string = Encode::encode("UTF-16BE", $string);
2424 0         0 $encoding = 1;
2425             }
2426             }
2427              
2428              
2429 0         0 $length = 0x03 + length $string; # Length of the record data
2430              
2431 0         0 my $header = pack("vv", $record, $length);
2432 0         0 my $data = pack("vC", $strlen, $encoding);
2433              
2434 0         0 return $header . $data . $string;
2435             }
2436              
2437              
2438             ###############################################################################
2439             #
2440             # store_formula($formula)
2441             #
2442             # Pre-parse a formula. This is used in conjunction with repeat_formula()
2443             # to repetitively rewrite a formula without re-parsing it.
2444             #
2445             sub store_formula {
2446              
2447 4     4 0 14 my $self = shift;
2448 4         6 my $formula = $_[0]; # The formula text string
2449              
2450             # Strip the = sign at the beginning of the formula string
2451 4         22 $formula =~ s(^=)();
2452              
2453             # Parse the formula using the parser in Formula.pm
2454 4         9 my $parser = $self->{_parser};
2455              
2456             # In order to raise formula errors from the point of view of the calling
2457             # program we use an eval block and re-raise the error from here.
2458             #
2459 4         6 my @tokens;
2460 4         19 eval { @tokens = $parser->parse_formula($formula) };
  4         22  
2461              
2462 4 50       26 if ($@) {
2463 0         0 $@ =~ s/\n$//; # Strip the \n used in the Formula.pm die()
2464 0         0 croak $@; # Re-raise the error
2465             }
2466              
2467              
2468             # Return the parsed tokens in an anonymous array
2469 4         28 return [@tokens];
2470             }
2471              
2472              
2473             ###############################################################################
2474             #
2475             # repeat_formula($row, $col, $formula, $format, ($pattern => $replacement,...))
2476             #
2477             # Write a formula to the specified row and column (zero indexed) by
2478             # substituting $pattern $replacement pairs in the $formula created via
2479             # store_formula(). This allows the user to repetitively rewrite a formula
2480             # without the significant overhead of parsing.
2481             #
2482             # Returns 0 : normal termination
2483             # -1 : insufficient number of arguments
2484             # -2 : row or column out of range
2485             #
2486             sub repeat_formula {
2487              
2488 1     1 0 9 my $self = shift;
2489              
2490             # Check for a cell reference in A1 notation and substitute row and column
2491 1 50       5 if ($_[0] =~ /^\D/) {
2492 0         0 @_ = $self->_substitute_cellref(@_);
2493             }
2494              
2495 1 50       4 if (@_ < 2) { return -1 } # Check the number of args
  0         0  
2496              
2497 1         2 my $record = 0x0006; # Record identifier
2498 1         2 my $length; # Bytes to follow
2499              
2500 1         1 my $row = shift; # Zero indexed row
2501 1         2 my $col = shift; # Zero indexed column
2502 1         2 my $formula_ref = shift; # Array ref with formula tokens
2503 1         3 my $format = shift; # XF format
2504 1         3 my @pairs = @_; # Pattern/replacement pairs
2505              
2506              
2507             # Enforce an even number of arguments in the pattern/replacement list
2508 1 50       5 croak "Odd number of elements in pattern/replacement list" if @pairs %2;
2509              
2510             # Check that $formula is an array ref
2511 1 50       1078 croak "Not a valid formula" if ref $formula_ref ne 'ARRAY';
2512              
2513 1         8 my @tokens = @$formula_ref;
2514              
2515             # Ensure that there are tokens to substitute
2516 1 50       4 croak "No tokens in formula" unless @tokens;
2517              
2518              
2519             # As a temporary and undocumented measure we allow the user to specify the
2520             # result of the formula by appending a result => $value pair to the end
2521             # of the arguments.
2522 1         2 my $value = undef;
2523 1 50 33     12 if (@pairs && $pairs[-2] eq 'result') {
2524 0         0 $value = pop @pairs;
2525 0         0 pop @pairs;
2526             }
2527              
2528              
2529 1         4 while (@pairs) {
2530 1         2 my $pattern = shift @pairs;
2531 1         2 my $replace = shift @pairs;
2532              
2533 1         2 foreach my $token (@tokens) {
2534 2 100       34 last if $token =~ s/$pattern/$replace/;
2535             }
2536             }
2537              
2538              
2539             # Change the parameters in the formula cached by the Formula.pm object
2540 1         3 my $parser = $self->{_parser};
2541 1         5 my $formula = $parser->parse_tokens(@tokens);
2542              
2543 1 50       6 croak "Unrecognised token in formula" unless defined $formula;
2544              
2545              
2546 1         4 my $xf = _XF($self, $row, $col, $format); # The cell format
2547 1         2 my $chn = 0x0000; # Must be zero
2548 1         1 my $is_string = 0; # Formula evaluates to str
2549 1         1 my $num; # Current value of formula
2550             my $grbit; # Option flags
2551              
2552             # Excel normally stores the last calculated value of the formula in $num.
2553             # Clearly we are not in a position to calculate this "a priori". Instead
2554             # we set $num to zero and set the option flags in $grbit to ensure
2555             # automatic calculation of the formula when the file is opened.
2556             # As a workaround for some non-Excel apps we also allow the user to
2557             # specify the result of the formula.
2558             #
2559 1         5 ($num, $grbit, $is_string) = $self->_encode_formula_result($value);
2560              
2561             # Check that row and col are valid and store max and min values
2562 1 50       5 return -2 if $self->_check_dimensions($row, $col);
2563              
2564              
2565 1         2 my $formlen = length($formula); # Length of the binary string
2566 1         2 $length = 0x16 + $formlen; # Length of the record data
2567              
2568 1         3 my $header = pack("vv", $record, $length);
2569 1         2 my $data = pack("vvv", $row, $col, $xf);
2570 1         3 $data .= $num;
2571 1         4 $data .= pack("vVv", $grbit, $chn, $formlen);
2572              
2573              
2574             # The STRING record if the formula evaluates to a string.
2575 1         4 my $string = '';
2576 1 50       4 $string = $self->_get_formula_string($value) if $is_string;
2577              
2578              
2579             # Store the data or write immediately depending on the compatibility mode.
2580 1 50       4 if ($self->{_compatibility}) {
2581 0         0 $self->{_table}->[$row]->[$col] = $header . $data . $formula . $string;
2582             }
2583             else {
2584 1         5 $self->_append($header, $data, $formula, $string);
2585             }
2586              
2587 1         7 return 0;
2588             }
2589              
2590              
2591             ###############################################################################
2592             #
2593             # write_url($row, $col, $url, $string, $format)
2594             #
2595             # Write a hyperlink. This is comprised of two elements: the visible label and
2596             # the invisible link. The visible label is the same as the link unless an
2597             # alternative string is specified.
2598             #
2599             # The parameters $string and $format are optional and their order is
2600             # interchangeable for backward compatibility reasons.
2601             #
2602             # The hyperlink can be to a http, ftp, mail, internal sheet, or external
2603             # directory url.
2604             #
2605             # Returns 0 : normal termination
2606             # -1 : insufficient number of arguments
2607             # -2 : row or column out of range
2608             # -3 : long string truncated to 255 chars
2609             #
2610             sub write_url {
2611              
2612 1     1 0 8 my $self = shift;
2613              
2614             # Check for a cell reference in A1 notation and substitute row and column
2615 1 50       7 if ($_[0] =~ /^\D/) {
2616 0         0 @_ = $self->_substitute_cellref(@_);
2617             }
2618              
2619             # Check the number of args
2620 1 50       5 return -1 if @_ < 3;
2621              
2622             # Add start row and col to arg list
2623 1         6 return $self->write_url_range($_[0], $_[1], @_);
2624             }
2625              
2626              
2627             ###############################################################################
2628             #
2629             # write_url_range($row1, $col1, $row2, $col2, $url, $string, $format)
2630             #
2631             # This is the more general form of write_url(). It allows a hyperlink to be
2632             # written to a range of cells. This function also decides the type of hyperlink
2633             # to be written. These are either, Web (http, ftp, mailto), Internal
2634             # (Sheet1!A1) or external ('c:\temp\foo.xls#Sheet1!A1').
2635             #
2636             # See also write_url() above for a general description and return values.
2637             #
2638             sub write_url_range {
2639              
2640 1     1 0 3 my $self = shift;
2641              
2642             # Check for a cell reference in A1 notation and substitute row and column
2643 1 50       5 if ($_[0] =~ /^\D/) {
2644 0         0 @_ = $self->_substitute_cellref(@_);
2645             }
2646              
2647             # Check the number of args
2648 1 50       11 return -1 if @_ < 5;
2649              
2650              
2651             # Reverse the order of $string and $format if necessary. We work on a copy
2652             # in order to protect the callers args. We don't use "local @_" in case of
2653             # perl50005 threads.
2654             #
2655 1         4 my @args = @_;
2656              
2657 1 50       4 ($args[5], $args[6]) = ($args[6], $args[5]) if ref $args[5];
2658              
2659 1         3 my $url = $args[4];
2660              
2661              
2662             # Check for internal/external sheet links or default to web link
2663 1 50       11 return $self->_write_url_internal(@args) if $url =~ m[^internal:];
2664 1 50       5 return $self->_write_url_external(@args) if $url =~ m[^external:];
2665 1         4 return $self->_write_url_web(@args);
2666             }
2667              
2668              
2669             ###############################################################################
2670             #
2671             # _write_url_web($row1, $col1, $row2, $col2, $url, $string, $format)
2672             #
2673             # Used to write http, ftp and mailto hyperlinks.
2674             # The link type ($options) is 0x03 is the same as absolute dir ref without
2675             # sheet. However it is differentiated by the $unknown2 data stream.
2676             #
2677             # See also write_url() above for a general description and return values.
2678             #
2679             sub _write_url_web {
2680              
2681 1     1   4 my $self = shift;
2682              
2683 1         3 my $record = 0x01B8; # Record identifier
2684 1         2 my $length = 0x00000; # Bytes to follow
2685              
2686 1         3 my $row1 = $_[0]; # Start row
2687 1         1 my $col1 = $_[1]; # Start column
2688 1         3 my $row2 = $_[2]; # End row
2689 1         3 my $col2 = $_[3]; # End column
2690 1         3 my $url = $_[4]; # URL string
2691 1         2 my $str = $_[5]; # Alternative label
2692 1   33     9 my $xf = $_[6] || $self->{_url_format};# The cell format
2693              
2694              
2695             # Write the visible label but protect against url recursion in write().
2696 1 50       6 $str = $url unless defined $str;
2697 1         2 $self->{_writing_url} = 1;
2698 1         5 my $error = $self->write($row1, $col1, $str, $xf);
2699 1         3 $self->{_writing_url} = 0;
2700 1 50       4 return $error if $error == -2;
2701              
2702              
2703             # Pack the undocumented parts of the hyperlink stream
2704 1         4 my $unknown1 = pack("H*", "D0C9EA79F9BACE118C8200AA004BA90B02000000");
2705 1         2 my $unknown2 = pack("H*", "E0C9EA79F9BACE118C8200AA004BA90B");
2706              
2707              
2708             # Pack the option flags
2709 1         7 my $options = pack("V", 0x03);
2710              
2711              
2712             # URL encoding.
2713 1         3 my $encoding = 0;
2714              
2715             # Convert an Utf8 URL type and to a null terminated wchar string.
2716 1 50       4 if ($] >= 5.008) {
2717 1         5 require Encode;
2718              
2719 1 50       6 if (Encode::is_utf8($url)) {
2720 0         0 $url = Encode::encode("UTF-16LE", $url);
2721 0         0 $url .= "\0\0"; # URL is null terminated.
2722 0         0 $encoding = 1;
2723             }
2724             }
2725              
2726             # Convert an Ascii URL type and to a null terminated wchar string.
2727 1 50       4 if ($encoding == 0) {
2728 1         15 $url .= "\0";
2729 1         12 $url = pack 'v*', unpack 'c*', $url;
2730             }
2731              
2732              
2733             # Pack the length of the URL
2734 1         4 my $url_len = pack("V", length($url));
2735              
2736              
2737             # Calculate the data length
2738 1         2 $length = 0x34 + length($url);
2739              
2740              
2741             # Pack the header data
2742 1         4 my $header = pack("vv", $record, $length);
2743 1         2 my $data = pack("vvvv", $row1, $row2, $col1, $col2);
2744              
2745              
2746             # Write the packed data
2747 1         5 $self->_append( $header,
2748             $data,
2749             $unknown1,
2750             $options,
2751             $unknown2,
2752             $url_len,
2753             $url);
2754              
2755 1         4 return $error;
2756             }
2757              
2758              
2759             ###############################################################################
2760             #
2761             # _write_url_internal($row1, $col1, $row2, $col2, $url, $string, $format)
2762             #
2763             # Used to write internal reference hyperlinks such as "Sheet1!A1".
2764             #
2765             # See also write_url() above for a general description and return values.
2766             #
2767             sub _write_url_internal {
2768              
2769 0     0   0 my $self = shift;
2770              
2771 0         0 my $record = 0x01B8; # Record identifier
2772 0         0 my $length = 0x00000; # Bytes to follow
2773              
2774 0         0 my $row1 = $_[0]; # Start row
2775 0         0 my $col1 = $_[1]; # Start column
2776 0         0 my $row2 = $_[2]; # End row
2777 0         0 my $col2 = $_[3]; # End column
2778 0         0 my $url = $_[4]; # URL string
2779 0         0 my $str = $_[5]; # Alternative label
2780 0   0     0 my $xf = $_[6] || $self->{_url_format};# The cell format
2781              
2782             # Strip URL type
2783 0         0 $url =~ s[^internal:][];
2784              
2785              
2786             # Write the visible label but protect against url recursion in write().
2787 0 0       0 $str = $url unless defined $str;
2788 0         0 $self->{_writing_url} = 1;
2789 0         0 my $error = $self->write($row1, $col1, $str, $xf);
2790 0         0 $self->{_writing_url} = 0;
2791 0 0       0 return $error if $error == -2;
2792              
2793              
2794             # Pack the undocumented parts of the hyperlink stream
2795 0         0 my $unknown1 = pack("H*", "D0C9EA79F9BACE118C8200AA004BA90B02000000");
2796              
2797              
2798             # Pack the option flags
2799 0         0 my $options = pack("V", 0x08);
2800              
2801              
2802             # URL encoding.
2803 0         0 my $encoding = 0;
2804              
2805              
2806             # Convert an Utf8 URL type and to a null terminated wchar string.
2807 0 0       0 if ($] >= 5.008) {
2808 0         0 require Encode;
2809              
2810 0 0       0 if (Encode::is_utf8($url)) {
2811             # Quote sheet name if not already, i.e., Sheet!A1 to 'Sheet!A1'.
2812 0 0       0 $url =~ s/^(.+)!/'$1'!/ if not $url =~ /^'/;
2813              
2814 0         0 $url = Encode::encode("UTF-16LE", $url);
2815 0         0 $url .= "\0\0"; # URL is null terminated.
2816 0         0 $encoding = 1;
2817             }
2818             }
2819              
2820              
2821             # Convert an Ascii URL type and to a null terminated wchar string.
2822 0 0       0 if ($encoding == 0) {
2823 0         0 $url .= "\0";
2824 0         0 $url = pack 'v*', unpack 'c*', $url;
2825             }
2826              
2827              
2828             # Pack the length of the URL as chars (not wchars)
2829 0         0 my $url_len = pack("V", int(length($url)/2));
2830              
2831              
2832             # Calculate the data length
2833 0         0 $length = 0x24 + length($url);
2834              
2835              
2836             # Pack the header data
2837 0         0 my $header = pack("vv", $record, $length);
2838 0         0 my $data = pack("vvvv", $row1, $row2, $col1, $col2);
2839              
2840              
2841             # Write the packed data
2842 0         0 $self->_append( $header,
2843             $data,
2844             $unknown1,
2845             $options,
2846             $url_len,
2847             $url);
2848              
2849 0         0 return $error;
2850             }
2851              
2852              
2853             ###############################################################################
2854             #
2855             # _write_url_external($row1, $col1, $row2, $col2, $url, $string, $format)
2856             #
2857             # Write links to external directory names such as 'c:\foo.xls',
2858             # c:\foo.xls#Sheet1!A1', '../../foo.xls'. and '../../foo.xls#Sheet1!A1'.
2859             #
2860             # Note: Excel writes some relative links with the $dir_long string. We ignore
2861             # these cases for the sake of simpler code.
2862             #
2863             # See also write_url() above for a general description and return values.
2864             #
2865             sub _write_url_external {
2866              
2867 0     0   0 my $self = shift;
2868              
2869             # Network drives are different. We will handle them separately
2870             # MS/Novell network drives and shares start with \\
2871 0 0       0 return $self->_write_url_external_net(@_) if $_[4] =~ m[^external:\\\\];
2872              
2873              
2874 0         0 my $record = 0x01B8; # Record identifier
2875 0         0 my $length = 0x00000; # Bytes to follow
2876              
2877 0         0 my $row1 = $_[0]; # Start row
2878 0         0 my $col1 = $_[1]; # Start column
2879 0         0 my $row2 = $_[2]; # End row
2880 0         0 my $col2 = $_[3]; # End column
2881 0         0 my $url = $_[4]; # URL string
2882 0         0 my $str = $_[5]; # Alternative label
2883 0   0     0 my $xf = $_[6] || $self->{_url_format};# The cell format
2884              
2885              
2886             # Strip URL type and change Unix dir separator to Dos style (if needed)
2887             #
2888 0         0 $url =~ s[^external:][];
2889 0         0 $url =~ s[/][\\]g;
2890              
2891              
2892             # Write the visible label but protect against url recursion in write().
2893 0 0       0 ($str = $url) =~ s[\#][ - ] unless defined $str;
2894 0         0 $self->{_writing_url} = 1;
2895 0         0 my $error = $self->write($row1, $col1, $str, $xf);
2896 0         0 $self->{_writing_url} = 0;
2897 0 0       0 return $error if $error == -2;
2898              
2899              
2900             # Determine if the link is relative or absolute:
2901             # Absolute if link starts with DOS drive specifier like C:
2902             # Otherwise default to 0x00 for relative link.
2903             #
2904 0         0 my $absolute = 0x00;
2905 0 0       0 $absolute = 0x02 if $url =~ m/^[A-Za-z]:/;
2906              
2907              
2908             # Determine if the link contains a sheet reference and change some of the
2909             # parameters accordingly.
2910             # Split the dir name and sheet name (if it exists)
2911             #
2912 0         0 my ($dir_long , $sheet) = split /\#/, $url;
2913 0         0 my $link_type = 0x01 | $absolute;
2914 0         0 my $sheet_len;
2915              
2916 0 0       0 if (defined $sheet) {
2917 0         0 $link_type |= 0x08;
2918 0         0 $sheet_len = pack("V", length($sheet) + 0x01);
2919 0         0 $sheet = join("\0", split('', $sheet));
2920 0         0 $sheet .= "\0\0\0";
2921             }
2922             else {
2923 0         0 $sheet_len = '';
2924 0         0 $sheet = '';
2925             }
2926              
2927              
2928             # Pack the link type
2929 0         0 $link_type = pack("V", $link_type);
2930              
2931              
2932             # Calculate the up-level dir count e.g. (..\..\..\ == 3)
2933 0         0 my $up_count = 0;
2934 0         0 $up_count++ while $dir_long =~ s[^\.\.\\][];
2935 0         0 $up_count = pack("v", $up_count);
2936              
2937              
2938             # Store the short dos dir name (null terminated)
2939 0         0 my $dir_short = $dir_long . "\0";
2940              
2941              
2942             # Store the long dir name as a wchar string (non-null terminated)
2943 0         0 $dir_long = join("\0", split('', $dir_long));
2944 0         0 $dir_long = $dir_long . "\0";
2945              
2946              
2947             # Pack the lengths of the dir strings
2948 0         0 my $dir_short_len = pack("V", length $dir_short );
2949 0         0 my $dir_long_len = pack("V", length $dir_long );
2950 0         0 my $stream_len = pack("V", length($dir_long) + 0x06);
2951              
2952              
2953             # Pack the undocumented parts of the hyperlink stream
2954 0         0 my $unknown1 =pack("H*",'D0C9EA79F9BACE118C8200AA004BA90B02000000' );
2955 0         0 my $unknown2 =pack("H*",'0303000000000000C000000000000046' );
2956 0         0 my $unknown3 =pack("H*",'FFFFADDE000000000000000000000000000000000000000');
2957 0         0 my $unknown4 =pack("v", 0x03 );
2958              
2959              
2960             # Pack the main data stream
2961 0         0 my $data = pack("vvvv", $row1, $row2, $col1, $col2) .
2962             $unknown1 .
2963             $link_type .
2964             $unknown2 .
2965             $up_count .
2966             $dir_short_len.
2967             $dir_short .
2968             $unknown3 .
2969             $stream_len .
2970             $dir_long_len .
2971             $unknown4 .
2972             $dir_long .
2973             $sheet_len .
2974             $sheet ;
2975              
2976              
2977             # Pack the header data
2978 0         0 $length = length $data;
2979 0         0 my $header = pack("vv", $record, $length);
2980              
2981              
2982             # Write the packed data
2983 0         0 $self->_append($header, $data);
2984              
2985 0         0 return $error;
2986             }
2987              
2988              
2989              
2990              
2991             ###############################################################################
2992             #
2993             # _write_url_external_net($row1, $col1, $row2, $col2, $url, $string, $format)
2994             #
2995             # Write links to external MS/Novell network drives and shares such as
2996             # '//NETWORK/share/foo.xls' and '//NETWORK/share/foo.xls#Sheet1!A1'.
2997             #
2998             # See also write_url() above for a general description and return values.
2999             #
3000             sub _write_url_external_net {
3001              
3002 0     0   0 my $self = shift;
3003              
3004 0         0 my $record = 0x01B8; # Record identifier
3005 0         0 my $length = 0x00000; # Bytes to follow
3006              
3007 0         0 my $row1 = $_[0]; # Start row
3008 0         0 my $col1 = $_[1]; # Start column
3009 0         0 my $row2 = $_[2]; # End row
3010 0         0 my $col2 = $_[3]; # End column
3011 0         0 my $url = $_[4]; # URL string
3012 0         0 my $str = $_[5]; # Alternative label
3013 0   0     0 my $xf = $_[6] || $self->{_url_format};# The cell format
3014              
3015              
3016             # Strip URL type and change Unix dir separator to Dos style (if needed)
3017             #
3018 0         0 $url =~ s[^external:][];
3019 0         0 $url =~ s[/][\\]g;
3020              
3021              
3022             # Write the visible label but protect against url recursion in write().
3023 0 0       0 ($str = $url) =~ s[\#][ - ] unless defined $str;
3024 0         0 $self->{_writing_url} = 1;
3025 0         0 my $error = $self->write($row1, $col1, $str, $xf);
3026 0         0 $self->{_writing_url} = 0;
3027 0 0       0 return $error if $error == -2;
3028              
3029              
3030             # Determine if the link contains a sheet reference and change some of the
3031             # parameters accordingly.
3032             # Split the dir name and sheet name (if it exists)
3033             #
3034 0         0 my ($dir_long , $sheet) = split /\#/, $url;
3035 0         0 my $link_type = 0x0103; # Always absolute
3036 0         0 my $sheet_len;
3037              
3038 0 0       0 if (defined $sheet) {
3039 0         0 $link_type |= 0x08;
3040 0         0 $sheet_len = pack("V", length($sheet) + 0x01);
3041 0         0 $sheet = join("\0", split('', $sheet));
3042 0         0 $sheet .= "\0\0\0";
3043             }
3044             else {
3045 0         0 $sheet_len = '';
3046 0         0 $sheet = '';
3047             }
3048              
3049             # Pack the link type
3050 0         0 $link_type = pack("V", $link_type);
3051              
3052              
3053             # Make the string null terminated
3054 0         0 $dir_long = $dir_long . "\0";
3055              
3056              
3057             # Pack the lengths of the dir string
3058 0         0 my $dir_long_len = pack("V", length $dir_long);
3059              
3060              
3061             # Store the long dir name as a wchar string (non-null terminated)
3062 0         0 $dir_long = join("\0", split('', $dir_long));
3063 0         0 $dir_long = $dir_long . "\0";
3064              
3065              
3066             # Pack the undocumented part of the hyperlink stream
3067 0         0 my $unknown1 = pack("H*",'D0C9EA79F9BACE118C8200AA004BA90B02000000');
3068              
3069              
3070             # Pack the main data stream
3071 0         0 my $data = pack("vvvv", $row1, $row2, $col1, $col2) .
3072             $unknown1 .
3073             $link_type .
3074             $dir_long_len .
3075             $dir_long .
3076             $sheet_len .
3077             $sheet ;
3078              
3079              
3080             # Pack the header data
3081 0         0 $length = length $data;
3082 0         0 my $header = pack("vv", $record, $length);
3083              
3084              
3085             # Write the packed data
3086 0         0 $self->_append($header, $data);
3087              
3088 0         0 return $error;
3089             }
3090              
3091              
3092             ###############################################################################
3093             #
3094             # write_date_time ($row, $col, $string, $format)
3095             #
3096             # Write a datetime string in ISO8601 "yyyy-mm-ddThh:mm:ss.ss" format as a
3097             # number representing an Excel date. $format is optional.
3098             #
3099             # Returns 0 : normal termination
3100             # -1 : insufficient number of arguments
3101             # -2 : row or column out of range
3102             # -3 : Invalid date_time, written as string
3103             #
3104             sub write_date_time {
3105              
3106 0     0 0 0 my $self = shift;
3107              
3108             # Check for a cell reference in A1 notation and substitute row and column
3109 0 0       0 if ($_[0] =~ /^\D/) {
3110 0         0 @_ = $self->_substitute_cellref(@_);
3111             }
3112              
3113 0 0       0 if (@_ < 3) { return -1 } # Check the number of args
  0         0  
3114              
3115 0         0 my $row = $_[0]; # Zero indexed row
3116 0         0 my $col = $_[1]; # Zero indexed column
3117 0         0 my $str = $_[2];
3118              
3119              
3120             # Check that row and col are valid and store max and min values
3121 0 0       0 return -2 if $self->_check_dimensions($row, $col);
3122              
3123 0         0 my $error = 0;
3124 0         0 my $date_time = $self->convert_date_time($str);
3125              
3126 0 0       0 if (defined $date_time) {
3127 0         0 $error = $self->write_number($row, $col, $date_time, $_[3]);
3128             }
3129             else {
3130             # The date isn't valid so write it as a string.
3131 0         0 $self->write_string($row, $col, $str, $_[3]);
3132 0         0 $error = -3;
3133             }
3134 0         0 return $error;
3135             }
3136              
3137              
3138              
3139             ###############################################################################
3140             #
3141             # convert_date_time($date_time_string)
3142             #
3143             # The function takes a date and time in ISO8601 "yyyy-mm-ddThh:mm:ss.ss" format
3144             # and converts it to a decimal number representing a valid Excel date.
3145             #
3146             # Dates and times in Excel are represented by real numbers. The integer part of
3147             # the number stores the number of days since the epoch and the fractional part
3148             # stores the percentage of the day in seconds. The epoch can be either 1900 or
3149             # 1904.
3150             #
3151             # Parameter: Date and time string in one of the following formats:
3152             # yyyy-mm-ddThh:mm:ss.ss # Standard
3153             # yyyy-mm-ddT # Date only
3154             # Thh:mm:ss.ss # Time only
3155             #
3156             # Returns:
3157             # A decimal number representing a valid Excel date, or
3158             # undef if the date is invalid.
3159             #
3160             sub convert_date_time {
3161              
3162 630     630 0 355594 my $self = shift;
3163 630         1222 my $date_time = $_[0];
3164              
3165 630         694 my $days = 0; # Number of days since epoch
3166 630         719 my $seconds = 0; # Time expressed as fraction of 24h hours in seconds
3167              
3168 630         676 my ($year, $month, $day);
3169 0         0 my ($hour, $min, $sec);
3170              
3171              
3172             # Strip leading and trailing whitespace.
3173 630         2190 $date_time =~ s/^\s+//;
3174 630         1041 $date_time =~ s/\s+$//;
3175              
3176             # Check for invalid date char.
3177 630 50       1838 return if $date_time =~ /[^0-9T:\-\.Z]/;
3178              
3179             # Check for "T" after date or before time.
3180 630 50       5332 return unless $date_time =~ /\dT|T\d/;
3181              
3182             # Strip trailing Z in ISO8601 date.
3183 630         852 $date_time =~ s/Z$//;
3184              
3185              
3186             # Split into date and time.
3187 630         1707 my ($date, $time) = split /T/, $date_time;
3188              
3189              
3190             # We allow the time portion of the input DateTime to be optional.
3191 630 100       1506 if ($time ne '') {
3192             # Match hh:mm:ss.sss+ where the seconds are optional
3193 206 50       912 if ($time =~ /^(\d\d):(\d\d)(:(\d\d(\.\d+)?))?/) {
3194 206         363 $hour = $1;
3195 206         390 $min = $2;
3196 206   100     734 $sec = $4 || 0;
3197             }
3198             else {
3199 0         0 return undef; # Not a valid time format.
3200             }
3201              
3202             # Some boundary checks
3203 206 100       550 return if $hour >= 24;
3204 205 100       378 return if $min >= 60;
3205 204 100       502 return if $sec >= 60;
3206              
3207             # Excel expresses seconds as a fraction of the number in 24 hours.
3208 202         433 $seconds = ($hour *60*60 + $min *60 + $sec) / (24 *60 *60);
3209             }
3210              
3211              
3212             # We allow the date portion of the input DateTime to be optional.
3213 626 100       1245 return $seconds if $date eq '';
3214              
3215              
3216             # Match date as yyyy-mm-dd.
3217 624 100       2277 if ($date =~ /^(\d\d\d\d)-(\d\d)-(\d\d)$/) {
3218 622         1113 $year = $1;
3219 622         1597 $month = $2;
3220 622         875 $day = $3;
3221             }
3222             else {
3223 2         7 return undef; # Not a valid date format.
3224             }
3225              
3226             # Set the epoch as 1900 or 1904. Defaults to 1900.
3227 622         989 my $date_1904 = $self->{_1904};
3228              
3229              
3230             # Special cases for Excel.
3231 622 100       1143 if (not $date_1904) {
3232 413 100       1077 return $seconds if $date eq '1899-12-31'; # Excel 1900 epoch
3233 309 100       566 return $seconds if $date eq '1900-01-00'; # Excel 1900 epoch
3234 308 100       595 return 60 + $seconds if $date eq '1900-02-29'; # Excel false leapday
3235             }
3236              
3237              
3238             # We calculate the date by calculating the number of days since the epoch
3239             # and adjust for the number of leap days. We calculate the number of leap
3240             # days by normalising the year in relation to the epoch. Thus the year 2000
3241             # becomes 100 for 4 and 100 year leapdays and 400 for 400 year leapdays.
3242             #
3243 516 100       828 my $epoch = $date_1904 ? 1904 : 1900;
3244 516 100       775 my $offset = $date_1904 ? 4 : 0;
3245 516         573 my $norm = 300;
3246 516         976 my $range = $year -$epoch;
3247              
3248              
3249             # Set month days and check for leap year.
3250 516         1299 my @mdays = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
3251 516         528 my $leap = 0;
3252 516 100 100     3072 $leap = 1 if $year % 4 == 0 and $year % 100 or $year % 400 == 0;
      100        
3253 516 100       941 $mdays[1] = 29 if $leap;
3254              
3255              
3256             # Some boundary checks
3257 516 100 66     1902 return if $year < $epoch or $year > 9999;
3258 510 100 100     2088 return if $month < 1 or $month > 12;
3259 504 100 100     2056 return if $day < 1 or $day > $mdays[$month -1];
3260              
3261             # Accumulate the number of days since the epoch.
3262 498         682 $days = $day; # Add days for current month
3263 498         2274 $days += $mdays[$_] for 0 .. $month -2; # Add days for past months
3264 498         779 $days += $range *365; # Add days for past years
3265 498         841 $days += int(($range) / 4); # Add leapdays
3266 498         646 $days -= int(($range +$offset) /100); # Subtract 100 year leapdays
3267 498         635 $days += int(($range +$offset +$norm)/400); # Add 400 year leapdays
3268 498         472 $days -= $leap; # Already counted above
3269              
3270              
3271             # Adjust for Excel erroneously treating 1900 as a leap year.
3272 498 100 100     1697 $days++ if $date_1904 == 0 and $days > 59;
3273              
3274 498         1769 return $days + $seconds;
3275             }
3276              
3277              
3278              
3279              
3280              
3281             ###############################################################################
3282             #
3283             # set_row($row, $height, $XF, $hidden, $level)
3284             #
3285             # This method is used to set the height and XF format for a row.
3286             # Writes the BIFF record ROW.
3287             #
3288             sub set_row {
3289              
3290 15     15 0 1325 my $self = shift;
3291 15         19 my $record = 0x0208; # Record identifier
3292 15         21 my $length = 0x0010; # Number of bytes to follow
3293              
3294 15         23 my $row = $_[0]; # Row Number
3295 15         21 my $colMic = 0x0000; # First defined column
3296 15         18 my $colMac = 0x0000; # Last defined column
3297 15         16 my $miyRw; # Row height
3298 15         19 my $irwMac = 0x0000; # Used by Excel to optimise loading
3299 15         16 my $reserved = 0x0000; # Reserved
3300 15         20 my $grbit = 0x0000; # Option flags
3301 15         21 my $ixfe; # XF index
3302 15         19 my $height = $_[1]; # Row height
3303 15         22 my $format = $_[2]; # Format object
3304 15   50     64 my $hidden = $_[3] || 0; # Hidden flag
3305 15   50     106 my $level = $_[4] || 0; # Outline level
3306 15   50     60 my $collapsed = $_[5] || 0; # Collapsed row
3307              
3308              
3309 15 50       42 return unless defined $row; # Ensure at least $row is specified.
3310              
3311             # Check that row and col are valid and store max and min values
3312 15 50       48 return -2 if $self->_check_dimensions($row, 0, 0, 1);
3313              
3314             # Check for a format object
3315 15 100       40 if (ref $format) {
3316 1         7 $ixfe = $format->get_xf_index();
3317             }
3318             else {
3319 14         28 $ixfe = 0x0F;
3320             }
3321              
3322              
3323             # Set the row height in units of 1/20 of a point. Note, some heights may
3324             # not be obtained exactly due to rounding in Excel.
3325             #
3326 15 100       31 if (defined $height) {
3327 14         44 $miyRw = $height *20;
3328             }
3329             else {
3330 1         2 $miyRw = 0xff; # The default row height
3331 1         1 $height = 0;
3332             }
3333              
3334              
3335             # Set the limits for the outline levels (0 <= x <= 7).
3336 15 50       36 $level = 0 if $level < 0;
3337 15 50       49 $level = 7 if $level > 7;
3338              
3339 15 50       40 $self->{_outline_row_level} = $level if $level >$self->{_outline_row_level};
3340              
3341              
3342             # Set the options flags.
3343             # 0x10: The fCollapsed flag indicates that the row contains the "+"
3344             # when an outline group is collapsed.
3345             # 0x20: The fDyZero height flag indicates a collapsed or hidden row.
3346             # 0x40: The fUnsynced flag is used to show that the font and row heights
3347             # are not compatible. This is usually the case for WriteExcel.
3348             # 0x80: The fGhostDirty flag indicates that the row has been formatted.
3349             #
3350 15         19 $grbit |= $level;
3351 15 50       36 $grbit |= 0x0010 if $collapsed;
3352 15 50       37 $grbit |= 0x0020 if $hidden;
3353 15         23 $grbit |= 0x0040;
3354 15 100       34 $grbit |= 0x0080 if $format;
3355 15         17 $grbit |= 0x0100;
3356              
3357              
3358 15         42 my $header = pack("vv", $record, $length);
3359 15         40 my $data = pack("vvvvvvvv", $row, $colMic, $colMac, $miyRw,
3360             $irwMac,$reserved, $grbit, $ixfe);
3361              
3362              
3363             # Store the data or write immediately depending on the compatibility mode.
3364 15 100       46 if ($self->{_compatibility}) {
3365 2         12 $self->{_row_data}->{$_[0]} = $header . $data;
3366             }
3367             else {
3368 13         36 $self->_append($header, $data);
3369             }
3370              
3371              
3372             # Store the row sizes for use when calculating image vertices.
3373             # Also store the row formats.
3374 15         61 $self->{_row_sizes}->{$_[0]} = $height;
3375 15 100       65 $self->{_row_formats}->{$_[0]} = $format if defined $format;
3376             }
3377              
3378              
3379              
3380             ###############################################################################
3381             #
3382             # _write_row_default()
3383             #
3384             # Write a default row record, in compatibility mode, for rows that don't have
3385             # user specified values..
3386             #
3387             sub _write_row_default {
3388              
3389 5     5   6 my $self = shift;
3390 5         5 my $record = 0x0208; # Record identifier
3391 5         5 my $length = 0x0010; # Number of bytes to follow
3392              
3393 5         6 my $row = $_[0]; # Row Number
3394 5         5 my $colMic = $_[1]; # First defined column
3395 5         5 my $colMac = $_[2]; # Last defined column
3396 5         5 my $miyRw = 0xFF; # Row height
3397 5         5 my $irwMac = 0x0000; # Used by Excel to optimise loading
3398 5         5 my $reserved = 0x0000; # Reserved
3399 5         3 my $grbit = 0x0100; # Option flags
3400 5         5 my $ixfe = 0x0F; # XF index
3401              
3402 5         8 my $header = pack("vv", $record, $length);
3403 5         9 my $data = pack("vvvvvvvv", $row, $colMic, $colMac, $miyRw,
3404             $irwMac,$reserved, $grbit, $ixfe);
3405              
3406 5         14 $self->_append($header, $data);
3407             }
3408              
3409              
3410             ###############################################################################
3411             #
3412             # _check_dimensions($row, $col, $ignore_row, $ignore_col)
3413             #
3414             # Check that $row and $col are valid and store max and min values for use in
3415             # DIMENSIONS record. See, _store_dimensions().
3416             #
3417             # The $ignore_row/$ignore_col flags is used to indicate that we wish to
3418             # perform the dimension check without storing the value.
3419             #
3420             # The ignore flags are use by set_row() and data_validate.
3421             #
3422             sub _check_dimensions {
3423              
3424 22697     22697   43263 my $self = shift;
3425 22697         28256 my $row = $_[0];
3426 22697         26377 my $col = $_[1];
3427 22697         28116 my $ignore_row = $_[2];
3428 22697         26493 my $ignore_col = $_[3];
3429              
3430              
3431 22697 100       45517 return -2 if not defined $row;
3432 22696 50       58171 return -2 if $row >= $self->{_xls_rowmax};
3433              
3434 22696 100       45875 return -2 if not defined $col;
3435 22695 50       53447 return -2 if $col >= $self->{_xls_colmax};
3436              
3437              
3438 22695 100       42725 if (not $ignore_row) {
3439              
3440 22609 100 100     118381 if (not defined $self->{_dim_rowmin} or $row < $self->{_dim_rowmin}) {
3441 68         143 $self->{_dim_rowmin} = $row;
3442             }
3443              
3444 22609 100 100     138821 if (not defined $self->{_dim_rowmax} or $row > $self->{_dim_rowmax}) {
3445 20535         43462 $self->{_dim_rowmax} = $row;
3446             }
3447             }
3448              
3449 22695 100       44070 if (not $ignore_col) {
3450              
3451 22594 100 100     106383 if (not defined $self->{_dim_colmin} or $col < $self->{_dim_colmin}) {
3452 62         107 $self->{_dim_colmin} = $col;
3453             }
3454              
3455 22594 100 100     124872 if (not defined $self->{_dim_colmax} or $col > $self->{_dim_colmax}) {
3456 69         128 $self->{_dim_colmax} = $col;
3457             }
3458             }
3459              
3460 22695         63765 return 0;
3461             }
3462              
3463              
3464             ###############################################################################
3465             #
3466             # _store_dimensions()
3467             #
3468             # Writes Excel DIMENSIONS to define the area in which there is cell data.
3469             #
3470             # Notes:
3471             # Excel stores the max row/col as row/col +1.
3472             # Max and min values of 0 are used to indicate that no cell data.
3473             # We set the undef member data to 0 since it is used by _store_table().
3474             # Inserting images or charts doesn't change the DIMENSION data.
3475             #
3476             sub _store_dimensions {
3477              
3478 164     164   7625 my $self = shift;
3479 164         253 my $record = 0x0200; # Record identifier
3480 164         240 my $length = 0x000E; # Number of bytes to follow
3481 164         209 my $row_min; # First row
3482             my $row_max; # Last row plus 1
3483 0         0 my $col_min; # First column
3484 0         0 my $col_max; # Last column plus 1
3485 164         198 my $reserved = 0x0000; # Reserved by Excel
3486              
3487 164 100       518 if (defined $self->{_dim_rowmin}) {$row_min = $self->{_dim_rowmin} }
  94         178  
  70         123  
3488             else {$row_min = 0 }
3489              
3490 164 100       477 if (defined $self->{_dim_rowmax}) {$row_max = $self->{_dim_rowmax} + 1}
  94         140  
  70         114  
3491             else {$row_max = 0 }
3492              
3493 164 100       435 if (defined $self->{_dim_colmin}) {$col_min = $self->{_dim_colmin} }
  90         132  
  74         143  
3494             else {$col_min = 0 }
3495              
3496 164 100       412 if (defined $self->{_dim_colmax}) {$col_max = $self->{_dim_colmax} + 1}
  90         140  
  74         105  
3497             else {$col_max = 0 }
3498              
3499              
3500             # Set member data to the new max/min value for use by _store_table().
3501 164         300 $self->{_dim_rowmin} = $row_min;
3502 164         280 $self->{_dim_rowmax} = $row_max;
3503 164         234 $self->{_dim_colmin} = $col_min;
3504 164         228 $self->{_dim_colmax} = $col_max;
3505              
3506              
3507 164         372 my $header = pack("vv", $record, $length);
3508 164         413 my $data = pack("VVvvv", $row_min, $row_max,
3509             $col_min, $col_max, $reserved);
3510 164         841 $self->_prepend($header, $data);
3511             }
3512              
3513              
3514             ###############################################################################
3515             #
3516             # _store_window2()
3517             #
3518             # Write BIFF record Window2.
3519             #
3520             sub _store_window2 {
3521              
3522 32     32   307446 use integer; # Avoid << shift bug in Perl 5.6.0 on HP-UX
  32         93  
  32         279  
3523              
3524 133     133   211 my $self = shift;
3525 133         176 my $record = 0x023E; # Record identifier
3526 133         173 my $length = 0x0012; # Number of bytes to follow
3527              
3528 133         170 my $grbit = 0x00B6; # Option flags
3529 133         256 my $rwTop = $self->{_first_row}; # Top visible row
3530 133         211 my $colLeft = $self->{_first_col}; # Leftmost visible column
3531 133         179 my $rgbHdr = 0x00000040; # Row/col heading, grid color
3532              
3533 133         162 my $wScaleSLV = 0x0000; # Zoom in page break preview
3534 133         159 my $wScaleNormal = 0x0000; # Zoom in normal view
3535 133         164 my $reserved = 0x00000000;
3536              
3537              
3538             # The options flags that comprise $grbit
3539 133         255 my $fDspFmla = $self->{_display_formulas}; # 0 - bit
3540 133         213 my $fDspGrid = $self->{_screen_gridlines}; # 1
3541 133         294 my $fDspRwCol = $self->{_display_headers}; # 2
3542 133         211 my $fFrozen = $self->{_frozen}; # 3
3543 133         193 my $fDspZeros = $self->{_display_zeros}; # 4
3544 133         153 my $fDefaultHdr = 1; # 5
3545 133         302 my $fArabic = $self->{_display_arabic}; # 6
3546 133         194 my $fDspGuts = $self->{_outline_on}; # 7
3547 133         225 my $fFrozenNoSplit = $self->{_frozen_no_split}; # 0 - bit
3548 133         215 my $fSelected = $self->{_selected}; # 1
3549 133         206 my $fPaged = $self->{_active}; # 2
3550 133         173 my $fBreakPreview = 0; # 3
3551              
3552 133         242 $grbit = $fDspFmla;
3553 133         2145 $grbit |= $fDspGrid << 1;
3554 133         183 $grbit |= $fDspRwCol << 2;
3555 133         174 $grbit |= $fFrozen << 3;
3556 133         186 $grbit |= $fDspZeros << 4;
3557 133         163 $grbit |= $fDefaultHdr << 5;
3558 133         185 $grbit |= $fArabic << 6;
3559 133         203 $grbit |= $fDspGuts << 7;
3560 133         192 $grbit |= $fFrozenNoSplit << 8;
3561 133         165 $grbit |= $fSelected << 9;
3562 133         441 $grbit |= $fPaged << 10;
3563 133         184 $grbit |= $fBreakPreview << 11;
3564              
3565 133         335 my $header = pack("vv", $record, $length);
3566 133         357 my $data = pack("vvvVvvV", $grbit, $rwTop, $colLeft, $rgbHdr,
3567             $wScaleSLV, $wScaleNormal, $reserved );
3568              
3569 133         465 $self->_append($header, $data);
3570             }
3571              
3572              
3573             ###############################################################################
3574             #
3575             # _store_page_view()
3576             #
3577             # Set page view mode. Only applicable to Mac Excel.
3578             #
3579             sub _store_page_view {
3580              
3581 133     133   213 my $self = shift;
3582              
3583 133 50       440 return unless $self->{_page_view};
3584              
3585 0         0 my $data = pack "H*", 'C8081100C808000000000040000000000900000000';
3586              
3587 0         0 $self->_append($data);
3588             }
3589              
3590              
3591             ###############################################################################
3592             #
3593             # _store_tab_color()
3594             #
3595             # Write the Tab Color BIFF record.
3596             #
3597             sub _store_tab_color {
3598              
3599 135     135   195 my $self = shift;
3600 135         220 my $color = $self->{_tab_color};
3601              
3602 135 50       389 return unless $color;
3603              
3604 0         0 my $record = 0x0862; # Record identifier
3605 0         0 my $length = 0x0014; # Number of bytes to follow
3606              
3607 0         0 my $zero = 0x0000;
3608 0         0 my $unknown = 0x0014;
3609              
3610 0         0 my $header = pack("vv", $record, $length);
3611 0         0 my $data = pack("vvvvvvvvvv", $record, $zero, $zero, $zero, $zero,
3612             $zero, $unknown, $zero, $color, $zero);
3613              
3614 0         0 $self->_append($header, $data);
3615             }
3616              
3617              
3618             ###############################################################################
3619             #
3620             # _store_defrow()
3621             #
3622             # Write BIFF record DEFROWHEIGHT.
3623             #
3624             sub _store_defrow {
3625              
3626 133     133   194 my $self = shift;
3627 133         175 my $record = 0x0225; # Record identifier
3628 133         163 my $length = 0x0004; # Number of bytes to follow
3629              
3630 133         175 my $grbit = 0x0000; # Options.
3631 133         164 my $height = 0x00FF; # Default row height
3632              
3633 133         281 my $header = pack("vv", $record, $length);
3634 133         234 my $data = pack("vv", $grbit, $height);
3635              
3636 133         450 $self->_prepend($header, $data);
3637             }
3638              
3639              
3640             ###############################################################################
3641             #
3642             # _store_defcol()
3643             #
3644             # Write BIFF record DEFCOLWIDTH.
3645             #
3646             sub _store_defcol {
3647              
3648 133     133   249 my $self = shift;
3649 133         170 my $record = 0x0055; # Record identifier
3650 133         186 my $length = 0x0002; # Number of bytes to follow
3651              
3652 133         182 my $colwidth = 0x0008; # Default column width
3653              
3654 133         303 my $header = pack("vv", $record, $length);
3655 133         244 my $data = pack("v", $colwidth);
3656              
3657 133         429 $self->_prepend($header, $data);
3658             }
3659              
3660              
3661             ###############################################################################
3662             #
3663             # _store_colinfo($firstcol, $lastcol, $width, $format, $hidden)
3664             #
3665             # Write BIFF record COLINFO to define column widths
3666             #
3667             # Note: The SDK says the record length is 0x0B but Excel writes a 0x0C
3668             # length record.
3669             #
3670             sub _store_colinfo {
3671              
3672 5     5   8 my $self = shift;
3673 5         7 my $record = 0x007D; # Record identifier
3674 5         8 my $length = 0x000B; # Number of bytes to follow
3675              
3676 5   50     15 my $colFirst = $_[0] || 0; # First formatted column
3677 5   50     14 my $colLast = $_[1] || 0; # Last formatted column
3678 5   100     16 my $width = $_[2] || 8.43; # Col width in user units, 8.43 is default
3679 5         8 my $coldx; # Col width in internal units
3680             my $pixels; # Col width in pixels
3681              
3682             # Excel rounds the column width to the nearest pixel. Therefore we first
3683             # convert to pixels and then to the internal units. The pixel to users-units
3684             # relationship is different for values less than 1.
3685             #
3686 5 50       29 if ($width < 1) {
3687 0         0 $pixels = int($width *12);
3688             }
3689             else {
3690 5         11 $pixels = int($width *7 ) +5;
3691             }
3692              
3693 5         12 $coldx = int($pixels *256/7);
3694              
3695              
3696 5         6 my $ixfe; # XF index
3697 5         8 my $grbit = 0x0000; # Option flags
3698 5         5 my $reserved = 0x00; # Reserved
3699 5         8 my $format = $_[3]; # Format object
3700 5   50     33 my $hidden = $_[4] || 0; # Hidden flag
3701 5   50     22 my $level = $_[5] || 0; # Outline level
3702 5   50     31 my $collapsed = $_[6] || 0; # Outline level
3703              
3704              
3705             # Check for a format object
3706 5 100       14 if (ref $format) {
3707 1         7 $ixfe = $format->get_xf_index();
3708             }
3709             else {
3710 4         7 $ixfe = 0x0F;
3711             }
3712              
3713              
3714             # Set the limits for the outline levels (0 <= x <= 7).
3715 5 50       21 $level = 0 if $level < 0;
3716 5 50       16 $level = 7 if $level > 7;
3717              
3718              
3719             # Set the options flags. (See set_row() for more details).
3720 5 50       12 $grbit |= 0x0001 if $hidden;
3721 5         7 $grbit |= $level << 8;
3722 5 50       16 $grbit |= 0x1000 if $collapsed;
3723              
3724              
3725 5         12 my $header = pack("vv", $record, $length);
3726 5         15 my $data = pack("vvvvvC", $colFirst, $colLast, $coldx,
3727             $ixfe, $grbit, $reserved);
3728              
3729 5         19 $self->_prepend($header, $data);
3730             }
3731              
3732              
3733             ###############################################################################
3734             #
3735             # _store_filtermode()
3736             #
3737             # Write BIFF record FILTERMODE to indicate that the worksheet contains
3738             # AUTOFILTER record, ie. autofilters with a filter set.
3739             #
3740             sub _store_filtermode {
3741              
3742 133     133   189 my $self = shift;
3743              
3744 133         172 my $record = 0x009B; # Record identifier
3745 133         174 my $length = 0x0000; # Number of bytes to follow
3746              
3747             # Only write the record if the worksheet contains a filtered autofilter.
3748 133 50       382 return unless $self->{_filter_on};
3749              
3750 0         0 my $header = pack("vv", $record, $length);
3751              
3752 0         0 $self->_prepend($header);
3753             }
3754              
3755              
3756             ###############################################################################
3757             #
3758             # _store_autofilterinfo()
3759             #
3760             # Write BIFF record AUTOFILTERINFO.
3761             #
3762             sub _store_autofilterinfo {
3763              
3764 133     133   212 my $self = shift;
3765              
3766 133         181 my $record = 0x009D; # Record identifier
3767 133         234 my $length = 0x0002; # Number of bytes to follow
3768 133         221 my $num_filters = $self->{_filter_count};
3769              
3770             # Only write the record if the worksheet contains an autofilter.
3771 133 100       406 return unless $self->{_filter_count};
3772              
3773 3         7 my $header = pack("vv", $record, $length);
3774 3         6 my $data = pack("v", $num_filters);
3775              
3776 3         11 $self->_prepend($header, $data);
3777             }
3778              
3779              
3780             ###############################################################################
3781             #
3782             # _store_selection($first_row, $first_col, $last_row, $last_col)
3783             #
3784             # Write BIFF record SELECTION.
3785             #
3786             sub _store_selection {
3787              
3788 133     133   187 my $self = shift;
3789 133         192 my $record = 0x001D; # Record identifier
3790 133         216 my $length = 0x000F; # Number of bytes to follow
3791              
3792 133         274 my $pnn = $self->{_active_pane}; # Pane position
3793 133         205 my $rwAct = $_[0]; # Active row
3794 133         174 my $colAct = $_[1]; # Active column
3795 133         176 my $irefAct = 0; # Active cell ref
3796 133         180 my $cref = 1; # Number of refs
3797              
3798 133         172 my $rwFirst = $_[0]; # First row in reference
3799 133         175 my $colFirst = $_[1]; # First col in reference
3800 133   33     572 my $rwLast = $_[2] || $rwFirst; # Last row in reference
3801 133   33     572 my $colLast = $_[3] || $colFirst; # Last col in reference
3802              
3803             # Swap last row/col for first row/col as necessary
3804 133 50       380 if ($rwFirst > $rwLast) {
3805 0         0 ($rwFirst, $rwLast) = ($rwLast, $rwFirst);
3806             }
3807              
3808 133 50       316 if ($colFirst > $colLast) {
3809 0         0 ($colFirst, $colLast) = ($colLast, $colFirst);
3810             }
3811              
3812              
3813 133         300 my $header = pack("vv", $record, $length);
3814 133         348 my $data = pack("CvvvvvvCC", $pnn, $rwAct, $colAct,
3815             $irefAct, $cref,
3816             $rwFirst, $rwLast,
3817             $colFirst, $colLast);
3818              
3819 133         329 $self->_append($header, $data);
3820             }
3821              
3822              
3823             ###############################################################################
3824             #
3825             # _store_externcount($count)
3826             #
3827             # Write BIFF record EXTERNCOUNT to indicate the number of external sheet
3828             # references in a worksheet.
3829             #
3830             # Excel only stores references to external sheets that are used in formulas.
3831             # For simplicity we store references to all the sheets in the workbook
3832             # regardless of whether they are used or not. This reduces the overall
3833             # complexity and eliminates the need for a two way dialogue between the formula
3834             # parser the worksheet objects.
3835             #
3836             sub _store_externcount {
3837              
3838 0     0   0 my $self = shift;
3839 0         0 my $record = 0x0016; # Record identifier
3840 0         0 my $length = 0x0002; # Number of bytes to follow
3841              
3842 0         0 my $cxals = $_[0]; # Number of external references
3843              
3844 0         0 my $header = pack("vv", $record, $length);
3845 0         0 my $data = pack("v", $cxals);
3846              
3847 0         0 $self->_prepend($header, $data);
3848             }
3849              
3850              
3851             ###############################################################################
3852             #
3853             # _store_externsheet($sheetname)
3854             #
3855             #
3856             # Writes the Excel BIFF EXTERNSHEET record. These references are used by
3857             # formulas. A formula references a sheet name via an index. Since we store a
3858             # reference to all of the external worksheets the EXTERNSHEET index is the same
3859             # as the worksheet index.
3860             #
3861             sub _store_externsheet {
3862              
3863 0     0   0 my $self = shift;
3864              
3865 0         0 my $record = 0x0017; # Record identifier
3866 0         0 my $length; # Number of bytes to follow
3867              
3868 0         0 my $sheetname = $_[0]; # Worksheet name
3869 0         0 my $cch; # Length of sheet name
3870             my $rgch; # Filename encoding
3871              
3872             # References to the current sheet are encoded differently to references to
3873             # external sheets.
3874             #
3875 0 0       0 if ($self->{_name} eq $sheetname) {
3876 0         0 $sheetname = '';
3877 0         0 $length = 0x02; # The following 2 bytes
3878 0         0 $cch = 1; # The following byte
3879 0         0 $rgch = 0x02; # Self reference
3880             }
3881             else {
3882 0         0 $length = 0x02 + length($_[0]);
3883 0         0 $cch = length($sheetname);
3884 0         0 $rgch = 0x03; # Reference to a sheet in the current workbook
3885             }
3886              
3887 0         0 my $header = pack("vv", $record, $length);
3888 0         0 my $data = pack("CC", $cch, $rgch);
3889              
3890 0         0 $self->_prepend($header, $data, $sheetname);
3891             }
3892              
3893              
3894             ###############################################################################
3895             #
3896             # _store_panes()
3897             #
3898             #
3899             # Writes the Excel BIFF PANE record.
3900             # The panes can either be frozen or thawed (unfrozen).
3901             # Frozen panes are specified in terms of a integer number of rows and columns.
3902             # Thawed panes are specified in terms of Excel's units for rows and columns.
3903             #
3904             sub _store_panes {
3905              
3906 0     0   0 my $self = shift;
3907 0         0 my $record = 0x0041; # Record identifier
3908 0         0 my $length = 0x000A; # Number of bytes to follow
3909              
3910 0   0     0 my $y = $_[0] || 0; # Vertical split position
3911 0   0     0 my $x = $_[1] || 0; # Horizontal split position
3912 0         0 my $rwTop = $_[2]; # Top row visible
3913 0         0 my $colLeft = $_[3]; # Leftmost column visible
3914 0         0 my $no_split = $_[4]; # No used here.
3915 0         0 my $pnnAct = $_[5]; # Active pane
3916              
3917              
3918             # Code specific to frozen or thawed panes.
3919 0 0       0 if ($self->{_frozen}) {
3920             # Set default values for $rwTop and $colLeft
3921 0 0       0 $rwTop = $y unless defined $rwTop;
3922 0 0       0 $colLeft = $x unless defined $colLeft;
3923             }
3924             else {
3925             # Set default values for $rwTop and $colLeft
3926 0 0       0 $rwTop = 0 unless defined $rwTop;
3927 0 0       0 $colLeft = 0 unless defined $colLeft;
3928              
3929             # Convert Excel's row and column units to the internal units.
3930             # The default row height is 12.75
3931             # The default column width is 8.43
3932             # The following slope and intersection values were interpolated.
3933             #
3934 0         0 $y = 20*$y + 255;
3935 0         0 $x = 113.879*$x + 390;
3936             }
3937              
3938              
3939             # Determine which pane should be active. There is also the undocumented
3940             # option to override this should it be necessary: may be removed later.
3941             #
3942 0 0       0 if (not defined $pnnAct) {
3943 0 0 0     0 $pnnAct = 0 if ($x != 0 && $y != 0); # Bottom right
3944 0 0 0     0 $pnnAct = 1 if ($x != 0 && $y == 0); # Top right
3945 0 0 0     0 $pnnAct = 2 if ($x == 0 && $y != 0); # Bottom left
3946 0 0 0     0 $pnnAct = 3 if ($x == 0 && $y == 0); # Top left
3947             }
3948              
3949 0         0 $self->{_active_pane} = $pnnAct; # Used in _store_selection
3950              
3951 0         0 my $header = pack("vv", $record, $length);
3952 0         0 my $data = pack("vvvvv", $x, $y, $rwTop, $colLeft, $pnnAct);
3953              
3954 0         0 $self->_append($header, $data);
3955             }
3956              
3957              
3958             ###############################################################################
3959             #
3960             # _store_setup()
3961             #
3962             # Store the page setup SETUP BIFF record.
3963             #
3964             sub _store_setup {
3965              
3966 32     32   86948 use integer; # Avoid << shift bug in Perl 5.6.0 on HP-UX
  32         79  
  32         194  
3967              
3968 135     135   202 my $self = shift;
3969 135         194 my $record = 0x00A1; # Record identifier
3970 135         161 my $length = 0x0022; # Number of bytes to follow
3971              
3972              
3973 135         276 my $iPaperSize = $self->{_paper_size}; # Paper size
3974 135         234 my $iScale = $self->{_print_scale}; # Print scaling factor
3975 135         260 my $iPageStart = $self->{_page_start}; # Starting page number
3976 135         234 my $iFitWidth = $self->{_fit_width}; # Fit to number of pages wide
3977 135         254 my $iFitHeight = $self->{_fit_height}; # Fit to number of pages high
3978 135         161 my $grbit = 0x00; # Option flags
3979 135         164 my $iRes = 0x0258; # Print resolution
3980 135         170 my $iVRes = 0x0258; # Vertical print resolution
3981 135         262 my $numHdr = $self->{_margin_header}; # Header Margin
3982 135         222 my $numFtr = $self->{_margin_footer}; # Footer Margin
3983 135         202 my $iCopies = 0x01; # Number of copies
3984              
3985              
3986 135         256 my $fLeftToRight = $self->{_page_order}; # Print over then down
3987 135         213 my $fLandscape = $self->{_orientation}; # Page orientation
3988 135         181 my $fNoPls = 0x0; # Setup not read from printer
3989 135         230 my $fNoColor = $self->{_black_white}; # Print black and white
3990 135         234 my $fDraft = $self->{_draft_quality}; # Print draft quality
3991 135         202 my $fNotes = $self->{_print_comments};# Print notes
3992 135         2601 my $fNoOrient = 0x0; # Orientation not set
3993 135         223 my $fUsePage = $self->{_custom_start}; # Use custom starting page
3994              
3995              
3996 135         168 $grbit = $fLeftToRight;
3997 135         212 $grbit |= $fLandscape << 1;
3998 135         243 $grbit |= $fNoPls << 2;
3999 135         188 $grbit |= $fNoColor << 3;
4000 135         166 $grbit |= $fDraft << 4;
4001 135         164 $grbit |= $fNotes << 5;
4002 135         180 $grbit |= $fNoOrient << 6;
4003 135         193 $grbit |= $fUsePage << 7;
4004              
4005              
4006 135         311 $numHdr = pack("d", $numHdr);
4007 135         231 $numFtr = pack("d", $numFtr);
4008              
4009 135 50       473 if ($self->{_byte_order}) {
4010 0         0 $numHdr = reverse $numHdr;
4011 0         0 $numFtr = reverse $numFtr;
4012             }
4013              
4014 135         275 my $header = pack("vv", $record, $length);
4015 135         345 my $data1 = pack("vvvvvvvv", $iPaperSize,
4016             $iScale,
4017             $iPageStart,
4018             $iFitWidth,
4019             $iFitHeight,
4020             $grbit,
4021             $iRes,
4022             $iVRes);
4023 135         230 my $data2 = $numHdr .$numFtr;
4024 135         246 my $data3 = pack("v", $iCopies);
4025              
4026 135         460 $self->_prepend($header, $data1, $data2, $data3);
4027              
4028             }
4029              
4030             ###############################################################################
4031             #
4032             # _store_header()
4033             #
4034             # Store the header caption BIFF record.
4035             #
4036             sub _store_header {
4037              
4038 135     135   206 my $self = shift;
4039              
4040 135         183 my $record = 0x0014; # Record identifier
4041 135         162 my $length; # Bytes to follow
4042              
4043 135         260 my $str = $self->{_header}; # header string
4044 135         188 my $cch = length($str); # Length of header string
4045 135         259 my $encoding = $self->{_header_encoding}; # Character encoding
4046              
4047              
4048             # Character length is num of chars not num of bytes
4049 135 50       342 $cch /= 2 if $encoding;
4050              
4051             # Change the UTF-16 name from BE to LE
4052 135 50       317 $str = pack 'n*', unpack 'v*', $str if $encoding;
4053              
4054 135         202 $length = 3 + length($str);
4055              
4056 135         346 my $header = pack("vv", $record, $length);
4057 135         273 my $data = pack("vC", $cch, $encoding);
4058              
4059 135         422 $self->_prepend($header, $data, $str);
4060             }
4061              
4062              
4063             ###############################################################################
4064             #
4065             # _store_footer()
4066             #
4067             # Store the footer caption BIFF record.
4068             #
4069             sub _store_footer {
4070              
4071 135     135   190 my $self = shift;
4072              
4073 135         194 my $record = 0x0015; # Record identifier
4074 135         164 my $length; # Bytes to follow
4075              
4076 135         309 my $str = $self->{_footer}; # footer string
4077 135         188 my $cch = length($str); # Length of footer string
4078 135         205 my $encoding = $self->{_footer_encoding}; # Character encoding
4079              
4080              
4081             # Character length is num of chars not num of bytes
4082 135 50       336 $cch /= 2 if $encoding;
4083              
4084             # Change the UTF-16 name from BE to LE
4085 135 50       299 $str = pack 'n*', unpack 'v*', $str if $encoding;
4086              
4087 135         195 $length = 3 + length($str);
4088              
4089 135         275 my $header = pack("vv", $record, $length);
4090 135         251 my $data = pack("vC", $cch, $encoding);
4091              
4092 135         408 $self->_prepend($header, $data, $str);
4093             }
4094              
4095              
4096             ###############################################################################
4097             #
4098             # _store_hcenter()
4099             #
4100             # Store the horizontal centering HCENTER BIFF record.
4101             #
4102             sub _store_hcenter {
4103              
4104 135     135   198 my $self = shift;
4105              
4106 135         186 my $record = 0x0083; # Record identifier
4107 135         176 my $length = 0x0002; # Bytes to follow
4108              
4109 135         250 my $fHCenter = $self->{_hcenter}; # Horizontal centering
4110              
4111 135         276 my $header = pack("vv", $record, $length);
4112 135         233 my $data = pack("v", $fHCenter);
4113              
4114 135         409 $self->_prepend($header, $data);
4115             }
4116              
4117              
4118             ###############################################################################
4119             #
4120             # _store_vcenter()
4121             #
4122             # Store the vertical centering VCENTER BIFF record.
4123             #
4124             sub _store_vcenter {
4125              
4126 135     135   193 my $self = shift;
4127              
4128 135         191 my $record = 0x0084; # Record identifier
4129 135         174 my $length = 0x0002; # Bytes to follow
4130              
4131 135         233 my $fVCenter = $self->{_vcenter}; # Horizontal centering
4132              
4133 135         275 my $header = pack("vv", $record, $length);
4134 135         227 my $data = pack("v", $fVCenter);
4135              
4136 135         467 $self->_prepend($header, $data);
4137             }
4138              
4139              
4140             ###############################################################################
4141             #
4142             # _store_margin_left()
4143             #
4144             # Store the LEFTMARGIN BIFF record.
4145             #
4146             sub _store_margin_left {
4147              
4148 135     135   205 my $self = shift;
4149              
4150 135         191 my $record = 0x0026; # Record identifier
4151 135         183 my $length = 0x0008; # Bytes to follow
4152              
4153 135         251 my $margin = $self->{_margin_left}; # Margin in inches
4154              
4155 135         259 my $header = pack("vv", $record, $length);
4156 135         227 my $data = pack("d", $margin);
4157              
4158 135 50       381 if ($self->{_byte_order}) { $data = reverse $data }
  0         0  
4159              
4160 135         416 $self->_prepend($header, $data);
4161             }
4162              
4163              
4164             ###############################################################################
4165             #
4166             # _store_margin_right()
4167             #
4168             # Store the RIGHTMARGIN BIFF record.
4169             #
4170             sub _store_margin_right {
4171              
4172 135     135   201 my $self = shift;
4173              
4174 135         214 my $record = 0x0027; # Record identifier
4175 135         173 my $length = 0x0008; # Bytes to follow
4176              
4177 135         233 my $margin = $self->{_margin_right}; # Margin in inches
4178              
4179 135         280 my $header = pack("vv", $record, $length);
4180 135         220 my $data = pack("d", $margin);
4181              
4182 135 50       378 if ($self->{_byte_order}) { $data = reverse $data }
  0         0  
4183              
4184 135         465 $self->_prepend($header, $data);
4185             }
4186              
4187              
4188             ###############################################################################
4189             #
4190             # _store_margin_top()
4191             #
4192             # Store the TOPMARGIN BIFF record.
4193             #
4194             sub _store_margin_top {
4195              
4196 135     135   203 my $self = shift;
4197              
4198 135         202 my $record = 0x0028; # Record identifier
4199 135         172 my $length = 0x0008; # Bytes to follow
4200              
4201 135         258 my $margin = $self->{_margin_top}; # Margin in inches
4202              
4203 135         273 my $header = pack("vv", $record, $length);
4204 135         224 my $data = pack("d", $margin);
4205              
4206 135 50       378 if ($self->{_byte_order}) { $data = reverse $data }
  0         0  
4207              
4208 135         523 $self->_prepend($header, $data);
4209             }
4210              
4211              
4212             ###############################################################################
4213             #
4214             # _store_margin_bottom()
4215             #
4216             # Store the BOTTOMMARGIN BIFF record.
4217             #
4218             sub _store_margin_bottom {
4219              
4220 135     135   197 my $self = shift;
4221              
4222 135         185 my $record = 0x0029; # Record identifier
4223 135         167 my $length = 0x0008; # Bytes to follow
4224              
4225 135         316 my $margin = $self->{_margin_bottom}; # Margin in inches
4226              
4227 135         299 my $header = pack("vv", $record, $length);
4228 135         227 my $data = pack("d", $margin);
4229              
4230 135 50       371 if ($self->{_byte_order}) { $data = reverse $data }
  0         0  
4231              
4232 135         416 $self->_prepend($header, $data);
4233             }
4234              
4235              
4236             ###############################################################################
4237             #
4238             # merge_cells($first_row, $first_col, $last_row, $last_col)
4239             #
4240             # This is an Excel97/2000 method. It is required to perform more complicated
4241             # merging than the normal align merge in Format.pm
4242             #
4243             sub merge_cells {
4244              
4245 3     3 0 7 my $self = shift;
4246              
4247             # Check for a cell reference in A1 notation and substitute row and column
4248 3 50       34 if ($_[0] =~ /^\D/) {
4249 0         0 @_ = $self->_substitute_cellref(@_);
4250             }
4251              
4252 3         7 my $record = 0x00E5; # Record identifier
4253 3         6 my $length = 0x000A; # Bytes to follow
4254              
4255 3         5 my $cref = 1; # Number of refs
4256 3         6 my $rwFirst = $_[0]; # First row in reference
4257 3         7 my $colFirst = $_[1]; # First col in reference
4258 3   33     12 my $rwLast = $_[2] || $rwFirst; # Last row in reference
4259 3   33     9 my $colLast = $_[3] || $colFirst; # Last col in reference
4260              
4261              
4262             # Excel doesn't allow a single cell to be merged
4263 3 50 33     25 return if $rwFirst == $rwLast and $colFirst == $colLast;
4264              
4265             # Swap last row/col with first row/col as necessary
4266 3 50       10 ($rwFirst, $rwLast ) = ($rwLast, $rwFirst ) if $rwFirst > $rwLast;
4267 3 50       9 ($colFirst, $colLast) = ($colLast, $colFirst) if $colFirst > $colLast;
4268              
4269 3         10 my $header = pack("vv", $record, $length);
4270 3         9 my $data = pack("vvvvv", $cref,
4271             $rwFirst, $rwLast,
4272             $colFirst, $colLast);
4273              
4274 3         9 $self->_append($header, $data);
4275             }
4276              
4277              
4278             ###############################################################################
4279             #
4280             # merge_range($row1, $col1, $row2, $col2, $string, $format, $encoding)
4281             #
4282             # This is a wrapper to ensure correct use of the merge_cells method, i.e., write
4283             # the first cell of the range, write the formatted blank cells in the range and
4284             # then call the merge_cells record. Failing to do the steps in this order will
4285             # cause Excel 97 to crash.
4286             #
4287             sub merge_range {
4288              
4289 4     4 0 574 my $self = shift;
4290              
4291             # Check for a cell reference in A1 notation and substitute row and column
4292 4 50       21 if ($_[0] =~ /^\D/) {
4293 4         15 @_ = $self->_substitute_cellref(@_);
4294             }
4295 4 50 33     19 croak "Incorrect number of arguments" if @_ != 6 and @_ != 7;
4296 4 50       17 croak "Format argument is not a format object" unless ref $_[5];
4297              
4298 4         7 my $rwFirst = $_[0];
4299 4         9 my $colFirst = $_[1];
4300 4         6 my $rwLast = $_[2];
4301 4         6 my $colLast = $_[3];
4302 4         7 my $string = $_[4];
4303 4         5 my $format = $_[5];
4304 4 50       19 my $encoding = $_[6] ? 1 : 0;
4305              
4306              
4307             # Temp code to prevent merged formats in non-merged cells.
4308 4         8 my $error = "Error: refer to merge_range() in the documentation. " .
4309             "Can't use previously non-merged format in merged cells";
4310              
4311 4 100       195 croak $error if $format->{_used_merge} == -1;
4312 3         7 $format->{_used_merge} = 0; # Until the end of this function.
4313              
4314              
4315             # Set the merge_range property of the format object. For BIFF8+.
4316 3         44 $format->set_merge_range();
4317              
4318             # Excel doesn't allow a single cell to be merged
4319 3 50 33     16 croak "Can't merge single cell" if $rwFirst == $rwLast and
4320             $colFirst == $colLast;
4321              
4322             # Swap last row/col with first row/col as necessary
4323 3 50       10 ($rwFirst, $rwLast ) = ($rwLast, $rwFirst ) if $rwFirst > $rwLast;
4324 3 50       15 ($colFirst, $colLast) = ($colLast, $colFirst) if $colFirst > $colLast;
4325              
4326             # Write the first cell
4327 3 50       7 if ($encoding) {
4328 0         0 $self->write_utf16be_string($rwFirst, $colFirst, $string, $format);
4329             }
4330             else {
4331 3         12 $self->write ($rwFirst, $colFirst, $string, $format);
4332             }
4333              
4334             # Pad out the rest of the area with formatted blank cells.
4335 3         11 for my $row ($rwFirst .. $rwLast) {
4336 7         15 for my $col ($colFirst .. $colLast) {
4337 17 100 100     63 next if $row == $rwFirst and $col == $colFirst;
4338 14         35 $self->write_blank($row, $col, $format);
4339             }
4340             }
4341              
4342 3         17 $self->merge_cells($rwFirst, $colFirst, $rwLast, $colLast);
4343              
4344             # Temp code to prevent merged formats in non-merged cells.
4345 3         13 $format->{_used_merge} = 1;
4346              
4347             }
4348              
4349              
4350             ###############################################################################
4351             #
4352             # _store_print_headers()
4353             #
4354             # Write the PRINTHEADERS BIFF record.
4355             #
4356             sub _store_print_headers {
4357              
4358 133     133   201 my $self = shift;
4359              
4360 133         203 my $record = 0x002a; # Record identifier
4361 133         157 my $length = 0x0002; # Bytes to follow
4362              
4363 133         222 my $fPrintRwCol = $self->{_print_headers}; # Boolean flag
4364              
4365 133         253 my $header = pack("vv", $record, $length);
4366 133         236 my $data = pack("v", $fPrintRwCol);
4367              
4368 133         1269 $self->_prepend($header, $data);
4369             }
4370              
4371              
4372             ###############################################################################
4373             #
4374             # _store_print_gridlines()
4375             #
4376             # Write the PRINTGRIDLINES BIFF record. Must be used in conjunction with the
4377             # GRIDSET record.
4378             #
4379             sub _store_print_gridlines {
4380              
4381 133     133   279 my $self = shift;
4382              
4383 133         187 my $record = 0x002b; # Record identifier
4384 133         178 my $length = 0x0002; # Bytes to follow
4385              
4386 133         219 my $fPrintGrid = $self->{_print_gridlines}; # Boolean flag
4387              
4388 133         268 my $header = pack("vv", $record, $length);
4389 133         297 my $data = pack("v", $fPrintGrid);
4390              
4391 133         386 $self->_prepend($header, $data);
4392             }
4393              
4394              
4395             ###############################################################################
4396             #
4397             # _store_gridset()
4398             #
4399             # Write the GRIDSET BIFF record. Must be used in conjunction with the
4400             # PRINTGRIDLINES record.
4401             #
4402             sub _store_gridset {
4403              
4404 133     133   214 my $self = shift;
4405              
4406 133         190 my $record = 0x0082; # Record identifier
4407 133         164 my $length = 0x0002; # Bytes to follow
4408              
4409 133         277 my $fGridSet = not $self->{_print_gridlines}; # Boolean flag
4410              
4411 133         254 my $header = pack("vv", $record, $length);
4412 133         229 my $data = pack("v", $fGridSet);
4413              
4414 133         420 $self->_prepend($header, $data);
4415              
4416             }
4417              
4418              
4419             ###############################################################################
4420             #
4421             # _store_guts()
4422             #
4423             # Write the GUTS BIFF record. This is used to configure the gutter margins
4424             # where Excel outline symbols are displayed. The visibility of the gutters is
4425             # controlled by a flag in WSBOOL. See also _store_wsbool().
4426             #
4427             # We are all in the gutter but some of us are looking at the stars.
4428             #
4429             sub _store_guts {
4430              
4431 133     133   182 my $self = shift;
4432              
4433 133         190 my $record = 0x0080; # Record identifier
4434 133         162 my $length = 0x0008; # Bytes to follow
4435              
4436 133         155 my $dxRwGut = 0x0000; # Size of row gutter
4437 133         200 my $dxColGut = 0x0000; # Size of col gutter
4438              
4439 133         232 my $row_level = $self->{_outline_row_level};
4440 133         198 my $col_level = 0;
4441              
4442              
4443             # Calculate the maximum column outline level. The equivalent calculation
4444             # for the row outline level is carried out in set_row().
4445             #
4446 133         189 foreach my $colinfo (@{$self->{_colinfo}}) {
  133         387  
4447             # Skip cols without outline level info.
4448 5 50       7 next if @{$colinfo} < 6;
  5         23  
4449 0 0       0 $col_level = @{$colinfo}[5] if @{$colinfo}[5] > $col_level;
  0         0  
  0         0  
4450             }
4451              
4452              
4453             # Set the limits for the outline levels (0 <= x <= 7).
4454 133 50       379 $col_level = 0 if $col_level < 0;
4455 133 50       318 $col_level = 7 if $col_level > 7;
4456              
4457              
4458             # The displayed level is one greater than the max outline levels
4459 133 50       301 $row_level++ if $row_level > 0;
4460 133 50       292 $col_level++ if $col_level > 0;
4461              
4462 133         354 my $header = pack("vv", $record, $length);
4463 133         274 my $data = pack("vvvv", $dxRwGut, $dxColGut, $row_level, $col_level);
4464              
4465 133         445 $self->_prepend($header, $data);
4466              
4467             }
4468              
4469              
4470             ###############################################################################
4471             #
4472             # _store_wsbool()
4473             #
4474             # Write the WSBOOL BIFF record, mainly for fit-to-page. Used in conjunction
4475             # with the SETUP record.
4476             #
4477             sub _store_wsbool {
4478              
4479 133     133   207 my $self = shift;
4480              
4481 133         170 my $record = 0x0081; # Record identifier
4482 133         194 my $length = 0x0002; # Bytes to follow
4483              
4484 133         182 my $grbit = 0x0000; # Option flags
4485              
4486             # Set the option flags
4487 133         169 $grbit |= 0x0001; # Auto page breaks visible
4488 133 50       426 $grbit |= 0x0020 if $self->{_outline_style}; # Auto outline styles
4489 133 50       413 $grbit |= 0x0040 if $self->{_outline_below}; # Outline summary below
4490 133 50       370 $grbit |= 0x0080 if $self->{_outline_right}; # Outline summary right
4491 133 50       337 $grbit |= 0x0100 if $self->{_fit_page}; # Page setup fit to page
4492 133 50       440 $grbit |= 0x0400 if $self->{_outline_on}; # Outline symbols displayed
4493              
4494              
4495 133         279 my $header = pack("vv", $record, $length);
4496 133         250 my $data = pack("v", $grbit);
4497              
4498 133         439 $self->_prepend($header, $data);
4499             }
4500              
4501              
4502             ###############################################################################
4503             #
4504             # _store_hbreak()
4505             #
4506             # Write the HORIZONTALPAGEBREAKS BIFF record.
4507             #
4508             sub _store_hbreak {
4509              
4510 133     133   192 my $self = shift;
4511              
4512             # Return if the user hasn't specified pagebreaks
4513 133 50       166 return unless @{$self->{_hbreaks}};
  133         439  
4514              
4515             # Sort and filter array of page breaks
4516 0         0 my @breaks = $self->_sort_pagebreaks(@{$self->{_hbreaks}});
  0         0  
4517              
4518 0         0 my $record = 0x001b; # Record identifier
4519 0         0 my $cbrk = scalar @breaks; # Number of page breaks
4520 0         0 my $length = 2 + 6*$cbrk; # Bytes to follow
4521              
4522              
4523 0         0 my $header = pack("vv", $record, $length);
4524 0         0 my $data = pack("v", $cbrk);
4525              
4526             # Append each page break
4527 0         0 foreach my $break (@breaks) {
4528 0         0 $data .= pack("vvv", $break, 0x0000, 0x00ff);
4529             }
4530              
4531 0         0 $self->_prepend($header, $data);
4532             }
4533              
4534              
4535             ###############################################################################
4536             #
4537             # _store_vbreak()
4538             #
4539             # Write the VERTICALPAGEBREAKS BIFF record.
4540             #
4541             sub _store_vbreak {
4542              
4543 133     133   195 my $self = shift;
4544              
4545             # Return if the user hasn't specified pagebreaks
4546 133 50       160 return unless @{$self->{_vbreaks}};
  133         506  
4547              
4548             # Sort and filter array of page breaks
4549 0         0 my @breaks = $self->_sort_pagebreaks(@{$self->{_vbreaks}});
  0         0  
4550              
4551 0         0 my $record = 0x001a; # Record identifier
4552 0         0 my $cbrk = scalar @breaks; # Number of page breaks
4553 0         0 my $length = 2 + 6*$cbrk; # Bytes to follow
4554              
4555              
4556 0         0 my $header = pack("vv", $record, $length);
4557 0         0 my $data = pack("v", $cbrk);
4558              
4559             # Append each page break
4560 0         0 foreach my $break (@breaks) {
4561 0         0 $data .= pack("vvv", $break, 0x0000, 0xffff);
4562             }
4563              
4564 0         0 $self->_prepend($header, $data);
4565             }
4566              
4567              
4568             ###############################################################################
4569             #
4570             # _store_protect()
4571             #
4572             # Set the Biff PROTECT record to indicate that the worksheet is protected.
4573             #
4574             sub _store_protect {
4575              
4576 133     133   191 my $self = shift;
4577              
4578             # Exit unless sheet protection has been specified
4579 133 50       520 return unless $self->{_protect};
4580              
4581 0         0 my $record = 0x0012; # Record identifier
4582 0         0 my $length = 0x0002; # Bytes to follow
4583              
4584 0         0 my $fLock = $self->{_protect}; # Worksheet is protected
4585              
4586 0         0 my $header = pack("vv", $record, $length);
4587 0         0 my $data = pack("v", $fLock);
4588              
4589 0         0 $self->_prepend($header, $data);
4590             }
4591              
4592              
4593             ###############################################################################
4594             #
4595             # _store_obj_protect()
4596             #
4597             # Set the Biff OBJPROTECT record to indicate that objects are protected.
4598             #
4599             sub _store_obj_protect {
4600              
4601 133     133   196 my $self = shift;
4602              
4603             # Exit unless sheet protection has been specified
4604 133 50       377 return unless $self->{_protect};
4605              
4606 0         0 my $record = 0x0063; # Record identifier
4607 0         0 my $length = 0x0002; # Bytes to follow
4608              
4609 0         0 my $fLock = $self->{_protect}; # Worksheet is protected
4610              
4611 0         0 my $header = pack("vv", $record, $length);
4612 0         0 my $data = pack("v", $fLock);
4613              
4614 0         0 $self->_prepend($header, $data);
4615             }
4616              
4617              
4618             ###############################################################################
4619             #
4620             # _store_password()
4621             #
4622             # Write the worksheet PASSWORD record.
4623             #
4624             sub _store_password {
4625              
4626 135     135   184 my $self = shift;
4627              
4628             # Exit unless sheet protection and password have been specified
4629 135 50 33     636 return unless $self->{_protect} and defined $self->{_password};
4630              
4631 0         0 my $record = 0x0013; # Record identifier
4632 0         0 my $length = 0x0002; # Bytes to follow
4633              
4634 0         0 my $wPassword = $self->{_password}; # Encoded password
4635              
4636 0         0 my $header = pack("vv", $record, $length);
4637 0         0 my $data = pack("v", $wPassword);
4638              
4639 0         0 $self->_prepend($header, $data);
4640             }
4641              
4642              
4643             #
4644             # Note about compatibility mode.
4645             #
4646             # Excel doesn't require every possible Biff record to be present in a file.
4647             # In particular if the indexing records INDEX, ROW and DBCELL aren't present
4648             # it just ignores the fact and reads the cells anyway. This is also true of
4649             # the EXTSST record. Gnumeric and OOo also take this approach. This allows
4650             # WriteExcel to ignore these records in order to minimise the amount of data
4651             # stored in memory. However, other third party applications that read Excel
4652             # files often expect these records to be present. In "compatibility mode"
4653             # WriteExcel writes these records and tries to be as close to an Excel
4654             # generated file as possible.
4655             #
4656             # This requires additional data to be stored in memory until the file is
4657             # about to be written. This incurs a memory and speed penalty and may not be
4658             # suitable for very large files.
4659             #
4660              
4661              
4662              
4663             ###############################################################################
4664             #
4665             # _store_table()
4666             #
4667             # Write cell data stored in the worksheet row/col table.
4668             #
4669             # This is only used when compatibity_mode() is in operation.
4670             #
4671             # This method writes ROW data, then cell data (NUMBER, LABELSST, etc) and then
4672             # DBCELL records in blocks of 32 rows. This is explained in detail (for a
4673             # change) in the Excel SDK and in the OOo Excel file format doc.
4674             #
4675             sub _store_table {
4676              
4677 133     133   198 my $self = shift;
4678              
4679 133 100       447 return unless $self->{_compatibility};
4680              
4681             # Offset from the DBCELL record back to the first ROW of the 32 row block.
4682 7         7 my $row_offset = 0;
4683              
4684             # Track rows that have cell data or modified by set_row().
4685 7         7 my @written_rows;
4686              
4687              
4688             # Write the ROW records with updated max/min col fields.
4689             #
4690 7         22 for my $row (0 .. $self->{_dim_rowmax} -1) {
4691             # Skip unless there is cell data in row or the row has been modified.
4692 35 100 100     166 next unless $self->{_table}->[$row] or $self->{_row_data}->{$row};
4693              
4694             # Store the rows with data.
4695 7         9 push @written_rows, $row;
4696              
4697             # Increase the row offset by the length of a ROW record;
4698 7         8 $row_offset += 20;
4699              
4700             # The max/min cols in the ROW records are the same as in DIMENSIONS.
4701 7         11 my $col_min = $self->{_dim_colmin};
4702 7         10 my $col_max = $self->{_dim_colmax};
4703              
4704             # Write a user specified ROW record (modified by set_row()).
4705 7 100       16 if ($self->{_row_data}->{$row}) {
4706             # Rewrite the min and max cols for user defined row record.
4707 2         5 my $packed_row = $self->{_row_data}->{$row};
4708 2         6 substr $packed_row, 6, 4, pack('vv', $col_min, $col_max);
4709 2         7 $self->_append($packed_row);
4710             }
4711             else {
4712             # Write a default Row record if there isn't a user defined ROW.
4713 5         26 $self->_write_row_default($row, $col_min, $col_max);
4714             }
4715              
4716              
4717              
4718             # If 32 rows have been written or we are at the last row in the
4719             # worksheet then write the cell data and the DBCELL record.
4720             #
4721 7 50 33     35 if (@written_rows == 32 or $row == $self->{_dim_rowmax} -1) {
4722              
4723             # Offsets to the first cell of each row.
4724 7         8 my @cell_offsets;
4725 7         12 push @cell_offsets, $row_offset - 20;
4726              
4727             # Write the cell data in each row and sum their lengths for the
4728             # cell offsets.
4729             #
4730 7         15 for my $row (@written_rows) {
4731 7         7 my $cell_offset = 0;
4732              
4733 7         5 for my $col (@{$self->{_table}->[$row]}) {
  7         18  
4734 527 100       1022 next unless $col;
4735 9         15 $self->_append($col);
4736 9         10 my $length = length $col;
4737 9         8 $row_offset += $length;
4738 9         24 $cell_offset += $length;
4739             }
4740 7         14 push @cell_offsets, $cell_offset;
4741             }
4742              
4743             # The last offset isn't required.
4744 7         8 pop @cell_offsets;
4745              
4746             # Stores the DBCELL offset for use in the INDEX record.
4747 7         7 push @{$self->{_db_indices}}, $self->{_datasize};
  7         15  
4748              
4749             # Write the DBCELL record.
4750 7         14 $self->_store_dbcell($row_offset, @cell_offsets);
4751              
4752             # Clear the variable for the next block of rows.
4753 7         11 @written_rows = ();
4754 7         8 @cell_offsets = ();
4755 7         18 $row_offset = 0;
4756             }
4757             }
4758             }
4759              
4760              
4761             ###############################################################################
4762             #
4763             # _store_dbcell()
4764             #
4765             # Store the DBCELL record using the offset calculated in _store_table().
4766             #
4767             # This is only used when compatibity_mode() is in operation.
4768             #
4769             sub _store_dbcell {
4770              
4771 7     7   9 my $self = shift;
4772 7         5 my $row_offset = shift;
4773 7         12 my @cell_offsets = @_;
4774              
4775              
4776 7         7 my $record = 0x00D7; # Record identifier
4777 7         9 my $length = 4 + 2 * @cell_offsets; # Bytes to follow
4778              
4779              
4780 7         10 my $header = pack 'vv', $record, $length;
4781 7         11 my $data = pack 'V', $row_offset;
4782 7         19 $data .= pack 'v', $_ for @cell_offsets;
4783              
4784 7         15 $self->_append($header, $data);
4785             }
4786              
4787              
4788             ###############################################################################
4789             #
4790             # _store_index()
4791             #
4792             # Store the INDEX record using the DBCELL offsets calculated in _store_table().
4793             #
4794             # This is only used when compatibity_mode() is in operation.
4795             #
4796             sub _store_index {
4797              
4798 133     133   225 my $self = shift;
4799              
4800 133 100       435 return unless $self->{_compatibility};
4801              
4802 7         11 my @indices = @{$self->{_db_indices}};
  7         14  
4803 7         8 my $reserved = 0x00000000;
4804 7         8 my $row_min = $self->{_dim_rowmin};
4805 7         10 my $row_max = $self->{_dim_rowmax};
4806              
4807 7         8 my $record = 0x020B; # Record identifier
4808 7         7 my $length = 16 + 4 * @indices; # Bytes to follow
4809              
4810 7         9 my $header = pack 'vv', $record, $length;
4811 7         15 my $data = pack 'VVVV', $reserved,
4812             $row_min,
4813             $row_max,
4814             $reserved;
4815              
4816 7         8 for my $index (@indices) {
4817 7         23 $data .= pack 'V', $index + $self->{_offset} + 20 + $length +4;
4818             }
4819              
4820 7         18 $self->_prepend($header, $data);
4821              
4822             }
4823              
4824              
4825             ###############################################################################
4826             #
4827             # insert_chart($row, $col, $chart, $x, $y, $scale_x, $scale_y)
4828             #
4829             # Insert a chart into a worksheet. The $chart argument should be a Chart
4830             # object or else it is assumed to be a filename of an external binary file.
4831             # The latter is for backwards compatibility.
4832             #
4833             sub insert_chart {
4834              
4835 0     0 0 0 my $self = shift;
4836              
4837             # Check for a cell reference in A1 notation and substitute row and column
4838 0 0       0 if ($_[0] =~ /^\D/) {
4839 0         0 @_ = $self->_substitute_cellref(@_);
4840             }
4841              
4842 0         0 my $row = $_[0];
4843 0         0 my $col = $_[1];
4844 0         0 my $chart = $_[2];
4845 0   0     0 my $x_offset = $_[3] || 0;
4846 0   0     0 my $y_offset = $_[4] || 0;
4847 0   0     0 my $scale_x = $_[5] || 1;
4848 0   0     0 my $scale_y = $_[6] || 1;
4849              
4850 0 0       0 croak "Insufficient arguments in insert_chart()" unless @_ >= 3;
4851              
4852 0 0       0 if ( ref $chart ) {
4853             # Check for a Chart object.
4854 0 0       0 croak "Not a Chart object in insert_chart()"
4855             unless $chart->isa( 'Spreadsheet::WriteExcel::Chart' );
4856              
4857             # Check that the chart is an embedded style chart.
4858 0 0       0 croak "Not a embedded style Chart object in insert_chart()"
4859             unless $chart->{_embedded};
4860              
4861             }
4862             else {
4863              
4864             # Assume an external bin filename.
4865 0 0       0 croak "Couldn't locate $chart in insert_chart(): $!" unless -e $chart;
4866             }
4867              
4868 0         0 $self->{_charts}->{$row}->{$col} = [
4869             $row,
4870             $col,
4871             $chart,
4872             $x_offset,
4873             $y_offset,
4874             $scale_x,
4875             $scale_y,
4876             ];
4877              
4878             }
4879              
4880             # Older method name for backwards compatibility.
4881             *embed_chart = *insert_chart;
4882              
4883             ###############################################################################
4884             #
4885             # insert_image($row, $col, $filename, $x, $y, $scale_x, $scale_y)
4886             #
4887             # Insert an image into the worksheet.
4888             #
4889             sub insert_image {
4890              
4891 0     0 0 0 my $self = shift;
4892              
4893             # Check for a cell reference in A1 notation and substitute row and column
4894 0 0       0 if ($_[0] =~ /^\D/) {
4895 0         0 @_ = $self->_substitute_cellref(@_);
4896             }
4897              
4898 0         0 my $row = $_[0];
4899 0         0 my $col = $_[1];
4900 0         0 my $image = $_[2];
4901 0   0     0 my $x_offset = $_[3] || 0;
4902 0   0     0 my $y_offset = $_[4] || 0;
4903 0   0     0 my $scale_x = $_[5] || 1;
4904 0   0     0 my $scale_y = $_[6] || 1;
4905              
4906 0 0       0 croak "Insufficient arguments in insert_image()" unless @_ >= 3;
4907 0 0       0 croak "Couldn't locate $image: $!" unless -e $image;
4908              
4909 0         0 $self->{_images}->{$row}->{$col} = [
4910             $row,
4911             $col,
4912             $image,
4913             $x_offset,
4914             $y_offset,
4915             $scale_x,
4916             $scale_y,
4917             ];
4918              
4919             }
4920              
4921             # Older method name for backwards compatibility.
4922             *insert_bitmap = *insert_image;
4923              
4924              
4925             ###############################################################################
4926             #
4927             # _position_object()
4928             #
4929             # Calculate the vertices that define the position of a graphical object within
4930             # the worksheet.
4931             #
4932             # +------------+------------+
4933             # | A | B |
4934             # +-----+------------+------------+
4935             # | |(x1,y1) | |
4936             # | 1 |(A1)._______|______ |
4937             # | | | | |
4938             # | | | | |
4939             # +-----+----| BITMAP |-----+
4940             # | | | | |
4941             # | 2 | |______________. |
4942             # | | | (B2)|
4943             # | | | (x2,y2)|
4944             # +---- +------------+------------+
4945             #
4946             # Example of a bitmap that covers some of the area from cell A1 to cell B2.
4947             #
4948             # Based on the width and height of the bitmap we need to calculate 8 vars:
4949             # $col_start, $row_start, $col_end, $row_end, $x1, $y1, $x2, $y2.
4950             # The width and height of the cells are also variable and have to be taken into
4951             # account.
4952             # The values of $col_start and $row_start are passed in from the calling
4953             # function. The values of $col_end and $row_end are calculated by subtracting
4954             # the width and height of the bitmap from the width and height of the
4955             # underlying cells.
4956             # The vertices are expressed as a percentage of the underlying cell width as
4957             # follows (rhs values are in pixels):
4958             #
4959             # x1 = X / W *1024
4960             # y1 = Y / H *256
4961             # x2 = (X-1) / W *1024
4962             # y2 = (Y-1) / H *256
4963             #
4964             # Where: X is distance from the left side of the underlying cell
4965             # Y is distance from the top of the underlying cell
4966             # W is the width of the cell
4967             # H is the height of the cell
4968             #
4969             # Note: the SDK incorrectly states that the height should be expressed as a
4970             # percentage of 1024.
4971             #
4972             sub _position_object {
4973              
4974 22589     22589   53899 my $self = shift;
4975              
4976 22589         25043 my $col_start; # Col containing upper left corner of object
4977             my $x1; # Distance to left side of object
4978              
4979 0         0 my $row_start; # Row containing top left corner of object
4980 0         0 my $y1; # Distance to top of object
4981              
4982 0         0 my $col_end; # Col containing lower right corner of object
4983 0         0 my $x2; # Distance to right side of object
4984              
4985 0         0 my $row_end; # Row containing bottom right corner of object
4986 0         0 my $y2; # Distance to bottom of object
4987              
4988 0         0 my $width; # Width of image frame
4989 0         0 my $height; # Height of image frame
4990              
4991 22589         46103 ($col_start, $row_start, $x1, $y1, $width, $height) = @_;
4992              
4993              
4994             # Adjust start column for offsets that are greater than the col width
4995 22589         56413 while ($x1 >= $self->_size_col($col_start)) {
4996 0         0 $x1 -= $self->_size_col($col_start);
4997 0         0 $col_start++;
4998             }
4999              
5000             # Adjust start row for offsets that are greater than the row height
5001 22589         46808 while ($y1 >= $self->_size_row($row_start)) {
5002 0         0 $y1 -= $self->_size_row($row_start);
5003 0         0 $row_start++;
5004             }
5005              
5006              
5007             # Initialise end cell to the same as the start cell
5008 22589         27767 $col_end = $col_start;
5009 22589         23715 $row_end = $row_start;
5010              
5011 22589         28155 $width = $width + $x1;
5012 22589         32191 $height = $height + $y1;
5013              
5014              
5015             # Subtract the underlying cell widths to find the end cell of the image
5016 22589         43412 while ($width >= $self->_size_col($col_end)) {
5017 45145         88533 $width -= $self->_size_col($col_end);
5018 45145         92158 $col_end++;
5019             }
5020              
5021             # Subtract the underlying cell heights to find the end cell of the image
5022 22589         48758 while ($height >= $self->_size_row($row_end)) {
5023 90277         167282 $height -= $self->_size_row($row_end);
5024 90277         168731 $row_end++;
5025             }
5026              
5027             # Bitmap isn't allowed to start or finish in a hidden cell, i.e. a cell
5028             # with zero eight or width.
5029             #
5030 22589 50       44500 return if $self->_size_col($col_start) == 0;
5031 22589 50       40260 return if $self->_size_col($col_end) == 0;
5032 22589 50       44599 return if $self->_size_row($row_start) == 0;
5033 22589 50       46870 return if $self->_size_row($row_end) == 0;
5034              
5035             # Convert the pixel values to the percentage value expected by Excel
5036 22589         44239 $x1 = $x1 / $self->_size_col($col_start) * 1024;
5037 22589         51366 $y1 = $y1 / $self->_size_row($row_start) * 256;
5038 22589         41326 $x2 = $width / $self->_size_col($col_end) * 1024;
5039 22589         42683 $y2 = $height / $self->_size_row($row_end) * 256;
5040              
5041             # Simulate ceil() without calling POSIX::ceil().
5042 22589         35173 $x1 = int($x1 +0.5);
5043 22589         24594 $y1 = int($y1 +0.5);
5044 22589         26174 $x2 = int($x2 +0.5);
5045 22589         25107 $y2 = int($y2 +0.5);
5046              
5047 22589         93624 return( $col_start, $x1,
5048             $row_start, $y1,
5049             $col_end, $x2,
5050             $row_end, $y2
5051             );
5052             }
5053              
5054              
5055             ###############################################################################
5056             #
5057             # _size_col($col)
5058             #
5059             # Convert the width of a cell from user's units to pixels. Excel rounds the
5060             # column width to the nearest pixel. If the width hasn't been set by the user
5061             # we use the default value. If the column is hidden we use a value of zero.
5062             #
5063             sub _size_col {
5064              
5065 225824     225824   292330 my $self = shift;
5066 225824         243717 my $col = $_[0];
5067              
5068             # Look up the cell value to see if it has been changed
5069 225824 100       457753 if (exists $self->{_col_sizes}->{$col}) {
5070 17         25 my $width = $self->{_col_sizes}->{$col};
5071              
5072             # The relationship is different for user units less than 1.
5073 17 50       27 if ($width < 1) {
5074 0         0 return int($width *12);
5075             }
5076             else {
5077 17         44 return int($width *7 ) +5;
5078             }
5079             }
5080             else {
5081 225807         591597 return 64;
5082             }
5083             }
5084              
5085              
5086             ###############################################################################
5087             #
5088             # _size_row($row)
5089             #
5090             # Convert the height of a cell from user's units to pixels. By interpolation
5091             # the relationship is: y = 4/3x. If the height hasn't been set by the user we
5092             # use the default value. If the row is hidden we use a value of zero. (Not
5093             # possible to hide row yet).
5094             #
5095             sub _size_row {
5096              
5097 316088     316088   349387 my $self = shift;
5098 316088         331533 my $row = $_[0];
5099              
5100             # Look up the cell value to see if it has been changed
5101 316088 100       639257 if (exists $self->{_row_sizes}->{$row}) {
5102 11 50       26 if ($self->{_row_sizes}->{$row} == 0) {
5103 0         0 return 0;
5104             }
5105             else {
5106 11         34 return int (4/3 * $self->{_row_sizes}->{$row});
5107             }
5108             }
5109             else {
5110 316077         668052 return 17;
5111             }
5112             }
5113              
5114              
5115             ###############################################################################
5116             #
5117             # _store_zoom($zoom)
5118             #
5119             #
5120             # Store the window zoom factor. This should be a reduced fraction but for
5121             # simplicity we will store all fractions with a numerator of 100.
5122             #
5123             sub _store_zoom {
5124              
5125 137     137   186 my $self = shift;
5126              
5127             # If scale is 100 we don't need to write a record
5128 137 50       478 return if $self->{_zoom} == 100;
5129              
5130 0         0 my $record = 0x00A0; # Record identifier
5131 0         0 my $length = 0x0004; # Bytes to follow
5132              
5133 0         0 my $header = pack("vv", $record, $length );
5134 0         0 my $data = pack("vv", $self->{_zoom}, 100);
5135              
5136 0         0 $self->_append($header, $data);
5137             }
5138              
5139              
5140             ###############################################################################
5141             #
5142             # write_utf16be_string($row, $col, $string, $format)
5143             #
5144             # Write a Unicode string to the specified row and column (zero indexed).
5145             # $format is optional.
5146             # Returns 0 : normal termination
5147             # -1 : insufficient number of arguments
5148             # -2 : row or column out of range
5149             # -3 : long string truncated to 255 chars
5150             #
5151             sub write_utf16be_string {
5152              
5153 2     2 0 48 my $self = shift;
5154              
5155             # Check for a cell reference in A1 notation and substitute row and column
5156 2 50       12 if ($_[0] =~ /^\D/) {
5157 0         0 @_ = $self->_substitute_cellref(@_);
5158             }
5159              
5160 2 50       7 if (@_ < 3) { return -1 } # Check the number of args
  0         0  
5161              
5162 2         3 my $record = 0x00FD; # Record identifier
5163 2         5 my $length = 0x000A; # Bytes to follow
5164              
5165 2         3 my $row = $_[0]; # Zero indexed row
5166 2         3 my $col = $_[1]; # Zero indexed column
5167 2         4 my $strlen = length($_[2]);
5168 2         4 my $str = $_[2];
5169 2         17 my $xf = _XF($self, $row, $col, $_[3]); # The cell format
5170 2         4 my $encoding = 0x1;
5171 2         3 my $str_error = 0;
5172              
5173             # Check that row and col are valid and store max and min values
5174 2 50       8 return -2 if $self->_check_dimensions($row, $col);
5175              
5176             # Limit the utf16 string to the max number of chars (not bytes).
5177 2 50       7 if ($strlen > 32767* 2) {
5178 0         0 $str = substr($str, 0, 32767*2);
5179 0         0 $str_error = -3;
5180             }
5181              
5182              
5183 2         3 my $num_bytes = length $str;
5184 2         7 my $num_chars = int($num_bytes / 2);
5185              
5186              
5187             # Check for a valid 2-byte char string.
5188 2 50       6 croak "Uneven number of bytes in Unicode string" if $num_bytes % 2;
5189              
5190              
5191             # Change from UTF16 big-endian to little endian
5192 2         9 $str = pack "v*", unpack "n*", $str;
5193              
5194              
5195             # Add the encoding and length header to the string.
5196 2         6 my $str_header = pack("vC", $num_chars, $encoding);
5197 2         5 $str = $str_header . $str;
5198              
5199              
5200 2 50       3 if (not exists ${$self->{_str_table}}->{$str}) {
  2         9  
5201 2         2 ${$self->{_str_table}}->{$str} = ${$self->{_str_unique}}++;
  2         7  
  2         4  
5202             }
5203              
5204              
5205 2         2 ${$self->{_str_total}}++;
  2         3  
5206              
5207              
5208 2         5 my $header = pack("vv", $record, $length);
5209 2         4 my $data = pack("vvvV", $row, $col, $xf, ${$self->{_str_table}}->{$str});
  2         8  
5210              
5211             # Store the data or write immediately depending on the compatibility mode.
5212 2 50       9 if ($self->{_compatibility}) {
5213 0         0 $self->{_table}->[$row]->[$col] = $header . $data;
5214             }
5215             else {
5216 2         12 $self->_append($header, $data);
5217             }
5218              
5219 2         6 return $str_error;
5220             }
5221              
5222              
5223             ###############################################################################
5224             #
5225             # write_utf16le_string($row, $col, $string, $format)
5226             #
5227             # Write a UTF-16LE string to the specified row and column (zero indexed).
5228             # $format is optional.
5229             # Returns 0 : normal termination
5230             # -1 : insufficient number of arguments
5231             # -2 : row or column out of range
5232             # -3 : long string truncated to 255 chars
5233             #
5234             sub write_utf16le_string {
5235              
5236 1     1 0 7 my $self = shift;
5237              
5238             # Check for a cell reference in A1 notation and substitute row and column
5239 1 50       7 if ($_[0] =~ /^\D/) {
5240 0         0 @_ = $self->_substitute_cellref(@_);
5241             }
5242              
5243 1 50       19 if (@_ < 3) { return -1 } # Check the number of args
  0         0  
5244              
5245 1         2 my $record = 0x00FD; # Record identifier
5246 1         2 my $length = 0x000A; # Bytes to follow
5247              
5248 1         2 my $row = $_[0]; # Zero indexed row
5249 1         3 my $col = $_[1]; # Zero indexed column
5250 1         2 my $str = $_[2];
5251 1         3 my $format = $_[3]; # The cell format
5252              
5253              
5254             # Change from UTF16 big-endian to little endian
5255 1         5 $str = pack "v*", unpack "n*", $str;
5256              
5257              
5258 1         4 return $self->write_utf16be_string($row, $col, $str, $format);
5259             }
5260              
5261              
5262             # Older method name for backwards compatibility.
5263             *write_unicode = *write_utf16be_string;
5264             *write_unicode_le = *write_utf16le_string;
5265              
5266              
5267              
5268             ###############################################################################
5269             #
5270             # _store_autofilters()
5271             #
5272             # Function to iterate through the columns that form part of an autofilter
5273             # range and write Biff AUTOFILTER records if a filter expression has been set.
5274             #
5275             sub _store_autofilters {
5276              
5277 133     133   241 my $self = shift;
5278              
5279             # Skip all columns if no filter have been set.
5280 133 50       481 return unless $self->{_filter_on};
5281              
5282 0         0 my (undef, undef, $col1, $col2) = @{$self->{_filter_area}};
  0         0  
5283              
5284 0         0 for my $i ($col1 .. $col2) {
5285             # Reverse order since records are being pre-pended.
5286 0         0 my $col = $col2 -$i;
5287              
5288             # Skip if column doesn't have an active filter.
5289 0 0       0 next unless $self->{_filter_cols}->{$col};
5290              
5291             # Retrieve the filter tokens
5292 0         0 my @tokens = @{$self->{_filter_cols}->{$col}};
  0         0  
5293              
5294             # Filter columns are relative to the first column in the filter.
5295 0         0 my $filter_col = $col - $col1;
5296              
5297             # Write the autofilter records.
5298 0         0 $self->_store_autofilter($filter_col, @tokens);
5299             }
5300             }
5301              
5302              
5303             ###############################################################################
5304             #
5305             # _store_autofilter()
5306             #
5307             # Function to write worksheet AUTOFILTER records. These contain 2 Biff Doper
5308             # structures to represent the 2 possible filter conditions.
5309             #
5310             sub _store_autofilter {
5311              
5312 29     29   128 my $self = shift;
5313              
5314 29         38 my $record = 0x009E;
5315 29         29 my $length = 0x0000;
5316              
5317 29         36 my $index = $_[0];
5318 29         76 my $operator_1 = $_[1];
5319 29         36 my $token_1 = $_[2];
5320 29         32 my $join = $_[3]; # And/Or
5321 29         33 my $operator_2 = $_[4];
5322 29         27 my $token_2 = $_[5];
5323              
5324 29         28 my $top10_active = 0;
5325 29         32 my $top10_direction = 0;
5326 29         29 my $top10_percent = 0;
5327 29         32 my $top10_value = 101;
5328              
5329 29         36 my $grbit = $join;
5330 29         25 my $optimised_1 = 0;
5331 29         24 my $optimised_2 = 0;
5332 29         37 my $doper_1 = '';
5333 29         32 my $doper_2 = '';
5334 29         31 my $string_1 = '';
5335 29         32 my $string_2 = '';
5336              
5337             # Excel used an optimisation in the case of a simple equality.
5338 29 100       71 $optimised_1 = 1 if $operator_1 == 2;
5339 29 100 100     77 $optimised_2 = 1 if defined $operator_2 and $operator_2 == 2;
5340              
5341              
5342             # Convert non-simple equalities back to type 2. See _parse_filter_tokens().
5343 29 100       55 $operator_1 = 2 if $operator_1 == 22;
5344 29 50 66     67 $operator_2 = 2 if defined $operator_2 and $operator_2 == 22;
5345              
5346              
5347             # Handle a "Top" style expression.
5348 29 100       64 if ($operator_1 >= 30) {
5349             # Remove the second expression if present.
5350 7         11 $operator_2 = undef;
5351 7         9 $token_2 = undef;
5352              
5353             # Set the active flag.
5354 7         14 $top10_active = 1;
5355              
5356 7 100 100     27 if ($operator_1 == 30 or $operator_1 == 31) {
5357 5         7 $top10_direction = 1;
5358             }
5359              
5360 7 100 100     34 if ($operator_1 == 31 or $operator_1 == 33) {
5361 2         3 $top10_percent = 1;
5362             }
5363              
5364 7 100       17 if ($top10_direction == 1) {
5365 5         7 $operator_1 = 6
5366             }
5367             else {
5368 2         4 $operator_1 = 3
5369             }
5370              
5371 7         9 $top10_value = $token_1;
5372 7         9 $token_1 = 0;
5373             }
5374              
5375              
5376 29         42 $grbit |= $optimised_1 << 2;
5377 29         33 $grbit |= $optimised_2 << 3;
5378 29         35 $grbit |= $top10_active << 4;
5379 29         30 $grbit |= $top10_direction << 5;
5380 29         32 $grbit |= $top10_percent << 6;
5381 29         30 $grbit |= $top10_value << 7;
5382              
5383 29         75 ($doper_1, $string_1) = $self->_pack_doper($operator_1, $token_1);
5384 29         79 ($doper_2, $string_2) = $self->_pack_doper($operator_2, $token_2);
5385              
5386 29         71 my $data = pack 'v', $index;
5387 29         45 $data .= pack 'v', $grbit;
5388 29         37 $data .= $doper_1;
5389 29         32 $data .= $doper_2;
5390 29         31 $data .= $string_1;
5391 29         39 $data .= $string_2;
5392              
5393 29         33 $length = length $data;
5394 29         53 my $header = pack('vv', $record, $length);
5395              
5396 29         103 $self->_prepend($header, $data);
5397             }
5398              
5399              
5400             ###############################################################################
5401             #
5402             # _pack_doper()
5403             #
5404             # Create a Biff Doper structure that represents a filter expression. Depending
5405             # on the type of the token we pack an Empty, String or Number doper.
5406             #
5407             sub _pack_doper {
5408              
5409 58     58   76 my $self = shift;
5410              
5411 58         62 my $operator = $_[0];
5412 58         80 my $token = $_[1];
5413              
5414 58         67 my $doper = '';
5415 58         58 my $string = '';
5416              
5417              
5418             # Return default doper for non-defined filters.
5419 58 100       124 if (not defined $operator) {
5420 26         59 return ($self->_pack_unused_doper, $string);
5421             }
5422              
5423              
5424 32 100 100     1175 if ($token =~ /^blanks|nonblanks$/i) {
    100          
5425 2         8 $doper = $self->_pack_blanks_doper($operator, $token);
5426             }
5427             elsif ($operator == 2 or
5428             $token !~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/)
5429             {
5430             # Excel treats all tokens as strings if the operator is equality, =.
5431              
5432 14         20 $string = $token;
5433              
5434 14         17 my $encoding = 0;
5435 14         21 my $length = length $string;
5436              
5437             # Handle utf8 strings in perl 5.8.
5438 14 50       35 if ($] >= 5.008) {
5439 14         83 require Encode;
5440              
5441 14 50       74 if (Encode::is_utf8($string)) {
5442 0         0 $string = Encode::encode("UTF-16BE", $string);
5443 0         0 $encoding = 1;
5444             }
5445             }
5446              
5447 14         47 $string = pack('C', $encoding) . $string;
5448 14         39 $doper = $self->_pack_string_doper($operator, $length);
5449             }
5450             else {
5451 16         27 $string = '';
5452 16         39 $doper = $self->_pack_number_doper($operator, $token);
5453             }
5454              
5455 32         109 return ($doper, $string);
5456             }
5457              
5458              
5459             ###############################################################################
5460             #
5461             # _pack_unused_doper()
5462             #
5463             # Pack an empty Doper structure.
5464             #
5465             sub _pack_unused_doper {
5466              
5467 26     26   33 my $self = shift;
5468              
5469 26         136 return pack 'C10', (0x0) x 10;
5470             }
5471              
5472              
5473             ###############################################################################
5474             #
5475             # _pack_blanks_doper()
5476             #
5477             # Pack an Blanks/NonBlanks Doper structure.
5478             #
5479             sub _pack_blanks_doper {
5480              
5481 2     2   3 my $self = shift;
5482              
5483 2         3 my $operator = $_[0];
5484 2         9 my $token = $_[1];
5485 2         2 my $type;
5486              
5487 2 100       6 if ($token eq 'blanks') {
5488 1         2 $type = 0x0C;
5489 1         7 $operator = 2;
5490              
5491             }
5492             else {
5493 1         3 $type = 0x0E;
5494 1         2 $operator = 5;
5495             }
5496              
5497              
5498 2         12 my $doper = pack 'CCVV', $type, # Data type
5499             $operator, #
5500             0x0000, # Reserved
5501             0x0000; # Reserved
5502 2         6 return $doper;
5503             }
5504              
5505              
5506             ###############################################################################
5507             #
5508             # _pack_string_doper()
5509             #
5510             # Pack an string Doper structure.
5511             #
5512             sub _pack_string_doper {
5513              
5514 14     14   24 my $self = shift;
5515              
5516 14         18 my $operator = $_[0];
5517 14         2554 my $length = $_[1];
5518 14         42 my $doper = pack 'CCVCCCC', 0x06, # Data type
5519             $operator, #
5520             0x0000, # Reserved
5521             $length, # String char length.
5522             0x0, 0x0, 0x0; # Reserved
5523 14         39 return $doper;
5524             }
5525              
5526              
5527             ###############################################################################
5528             #
5529             # _pack_number_doper()
5530             #
5531             # Pack an IEEE double number Doper structure.
5532             #
5533             sub _pack_number_doper {
5534              
5535 16     16   19 my $self = shift;
5536              
5537 16         17 my $operator = $_[0];
5538 16         25 my $number = $_[1];
5539 16         53 $number = pack 'd', $number;
5540 16 50       46 $number = reverse $number if $self->{_byte_order};
5541              
5542 16         35 my $doper = pack 'CC', 0x04, $operator;
5543 16         20 $doper .= $number;
5544              
5545 16         43 return $doper;
5546             }
5547              
5548              
5549             #
5550             # Methods related to comments and MSO objects.
5551             #
5552              
5553              
5554             ###############################################################################
5555             #
5556             # _prepare_images()
5557             #
5558             # Turn the HoH that stores the images into an array for easier handling.
5559             #
5560             sub _prepare_images {
5561              
5562 166     166   256 my $self = shift;
5563              
5564 166         239 my $count = 0;
5565 166         240 my @images;
5566              
5567              
5568             # We sort the images by row and column but that isn't strictly required.
5569             #
5570 166         227 my @rows = sort {$a <=> $b} keys %{$self->{_images}};
  0         0  
  166         694  
5571              
5572 166         400 for my $row (@rows) {
5573 0         0 my @cols = sort {$a <=> $b} keys %{$self->{_images}->{$row}};
  0         0  
  0         0  
5574              
5575 0         0 for my $col (@cols) {
5576 0         0 push @images, $self->{_images}->{$row}->{$col};
5577 0         0 $count++;
5578             }
5579             }
5580              
5581 166         440 $self->{_images} = {};
5582 166         693 $self->{_images_array} = \@images;
5583              
5584 166         1085 return $count;
5585             }
5586              
5587              
5588             ###############################################################################
5589             #
5590             # _prepare_comments()
5591             #
5592             # Turn the HoH that stores the comments into an array for easier handling.
5593             #
5594             sub _prepare_comments {
5595              
5596 166     166   326 my $self = shift;
5597              
5598 166         227 my $count = 0;
5599 166         290 my @comments;
5600              
5601              
5602             # We sort the comments by row and column but that isn't strictly required.
5603             #
5604 166         290 my @rows = sort {$a <=> $b} keys %{$self->{_comments}};
  181211         217048  
  166         7101  
5605              
5606 166         1663 for my $row (@rows) {
5607 20492         20991 my @cols = sort {$a <=> $b} keys %{$self->{_comments}->{$row}};
  0         0  
  20492         83339  
5608              
5609 20492         31832 for my $col (@cols) {
5610 20492         43963 push @comments, $self->{_comments}->{$row}->{$col};
5611 20492         49228 $count++;
5612             }
5613             }
5614              
5615 166         348 $self->{_comments} = {};
5616 166         16855 $self->{_comments_array} = \@comments;
5617              
5618 166         52697 return $count;
5619             }
5620              
5621              
5622             ###############################################################################
5623             #
5624             # _prepare_charts()
5625             #
5626             # Turn the HoH that stores the charts into an array for easier handling.
5627             #
5628             sub _prepare_charts {
5629              
5630 166     166   308 my $self = shift;
5631              
5632 166         267 my $count = 0;
5633 166         273 my @charts;
5634              
5635              
5636             # We sort the charts by row and column but that isn't strictly required.
5637             #
5638 166         287 my @rows = sort {$a <=> $b} keys %{$self->{_charts}};
  0         0  
  166         689  
5639              
5640 166         475 for my $row (@rows) {
5641 0         0 my @cols = sort {$a <=> $b} keys %{$self->{_charts}->{$row}};
  0         0  
  0         0  
5642              
5643 0         0 for my $col (@cols) {
5644 0         0 push @charts, $self->{_charts}->{$row}->{$col};
5645 0         0 $count++;
5646             }
5647             }
5648              
5649 166         375 $self->{_charts} = {};
5650 166         450 $self->{_charts_array} = \@charts;
5651              
5652 166         570 return $count;
5653             }
5654              
5655              
5656             ###############################################################################
5657             #
5658             # _store_images()
5659             #
5660             # Store the collections of records that make up images.
5661             #
5662             sub _store_images {
5663              
5664 133     133   194 my $self = shift;
5665              
5666 133         179 my $record = 0x00EC; # Record identifier
5667 133         175 my $length = 0x0000; # Bytes to follow
5668              
5669 133         195 my @ids = @{$self->{_object_ids }};
  133         450  
5670 133         222 my $spid = shift @ids;
5671              
5672 133         188 my @images = @{$self->{_images_array}};
  133         306  
5673 133         213 my $num_images = scalar @images;
5674              
5675 133         233 my $num_filters = $self->{_filter_count};
5676 133         171 my $num_comments = @{$self->{_comments_array}};
  133         283  
5677 133         162 my $num_charts = @{$self->{_charts_array }};
  133         295  
5678              
5679             # Skip this if there aren't any images.
5680 133 50       462 return unless $num_images;
5681              
5682 0         0 for my $i (0 .. $num_images-1) {
5683 0         0 my $row = $images[$i]->[0];
5684 0         0 my $col = $images[$i]->[1];
5685 0         0 my $name = $images[$i]->[2];
5686 0         0 my $x_offset = $images[$i]->[3];
5687 0         0 my $y_offset = $images[$i]->[4];
5688 0         0 my $scale_x = $images[$i]->[5];
5689 0         0 my $scale_y = $images[$i]->[6];
5690 0         0 my $image_id = $images[$i]->[7];
5691 0         0 my $type = $images[$i]->[8];
5692 0         0 my $width = $images[$i]->[9];
5693 0         0 my $height = $images[$i]->[10];
5694              
5695 0 0       0 $width *= $scale_x if $scale_x;
5696 0 0       0 $height *= $scale_y if $scale_y;
5697              
5698              
5699             # Calculate the positions of image object.
5700 0         0 my @vertices = $self->_position_object( $col,
5701             $row,
5702             $x_offset,
5703             $y_offset,
5704             $width,
5705             $height
5706             );
5707              
5708 0 0       0 if ($i == 0) {
5709             # Write the parent MSODRAWIING record.
5710 0         0 my $dg_length = 156 + 84*($num_images -1);
5711 0         0 my $spgr_length = 132 + 84*($num_images -1);
5712              
5713 0         0 $dg_length += 120 *$num_charts;
5714 0         0 $spgr_length += 120 *$num_charts;
5715              
5716 0         0 $dg_length += 96 *$num_filters;
5717 0         0 $spgr_length += 96 *$num_filters;
5718              
5719 0         0 $dg_length += 128 *$num_comments;
5720 0         0 $spgr_length += 128 *$num_comments;
5721              
5722              
5723              
5724 0         0 my $data = $self->_store_mso_dg_container($dg_length);
5725 0         0 $data .= $self->_store_mso_dg(@ids);
5726 0         0 $data .= $self->_store_mso_spgr_container($spgr_length);
5727 0         0 $data .= $self->_store_mso_sp_container(40);
5728 0         0 $data .= $self->_store_mso_spgr();
5729 0         0 $data .= $self->_store_mso_sp(0x0, $spid++, 0x0005);
5730 0         0 $data .= $self->_store_mso_sp_container(76);
5731 0         0 $data .= $self->_store_mso_sp(75, $spid++, 0x0A00);
5732 0         0 $data .= $self->_store_mso_opt_image($image_id);
5733 0         0 $data .= $self->_store_mso_client_anchor(2, @vertices);
5734 0         0 $data .= $self->_store_mso_client_data();
5735              
5736 0         0 $length = length $data;
5737 0         0 my $header = pack("vv", $record, $length);
5738 0         0 $self->_append($header, $data);
5739              
5740             }
5741             else {
5742             # Write the child MSODRAWIING record.
5743 0         0 my $data = $self->_store_mso_sp_container(76);
5744 0         0 $data .= $self->_store_mso_sp(75, $spid++, 0x0A00);
5745 0         0 $data .= $self->_store_mso_opt_image($image_id);
5746 0         0 $data .= $self->_store_mso_client_anchor(2, @vertices);
5747 0         0 $data .= $self->_store_mso_client_data();
5748              
5749 0         0 $length = length $data;
5750 0         0 my $header = pack("vv", $record, $length);
5751 0         0 $self->_append($header, $data);
5752              
5753              
5754             }
5755              
5756 0         0 $self->_store_obj_image($i+1);
5757             }
5758              
5759 0         0 $self->{_object_ids}->[0] = $spid;
5760             }
5761              
5762              
5763              
5764             ###############################################################################
5765             #
5766             # _store_charts()
5767             #
5768             # Store the collections of records that make up charts.
5769             #
5770             sub _store_charts {
5771              
5772 133     133   194 my $self = shift;
5773              
5774 133         182 my $record = 0x00EC; # Record identifier
5775 133         202 my $length = 0x0000; # Bytes to follow
5776              
5777 133         189 my @ids = @{$self->{_object_ids}};
  133         319  
5778 133         224 my $spid = shift @ids;
5779              
5780 133         169 my @charts = @{$self->{_charts_array}};
  133         270  
5781 133         218 my $num_charts = scalar @charts;
5782              
5783 133         213 my $num_filters = $self->{_filter_count};
5784 133         157 my $num_comments = @{$self->{_comments_array}};
  133         252  
5785              
5786             # Number of objects written so far.
5787 133         192 my $num_objects = @{$self->{_images_array}};
  133         240  
5788              
5789             # Skip this if there aren't any charts.
5790 133 50       412 return unless $num_charts;
5791              
5792 0         0 for my $i (0 .. $num_charts-1 ) {
5793 0         0 my $row = $charts[$i]->[0];
5794 0         0 my $col = $charts[$i]->[1];
5795 0         0 my $chart = $charts[$i]->[2];
5796 0         0 my $x_offset = $charts[$i]->[3];
5797 0         0 my $y_offset = $charts[$i]->[4];
5798 0         0 my $scale_x = $charts[$i]->[5];
5799 0         0 my $scale_y = $charts[$i]->[6];
5800 0         0 my $width = 526;
5801 0         0 my $height = 319;
5802              
5803 0 0       0 $width *= $scale_x if $scale_x;
5804 0 0       0 $height *= $scale_y if $scale_y;
5805              
5806             # Calculate the positions of chart object.
5807 0         0 my @vertices = $self->_position_object( $col,
5808             $row,
5809             $x_offset,
5810             $y_offset,
5811             $width,
5812             $height
5813             );
5814              
5815              
5816 0 0 0     0 if ($i == 0 and not $num_objects) {
5817             # Write the parent MSODRAWIING record.
5818 0         0 my $dg_length = 192 + 120*($num_charts -1);
5819 0         0 my $spgr_length = 168 + 120*($num_charts -1);
5820              
5821 0         0 $dg_length += 96 *$num_filters;
5822 0         0 $spgr_length += 96 *$num_filters;
5823              
5824 0         0 $dg_length += 128 *$num_comments;
5825 0         0 $spgr_length += 128 *$num_comments;
5826              
5827              
5828 0         0 my $data = $self->_store_mso_dg_container($dg_length);
5829 0         0 $data .= $self->_store_mso_dg(@ids);
5830 0         0 $data .= $self->_store_mso_spgr_container($spgr_length);
5831 0         0 $data .= $self->_store_mso_sp_container(40);
5832 0         0 $data .= $self->_store_mso_spgr();
5833 0         0 $data .= $self->_store_mso_sp(0x0, $spid++, 0x0005);
5834 0         0 $data .= $self->_store_mso_sp_container(112);
5835 0         0 $data .= $self->_store_mso_sp(201, $spid++, 0x0A00);
5836 0         0 $data .= $self->_store_mso_opt_chart();
5837 0         0 $data .= $self->_store_mso_client_anchor(0, @vertices);
5838 0         0 $data .= $self->_store_mso_client_data();
5839              
5840 0         0 $length = length $data;
5841 0         0 my $header = pack("vv", $record, $length);
5842 0         0 $self->_append($header, $data);
5843              
5844             }
5845             else {
5846             # Write the child MSODRAWIING record.
5847 0         0 my $data = $self->_store_mso_sp_container(112);
5848 0         0 $data .= $self->_store_mso_sp(201, $spid++, 0x0A00);
5849 0         0 $data .= $self->_store_mso_opt_chart();
5850 0         0 $data .= $self->_store_mso_client_anchor(0, @vertices);
5851 0         0 $data .= $self->_store_mso_client_data();
5852              
5853 0         0 $length = length $data;
5854 0         0 my $header = pack("vv", $record, $length);
5855 0         0 $self->_append($header, $data);
5856              
5857              
5858             }
5859              
5860 0         0 $self->_store_obj_chart($num_objects+$i+1);
5861 0         0 $self->_store_chart_binary($chart);
5862             }
5863              
5864              
5865             # Simulate the EXTERNSHEET link between the chart and data using a formula
5866             # such as '=Sheet1!A1'.
5867             # TODO. Won't work for external data refs. Also should use a more direct
5868             # method.
5869             #
5870 0         0 my $name = $self->{_name};
5871 0 0 0     0 if ($self->{_encoding} && $] >= 5.008) {
5872 0         0 require Encode;
5873 0         0 $name = Encode::decode('UTF-16BE', $name);
5874             }
5875 0         0 $self->store_formula("='$name'!A1");
5876              
5877 0         0 $self->{_object_ids}->[0] = $spid;
5878             }
5879              
5880              
5881             ###############################################################################
5882             #
5883             # _store_chart_binary
5884             #
5885             # Add the binary data for a chart. This could either be from a Chart object
5886             # or from an external binary file (for backwards compatibility).
5887             #
5888             sub _store_chart_binary {
5889              
5890 0     0   0 my $self = shift;
5891 0         0 my $chart = $_[0];
5892 0         0 my $tmp;
5893              
5894              
5895 0 0       0 if ( ref $chart ) {
5896 0         0 $chart->_close();
5897 0         0 my $tmp = $chart->get_data();
5898 0         0 $self->_append( $tmp );
5899             }
5900             else {
5901              
5902 0 0       0 my $filehandle = FileHandle->new( $chart )
5903             or die "Couldn't open $chart in insert_chart(): $!.\n";
5904              
5905 0         0 binmode( $filehandle );
5906              
5907 0         0 while ( read( $filehandle, $tmp, 4096 ) ) {
5908 0         0 $self->_append( $tmp );
5909             }
5910             }
5911             }
5912              
5913              
5914             ###############################################################################
5915             #
5916             # _store_filters()
5917             #
5918             # Store the collections of records that make up filters.
5919             #
5920             sub _store_filters {
5921              
5922 133     133   194 my $self = shift;
5923              
5924 133         174 my $record = 0x00EC; # Record identifier
5925 133         189 my $length = 0x0000; # Bytes to follow
5926              
5927 133         177 my @ids = @{$self->{_object_ids}};
  133         303  
5928 133         219 my $spid = shift @ids;
5929              
5930 133         237 my $filter_area = $self->{_filter_area};
5931 133         204 my $num_filters = $self->{_filter_count};
5932              
5933 133         184 my $num_comments = @{$self->{_comments_array}};
  133         265  
5934              
5935             # Number of objects written so far.
5936 133         241 my $num_objects = @{$self->{_images_array}}
  133         266  
5937 133         208 + @{$self->{_charts_array}};
5938              
5939             # Skip this if there aren't any filters.
5940 133 100       409 return unless $num_filters;
5941              
5942              
5943 3         9 my ($row1, $row2, $col1, $col2) = @$filter_area;
5944              
5945 3         7 for my $i (0 .. $num_filters-1 ) {
5946              
5947 9         28 my @vertices = ( $col1 +$i,
5948             0,
5949             $row1,
5950             0,
5951             $col1 +$i +1,
5952             0,
5953             $row1 +1,
5954             0);
5955              
5956 9 100 66     31 if ($i == 0 and not $num_objects) {
5957             # Write the parent MSODRAWIING record.
5958 3         7 my $dg_length = 168 + 96*($num_filters -1);
5959 3         8 my $spgr_length = 144 + 96*($num_filters -1);
5960              
5961 3         5 $dg_length += 128 *$num_comments;
5962 3         4 $spgr_length += 128 *$num_comments;
5963              
5964              
5965 3         13 my $data = $self->_store_mso_dg_container($dg_length);
5966 3         21 $data .= $self->_store_mso_dg(@ids);
5967 3         12 $data .= $self->_store_mso_spgr_container($spgr_length);
5968 3         11 $data .= $self->_store_mso_sp_container(40);
5969 3         11 $data .= $self->_store_mso_spgr();
5970 3         15 $data .= $self->_store_mso_sp(0x0, $spid++, 0x0005);
5971 3         10 $data .= $self->_store_mso_sp_container(88);
5972 3         12 $data .= $self->_store_mso_sp(201, $spid++, 0x0A00);
5973 3         12 $data .= $self->_store_mso_opt_filter();
5974 3         13 $data .= $self->_store_mso_client_anchor(1, @vertices);
5975 3         11 $data .= $self->_store_mso_client_data();
5976              
5977 3         5 $length = length $data;
5978 3         7 my $header = pack("vv", $record, $length);
5979 3         11 $self->_append($header, $data);
5980              
5981             }
5982             else {
5983             # Write the child MSODRAWIING record.
5984 6         15 my $data = $self->_store_mso_sp_container(88);
5985 6         16 $data .= $self->_store_mso_sp(201, $spid++, 0x0A00);
5986 6         16 $data .= $self->_store_mso_opt_filter();
5987 6         17 $data .= $self->_store_mso_client_anchor(1, @vertices);
5988 6         15 $data .= $self->_store_mso_client_data();
5989              
5990 6         9 $length = length $data;
5991 6         13 my $header = pack("vv", $record, $length);
5992 6         15 $self->_append($header, $data);
5993              
5994              
5995             }
5996              
5997 9         31 $self->_store_obj_filter($num_objects+$i+1, $col1 +$i);
5998             }
5999              
6000              
6001             # Simulate the EXTERNSHEET link between the filter and data using a formula
6002             # such as '=Sheet1!A1'.
6003             # TODO. Won't work for external data refs. Also should use a more direct
6004             # method.
6005             #
6006 3         12 my $formula = "='$self->{_name}'!A1";
6007 3         14 $self->store_formula($formula);
6008              
6009 3         22 $self->{_object_ids}->[0] = $spid;
6010             }
6011              
6012              
6013             ###############################################################################
6014             #
6015             # _store_comments()
6016             #
6017             # Store the collections of records that make up cell comments.
6018             #
6019             # NOTE: We write the comment objects last since that makes it a little easier
6020             # to write the NOTE records directly after the MSODRAWIING records.
6021             #
6022             sub _store_comments {
6023              
6024 133     133   188 my $self = shift;
6025              
6026 133         177 my $record = 0x00EC; # Record identifier
6027 133         185 my $length = 0x0000; # Bytes to follow
6028              
6029 133         181 my @ids = @{$self->{_object_ids}};
  133         298  
6030 133         283 my $spid = shift @ids;
6031              
6032 133         167 my @comments = @{$self->{_comments_array}};
  133         276  
6033 133         197 my $num_comments = scalar @comments;
6034              
6035             # Number of objects written so far.
6036 133         311 my $num_objects = @{$self->{_images_array}}
  133         254  
6037             + $self->{_filter_count}
6038 133         159 + @{$self->{_charts_array}};
6039              
6040             # Skip this if there aren't any comments.
6041 133 100       439 return unless $num_comments;
6042              
6043 1         4 for my $i (0 .. $num_comments-1) {
6044              
6045 1         4 my $row = $comments[$i]->[0];
6046 1         2 my $col = $comments[$i]->[1];
6047 1         2 my $str = $comments[$i]->[2];
6048 1         4 my $encoding = $comments[$i]->[3];
6049 1         2 my $visible = $comments[$i]->[6];
6050 1         3 my $color = $comments[$i]->[7];
6051 1         2 my @vertices = @{$comments[$i]->[8]};
  1         3  
6052 1         2 my $str_len = length $str;
6053 1 50       11 $str_len /= 2 if $encoding; # Num of chars not bytes.
6054 1         5 my $formats = [[0, 9], [$str_len, 0]];
6055              
6056              
6057 1 50 33     7 if ($i == 0 and not $num_objects) {
6058             # Write the parent MSODRAWIING record.
6059 1         3 my $dg_length = 200 + 128*($num_comments -1);
6060 1         2 my $spgr_length = 176 + 128*($num_comments -1);
6061              
6062 1         5 my $data = $self->_store_mso_dg_container($dg_length);
6063 1         5 $data .= $self->_store_mso_dg(@ids);
6064 1         5 $data .= $self->_store_mso_spgr_container($spgr_length);
6065 1         5 $data .= $self->_store_mso_sp_container(40);
6066 1         5 $data .= $self->_store_mso_spgr();
6067 1         5 $data .= $self->_store_mso_sp(0x0, $spid++, 0x0005);
6068 1         6 $data .= $self->_store_mso_sp_container(120);
6069 1         4 $data .= $self->_store_mso_sp(202, $spid++, 0x0A00);
6070 1         5 $data .= $self->_store_mso_opt_comment(0x80, $visible, $color);
6071 1         14 $data .= $self->_store_mso_client_anchor(3, @vertices);
6072 1         6 $data .= $self->_store_mso_client_data();
6073              
6074 1         3 $length = length $data;
6075 1         3 my $header = pack("vv", $record, $length);
6076 1         7 $self->_append($header, $data);
6077              
6078             }
6079             else {
6080             # Write the child MSODRAWIING record.
6081 0         0 my $data = $self->_store_mso_sp_container(120);
6082 0         0 $data .= $self->_store_mso_sp(202, $spid++, 0x0A00);
6083 0         0 $data .= $self->_store_mso_opt_comment(0x80, $visible, $color);
6084 0         0 $data .= $self->_store_mso_client_anchor(3, @vertices);
6085 0         0 $data .= $self->_store_mso_client_data();
6086              
6087 0         0 $length = length $data;
6088 0         0 my $header = pack("vv", $record, $length);
6089 0         0 $self->_append($header, $data);
6090              
6091              
6092             }
6093              
6094 1         6 $self->_store_obj_comment($num_objects+$i+1);
6095 1         6 $self->_store_mso_drawing_text_box();
6096 1         5 $self->_store_txo($str_len);
6097 1         4 $self->_store_txo_continue_1($str, $encoding);
6098 1         6 $self->_store_txo_continue_2($formats);
6099             }
6100              
6101              
6102             # Write the NOTE records after MSODRAWIING records.
6103 1         3 for my $i (0 .. $num_comments-1) {
6104              
6105 1         3 my $row = $comments[$i]->[0];
6106 1         2 my $col = $comments[$i]->[1];
6107 1         2 my $author = $comments[$i]->[4];
6108 1         2 my $author_enc = $comments[$i]->[5];
6109 1         2 my $visible = $comments[$i]->[6];
6110              
6111 1         5 $self->_store_note($row, $col, $num_objects+$i+1,
6112             $author, $author_enc, $visible);
6113             }
6114             }
6115              
6116              
6117             ###############################################################################
6118             #
6119             # _store_mso_dg_container()
6120             #
6121             # Write the Escher DgContainer record that is part of MSODRAWING.
6122             #
6123             sub _store_mso_dg_container {
6124              
6125 5     5   569 my $self = shift;
6126              
6127 5         7 my $type = 0xF002;
6128 5         10 my $version = 15;
6129 5         7 my $instance = 0;
6130 5         12 my $data = '';
6131 5         8 my $length = $_[0];
6132              
6133              
6134 5         40 return $self->_add_mso_generic($type, $version, $instance, $data, $length);
6135             }
6136              
6137              
6138             ###############################################################################
6139             #
6140             # _store_mso_dg()
6141             #
6142             # Write the Escher Dg record that is part of MSODRAWING.
6143             #
6144             sub _store_mso_dg {
6145              
6146 5     5   531 my $self = shift;
6147              
6148 5         10 my $type = 0xF008;
6149 5         9 my $version = 0;
6150 5         7 my $instance = $_[0];
6151 5         10 my $data = '';
6152 5         7 my $length = 8;
6153              
6154 5         8 my $num_shapes = $_[1];
6155 5         9 my $max_spid = $_[2];
6156              
6157 5         20 $data = pack "VV", $num_shapes, $max_spid;
6158              
6159 5         24 return $self->_add_mso_generic($type, $version, $instance, $data, $length);
6160             }
6161              
6162              
6163             ###############################################################################
6164             #
6165             # _store_mso_spgr_container()
6166             #
6167             # Write the Escher SpgrContainer record that is part of MSODRAWING.
6168             #
6169             sub _store_mso_spgr_container {
6170              
6171 5     5   518 my $self = shift;
6172              
6173 5         10 my $type = 0xF003;
6174 5         9 my $version = 15;
6175 5         9 my $instance = 0;
6176 5         9 my $data = '';
6177 5         9 my $length = $_[0];
6178              
6179              
6180 5         19 return $self->_add_mso_generic($type, $version, $instance, $data, $length);
6181             }
6182              
6183              
6184             ###############################################################################
6185             #
6186             # _store_mso_sp_container()
6187             #
6188             # Write the Escher SpContainer record that is part of MSODRAWING.
6189             #
6190             sub _store_mso_sp_container {
6191              
6192 15     15   534 my $self = shift;
6193              
6194 15         26 my $type = 0xF004;
6195 15         29 my $version = 15;
6196 15         19 my $instance = 0;
6197 15         20 my $data = '';
6198 15         22 my $length = $_[0];
6199              
6200              
6201 15         50 return $self->_add_mso_generic($type, $version, $instance, $data, $length);
6202             }
6203              
6204              
6205             ###############################################################################
6206             #
6207             # _store_mso_spgr()
6208             #
6209             # Write the Escher Spgr record that is part of MSODRAWING.
6210             #
6211             sub _store_mso_spgr {
6212              
6213 4     4   6 my $self = shift;
6214              
6215 4         7 my $type = 0xF009;
6216 4         7 my $version = 1;
6217 4         5 my $instance = 0;
6218 4         17 my $data = pack "VVVV", 0, 0, 0, 0;
6219 4         5 my $length = 16;
6220              
6221              
6222 4         17 return $self->_add_mso_generic($type, $version, $instance, $data, $length);
6223             }
6224              
6225              
6226             ###############################################################################
6227             #
6228             # _store_mso_sp()
6229             #
6230             # Write the Escher Sp record that is part of MSODRAWING.
6231             #
6232             sub _store_mso_sp {
6233              
6234 16     16   1101 my $self = shift;
6235              
6236 16         20 my $type = 0xF00A;
6237 16         18 my $version = 2;
6238 16         52 my $instance = $_[0];
6239 16         26 my $data = '';
6240 16         24 my $length = 8;
6241              
6242 16         18 my $spid = $_[1];
6243 16         20 my $options = $_[2];
6244              
6245 16         34 $data = pack "VV", $spid, $options;
6246              
6247 16         50 return $self->_add_mso_generic($type, $version, $instance, $data, $length);
6248             }
6249              
6250              
6251             ###############################################################################
6252             #
6253             # _store_mso_opt_comment()
6254             #
6255             # Write the Escher Opt record that is part of MSODRAWING.
6256             #
6257             sub _store_mso_opt_comment {
6258              
6259 2     2   554 my $self = shift;
6260              
6261 2         6 my $type = 0xF00B;
6262 2         5 my $version = 3;
6263 2         3 my $instance = 9;
6264 2         3 my $data = '';
6265 2         3 my $length = 54;
6266              
6267 2         4 my $spid = $_[0];
6268 2         4 my $visible = $_[1];
6269 2   100     13 my $colour = $_[2] || 0x50;
6270              
6271              
6272             # Use the visible flag if set by the user or else use the worksheet value.
6273             # Note that the value used is the opposite of _store_note().
6274             #
6275 2 50       8 if (defined $visible) {
6276 0 0       0 $visible = $visible ? 0x0000 : 0x0002;
6277             }
6278             else {
6279 2 50       11 $visible = $self->{_comments_visible} ? 0x0000 : 0x0002;
6280             }
6281              
6282              
6283 2         6 $data = pack "V", $spid;
6284 2         5 $data .= pack "H*", '0000BF00080008005801000000008101' ;
6285 2         6 $data .= pack "C", $colour;
6286 2         5 $data .= pack "H*", '000008830150000008BF011000110001' .
6287             '02000000003F0203000300BF03';
6288 2         5 $data .= pack "v", $visible;
6289 2         6 $data .= pack "H*", '0A00';
6290              
6291              
6292 2         9 return $self->_add_mso_generic($type, $version, $instance, $data, $length);
6293             }
6294              
6295              
6296             ###############################################################################
6297             #
6298             # _store_mso_opt_image()
6299             #
6300             # Write the Escher Opt record that is part of MSODRAWING.
6301             #
6302             sub _store_mso_opt_image {
6303              
6304 0     0   0 my $self = shift;
6305              
6306 0         0 my $type = 0xF00B;
6307 0         0 my $version = 3;
6308 0         0 my $instance = 3;
6309 0         0 my $data = '';
6310 0         0 my $length = undef;
6311 0         0 my $spid = $_[0];
6312              
6313 0         0 $data = pack 'v', 0x4104; # Blip -> pib
6314 0         0 $data .= pack 'V', $spid;
6315 0         0 $data .= pack 'v', 0x01BF; # Fill Style -> fNoFillHitTest
6316 0         0 $data .= pack 'V', 0x00010000;
6317 0         0 $data .= pack 'v', 0x03BF; # Group Shape -> fPrint
6318 0         0 $data .= pack 'V', 0x00080000;
6319              
6320              
6321 0         0 return $self->_add_mso_generic($type, $version, $instance, $data, $length);
6322             }
6323              
6324              
6325             ###############################################################################
6326             #
6327             # _store_mso_opt_chart()
6328             #
6329             # Write the Escher Opt record that is part of MSODRAWING.
6330             #
6331             sub _store_mso_opt_chart {
6332              
6333 0     0   0 my $self = shift;
6334              
6335 0         0 my $type = 0xF00B;
6336 0         0 my $version = 3;
6337 0         0 my $instance = 9;
6338 0         0 my $data = '';
6339 0         0 my $length = undef;
6340              
6341 0         0 $data = pack 'v', 0x007F; # Protection -> fLockAgainstGrouping
6342 0         0 $data .= pack 'V', 0x01040104;
6343              
6344 0         0 $data .= pack 'v', 0x00BF; # Text -> fFitTextToShape
6345 0         0 $data .= pack 'V', 0x00080008;
6346              
6347 0         0 $data .= pack 'v', 0x0181; # Fill Style -> fillColor
6348 0         0 $data .= pack 'V', 0x0800004E ;
6349              
6350 0         0 $data .= pack 'v', 0x0183; # Fill Style -> fillBackColor
6351 0         0 $data .= pack 'V', 0x0800004D;
6352              
6353 0         0 $data .= pack 'v', 0x01BF; # Fill Style -> fNoFillHitTest
6354 0         0 $data .= pack 'V', 0x00110010;
6355              
6356 0         0 $data .= pack 'v', 0x01C0; # Line Style -> lineColor
6357 0         0 $data .= pack 'V', 0x0800004D;
6358              
6359 0         0 $data .= pack 'v', 0x01FF; # Line Style -> fNoLineDrawDash
6360 0         0 $data .= pack 'V', 0x00080008;
6361              
6362 0         0 $data .= pack 'v', 0x023F; # Shadow Style -> fshadowObscured
6363 0         0 $data .= pack 'V', 0x00020000;
6364              
6365 0         0 $data .= pack 'v', 0x03BF; # Group Shape -> fPrint
6366 0         0 $data .= pack 'V', 0x00080000;
6367              
6368              
6369 0         0 return $self->_add_mso_generic($type, $version, $instance, $data, $length);
6370             }
6371              
6372              
6373             ###############################################################################
6374             #
6375             # _store_mso_opt_filter()
6376             #
6377             # Write the Escher Opt record that is part of MSODRAWING.
6378             #
6379             sub _store_mso_opt_filter {
6380              
6381 9     9   13 my $self = shift;
6382              
6383 9         12 my $type = 0xF00B;
6384 9         10 my $version = 3;
6385 9         10 my $instance = 5;
6386 9         13 my $data = '';
6387 9         9 my $length = undef;
6388              
6389              
6390              
6391 9         11 $data = pack 'v', 0x007F; # Protection -> fLockAgainstGrouping
6392 9         15 $data .= pack 'V', 0x01040104;
6393              
6394 9         9 $data .= pack 'v', 0x00BF; # Text -> fFitTextToShape
6395 9         8 $data .= pack 'V', 0x00080008;
6396              
6397 9         12 $data .= pack 'v', 0x01BF; # Fill Style -> fNoFillHitTest
6398 9         11 $data .= pack 'V', 0x00010000;
6399              
6400 9         9 $data .= pack 'v', 0x01FF; # Line Style -> fNoLineDrawDash
6401 9         12 $data .= pack 'V', 0x00080000;
6402              
6403 9         10 $data .= pack 'v', 0x03BF; # Group Shape -> fPrint
6404 9         18 $data .= pack 'V', 0x000A0000;
6405              
6406              
6407 9         29 return $self->_add_mso_generic($type, $version, $instance, $data, $length);
6408             }
6409              
6410              
6411             ###############################################################################
6412             #
6413             # _store_mso_client_anchor()
6414             #
6415             # Write the Escher ClientAnchor record that is part of MSODRAWING.
6416             #
6417             sub _store_mso_client_anchor {
6418              
6419 26     26   265 my $self = shift;
6420              
6421 26         44 my $type = 0xF010;
6422 26         27 my $version = 0;
6423 26         29 my $instance = 0;
6424 26         32 my $data = '';
6425 26         30 my $length = 18;
6426              
6427 26         34 my $flag = shift;
6428              
6429 26         39 my $col_start = $_[0]; # Col containing upper left corner of object
6430 26         39 my $x1 = $_[1]; # Distance to left side of object
6431              
6432 26         33 my $row_start = $_[2]; # Row containing top left corner of object
6433 26         29 my $y1 = $_[3]; # Distance to top of object
6434              
6435 26         35 my $col_end = $_[4]; # Col containing lower right corner of object
6436 26         33 my $x2 = $_[5]; # Distance to right side of object
6437              
6438 26         29 my $row_end = $_[6]; # Row containing bottom right corner of object
6439 26         31 my $y2 = $_[7]; # Distance to bottom of object
6440              
6441 26         70 $data = pack "v9", $flag,
6442             $col_start, $x1,
6443             $row_start, $y1,
6444             $col_end, $x2,
6445             $row_end, $y2;
6446              
6447              
6448              
6449 26         109 return $self->_add_mso_generic($type, $version, $instance, $data, $length);
6450             }
6451              
6452              
6453             ###############################################################################
6454             #
6455             # _store_mso_client_data()
6456             #
6457             # Write the Escher ClientData record that is part of MSODRAWING.
6458             #
6459             sub _store_mso_client_data {
6460              
6461 11     11   675 my $self = shift;
6462              
6463 11         14 my $type = 0xF011;
6464 11         13 my $version = 0;
6465 11         16 my $instance = 0;
6466 11         18 my $data = '';
6467 11         15 my $length = 0;
6468              
6469              
6470 11         35 return $self->_add_mso_generic($type, $version, $instance, $data, $length);
6471             }
6472              
6473              
6474             ###############################################################################
6475             #
6476             # _store_obj_comment()
6477             #
6478             # Write the OBJ record that is part of cell comments.
6479             #
6480             sub _store_obj_comment {
6481              
6482 2     2   609 my $self = shift;
6483              
6484 2         4 my $record = 0x005D; # Record identifier
6485 2         3 my $length = 0x0034; # Bytes to follow
6486              
6487 2         4 my $obj_id = $_[0]; # Object ID number.
6488 2         3 my $obj_type = 0x0019; # Object type (comment).
6489 2         3 my $data = ''; # Record data.
6490              
6491 2         4 my $sub_record = 0x0000; # Sub-record identifier.
6492 2         3 my $sub_length = 0x0000; # Length of sub-record.
6493 2         4 my $sub_data = ''; # Data of sub-record.
6494 2         4 my $options = 0x4011;
6495 2         2 my $reserved = 0x0000;
6496              
6497             # Add ftCmo (common object data) subobject
6498 2         4 $sub_record = 0x0015; # ftCmo
6499 2         2 $sub_length = 0x0012;
6500 2         13 $sub_data = pack "vvvVVV", $obj_type, $obj_id, $options,
6501             $reserved, $reserved, $reserved;
6502 2         6 $data = pack("vv", $sub_record, $sub_length);
6503 2         4 $data .= $sub_data;
6504              
6505              
6506             # Add ftNts (note structure) subobject
6507 2         4 $sub_record = 0x000D; # ftNts
6508 2         3 $sub_length = 0x0016;
6509 2         11 $sub_data = pack "VVVVVv", ($reserved) x 6;
6510 2         6 $data .= pack("vv", $sub_record, $sub_length);
6511 2         21 $data .= $sub_data;
6512              
6513              
6514             # Add ftEnd (end of object) subobject
6515 2         4 $sub_record = 0x0000; # ftNts
6516 2         4 $sub_length = 0x0000;
6517 2         4 $data .= pack("vv", $sub_record, $sub_length);
6518              
6519              
6520             # Pack the record.
6521 2         6 my $header = pack("vv", $record, $length);
6522              
6523 2         7 $self->_append($header, $data);
6524              
6525             }
6526              
6527              
6528             ###############################################################################
6529             #
6530             # _store_obj_image()
6531             #
6532             # Write the OBJ record that is part of image records.
6533             #
6534             sub _store_obj_image {
6535              
6536 0     0   0 my $self = shift;
6537              
6538 0         0 my $record = 0x005D; # Record identifier
6539 0         0 my $length = 0x0026; # Bytes to follow
6540              
6541 0         0 my $obj_id = $_[0]; # Object ID number.
6542 0         0 my $obj_type = 0x0008; # Object type (Picture).
6543 0         0 my $data = ''; # Record data.
6544              
6545 0         0 my $sub_record = 0x0000; # Sub-record identifier.
6546 0         0 my $sub_length = 0x0000; # Length of sub-record.
6547 0         0 my $sub_data = ''; # Data of sub-record.
6548 0         0 my $options = 0x6011;
6549 0         0 my $reserved = 0x0000;
6550              
6551             # Add ftCmo (common object data) subobject
6552 0         0 $sub_record = 0x0015; # ftCmo
6553 0         0 $sub_length = 0x0012;
6554 0         0 $sub_data = pack 'vvvVVV', $obj_type, $obj_id, $options,
6555             $reserved, $reserved, $reserved;
6556 0         0 $data = pack 'vv', $sub_record, $sub_length;
6557 0         0 $data .= $sub_data;
6558              
6559              
6560             # Add ftCf (Clipboard format) subobject
6561 0         0 $sub_record = 0x0007; # ftCf
6562 0         0 $sub_length = 0x0002;
6563 0         0 $sub_data = pack 'v', 0xFFFF;
6564 0         0 $data .= pack 'vv', $sub_record, $sub_length;
6565 0         0 $data .= $sub_data;
6566              
6567             # Add ftPioGrbit (Picture option flags) subobject
6568 0         0 $sub_record = 0x0008; # ftPioGrbit
6569 0         0 $sub_length = 0x0002;
6570 0         0 $sub_data = pack 'v', 0x0001;
6571 0         0 $data .= pack 'vv', $sub_record, $sub_length;
6572 0         0 $data .= $sub_data;
6573              
6574              
6575             # Add ftEnd (end of object) subobject
6576 0         0 $sub_record = 0x0000; # ftNts
6577 0         0 $sub_length = 0x0000;
6578 0         0 $data .= pack 'vv', $sub_record, $sub_length;
6579              
6580              
6581             # Pack the record.
6582 0         0 my $header = pack('vv', $record, $length);
6583              
6584 0         0 $self->_append($header, $data);
6585              
6586             }
6587              
6588              
6589             ###############################################################################
6590             #
6591             # _store_obj_chart()
6592             #
6593             # Write the OBJ record that is part of chart records.
6594             #
6595             sub _store_obj_chart {
6596              
6597 0     0   0 my $self = shift;
6598              
6599 0         0 my $record = 0x005D; # Record identifier
6600 0         0 my $length = 0x001A; # Bytes to follow
6601              
6602 0         0 my $obj_id = $_[0]; # Object ID number.
6603 0         0 my $obj_type = 0x0005; # Object type (chart).
6604 0         0 my $data = ''; # Record data.
6605              
6606 0         0 my $sub_record = 0x0000; # Sub-record identifier.
6607 0         0 my $sub_length = 0x0000; # Length of sub-record.
6608 0         0 my $sub_data = ''; # Data of sub-record.
6609 0         0 my $options = 0x6011;
6610 0         0 my $reserved = 0x0000;
6611              
6612             # Add ftCmo (common object data) subobject
6613 0         0 $sub_record = 0x0015; # ftCmo
6614 0         0 $sub_length = 0x0012;
6615 0         0 $sub_data = pack 'vvvVVV', $obj_type, $obj_id, $options,
6616             $reserved, $reserved, $reserved;
6617 0         0 $data = pack 'vv', $sub_record, $sub_length;
6618 0         0 $data .= $sub_data;
6619              
6620             # Add ftEnd (end of object) subobject
6621 0         0 $sub_record = 0x0000; # ftNts
6622 0         0 $sub_length = 0x0000;
6623 0         0 $data .= pack 'vv', $sub_record, $sub_length;
6624              
6625              
6626             # Pack the record.
6627 0         0 my $header = pack('vv', $record, $length);
6628              
6629 0         0 $self->_append($header, $data);
6630              
6631             }
6632              
6633              
6634              
6635              
6636             ###############################################################################
6637             #
6638             # _store_obj_filter()
6639             #
6640             # Write the OBJ record that is part of filter records.
6641             #
6642             sub _store_obj_filter {
6643              
6644 9     9   11 my $self = shift;
6645              
6646 9         10 my $record = 0x005D; # Record identifier
6647 9         10 my $length = 0x0046; # Bytes to follow
6648              
6649 9         11 my $obj_id = $_[0]; # Object ID number.
6650 9         10 my $obj_type = 0x0014; # Object type (combo box).
6651 9         14 my $data = ''; # Record data.
6652              
6653 9         10 my $sub_record = 0x0000; # Sub-record identifier.
6654 9         11 my $sub_length = 0x0000; # Length of sub-record.
6655 9         11 my $sub_data = ''; # Data of sub-record.
6656 9         9 my $options = 0x2101;
6657 9         10 my $reserved = 0x0000;
6658              
6659             # Add ftCmo (common object data) subobject
6660 9         9 $sub_record = 0x0015; # ftCmo
6661 9         9 $sub_length = 0x0012;
6662 9         23 $sub_data = pack 'vvvVVV', $obj_type, $obj_id, $options,
6663             $reserved, $reserved, $reserved;
6664 9         17 $data = pack 'vv', $sub_record, $sub_length;
6665 9         12 $data .= $sub_data;
6666              
6667             # Add ftSbs Scroll bar subobject
6668 9         9 $sub_record = 0x000C; # ftSbs
6669 9         11 $sub_length = 0x0014;
6670 9         13 $sub_data = pack 'H*', '0000000000000000640001000A00000010000100';
6671 9         18 $data .= pack 'vv', $sub_record, $sub_length;
6672 9         11 $data .= $sub_data;
6673              
6674              
6675             # Add ftLbsData (List box data) subobject
6676 9         9 $sub_record = 0x0013; # ftLbsData
6677 9         12 $sub_length = 0x1FEE; # Special case (undocumented).
6678              
6679              
6680             # If the filter is active we set one of the undocumented flags.
6681 9         10 my $col = $_[1];
6682              
6683 9 50       31 if ($self->{_filter_cols}->{$col}) {
6684 0         0 $sub_data = pack 'H*', '000000000100010300000A0008005700';
6685             }
6686             else {
6687 9         14 $sub_data = pack 'H*', '00000000010001030000020008005700';
6688             }
6689              
6690 9         24 $data .= pack 'vv', $sub_record, $sub_length;
6691 9         12 $data .= $sub_data;
6692              
6693              
6694             # Add ftEnd (end of object) subobject
6695 9         10 $sub_record = 0x0000; # ftNts
6696 9         11 $sub_length = 0x0000;
6697 9         13 $data .= pack 'vv', $sub_record, $sub_length;
6698              
6699             # Pack the record.
6700 9         16 my $header = pack('vv', $record, $length);
6701              
6702 9         19 $self->_append($header, $data);
6703             }
6704              
6705              
6706             ###############################################################################
6707             #
6708             # _store_mso_drawing_text_box()
6709             #
6710             # Write the MSODRAWING ClientTextbox record that is part of comments.
6711             #
6712             sub _store_mso_drawing_text_box {
6713              
6714 1     1   2 my $self = shift;
6715              
6716 1         2 my $record = 0x00EC; # Record identifier
6717 1         2 my $length = 0x0008; # Bytes to follow
6718              
6719              
6720 1         6 my $data = $self->_store_mso_client_text_box();
6721 1         3 my $header = pack("vv", $record, $length);
6722              
6723 1         3 $self->_append($header, $data);
6724             }
6725              
6726              
6727             ###############################################################################
6728             #
6729             # _store_mso_client_text_box()
6730             #
6731             # Write the Escher ClientTextbox record that is part of MSODRAWING.
6732             #
6733             sub _store_mso_client_text_box {
6734              
6735 2     2   601 my $self = shift;
6736              
6737 2         4 my $type = 0xF00D;
6738 2         5 my $version = 0;
6739 2         4 my $instance = 0;
6740 2         5 my $data = '';
6741 2         4 my $length = 0;
6742              
6743              
6744 2         10 return $self->_add_mso_generic($type, $version, $instance, $data, $length);
6745             }
6746              
6747              
6748             ###############################################################################
6749             #
6750             # _store_txo()
6751             #
6752             # Write the worksheet TXO record that is part of cell comments.
6753             #
6754             sub _store_txo {
6755              
6756 2     2   21 my $self = shift;
6757              
6758 2         6 my $record = 0x01B6; # Record identifier
6759 2         4 my $length = 0x0012; # Bytes to follow
6760              
6761 2         4 my $string_len = $_[0]; # Length of the note text.
6762 2   50     31 my $format_len = $_[1] || 16; # Length of the format runs.
6763 2   50     22 my $rotation = $_[2] || 0; # Options
6764 2         4 my $grbit = 0x0212; # Options
6765 2         4 my $reserved = 0x0000; # Options
6766              
6767             # Pack the record.
6768 2         8 my $header = pack("vv", $record, $length);
6769 2         11 my $data = pack("vvVvvvV", $grbit, $rotation, $reserved, $reserved,
6770             $string_len, $format_len, $reserved);
6771              
6772 2         9 $self->_append($header, $data);
6773              
6774             }
6775              
6776              
6777             ###############################################################################
6778             #
6779             # _store_txo_continue_1()
6780             #
6781             # Write the first CONTINUE record to follow the TXO record. It contains the
6782             # text data.
6783             #
6784             sub _store_txo_continue_1 {
6785              
6786 2     2   1096 my $self = shift;
6787              
6788 2         11 my $record = 0x003C; # Record identifier
6789 2         5 my $string = $_[0]; # Comment string.
6790 2   50     14 my $encoding = $_[1] || 0; # Encoding of the string.
6791              
6792              
6793             # Split long comment strings into smaller continue blocks if necessary.
6794             # We can't let BIFFwriter::_add_continue() handled this since an extra
6795             # encoding byte has to be added similar to the SST block.
6796             #
6797             # We make the limit size smaller than the _add_continue() size and even
6798             # so that UTF16 chars occur in the same block.
6799             #
6800 2         4 my $limit = 8218;
6801 2         10 while (length($string) > $limit) {
6802 0         0 my $tmp_str = substr($string, 0, $limit, "");
6803              
6804 0         0 my $data = pack("C", $encoding) . $tmp_str;
6805 0         0 my $length = length $data;
6806 0         0 my $header = pack("vv", $record, $length);
6807              
6808 0         0 $self->_append($header, $data);
6809             }
6810              
6811             # Pack the record.
6812 2         10 my $data = pack("C", $encoding) . $string;
6813 2         4 my $length = length $data;
6814 2         7 my $header = pack("vv", $record, $length);
6815              
6816 2         8 $self->_append($header, $data);
6817              
6818             }
6819              
6820              
6821             ###############################################################################
6822             #
6823             # _store_txo_continue_2()
6824             #
6825             # Write the second CONTINUE record to follow the TXO record. It contains the
6826             # formatting information for the string.
6827             #
6828             sub _store_txo_continue_2 {
6829              
6830 2     2   591 my $self = shift;
6831              
6832 2         5 my $record = 0x003C; # Record identifier
6833 2         3 my $length = 0x0000; # Bytes to follow
6834 2         7 my $formats = $_[0]; # Formatting information
6835              
6836              
6837             # Pack the record.
6838 2         4 my $data = '';
6839              
6840 2         6 for my $a_ref (@$formats) {
6841 4         18 $data .= pack "vvV", $a_ref->[0], $a_ref->[1], 0x0;
6842             }
6843              
6844 2         11 $length = length $data;
6845 2         7 my $header = pack("vv", $record, $length);
6846              
6847              
6848 2         9 $self->_append($header, $data);
6849              
6850             }
6851              
6852              
6853             ###############################################################################
6854             #
6855             # _store_note()
6856             #
6857             # Write the worksheet NOTE record that is part of cell comments.
6858             #
6859             sub _store_note {
6860              
6861 6     6   80 my $self = shift;
6862              
6863 6         8 my $record = 0x001C; # Record identifier
6864 6         13 my $length = 0x000C; # Bytes to follow
6865              
6866 6         9 my $row = $_[0];
6867 6         9 my $col = $_[1];
6868 6         9 my $obj_id = $_[2];
6869 6   66     31 my $author = $_[3] || $self->{_comments_author};
6870 6   66     26 my $author_enc = $_[4] || $self->{_comments_author_enc};
6871 6         8 my $visible = $_[5];
6872              
6873              
6874             # Use the visible flag if set by the user or else use the worksheet value.
6875             # The flag is also set in _store_mso_opt_comment() but with the opposite
6876             # value.
6877 6 100       15 if (defined $visible) {
6878 1 50       5 $visible = $visible ? 0x0002 : 0x0000;
6879             }
6880             else {
6881 5 50       16 $visible = $self->{_comments_visible} ? 0x0002 : 0x0000;
6882             }
6883              
6884              
6885             # Get the number of chars in the author string (not bytes).
6886 6         9 my $num_chars = length $author;
6887 6 100       15 $num_chars /= 2 if $author_enc;
6888              
6889              
6890             # Null terminate the author string.
6891 6         9 $author .= "\0";
6892              
6893              
6894             # Pack the record.
6895 6         58 my $data = pack("vvvvvC", $row, $col, $visible, $obj_id,
6896             $num_chars, $author_enc);
6897              
6898 6         10 $length = length($data) + length($author);
6899 6         11 my $header = pack("vv", $record, $length);
6900              
6901 6         22 $self->_append($header, $data, $author);
6902             }
6903              
6904              
6905             ###############################################################################
6906             #
6907             # _comment_params()
6908             #
6909             # This method handles the additional optional parameters to write_comment() as
6910             # well as calculating the comment object position and vertices.
6911             #
6912             sub _comment_params {
6913              
6914 22562     22562   47364 my $self = shift;
6915              
6916 22562         28220 my $row = shift;
6917 22562         24343 my $col = shift;
6918 22562         30650 my $string = shift;
6919              
6920 22562         28355 my $default_width = 128;
6921 22562         29518 my $default_height = 74;
6922              
6923 22562         183090 my %params = (
6924             author => '',
6925             author_encoding => 0,
6926             encoding => 0,
6927             color => undef,
6928             start_cell => undef,
6929             start_col => undef,
6930             start_row => undef,
6931             visible => undef,
6932             width => $default_width,
6933             height => $default_height,
6934             x_offset => undef,
6935             x_scale => 1,
6936             y_offset => undef,
6937             y_scale => 1,
6938             );
6939              
6940              
6941             # Overwrite the defaults with any user supplied values. Incorrect or
6942             # misspelled parameters are silently ignored.
6943 22562         286806 %params = (%params, @_);
6944              
6945              
6946             # Ensure that a width and height have been set.
6947 22562 50       97962 $params{width} = $default_width if not $params{width};
6948 22562 50       45655 $params{height} = $default_height if not $params{height};
6949              
6950              
6951             # Check that utf16 strings have an even number of bytes.
6952 22562 50       44453 if ($params{encoding}) {
6953 0 0       0 croak "Uneven number of bytes in comment string"
6954             if length($string) % 2;
6955              
6956             # Change from UTF-16BE to UTF-16LE
6957 0         0 $string = pack 'v*', unpack 'n*', $string;
6958             }
6959              
6960 22562 100       53617 if ($params{author_encoding}) {
6961 1 50       5 croak "Uneven number of bytes in author string"
6962             if length($params{author}) % 2;
6963              
6964             # Change from UTF-16BE to UTF-16LE
6965 1         6 $params{author} = pack 'v*', unpack 'n*', $params{author};
6966             }
6967              
6968              
6969             # Handle utf8 strings in perl 5.8.
6970 22562 50       58800 if ($] >= 5.008) {
6971 22562         122219 require Encode;
6972              
6973 22562 50       71528 if (Encode::is_utf8($string)) {
6974 0         0 $string = Encode::encode("UTF-16LE", $string);
6975 0         0 $params{encoding} = 1;
6976             }
6977              
6978 22562 100       61709 if (Encode::is_utf8($params{author})) {
6979 1         7 $params{author} = Encode::encode("UTF-16LE", $params{author});
6980 1         4973 $params{author_encoding} = 1;
6981             }
6982             }
6983              
6984              
6985             # Limit the string to the max number of chars (not bytes).
6986 22562         27557 my $max_len = 32767;
6987 22562 50       53725 $max_len *= 2 if $params{encoding};
6988              
6989 22562 50       44701 if (length($string) > $max_len) {
6990 0         0 $string = substr($string, 0, $max_len);
6991             }
6992              
6993              
6994             # Set the comment background colour.
6995 22562         27879 my $color = $params{color};
6996 22562         66724 $color = &Spreadsheet::WriteExcel::Format::_get_color($color);
6997 22562 50       76493 $color = 0x50 if $color == 0x7FFF; # Default color.
6998 22562         31983 $params{color} = $color;
6999              
7000              
7001             # Convert a cell reference to a row and column.
7002 22562 50       53352 if (defined $params{start_cell}) {
7003 0         0 my ($row, $col) = $self->_substitute_cellref($params{start_cell});
7004 0         0 $params{start_row} = $row;
7005 0         0 $params{start_col} = $col;
7006             }
7007              
7008              
7009             # Set the default start cell and offsets for the comment. These are
7010             # generally fixed in relation to the parent cell. However there are
7011             # some edge cases for cells at the, er, edges.
7012             #
7013 22562 50       49122 if (not defined $params{start_row}) {
7014              
7015 22562 100       89841 if ($row == 0 ) {$params{start_row} = 0 }
  37 100       77  
  1 100       3  
    100          
7016 1         2 elsif ($row == 65533) {$params{start_row} = 65529 }
7017 1         2 elsif ($row == 65534) {$params{start_row} = 65530 }
7018 22522         41472 elsif ($row == 65535) {$params{start_row} = 65531 }
7019             else {$params{start_row} = $row -1}
7020             }
7021              
7022 22562 100       47524 if (not defined $params{y_offset}) {
7023              
7024 22561 100       85246 if ($row == 0 ) {$params{y_offset} = 2 }
  37 100       73  
  1 100       3  
    100          
7025 1         2 elsif ($row == 65533) {$params{y_offset} = 4 }
7026 1         3 elsif ($row == 65534) {$params{y_offset} = 4 }
7027 22521         33079 elsif ($row == 65535) {$params{y_offset} = 2 }
7028             else {$params{y_offset} = 7 }
7029             }
7030              
7031 22562 50       48158 if (not defined $params{start_col}) {
7032              
7033 22562 100       61198 if ($col == 253 ) {$params{start_col} = 250 }
  1 100       3  
  1 100       2  
7034 1         2 elsif ($col == 254 ) {$params{start_col} = 251 }
7035 22559         44596 elsif ($col == 255 ) {$params{start_col} = 252 }
7036             else {$params{start_col} = $col +1}
7037             }
7038              
7039 22562 100       50661 if (not defined $params{x_offset}) {
7040              
7041 22561 100       58834 if ($col == 253 ) {$params{x_offset} = 49 }
  1 100       3  
  1 100       1  
7042 1         3 elsif ($col == 254 ) {$params{x_offset} = 49 }
7043 22558         31808 elsif ($col == 255 ) {$params{x_offset} = 49 }
7044             else {$params{x_offset} = 15 }
7045             }
7046              
7047              
7048             # Scale the size of the comment box if required.
7049 22562 50       55551 if ($params{x_scale}) {
7050 22562         53712 $params{width} = $params{width} * $params{x_scale};
7051             }
7052              
7053 22562 50       52054 if ($params{y_scale}) {
7054 22562         36046 $params{height} = $params{height} * $params{y_scale};
7055             }
7056              
7057              
7058             # Calculate the positions of comment object.
7059 22562         66910 my @vertices = $self->_position_object( $params{start_col},
7060             $params{start_row},
7061             $params{x_offset},
7062             $params{y_offset},
7063             $params{width},
7064             $params{height}
7065             );
7066              
7067             return(
7068 22562         379495 $row,
7069             $col,
7070             $string,
7071             $params{encoding},
7072             $params{author},
7073             $params{author_encoding},
7074             $params{visible},
7075             $params{color},
7076             [@vertices]
7077             );
7078             }
7079              
7080              
7081              
7082             #
7083             # DATA VALIDATION
7084             #
7085              
7086             ###############################################################################
7087             #
7088             # data_validation($row, $col, {...})
7089             #
7090             # This method handles the interface to Excel data validation.
7091             # Somewhat ironically the this requires a lot of validation code since the
7092             # interface is flexible and covers a several types of data validation.
7093             #
7094             # We allow data validation to be called on one cell or a range of cells. The
7095             # hashref contains the validation parameters and must be the last param:
7096             # data_validation($row, $col, {...})
7097             # data_validation($first_row, $first_col, $last_row, $last_col, {...})
7098             #
7099             # Returns 0 : normal termination
7100             # -1 : insufficient number of arguments
7101             # -2 : row or column out of range
7102             # -3 : incorrect parameter.
7103             #
7104             sub data_validation {
7105              
7106 43     43 0 44498 my $self = shift;
7107              
7108             # Check for a cell reference in A1 notation and substitute row and column
7109 43 100       245 if ($_[0] =~ /^\D/) {
7110 38         173 @_ = $self->_substitute_cellref(@_);
7111             }
7112              
7113             # Check for a valid number of args.
7114 43 50 66     303 if (@_ != 5 && @_ != 3) { return -1 }
  0         0  
7115              
7116             # The final hashref contains the validation parameters.
7117 43         66 my $param = pop;
7118              
7119             # Make the last row/col the same as the first if not defined.
7120 43         83 my ($row1, $col1, $row2, $col2) = @_;
7121 43 100       111 if (!defined $row2) {
7122 38         62 $row2 = $row1;
7123 38         51 $col2 = $col1;
7124             }
7125              
7126             # Check that row and col are valid without storing the values.
7127 43 50       230 return -2 if $self->_check_dimensions($row1, $col1, 1, 1);
7128 43 50       129 return -2 if $self->_check_dimensions($row2, $col2, 1, 1);
7129              
7130              
7131             # Check that the last parameter is a hash list.
7132 43 50       169 if (ref $param ne 'HASH') {
7133 0         0 carp "Last parameter '$param' in data_validation() must be a hash ref";
7134 0         0 return -3;
7135             }
7136              
7137             # List of valid input parameters.
7138 43         644 my %valid_parameter = (
7139             validate => 1,
7140             criteria => 1,
7141             value => 1,
7142             source => 1,
7143             minimum => 1,
7144             maximum => 1,
7145             ignore_blank => 1,
7146             dropdown => 1,
7147             show_input => 1,
7148             input_title => 1,
7149             input_message => 1,
7150             show_error => 1,
7151             error_title => 1,
7152             error_message => 1,
7153             error_type => 1,
7154             other_cells => 1,
7155             );
7156              
7157             # Check for valid input parameters.
7158 43         199 for my $param_key (keys %$param) {
7159 171 50       462 if (not exists $valid_parameter{$param_key}) {
7160 0         0 carp "Unknown parameter '$param_key' in data_validation()";
7161 0         0 return -3;
7162             }
7163             }
7164              
7165             # Map alternative parameter names 'source' or 'minimum' to 'value'.
7166 43 100       198 $param->{value} = $param->{source} if defined $param->{source};
7167 43 100       162 $param->{value} = $param->{minimum} if defined $param->{minimum};
7168              
7169             # 'validate' is a required parameter.
7170 43 50       139 if (not exists $param->{validate}) {
7171 0         0 carp "Parameter 'validate' is required in data_validation()";
7172 0         0 return -3;
7173             }
7174              
7175              
7176             # List of valid validation types.
7177 43         913 my %valid_type = (
7178             'any' => 0,
7179             'any value' => 0,
7180             'whole number' => 1,
7181             'whole' => 1,
7182             'integer' => 1,
7183             'decimal' => 2,
7184             'list' => 3,
7185             'date' => 4,
7186             'time' => 5,
7187             'text length' => 6,
7188             'length' => 6,
7189             'custom' => 7,
7190             );
7191              
7192              
7193             # Check for valid validation types.
7194 43 50       198 if (not exists $valid_type{lc($param->{validate})}) {
7195 0         0 carp "Unknown validation type '$param->{validate}' for parameter " .
7196             "'validate' in data_validation()";
7197 0         0 return -3;
7198             }
7199             else {
7200 43         145 $param->{validate} = $valid_type{lc($param->{validate})};
7201             }
7202              
7203              
7204             # No action is required for validation type 'any'.
7205             # TODO: we should perhaps store 'any' for message only validations.
7206 43 100       128 return 0 if $param->{validate} == 0;
7207              
7208              
7209             # The list and custom validations don't have a criteria so we use a default
7210             # of 'between'.
7211 42 100 100     239 if ($param->{validate} == 3 || $param->{validate} == 7) {
7212 4         12 $param->{criteria} = 'between';
7213 4         12 $param->{maximum} = undef;
7214             }
7215              
7216             # 'criteria' is a required parameter.
7217 42 50       135 if (not exists $param->{criteria}) {
7218 0         0 carp "Parameter 'criteria' is required in data_validation()";
7219 0         0 return -3;
7220             }
7221              
7222              
7223             # List of valid criteria types.
7224 42         657 my %criteria_type = (
7225             'between' => 0,
7226             'not between' => 1,
7227             'equal to' => 2,
7228             '=' => 2,
7229             '==' => 2,
7230             'not equal to' => 3,
7231             '!=' => 3,
7232             '<>' => 3,
7233             'greater than' => 4,
7234             '>' => 4,
7235             'less than' => 5,
7236             '<' => 5,
7237             'greater than or equal to' => 6,
7238             '>=' => 6,
7239             'less than or equal to' => 7,
7240             '<=' => 7,
7241             );
7242              
7243             # Check for valid criteria types.
7244 42 50       147 if (not exists $criteria_type{lc($param->{criteria})}) {
7245 0         0 carp "Unknown criteria type '$param->{criteria}' for parameter " .
7246             "'criteria' in data_validation()";
7247 0         0 return -3;
7248             }
7249             else {
7250 42         139 $param->{criteria} = $criteria_type{lc($param->{criteria})};
7251             }
7252              
7253              
7254             # 'Between' and 'Not between' criteria require 2 values.
7255 42 100 100     215 if ($param->{criteria} == 0 || $param->{criteria} == 1) {
7256 23 50       71 if (not exists $param->{maximum}) {
7257 0         0 carp "Parameter 'maximum' is required in data_validation() " .
7258             "when using 'between' or 'not between' criteria";
7259 0         0 return -3;
7260             }
7261             }
7262             else {
7263 19         53 $param->{maximum} = undef;
7264             }
7265              
7266              
7267              
7268             # List of valid error dialog types.
7269 42         206 my %error_type = (
7270             'stop' => 0,
7271             'warning' => 1,
7272             'information' => 2,
7273             );
7274              
7275             # Check for valid error dialog types.
7276 42 100       128 if (not exists $param->{error_type}) {
    50          
7277 40         95 $param->{error_type} = 0;
7278             }
7279             elsif (not exists $error_type{lc($param->{error_type})}) {
7280 0         0 carp "Unknown criteria type '$param->{error_type}' for parameter " .
7281             "'error_type' in data_validation()";
7282 0         0 return -3;
7283             }
7284             else {
7285 2         10 $param->{error_type} = $error_type{lc($param->{error_type})};
7286             }
7287              
7288              
7289             # Convert date/times value if required.
7290 42 100 100     267 if ($param->{validate} == 4 || $param->{validate} == 5) {
7291 5 100       39 if ($param->{value} =~ /T/) {
7292 3         18 my $date_time = $self->convert_date_time($param->{value});
7293              
7294 3 50       10 if (!defined $date_time) {
7295 0         0 carp "Invalid date/time value '$param->{value}' " .
7296             "in data_validation()";
7297 0         0 return -3;
7298             }
7299             else {
7300 3         9 $param->{value} = $date_time;
7301             }
7302             }
7303 5 100 66     24 if (defined $param->{maximum} && $param->{maximum} =~ /T/) {
7304 1         5 my $date_time = $self->convert_date_time($param->{maximum});
7305              
7306 1 50       5 if (!defined $date_time) {
7307 0         0 carp "Invalid date/time value '$param->{maximum}' " .
7308             "in data_validation()";
7309 0         0 return -3;
7310             }
7311             else {
7312 1         2 $param->{maximum} = $date_time;
7313             }
7314             }
7315             }
7316              
7317              
7318             # Set some defaults if they haven't been defined by the user.
7319 42 100       157 $param->{ignore_blank} = 1 if !defined $param->{ignore_blank};
7320 42 100       145 $param->{dropdown} = 1 if !defined $param->{dropdown};
7321 42 100       173 $param->{show_input} = 1 if !defined $param->{show_input};
7322 42 100       149 $param->{show_error} = 1 if !defined $param->{show_error};
7323              
7324              
7325             # These are the cells to which the validation is applied.
7326 42         238 $param->{cells} = [[$row1, $col1, $row2, $col2]];
7327              
7328             # A (for now) undocumented parameter to pass additional cell ranges.
7329 42 100       137 if (exists $param->{other_cells}) {
7330              
7331 3         7 push @{$param->{cells}}, @{$param->{other_cells}};
  3         6  
  3         8  
7332             }
7333              
7334             # Store the validation information until we close the worksheet.
7335 42         63 push @{$self->{_validations}}, $param;
  42         463  
7336             }
7337              
7338              
7339             ###############################################################################
7340             #
7341             # _store_validation_count()
7342             #
7343             # Store the count of the DV records to follow.
7344             #
7345             # Note, this could be wrapped into _store_dv() but we may require separate
7346             # handling of the object id at a later stage.
7347             #
7348             sub _store_validation_count {
7349              
7350 133     133   196 my $self = shift;
7351              
7352 133         486 my $dv_count = @{$self->{_validations}};
  133         329  
7353 133         221 my $obj_id = -1;
7354              
7355 133 100       355 return unless $dv_count;
7356              
7357 1         10 $self->_store_dval($obj_id , $dv_count);
7358             }
7359              
7360              
7361             ###############################################################################
7362             #
7363             # _store_validations()
7364             #
7365             # Store the data_validation records.
7366             #
7367             sub _store_validations {
7368              
7369 176     176   400 my $self = shift;
7370              
7371 176 100       262 return unless scalar @{$self->{_validations}};
  176         611  
7372              
7373 43         66 for my $param (@{$self->{_validations}}) {
  43         108  
7374 43         399 $self->_store_dv( $param->{cells},
7375             $param->{validate},
7376             $param->{criteria},
7377             $param->{value},
7378             $param->{maximum},
7379             $param->{input_title},
7380             $param->{input_message},
7381             $param->{error_title},
7382             $param->{error_message},
7383             $param->{error_type},
7384             $param->{ignore_blank},
7385             $param->{dropdown},
7386             $param->{show_input},
7387             $param->{show_error},
7388             );
7389             }
7390             }
7391              
7392              
7393             ###############################################################################
7394             #
7395             # _store_dval()
7396             #
7397             # Store the DV record which contains the number of and information common to
7398             # all DV structures.
7399             #
7400             sub _store_dval {
7401              
7402 4     4   854 my $self = shift;
7403              
7404 4         7 my $record = 0x01B2; # Record identifier
7405 4         4 my $length = 0x0012; # Bytes to follow
7406              
7407 4         5 my $obj_id = $_[0]; # Object ID number.
7408 4         5 my $dv_count = $_[1]; # Count of DV structs to follow.
7409              
7410 4         6 my $flags = 0x0004; # Option flags.
7411 4         5 my $x_coord = 0x00000000; # X coord of input box.
7412 4         5 my $y_coord = 0x00000000; # Y coord of input box.
7413              
7414              
7415             # Pack the record.
7416 4         11 my $header = pack('vv', $record, $length);
7417 4         15 my $data = pack('vVVVV', $flags, $x_coord, $y_coord, $obj_id, $dv_count);
7418              
7419 4         32 $self->_append($header, $data);
7420             }
7421              
7422              
7423             ###############################################################################
7424             #
7425             # _store_dv()
7426             #
7427             # Store the DV record that specifies the data validation criteria and options
7428             # for a range of cells..
7429             #
7430             sub _store_dv {
7431              
7432 43     43   70 my $self = shift;
7433              
7434 43         83 my $record = 0x01BE; # Record identifier
7435 43         75 my $length = 0x0000; # Bytes to follow
7436              
7437 43         64 my $flags = 0x00000000; # DV option flags.
7438              
7439 43         78 my $cells = $_[0]; # Aref of cells to which DV applies.
7440 43         65 my $validation_type = $_[1]; # Type of data validation.
7441 43         118 my $criteria_type = $_[2]; # Validation criteria.
7442 43         77 my $formula_1 = $_[3]; # Value/Source/Minimum formula.
7443 43         116 my $formula_2 = $_[4]; # Maximum formula.
7444 43         124 my $input_title = $_[5]; # Title of input message.
7445 43         97 my $input_message = $_[6]; # Text of input message.
7446 43         79 my $error_title = $_[7]; # Title of error message.
7447 43         95 my $error_message = $_[8]; # Text of input message.
7448 43         65 my $error_type = $_[9]; # Error dialog type.
7449 43         73 my $ignore_blank = $_[10]; # Ignore blank cells.
7450 43         8183 my $dropdown = $_[11]; # Display dropdown with list.
7451 43         55 my $input_box = $_[12]; # Display input box.
7452 43         66 my $error_box = $_[13]; # Display error box.
7453 43         161 my $ime_mode = 0; # IME input mode for far east fonts.
7454 43         64 my $str_lookup = 0; # See below.
7455              
7456             # Set the string lookup flag for 'list' validations with a string array.
7457 43 100 100     170 if ($validation_type == 3 && ref $formula_1 eq 'ARRAY') {
7458 2         5 $str_lookup = 1;
7459             }
7460              
7461             # The dropdown flag is stored as a negated value.
7462 43         83 my $no_dropdown = not $dropdown;
7463              
7464             # Set the required flags.
7465 43         98 $flags |= $validation_type;
7466 43         70 $flags |= $error_type << 4;
7467 43         65 $flags |= $str_lookup << 7;
7468 43         49 $flags |= $ignore_blank << 8;
7469 43         57 $flags |= $no_dropdown << 9;
7470 43         57 $flags |= $ime_mode << 10;
7471 43         65 $flags |= $input_box << 18;
7472 43         57 $flags |= $error_box << 19;
7473 43         68 $flags |= $criteria_type << 20;
7474              
7475             # Pack the validation formulas.
7476 43         152 $formula_1 = $self->_pack_dv_formula($formula_1);
7477 43         169 $formula_2 = $self->_pack_dv_formula($formula_2);
7478              
7479             # Pack the input and error dialog strings.
7480 43         207 $input_title = $self->_pack_dv_string($input_title, 32 );
7481 43         146 $error_title = $self->_pack_dv_string($error_title, 32 );
7482 43         104 $input_message = $self->_pack_dv_string($input_message, 255);
7483 43         134 $error_message = $self->_pack_dv_string($error_message, 255);
7484              
7485             # Pack the DV cell data.
7486 43         106 my $dv_count = scalar @$cells;
7487 43         100 my $dv_data = pack 'v', $dv_count;
7488 43         108 for my $range (@$cells) {
7489 48         272 $dv_data .= pack 'vvvv', $range->[0],
7490             $range->[2],
7491             $range->[1],
7492             $range->[3];
7493             }
7494              
7495             # Pack the record.
7496 43         170 my $data = pack 'V', $flags;
7497 43         167 $data .= $input_title;
7498 43         83 $data .= $error_title;
7499 43         52 $data .= $input_message;
7500 43         69 $data .= $error_message;
7501 43         68 $data .= $formula_1;
7502 43         72 $data .= $formula_2;
7503 43         67 $data .= $dv_data;
7504              
7505 43         173 my $header = pack('vv', $record, length $data);
7506              
7507 43         237 $self->_append($header, $data);
7508             }
7509              
7510              
7511             ###############################################################################
7512             #
7513             # _pack_dv_string()
7514             #
7515             # Pack the strings used in the input and error dialog captions and messages.
7516             # Captions are limited to 32 characters. Messages are limited to 255 chars.
7517             #
7518             sub _pack_dv_string {
7519              
7520 180     180   6369 my $self = shift;
7521              
7522 180         268 my $string = $_[0];
7523 180         228 my $max_length = $_[1];
7524              
7525 180         228 my $str_length = 0;
7526 180         206 my $encoding = 0;
7527              
7528             # The default empty string is "\0".
7529 180 100 100     588 if (!defined $string || $string eq '') {
7530 156         298 $string = "\0";
7531             }
7532              
7533             # Excel limits DV captions to 32 chars and messages to 255.
7534 180 100       436 if (length $string > $max_length) {
7535 2         9 $string = substr($string, 0, $max_length);
7536             }
7537              
7538 180         218 $str_length = length $string;
7539              
7540             # Handle utf8 strings in perl 5.8.
7541 180 50       420 if ($] >= 5.008) {
7542 180         996 require Encode;
7543              
7544 180 100       623 if (Encode::is_utf8($string)) {
7545 2         13 $string = Encode::encode("UTF-16LE", $string);
7546 2         9591 $encoding = 1;
7547             }
7548             }
7549              
7550 180         712 return pack('vC', $str_length, $encoding) . $string;
7551             }
7552              
7553              
7554             ###############################################################################
7555             #
7556             # _pack_dv_formula()
7557             #
7558             # Pack the formula used in the DV record. This is the same as an cell formula
7559             # with some additional header information. Note, DV formulas in Excel use
7560             # relative addressing (R1C1 and ptgXxxN) however we use the Formula.pm's
7561             # default absolute addressing (A1 and ptgXxx).
7562             #
7563             sub _pack_dv_formula {
7564              
7565 98     98   7449 my $self = shift;
7566              
7567 98         175 my $formula = $_[0];
7568 98         153 my $encoding = 0;
7569 98         151 my $length = 0;
7570 98         136 my $unused = 0x0000;
7571 98         115 my @tokens;
7572              
7573             # Return a default structure for unused formulas.
7574 98 100 100     573 if (!defined $formula || $formula eq '') {
7575 25         148 return pack('vv', 0, $unused);
7576             }
7577              
7578             # Pack a list array ref as a null separated string.
7579 73 100       201 if (ref $formula eq 'ARRAY') {
7580 4         17 $formula = join "\0", @$formula;
7581 4         13 $formula = qq("$formula");
7582             }
7583              
7584             # Strip the = sign at the beginning of the formula string
7585 73         195 $formula =~ s(^=)();
7586              
7587             # Parse the formula using the parser in Formula.pm
7588 73         176 my $parser = $self->{_parser};
7589              
7590             # In order to raise formula errors from the point of view of the calling
7591             # program we use an eval block and re-raise the error from here.
7592             #
7593 73         123 eval { @tokens = $parser->parse_formula($formula) };
  73         306  
7594              
7595 73 50       386 if ($@) {
7596 0         0 $@ =~ s/\n$//; # Strip the \n used in the Formula.pm die()
7597 0         0 croak $@; # Re-raise the error
7598             }
7599             else {
7600             # TODO test for non valid ptgs such as Sheet2!A1
7601             }
7602             # Force 2d ranges to be a reference class.
7603 73         598 s/_range2d/_range2dR/ for @tokens;
7604 73         487 s/_name/_nameR/ for @tokens;
7605              
7606             # Parse the tokens into a formula string.
7607 73         284 $formula = $parser->parse_tokens(@tokens);
7608              
7609              
7610 73         567 return pack('vv', length $formula, $unused) . $formula;
7611             }
7612              
7613              
7614              
7615              
7616              
7617             1;
7618              
7619              
7620             __END__