File Coverage

blib/lib/Excel/ValueWriter/XLSX.pm

Criterion	Covered	Total	%
statement	260	267	97.3
branch	51	68	75.0
condition	41	67	61.1
subroutine	45	46	97.8
pod	5	20	25.0
total	402	468	85.9

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 blessed/;
use List::Util            qw/none/;
use POSIX                 qw/strftime/;
use Date::Calc            qw/Delta_Days/;
use Carp                  qw/croak/;
use Encode                qw/encode_utf8/;
use Data::Domain 1.16     qw/:all/;
use Try::Tiny;

our $VERSION = '1.10';

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

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

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

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

#======================================================================
# SIGNATURES FOR CONTROLLING ARGS TO PUBLIC METHODS
#======================================================================

my $sig_for_new = Struict( # Struict = strict Struct .. not a typo!

  # date_regex : for identifying dates in data cells. Should capture into $+{d}, $+{m} and $+{y}.
  date_regex        => Regexp(-if_absent =>
                         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        => Regexp(-if_absent => qr[^(?:(TRUE)|FALSE)$]),

  # ZIP compression level
  compression_level => Int(-range => [1, 9], -if_absent => COMPRESSION_LEVEL_DEFAULT),
 )->meth_signature;


my $sig_for_add_sheet = List(
  String(-name => 'sheet_name', -regex => $RX_SHEET_NAME),
  String(-name => 'table_name', -regex => $RX_TABLE_NAME, -optional => 1),
  List  (-name => 'headers',    -all => String,           -optional => 1),
  One_of(-name => 'rows_maker', -options => [List,                                      # an array of rows, or
                                             Coderef,                                   # a row generator coderef, or
                                             Obj(-isa => 'DBI::st'),                    # a DBI statement, or
                                             Obj(-isa => 'DBIx::DataModel::Statement'), # a DBIx::DataModel statement
                                            ]),
  Struict(-name => 'options', -optional => 1, -fields => {
      cols => One_of(List(-all => Num),
                     List(-all => Struct(width => Num(-optional => 1),
                                         style => Int(-optional => 1),
                                         min   => Int(-optional => 1),
                                         max   => Int(-optional => 1))))
    }),
 )->meth_signature;

my $sig_for_add_sheets_from_database = List(-items => [Obj   (-isa     => 'DBI::db'),
                                                       String(-default => "S.")],
                                            -all   => String,
 )->meth_signature;

my $sig_for_add_defined_name = List(String(-name => "name"),
                                    String(-name => "formula"),
                                    String(-name => "comments", -optional => 1),
  )->meth_signature;



my $sig_for_save_as = One_of(String,
                             Whatever(-does => 'IO'),
  )->meth_signature;



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

sub new {
  my ($class, %self) = &$sig_for_new;

  # initial values for internal data structures (constructor args cannot initialize those)
  $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 {
  # the 3rd parameter ($headers) may be omitted -- so we insert an undef if necessary
  splice @_, 3, 0, undef if @_ < 5 or @_ == 5 && (ref $_[4] // '') eq 'HASH';

  # now we can parse the parameters
  my ($self, $sheet_name, $table_name, $headers, $rows_maker, $options) = &$sig_for_add_sheet;

  # register the sheet name
  none {$sheet_name eq $_} @{$self->{sheets}}
    or croak "this workbook already has a sheet named '$sheet_name'";
  push @{$self->{sheets}}, $sheet_name;

  # iterator for generating rows
  my $row_iterator = $self->_build_row_iterator($rows_maker, \$headers);

  # build inner XML
  my ($xml, $last_row, $last_col) = $self->_build_rows($headers, $row_iterator, $table_name);

  # add XML preamble and close sheet data
  my $ref = $last_row >= 1 ? "A1:$last_col$last_row" : "A1"; # range of cells in sheet
  my $preamble = join "",
    q{},
    q{
              q{ xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships">},
    qq{};
  $preamble .= $self->_xml_for_options($options) if $options;
  $preamble .= q{};
  substr $xml, 0, 0, $preamble;
  $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 && $headers) {
    my $table_id = $self->_add_table($table_name, $last_col, $last_row, @$headers);
    push @table_rels, $table_id;
    $xml .= q{};
  }

  # close the worksheet xml
  $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->add_string_to_zip(encode_utf8($xml),                  "xl/worksheets/$sheet_file"           );
  $self->add_string_to_zip($self->worksheet_rels(@table_rels), "xl/worksheets/_rels/$sheet_file.rels");

  return $sheet_id;
}

sub _build_row_iterator {
  my ($self, $rows_maker, $headers_ref) = @_;

  my $iterator;

  my $ref = ref $rows_maker;
  if ($ref && $ref eq 'CODE') {
    $iterator  = $rows_maker;
    $$headers_ref //= $iterator->();
  }
  elsif ($ref && $ref eq 'ARRAY') {
    my $i = 0;
    $iterator  = sub { $i < @$rows_maker ? $rows_maker->[$i++] : undef};
    $$headers_ref //= $iterator->();
  }
  elsif (blessed $rows_maker && $rows_maker->isa('DBI::st')) {
    $rows_maker->{Executed}
      or croak '->add_sheet(..., $sth) : the statement handle must be executed (call the $sth->execute method)';
    $iterator  = sub { $rows_maker->fetchrow_arrayref};
    $$headers_ref //= $rows_maker->{NAME}; # see L
  }
  elsif (blessed $rows_maker && $rows_maker->isa('DBIx::DataModel::Statement')) {
    DBIx::DataModel->VERSION >= 3.0
      or croak 'add_sheet(.., $statement) : requires DBIx::DataModel >= 3.0; your version is ', DBIx::DataModel->VERSION;
    $$headers_ref //= $rows_maker->sth->{NAME};
    $iterator  = sub {my $row = $rows_maker->next; return $row ? [@{$row}{@$$headers_ref}] : ()};
  }
  else {
    croak 'add_sheet() : missing or invalid last argument ($rows_maker)';
  }

  return $iterator;
}

sub _build_rows {
  my ($self, $headers, $row_iterator, $table_name) = @_;

  my $xml = "";

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

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

  # loop over rows and columns
  my $row_num = 0;
 ROW:
  for (my $row = $headers; $row; $row = $row_iterator->()) {
    $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 (so 'AA' comes after 'Z')
      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;
      my $n_days; # in case we need to parse a date

      # 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
                      && is_valid_date(\%+, \$n_days)  ? (v => qq{ s="$DATE_STYLE"}, $n_days                        )
        : $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 = qq{<$tag>$val};
      push @cells, $cell;
    }

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

  # if this sheet contains an Excel table, make sure there is at least one data row
  ++$row_num and $xml .= qq{}
    if $table_name && $row_num == 1;

  return ($xml, $row_num, $col_letters[-1]);
}



sub _xml_for_options {
  my ($self, $options) = @_;

  # currently there is only one option 'cols'. Handled below in a separate sub for better clarity.
  return $self->_xml_for_cols_option($options->{cols});
}


sub _xml_for_cols_option {
  my ($self, $cols) = @_;

  my $xml = "";
  my $next_col_num = 1;
  foreach my $col (@$cols) {
    # build attributes for the node
    my %attrs = ref $col ? %$col : (width => $col); # cols => [6, ...] is just syntactic sugar for => [{width => 6}, ...]
    $attrs{$_} //= $next_col_num for qw/min max/;   # colrange to which this
    $attrs{customWidth} //= 1 if $attrs{width};     # tells Excel that the width is not automatic

    # generate XML from attributes
    $xml .= join(" ", "";

    # compute index of next column
    $next_col_num = $attrs{max} + 1;
  }
  $xml .= "";

  return $xml;
}


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

  # 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;
  }

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



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) = @_;

  # register this table
  none {$table_name eq $_} @{$self->{tables}}
    or croak "this workbook already has a table named '$table_name'";
  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{




346




 





 





 





 





 





 



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




347




 





 





 





 





 





 



     qq{}, 




348




 





 





 





 





 





 



     qq{}, 




349




 





 





 





 





 





 



     @columns, 




350




 





 





 





 





 





 



     qq{}, 




351




 





 





 





 





 





 



     qq{}, 




352




 





 





 





 





 





 



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

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

  return $table_id;
}


sub add_defined_name {
  my ($self, $name, $formula, $comment) = &$sig_for_add_defined_name;

  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) = &$sig_for_save_as;

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

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


sub add_string_to_zip {
  my ($self, $content, $name) = @_;

  $self->{zip}->addString($content, $name, $self->{compression_level});
}



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 is_valid_date {
  my ($named_captures, $n_days_ref) = @_;
  my ($y, $m, $d) = @{$named_captures}{qw/y m d/};

  # years before 1900 can't be handled by Excel
  return undef if $y < 1900;

  # convert the given date into a number of days since 1st January 1900.
  my $return_status = try   {$$n_days_ref = Delta_Days(1900, 1, 1, $y, $m, $d) + 1;
                             my $is_after_february_1900 = $$n_days_ref > 59;
                             $$n_days_ref += 1 if $is_after_february_1900; # because Excel wrongly treats 1900 as a leap year
                             1; # success
                            };
                             # no catch .. undef if failure (invalid date)

  return $return_status;

  # NOTE : invalid dates will be inserted as Excel strings
}


1;

__END__