File Coverage

blib/lib/Excel/ValueWriter/XLSX.pm

Criterion	Covered	Total	%
statement	217	229	94.7
branch	40	52	76.9
condition	22	32	68.7
subroutine	38	39	97.4
pod	5	21	23.8
total	322	373	86.3

use 5.014;
package Excel::ValueWriter::XLSX;
use strict;
use warnings;
use utf8;
use Archive::Zip          qw/AZ_OK COMPRESSION_LEVEL_DEFAULT/;
use Scalar::Util          qw/looks_like_number/;
use List::Util            qw/none/;
use Params::Validate      qw/validate_with SCALAR SCALARREF UNDEF/;
use POSIX                 qw/strftime/;
use Date::Calc            qw/Delta_Days/;
use Carp                  qw/croak/;
use Encode                qw/encode_utf8/;

our $VERSION = '1.04';

#======================================================================
# GLOBALS
#======================================================================

my $DATE_STYLE = 1;                        # 0-based index into the  format for dates ..
                                           # .. defined in the styles() method

my $SHEET_NAME = qr(^[^\\/?*\[\]]{1,31}$); # valid sheet names: <32 chars, no chars \/?*[]
my $TABLE_NAME = qr(^\w{3,}$);             # valid table names: >= 3 chars, no spaces


# specification in Params::Validate format for checking parameters to the new() method
my %params_spec = (

  # date_regex : for identifying dates in data cells. Should capture into $+{d}, $+{m} and $+{y}.
  date_regex        => {type => SCALARREF|UNDEF, optional => 1, default =>
                         qr[^(?: (?\d\d?)    \. (?\d\d?) \. (?\d\d\d\d)  # dd.mm.yyyy
                               | (?\d\d\d\d) -  (?\d\d?) -  (?\d\d?)     # yyyy-mm-dd
                               | (?\d\d?)    /  (?\d\d?) /  (?\d\d\d\d)) # mm/dd/yyyy
                             $]x},

  # bool_regex : for identifying booleans in data cells. If true, should capture into $1
  bool_regex        => {type => SCALARREF|UNDEF, optional => 1, default => qr[^(?:(TRUE)|FALSE)$]},

  compression_level => {type => SCALAR, regex => qr/^\d$/, optional => 1, default => COMPRESSION_LEVEL_DEFAULT},

 );


my %entity       = ( '<' => '<', '>' => '>', '&' => '&' );
my $entity_regex = do {my $chars = join "", keys %entity; qr/[$chars]/};


#======================================================================
# CONSTRUCTOR
#======================================================================

sub new {
  my $class = shift;

  # check parameters and create $self
  my $self = validate_with( params      => \@_,
                            spec        => \%params_spec,
                            allow_extra => 0,
                           );

  # initial values for internal data structures
  $self->{sheets}                = []; # array of sheet names
  $self->{tables}                = []; # array of table names
  $self->{shared_string}         = {}; # ($string => $string_index)
  $self->{n_strings_in_workbook} = 0;  # total nb of strings (including duplicates)
  $self->{last_string_id}        = 0;  # index for the next shared string
  $self->{defined_names}         = {}; # ($name => [$formula, $comment])

  # immediately open a Zip archive
  $self->{zip} = Archive::Zip->new;

  # return the constructed object
  bless $self, $class;
}


#======================================================================
# GATHERING DATA
#======================================================================


sub add_sheet {
  # 3rd parameter ($headers) may be omitted -- so we insert an undef if necessary
  splice @_, 3, 0, undef if @_ < 5;

  # now we can parse the parameters
  my ($self, $sheet_name, $table_name, $headers, $code_or_array) = @_;

  # check if the given sheet name is valid
  $sheet_name =~ $SHEET_NAME
    or croak "'$sheet_name' is not a valid sheet name";
  none {$sheet_name eq $_} @{$self->{sheets}}
    or croak "this workbook already has a sheet named '$sheet_name'";

  # local copies for convenience
  my $date_regex = $self->{date_regex};
  my $bool_regex = $self->{bool_regex};

  # iterator for generating rows; either received as argument or built as a closure upon an array
  my $next_row
    = ref $code_or_array eq 'CODE'  ? $code_or_array
    : ref $code_or_array ne 'ARRAY' ? croak 'add_sheet() : missing or invalid $rows argument'
    : do {my $i = 0; sub { $i < @$code_or_array ? $code_or_array->[$i++] : undef}};

  # if $headers were not given explicitly, the first row will do
  $headers //= $next_row->();

  # array of column references in A1 Excel notation
  my @col_letters = ('A'); # this array will be expanded on demand in the loop below

  # register the sheet name
  push @{$self->{sheets}}, $sheet_name;

  # start building XML for the sheet
  my @xml = (
    q{},
    q{
              q{ xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships">},
    q{},
    );

  # loop over rows and columns
  my $row_num = 0;
 ROW:
  for (my $row = $headers; $row; $row = $next_row->()) {
    $row_num++;
    my $last_col = @$row or next ROW;
    my @cells;

  COLUMN:
    foreach my $col (0 .. $last_col-1) {

      # if this column letter is not known yet, compute it using Perl's increment op on strings
      my $col_letter = $col_letters[$col]
                   //= do {my $prev_letter = $col_letters[$col-1]; ++$prev_letter};

      # get the value; if the cell is empty, no need to write it into the XML
      my $val = $row->[$col];
      defined $val and length $val or next COLUMN;

      # choose XML attributes and inner value
      # NOTE : for perl, looks_like_number( "INFINITY") is TRUE! Hence the test $val !~ /^\pL/
      (my $tag, my $attrs, $val)
        = looks_like_number($val) && $val !~ /^\pL/ ? (v => ""                  , $val                          )
        : $date_regex && $val =~ $date_regex        ? (v => qq{ s="$DATE_STYLE"}, n_days($+{y}, $+{m}, $+{d})   )
        : $bool_regex && $val =~ $bool_regex        ? (v => qq{ t="b"}          , $1 ? 1 : 0                    )
        : $val =~ /^=/                              ? (f => "",                   escape_formula($val)          )
        :                                             (v => qq{ t="s"}          , $self->add_shared_string($val));

      # add the new XML cell
      my $cell = sprintf qq{<%s>%s}, $col_letter, $row_num, $attrs, $tag, $val, $tag;
      push @cells, $cell;
    }

    # generate the row XML and add it to the sheet
    my $row_xml = join "", qq{}, @cells, qq{};
    push @xml, $row_xml;
  }

  # close sheet data
  push @xml, q{};

  # if required, add the table corresponding to this sheet into the zip archive, and refer to it in XML
  my @table_rels;
  if ($table_name && $row_num) {
    my $table_id = $self->add_table($table_name, $col_letters[-1], $row_num, @$headers);
    push @table_rels, $table_id;
    push @xml, q{};
  }

  # close the worksheet xml
  push @xml, q{};

  # insert the sheet and its rels into the zip archive
  my $sheet_id   = $self->n_sheets;
  my $sheet_file = "sheet$sheet_id.xml";
  $self->{zip}->addString(encode_utf8(join("", @xml)),
                          "xl/worksheets/$sheet_file",
                          $self->{compression_level});
  $self->{zip}->addString($self->worksheet_rels(@table_rels),
                          "xl/worksheets/_rels/$sheet_file.rels",
                          $self->{compression_level});

  return $sheet_id;
}



sub add_sheets_from_database {
  my ($self, $dbh, $sheet_prefix, @table_names) = @_;

  # in absence of table names, get them from the database metadata
  if (!@table_names) {
    my $tables = $dbh->table_info(undef, undef, undef, 'TABLE')->fetchall_arrayref({});
    @table_names = map {$_->{TABLE_NAME}} @$tables;
  }

  $sheet_prefix //= "S.";

  foreach my $table (@table_names) {
    my $sth = $dbh->prepare("select * from $table");
    $sth->execute;
    my $headers = $sth->{NAME};
    my $rows    = $sth->fetchall_arrayref;
    $self->add_sheet("$sheet_prefix$table", $table, $headers, $rows);
  }
}



sub add_shared_string {
  my ($self, $string) = @_;

  # single quote before an initial equal sign is ignored (escaping the '=' like in Excel)
  $string =~ s/^'=/=/;

  # keep a global count of how many strings are in the workbook
  $self->{n_strings_in_workbook}++;

  # if that string was already stored, return its id, otherwise create a new id
  $self->{shared_strings}{$string} //= $self->{last_string_id}++;
}



sub add_table {
  my ($self, $table_name, $last_col, $last_row, @col_names) = @_;

  # check if the given table name is valid
  $table_name =~ $TABLE_NAME
    or croak "'$table_name' is not a valid table name";
  none {$table_name eq $_} @{$self->{tables}}
    or croak "this workbook already has a table named '$table_name'";

  # register this table
  push @{$self->{tables}}, $table_name;
  my $table_id = $self->n_tables;

  # build column headers from first data row
  unshift @col_names, undef; # so that the first index is at 1, not 0
  my @columns = map {qq{}} 1 .. $#col_names;

  # Excel range of this table
  my $ref = "A1:$last_col$last_row";

  # assemble XML for the table
  my @xml = (
    qq{},
    qq{




252




 





 





 





 





 





 



          qq{ id="$table_id" displayName="$table_name" ref="$ref" totalsRowShown="0">}, 




253




 





 





 





 





 





 



     qq{}, 




254




 





 





 





 





 





 



     qq{}, 




255




 





 





 





 





 





 



     @columns, 




256




 





 





 





 





 





 



     qq{}, 




257




 





 





 





 





 





 



     qq{}, 




258




 





 





 





 





 





 



     qq{},
         qq{ id="$table_id" displayName="$table_name" ref="$ref" totalsRowShown="0">},
    qq{},
    qq{},
    @columns,
    qq{},
    qq{},
    qq{
   );

  # insert into the zip archive
  $self->{zip}->addString(encode_utf8(join "", @xml),
                          "xl/tables/table$table_id.xml",
                          $self->{compression_level});

  return $table_id;
}


sub add_defined_name {
  my ($self, $name, $formula, $comment) = @_;

  $name && $formula                        or croak 'add_defined_name($name, $formula): empty argument';
  not exists $self->{defined_names}{$name} or croak "add_defined_name(): name '$name' already in use";
  $self->{defined_names}{$name} = [$formula, $comment];
}


sub worksheet_rels {
  my ($self, $table_id) = @_;

  my @rels;
  push @rels, "officeDocument/2006/relationships/table" => "../tables/table$table_id.xml" if $table_id;
  return $self->relationships(@rels);
}


#======================================================================
# BUILDING THE ZIP CONTENTS
#======================================================================

sub save_as {
  my ($self, $target) = @_;

  # assemble all parts within the zip, except sheets and tables that were already added previously
  my $zip = $self->{zip};
  $zip->addString($self->content_types,  "[Content_Types].xml"        , $self->{compression_level});
  $zip->addString($self->core,           "docProps/core.xml"          , $self->{compression_level});
  $zip->addString($self->app,            "docProps/app.xml"           , $self->{compression_level});
  $zip->addString($self->workbook,       "xl/workbook.xml"            , $self->{compression_level});
  $zip->addString($self->_rels,          "_rels/.rels"                , $self->{compression_level});
  $zip->addString($self->workbook_rels,  "xl/_rels/workbook.xml.rels" , $self->{compression_level});
  $zip->addString($self->shared_strings, "xl/sharedStrings.xml"       , $self->{compression_level});
  $zip->addString($self->styles,         "xl/styles.xml"              , $self->{compression_level});

  # write the Zip archive
  my $write_result = ref $target ? $zip->writeToFileHandle($target) : $zip->writeToFileNamed($target);
  $write_result == AZ_OK
    or croak "could not save Zip archive into " . (ref($target) || $target);
}


sub _rels {
  my ($self) = @_;

  return $self->relationships("officeDocument/2006/relationships/extended-properties" => "docProps/app.xml",
                              "package/2006/relationships/metadata/core-properties"   => "docProps/core.xml",
                              "officeDocument/2006/relationships/officeDocument"      => "xl/workbook.xml");
}

sub workbook_rels {
  my ($self) = @_;

  my @rels = map {("officeDocument/2006/relationships/worksheet"     => "worksheets/sheet$_.xml")}
                 1 .. $self->n_sheets;
  push @rels,      "officeDocument/2006/relationships/sharedStrings" => "sharedStrings.xml",
                   "officeDocument/2006/relationships/styles"        => "styles.xml";

  return $self->relationships(@rels);
}


sub workbook {
  my ($self) = @_;

  # opening XML
  my @xml = (
    qq{},
    qq{
             qq{ xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships">},
    );

  # references to the worksheets
  push @xml, q{};
  my $sheet_id = 1;
  foreach my $sheet_name (@{$self->{sheets}}) {
    push @xml, qq{};
    $sheet_id++;
  }
  push @xml, q{};

  if (my $names = $self->{defined_names}) {
    push @xml, q{};
    while (my ($name, $content) = each %$names) {
      my $attrs = qq{name="$name"};
      $attrs   .= qq{ comment="$content->[1]"} if $content->[1];
      $content->[0] =~ s/($entity_regex)/$entity{$1}/g;
      push @xml, qq{$content->[0]};
    }
    push @xml, q{};
  }


  # closing XML
  push @xml, q{};

  return encode_utf8(join "", @xml);
}


sub content_types {
  my ($self) = @_;

  my $spreadsheetml = "application/vnd.openxmlformats-officedocument.spreadsheetml";

  my @sheets_xml
    = map {qq{}} 1 .. $self->n_sheets;

  my @tables_xml
    = map {qq{  }} 1 .. $self->n_tables;

  my @xml = (
    qq{},
    qq{},
    qq{},
    qq{},
    qq{},
    qq{},
    qq{},
    qq{},
    qq{},
    @sheets_xml,
    @tables_xml,
    qq{},
   );

  return join "", @xml;
}


sub core {
  my ($self) = @_;

  my $now = strftime "%Y-%m-%dT%H:%M:%SZ", gmtime;

  my @xml = (
    qq{},
    qq{
                      qq{ xmlns:dc="http://purl.org/dc/elements/1.1/"},
                      qq{ xmlns:dcterms="http://purl.org/dc/terms/"},
                      qq{ xmlns:dcmitype="http://purl.org/dc/dcmitype/"},
                      qq{ xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">},
    qq{$now},
    qq{$now},
    qq{},
   );

  return join "", @xml;
}

sub app {
  my ($self) = @_;

  my @xml = (
    qq{},
    qq{
               qq{ xmlns:vt="http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes">},
    qq{Microsoft Excel},
    qq{},
   );

  return join "", @xml;
}




sub shared_strings {
  my ($self) = @_;

  # array of XML nodes for each shared string
  my @si_nodes;
  $si_nodes[$self->{shared_strings}{$_}] = si_node($_) foreach keys %{$self->{shared_strings}};

  # assemble XML
  my @xml = (
    qq{},
    qq{
         qq{ count="$self->{n_strings_in_workbook}" uniqueCount="$self->{last_string_id}">},
    @si_nodes,
    qq{},
   );

  return encode_utf8(join "", @xml);
}


sub styles {
  my ($self) = @_;

  # minimal stylesheet
  # style "1" will be used for displaying dates; it uses the default numFmtId for dates, which is 14 (Excel builtin).
  # other nodes are empty but must be present
  my @xml = (
    q{},
    q{},
    q{},
    q{},
    q{},
    q{},
    q{},
    q{},
    q{},
   );

  my $xml = join "", @xml;

  return $xml;
}


#======================================================================
# UTILITY METHODS
#======================================================================

sub relationships {
  my ($self, @rels) = @_;

  # build a "rel" file from a list of relationships
  my @xml = (
    qq{},
    qq{},
   );

  my $id = 1;
  while (my ($type, $target) = splice(@rels, 0, 2)) {
    push @xml, qq{};
    $id++;
  }

  push @xml, qq{};

  return join "", @xml;
}


sub n_sheets {
  my ($self) = @_;
  return scalar @{$self->{sheets}};
}

sub n_tables {
  my ($self) = @_;
  return scalar @{$self->{tables}};
}


#======================================================================
# UTILITY ROUTINES
#======================================================================


sub si_node { # build XML node for a single shared string
  my ($string) = @_;

  # escape XML entities
  $string =~ s/($entity_regex)/$entity{$1}/g;


  # Excel escapes control characters with _xHHHH_ and also escapes any
  # literal strings of that type by encoding the leading underscore. So
  # "\0" -> _x0000_ and "_x0000_" -> _x005F_x0000_.
  # The following substitutions deal with those cases.
  # This code is borrowed from Excel::Writer::XLSX::Package::SharedStrings -- thank you, John McNamara

  # Escape the escape.
  $string =~ s/(_x[0-9a-fA-F]{4}_)/_x005F$1/g;

  # Convert control character to the _xHHHH_ escape.
  $string =~ s/([\x00-\x08\x0B-\x1F])/sprintf "_x%04X_", ord($1)/eg;

  my $maybe_preserve_space = $string =~ /^\s|\s$/ ? ' xml:space="preserve"' : '';
  my $node = qq{$string};

  return $node;
}

sub escape_formula {
  my ($string) = @_;

  $string =~ s/^=//;
  $string =~ s/($entity_regex)/$entity{$1}/g;
  return $string;
}


sub n_days {
  my ($y, $m, $d) = @_;

  # convert the given date into a number of days since 1st January 1900
  my $n_days = Delta_Days(1900, 1, 1, $y, $m, $d) + 1;
  my $is_after_february_1900 = $n_days > 59;
  $n_days += 1 if $is_after_february_1900; # because Excel wrongly treats 1900 as a leap year

  return $n_days;
}





1;

__END__