package Spreadsheet::WriteExcel::Worksheet;
###############################################################################
#
# Worksheet - A writer class for Excel Worksheets.
#
#
# Used in conjunction with Spreadsheet::WriteExcel
#
# Copyright 2000-2010, John McNamara, jmcnamara@cpan.org
#
# Documentation after __END__
#
use Exporter;
use strict;
use Carp;
use Spreadsheet::WriteExcel::BIFFwriter;
use Spreadsheet::WriteExcel::Format;
use Spreadsheet::WriteExcel::Formula;
use vars qw($VERSION @ISA);
@ISA = qw(Spreadsheet::WriteExcel::BIFFwriter);
$VERSION = '2.40';
###############################################################################
#
# new()
#
# Constructor. Creates a new Worksheet object from a BIFFwriter object
#
sub new {
my $class = shift;
my $self = Spreadsheet::WriteExcel::BIFFwriter->new();
my $rowmax = 65536;
my $colmax = 256;
my $strmax = 0;
$self->{_name} = $_[0];
$self->{_index} = $_[1];
$self->{_encoding} = $_[2];
$self->{_activesheet} = $_[3];
$self->{_firstsheet} = $_[4];
$self->{_url_format} = $_[5];
$self->{_parser} = $_[6];
$self->{_tempdir} = $_[7];
$self->{_str_total} = $_[8];
$self->{_str_unique} = $_[9];
$self->{_str_table} = $_[10];
$self->{_1904} = $_[11];
$self->{_compatibility} = $_[12];
$self->{_palette} = $_[13];
$self->{_sheet_type} = 0x0000;
$self->{_ext_sheets} = [];
$self->{_using_tmpfile} = 1;
$self->{_filehandle} = "";
$self->{_fileclosed} = 0;
$self->{_offset} = 0;
$self->{_xls_rowmax} = $rowmax;
$self->{_xls_colmax} = $colmax;
$self->{_xls_strmax} = $strmax;
$self->{_dim_rowmin} = undef;
$self->{_dim_rowmax} = undef;
$self->{_dim_colmin} = undef;
$self->{_dim_colmax} = undef;
$self->{_colinfo} = [];
$self->{_selection} = [0, 0];
$self->{_panes} = [];
$self->{_active_pane} = 3;
$self->{_frozen} = 0;
$self->{_frozen_no_split} = 1;
$self->{_selected} = 0;
$self->{_hidden} = 0;
$self->{_active} = 0;
$self->{_tab_color} = 0;
$self->{_first_row} = 0;
$self->{_first_col} = 0;
$self->{_display_formulas} = 0;
$self->{_display_headers} = 1;
$self->{_display_zeros} = 1;
$self->{_display_arabic} = 0;
$self->{_paper_size} = 0x0;
$self->{_orientation} = 0x1;
$self->{_header} = '';
$self->{_footer} = '';
$self->{_header_encoding} = 0;
$self->{_footer_encoding} = 0;
$self->{_hcenter} = 0;
$self->{_vcenter} = 0;
$self->{_margin_header} = 0.50;
$self->{_margin_footer} = 0.50;
$self->{_margin_left} = 0.75;
$self->{_margin_right} = 0.75;
$self->{_margin_top} = 1.00;
$self->{_margin_bottom} = 1.00;
$self->{_title_rowmin} = undef;
$self->{_title_rowmax} = undef;
$self->{_title_colmin} = undef;
$self->{_title_colmax} = undef;
$self->{_print_rowmin} = undef;
$self->{_print_rowmax} = undef;
$self->{_print_colmin} = undef;
$self->{_print_colmax} = undef;
$self->{_print_gridlines} = 1;
$self->{_screen_gridlines} = 1;
$self->{_print_headers} = 0;
$self->{_page_order} = 0;
$self->{_black_white} = 0;
$self->{_draft_quality} = 0;
$self->{_print_comments} = 0;
$self->{_page_start} = 1;
$self->{_custom_start} = 0;
$self->{_fit_page} = 0;
$self->{_fit_width} = 0;
$self->{_fit_height} = 0;
$self->{_hbreaks} = [];
$self->{_vbreaks} = [];
$self->{_protect} = 0;
$self->{_password} = undef;
$self->{_col_sizes} = {};
$self->{_row_sizes} = {};
$self->{_col_formats} = {};
$self->{_row_formats} = {};
$self->{_zoom} = 100;
$self->{_print_scale} = 100;
$self->{_page_view} = 0;
$self->{_leading_zeros} = 0;
$self->{_outline_row_level} = 0;
$self->{_outline_style} = 0;
$self->{_outline_below} = 1;
$self->{_outline_right} = 1;
$self->{_outline_on} = 1;
$self->{_write_match} = [];
$self->{_object_ids} = [];
$self->{_images} = {};
$self->{_images_array} = [];
$self->{_charts} = {};
$self->{_charts_array} = [];
$self->{_comments} = {};
$self->{_comments_array} = [];
$self->{_comments_author} = '';
$self->{_comments_author_enc} = 0;
$self->{_comments_visible} = 0;
$self->{_filter_area} = [];
$self->{_filter_count} = 0;
$self->{_filter_on} = 0;
$self->{_writing_url} = 0;
$self->{_db_indices} = [];
$self->{_validations} = [];
bless $self, $class;
$self->_initialize();
return $self;
}
###############################################################################
#
# _initialize()
#
# Open a tmp file to store the majority of the Worksheet data. If this fails,
# for example due to write permissions, store the data in memory. This can be
# slow for large files.
#
sub _initialize {
my $self = shift;
my $fh;
my $tmp_dir;
# The following code is complicated by Windows limitations. Porters can
# choose a more direct method.
# In the default case we use IO::File->new_tmpfile(). This may fail, in
# particular with IIS on Windows, so we allow the user to specify a temp
# directory via File::Temp.
#
if (defined $self->{_tempdir}) {
# Delay loading File:Temp to reduce the module dependencies.
eval { require File::Temp };
die "The File::Temp module must be installed in order ".
"to call set_tempdir().\n" if $@;
# Trap but ignore File::Temp errors.
eval { $fh = File::Temp::tempfile(DIR => $self->{_tempdir}) };
# Store the failed tmp dir in case of errors.
$tmp_dir = $self->{_tempdir} || File::Spec->tmpdir if not $fh;
}
else {
$fh = IO::File->new_tmpfile();
# Store the failed tmp dir in case of errors.
$tmp_dir = "POSIX::tmpnam() directory" if not $fh;
}
# Check if the temp file creation was successful. Else store data in memory.
if ($fh) {
# binmode file whether platform requires it or not.
binmode($fh);
# Store filehandle
$self->{_filehandle} = $fh;
}
else {
# Set flag to store data in memory if XX::tempfile() failed.
$self->{_using_tmpfile} = 0;
if ($self->{_index} == 0 && $^W) {
my $dir = $self->{_tempdir} || File::Spec->tmpdir();
warn "Unable to create temp files in $tmp_dir. Data will be ".
"stored in memory. Refer to set_tempdir() in the ".
"Spreadsheet::WriteExcel documentation.\n" ;
}
}
}
###############################################################################
#
# _close()
#
# Add data to the beginning of the workbook (note the reverse order)
# and to the end of the workbook.
#
sub _close {
my $self = shift;
################################################
# Prepend in reverse order!!
#
# Prepend the sheet dimensions
$self->_store_dimensions();
# Prepend the autofilter filters.
$self->_store_autofilters;
# Prepend the sheet autofilter info.
$self->_store_autofilterinfo();
# Prepend the sheet filtermode record.
$self->_store_filtermode();
# Prepend the COLINFO records if they exist
if (@{$self->{_colinfo}}){
my @colinfo = @{$self->{_colinfo}};
while (@colinfo) {
my $arrayref = pop @colinfo;
$self->_store_colinfo(@$arrayref);
}
}
# Prepend the DEFCOLWIDTH record
$self->_store_defcol();
# Prepend the sheet password
$self->_store_password();
# Prepend the sheet protection
$self->_store_protect();
$self->_store_obj_protect();
# Prepend the page setup
$self->_store_setup();
# Prepend the bottom margin
$self->_store_margin_bottom();
# Prepend the top margin
$self->_store_margin_top();
# Prepend the right margin
$self->_store_margin_right();
# Prepend the left margin
$self->_store_margin_left();
# Prepend the page vertical centering
$self->_store_vcenter();
# Prepend the page horizontal centering
$self->_store_hcenter();
# Prepend the page footer
$self->_store_footer();
# Prepend the page header
$self->_store_header();
# Prepend the vertical page breaks
$self->_store_vbreak();
# Prepend the horizontal page breaks
$self->_store_hbreak();
# Prepend WSBOOL
$self->_store_wsbool();
# Prepend the default row height.
$self->_store_defrow();
# Prepend GUTS
$self->_store_guts();
# Prepend GRIDSET
$self->_store_gridset();
# Prepend PRINTGRIDLINES
$self->_store_print_gridlines();
# Prepend PRINTHEADERS
$self->_store_print_headers();
#
# End of prepend. Read upwards from here.
################################################
# Append
$self->_store_table();
$self->_store_images();
$self->_store_charts();
$self->_store_filters();
$self->_store_comments();
$self->_store_window2();
$self->_store_page_view();
$self->_store_zoom();
$self->_store_panes(@{$self->{_panes}}) if @{$self->{_panes}};
$self->_store_selection(@{$self->{_selection}});
$self->_store_validation_count();
$self->_store_validations();
$self->_store_tab_color();
$self->_store_eof();
# Prepend the BOF and INDEX records
$self->_store_index();
$self->_store_bof(0x0010);
}
###############################################################################
#
# _compatibility_mode()
#
# Set the compatibility mode.
#
# See the explanation in Workbook::compatibility_mode(). This private method
# is mainly used for test purposes.
#
sub _compatibility_mode {
my $self = shift;
if (defined($_[0])) {
$self->{_compatibility} = $_[0];
}
else {
$self->{_compatibility} = 1;
}
}
###############################################################################
#
# get_name().
#
# Retrieve the worksheet name.
#
# Note, there is no set_name() method because names are used in formulas and
# converted to internal indices. Allowing the user to change sheet names
# after they have been set in add_worksheet() is asking for trouble.
#
sub get_name {
my $self = shift;
return $self->{_name};
}
###############################################################################
#
# get_data().
#
# Retrieves data from memory in one chunk, or from disk in $buffer
# sized chunks.
#
sub get_data {
my $self = shift;
my $buffer = 4096;
my $tmp;
# Return data stored in memory
if (defined $self->{_data}) {
$tmp = $self->{_data};
$self->{_data} = undef;
my $fh = $self->{_filehandle};
seek($fh, 0, 0) if $self->{_using_tmpfile};
return $tmp;
}
# Return data stored on disk
if ($self->{_using_tmpfile}) {
return $tmp if read($self->{_filehandle}, $tmp, $buffer);
}
# No data to return
return undef;
}
###############################################################################
#
# select()
#
# Set this worksheet as a selected worksheet, i.e. the worksheet has its tab
# highlighted.
#
sub select {
my $self = shift;
$self->{_hidden} = 0; # Selected worksheet can't be hidden.
$self->{_selected} = 1;
}
###############################################################################
#
# activate()
#
# Set this worksheet as the active worksheet, i.e. the worksheet that is
# displayed when the workbook is opened. Also set it as selected.
#
sub activate {
my $self = shift;
$self->{_hidden} = 0; # Active worksheet can't be hidden.
$self->{_selected} = 1;
${$self->{_activesheet}} = $self->{_index};
}
###############################################################################
#
# hide()
#
# Hide this worksheet.
#
sub hide {
my $self = shift;
$self->{_hidden} = 1;
# A hidden worksheet shouldn't be active or selected.
$self->{_selected} = 0;
${$self->{_activesheet}} = 0;
${$self->{_firstsheet}} = 0;
}
###############################################################################
#
# set_first_sheet()
#
# Set this worksheet as the first visible sheet. This is necessary
# when there are a large number of worksheets and the activated
# worksheet is not visible on the screen.
#
sub set_first_sheet {
my $self = shift;
$self->{_hidden} = 0; # Active worksheet can't be hidden.
${$self->{_firstsheet}} = $self->{_index};
}
###############################################################################
#
# protect($password)
#
# Set the worksheet protection flag to prevent accidental modification and to
# hide formulas if the locked and hidden format properties have been set.
#
sub protect {
my $self = shift;
$self->{_protect} = 1;
$self->{_password} = $self->_encode_password($_[0]) if defined $_[0];
}
###############################################################################
#
# set_column($firstcol, $lastcol, $width, $format, $hidden, $level)
#
# Set the width of a single column or a range of columns.
# See also: _store_colinfo
#
sub set_column {
my $self = shift;
my @data = @_;
my $cell = $data[0];
# Check for a cell reference in A1 notation and substitute row and column
if ($cell =~ /^\D/) {
@data = $self->_substitute_cellref(@_);
# Returned values $row1 and $row2 aren't required here. Remove them.
shift @data; # $row1
splice @data, 1, 1; # $row2
}
return if @data < 3; # Ensure at least $firstcol, $lastcol and $width
return if not defined $data[0]; # Columns must be defined.
return if not defined $data[1];
# Assume second column is the same as first if 0. Avoids KB918419 bug.
$data[1] = $data[0] if $data[1] == 0;
# Ensure 2nd col is larger than first. Also for KB918419 bug.
($data[0], $data[1]) = ($data[1], $data[0]) if $data[0] > $data[1];
# Limit columns to Excel max of 255.
$data[0] = 255 if $data[0] > 255;
$data[1] = 255 if $data[1] > 255;
push @{$self->{_colinfo}}, [ @data ];
# Store the col sizes for use when calculating image vertices taking
# hidden columns into account. Also store the column formats.
#
my $width = $data[4] ? 0 : $data[2]; # Set width to zero if col is hidden
$width ||= 0; # Ensure width isn't undef.
my $format = $data[3];
my ($firstcol, $lastcol) = @data;
foreach my $col ($firstcol .. $lastcol) {
$self->{_col_sizes}->{$col} = $width;
$self->{_col_formats}->{$col} = $format if defined $format;
}
}
###############################################################################
#
# set_selection()
#
# Set which cell or cells are selected in a worksheet: see also the
# sub _store_selection
#
sub set_selection {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
$self->{_selection} = [ @_ ];
}
###############################################################################
#
# freeze_panes()
#
# Set panes and mark them as frozen. See also _store_panes().
#
sub freeze_panes {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
# Extra flag indicated a split and freeze.
$self->{_frozen_no_split} = 0 if $_[4];
$self->{_frozen} = 1;
$self->{_panes} = [ @_ ];
}
###############################################################################
#
# split_panes()
#
# Set panes and mark them as split. See also _store_panes().
#
sub split_panes {
my $self = shift;
$self->{_frozen} = 0;
$self->{_frozen_no_split} = 0;
$self->{_panes} = [ @_ ];
}
# Older method name for backwards compatibility.
*thaw_panes = *split_panes;
###############################################################################
#
# set_portrait()
#
# Set the page orientation as portrait.
#
sub set_portrait {
my $self = shift;
$self->{_orientation} = 1;
}
###############################################################################
#
# set_landscape()
#
# Set the page orientation as landscape.
#
sub set_landscape {
my $self = shift;
$self->{_orientation} = 0;
}
###############################################################################
#
# set_page_view()
#
# Set the page view mode for Mac Excel.
#
sub set_page_view {
my $self = shift;
$self->{_page_view} = defined $_[0] ? $_[0] : 1;
}
###############################################################################
#
# set_tab_color()
#
# Set the colour of the worksheet colour.
#
sub set_tab_color {
my $self = shift;
my $color = &Spreadsheet::WriteExcel::Format::_get_color($_[0]);
$color = 0 if $color == 0x7FFF; # Default color.
$self->{_tab_color} = $color;
}
###############################################################################
#
# set_paper()
#
# Set the paper type. Ex. 1 = US Letter, 9 = A4
#
sub set_paper {
my $self = shift;
$self->{_paper_size} = $_[0] || 0;
}
###############################################################################
#
# set_header()
#
# Set the page header caption and optional margin.
#
sub set_header {
my $self = shift;
my $string = $_[0] || '';
my $margin = $_[1] || 0.50;
my $encoding = $_[2] || 0;
# Handle utf8 strings in perl 5.8.
if ($] >= 5.008) {
require Encode;
if (Encode::is_utf8($string)) {
$string = Encode::encode("UTF-16BE", $string);
$encoding = 1;
}
}
my $limit = $encoding ? 255 *2 : 255;
if (length $string >= $limit) {
carp 'Header string must be less than 255 characters';
return;
}
$self->{_header} = $string;
$self->{_margin_header} = $margin;
$self->{_header_encoding} = $encoding;
}
###############################################################################
#
# set_footer()
#
# Set the page footer caption and optional margin.
#
sub set_footer {
my $self = shift;
my $string = $_[0] || '';
my $margin = $_[1] || 0.50;
my $encoding = $_[2] || 0;
# Handle utf8 strings in perl 5.8.
if ($] >= 5.008) {
require Encode;
if (Encode::is_utf8($string)) {
$string = Encode::encode("UTF-16BE", $string);
$encoding = 1;
}
}
my $limit = $encoding ? 255 *2 : 255;
if (length $string >= $limit) {
carp 'Footer string must be less than 255 characters';
return;
}
$self->{_footer} = $string;
$self->{_margin_footer} = $margin;
$self->{_footer_encoding} = $encoding;
}
###############################################################################
#
# center_horizontally()
#
# Center the page horizontally.
#
sub center_horizontally {
my $self = shift;
if (defined $_[0]) {
$self->{_hcenter} = $_[0];
}
else {
$self->{_hcenter} = 1;
}
}
###############################################################################
#
# center_vertically()
#
# Center the page horizontally.
#
sub center_vertically {
my $self = shift;
if (defined $_[0]) {
$self->{_vcenter} = $_[0];
}
else {
$self->{_vcenter} = 1;
}
}
###############################################################################
#
# set_margins()
#
# Set all the page margins to the same value in inches.
#
sub set_margins {
my $self = shift;
$self->set_margin_left($_[0]);
$self->set_margin_right($_[0]);
$self->set_margin_top($_[0]);
$self->set_margin_bottom($_[0]);
}
###############################################################################
#
# set_margins_LR()
#
# Set the left and right margins to the same value in inches.
#
sub set_margins_LR {
my $self = shift;
$self->set_margin_left($_[0]);
$self->set_margin_right($_[0]);
}
###############################################################################
#
# set_margins_TB()
#
# Set the top and bottom margins to the same value in inches.
#
sub set_margins_TB {
my $self = shift;
$self->set_margin_top($_[0]);
$self->set_margin_bottom($_[0]);
}
###############################################################################
#
# set_margin_left()
#
# Set the left margin in inches.
#
sub set_margin_left {
my $self = shift;
$self->{_margin_left} = defined $_[0] ? $_[0] : 0.75;
}
###############################################################################
#
# set_margin_right()
#
# Set the right margin in inches.
#
sub set_margin_right {
my $self = shift;
$self->{_margin_right} = defined $_[0] ? $_[0] : 0.75;
}
###############################################################################
#
# set_margin_top()
#
# Set the top margin in inches.
#
sub set_margin_top {
my $self = shift;
$self->{_margin_top} = defined $_[0] ? $_[0] : 1.00;
}
###############################################################################
#
# set_margin_bottom()
#
# Set the bottom margin in inches.
#
sub set_margin_bottom {
my $self = shift;
$self->{_margin_bottom} = defined $_[0] ? $_[0] : 1.00;
}
###############################################################################
#
# repeat_rows($first_row, $last_row)
#
# Set the rows to repeat at the top of each printed page. See also the
# _store_name_xxxx() methods in Workbook.pm.
#
sub repeat_rows {
my $self = shift;
$self->{_title_rowmin} = $_[0];
$self->{_title_rowmax} = $_[1] || $_[0]; # Second row is optional
}
###############################################################################
#
# repeat_columns($first_col, $last_col)
#
# Set the columns to repeat at the left hand side of each printed page.
# See also the _store_names() methods in Workbook.pm.
#
sub repeat_columns {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
# Returned values $row1 and $row2 aren't required here. Remove them.
shift @_; # $row1
splice @_, 1, 1; # $row2
}
$self->{_title_colmin} = $_[0];
$self->{_title_colmax} = $_[1] || $_[0]; # Second col is optional
}
###############################################################################
#
# print_area($first_row, $first_col, $last_row, $last_col)
#
# Set the area of each worksheet that will be printed. See also the
# _store_names() methods in Workbook.pm.
#
sub print_area {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
return if @_ != 4; # Require 4 parameters
$self->{_print_rowmin} = $_[0];
$self->{_print_colmin} = $_[1];
$self->{_print_rowmax} = $_[2];
$self->{_print_colmax} = $_[3];
}
###############################################################################
#
# autofilter($first_row, $first_col, $last_row, $last_col)
#
# Set the autofilter area in the worksheet.
#
sub autofilter {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
return if @_ != 4; # Require 4 parameters
my ($row1, $col1, $row2, $col2) = @_;
# Reverse max and min values if necessary.
($row1, $row2) = ($row2, $row1) if $row2 < $row1;
($col1, $col2) = ($col2, $col1) if $col2 < $col1;
# Store the Autofilter information
$self->{_filter_area} = [$row1, $row2, $col1, $col2];
$self->{_filter_count} = 1+ $col2 -$col1;
}
###############################################################################
#
# filter_column($column, $criteria, ...)
#
# Set the column filter criteria.
#
sub filter_column {
my $self = shift;
my $col = $_[0];
my $expression = $_[1];
croak "Must call autofilter() before filter_column()"
unless $self->{_filter_count};
croak "Incorrect number of arguments to filter_column()" unless @_ == 2;
# Check for a column reference in A1 notation and substitute.
if ($col =~ /^\D/) {
# Convert col ref to a cell ref and then to a col number.
(undef, $col) = $self->_substitute_cellref($col . '1');
}
my (undef, undef, $col_first, $col_last) = @{$self->{_filter_area}};
# Reject column if it is outside filter range.
if ($col < $col_first or $col > $col_last) {
croak "Column '$col' outside autofilter() column range " .
"($col_first .. $col_last)";
}
my @tokens = $self->_extract_filter_tokens($expression);
croak "Incorrect number of tokens in expression '$expression'"
unless (@tokens == 3 or @tokens == 7);
@tokens = $self->_parse_filter_expression($expression, @tokens);
$self->{_filter_cols}->{$col} = [@tokens];
$self->{_filter_on} = 1;
}
###############################################################################
#
# _extract_filter_tokens($expression)
#
# Extract the tokens from the filter expression. The tokens are mainly non-
# whitespace groups. The only tricky part is to extract string tokens that
# contain whitespace and/or quoted double quotes (Excel's escaped quotes).
#
# Examples: 'x < 2000'
# 'x > 2000 and x < 5000'
# 'x = "foo"'
# 'x = "foo bar"'
# 'x = "foo "" bar"'
#
sub _extract_filter_tokens {
my $self = shift;
my $expression = $_[0];
return unless $expression;
my @tokens = ($expression =~ /"(?:[^"]|"")*"|\S+/g); #"
# Remove leading and trailing quotes and unescape other quotes
for (@tokens) {
s/^"//; #"
s/"$//; #"
s/""/"/g; #"
}
return @tokens;
}
###############################################################################
#
# _parse_filter_expression(@token)
#
# Converts the tokens of a possibly conditional expression into 1 or 2
# sub expressions for further parsing.
#
# Examples:
# ('x', '==', 2000) -> exp1
# ('x', '>', 2000, 'and', 'x', '<', 5000) -> exp1 and exp2
#
sub _parse_filter_expression {
my $self = shift;
my $expression = shift;
my @tokens = @_;
# The number of tokens will be either 3 (for 1 expression)
# or 7 (for 2 expressions).
#
if (@tokens == 7) {
my $conditional = $tokens[3];
if ($conditional =~ /^(and|&&)$/) {
$conditional = 0;
}
elsif ($conditional =~ /^(or|\|\|)$/) {
$conditional = 1;
}
else {
croak "Token '$conditional' is not a valid conditional " .
"in filter expression '$expression'";
}
my @expression_1 = $self->_parse_filter_tokens($expression,
@tokens[0, 1, 2]);
my @expression_2 = $self->_parse_filter_tokens($expression,
@tokens[4, 5, 6]);
return (@expression_1, $conditional, @expression_2);
}
else {
return $self->_parse_filter_tokens($expression, @tokens);
}
}
###############################################################################
#
# _parse_filter_tokens(@token)
#
# Parse the 3 tokens of a filter expression and return the operator and token.
#
sub _parse_filter_tokens {
my $self = shift;
my $expression = shift;
my @tokens = @_;
my %operators = (
'==' => 2,
'=' => 2,
'=~' => 2,
'eq' => 2,
'!=' => 5,
'!~' => 5,
'ne' => 5,
'<>' => 5,
'<' => 1,
'<=' => 3,
'>' => 4,
'>=' => 6,
);
my $operator = $operators{$tokens[1]};
my $token = $tokens[2];
# Special handling of "Top" filter expressions.
if ($tokens[0] =~ /^top|bottom$/i) {
my $value = $tokens[1];
if ($value =~ /\D/ or
$value < 1 or
$value > 500)
{
croak "The value '$value' in expression '$expression' " .
"must be in the range 1 to 500";
}
$token = lc $token;
if ($token ne 'items' and $token ne '%') {
croak "The type '$token' in expression '$expression' " .
"must be either 'items' or '%'";
}
if ($tokens[0] =~ /^top$/i) {
$operator = 30;
}
else {
$operator = 32;
}
if ($tokens[2] eq '%') {
$operator++;
}
$token = $value;
}
if (not $operator and $tokens[0]) {
croak "Token '$tokens[1]' is not a valid operator " .
"in filter expression '$expression'";
}
# Special handling for Blanks/NonBlanks.
if ($token =~ /^blanks|nonblanks$/i) {
# Only allow Equals or NotEqual in this context.
if ($operator != 2 and $operator != 5) {
croak "The operator '$tokens[1]' in expression '$expression' " .
"is not valid in relation to Blanks/NonBlanks'";
}
$token = lc $token;
# The operator should always be 2 (=) to flag a "simple" equality in
# the binary record. Therefore we convert <> to =.
if ($token eq 'blanks') {
if ($operator == 5) {
$operator = 2;
$token = 'nonblanks';
}
}
else {
if ($operator == 5) {
$operator = 2;
$token = 'blanks';
}
}
}
# if the string token contains an Excel match character then change the
# operator type to indicate a non "simple" equality.
if ($operator == 2 and $token =~ /[*?]/) {
$operator = 22;
}
return ($operator, $token);
}
###############################################################################
#
# hide_gridlines()
#
# Set the option to hide gridlines on the screen and the printed page.
# There are two ways of doing this in the Excel BIFF format: The first is by
# setting the DspGrid field of the WINDOW2 record, this turns off the screen
# and subsequently the print gridline. The second method is to via the
# PRINTGRIDLINES and GRIDSET records, this turns off the printed gridlines
# only. The first method is probably sufficient for most cases. The second
# method is supported for backwards compatibility. Porters take note.
#
sub hide_gridlines {
my $self = shift;
my $option = $_[0];
$option = 1 unless defined $option; # Default to hiding printed gridlines
if ($option == 0) {
$self->{_print_gridlines} = 1; # 1 = display, 0 = hide
$self->{_screen_gridlines} = 1;
}
elsif ($option == 1) {
$self->{_print_gridlines} = 0;
$self->{_screen_gridlines} = 1;
}
else {
$self->{_print_gridlines} = 0;
$self->{_screen_gridlines} = 0;
}
}
###############################################################################
#
# print_row_col_headers()
#
# Set the option to print the row and column headers on the printed page.
# See also the _store_print_headers() method below.
#
sub print_row_col_headers {
my $self = shift;
if (defined $_[0]) {
$self->{_print_headers} = $_[0];
}
else {
$self->{_print_headers} = 1;
}
}
###############################################################################
#
# fit_to_pages($width, $height)
#
# Store the vertical and horizontal number of pages that will define the
# maximum area printed. See also _store_setup() and _store_wsbool() below.
#
sub fit_to_pages {
my $self = shift;
$self->{_fit_page} = 1;
$self->{_fit_width} = $_[0] || 0;
$self->{_fit_height} = $_[1] || 0;
}
###############################################################################
#
# set_h_pagebreaks(@breaks)
#
# Store the horizontal page breaks on a worksheet.
#
sub set_h_pagebreaks {
my $self = shift;
push @{$self->{_hbreaks}}, @_;
}
###############################################################################
#
# set_v_pagebreaks(@breaks)
#
# Store the vertical page breaks on a worksheet.
#
sub set_v_pagebreaks {
my $self = shift;
push @{$self->{_vbreaks}}, @_;
}
###############################################################################
#
# set_zoom($scale)
#
# Set the worksheet zoom factor.
#
sub set_zoom {
my $self = shift;
my $scale = $_[0] || 100;
# Confine the scale to Excel's range
if ($scale < 10 or $scale > 400) {
carp "Zoom factor $scale outside range: 10 <= zoom <= 400";
$scale = 100;
}
$self->{_zoom} = int $scale;
}
###############################################################################
#
# set_print_scale($scale)
#
# Set the scale factor for the printed page.
#
sub set_print_scale {
my $self = shift;
my $scale = $_[0] || 100;
# Confine the scale to Excel's range
if ($scale < 10 or $scale > 400) {
carp "Print scale $scale outside range: 10 <= zoom <= 400";
$scale = 100;
}
# Turn off "fit to page" option
$self->{_fit_page} = 0;
$self->{_print_scale} = int $scale;
}
###############################################################################
#
# keep_leading_zeros()
#
# Causes the write() method to treat integers with a leading zero as a string.
# This ensures that any leading zeros such, as in zip codes, are maintained.
#
sub keep_leading_zeros {
my $self = shift;
if (defined $_[0]) {
$self->{_leading_zeros} = $_[0];
}
else {
$self->{_leading_zeros} = 1;
}
}
###############################################################################
#
# show_comments()
#
# Make any comments in the worksheet visible.
#
sub show_comments {
my $self = shift;
$self->{_comments_visible} = defined $_[0] ? $_[0] : 1;
}
###############################################################################
#
# set_comments_author()
#
# Set the default author of the cell comments.
#
sub set_comments_author {
my $self = shift;
$self->{_comments_author} = defined $_[0] ? $_[0] : '';
$self->{_comments_author_enc} = $_[1] ? 1 : 0;
}
###############################################################################
#
# right_to_left()
#
# Display the worksheet right to left for some eastern versions of Excel.
#
sub right_to_left {
my $self = shift;
$self->{_display_arabic} = defined $_[0] ? $_[0] : 1;
}
###############################################################################
#
# hide_zero()
#
# Hide cell zero values.
#
sub hide_zero {
my $self = shift;
$self->{_display_zeros} = defined $_[0] ? not $_[0] : 0;
}
###############################################################################
#
# print_across()
#
# Set the order in which pages are printed.
#
sub print_across {
my $self = shift;
$self->{_page_order} = defined $_[0] ? $_[0] : 1;
}
###############################################################################
#
# set_start_page()
#
# Set the start page number.
#
sub set_start_page {
my $self = shift;
return unless defined $_[0];
$self->{_page_start} = $_[0];
$self->{_custom_start} = 1;
}
###############################################################################
#
# set_first_row_column()
#
# Set the topmost and leftmost visible row and column.
# TODO: Document this when tested fully for interaction with panes.
#
sub set_first_row_column {
my $self = shift;
my $row = $_[0] || 0;
my $col = $_[1] || 0;
$row = 65535 if $row > 65535;
$col = 255 if $col > 255;
$self->{_first_row} = $row;
$self->{_first_col} = $col;
}
###############################################################################
#
# add_write_handler($re, $code_ref)
#
# Allow the user to add their own matches and handlers to the write() method.
#
sub add_write_handler {
my $self = shift;
return unless @_ == 2;
return unless ref $_[1] eq 'CODE';
push @{$self->{_write_match}}, [ @_ ];
}
###############################################################################
#
# write($row, $col, $token, $format)
#
# Parse $token and call appropriate write method. $row and $column are zero
# indexed. $format is optional.
#
# The write_url() methods have a flag to prevent recursion when writing a
# string that looks like a url.
#
# Returns: return value of called subroutine
#
sub write {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
my $token = $_[2];
# Handle undefs as blanks
$token = '' unless defined $token;
# First try user defined matches.
for my $aref (@{$self->{_write_match}}) {
my $re = $aref->[0];
my $sub = $aref->[1];
if ($token =~ /$re/) {
my $match = &$sub($self, @_);
return $match if defined $match;
}
}
# Match an array ref.
if (ref $token eq "ARRAY") {
return $self->write_row(@_);
}
# Match integer with leading zero(s)
elsif ($self->{_leading_zeros} and $token =~ /^0\d+$/) {
return $self->write_string(@_);
}
# Match number
elsif ($token =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) {
return $self->write_number(@_);
}
# Match http, https or ftp URL
elsif ($token =~ m|^[fh]tt?ps?://| and not $self->{_writing_url}) {
return $self->write_url(@_);
}
# Match mailto:
elsif ($token =~ m/^mailto:/ and not $self->{_writing_url}) {
return $self->write_url(@_);
}
# Match internal or external sheet link
elsif ($token =~ m[^(?:in|ex)ternal:] and not $self->{_writing_url}) {
return $self->write_url(@_);
}
# Match formula
elsif ($token =~ /^=/) {
return $self->write_formula(@_);
}
# Match blank
elsif ($token eq '') {
splice @_, 2, 1; # remove the empty string from the parameter list
return $self->write_blank(@_);
}
else {
return $self->write_string(@_);
}
}
###############################################################################
#
# write_row($row, $col, $array_ref, $format)
#
# Write a row of data starting from ($row, $col). Call write_col() if any of
# the elements of the array ref are in turn array refs. This allows the writing
# of 1D or 2D arrays of data in one go.
#
# Returns: the first encountered error value or zero for no errors
#
sub write_row {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
# Catch non array refs passed by user.
if (ref $_[2] ne 'ARRAY') {
croak "Not an array ref in call to write_row()$!";
}
my $row = shift;
my $col = shift;
my $tokens = shift;
my @options = @_;
my $error = 0;
my $ret;
foreach my $token (@$tokens) {
# Check for nested arrays
if (ref $token eq "ARRAY") {
$ret = $self->write_col($row, $col, $token, @options);
} else {
$ret = $self->write ($row, $col, $token, @options);
}
# Return only the first error encountered, if any.
$error ||= $ret;
$col++;
}
return $error;
}
###############################################################################
#
# write_col($row, $col, $array_ref, $format)
#
# Write a column of data starting from ($row, $col). Call write_row() if any of
# the elements of the array ref are in turn array refs. This allows the writing
# of 1D or 2D arrays of data in one go.
#
# Returns: the first encountered error value or zero for no errors
#
sub write_col {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
# Catch non array refs passed by user.
if (ref $_[2] ne 'ARRAY') {
croak "Not an array ref in call to write_col()$!";
}
my $row = shift;
my $col = shift;
my $tokens = shift;
my @options = @_;
my $error = 0;
my $ret;
foreach my $token (@$tokens) {
# write() will deal with any nested arrays
$ret = $self->write($row, $col, $token, @options);
# Return only the first error encountered, if any.
$error ||= $ret;
$row++;
}
return $error;
}
###############################################################################
#
# write_comment($row, $col, $comment)
#
# Write a comment to the specified row and column (zero indexed).
#
# Returns 0 : normal termination
# -1 : insufficient number of arguments
# -2 : row or column out of range
#
sub write_comment {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
if (@_ < 3) { return -1 } # Check the number of args
my $row = $_[0];
my $col = $_[1];
# Check for pairs of optional arguments, i.e. an odd number of args.
croak "Uneven number of additional arguments" unless @_ % 2;
# Check that row and col are valid and store max and min values
return -2 if $self->_check_dimensions($row, $col);
# We have to avoid duplicate comments in cells or else Excel will complain.
$self->{_comments}->{$row}->{$col} = [ $self->_comment_params(@_) ];
}
###############################################################################
#
# _XF()
#
# Returns an index to the XF record in the workbook.
#
# Note: this is a function, not a method.
#
sub _XF {
my $self = $_[0];
my $row = $_[1];
my $col = $_[2];
my $format = $_[3];
my $error = "Error: refer to merge_range() in the documentation. " .
"Can't use previously merged format in non-merged cell";
if (ref($format)) {
# Temp code to prevent merged formats in non-merged cells.
croak $error if $format->{_used_merge} == 1;
$format->{_used_merge} = -1;
return $format->get_xf_index();
}
elsif (exists $self->{_row_formats}->{$row}) {
# Temp code to prevent merged formats in non-merged cells.
croak $error if $self->{_row_formats}->{$row}->{_used_merge} == 1;
$self->{_row_formats}->{$row}->{_used_merge} = -1;
return $self->{_row_formats}->{$row}->get_xf_index();
}
elsif (exists $self->{_col_formats}->{$col}) {
# Temp code to prevent merged formats in non-merged cells.
croak $error if $self->{_col_formats}->{$col}->{_used_merge} == 1;
$self->{_col_formats}->{$col}->{_used_merge} = -1;
return $self->{_col_formats}->{$col}->get_xf_index();
}
else {
return 0x0F;
}
}
###############################################################################
###############################################################################
#
# Internal methods
#
###############################################################################
#
# _append(), overridden.
#
# Store Worksheet data in memory using the base class _append() or to a
# temporary file, the default.
#
sub _append {
my $self = shift;
my $data = '';
if ($self->{_using_tmpfile}) {
$data = join('', @_);
# Add CONTINUE records if necessary
$data = $self->_add_continue($data) if length($data) > $self->{_limit};
# Protect print() from -l on the command line.
local $\ = undef;
print {$self->{_filehandle}} $data;
$self->{_datasize} += length($data);
}
else {
$data = $self->SUPER::_append(@_);
}
return $data;
}
###############################################################################
#
# _substitute_cellref()
#
# Substitute an Excel cell reference in A1 notation for zero based row and
# column values in an argument list.
#
# Ex: ("A4", "Hello") is converted to (3, 0, "Hello").
#
sub _substitute_cellref {
my $self = shift;
my $cell = uc(shift);
# Convert a column range: 'A:A' or 'B:G'.
# A range such as A:A is equivalent to A1:65536, so add rows as required
if ($cell =~ /\$?([A-I]?[A-Z]):\$?([A-I]?[A-Z])/) {
my ($row1, $col1) = $self->_cell_to_rowcol($1 .'1');
my ($row2, $col2) = $self->_cell_to_rowcol($2 .'65536');
return $row1, $col1, $row2, $col2, @_;
}
# Convert a cell range: 'A1:B7'
if ($cell =~ /\$?([A-I]?[A-Z]\$?\d+):\$?([A-I]?[A-Z]\$?\d+)/) {
my ($row1, $col1) = $self->_cell_to_rowcol($1);
my ($row2, $col2) = $self->_cell_to_rowcol($2);
return $row1, $col1, $row2, $col2, @_;
}
# Convert a cell reference: 'A1' or 'AD2000'
if ($cell =~ /\$?([A-I]?[A-Z]\$?\d+)/) {
my ($row1, $col1) = $self->_cell_to_rowcol($1);
return $row1, $col1, @_;
}
croak("Unknown cell reference $cell");
}
###############################################################################
#
# _cell_to_rowcol($cell_ref)
#
# Convert an Excel cell reference in A1 notation to a zero based row and column
# reference; converts C1 to (0, 2).
#
# Returns: row, column
#
sub _cell_to_rowcol {
my $self = shift;
my $cell = shift;
$cell =~ /\$?([A-I]?[A-Z])\$?(\d+)/;
my $col = $1;
my $row = $2;
# Convert base26 column string to number
# All your Base are belong to us.
my @chars = split //, $col;
my $expn = 0;
$col = 0;
while (@chars) {
my $char = pop(@chars); # LS char first
$col += (ord($char) -ord('A') +1) * (26**$expn);
$expn++;
}
# Convert 1-index to zero-index
$row--;
$col--;
return $row, $col;
}
###############################################################################
#
# _sort_pagebreaks()
#
#
# This is an internal method that is used to filter elements of the array of
# pagebreaks used in the _store_hbreak() and _store_vbreak() methods. It:
# 1. Removes duplicate entries from the list.
# 2. Sorts the list.
# 3. Removes 0 from the list if present.
#
sub _sort_pagebreaks {
my $self= shift;
my %hash;
my @array;
@hash{@_} = undef; # Hash slice to remove duplicates
@array = sort {$a <=> $b} keys %hash; # Numerical sort
shift @array if $array[0] == 0; # Remove zero
# 1000 vertical pagebreaks appears to be an internal Excel 5 limit.
# It is slightly higher in Excel 97/200, approx. 1026
splice(@array, 1000) if (@array > 1000);
return @array
}
###############################################################################
#
# _encode_password($password)
#
# Based on the algorithm provided by Daniel Rentz of OpenOffice.
#
#
sub _encode_password {
use integer;
my $self = shift;
my $plaintext = $_[0];
my $password;
my $count;
my @chars;
my $i = 0;
$count = @chars = split //, $plaintext;
foreach my $char (@chars) {
my $low_15;
my $high_15;
$char = ord($char) << ++$i;
$low_15 = $char & 0x7fff;
$high_15 = $char & 0x7fff << 15;
$high_15 = $high_15 >> 15;
$char = $low_15 | $high_15;
}
$password = 0x0000;
$password ^= $_ for @chars;
$password ^= $count;
$password ^= 0xCE4B;
return $password;
}
###############################################################################
#
# outline_settings($visible, $symbols_below, $symbols_right, $auto_style)
#
# This method sets the properties for outlining and grouping. The defaults
# correspond to Excel's defaults.
#
sub outline_settings {
my $self = shift;
$self->{_outline_on} = defined $_[0] ? $_[0] : 1;
$self->{_outline_below} = defined $_[1] ? $_[1] : 1;
$self->{_outline_right} = defined $_[2] ? $_[2] : 1;
$self->{_outline_style} = $_[3] || 0;
# Ensure this is a boolean vale for Window2
$self->{_outline_on} = 1 if $self->{_outline_on};
}
###############################################################################
###############################################################################
#
# BIFF RECORDS
#
###############################################################################
#
# write_number($row, $col, $num, $format)
#
# Write a double to the specified row and column (zero indexed).
# An integer can be written as a double. Excel will display an
# integer. $format is optional.
#
# Returns 0 : normal termination
# -1 : insufficient number of arguments
# -2 : row or column out of range
#
sub write_number {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
if (@_ < 3) { return -1 } # Check the number of args
my $record = 0x0203; # Record identifier
my $length = 0x000E; # Number of bytes to follow
my $row = $_[0]; # Zero indexed row
my $col = $_[1]; # Zero indexed column
my $num = $_[2];
my $xf = _XF($self, $row, $col, $_[3]); # The cell format
# Check that row and col are valid and store max and min values
return -2 if $self->_check_dimensions($row, $col);
my $header = pack("vv", $record, $length);
my $data = pack("vvv", $row, $col, $xf);
my $xl_double = pack("d", $num);
if ($self->{_byte_order}) { $xl_double = reverse $xl_double }
# Store the data or write immediately depending on the compatibility mode.
if ($self->{_compatibility}) {
$self->{_table}->[$row]->[$col] = $header . $data . $xl_double;
}
else {
$self->_append($header, $data, $xl_double);
}
return 0;
}
###############################################################################
#
# write_string ($row, $col, $string, $format)
#
# Write a string to the specified row and column (zero indexed).
# $format is optional.
# Returns 0 : normal termination
# -1 : insufficient number of arguments
# -2 : row or column out of range
# -3 : long string truncated to max chars
#
sub write_string {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
if (@_ < 3) { return -1 } # Check the number of args
my $record = 0x00FD; # Record identifier
my $length = 0x000A; # Bytes to follow
my $row = $_[0]; # Zero indexed row
my $col = $_[1]; # Zero indexed column
my $strlen = length($_[2]);
my $str = $_[2];
my $xf = _XF($self, $row, $col, $_[3]); # The cell format
my $encoding = 0x0;
my $str_error = 0;
# Handle utf8 strings in perl 5.8.
if ($] >= 5.008) {
require Encode;
if (Encode::is_utf8($str)) {
my $tmp = Encode::encode("UTF-16LE", $str);
return $self->write_utf16le_string($row, $col, $tmp, $_[3]);
}
}
# Check that row and col are valid and store max and min values
return -2 if $self->_check_dimensions($row, $col);
# Limit the string to the max number of chars.
if ($strlen > 32767) {
$str = substr($str, 0, 32767);
$str_error = -3;
}
# Prepend the string with the type.
my $str_header = pack("vC", length($str), $encoding);
$str = $str_header . $str;
if (not exists ${$self->{_str_table}}->{$str}) {
${$self->{_str_table}}->{$str} = ${$self->{_str_unique}}++;
}
${$self->{_str_total}}++;
my $header = pack("vv", $record, $length);
my $data = pack("vvvV", $row, $col, $xf, ${$self->{_str_table}}->{$str});
# Store the data or write immediately depending on the compatibility mode.
if ($self->{_compatibility}) {
$self->{_table}->[$row]->[$col] = $header . $data;
}
else {
$self->_append($header, $data);
}
return $str_error;
}
###############################################################################
#
# write_blank($row, $col, $format)
#
# Write a blank cell to the specified row and column (zero indexed).
# A blank cell is used to specify formatting without adding a string
# or a number.
#
# A blank cell without a format serves no purpose. Therefore, we don't write
# a BLANK record unless a format is specified. This is mainly an optimisation
# for the write_row() and write_col() methods.
#
# Returns 0 : normal termination (including no format)
# -1 : insufficient number of arguments
# -2 : row or column out of range
#
sub write_blank {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
# Check the number of args
return -1 if @_ < 2;
# Don't write a blank cell unless it has a format
return 0 if not defined $_[2];
my $record = 0x0201; # Record identifier
my $length = 0x0006; # Number of bytes to follow
my $row = $_[0]; # Zero indexed row
my $col = $_[1]; # Zero indexed column
my $xf = _XF($self, $row, $col, $_[2]); # The cell format
# Check that row and col are valid and store max and min values
return -2 if $self->_check_dimensions($row, $col);
my $header = pack("vv", $record, $length);
my $data = pack("vvv", $row, $col, $xf);
# Store the data or write immediately depending on the compatibility mode.
if ($self->{_compatibility}) {
$self->{_table}->[$row]->[$col] = $header . $data;
}
else {
$self->_append($header, $data);
}
return 0;
}
###############################################################################
#
# write_formula($row, $col, $formula, $format, $value)
#
# Write a formula to the specified row and column (zero indexed).
# The textual representation of the formula is passed to the parser in
# Formula.pm which returns a packed binary string.
#
# $format is optional.
#
# $value is an optional result of the formula that can be supplied by the user.
#
# Returns 0 : normal termination
# -1 : insufficient number of arguments
# -2 : row or column out of range
#
sub write_formula {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
if (@_ < 3) { return -1 } # Check the number of args
return if ! defined $_[2];
my $record = 0x0006; # Record identifier
my $length; # Bytes to follow
my $row = $_[0]; # Zero indexed row
my $col = $_[1]; # Zero indexed column
my $formula = $_[2]; # The formula text string
my $value = $_[4]; # The formula value.
my $xf = _XF($self, $row, $col, $_[3]); # The cell format
my $chn = 0x0000; # Must be zero
my $is_string = 0; # Formula evaluates to str
my $num; # Current value of formula
my $grbit; # Option flags
# Excel normally stores the last calculated value of the formula in $num.
# Clearly we are not in a position to calculate this "a priori". Instead
# we set $num to zero and set the option flags in $grbit to ensure
# automatic calculation of the formula when the file is opened.
# As a workaround for some non-Excel apps we also allow the user to
# specify the result of the formula.
#
($num, $grbit, $is_string) = $self->_encode_formula_result($value);
# Check that row and col are valid and store max and min values
return -2 if $self->_check_dimensions($row, $col);
# Strip the = sign at the beginning of the formula string
$formula =~ s(^=)();
my $tmp = $formula;
# Parse the formula using the parser in Formula.pm
my $parser = $self->{_parser};
# In order to raise formula errors from the point of view of the calling
# program we use an eval block and re-raise the error from here.
#
eval { $formula = $parser->parse_formula($formula) };
if ($@) {
$@ =~ s/\n$//; # Strip the \n used in the Formula.pm die()
croak $@; # Re-raise the error
}
my $formlen = length($formula); # Length of the binary string
$length = 0x16 + $formlen; # Length of the record data
my $header = pack("vv", $record, $length);
my $data = pack("vvv", $row, $col, $xf);
$data .= $num;
$data .= pack("vVv", $grbit, $chn, $formlen);
# The STRING record if the formula evaluates to a string.
my $string = '';
$string = $self->_get_formula_string($value) if $is_string;
# Store the data or write immediately depending on the compatibility mode.
if ($self->{_compatibility}) {
$self->{_table}->[$row]->[$col] = $header . $data . $formula . $string;
}
else {
$self->_append($header, $data, $formula, $string);
}
return 0;
}
###############################################################################
#
# _encode_formula_result()
#
# Encode the user supplied result for a formula.
#
sub _encode_formula_result {
my $self = shift;
my $value = $_[0]; # Result to be encoded.
my $is_string = 0; # Formula evaluates to str.
my $num; # Current value of formula.
my $grbit; # Option flags.
if (not defined $value) {
$grbit = 0x03;
$num = pack "d", 0;
}
else {
# The user specified the result of the formula. We turn off the recalc
# flag and check the result type.
$grbit = 0x00;
if ($value =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) {
# Value is a number.
$num = pack "d", $value;
}
else {
my %bools = (
'TRUE' => [1, 1],
'FALSE' => [1, 0],
'#NULL!' => [2, 0],
'#DIV/0!' => [2, 7],
'#VALUE!' => [2, 15],
'#REF!' => [2, 23],
'#NAME?' => [2, 29],
'#NUM!' => [2, 36],
'#N/A' => [2, 42],
);
if (exists $bools{$value}) {
# Value is a boolean.
$num = pack "vvvv", $bools{$value}->[0],
$bools{$value}->[1],
0,
0xFFFF;
}
else {
# Value is a string.
$num = pack "vvvv", 0,
0,
0,
0xFFFF;
$is_string = 1;
}
}
}
return ($num, $grbit, $is_string);
}
###############################################################################
#
# _get_formula_string()
#
# Pack the string value when a formula evaluates to a string. The value cannot
# be calculated by the module and thus must be supplied by the user.
#
sub _get_formula_string {
my $self = shift;
my $record = 0x0207; # Record identifier
my $length = 0x00; # Bytes to follow
my $string = $_[0]; # Formula string.
my $strlen = length $_[0]; # Length of the formula string (chars).
my $encoding = 0; # String encoding.
# Handle utf8 strings in perl 5.8.
if ($] >= 5.008) {
require Encode;
if (Encode::is_utf8($string)) {
$string = Encode::encode("UTF-16BE", $string);
$encoding = 1;
}
}
$length = 0x03 + length $string; # Length of the record data
my $header = pack("vv", $record, $length);
my $data = pack("vC", $strlen, $encoding);
return $header . $data . $string;
}
###############################################################################
#
# store_formula($formula)
#
# Pre-parse a formula. This is used in conjunction with repeat_formula()
# to repetitively rewrite a formula without re-parsing it.
#
sub store_formula {
my $self = shift;
my $formula = $_[0]; # The formula text string
# Strip the = sign at the beginning of the formula string
$formula =~ s(^=)();
# Parse the formula using the parser in Formula.pm
my $parser = $self->{_parser};
# In order to raise formula errors from the point of view of the calling
# program we use an eval block and re-raise the error from here.
#
my @tokens;
eval { @tokens = $parser->parse_formula($formula) };
if ($@) {
$@ =~ s/\n$//; # Strip the \n used in the Formula.pm die()
croak $@; # Re-raise the error
}
# Return the parsed tokens in an anonymous array
return [@tokens];
}
###############################################################################
#
# repeat_formula($row, $col, $formula, $format, ($pattern => $replacement,...))
#
# Write a formula to the specified row and column (zero indexed) by
# substituting $pattern $replacement pairs in the $formula created via
# store_formula(). This allows the user to repetitively rewrite a formula
# without the significant overhead of parsing.
#
# Returns 0 : normal termination
# -1 : insufficient number of arguments
# -2 : row or column out of range
#
sub repeat_formula {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
if (@_ < 2) { return -1 } # Check the number of args
my $record = 0x0006; # Record identifier
my $length; # Bytes to follow
my $row = shift; # Zero indexed row
my $col = shift; # Zero indexed column
my $formula_ref = shift; # Array ref with formula tokens
my $format = shift; # XF format
my @pairs = @_; # Pattern/replacement pairs
# Enforce an even number of arguments in the pattern/replacement list
croak "Odd number of elements in pattern/replacement list" if @pairs %2;
# Check that $formula is an array ref
croak "Not a valid formula" if ref $formula_ref ne 'ARRAY';
my @tokens = @$formula_ref;
# Ensure that there are tokens to substitute
croak "No tokens in formula" unless @tokens;
# As a temporary and undocumented measure we allow the user to specify the
# result of the formula by appending a result => $value pair to the end
# of the arguments.
my $value = undef;
if (@pairs && $pairs[-2] eq 'result') {
$value = pop @pairs;
pop @pairs;
}
while (@pairs) {
my $pattern = shift @pairs;
my $replace = shift @pairs;
foreach my $token (@tokens) {
last if $token =~ s/$pattern/$replace/;
}
}
# Change the parameters in the formula cached by the Formula.pm object
my $parser = $self->{_parser};
my $formula = $parser->parse_tokens(@tokens);
croak "Unrecognised token in formula" unless defined $formula;
my $xf = _XF($self, $row, $col, $format); # The cell format
my $chn = 0x0000; # Must be zero
my $is_string = 0; # Formula evaluates to str
my $num; # Current value of formula
my $grbit; # Option flags
# Excel normally stores the last calculated value of the formula in $num.
# Clearly we are not in a position to calculate this "a priori". Instead
# we set $num to zero and set the option flags in $grbit to ensure
# automatic calculation of the formula when the file is opened.
# As a workaround for some non-Excel apps we also allow the user to
# specify the result of the formula.
#
($num, $grbit, $is_string) = $self->_encode_formula_result($value);
# Check that row and col are valid and store max and min values
return -2 if $self->_check_dimensions($row, $col);
my $formlen = length($formula); # Length of the binary string
$length = 0x16 + $formlen; # Length of the record data
my $header = pack("vv", $record, $length);
my $data = pack("vvv", $row, $col, $xf);
$data .= $num;
$data .= pack("vVv", $grbit, $chn, $formlen);
# The STRING record if the formula evaluates to a string.
my $string = '';
$string = $self->_get_formula_string($value) if $is_string;
# Store the data or write immediately depending on the compatibility mode.
if ($self->{_compatibility}) {
$self->{_table}->[$row]->[$col] = $header . $data . $formula . $string;
}
else {
$self->_append($header, $data, $formula, $string);
}
return 0;
}
###############################################################################
#
# write_url($row, $col, $url, $string, $format)
#
# Write a hyperlink. This is comprised of two elements: the visible label and
# the invisible link. The visible label is the same as the link unless an
# alternative string is specified.
#
# The parameters $string and $format are optional and their order is
# interchangeable for backward compatibility reasons.
#
# The hyperlink can be to a http, ftp, mail, internal sheet, or external
# directory url.
#
# Returns 0 : normal termination
# -1 : insufficient number of arguments
# -2 : row or column out of range
# -3 : long string truncated to 255 chars
#
sub write_url {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
# Check the number of args
return -1 if @_ < 3;
# Add start row and col to arg list
return $self->write_url_range($_[0], $_[1], @_);
}
###############################################################################
#
# write_url_range($row1, $col1, $row2, $col2, $url, $string, $format)
#
# This is the more general form of write_url(). It allows a hyperlink to be
# written to a range of cells. This function also decides the type of hyperlink
# to be written. These are either, Web (http, ftp, mailto), Internal
# (Sheet1!A1) or external ('c:\temp\foo.xls#Sheet1!A1').
#
# See also write_url() above for a general description and return values.
#
sub write_url_range {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
# Check the number of args
return -1 if @_ < 5;
# Reverse the order of $string and $format if necessary. We work on a copy
# in order to protect the callers args. We don't use "local @_" in case of
# perl50005 threads.
#
my @args = @_;
($args[5], $args[6]) = ($args[6], $args[5]) if ref $args[5];
my $url = $args[4];
# Check for internal/external sheet links or default to web link
return $self->_write_url_internal(@args) if $url =~ m[^internal:];
return $self->_write_url_external(@args) if $url =~ m[^external:];
return $self->_write_url_web(@args);
}
###############################################################################
#
# _write_url_web($row1, $col1, $row2, $col2, $url, $string, $format)
#
# Used to write http, ftp and mailto hyperlinks.
# The link type ($options) is 0x03 is the same as absolute dir ref without
# sheet. However it is differentiated by the $unknown2 data stream.
#
# See also write_url() above for a general description and return values.
#
sub _write_url_web {
my $self = shift;
my $record = 0x01B8; # Record identifier
my $length = 0x00000; # Bytes to follow
my $row1 = $_[0]; # Start row
my $col1 = $_[1]; # Start column
my $row2 = $_[2]; # End row
my $col2 = $_[3]; # End column
my $url = $_[4]; # URL string
my $str = $_[5]; # Alternative label
my $xf = $_[6] || $self->{_url_format};# The cell format
# Write the visible label but protect against url recursion in write().
$str = $url unless defined $str;
$self->{_writing_url} = 1;
my $error = $self->write($row1, $col1, $str, $xf);
$self->{_writing_url} = 0;
return $error if $error == -2;
# Pack the undocumented parts of the hyperlink stream
my $unknown1 = pack("H*", "D0C9EA79F9BACE118C8200AA004BA90B02000000");
my $unknown2 = pack("H*", "E0C9EA79F9BACE118C8200AA004BA90B");
# Pack the option flags
my $options = pack("V", 0x03);
# URL encoding.
my $encoding = 0;
# Convert an Utf8 URL type and to a null terminated wchar string.
if ($] >= 5.008) {
require Encode;
if (Encode::is_utf8($url)) {
$url = Encode::encode("UTF-16LE", $url);
$url .= "\0\0"; # URL is null terminated.
$encoding = 1;
}
}
# Convert an Ascii URL type and to a null terminated wchar string.
if ($encoding == 0) {
$url .= "\0";
$url = pack 'v*', unpack 'c*', $url;
}
# Pack the length of the URL
my $url_len = pack("V", length($url));
# Calculate the data length
$length = 0x34 + length($url);
# Pack the header data
my $header = pack("vv", $record, $length);
my $data = pack("vvvv", $row1, $row2, $col1, $col2);
# Write the packed data
$self->_append( $header,
$data,
$unknown1,
$options,
$unknown2,
$url_len,
$url);
return $error;
}
###############################################################################
#
# _write_url_internal($row1, $col1, $row2, $col2, $url, $string, $format)
#
# Used to write internal reference hyperlinks such as "Sheet1!A1".
#
# See also write_url() above for a general description and return values.
#
sub _write_url_internal {
my $self = shift;
my $record = 0x01B8; # Record identifier
my $length = 0x00000; # Bytes to follow
my $row1 = $_[0]; # Start row
my $col1 = $_[1]; # Start column
my $row2 = $_[2]; # End row
my $col2 = $_[3]; # End column
my $url = $_[4]; # URL string
my $str = $_[5]; # Alternative label
my $xf = $_[6] || $self->{_url_format};# The cell format
# Strip URL type
$url =~ s[^internal:][];
# Write the visible label but protect against url recursion in write().
$str = $url unless defined $str;
$self->{_writing_url} = 1;
my $error = $self->write($row1, $col1, $str, $xf);
$self->{_writing_url} = 0;
return $error if $error == -2;
# Pack the undocumented parts of the hyperlink stream
my $unknown1 = pack("H*", "D0C9EA79F9BACE118C8200AA004BA90B02000000");
# Pack the option flags
my $options = pack("V", 0x08);
# URL encoding.
my $encoding = 0;
# Convert an Utf8 URL type and to a null terminated wchar string.
if ($] >= 5.008) {
require Encode;
if (Encode::is_utf8($url)) {
# Quote sheet name if not already, i.e., Sheet!A1 to 'Sheet!A1'.
$url =~ s/^(.+)!/'$1'!/ if not $url =~ /^'/;
$url = Encode::encode("UTF-16LE", $url);
$url .= "\0\0"; # URL is null terminated.
$encoding = 1;
}
}
# Convert an Ascii URL type and to a null terminated wchar string.
if ($encoding == 0) {
$url .= "\0";
$url = pack 'v*', unpack 'c*', $url;
}
# Pack the length of the URL as chars (not wchars)
my $url_len = pack("V", int(length($url)/2));
# Calculate the data length
$length = 0x24 + length($url);
# Pack the header data
my $header = pack("vv", $record, $length);
my $data = pack("vvvv", $row1, $row2, $col1, $col2);
# Write the packed data
$self->_append( $header,
$data,
$unknown1,
$options,
$url_len,
$url);
return $error;
}
###############################################################################
#
# _write_url_external($row1, $col1, $row2, $col2, $url, $string, $format)
#
# Write links to external directory names such as 'c:\foo.xls',
# c:\foo.xls#Sheet1!A1', '../../foo.xls'. and '../../foo.xls#Sheet1!A1'.
#
# Note: Excel writes some relative links with the $dir_long string. We ignore
# these cases for the sake of simpler code.
#
# See also write_url() above for a general description and return values.
#
sub _write_url_external {
my $self = shift;
# Network drives are different. We will handle them separately
# MS/Novell network drives and shares start with \\
return $self->_write_url_external_net(@_) if $_[4] =~ m[^external:\\\\];
my $record = 0x01B8; # Record identifier
my $length = 0x00000; # Bytes to follow
my $row1 = $_[0]; # Start row
my $col1 = $_[1]; # Start column
my $row2 = $_[2]; # End row
my $col2 = $_[3]; # End column
my $url = $_[4]; # URL string
my $str = $_[5]; # Alternative label
my $xf = $_[6] || $self->{_url_format};# The cell format
# Strip URL type and change Unix dir separator to Dos style (if needed)
#
$url =~ s[^external:][];
$url =~ s[/][\\]g;
# Write the visible label but protect against url recursion in write().
($str = $url) =~ s[\#][ - ] unless defined $str;
$self->{_writing_url} = 1;
my $error = $self->write($row1, $col1, $str, $xf);
$self->{_writing_url} = 0;
return $error if $error == -2;
# Determine if the link is relative or absolute:
# Absolute if link starts with DOS drive specifier like C:
# Otherwise default to 0x00 for relative link.
#
my $absolute = 0x00;
$absolute = 0x02 if $url =~ m/^[A-Za-z]:/;
# Determine if the link contains a sheet reference and change some of the
# parameters accordingly.
# Split the dir name and sheet name (if it exists)
#
my ($dir_long , $sheet) = split /\#/, $url;
my $link_type = 0x01 | $absolute;
my $sheet_len;
if (defined $sheet) {
$link_type |= 0x08;
$sheet_len = pack("V", length($sheet) + 0x01);
$sheet = join("\0", split('', $sheet));
$sheet .= "\0\0\0";
}
else {
$sheet_len = '';
$sheet = '';
}
# Pack the link type
$link_type = pack("V", $link_type);
# Calculate the up-level dir count e.g. (..\..\..\ == 3)
my $up_count = 0;
$up_count++ while $dir_long =~ s[^\.\.\\][];
$up_count = pack("v", $up_count);
# Store the short dos dir name (null terminated)
my $dir_short = $dir_long . "\0";
# Store the long dir name as a wchar string (non-null terminated)
$dir_long = join("\0", split('', $dir_long));
$dir_long = $dir_long . "\0";
# Pack the lengths of the dir strings
my $dir_short_len = pack("V", length $dir_short );
my $dir_long_len = pack("V", length $dir_long );
my $stream_len = pack("V", length($dir_long) + 0x06);
# Pack the undocumented parts of the hyperlink stream
my $unknown1 =pack("H*",'D0C9EA79F9BACE118C8200AA004BA90B02000000' );
my $unknown2 =pack("H*",'0303000000000000C000000000000046' );
my $unknown3 =pack("H*",'FFFFADDE000000000000000000000000000000000000000');
my $unknown4 =pack("v", 0x03 );
# Pack the main data stream
my $data = pack("vvvv", $row1, $row2, $col1, $col2) .
$unknown1 .
$link_type .
$unknown2 .
$up_count .
$dir_short_len.
$dir_short .
$unknown3 .
$stream_len .
$dir_long_len .
$unknown4 .
$dir_long .
$sheet_len .
$sheet ;
# Pack the header data
$length = length $data;
my $header = pack("vv", $record, $length);
# Write the packed data
$self->_append($header, $data);
return $error;
}
###############################################################################
#
# _write_url_external_net($row1, $col1, $row2, $col2, $url, $string, $format)
#
# Write links to external MS/Novell network drives and shares such as
# '//NETWORK/share/foo.xls' and '//NETWORK/share/foo.xls#Sheet1!A1'.
#
# See also write_url() above for a general description and return values.
#
sub _write_url_external_net {
my $self = shift;
my $record = 0x01B8; # Record identifier
my $length = 0x00000; # Bytes to follow
my $row1 = $_[0]; # Start row
my $col1 = $_[1]; # Start column
my $row2 = $_[2]; # End row
my $col2 = $_[3]; # End column
my $url = $_[4]; # URL string
my $str = $_[5]; # Alternative label
my $xf = $_[6] || $self->{_url_format};# The cell format
# Strip URL type and change Unix dir separator to Dos style (if needed)
#
$url =~ s[^external:][];
$url =~ s[/][\\]g;
# Write the visible label but protect against url recursion in write().
($str = $url) =~ s[\#][ - ] unless defined $str;
$self->{_writing_url} = 1;
my $error = $self->write($row1, $col1, $str, $xf);
$self->{_writing_url} = 0;
return $error if $error == -2;
# Determine if the link contains a sheet reference and change some of the
# parameters accordingly.
# Split the dir name and sheet name (if it exists)
#
my ($dir_long , $sheet) = split /\#/, $url;
my $link_type = 0x0103; # Always absolute
my $sheet_len;
if (defined $sheet) {
$link_type |= 0x08;
$sheet_len = pack("V", length($sheet) + 0x01);
$sheet = join("\0", split('', $sheet));
$sheet .= "\0\0\0";
}
else {
$sheet_len = '';
$sheet = '';
}
# Pack the link type
$link_type = pack("V", $link_type);
# Make the string null terminated
$dir_long = $dir_long . "\0";
# Pack the lengths of the dir string
my $dir_long_len = pack("V", length $dir_long);
# Store the long dir name as a wchar string (non-null terminated)
$dir_long = join("\0", split('', $dir_long));
$dir_long = $dir_long . "\0";
# Pack the undocumented part of the hyperlink stream
my $unknown1 = pack("H*",'D0C9EA79F9BACE118C8200AA004BA90B02000000');
# Pack the main data stream
my $data = pack("vvvv", $row1, $row2, $col1, $col2) .
$unknown1 .
$link_type .
$dir_long_len .
$dir_long .
$sheet_len .
$sheet ;
# Pack the header data
$length = length $data;
my $header = pack("vv", $record, $length);
# Write the packed data
$self->_append($header, $data);
return $error;
}
###############################################################################
#
# write_date_time ($row, $col, $string, $format)
#
# Write a datetime string in ISO8601 "yyyy-mm-ddThh:mm:ss.ss" format as a
# number representing an Excel date. $format is optional.
#
# Returns 0 : normal termination
# -1 : insufficient number of arguments
# -2 : row or column out of range
# -3 : Invalid date_time, written as string
#
sub write_date_time {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
if (@_ < 3) { return -1 } # Check the number of args
my $row = $_[0]; # Zero indexed row
my $col = $_[1]; # Zero indexed column
my $str = $_[2];
# Check that row and col are valid and store max and min values
return -2 if $self->_check_dimensions($row, $col);
my $error = 0;
my $date_time = $self->convert_date_time($str);
if (defined $date_time) {
$error = $self->write_number($row, $col, $date_time, $_[3]);
}
else {
# The date isn't valid so write it as a string.
$self->write_string($row, $col, $str, $_[3]);
$error = -3;
}
return $error;
}
###############################################################################
#
# convert_date_time($date_time_string)
#
# The function takes a date and time in ISO8601 "yyyy-mm-ddThh:mm:ss.ss" format
# and converts it to a decimal number representing a valid Excel date.
#
# Dates and times in Excel are represented by real numbers. The integer part of
# the number stores the number of days since the epoch and the fractional part
# stores the percentage of the day in seconds. The epoch can be either 1900 or
# 1904.
#
# Parameter: Date and time string in one of the following formats:
# yyyy-mm-ddThh:mm:ss.ss # Standard
# yyyy-mm-ddT # Date only
# Thh:mm:ss.ss # Time only
#
# Returns:
# A decimal number representing a valid Excel date, or
# undef if the date is invalid.
#
sub convert_date_time {
my $self = shift;
my $date_time = $_[0];
my $days = 0; # Number of days since epoch
my $seconds = 0; # Time expressed as fraction of 24h hours in seconds
my ($year, $month, $day);
my ($hour, $min, $sec);
# Strip leading and trailing whitespace.
$date_time =~ s/^\s+//;
$date_time =~ s/\s+$//;
# Check for invalid date char.
return if $date_time =~ /[^0-9T:\-\.Z]/;
# Check for "T" after date or before time.
return unless $date_time =~ /\dT|T\d/;
# Strip trailing Z in ISO8601 date.
$date_time =~ s/Z$//;
# Split into date and time.
my ($date, $time) = split /T/, $date_time;
# We allow the time portion of the input DateTime to be optional.
if ($time ne '') {
# Match hh:mm:ss.sss+ where the seconds are optional
if ($time =~ /^(\d\d):(\d\d)(:(\d\d(\.\d+)?))?/) {
$hour = $1;
$min = $2;
$sec = $4 || 0;
}
else {
return undef; # Not a valid time format.
}
# Some boundary checks
return if $hour >= 24;
return if $min >= 60;
return if $sec >= 60;
# Excel expresses seconds as a fraction of the number in 24 hours.
$seconds = ($hour *60*60 + $min *60 + $sec) / (24 *60 *60);
}
# We allow the date portion of the input DateTime to be optional.
return $seconds if $date eq '';
# Match date as yyyy-mm-dd.
if ($date =~ /^(\d\d\d\d)-(\d\d)-(\d\d)$/) {
$year = $1;
$month = $2;
$day = $3;
}
else {
return undef; # Not a valid date format.
}
# Set the epoch as 1900 or 1904. Defaults to 1900.
my $date_1904 = $self->{_1904};
# Special cases for Excel.
if (not $date_1904) {
return $seconds if $date eq '1899-12-31'; # Excel 1900 epoch
return $seconds if $date eq '1900-01-00'; # Excel 1900 epoch
return 60 + $seconds if $date eq '1900-02-29'; # Excel false leapday
}
# We calculate the date by calculating the number of days since the epoch
# and adjust for the number of leap days. We calculate the number of leap
# days by normalising the year in relation to the epoch. Thus the year 2000
# becomes 100 for 4 and 100 year leapdays and 400 for 400 year leapdays.
#
my $epoch = $date_1904 ? 1904 : 1900;
my $offset = $date_1904 ? 4 : 0;
my $norm = 300;
my $range = $year -$epoch;
# Set month days and check for leap year.
my @mdays = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
my $leap = 0;
$leap = 1 if $year % 4 == 0 and $year % 100 or $year % 400 == 0;
$mdays[1] = 29 if $leap;
# Some boundary checks
return if $year < $epoch or $year > 9999;
return if $month < 1 or $month > 12;
return if $day < 1 or $day > $mdays[$month -1];
# Accumulate the number of days since the epoch.
$days = $day; # Add days for current month
$days += $mdays[$_] for 0 .. $month -2; # Add days for past months
$days += $range *365; # Add days for past years
$days += int(($range) / 4); # Add leapdays
$days -= int(($range +$offset) /100); # Subtract 100 year leapdays
$days += int(($range +$offset +$norm)/400); # Add 400 year leapdays
$days -= $leap; # Already counted above
# Adjust for Excel erroneously treating 1900 as a leap year.
$days++ if $date_1904 == 0 and $days > 59;
return $days + $seconds;
}
###############################################################################
#
# set_row($row, $height, $XF, $hidden, $level)
#
# This method is used to set the height and XF format for a row.
# Writes the BIFF record ROW.
#
sub set_row {
my $self = shift;
my $record = 0x0208; # Record identifier
my $length = 0x0010; # Number of bytes to follow
my $row = $_[0]; # Row Number
my $colMic = 0x0000; # First defined column
my $colMac = 0x0000; # Last defined column
my $miyRw; # Row height
my $irwMac = 0x0000; # Used by Excel to optimise loading
my $reserved = 0x0000; # Reserved
my $grbit = 0x0000; # Option flags
my $ixfe; # XF index
my $height = $_[1]; # Row height
my $format = $_[2]; # Format object
my $hidden = $_[3] || 0; # Hidden flag
my $level = $_[4] || 0; # Outline level
my $collapsed = $_[5] || 0; # Collapsed row
return unless defined $row; # Ensure at least $row is specified.
# Check that row and col are valid and store max and min values
return -2 if $self->_check_dimensions($row, 0, 0, 1);
# Check for a format object
if (ref $format) {
$ixfe = $format->get_xf_index();
}
else {
$ixfe = 0x0F;
}
# Set the row height in units of 1/20 of a point. Note, some heights may
# not be obtained exactly due to rounding in Excel.
#
if (defined $height) {
$miyRw = $height *20;
}
else {
$miyRw = 0xff; # The default row height
$height = 0;
}
# Set the limits for the outline levels (0 <= x <= 7).
$level = 0 if $level < 0;
$level = 7 if $level > 7;
$self->{_outline_row_level} = $level if $level >$self->{_outline_row_level};
# Set the options flags.
# 0x10: The fCollapsed flag indicates that the row contains the "+"
# when an outline group is collapsed.
# 0x20: The fDyZero height flag indicates a collapsed or hidden row.
# 0x40: The fUnsynced flag is used to show that the font and row heights
# are not compatible. This is usually the case for WriteExcel.
# 0x80: The fGhostDirty flag indicates that the row has been formatted.
#
$grbit |= $level;
$grbit |= 0x0010 if $collapsed;
$grbit |= 0x0020 if $hidden;
$grbit |= 0x0040;
$grbit |= 0x0080 if $format;
$grbit |= 0x0100;
my $header = pack("vv", $record, $length);
my $data = pack("vvvvvvvv", $row, $colMic, $colMac, $miyRw,
$irwMac,$reserved, $grbit, $ixfe);
# Store the data or write immediately depending on the compatibility mode.
if ($self->{_compatibility}) {
$self->{_row_data}->{$_[0]} = $header . $data;
}
else {
$self->_append($header, $data);
}
# Store the row sizes for use when calculating image vertices.
# Also store the row formats.
$self->{_row_sizes}->{$_[0]} = $height;
$self->{_row_formats}->{$_[0]} = $format if defined $format;
}
###############################################################################
#
# _write_row_default()
#
# Write a default row record, in compatibility mode, for rows that don't have
# user specified values..
#
sub _write_row_default {
my $self = shift;
my $record = 0x0208; # Record identifier
my $length = 0x0010; # Number of bytes to follow
my $row = $_[0]; # Row Number
my $colMic = $_[1]; # First defined column
my $colMac = $_[2]; # Last defined column
my $miyRw = 0xFF; # Row height
my $irwMac = 0x0000; # Used by Excel to optimise loading
my $reserved = 0x0000; # Reserved
my $grbit = 0x0100; # Option flags
my $ixfe = 0x0F; # XF index
my $header = pack("vv", $record, $length);
my $data = pack("vvvvvvvv", $row, $colMic, $colMac, $miyRw,
$irwMac,$reserved, $grbit, $ixfe);
$self->_append($header, $data);
}
###############################################################################
#
# _check_dimensions($row, $col, $ignore_row, $ignore_col)
#
# Check that $row and $col are valid and store max and min values for use in
# DIMENSIONS record. See, _store_dimensions().
#
# The $ignore_row/$ignore_col flags is used to indicate that we wish to
# perform the dimension check without storing the value.
#
# The ignore flags are use by set_row() and data_validate.
#
sub _check_dimensions {
my $self = shift;
my $row = $_[0];
my $col = $_[1];
my $ignore_row = $_[2];
my $ignore_col = $_[3];
return -2 if not defined $row;
return -2 if $row >= $self->{_xls_rowmax};
return -2 if not defined $col;
return -2 if $col >= $self->{_xls_colmax};
if (not $ignore_row) {
if (not defined $self->{_dim_rowmin} or $row < $self->{_dim_rowmin}) {
$self->{_dim_rowmin} = $row;
}
if (not defined $self->{_dim_rowmax} or $row > $self->{_dim_rowmax}) {
$self->{_dim_rowmax} = $row;
}
}
if (not $ignore_col) {
if (not defined $self->{_dim_colmin} or $col < $self->{_dim_colmin}) {
$self->{_dim_colmin} = $col;
}
if (not defined $self->{_dim_colmax} or $col > $self->{_dim_colmax}) {
$self->{_dim_colmax} = $col;
}
}
return 0;
}
###############################################################################
#
# _store_dimensions()
#
# Writes Excel DIMENSIONS to define the area in which there is cell data.
#
# Notes:
# Excel stores the max row/col as row/col +1.
# Max and min values of 0 are used to indicate that no cell data.
# We set the undef member data to 0 since it is used by _store_table().
# Inserting images or charts doesn't change the DIMENSION data.
#
sub _store_dimensions {
my $self = shift;
my $record = 0x0200; # Record identifier
my $length = 0x000E; # Number of bytes to follow
my $row_min; # First row
my $row_max; # Last row plus 1
my $col_min; # First column
my $col_max; # Last column plus 1
my $reserved = 0x0000; # Reserved by Excel
if (defined $self->{_dim_rowmin}) {$row_min = $self->{_dim_rowmin} }
else {$row_min = 0 }
if (defined $self->{_dim_rowmax}) {$row_max = $self->{_dim_rowmax} + 1}
else {$row_max = 0 }
if (defined $self->{_dim_colmin}) {$col_min = $self->{_dim_colmin} }
else {$col_min = 0 }
if (defined $self->{_dim_colmax}) {$col_max = $self->{_dim_colmax} + 1}
else {$col_max = 0 }
# Set member data to the new max/min value for use by _store_table().
$self->{_dim_rowmin} = $row_min;
$self->{_dim_rowmax} = $row_max;
$self->{_dim_colmin} = $col_min;
$self->{_dim_colmax} = $col_max;
my $header = pack("vv", $record, $length);
my $data = pack("VVvvv", $row_min, $row_max,
$col_min, $col_max, $reserved);
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_window2()
#
# Write BIFF record Window2.
#
sub _store_window2 {
use integer; # Avoid << shift bug in Perl 5.6.0 on HP-UX
my $self = shift;
my $record = 0x023E; # Record identifier
my $length = 0x0012; # Number of bytes to follow
my $grbit = 0x00B6; # Option flags
my $rwTop = $self->{_first_row}; # Top visible row
my $colLeft = $self->{_first_col}; # Leftmost visible column
my $rgbHdr = 0x00000040; # Row/col heading, grid color
my $wScaleSLV = 0x0000; # Zoom in page break preview
my $wScaleNormal = 0x0000; # Zoom in normal view
my $reserved = 0x00000000;
# The options flags that comprise $grbit
my $fDspFmla = $self->{_display_formulas}; # 0 - bit
my $fDspGrid = $self->{_screen_gridlines}; # 1
my $fDspRwCol = $self->{_display_headers}; # 2
my $fFrozen = $self->{_frozen}; # 3
my $fDspZeros = $self->{_display_zeros}; # 4
my $fDefaultHdr = 1; # 5
my $fArabic = $self->{_display_arabic}; # 6
my $fDspGuts = $self->{_outline_on}; # 7
my $fFrozenNoSplit = $self->{_frozen_no_split}; # 0 - bit
my $fSelected = $self->{_selected}; # 1
my $fPaged = $self->{_active}; # 2
my $fBreakPreview = 0; # 3
$grbit = $fDspFmla;
$grbit |= $fDspGrid << 1;
$grbit |= $fDspRwCol << 2;
$grbit |= $fFrozen << 3;
$grbit |= $fDspZeros << 4;
$grbit |= $fDefaultHdr << 5;
$grbit |= $fArabic << 6;
$grbit |= $fDspGuts << 7;
$grbit |= $fFrozenNoSplit << 8;
$grbit |= $fSelected << 9;
$grbit |= $fPaged << 10;
$grbit |= $fBreakPreview << 11;
my $header = pack("vv", $record, $length);
my $data = pack("vvvVvvV", $grbit, $rwTop, $colLeft, $rgbHdr,
$wScaleSLV, $wScaleNormal, $reserved );
$self->_append($header, $data);
}
###############################################################################
#
# _store_page_view()
#
# Set page view mode. Only applicable to Mac Excel.
#
sub _store_page_view {
my $self = shift;
return unless $self->{_page_view};
my $data = pack "H*", 'C8081100C808000000000040000000000900000000';
$self->_append($data);
}
###############################################################################
#
# _store_tab_color()
#
# Write the Tab Color BIFF record.
#
sub _store_tab_color {
my $self = shift;
my $color = $self->{_tab_color};
return unless $color;
my $record = 0x0862; # Record identifier
my $length = 0x0014; # Number of bytes to follow
my $zero = 0x0000;
my $unknown = 0x0014;
my $header = pack("vv", $record, $length);
my $data = pack("vvvvvvvvvv", $record, $zero, $zero, $zero, $zero,
$zero, $unknown, $zero, $color, $zero);
$self->_append($header, $data);
}
###############################################################################
#
# _store_defrow()
#
# Write BIFF record DEFROWHEIGHT.
#
sub _store_defrow {
my $self = shift;
my $record = 0x0225; # Record identifier
my $length = 0x0004; # Number of bytes to follow
my $grbit = 0x0000; # Options.
my $height = 0x00FF; # Default row height
my $header = pack("vv", $record, $length);
my $data = pack("vv", $grbit, $height);
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_defcol()
#
# Write BIFF record DEFCOLWIDTH.
#
sub _store_defcol {
my $self = shift;
my $record = 0x0055; # Record identifier
my $length = 0x0002; # Number of bytes to follow
my $colwidth = 0x0008; # Default column width
my $header = pack("vv", $record, $length);
my $data = pack("v", $colwidth);
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_colinfo($firstcol, $lastcol, $width, $format, $hidden)
#
# Write BIFF record COLINFO to define column widths
#
# Note: The SDK says the record length is 0x0B but Excel writes a 0x0C
# length record.
#
sub _store_colinfo {
my $self = shift;
my $record = 0x007D; # Record identifier
my $length = 0x000B; # Number of bytes to follow
my $colFirst = $_[0] || 0; # First formatted column
my $colLast = $_[1] || 0; # Last formatted column
my $width = $_[2] || 8.43; # Col width in user units, 8.43 is default
my $coldx; # Col width in internal units
my $pixels; # Col width in pixels
# Excel rounds the column width to the nearest pixel. Therefore we first
# convert to pixels and then to the internal units. The pixel to users-units
# relationship is different for values less than 1.
#
if ($width < 1) {
$pixels = int($width *12);
}
else {
$pixels = int($width *7 ) +5;
}
$coldx = int($pixels *256/7);
my $ixfe; # XF index
my $grbit = 0x0000; # Option flags
my $reserved = 0x00; # Reserved
my $format = $_[3]; # Format object
my $hidden = $_[4] || 0; # Hidden flag
my $level = $_[5] || 0; # Outline level
my $collapsed = $_[6] || 0; # Outline level
# Check for a format object
if (ref $format) {
$ixfe = $format->get_xf_index();
}
else {
$ixfe = 0x0F;
}
# Set the limits for the outline levels (0 <= x <= 7).
$level = 0 if $level < 0;
$level = 7 if $level > 7;
# Set the options flags. (See set_row() for more details).
$grbit |= 0x0001 if $hidden;
$grbit |= $level << 8;
$grbit |= 0x1000 if $collapsed;
my $header = pack("vv", $record, $length);
my $data = pack("vvvvvC", $colFirst, $colLast, $coldx,
$ixfe, $grbit, $reserved);
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_filtermode()
#
# Write BIFF record FILTERMODE to indicate that the worksheet contains
# AUTOFILTER record, ie. autofilters with a filter set.
#
sub _store_filtermode {
my $self = shift;
my $record = 0x009B; # Record identifier
my $length = 0x0000; # Number of bytes to follow
# Only write the record if the worksheet contains a filtered autofilter.
return unless $self->{_filter_on};
my $header = pack("vv", $record, $length);
$self->_prepend($header);
}
###############################################################################
#
# _store_autofilterinfo()
#
# Write BIFF record AUTOFILTERINFO.
#
sub _store_autofilterinfo {
my $self = shift;
my $record = 0x009D; # Record identifier
my $length = 0x0002; # Number of bytes to follow
my $num_filters = $self->{_filter_count};
# Only write the record if the worksheet contains an autofilter.
return unless $self->{_filter_count};
my $header = pack("vv", $record, $length);
my $data = pack("v", $num_filters);
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_selection($first_row, $first_col, $last_row, $last_col)
#
# Write BIFF record SELECTION.
#
sub _store_selection {
my $self = shift;
my $record = 0x001D; # Record identifier
my $length = 0x000F; # Number of bytes to follow
my $pnn = $self->{_active_pane}; # Pane position
my $rwAct = $_[0]; # Active row
my $colAct = $_[1]; # Active column
my $irefAct = 0; # Active cell ref
my $cref = 1; # Number of refs
my $rwFirst = $_[0]; # First row in reference
my $colFirst = $_[1]; # First col in reference
my $rwLast = $_[2] || $rwFirst; # Last row in reference
my $colLast = $_[3] || $colFirst; # Last col in reference
# Swap last row/col for first row/col as necessary
if ($rwFirst > $rwLast) {
($rwFirst, $rwLast) = ($rwLast, $rwFirst);
}
if ($colFirst > $colLast) {
($colFirst, $colLast) = ($colLast, $colFirst);
}
my $header = pack("vv", $record, $length);
my $data = pack("CvvvvvvCC", $pnn, $rwAct, $colAct,
$irefAct, $cref,
$rwFirst, $rwLast,
$colFirst, $colLast);
$self->_append($header, $data);
}
###############################################################################
#
# _store_externcount($count)
#
# Write BIFF record EXTERNCOUNT to indicate the number of external sheet
# references in a worksheet.
#
# Excel only stores references to external sheets that are used in formulas.
# For simplicity we store references to all the sheets in the workbook
# regardless of whether they are used or not. This reduces the overall
# complexity and eliminates the need for a two way dialogue between the formula
# parser the worksheet objects.
#
sub _store_externcount {
my $self = shift;
my $record = 0x0016; # Record identifier
my $length = 0x0002; # Number of bytes to follow
my $cxals = $_[0]; # Number of external references
my $header = pack("vv", $record, $length);
my $data = pack("v", $cxals);
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_externsheet($sheetname)
#
#
# Writes the Excel BIFF EXTERNSHEET record. These references are used by
# formulas. A formula references a sheet name via an index. Since we store a
# reference to all of the external worksheets the EXTERNSHEET index is the same
# as the worksheet index.
#
sub _store_externsheet {
my $self = shift;
my $record = 0x0017; # Record identifier
my $length; # Number of bytes to follow
my $sheetname = $_[0]; # Worksheet name
my $cch; # Length of sheet name
my $rgch; # Filename encoding
# References to the current sheet are encoded differently to references to
# external sheets.
#
if ($self->{_name} eq $sheetname) {
$sheetname = '';
$length = 0x02; # The following 2 bytes
$cch = 1; # The following byte
$rgch = 0x02; # Self reference
}
else {
$length = 0x02 + length($_[0]);
$cch = length($sheetname);
$rgch = 0x03; # Reference to a sheet in the current workbook
}
my $header = pack("vv", $record, $length);
my $data = pack("CC", $cch, $rgch);
$self->_prepend($header, $data, $sheetname);
}
###############################################################################
#
# _store_panes()
#
#
# Writes the Excel BIFF PANE record.
# The panes can either be frozen or thawed (unfrozen).
# Frozen panes are specified in terms of a integer number of rows and columns.
# Thawed panes are specified in terms of Excel's units for rows and columns.
#
sub _store_panes {
my $self = shift;
my $record = 0x0041; # Record identifier
my $length = 0x000A; # Number of bytes to follow
my $y = $_[0] || 0; # Vertical split position
my $x = $_[1] || 0; # Horizontal split position
my $rwTop = $_[2]; # Top row visible
my $colLeft = $_[3]; # Leftmost column visible
my $no_split = $_[4]; # No used here.
my $pnnAct = $_[5]; # Active pane
# Code specific to frozen or thawed panes.
if ($self->{_frozen}) {
# Set default values for $rwTop and $colLeft
$rwTop = $y unless defined $rwTop;
$colLeft = $x unless defined $colLeft;
}
else {
# Set default values for $rwTop and $colLeft
$rwTop = 0 unless defined $rwTop;
$colLeft = 0 unless defined $colLeft;
# Convert Excel's row and column units to the internal units.
# The default row height is 12.75
# The default column width is 8.43
# The following slope and intersection values were interpolated.
#
$y = 20*$y + 255;
$x = 113.879*$x + 390;
}
# Determine which pane should be active. There is also the undocumented
# option to override this should it be necessary: may be removed later.
#
if (not defined $pnnAct) {
$pnnAct = 0 if ($x != 0 && $y != 0); # Bottom right
$pnnAct = 1 if ($x != 0 && $y == 0); # Top right
$pnnAct = 2 if ($x == 0 && $y != 0); # Bottom left
$pnnAct = 3 if ($x == 0 && $y == 0); # Top left
}
$self->{_active_pane} = $pnnAct; # Used in _store_selection
my $header = pack("vv", $record, $length);
my $data = pack("vvvvv", $x, $y, $rwTop, $colLeft, $pnnAct);
$self->_append($header, $data);
}
###############################################################################
#
# _store_setup()
#
# Store the page setup SETUP BIFF record.
#
sub _store_setup {
use integer; # Avoid << shift bug in Perl 5.6.0 on HP-UX
my $self = shift;
my $record = 0x00A1; # Record identifier
my $length = 0x0022; # Number of bytes to follow
my $iPaperSize = $self->{_paper_size}; # Paper size
my $iScale = $self->{_print_scale}; # Print scaling factor
my $iPageStart = $self->{_page_start}; # Starting page number
my $iFitWidth = $self->{_fit_width}; # Fit to number of pages wide
my $iFitHeight = $self->{_fit_height}; # Fit to number of pages high
my $grbit = 0x00; # Option flags
my $iRes = 0x0258; # Print resolution
my $iVRes = 0x0258; # Vertical print resolution
my $numHdr = $self->{_margin_header}; # Header Margin
my $numFtr = $self->{_margin_footer}; # Footer Margin
my $iCopies = 0x01; # Number of copies
my $fLeftToRight = $self->{_page_order}; # Print over then down
my $fLandscape = $self->{_orientation}; # Page orientation
my $fNoPls = 0x0; # Setup not read from printer
my $fNoColor = $self->{_black_white}; # Print black and white
my $fDraft = $self->{_draft_quality}; # Print draft quality
my $fNotes = $self->{_print_comments};# Print notes
my $fNoOrient = 0x0; # Orientation not set
my $fUsePage = $self->{_custom_start}; # Use custom starting page
$grbit = $fLeftToRight;
$grbit |= $fLandscape << 1;
$grbit |= $fNoPls << 2;
$grbit |= $fNoColor << 3;
$grbit |= $fDraft << 4;
$grbit |= $fNotes << 5;
$grbit |= $fNoOrient << 6;
$grbit |= $fUsePage << 7;
$numHdr = pack("d", $numHdr);
$numFtr = pack("d", $numFtr);
if ($self->{_byte_order}) {
$numHdr = reverse $numHdr;
$numFtr = reverse $numFtr;
}
my $header = pack("vv", $record, $length);
my $data1 = pack("vvvvvvvv", $iPaperSize,
$iScale,
$iPageStart,
$iFitWidth,
$iFitHeight,
$grbit,
$iRes,
$iVRes);
my $data2 = $numHdr .$numFtr;
my $data3 = pack("v", $iCopies);
$self->_prepend($header, $data1, $data2, $data3);
}
###############################################################################
#
# _store_header()
#
# Store the header caption BIFF record.
#
sub _store_header {
my $self = shift;
my $record = 0x0014; # Record identifier
my $length; # Bytes to follow
my $str = $self->{_header}; # header string
my $cch = length($str); # Length of header string
my $encoding = $self->{_header_encoding}; # Character encoding
# Character length is num of chars not num of bytes
$cch /= 2 if $encoding;
# Change the UTF-16 name from BE to LE
$str = pack 'n*', unpack 'v*', $str if $encoding;
$length = 3 + length($str);
my $header = pack("vv", $record, $length);
my $data = pack("vC", $cch, $encoding);
$self->_prepend($header, $data, $str);
}
###############################################################################
#
# _store_footer()
#
# Store the footer caption BIFF record.
#
sub _store_footer {
my $self = shift;
my $record = 0x0015; # Record identifier
my $length; # Bytes to follow
my $str = $self->{_footer}; # footer string
my $cch = length($str); # Length of footer string
my $encoding = $self->{_footer_encoding}; # Character encoding
# Character length is num of chars not num of bytes
$cch /= 2 if $encoding;
# Change the UTF-16 name from BE to LE
$str = pack 'n*', unpack 'v*', $str if $encoding;
$length = 3 + length($str);
my $header = pack("vv", $record, $length);
my $data = pack("vC", $cch, $encoding);
$self->_prepend($header, $data, $str);
}
###############################################################################
#
# _store_hcenter()
#
# Store the horizontal centering HCENTER BIFF record.
#
sub _store_hcenter {
my $self = shift;
my $record = 0x0083; # Record identifier
my $length = 0x0002; # Bytes to follow
my $fHCenter = $self->{_hcenter}; # Horizontal centering
my $header = pack("vv", $record, $length);
my $data = pack("v", $fHCenter);
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_vcenter()
#
# Store the vertical centering VCENTER BIFF record.
#
sub _store_vcenter {
my $self = shift;
my $record = 0x0084; # Record identifier
my $length = 0x0002; # Bytes to follow
my $fVCenter = $self->{_vcenter}; # Horizontal centering
my $header = pack("vv", $record, $length);
my $data = pack("v", $fVCenter);
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_margin_left()
#
# Store the LEFTMARGIN BIFF record.
#
sub _store_margin_left {
my $self = shift;
my $record = 0x0026; # Record identifier
my $length = 0x0008; # Bytes to follow
my $margin = $self->{_margin_left}; # Margin in inches
my $header = pack("vv", $record, $length);
my $data = pack("d", $margin);
if ($self->{_byte_order}) { $data = reverse $data }
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_margin_right()
#
# Store the RIGHTMARGIN BIFF record.
#
sub _store_margin_right {
my $self = shift;
my $record = 0x0027; # Record identifier
my $length = 0x0008; # Bytes to follow
my $margin = $self->{_margin_right}; # Margin in inches
my $header = pack("vv", $record, $length);
my $data = pack("d", $margin);
if ($self->{_byte_order}) { $data = reverse $data }
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_margin_top()
#
# Store the TOPMARGIN BIFF record.
#
sub _store_margin_top {
my $self = shift;
my $record = 0x0028; # Record identifier
my $length = 0x0008; # Bytes to follow
my $margin = $self->{_margin_top}; # Margin in inches
my $header = pack("vv", $record, $length);
my $data = pack("d", $margin);
if ($self->{_byte_order}) { $data = reverse $data }
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_margin_bottom()
#
# Store the BOTTOMMARGIN BIFF record.
#
sub _store_margin_bottom {
my $self = shift;
my $record = 0x0029; # Record identifier
my $length = 0x0008; # Bytes to follow
my $margin = $self->{_margin_bottom}; # Margin in inches
my $header = pack("vv", $record, $length);
my $data = pack("d", $margin);
if ($self->{_byte_order}) { $data = reverse $data }
$self->_prepend($header, $data);
}
###############################################################################
#
# merge_cells($first_row, $first_col, $last_row, $last_col)
#
# This is an Excel97/2000 method. It is required to perform more complicated
# merging than the normal align merge in Format.pm
#
sub merge_cells {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
my $record = 0x00E5; # Record identifier
my $length = 0x000A; # Bytes to follow
my $cref = 1; # Number of refs
my $rwFirst = $_[0]; # First row in reference
my $colFirst = $_[1]; # First col in reference
my $rwLast = $_[2] || $rwFirst; # Last row in reference
my $colLast = $_[3] || $colFirst; # Last col in reference
# Excel doesn't allow a single cell to be merged
return if $rwFirst == $rwLast and $colFirst == $colLast;
# Swap last row/col with first row/col as necessary
($rwFirst, $rwLast ) = ($rwLast, $rwFirst ) if $rwFirst > $rwLast;
($colFirst, $colLast) = ($colLast, $colFirst) if $colFirst > $colLast;
my $header = pack("vv", $record, $length);
my $data = pack("vvvvv", $cref,
$rwFirst, $rwLast,
$colFirst, $colLast);
$self->_append($header, $data);
}
###############################################################################
#
# merge_range($row1, $col1, $row2, $col2, $string, $format, $encoding)
#
# This is a wrapper to ensure correct use of the merge_cells method, i.e., write
# the first cell of the range, write the formatted blank cells in the range and
# then call the merge_cells record. Failing to do the steps in this order will
# cause Excel 97 to crash.
#
sub merge_range {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
croak "Incorrect number of arguments" if @_ != 6 and @_ != 7;
croak "Format argument is not a format object" unless ref $_[5];
my $rwFirst = $_[0];
my $colFirst = $_[1];
my $rwLast = $_[2];
my $colLast = $_[3];
my $string = $_[4];
my $format = $_[5];
my $encoding = $_[6] ? 1 : 0;
# Temp code to prevent merged formats in non-merged cells.
my $error = "Error: refer to merge_range() in the documentation. " .
"Can't use previously non-merged format in merged cells";
croak $error if $format->{_used_merge} == -1;
$format->{_used_merge} = 0; # Until the end of this function.
# Set the merge_range property of the format object. For BIFF8+.
$format->set_merge_range();
# Excel doesn't allow a single cell to be merged
croak "Can't merge single cell" if $rwFirst == $rwLast and
$colFirst == $colLast;
# Swap last row/col with first row/col as necessary
($rwFirst, $rwLast ) = ($rwLast, $rwFirst ) if $rwFirst > $rwLast;
($colFirst, $colLast) = ($colLast, $colFirst) if $colFirst > $colLast;
# Write the first cell
if ($encoding) {
$self->write_utf16be_string($rwFirst, $colFirst, $string, $format);
}
else {
$self->write ($rwFirst, $colFirst, $string, $format);
}
# Pad out the rest of the area with formatted blank cells.
for my $row ($rwFirst .. $rwLast) {
for my $col ($colFirst .. $colLast) {
next if $row == $rwFirst and $col == $colFirst;
$self->write_blank($row, $col, $format);
}
}
$self->merge_cells($rwFirst, $colFirst, $rwLast, $colLast);
# Temp code to prevent merged formats in non-merged cells.
$format->{_used_merge} = 1;
}
###############################################################################
#
# _store_print_headers()
#
# Write the PRINTHEADERS BIFF record.
#
sub _store_print_headers {
my $self = shift;
my $record = 0x002a; # Record identifier
my $length = 0x0002; # Bytes to follow
my $fPrintRwCol = $self->{_print_headers}; # Boolean flag
my $header = pack("vv", $record, $length);
my $data = pack("v", $fPrintRwCol);
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_print_gridlines()
#
# Write the PRINTGRIDLINES BIFF record. Must be used in conjunction with the
# GRIDSET record.
#
sub _store_print_gridlines {
my $self = shift;
my $record = 0x002b; # Record identifier
my $length = 0x0002; # Bytes to follow
my $fPrintGrid = $self->{_print_gridlines}; # Boolean flag
my $header = pack("vv", $record, $length);
my $data = pack("v", $fPrintGrid);
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_gridset()
#
# Write the GRIDSET BIFF record. Must be used in conjunction with the
# PRINTGRIDLINES record.
#
sub _store_gridset {
my $self = shift;
my $record = 0x0082; # Record identifier
my $length = 0x0002; # Bytes to follow
my $fGridSet = not $self->{_print_gridlines}; # Boolean flag
my $header = pack("vv", $record, $length);
my $data = pack("v", $fGridSet);
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_guts()
#
# Write the GUTS BIFF record. This is used to configure the gutter margins
# where Excel outline symbols are displayed. The visibility of the gutters is
# controlled by a flag in WSBOOL. See also _store_wsbool().
#
# We are all in the gutter but some of us are looking at the stars.
#
sub _store_guts {
my $self = shift;
my $record = 0x0080; # Record identifier
my $length = 0x0008; # Bytes to follow
my $dxRwGut = 0x0000; # Size of row gutter
my $dxColGut = 0x0000; # Size of col gutter
my $row_level = $self->{_outline_row_level};
my $col_level = 0;
# Calculate the maximum column outline level. The equivalent calculation
# for the row outline level is carried out in set_row().
#
foreach my $colinfo (@{$self->{_colinfo}}) {
# Skip cols without outline level info.
next if @{$colinfo} < 6;
$col_level = @{$colinfo}[5] if @{$colinfo}[5] > $col_level;
}
# Set the limits for the outline levels (0 <= x <= 7).
$col_level = 0 if $col_level < 0;
$col_level = 7 if $col_level > 7;
# The displayed level is one greater than the max outline levels
$row_level++ if $row_level > 0;
$col_level++ if $col_level > 0;
my $header = pack("vv", $record, $length);
my $data = pack("vvvv", $dxRwGut, $dxColGut, $row_level, $col_level);
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_wsbool()
#
# Write the WSBOOL BIFF record, mainly for fit-to-page. Used in conjunction
# with the SETUP record.
#
sub _store_wsbool {
my $self = shift;
my $record = 0x0081; # Record identifier
my $length = 0x0002; # Bytes to follow
my $grbit = 0x0000; # Option flags
# Set the option flags
$grbit |= 0x0001; # Auto page breaks visible
$grbit |= 0x0020 if $self->{_outline_style}; # Auto outline styles
$grbit |= 0x0040 if $self->{_outline_below}; # Outline summary below
$grbit |= 0x0080 if $self->{_outline_right}; # Outline summary right
$grbit |= 0x0100 if $self->{_fit_page}; # Page setup fit to page
$grbit |= 0x0400 if $self->{_outline_on}; # Outline symbols displayed
my $header = pack("vv", $record, $length);
my $data = pack("v", $grbit);
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_hbreak()
#
# Write the HORIZONTALPAGEBREAKS BIFF record.
#
sub _store_hbreak {
my $self = shift;
# Return if the user hasn't specified pagebreaks
return unless @{$self->{_hbreaks}};
# Sort and filter array of page breaks
my @breaks = $self->_sort_pagebreaks(@{$self->{_hbreaks}});
my $record = 0x001b; # Record identifier
my $cbrk = scalar @breaks; # Number of page breaks
my $length = 2 + 6*$cbrk; # Bytes to follow
my $header = pack("vv", $record, $length);
my $data = pack("v", $cbrk);
# Append each page break
foreach my $break (@breaks) {
$data .= pack("vvv", $break, 0x0000, 0x00ff);
}
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_vbreak()
#
# Write the VERTICALPAGEBREAKS BIFF record.
#
sub _store_vbreak {
my $self = shift;
# Return if the user hasn't specified pagebreaks
return unless @{$self->{_vbreaks}};
# Sort and filter array of page breaks
my @breaks = $self->_sort_pagebreaks(@{$self->{_vbreaks}});
my $record = 0x001a; # Record identifier
my $cbrk = scalar @breaks; # Number of page breaks
my $length = 2 + 6*$cbrk; # Bytes to follow
my $header = pack("vv", $record, $length);
my $data = pack("v", $cbrk);
# Append each page break
foreach my $break (@breaks) {
$data .= pack("vvv", $break, 0x0000, 0xffff);
}
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_protect()
#
# Set the Biff PROTECT record to indicate that the worksheet is protected.
#
sub _store_protect {
my $self = shift;
# Exit unless sheet protection has been specified
return unless $self->{_protect};
my $record = 0x0012; # Record identifier
my $length = 0x0002; # Bytes to follow
my $fLock = $self->{_protect}; # Worksheet is protected
my $header = pack("vv", $record, $length);
my $data = pack("v", $fLock);
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_obj_protect()
#
# Set the Biff OBJPROTECT record to indicate that objects are protected.
#
sub _store_obj_protect {
my $self = shift;
# Exit unless sheet protection has been specified
return unless $self->{_protect};
my $record = 0x0063; # Record identifier
my $length = 0x0002; # Bytes to follow
my $fLock = $self->{_protect}; # Worksheet is protected
my $header = pack("vv", $record, $length);
my $data = pack("v", $fLock);
$self->_prepend($header, $data);
}
###############################################################################
#
# _store_password()
#
# Write the worksheet PASSWORD record.
#
sub _store_password {
my $self = shift;
# Exit unless sheet protection and password have been specified
return unless $self->{_protect} and defined $self->{_password};
my $record = 0x0013; # Record identifier
my $length = 0x0002; # Bytes to follow
my $wPassword = $self->{_password}; # Encoded password
my $header = pack("vv", $record, $length);
my $data = pack("v", $wPassword);
$self->_prepend($header, $data);
}
#
# Note about compatibility mode.
#
# Excel doesn't require every possible Biff record to be present in a file.
# In particular if the indexing records INDEX, ROW and DBCELL aren't present
# it just ignores the fact and reads the cells anyway. This is also true of
# the EXTSST record. Gnumeric and OOo also take this approach. This allows
# WriteExcel to ignore these records in order to minimise the amount of data
# stored in memory. However, other third party applications that read Excel
# files often expect these records to be present. In "compatibility mode"
# WriteExcel writes these records and tries to be as close to an Excel
# generated file as possible.
#
# This requires additional data to be stored in memory until the file is
# about to be written. This incurs a memory and speed penalty and may not be
# suitable for very large files.
#
###############################################################################
#
# _store_table()
#
# Write cell data stored in the worksheet row/col table.
#
# This is only used when compatibity_mode() is in operation.
#
# This method writes ROW data, then cell data (NUMBER, LABELSST, etc) and then
# DBCELL records in blocks of 32 rows. This is explained in detail (for a
# change) in the Excel SDK and in the OOo Excel file format doc.
#
sub _store_table {
my $self = shift;
return unless $self->{_compatibility};
# Offset from the DBCELL record back to the first ROW of the 32 row block.
my $row_offset = 0;
# Track rows that have cell data or modified by set_row().
my @written_rows;
# Write the ROW records with updated max/min col fields.
#
for my $row (0 .. $self->{_dim_rowmax} -1) {
# Skip unless there is cell data in row or the row has been modified.
next unless $self->{_table}->[$row] or $self->{_row_data}->{$row};
# Store the rows with data.
push @written_rows, $row;
# Increase the row offset by the length of a ROW record;
$row_offset += 20;
# The max/min cols in the ROW records are the same as in DIMENSIONS.
my $col_min = $self->{_dim_colmin};
my $col_max = $self->{_dim_colmax};
# Write a user specified ROW record (modified by set_row()).
if ($self->{_row_data}->{$row}) {
# Rewrite the min and max cols for user defined row record.
my $packed_row = $self->{_row_data}->{$row};
substr $packed_row, 6, 4, pack('vv', $col_min, $col_max);
$self->_append($packed_row);
}
else {
# Write a default Row record if there isn't a user defined ROW.
$self->_write_row_default($row, $col_min, $col_max);
}
# If 32 rows have been written or we are at the last row in the
# worksheet then write the cell data and the DBCELL record.
#
if (@written_rows == 32 or $row == $self->{_dim_rowmax} -1) {
# Offsets to the first cell of each row.
my @cell_offsets;
push @cell_offsets, $row_offset - 20;
# Write the cell data in each row and sum their lengths for the
# cell offsets.
#
for my $row (@written_rows) {
my $cell_offset = 0;
for my $col (@{$self->{_table}->[$row]}) {
next unless $col;
$self->_append($col);
my $length = length $col;
$row_offset += $length;
$cell_offset += $length;
}
push @cell_offsets, $cell_offset;
}
# The last offset isn't required.
pop @cell_offsets;
# Stores the DBCELL offset for use in the INDEX record.
push @{$self->{_db_indices}}, $self->{_datasize};
# Write the DBCELL record.
$self->_store_dbcell($row_offset, @cell_offsets);
# Clear the variable for the next block of rows.
@written_rows = ();
@cell_offsets = ();
$row_offset = 0;
}
}
}
###############################################################################
#
# _store_dbcell()
#
# Store the DBCELL record using the offset calculated in _store_table().
#
# This is only used when compatibity_mode() is in operation.
#
sub _store_dbcell {
my $self = shift;
my $row_offset = shift;
my @cell_offsets = @_;
my $record = 0x00D7; # Record identifier
my $length = 4 + 2 * @cell_offsets; # Bytes to follow
my $header = pack 'vv', $record, $length;
my $data = pack 'V', $row_offset;
$data .= pack 'v', $_ for @cell_offsets;
$self->_append($header, $data);
}
###############################################################################
#
# _store_index()
#
# Store the INDEX record using the DBCELL offsets calculated in _store_table().
#
# This is only used when compatibity_mode() is in operation.
#
sub _store_index {
my $self = shift;
return unless $self->{_compatibility};
my @indices = @{$self->{_db_indices}};
my $reserved = 0x00000000;
my $row_min = $self->{_dim_rowmin};
my $row_max = $self->{_dim_rowmax};
my $record = 0x020B; # Record identifier
my $length = 16 + 4 * @indices; # Bytes to follow
my $header = pack 'vv', $record, $length;
my $data = pack 'VVVV', $reserved,
$row_min,
$row_max,
$reserved;
for my $index (@indices) {
$data .= pack 'V', $index + $self->{_offset} + 20 + $length +4;
}
$self->_prepend($header, $data);
}
###############################################################################
#
# insert_chart($row, $col, $chart, $x, $y, $scale_x, $scale_y)
#
# Insert a chart into a worksheet. The $chart argument should be a Chart
# object or else it is assumed to be a filename of an external binary file.
# The latter is for backwards compatibility.
#
sub insert_chart {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
my $row = $_[0];
my $col = $_[1];
my $chart = $_[2];
my $x_offset = $_[3] || 0;
my $y_offset = $_[4] || 0;
my $scale_x = $_[5] || 1;
my $scale_y = $_[6] || 1;
croak "Insufficient arguments in insert_chart()" unless @_ >= 3;
if ( ref $chart ) {
# Check for a Chart object.
croak "Not a Chart object in insert_chart()"
unless $chart->isa( 'Spreadsheet::WriteExcel::Chart' );
# Check that the chart is an embedded style chart.
croak "Not a embedded style Chart object in insert_chart()"
unless $chart->{_embedded};
}
else {
# Assume an external bin filename.
croak "Couldn't locate $chart in insert_chart(): $!" unless -e $chart;
}
$self->{_charts}->{$row}->{$col} = [
$row,
$col,
$chart,
$x_offset,
$y_offset,
$scale_x,
$scale_y,
];
}
# Older method name for backwards compatibility.
*embed_chart = *insert_chart;
###############################################################################
#
# insert_image($row, $col, $filename, $x, $y, $scale_x, $scale_y)
#
# Insert an image into the worksheet.
#
sub insert_image {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
my $row = $_[0];
my $col = $_[1];
my $image = $_[2];
my $x_offset = $_[3] || 0;
my $y_offset = $_[4] || 0;
my $scale_x = $_[5] || 1;
my $scale_y = $_[6] || 1;
croak "Insufficient arguments in insert_image()" unless @_ >= 3;
croak "Couldn't locate $image: $!" unless -e $image;
$self->{_images}->{$row}->{$col} = [
$row,
$col,
$image,
$x_offset,
$y_offset,
$scale_x,
$scale_y,
];
}
# Older method name for backwards compatibility.
*insert_bitmap = *insert_image;
###############################################################################
#
# _position_object()
#
# Calculate the vertices that define the position of a graphical object within
# the worksheet.
#
# +------------+------------+
# | A | B |
# +-----+------------+------------+
# | |(x1,y1) | |
# | 1 |(A1)._______|______ |
# | | | | |
# | | | | |
# +-----+----| BITMAP |-----+
# | | | | |
# | 2 | |______________. |
# | | | (B2)|
# | | | (x2,y2)|
# +---- +------------+------------+
#
# Example of a bitmap that covers some of the area from cell A1 to cell B2.
#
# Based on the width and height of the bitmap we need to calculate 8 vars:
# $col_start, $row_start, $col_end, $row_end, $x1, $y1, $x2, $y2.
# The width and height of the cells are also variable and have to be taken into
# account.
# The values of $col_start and $row_start are passed in from the calling
# function. The values of $col_end and $row_end are calculated by subtracting
# the width and height of the bitmap from the width and height of the
# underlying cells.
# The vertices are expressed as a percentage of the underlying cell width as
# follows (rhs values are in pixels):
#
# x1 = X / W *1024
# y1 = Y / H *256
# x2 = (X-1) / W *1024
# y2 = (Y-1) / H *256
#
# Where: X is distance from the left side of the underlying cell
# Y is distance from the top of the underlying cell
# W is the width of the cell
# H is the height of the cell
#
# Note: the SDK incorrectly states that the height should be expressed as a
# percentage of 1024.
#
sub _position_object {
my $self = shift;
my $col_start; # Col containing upper left corner of object
my $x1; # Distance to left side of object
my $row_start; # Row containing top left corner of object
my $y1; # Distance to top of object
my $col_end; # Col containing lower right corner of object
my $x2; # Distance to right side of object
my $row_end; # Row containing bottom right corner of object
my $y2; # Distance to bottom of object
my $width; # Width of image frame
my $height; # Height of image frame
($col_start, $row_start, $x1, $y1, $width, $height) = @_;
# Adjust start column for offsets that are greater than the col width
while ($x1 >= $self->_size_col($col_start)) {
$x1 -= $self->_size_col($col_start);
$col_start++;
}
# Adjust start row for offsets that are greater than the row height
while ($y1 >= $self->_size_row($row_start)) {
$y1 -= $self->_size_row($row_start);
$row_start++;
}
# Initialise end cell to the same as the start cell
$col_end = $col_start;
$row_end = $row_start;
$width = $width + $x1;
$height = $height + $y1;
# Subtract the underlying cell widths to find the end cell of the image
while ($width >= $self->_size_col($col_end)) {
$width -= $self->_size_col($col_end);
$col_end++;
}
# Subtract the underlying cell heights to find the end cell of the image
while ($height >= $self->_size_row($row_end)) {
$height -= $self->_size_row($row_end);
$row_end++;
}
# Bitmap isn't allowed to start or finish in a hidden cell, i.e. a cell
# with zero eight or width.
#
return if $self->_size_col($col_start) == 0;
return if $self->_size_col($col_end) == 0;
return if $self->_size_row($row_start) == 0;
return if $self->_size_row($row_end) == 0;
# Convert the pixel values to the percentage value expected by Excel
$x1 = $x1 / $self->_size_col($col_start) * 1024;
$y1 = $y1 / $self->_size_row($row_start) * 256;
$x2 = $width / $self->_size_col($col_end) * 1024;
$y2 = $height / $self->_size_row($row_end) * 256;
# Simulate ceil() without calling POSIX::ceil().
$x1 = int($x1 +0.5);
$y1 = int($y1 +0.5);
$x2 = int($x2 +0.5);
$y2 = int($y2 +0.5);
return( $col_start, $x1,
$row_start, $y1,
$col_end, $x2,
$row_end, $y2
);
}
###############################################################################
#
# _size_col($col)
#
# Convert the width of a cell from user's units to pixels. Excel rounds the
# column width to the nearest pixel. If the width hasn't been set by the user
# we use the default value. If the column is hidden we use a value of zero.
#
sub _size_col {
my $self = shift;
my $col = $_[0];
# Look up the cell value to see if it has been changed
if (exists $self->{_col_sizes}->{$col}) {
my $width = $self->{_col_sizes}->{$col};
# The relationship is different for user units less than 1.
if ($width < 1) {
return int($width *12);
}
else {
return int($width *7 ) +5;
}
}
else {
return 64;
}
}
###############################################################################
#
# _size_row($row)
#
# Convert the height of a cell from user's units to pixels. By interpolation
# the relationship is: y = 4/3x. If the height hasn't been set by the user we
# use the default value. If the row is hidden we use a value of zero. (Not
# possible to hide row yet).
#
sub _size_row {
my $self = shift;
my $row = $_[0];
# Look up the cell value to see if it has been changed
if (exists $self->{_row_sizes}->{$row}) {
if ($self->{_row_sizes}->{$row} == 0) {
return 0;
}
else {
return int (4/3 * $self->{_row_sizes}->{$row});
}
}
else {
return 17;
}
}
###############################################################################
#
# _store_zoom($zoom)
#
#
# Store the window zoom factor. This should be a reduced fraction but for
# simplicity we will store all fractions with a numerator of 100.
#
sub _store_zoom {
my $self = shift;
# If scale is 100 we don't need to write a record
return if $self->{_zoom} == 100;
my $record = 0x00A0; # Record identifier
my $length = 0x0004; # Bytes to follow
my $header = pack("vv", $record, $length );
my $data = pack("vv", $self->{_zoom}, 100);
$self->_append($header, $data);
}
###############################################################################
#
# write_utf16be_string($row, $col, $string, $format)
#
# Write a Unicode string to the specified row and column (zero indexed).
# $format is optional.
# Returns 0 : normal termination
# -1 : insufficient number of arguments
# -2 : row or column out of range
# -3 : long string truncated to 255 chars
#
sub write_utf16be_string {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
if (@_ < 3) { return -1 } # Check the number of args
my $record = 0x00FD; # Record identifier
my $length = 0x000A; # Bytes to follow
my $row = $_[0]; # Zero indexed row
my $col = $_[1]; # Zero indexed column
my $strlen = length($_[2]);
my $str = $_[2];
my $xf = _XF($self, $row, $col, $_[3]); # The cell format
my $encoding = 0x1;
my $str_error = 0;
# Check that row and col are valid and store max and min values
return -2 if $self->_check_dimensions($row, $col);
# Limit the utf16 string to the max number of chars (not bytes).
if ($strlen > 32767* 2) {
$str = substr($str, 0, 32767*2);
$str_error = -3;
}
my $num_bytes = length $str;
my $num_chars = int($num_bytes / 2);
# Check for a valid 2-byte char string.
croak "Uneven number of bytes in Unicode string" if $num_bytes % 2;
# Change from UTF16 big-endian to little endian
$str = pack "v*", unpack "n*", $str;
# Add the encoding and length header to the string.
my $str_header = pack("vC", $num_chars, $encoding);
$str = $str_header . $str;
if (not exists ${$self->{_str_table}}->{$str}) {
${$self->{_str_table}}->{$str} = ${$self->{_str_unique}}++;
}
${$self->{_str_total}}++;
my $header = pack("vv", $record, $length);
my $data = pack("vvvV", $row, $col, $xf, ${$self->{_str_table}}->{$str});
# Store the data or write immediately depending on the compatibility mode.
if ($self->{_compatibility}) {
$self->{_table}->[$row]->[$col] = $header . $data;
}
else {
$self->_append($header, $data);
}
return $str_error;
}
###############################################################################
#
# write_utf16le_string($row, $col, $string, $format)
#
# Write a UTF-16LE string to the specified row and column (zero indexed).
# $format is optional.
# Returns 0 : normal termination
# -1 : insufficient number of arguments
# -2 : row or column out of range
# -3 : long string truncated to 255 chars
#
sub write_utf16le_string {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
if (@_ < 3) { return -1 } # Check the number of args
my $record = 0x00FD; # Record identifier
my $length = 0x000A; # Bytes to follow
my $row = $_[0]; # Zero indexed row
my $col = $_[1]; # Zero indexed column
my $str = $_[2];
my $format = $_[3]; # The cell format
# Change from UTF16 big-endian to little endian
$str = pack "v*", unpack "n*", $str;
return $self->write_utf16be_string($row, $col, $str, $format);
}
# Older method name for backwards compatibility.
*write_unicode = *write_utf16be_string;
*write_unicode_le = *write_utf16le_string;
###############################################################################
#
# _store_autofilters()
#
# Function to iterate through the columns that form part of an autofilter
# range and write Biff AUTOFILTER records if a filter expression has been set.
#
sub _store_autofilters {
my $self = shift;
# Skip all columns if no filter have been set.
return unless $self->{_filter_on};
my (undef, undef, $col1, $col2) = @{$self->{_filter_area}};
for my $i ($col1 .. $col2) {
# Reverse order since records are being pre-pended.
my $col = $col2 -$i;
# Skip if column doesn't have an active filter.
next unless $self->{_filter_cols}->{$col};
# Retrieve the filter tokens
my @tokens = @{$self->{_filter_cols}->{$col}};
# Filter columns are relative to the first column in the filter.
my $filter_col = $col - $col1;
# Write the autofilter records.
$self->_store_autofilter($filter_col, @tokens);
}
}
###############################################################################
#
# _store_autofilter()
#
# Function to write worksheet AUTOFILTER records. These contain 2 Biff Doper
# structures to represent the 2 possible filter conditions.
#
sub _store_autofilter {
my $self = shift;
my $record = 0x009E;
my $length = 0x0000;
my $index = $_[0];
my $operator_1 = $_[1];
my $token_1 = $_[2];
my $join = $_[3]; # And/Or
my $operator_2 = $_[4];
my $token_2 = $_[5];
my $top10_active = 0;
my $top10_direction = 0;
my $top10_percent = 0;
my $top10_value = 101;
my $grbit = $join;
my $optimised_1 = 0;
my $optimised_2 = 0;
my $doper_1 = '';
my $doper_2 = '';
my $string_1 = '';
my $string_2 = '';
# Excel used an optimisation in the case of a simple equality.
$optimised_1 = 1 if $operator_1 == 2;
$optimised_2 = 1 if defined $operator_2 and $operator_2 == 2;
# Convert non-simple equalities back to type 2. See _parse_filter_tokens().
$operator_1 = 2 if $operator_1 == 22;
$operator_2 = 2 if defined $operator_2 and $operator_2 == 22;
# Handle a "Top" style expression.
if ($operator_1 >= 30) {
# Remove the second expression if present.
$operator_2 = undef;
$token_2 = undef;
# Set the active flag.
$top10_active = 1;
if ($operator_1 == 30 or $operator_1 == 31) {
$top10_direction = 1;
}
if ($operator_1 == 31 or $operator_1 == 33) {
$top10_percent = 1;
}
if ($top10_direction == 1) {
$operator_1 = 6
}
else {
$operator_1 = 3
}
$top10_value = $token_1;
$token_1 = 0;
}
$grbit |= $optimised_1 << 2;
$grbit |= $optimised_2 << 3;
$grbit |= $top10_active << 4;
$grbit |= $top10_direction << 5;
$grbit |= $top10_percent << 6;
$grbit |= $top10_value << 7;
($doper_1, $string_1) = $self->_pack_doper($operator_1, $token_1);
($doper_2, $string_2) = $self->_pack_doper($operator_2, $token_2);
my $data = pack 'v', $index;
$data .= pack 'v', $grbit;
$data .= $doper_1;
$data .= $doper_2;
$data .= $string_1;
$data .= $string_2;
$length = length $data;
my $header = pack('vv', $record, $length);
$self->_prepend($header, $data);
}
###############################################################################
#
# _pack_doper()
#
# Create a Biff Doper structure that represents a filter expression. Depending
# on the type of the token we pack an Empty, String or Number doper.
#
sub _pack_doper {
my $self = shift;
my $operator = $_[0];
my $token = $_[1];
my $doper = '';
my $string = '';
# Return default doper for non-defined filters.
if (not defined $operator) {
return ($self->_pack_unused_doper, $string);
}
if ($token =~ /^blanks|nonblanks$/i) {
$doper = $self->_pack_blanks_doper($operator, $token);
}
elsif ($operator == 2 or
$token !~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/)
{
# Excel treats all tokens as strings if the operator is equality, =.
$string = $token;
my $encoding = 0;
my $length = length $string;
# Handle utf8 strings in perl 5.8.
if ($] >= 5.008) {
require Encode;
if (Encode::is_utf8($string)) {
$string = Encode::encode("UTF-16BE", $string);
$encoding = 1;
}
}
$string = pack('C', $encoding) . $string;
$doper = $self->_pack_string_doper($operator, $length);
}
else {
$string = '';
$doper = $self->_pack_number_doper($operator, $token);
}
return ($doper, $string);
}
###############################################################################
#
# _pack_unused_doper()
#
# Pack an empty Doper structure.
#
sub _pack_unused_doper {
my $self = shift;
return pack 'C10', (0x0) x 10;
}
###############################################################################
#
# _pack_blanks_doper()
#
# Pack an Blanks/NonBlanks Doper structure.
#
sub _pack_blanks_doper {
my $self = shift;
my $operator = $_[0];
my $token = $_[1];
my $type;
if ($token eq 'blanks') {
$type = 0x0C;
$operator = 2;
}
else {
$type = 0x0E;
$operator = 5;
}
my $doper = pack 'CCVV', $type, # Data type
$operator, #
0x0000, # Reserved
0x0000; # Reserved
return $doper;
}
###############################################################################
#
# _pack_string_doper()
#
# Pack an string Doper structure.
#
sub _pack_string_doper {
my $self = shift;
my $operator = $_[0];
my $length = $_[1];
my $doper = pack 'CCVCCCC', 0x06, # Data type
$operator, #
0x0000, # Reserved
$length, # String char length.
0x0, 0x0, 0x0; # Reserved
return $doper;
}
###############################################################################
#
# _pack_number_doper()
#
# Pack an IEEE double number Doper structure.
#
sub _pack_number_doper {
my $self = shift;
my $operator = $_[0];
my $number = $_[1];
$number = pack 'd', $number;
$number = reverse $number if $self->{_byte_order};
my $doper = pack 'CC', 0x04, $operator;
$doper .= $number;
return $doper;
}
#
# Methods related to comments and MSO objects.
#
###############################################################################
#
# _prepare_images()
#
# Turn the HoH that stores the images into an array for easier handling.
#
sub _prepare_images {
my $self = shift;
my $count = 0;
my @images;
# We sort the images by row and column but that isn't strictly required.
#
my @rows = sort {$a <=> $b} keys %{$self->{_images}};
for my $row (@rows) {
my @cols = sort {$a <=> $b} keys %{$self->{_images}->{$row}};
for my $col (@cols) {
push @images, $self->{_images}->{$row}->{$col};
$count++;
}
}
$self->{_images} = {};
$self->{_images_array} = \@images;
return $count;
}
###############################################################################
#
# _prepare_comments()
#
# Turn the HoH that stores the comments into an array for easier handling.
#
sub _prepare_comments {
my $self = shift;
my $count = 0;
my @comments;
# We sort the comments by row and column but that isn't strictly required.
#
my @rows = sort {$a <=> $b} keys %{$self->{_comments}};
for my $row (@rows) {
my @cols = sort {$a <=> $b} keys %{$self->{_comments}->{$row}};
for my $col (@cols) {
push @comments, $self->{_comments}->{$row}->{$col};
$count++;
}
}
$self->{_comments} = {};
$self->{_comments_array} = \@comments;
return $count;
}
###############################################################################
#
# _prepare_charts()
#
# Turn the HoH that stores the charts into an array for easier handling.
#
sub _prepare_charts {
my $self = shift;
my $count = 0;
my @charts;
# We sort the charts by row and column but that isn't strictly required.
#
my @rows = sort {$a <=> $b} keys %{$self->{_charts}};
for my $row (@rows) {
my @cols = sort {$a <=> $b} keys %{$self->{_charts}->{$row}};
for my $col (@cols) {
push @charts, $self->{_charts}->{$row}->{$col};
$count++;
}
}
$self->{_charts} = {};
$self->{_charts_array} = \@charts;
return $count;
}
###############################################################################
#
# _store_images()
#
# Store the collections of records that make up images.
#
sub _store_images {
my $self = shift;
my $record = 0x00EC; # Record identifier
my $length = 0x0000; # Bytes to follow
my @ids = @{$self->{_object_ids }};
my $spid = shift @ids;
my @images = @{$self->{_images_array}};
my $num_images = scalar @images;
my $num_filters = $self->{_filter_count};
my $num_comments = @{$self->{_comments_array}};
my $num_charts = @{$self->{_charts_array }};
# Skip this if there aren't any images.
return unless $num_images;
for my $i (0 .. $num_images-1) {
my $row = $images[$i]->[0];
my $col = $images[$i]->[1];
my $name = $images[$i]->[2];
my $x_offset = $images[$i]->[3];
my $y_offset = $images[$i]->[4];
my $scale_x = $images[$i]->[5];
my $scale_y = $images[$i]->[6];
my $image_id = $images[$i]->[7];
my $type = $images[$i]->[8];
my $width = $images[$i]->[9];
my $height = $images[$i]->[10];
$width *= $scale_x if $scale_x;
$height *= $scale_y if $scale_y;
# Calculate the positions of image object.
my @vertices = $self->_position_object( $col,
$row,
$x_offset,
$y_offset,
$width,
$height
);
if ($i == 0) {
# Write the parent MSODRAWIING record.
my $dg_length = 156 + 84*($num_images -1);
my $spgr_length = 132 + 84*($num_images -1);
$dg_length += 120 *$num_charts;
$spgr_length += 120 *$num_charts;
$dg_length += 96 *$num_filters;
$spgr_length += 96 *$num_filters;
$dg_length += 128 *$num_comments;
$spgr_length += 128 *$num_comments;
my $data = $self->_store_mso_dg_container($dg_length);
$data .= $self->_store_mso_dg(@ids);
$data .= $self->_store_mso_spgr_container($spgr_length);
$data .= $self->_store_mso_sp_container(40);
$data .= $self->_store_mso_spgr();
$data .= $self->_store_mso_sp(0x0, $spid++, 0x0005);
$data .= $self->_store_mso_sp_container(76);
$data .= $self->_store_mso_sp(75, $spid++, 0x0A00);
$data .= $self->_store_mso_opt_image($image_id);
$data .= $self->_store_mso_client_anchor(2, @vertices);
$data .= $self->_store_mso_client_data();
$length = length $data;
my $header = pack("vv", $record, $length);
$self->_append($header, $data);
}
else {
# Write the child MSODRAWIING record.
my $data = $self->_store_mso_sp_container(76);
$data .= $self->_store_mso_sp(75, $spid++, 0x0A00);
$data .= $self->_store_mso_opt_image($image_id);
$data .= $self->_store_mso_client_anchor(2, @vertices);
$data .= $self->_store_mso_client_data();
$length = length $data;
my $header = pack("vv", $record, $length);
$self->_append($header, $data);
}
$self->_store_obj_image($i+1);
}
$self->{_object_ids}->[0] = $spid;
}
###############################################################################
#
# _store_charts()
#
# Store the collections of records that make up charts.
#
sub _store_charts {
my $self = shift;
my $record = 0x00EC; # Record identifier
my $length = 0x0000; # Bytes to follow
my @ids = @{$self->{_object_ids}};
my $spid = shift @ids;
my @charts = @{$self->{_charts_array}};
my $num_charts = scalar @charts;
my $num_filters = $self->{_filter_count};
my $num_comments = @{$self->{_comments_array}};
# Number of objects written so far.
my $num_objects = @{$self->{_images_array}};
# Skip this if there aren't any charts.
return unless $num_charts;
for my $i (0 .. $num_charts-1 ) {
my $row = $charts[$i]->[0];
my $col = $charts[$i]->[1];
my $chart = $charts[$i]->[2];
my $x_offset = $charts[$i]->[3];
my $y_offset = $charts[$i]->[4];
my $scale_x = $charts[$i]->[5];
my $scale_y = $charts[$i]->[6];
my $width = 526;
my $height = 319;
$width *= $scale_x if $scale_x;
$height *= $scale_y if $scale_y;
# Calculate the positions of chart object.
my @vertices = $self->_position_object( $col,
$row,
$x_offset,
$y_offset,
$width,
$height
);
if ($i == 0 and not $num_objects) {
# Write the parent MSODRAWIING record.
my $dg_length = 192 + 120*($num_charts -1);
my $spgr_length = 168 + 120*($num_charts -1);
$dg_length += 96 *$num_filters;
$spgr_length += 96 *$num_filters;
$dg_length += 128 *$num_comments;
$spgr_length += 128 *$num_comments;
my $data = $self->_store_mso_dg_container($dg_length);
$data .= $self->_store_mso_dg(@ids);
$data .= $self->_store_mso_spgr_container($spgr_length);
$data .= $self->_store_mso_sp_container(40);
$data .= $self->_store_mso_spgr();
$data .= $self->_store_mso_sp(0x0, $spid++, 0x0005);
$data .= $self->_store_mso_sp_container(112);
$data .= $self->_store_mso_sp(201, $spid++, 0x0A00);
$data .= $self->_store_mso_opt_chart();
$data .= $self->_store_mso_client_anchor(0, @vertices);
$data .= $self->_store_mso_client_data();
$length = length $data;
my $header = pack("vv", $record, $length);
$self->_append($header, $data);
}
else {
# Write the child MSODRAWIING record.
my $data = $self->_store_mso_sp_container(112);
$data .= $self->_store_mso_sp(201, $spid++, 0x0A00);
$data .= $self->_store_mso_opt_chart();
$data .= $self->_store_mso_client_anchor(0, @vertices);
$data .= $self->_store_mso_client_data();
$length = length $data;
my $header = pack("vv", $record, $length);
$self->_append($header, $data);
}
$self->_store_obj_chart($num_objects+$i+1);
$self->_store_chart_binary($chart);
}
# Simulate the EXTERNSHEET link between the chart and data using a formula
# such as '=Sheet1!A1'.
# TODO. Won't work for external data refs. Also should use a more direct
# method.
#
my $name = $self->{_name};
if ($self->{_encoding} && $] >= 5.008) {
require Encode;
$name = Encode::decode('UTF-16BE', $name);
}
$self->store_formula("='$name'!A1");
$self->{_object_ids}->[0] = $spid;
}
###############################################################################
#
# _store_chart_binary
#
# Add the binary data for a chart. This could either be from a Chart object
# or from an external binary file (for backwards compatibility).
#
sub _store_chart_binary {
my $self = shift;
my $chart = $_[0];
my $tmp;
if ( ref $chart ) {
$chart->_close();
my $tmp = $chart->get_data();
$self->_append( $tmp );
}
else {
my $filehandle = FileHandle->new( $chart )
or die "Couldn't open $chart in insert_chart(): $!.\n";
binmode( $filehandle );
while ( read( $filehandle, $tmp, 4096 ) ) {
$self->_append( $tmp );
}
}
}
###############################################################################
#
# _store_filters()
#
# Store the collections of records that make up filters.
#
sub _store_filters {
my $self = shift;
my $record = 0x00EC; # Record identifier
my $length = 0x0000; # Bytes to follow
my @ids = @{$self->{_object_ids}};
my $spid = shift @ids;
my $filter_area = $self->{_filter_area};
my $num_filters = $self->{_filter_count};
my $num_comments = @{$self->{_comments_array}};
# Number of objects written so far.
my $num_objects = @{$self->{_images_array}}
+ @{$self->{_charts_array}};
# Skip this if there aren't any filters.
return unless $num_filters;
my ($row1, $row2, $col1, $col2) = @$filter_area;
for my $i (0 .. $num_filters-1 ) {
my @vertices = ( $col1 +$i,
0,
$row1,
0,
$col1 +$i +1,
0,
$row1 +1,
0);
if ($i == 0 and not $num_objects) {
# Write the parent MSODRAWIING record.
my $dg_length = 168 + 96*($num_filters -1);
my $spgr_length = 144 + 96*($num_filters -1);
$dg_length += 128 *$num_comments;
$spgr_length += 128 *$num_comments;
my $data = $self->_store_mso_dg_container($dg_length);
$data .= $self->_store_mso_dg(@ids);
$data .= $self->_store_mso_spgr_container($spgr_length);
$data .= $self->_store_mso_sp_container(40);
$data .= $self->_store_mso_spgr();
$data .= $self->_store_mso_sp(0x0, $spid++, 0x0005);
$data .= $self->_store_mso_sp_container(88);
$data .= $self->_store_mso_sp(201, $spid++, 0x0A00);
$data .= $self->_store_mso_opt_filter();
$data .= $self->_store_mso_client_anchor(1, @vertices);
$data .= $self->_store_mso_client_data();
$length = length $data;
my $header = pack("vv", $record, $length);
$self->_append($header, $data);
}
else {
# Write the child MSODRAWIING record.
my $data = $self->_store_mso_sp_container(88);
$data .= $self->_store_mso_sp(201, $spid++, 0x0A00);
$data .= $self->_store_mso_opt_filter();
$data .= $self->_store_mso_client_anchor(1, @vertices);
$data .= $self->_store_mso_client_data();
$length = length $data;
my $header = pack("vv", $record, $length);
$self->_append($header, $data);
}
$self->_store_obj_filter($num_objects+$i+1, $col1 +$i);
}
# Simulate the EXTERNSHEET link between the filter and data using a formula
# such as '=Sheet1!A1'.
# TODO. Won't work for external data refs. Also should use a more direct
# method.
#
my $formula = "='$self->{_name}'!A1";
$self->store_formula($formula);
$self->{_object_ids}->[0] = $spid;
}
###############################################################################
#
# _store_comments()
#
# Store the collections of records that make up cell comments.
#
# NOTE: We write the comment objects last since that makes it a little easier
# to write the NOTE records directly after the MSODRAWIING records.
#
sub _store_comments {
my $self = shift;
my $record = 0x00EC; # Record identifier
my $length = 0x0000; # Bytes to follow
my @ids = @{$self->{_object_ids}};
my $spid = shift @ids;
my @comments = @{$self->{_comments_array}};
my $num_comments = scalar @comments;
# Number of objects written so far.
my $num_objects = @{$self->{_images_array}}
+ $self->{_filter_count}
+ @{$self->{_charts_array}};
# Skip this if there aren't any comments.
return unless $num_comments;
for my $i (0 .. $num_comments-1) {
my $row = $comments[$i]->[0];
my $col = $comments[$i]->[1];
my $str = $comments[$i]->[2];
my $encoding = $comments[$i]->[3];
my $visible = $comments[$i]->[6];
my $color = $comments[$i]->[7];
my @vertices = @{$comments[$i]->[8]};
my $str_len = length $str;
$str_len /= 2 if $encoding; # Num of chars not bytes.
my $formats = [[0, 9], [$str_len, 0]];
if ($i == 0 and not $num_objects) {
# Write the parent MSODRAWIING record.
my $dg_length = 200 + 128*($num_comments -1);
my $spgr_length = 176 + 128*($num_comments -1);
my $data = $self->_store_mso_dg_container($dg_length);
$data .= $self->_store_mso_dg(@ids);
$data .= $self->_store_mso_spgr_container($spgr_length);
$data .= $self->_store_mso_sp_container(40);
$data .= $self->_store_mso_spgr();
$data .= $self->_store_mso_sp(0x0, $spid++, 0x0005);
$data .= $self->_store_mso_sp_container(120);
$data .= $self->_store_mso_sp(202, $spid++, 0x0A00);
$data .= $self->_store_mso_opt_comment(0x80, $visible, $color);
$data .= $self->_store_mso_client_anchor(3, @vertices);
$data .= $self->_store_mso_client_data();
$length = length $data;
my $header = pack("vv", $record, $length);
$self->_append($header, $data);
}
else {
# Write the child MSODRAWIING record.
my $data = $self->_store_mso_sp_container(120);
$data .= $self->_store_mso_sp(202, $spid++, 0x0A00);
$data .= $self->_store_mso_opt_comment(0x80, $visible, $color);
$data .= $self->_store_mso_client_anchor(3, @vertices);
$data .= $self->_store_mso_client_data();
$length = length $data;
my $header = pack("vv", $record, $length);
$self->_append($header, $data);
}
$self->_store_obj_comment($num_objects+$i+1);
$self->_store_mso_drawing_text_box();
$self->_store_txo($str_len);
$self->_store_txo_continue_1($str, $encoding);
$self->_store_txo_continue_2($formats);
}
# Write the NOTE records after MSODRAWIING records.
for my $i (0 .. $num_comments-1) {
my $row = $comments[$i]->[0];
my $col = $comments[$i]->[1];
my $author = $comments[$i]->[4];
my $author_enc = $comments[$i]->[5];
my $visible = $comments[$i]->[6];
$self->_store_note($row, $col, $num_objects+$i+1,
$author, $author_enc, $visible);
}
}
###############################################################################
#
# _store_mso_dg_container()
#
# Write the Escher DgContainer record that is part of MSODRAWING.
#
sub _store_mso_dg_container {
my $self = shift;
my $type = 0xF002;
my $version = 15;
my $instance = 0;
my $data = '';
my $length = $_[0];
return $self->_add_mso_generic($type, $version, $instance, $data, $length);
}
###############################################################################
#
# _store_mso_dg()
#
# Write the Escher Dg record that is part of MSODRAWING.
#
sub _store_mso_dg {
my $self = shift;
my $type = 0xF008;
my $version = 0;
my $instance = $_[0];
my $data = '';
my $length = 8;
my $num_shapes = $_[1];
my $max_spid = $_[2];
$data = pack "VV", $num_shapes, $max_spid;
return $self->_add_mso_generic($type, $version, $instance, $data, $length);
}
###############################################################################
#
# _store_mso_spgr_container()
#
# Write the Escher SpgrContainer record that is part of MSODRAWING.
#
sub _store_mso_spgr_container {
my $self = shift;
my $type = 0xF003;
my $version = 15;
my $instance = 0;
my $data = '';
my $length = $_[0];
return $self->_add_mso_generic($type, $version, $instance, $data, $length);
}
###############################################################################
#
# _store_mso_sp_container()
#
# Write the Escher SpContainer record that is part of MSODRAWING.
#
sub _store_mso_sp_container {
my $self = shift;
my $type = 0xF004;
my $version = 15;
my $instance = 0;
my $data = '';
my $length = $_[0];
return $self->_add_mso_generic($type, $version, $instance, $data, $length);
}
###############################################################################
#
# _store_mso_spgr()
#
# Write the Escher Spgr record that is part of MSODRAWING.
#
sub _store_mso_spgr {
my $self = shift;
my $type = 0xF009;
my $version = 1;
my $instance = 0;
my $data = pack "VVVV", 0, 0, 0, 0;
my $length = 16;
return $self->_add_mso_generic($type, $version, $instance, $data, $length);
}
###############################################################################
#
# _store_mso_sp()
#
# Write the Escher Sp record that is part of MSODRAWING.
#
sub _store_mso_sp {
my $self = shift;
my $type = 0xF00A;
my $version = 2;
my $instance = $_[0];
my $data = '';
my $length = 8;
my $spid = $_[1];
my $options = $_[2];
$data = pack "VV", $spid, $options;
return $self->_add_mso_generic($type, $version, $instance, $data, $length);
}
###############################################################################
#
# _store_mso_opt_comment()
#
# Write the Escher Opt record that is part of MSODRAWING.
#
sub _store_mso_opt_comment {
my $self = shift;
my $type = 0xF00B;
my $version = 3;
my $instance = 9;
my $data = '';
my $length = 54;
my $spid = $_[0];
my $visible = $_[1];
my $colour = $_[2] || 0x50;
# Use the visible flag if set by the user or else use the worksheet value.
# Note that the value used is the opposite of _store_note().
#
if (defined $visible) {
$visible = $visible ? 0x0000 : 0x0002;
}
else {
$visible = $self->{_comments_visible} ? 0x0000 : 0x0002;
}
$data = pack "V", $spid;
$data .= pack "H*", '0000BF00080008005801000000008101' ;
$data .= pack "C", $colour;
$data .= pack "H*", '000008830150000008BF011000110001' .
'02000000003F0203000300BF03';
$data .= pack "v", $visible;
$data .= pack "H*", '0A00';
return $self->_add_mso_generic($type, $version, $instance, $data, $length);
}
###############################################################################
#
# _store_mso_opt_image()
#
# Write the Escher Opt record that is part of MSODRAWING.
#
sub _store_mso_opt_image {
my $self = shift;
my $type = 0xF00B;
my $version = 3;
my $instance = 3;
my $data = '';
my $length = undef;
my $spid = $_[0];
$data = pack 'v', 0x4104; # Blip -> pib
$data .= pack 'V', $spid;
$data .= pack 'v', 0x01BF; # Fill Style -> fNoFillHitTest
$data .= pack 'V', 0x00010000;
$data .= pack 'v', 0x03BF; # Group Shape -> fPrint
$data .= pack 'V', 0x00080000;
return $self->_add_mso_generic($type, $version, $instance, $data, $length);
}
###############################################################################
#
# _store_mso_opt_chart()
#
# Write the Escher Opt record that is part of MSODRAWING.
#
sub _store_mso_opt_chart {
my $self = shift;
my $type = 0xF00B;
my $version = 3;
my $instance = 9;
my $data = '';
my $length = undef;
$data = pack 'v', 0x007F; # Protection -> fLockAgainstGrouping
$data .= pack 'V', 0x01040104;
$data .= pack 'v', 0x00BF; # Text -> fFitTextToShape
$data .= pack 'V', 0x00080008;
$data .= pack 'v', 0x0181; # Fill Style -> fillColor
$data .= pack 'V', 0x0800004E ;
$data .= pack 'v', 0x0183; # Fill Style -> fillBackColor
$data .= pack 'V', 0x0800004D;
$data .= pack 'v', 0x01BF; # Fill Style -> fNoFillHitTest
$data .= pack 'V', 0x00110010;
$data .= pack 'v', 0x01C0; # Line Style -> lineColor
$data .= pack 'V', 0x0800004D;
$data .= pack 'v', 0x01FF; # Line Style -> fNoLineDrawDash
$data .= pack 'V', 0x00080008;
$data .= pack 'v', 0x023F; # Shadow Style -> fshadowObscured
$data .= pack 'V', 0x00020000;
$data .= pack 'v', 0x03BF; # Group Shape -> fPrint
$data .= pack 'V', 0x00080000;
return $self->_add_mso_generic($type, $version, $instance, $data, $length);
}
###############################################################################
#
# _store_mso_opt_filter()
#
# Write the Escher Opt record that is part of MSODRAWING.
#
sub _store_mso_opt_filter {
my $self = shift;
my $type = 0xF00B;
my $version = 3;
my $instance = 5;
my $data = '';
my $length = undef;
$data = pack 'v', 0x007F; # Protection -> fLockAgainstGrouping
$data .= pack 'V', 0x01040104;
$data .= pack 'v', 0x00BF; # Text -> fFitTextToShape
$data .= pack 'V', 0x00080008;
$data .= pack 'v', 0x01BF; # Fill Style -> fNoFillHitTest
$data .= pack 'V', 0x00010000;
$data .= pack 'v', 0x01FF; # Line Style -> fNoLineDrawDash
$data .= pack 'V', 0x00080000;
$data .= pack 'v', 0x03BF; # Group Shape -> fPrint
$data .= pack 'V', 0x000A0000;
return $self->_add_mso_generic($type, $version, $instance, $data, $length);
}
###############################################################################
#
# _store_mso_client_anchor()
#
# Write the Escher ClientAnchor record that is part of MSODRAWING.
#
sub _store_mso_client_anchor {
my $self = shift;
my $type = 0xF010;
my $version = 0;
my $instance = 0;
my $data = '';
my $length = 18;
my $flag = shift;
my $col_start = $_[0]; # Col containing upper left corner of object
my $x1 = $_[1]; # Distance to left side of object
my $row_start = $_[2]; # Row containing top left corner of object
my $y1 = $_[3]; # Distance to top of object
my $col_end = $_[4]; # Col containing lower right corner of object
my $x2 = $_[5]; # Distance to right side of object
my $row_end = $_[6]; # Row containing bottom right corner of object
my $y2 = $_[7]; # Distance to bottom of object
$data = pack "v9", $flag,
$col_start, $x1,
$row_start, $y1,
$col_end, $x2,
$row_end, $y2;
return $self->_add_mso_generic($type, $version, $instance, $data, $length);
}
###############################################################################
#
# _store_mso_client_data()
#
# Write the Escher ClientData record that is part of MSODRAWING.
#
sub _store_mso_client_data {
my $self = shift;
my $type = 0xF011;
my $version = 0;
my $instance = 0;
my $data = '';
my $length = 0;
return $self->_add_mso_generic($type, $version, $instance, $data, $length);
}
###############################################################################
#
# _store_obj_comment()
#
# Write the OBJ record that is part of cell comments.
#
sub _store_obj_comment {
my $self = shift;
my $record = 0x005D; # Record identifier
my $length = 0x0034; # Bytes to follow
my $obj_id = $_[0]; # Object ID number.
my $obj_type = 0x0019; # Object type (comment).
my $data = ''; # Record data.
my $sub_record = 0x0000; # Sub-record identifier.
my $sub_length = 0x0000; # Length of sub-record.
my $sub_data = ''; # Data of sub-record.
my $options = 0x4011;
my $reserved = 0x0000;
# Add ftCmo (common object data) subobject
$sub_record = 0x0015; # ftCmo
$sub_length = 0x0012;
$sub_data = pack "vvvVVV", $obj_type, $obj_id, $options,
$reserved, $reserved, $reserved;
$data = pack("vv", $sub_record, $sub_length);
$data .= $sub_data;
# Add ftNts (note structure) subobject
$sub_record = 0x000D; # ftNts
$sub_length = 0x0016;
$sub_data = pack "VVVVVv", ($reserved) x 6;
$data .= pack("vv", $sub_record, $sub_length);
$data .= $sub_data;
# Add ftEnd (end of object) subobject
$sub_record = 0x0000; # ftNts
$sub_length = 0x0000;
$data .= pack("vv", $sub_record, $sub_length);
# Pack the record.
my $header = pack("vv", $record, $length);
$self->_append($header, $data);
}
###############################################################################
#
# _store_obj_image()
#
# Write the OBJ record that is part of image records.
#
sub _store_obj_image {
my $self = shift;
my $record = 0x005D; # Record identifier
my $length = 0x0026; # Bytes to follow
my $obj_id = $_[0]; # Object ID number.
my $obj_type = 0x0008; # Object type (Picture).
my $data = ''; # Record data.
my $sub_record = 0x0000; # Sub-record identifier.
my $sub_length = 0x0000; # Length of sub-record.
my $sub_data = ''; # Data of sub-record.
my $options = 0x6011;
my $reserved = 0x0000;
# Add ftCmo (common object data) subobject
$sub_record = 0x0015; # ftCmo
$sub_length = 0x0012;
$sub_data = pack 'vvvVVV', $obj_type, $obj_id, $options,
$reserved, $reserved, $reserved;
$data = pack 'vv', $sub_record, $sub_length;
$data .= $sub_data;
# Add ftCf (Clipboard format) subobject
$sub_record = 0x0007; # ftCf
$sub_length = 0x0002;
$sub_data = pack 'v', 0xFFFF;
$data .= pack 'vv', $sub_record, $sub_length;
$data .= $sub_data;
# Add ftPioGrbit (Picture option flags) subobject
$sub_record = 0x0008; # ftPioGrbit
$sub_length = 0x0002;
$sub_data = pack 'v', 0x0001;
$data .= pack 'vv', $sub_record, $sub_length;
$data .= $sub_data;
# Add ftEnd (end of object) subobject
$sub_record = 0x0000; # ftNts
$sub_length = 0x0000;
$data .= pack 'vv', $sub_record, $sub_length;
# Pack the record.
my $header = pack('vv', $record, $length);
$self->_append($header, $data);
}
###############################################################################
#
# _store_obj_chart()
#
# Write the OBJ record that is part of chart records.
#
sub _store_obj_chart {
my $self = shift;
my $record = 0x005D; # Record identifier
my $length = 0x001A; # Bytes to follow
my $obj_id = $_[0]; # Object ID number.
my $obj_type = 0x0005; # Object type (chart).
my $data = ''; # Record data.
my $sub_record = 0x0000; # Sub-record identifier.
my $sub_length = 0x0000; # Length of sub-record.
my $sub_data = ''; # Data of sub-record.
my $options = 0x6011;
my $reserved = 0x0000;
# Add ftCmo (common object data) subobject
$sub_record = 0x0015; # ftCmo
$sub_length = 0x0012;
$sub_data = pack 'vvvVVV', $obj_type, $obj_id, $options,
$reserved, $reserved, $reserved;
$data = pack 'vv', $sub_record, $sub_length;
$data .= $sub_data;
# Add ftEnd (end of object) subobject
$sub_record = 0x0000; # ftNts
$sub_length = 0x0000;
$data .= pack 'vv', $sub_record, $sub_length;
# Pack the record.
my $header = pack('vv', $record, $length);
$self->_append($header, $data);
}
###############################################################################
#
# _store_obj_filter()
#
# Write the OBJ record that is part of filter records.
#
sub _store_obj_filter {
my $self = shift;
my $record = 0x005D; # Record identifier
my $length = 0x0046; # Bytes to follow
my $obj_id = $_[0]; # Object ID number.
my $obj_type = 0x0014; # Object type (combo box).
my $data = ''; # Record data.
my $sub_record = 0x0000; # Sub-record identifier.
my $sub_length = 0x0000; # Length of sub-record.
my $sub_data = ''; # Data of sub-record.
my $options = 0x2101;
my $reserved = 0x0000;
# Add ftCmo (common object data) subobject
$sub_record = 0x0015; # ftCmo
$sub_length = 0x0012;
$sub_data = pack 'vvvVVV', $obj_type, $obj_id, $options,
$reserved, $reserved, $reserved;
$data = pack 'vv', $sub_record, $sub_length;
$data .= $sub_data;
# Add ftSbs Scroll bar subobject
$sub_record = 0x000C; # ftSbs
$sub_length = 0x0014;
$sub_data = pack 'H*', '0000000000000000640001000A00000010000100';
$data .= pack 'vv', $sub_record, $sub_length;
$data .= $sub_data;
# Add ftLbsData (List box data) subobject
$sub_record = 0x0013; # ftLbsData
$sub_length = 0x1FEE; # Special case (undocumented).
# If the filter is active we set one of the undocumented flags.
my $col = $_[1];
if ($self->{_filter_cols}->{$col}) {
$sub_data = pack 'H*', '000000000100010300000A0008005700';
}
else {
$sub_data = pack 'H*', '00000000010001030000020008005700';
}
$data .= pack 'vv', $sub_record, $sub_length;
$data .= $sub_data;
# Add ftEnd (end of object) subobject
$sub_record = 0x0000; # ftNts
$sub_length = 0x0000;
$data .= pack 'vv', $sub_record, $sub_length;
# Pack the record.
my $header = pack('vv', $record, $length);
$self->_append($header, $data);
}
###############################################################################
#
# _store_mso_drawing_text_box()
#
# Write the MSODRAWING ClientTextbox record that is part of comments.
#
sub _store_mso_drawing_text_box {
my $self = shift;
my $record = 0x00EC; # Record identifier
my $length = 0x0008; # Bytes to follow
my $data = $self->_store_mso_client_text_box();
my $header = pack("vv", $record, $length);
$self->_append($header, $data);
}
###############################################################################
#
# _store_mso_client_text_box()
#
# Write the Escher ClientTextbox record that is part of MSODRAWING.
#
sub _store_mso_client_text_box {
my $self = shift;
my $type = 0xF00D;
my $version = 0;
my $instance = 0;
my $data = '';
my $length = 0;
return $self->_add_mso_generic($type, $version, $instance, $data, $length);
}
###############################################################################
#
# _store_txo()
#
# Write the worksheet TXO record that is part of cell comments.
#
sub _store_txo {
my $self = shift;
my $record = 0x01B6; # Record identifier
my $length = 0x0012; # Bytes to follow
my $string_len = $_[0]; # Length of the note text.
my $format_len = $_[1] || 16; # Length of the format runs.
my $rotation = $_[2] || 0; # Options
my $grbit = 0x0212; # Options
my $reserved = 0x0000; # Options
# Pack the record.
my $header = pack("vv", $record, $length);
my $data = pack("vvVvvvV", $grbit, $rotation, $reserved, $reserved,
$string_len, $format_len, $reserved);
$self->_append($header, $data);
}
###############################################################################
#
# _store_txo_continue_1()
#
# Write the first CONTINUE record to follow the TXO record. It contains the
# text data.
#
sub _store_txo_continue_1 {
my $self = shift;
my $record = 0x003C; # Record identifier
my $string = $_[0]; # Comment string.
my $encoding = $_[1] || 0; # Encoding of the string.
# Split long comment strings into smaller continue blocks if necessary.
# We can't let BIFFwriter::_add_continue() handled this since an extra
# encoding byte has to be added similar to the SST block.
#
# We make the limit size smaller than the _add_continue() size and even
# so that UTF16 chars occur in the same block.
#
my $limit = 8218;
while (length($string) > $limit) {
my $tmp_str = substr($string, 0, $limit, "");
my $data = pack("C", $encoding) . $tmp_str;
my $length = length $data;
my $header = pack("vv", $record, $length);
$self->_append($header, $data);
}
# Pack the record.
my $data = pack("C", $encoding) . $string;
my $length = length $data;
my $header = pack("vv", $record, $length);
$self->_append($header, $data);
}
###############################################################################
#
# _store_txo_continue_2()
#
# Write the second CONTINUE record to follow the TXO record. It contains the
# formatting information for the string.
#
sub _store_txo_continue_2 {
my $self = shift;
my $record = 0x003C; # Record identifier
my $length = 0x0000; # Bytes to follow
my $formats = $_[0]; # Formatting information
# Pack the record.
my $data = '';
for my $a_ref (@$formats) {
$data .= pack "vvV", $a_ref->[0], $a_ref->[1], 0x0;
}
$length = length $data;
my $header = pack("vv", $record, $length);
$self->_append($header, $data);
}
###############################################################################
#
# _store_note()
#
# Write the worksheet NOTE record that is part of cell comments.
#
sub _store_note {
my $self = shift;
my $record = 0x001C; # Record identifier
my $length = 0x000C; # Bytes to follow
my $row = $_[0];
my $col = $_[1];
my $obj_id = $_[2];
my $author = $_[3] || $self->{_comments_author};
my $author_enc = $_[4] || $self->{_comments_author_enc};
my $visible = $_[5];
# Use the visible flag if set by the user or else use the worksheet value.
# The flag is also set in _store_mso_opt_comment() but with the opposite
# value.
if (defined $visible) {
$visible = $visible ? 0x0002 : 0x0000;
}
else {
$visible = $self->{_comments_visible} ? 0x0002 : 0x0000;
}
# Get the number of chars in the author string (not bytes).
my $num_chars = length $author;
$num_chars /= 2 if $author_enc;
# Null terminate the author string.
$author .= "\0";
# Pack the record.
my $data = pack("vvvvvC", $row, $col, $visible, $obj_id,
$num_chars, $author_enc);
$length = length($data) + length($author);
my $header = pack("vv", $record, $length);
$self->_append($header, $data, $author);
}
###############################################################################
#
# _comment_params()
#
# This method handles the additional optional parameters to write_comment() as
# well as calculating the comment object position and vertices.
#
sub _comment_params {
my $self = shift;
my $row = shift;
my $col = shift;
my $string = shift;
my $default_width = 128;
my $default_height = 74;
my %params = (
author => '',
author_encoding => 0,
encoding => 0,
color => undef,
start_cell => undef,
start_col => undef,
start_row => undef,
visible => undef,
width => $default_width,
height => $default_height,
x_offset => undef,
x_scale => 1,
y_offset => undef,
y_scale => 1,
);
# Overwrite the defaults with any user supplied values. Incorrect or
# misspelled parameters are silently ignored.
%params = (%params, @_);
# Ensure that a width and height have been set.
$params{width} = $default_width if not $params{width};
$params{height} = $default_height if not $params{height};
# Check that utf16 strings have an even number of bytes.
if ($params{encoding}) {
croak "Uneven number of bytes in comment string"
if length($string) % 2;
# Change from UTF-16BE to UTF-16LE
$string = pack 'v*', unpack 'n*', $string;
}
if ($params{author_encoding}) {
croak "Uneven number of bytes in author string"
if length($params{author}) % 2;
# Change from UTF-16BE to UTF-16LE
$params{author} = pack 'v*', unpack 'n*', $params{author};
}
# Handle utf8 strings in perl 5.8.
if ($] >= 5.008) {
require Encode;
if (Encode::is_utf8($string)) {
$string = Encode::encode("UTF-16LE", $string);
$params{encoding} = 1;
}
if (Encode::is_utf8($params{author})) {
$params{author} = Encode::encode("UTF-16LE", $params{author});
$params{author_encoding} = 1;
}
}
# Limit the string to the max number of chars (not bytes).
my $max_len = 32767;
$max_len *= 2 if $params{encoding};
if (length($string) > $max_len) {
$string = substr($string, 0, $max_len);
}
# Set the comment background colour.
my $color = $params{color};
$color = &Spreadsheet::WriteExcel::Format::_get_color($color);
$color = 0x50 if $color == 0x7FFF; # Default color.
$params{color} = $color;
# Convert a cell reference to a row and column.
if (defined $params{start_cell}) {
my ($row, $col) = $self->_substitute_cellref($params{start_cell});
$params{start_row} = $row;
$params{start_col} = $col;
}
# Set the default start cell and offsets for the comment. These are
# generally fixed in relation to the parent cell. However there are
# some edge cases for cells at the, er, edges.
#
if (not defined $params{start_row}) {
if ($row == 0 ) {$params{start_row} = 0 }
elsif ($row == 65533) {$params{start_row} = 65529 }
elsif ($row == 65534) {$params{start_row} = 65530 }
elsif ($row == 65535) {$params{start_row} = 65531 }
else {$params{start_row} = $row -1}
}
if (not defined $params{y_offset}) {
if ($row == 0 ) {$params{y_offset} = 2 }
elsif ($row == 65533) {$params{y_offset} = 4 }
elsif ($row == 65534) {$params{y_offset} = 4 }
elsif ($row == 65535) {$params{y_offset} = 2 }
else {$params{y_offset} = 7 }
}
if (not defined $params{start_col}) {
if ($col == 253 ) {$params{start_col} = 250 }
elsif ($col == 254 ) {$params{start_col} = 251 }
elsif ($col == 255 ) {$params{start_col} = 252 }
else {$params{start_col} = $col +1}
}
if (not defined $params{x_offset}) {
if ($col == 253 ) {$params{x_offset} = 49 }
elsif ($col == 254 ) {$params{x_offset} = 49 }
elsif ($col == 255 ) {$params{x_offset} = 49 }
else {$params{x_offset} = 15 }
}
# Scale the size of the comment box if required.
if ($params{x_scale}) {
$params{width} = $params{width} * $params{x_scale};
}
if ($params{y_scale}) {
$params{height} = $params{height} * $params{y_scale};
}
# Calculate the positions of comment object.
my @vertices = $self->_position_object( $params{start_col},
$params{start_row},
$params{x_offset},
$params{y_offset},
$params{width},
$params{height}
);
return(
$row,
$col,
$string,
$params{encoding},
$params{author},
$params{author_encoding},
$params{visible},
$params{color},
[@vertices]
);
}
#
# DATA VALIDATION
#
###############################################################################
#
# data_validation($row, $col, {...})
#
# This method handles the interface to Excel data validation.
# Somewhat ironically the this requires a lot of validation code since the
# interface is flexible and covers a several types of data validation.
#
# We allow data validation to be called on one cell or a range of cells. The
# hashref contains the validation parameters and must be the last param:
# data_validation($row, $col, {...})
# data_validation($first_row, $first_col, $last_row, $last_col, {...})
#
# Returns 0 : normal termination
# -1 : insufficient number of arguments
# -2 : row or column out of range
# -3 : incorrect parameter.
#
sub data_validation {
my $self = shift;
# Check for a cell reference in A1 notation and substitute row and column
if ($_[0] =~ /^\D/) {
@_ = $self->_substitute_cellref(@_);
}
# Check for a valid number of args.
if (@_ != 5 && @_ != 3) { return -1 }
# The final hashref contains the validation parameters.
my $param = pop;
# Make the last row/col the same as the first if not defined.
my ($row1, $col1, $row2, $col2) = @_;
if (!defined $row2) {
$row2 = $row1;
$col2 = $col1;
}
# Check that row and col are valid without storing the values.
return -2 if $self->_check_dimensions($row1, $col1, 1, 1);
return -2 if $self->_check_dimensions($row2, $col2, 1, 1);
# Check that the last parameter is a hash list.
if (ref $param ne 'HASH') {
carp "Last parameter '$param' in data_validation() must be a hash ref";
return -3;
}
# List of valid input parameters.
my %valid_parameter = (
validate => 1,
criteria => 1,
value => 1,
source => 1,
minimum => 1,
maximum => 1,
ignore_blank => 1,
dropdown => 1,
show_input => 1,
input_title => 1,
input_message => 1,
show_error => 1,
error_title => 1,
error_message => 1,
error_type => 1,
other_cells => 1,
);
# Check for valid input parameters.
for my $param_key (keys %$param) {
if (not exists $valid_parameter{$param_key}) {
carp "Unknown parameter '$param_key' in data_validation()";
return -3;
}
}
# Map alternative parameter names 'source' or 'minimum' to 'value'.
$param->{value} = $param->{source} if defined $param->{source};
$param->{value} = $param->{minimum} if defined $param->{minimum};
# 'validate' is a required parameter.
if (not exists $param->{validate}) {
carp "Parameter 'validate' is required in data_validation()";
return -3;
}
# List of valid validation types.
my %valid_type = (
'any' => 0,
'any value' => 0,
'whole number' => 1,
'whole' => 1,
'integer' => 1,
'decimal' => 2,
'list' => 3,
'date' => 4,
'time' => 5,
'text length' => 6,
'length' => 6,
'custom' => 7,
);
# Check for valid validation types.
if (not exists $valid_type{lc($param->{validate})}) {
carp "Unknown validation type '$param->{validate}' for parameter " .
"'validate' in data_validation()";
return -3;
}
else {
$param->{validate} = $valid_type{lc($param->{validate})};
}
# No action is required for validation type 'any'.
# TODO: we should perhaps store 'any' for message only validations.
return 0 if $param->{validate} == 0;
# The list and custom validations don't have a criteria so we use a default
# of 'between'.
if ($param->{validate} == 3 || $param->{validate} == 7) {
$param->{criteria} = 'between';
$param->{maximum} = undef;
}
# 'criteria' is a required parameter.
if (not exists $param->{criteria}) {
carp "Parameter 'criteria' is required in data_validation()";
return -3;
}
# List of valid criteria types.
my %criteria_type = (
'between' => 0,
'not between' => 1,
'equal to' => 2,
'=' => 2,
'==' => 2,
'not equal to' => 3,
'!=' => 3,
'<>' => 3,
'greater than' => 4,
'>' => 4,
'less than' => 5,
'<' => 5,
'greater than or equal to' => 6,
'>=' => 6,
'less than or equal to' => 7,
'<=' => 7,
);
# Check for valid criteria types.
if (not exists $criteria_type{lc($param->{criteria})}) {
carp "Unknown criteria type '$param->{criteria}' for parameter " .
"'criteria' in data_validation()";
return -3;
}
else {
$param->{criteria} = $criteria_type{lc($param->{criteria})};
}
# 'Between' and 'Not between' criteria require 2 values.
if ($param->{criteria} == 0 || $param->{criteria} == 1) {
if (not exists $param->{maximum}) {
carp "Parameter 'maximum' is required in data_validation() " .
"when using 'between' or 'not between' criteria";
return -3;
}
}
else {
$param->{maximum} = undef;
}
# List of valid error dialog types.
my %error_type = (
'stop' => 0,
'warning' => 1,
'information' => 2,
);
# Check for valid error dialog types.
if (not exists $param->{error_type}) {
$param->{error_type} = 0;
}
elsif (not exists $error_type{lc($param->{error_type})}) {
carp "Unknown criteria type '$param->{error_type}' for parameter " .
"'error_type' in data_validation()";
return -3;
}
else {
$param->{error_type} = $error_type{lc($param->{error_type})};
}
# Convert date/times value if required.
if ($param->{validate} == 4 || $param->{validate} == 5) {
if ($param->{value} =~ /T/) {
my $date_time = $self->convert_date_time($param->{value});
if (!defined $date_time) {
carp "Invalid date/time value '$param->{value}' " .
"in data_validation()";
return -3;
}
else {
$param->{value} = $date_time;
}
}
if (defined $param->{maximum} && $param->{maximum} =~ /T/) {
my $date_time = $self->convert_date_time($param->{maximum});
if (!defined $date_time) {
carp "Invalid date/time value '$param->{maximum}' " .
"in data_validation()";
return -3;
}
else {
$param->{maximum} = $date_time;
}
}
}
# Set some defaults if they haven't been defined by the user.
$param->{ignore_blank} = 1 if !defined $param->{ignore_blank};
$param->{dropdown} = 1 if !defined $param->{dropdown};
$param->{show_input} = 1 if !defined $param->{show_input};
$param->{show_error} = 1 if !defined $param->{show_error};
# These are the cells to which the validation is applied.
$param->{cells} = [[$row1, $col1, $row2, $col2]];
# A (for now) undocumented parameter to pass additional cell ranges.
if (exists $param->{other_cells}) {
push @{$param->{cells}}, @{$param->{other_cells}};
}
# Store the validation information until we close the worksheet.
push @{$self->{_validations}}, $param;
}
###############################################################################
#
# _store_validation_count()
#
# Store the count of the DV records to follow.
#
# Note, this could be wrapped into _store_dv() but we may require separate
# handling of the object id at a later stage.
#
sub _store_validation_count {
my $self = shift;
my $dv_count = @{$self->{_validations}};
my $obj_id = -1;
return unless $dv_count;
$self->_store_dval($obj_id , $dv_count);
}
###############################################################################
#
# _store_validations()
#
# Store the data_validation records.
#
sub _store_validations {
my $self = shift;
return unless scalar @{$self->{_validations}};
for my $param (@{$self->{_validations}}) {
$self->_store_dv( $param->{cells},
$param->{validate},
$param->{criteria},
$param->{value},
$param->{maximum},
$param->{input_title},
$param->{input_message},
$param->{error_title},
$param->{error_message},
$param->{error_type},
$param->{ignore_blank},
$param->{dropdown},
$param->{show_input},
$param->{show_error},
);
}
}
###############################################################################
#
# _store_dval()
#
# Store the DV record which contains the number of and information common to
# all DV structures.
#
sub _store_dval {
my $self = shift;
my $record = 0x01B2; # Record identifier
my $length = 0x0012; # Bytes to follow
my $obj_id = $_[0]; # Object ID number.
my $dv_count = $_[1]; # Count of DV structs to follow.
my $flags = 0x0004; # Option flags.
my $x_coord = 0x00000000; # X coord of input box.
my $y_coord = 0x00000000; # Y coord of input box.
# Pack the record.
my $header = pack('vv', $record, $length);
my $data = pack('vVVVV', $flags, $x_coord, $y_coord, $obj_id, $dv_count);
$self->_append($header, $data);
}
###############################################################################
#
# _store_dv()
#
# Store the DV record that specifies the data validation criteria and options
# for a range of cells..
#
sub _store_dv {
my $self = shift;
my $record = 0x01BE; # Record identifier
my $length = 0x0000; # Bytes to follow
my $flags = 0x00000000; # DV option flags.
my $cells = $_[0]; # Aref of cells to which DV applies.
my $validation_type = $_[1]; # Type of data validation.
my $criteria_type = $_[2]; # Validation criteria.
my $formula_1 = $_[3]; # Value/Source/Minimum formula.
my $formula_2 = $_[4]; # Maximum formula.
my $input_title = $_[5]; # Title of input message.
my $input_message = $_[6]; # Text of input message.
my $error_title = $_[7]; # Title of error message.
my $error_message = $_[8]; # Text of input message.
my $error_type = $_[9]; # Error dialog type.
my $ignore_blank = $_[10]; # Ignore blank cells.
my $dropdown = $_[11]; # Display dropdown with list.
my $input_box = $_[12]; # Display input box.
my $error_box = $_[13]; # Display error box.
my $ime_mode = 0; # IME input mode for far east fonts.
my $str_lookup = 0; # See below.
# Set the string lookup flag for 'list' validations with a string array.
if ($validation_type == 3 && ref $formula_1 eq 'ARRAY') {
$str_lookup = 1;
}
# The dropdown flag is stored as a negated value.
my $no_dropdown = not $dropdown;
# Set the required flags.
$flags |= $validation_type;
$flags |= $error_type << 4;
$flags |= $str_lookup << 7;
$flags |= $ignore_blank << 8;
$flags |= $no_dropdown << 9;
$flags |= $ime_mode << 10;
$flags |= $input_box << 18;
$flags |= $error_box << 19;
$flags |= $criteria_type << 20;
# Pack the validation formulas.
$formula_1 = $self->_pack_dv_formula($formula_1);
$formula_2 = $self->_pack_dv_formula($formula_2);
# Pack the input and error dialog strings.
$input_title = $self->_pack_dv_string($input_title, 32 );
$error_title = $self->_pack_dv_string($error_title, 32 );
$input_message = $self->_pack_dv_string($input_message, 255);
$error_message = $self->_pack_dv_string($error_message, 255);
# Pack the DV cell data.
my $dv_count = scalar @$cells;
my $dv_data = pack 'v', $dv_count;
for my $range (@$cells) {
$dv_data .= pack 'vvvv', $range->[0],
$range->[2],
$range->[1],
$range->[3];
}
# Pack the record.
my $data = pack 'V', $flags;
$data .= $input_title;
$data .= $error_title;
$data .= $input_message;
$data .= $error_message;
$data .= $formula_1;
$data .= $formula_2;
$data .= $dv_data;
my $header = pack('vv', $record, length $data);
$self->_append($header, $data);
}
###############################################################################
#
# _pack_dv_string()
#
# Pack the strings used in the input and error dialog captions and messages.
# Captions are limited to 32 characters. Messages are limited to 255 chars.
#
sub _pack_dv_string {
my $self = shift;
my $string = $_[0];
my $max_length = $_[1];
my $str_length = 0;
my $encoding = 0;
# The default empty string is "\0".
if (!defined $string || $string eq '') {
$string = "\0";
}
# Excel limits DV captions to 32 chars and messages to 255.
if (length $string > $max_length) {
$string = substr($string, 0, $max_length);
}
$str_length = length $string;
# Handle utf8 strings in perl 5.8.
if ($] >= 5.008) {
require Encode;
if (Encode::is_utf8($string)) {
$string = Encode::encode("UTF-16LE", $string);
$encoding = 1;
}
}
return pack('vC', $str_length, $encoding) . $string;
}
###############################################################################
#
# _pack_dv_formula()
#
# Pack the formula used in the DV record. This is the same as an cell formula
# with some additional header information. Note, DV formulas in Excel use
# relative addressing (R1C1 and ptgXxxN) however we use the Formula.pm's
# default absolute addressing (A1 and ptgXxx).
#
sub _pack_dv_formula {
my $self = shift;
my $formula = $_[0];
my $encoding = 0;
my $length = 0;
my $unused = 0x0000;
my @tokens;
# Return a default structure for unused formulas.
if (!defined $formula || $formula eq '') {
return pack('vv', 0, $unused);
}
# Pack a list array ref as a null separated string.
if (ref $formula eq 'ARRAY') {
$formula = join "\0", @$formula;
$formula = qq("$formula");
}
# Strip the = sign at the beginning of the formula string
$formula =~ s(^=)();
# Parse the formula using the parser in Formula.pm
my $parser = $self->{_parser};
# In order to raise formula errors from the point of view of the calling
# program we use an eval block and re-raise the error from here.
#
eval { @tokens = $parser->parse_formula($formula) };
if ($@) {
$@ =~ s/\n$//; # Strip the \n used in the Formula.pm die()
croak $@; # Re-raise the error
}
else {
# TODO test for non valid ptgs such as Sheet2!A1
}
# Force 2d ranges to be a reference class.
s/_range2d/_range2dR/ for @tokens;
s/_name/_nameR/ for @tokens;
# Parse the tokens into a formula string.
$formula = $parser->parse_tokens(@tokens);
return pack('vv', length $formula, $unused) . $formula;
}
1;
__END__
=encoding latin1
=head1 NAME
Worksheet - A writer class for Excel Worksheets.
=head1 SYNOPSIS
See the documentation for Spreadsheet::WriteExcel
=head1 DESCRIPTION
This module is used in conjunction with Spreadsheet::WriteExcel.
=head1 AUTHOR
John McNamara jmcnamara@cpan.org
=head1 COPYRIGHT
Copyright MM-MMX, John McNamara.
All Rights Reserved. This module is free software. It may be used, redistributed and/or modified under the same terms as Perl itself.