File Coverage

blib/lib/MsOffice/Word/HTML/Writer.pm

Criterion	Covered	Total	%
statement	159	187	85.0
branch	27	58	46.5
condition	9	17	52.9
subroutine	27	29	93.1
pod	10	10	100.0
total	232	301	77.0

package MsOffice::Word::HTML::Writer;
use utf8;
use warnings;
use strict;
use MIME::Base64      qw/encode_base64/;
use MIME::Types;
use Carp;
use Params::Validate  qw/validate SCALAR HASHREF CODEREF UNDEF/;
use Scalar::Util      qw/looks_like_number openhandle/;
use Encode 2.12       qw/encode/;

our $VERSION = '1.10';

sub new {
  my $class = shift;

  # specification for validating named parameters
  my $param_spec = {
    title           => {type => SCALAR,               default  => "Document generated by MsOffice::Word::HTML::Writer"},
    head            => {type => SCALAR,               default  => ""     },
    hf_head         => {type => SCALAR,               default  => ""     },
    WordDocument    => {type => HASHREF,              optional => 1      },
    charset         => {type => SCALAR,               default  => 'utf-8'},
    encode_fallback => {type => SCALAR|CODEREF|UNDEF, optional => 1      },
   };

  # build instance
  my $self = {validate(@_, $param_spec)};

  # default encode fallback : let native characters pass through if charset is not utf-8
  $self->{encode_fallback} = sub {no utf8; sprintf "%c", shift} # see L
    unless exists $self->{encode_fallback} or $self->{charset} eq 'utf-8';

  # initializing internal slots
  $self->{MIME_parts} = [];
  $self->{sections}   = [{}];

  # returning a blessed object
  bless $self, $class;
}


sub create_section {
  my $self = shift;

  # validate named parameters
  my $param_spec = {page => {type => HASHREF, optional => 1}};
  $param_spec->{$_} = {type => SCALAR, optional => 1}
    for qw/header footer first_header first_footer new_page/;
  my %params = validate(@_, $param_spec);

  # if first automatic section is empty, delete it
  $self->{sections} = []
    if scalar(@{$self->{sections}}) == 1 && !$self->{sections}[0]{content};

  # add the new section
  push @{$self->{sections}}, \%params;
}


sub write {
  my $self = shift;

  # add html arguments to current section content
  $self->{sections}[-1]{content} .= join ("", @_);
}



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

  croak '->save_as($target) : $target is empty' if !$file_or_handle;

  my $fh;
  if (openhandle($file_or_handle)) {
    $fh = $file_or_handle;
    binmode($fh, ':raw');
  }
  else {
    # default extension is ".doc"
    $file_or_handle .= ".doc" unless $file_or_handle =~ /\.\w{1,5}$/;

    open $fh, ">:raw", $file_or_handle
      or croak "could not open >$file_or_handle: $!";
  }

  # write file contents
  my $octets = encode($self->{charset}, $self->content, $self->{encode_fallback});
  print $fh $octets;
  close $fh;

  return $file_or_handle;
}


sub attach {
  my ($self, $name, $open1, $open2, @other) = @_;

  # open a handle to the attachment (need to dispatch according to number
  # of args, because perlfunc/open() has complex prototyping behaviour)
  my $fh;
  if (@other) {
    open $fh, $open1, $open2, @other
      or croak "open $open1, $open2, @other : $!";
  }
  elsif ($open2) {
    open $fh, $open1, $open2
      or croak "open $open1, $open2 : $!";
  }
  else {
    open $fh, $open1
      or croak "open $open1 : $!";
  }

  # slurp the content
  binmode($fh) unless $name =~ /\.(html?|css|te?xt|rtf)$/i;
  local $/;
  my $attachment = <$fh>;

  # add the attachment (filename and content)
  push @{$self->{MIME_parts}}, ["files/$name", $attachment];
}


sub page_break {
  my ($self) = @_;
  return qq{\n};
}


sub tab {
  my ($self, $n_tabs) = @_;
  $n_tabs ||= 1;
  return qq{};
}

sub field {
  my ($self, $fieldname, $args, $content, $prevent_html_entity_encoding) = @_;

  for ($args, $content) {
    $_ ||= "";                              # undef replaced by empty string
    s/&/&/g,  s//>/g   # replace HTML entities
      unless $prevent_html_entity_encoding;
  }

  my $field;

  # when args : long form of field encoding
  if ($args) {
    my $space = qq{ };
    $field = qq{}
           . $space . $fieldname . $space . $args
           . qq{}
           . $content
           . qq{};
  }
  # otherwise : short form of field encoding
  else {
    $field = qq{$content};
  }

  return $field;
}

sub quote {
  my ($self, $text, $prevent_html_entity_encoding) = @_;
  my $args = $text;
  $args =~ s/"/\\"/g;
  $args = qq{"$args"};
  $args =~ s/"/"/g;
  return $self->field('QUOTE', $args, $text, $prevent_html_entity_encoding);
}



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

  # separator for parts in MIME document
  my $boundary = qw/__NEXT_PART__/;

  # MIME multipart header
  my $mime = qq{MIME-Version: 1.0\n}
           . qq{Content-Type: multipart/related; boundary="$boundary"\n\n}
           . qq{MIME document generated by MsOffice::Word::HTML::Writer\n\n};

  # generate each part (main document must be first)
  my @parts = $self->_MIME_parts;
  my $filelist = $self->_filelist(@parts);
  for my $pair ($self->_main, @parts, $filelist) {
    my ($filename, $content) = @$pair;
    my $mime_type = MIME::Types->new->mimeTypeOf($filename) || '';
    my ($encoding, $encoded);
    if ($mime_type =~ /^text|xml$/) {
      # no need for Windows-style end-of-lines of shape CRLF
      $content  =~ s/\r\n/\n/g;

      # if charset is not utf-8, wide chars are encoded as numerical HTML entities
      $content  =~ s/([^\x{0}-\x{FF}])/'&#'.ord($1).';'/eg unless $self->{charset} eq 'utf-8';

      # simple-minded MIME quoted-printable encoding
      $encoding = 'quoted-printable';
      ($encoded = $content)  =~ s/=/=3D/g;
      $mime_type .= qq{; charset="$self->{charset}"};
    }
    else {
      $encoding = 'base64';
      $encoded  = encode_base64($content);
    }

    $mime .= qq{--$boundary\n}
          .  qq{Content-Location: file:///C:/foo/$filename\n}
          .  qq{Content-Transfer-Encoding: $encoding\n}
          .  qq{Content-Type: $mime_type\n\n}
          .  $encoded
          . "\n";
  }

  # close last MIME part
  $mime .= "--$boundary--\n";

  return $mime;
}


#======================================================================
# PRIVATE METHODS
#======================================================================

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

  # body : concatenate content from all sections
  my $body = "";
  my $i = 1;
  foreach my $section (@{$self->{sections}}) {

    # section break
    if ($i > 1) {
      # type of break
      my $break = $section->{new_page};
      $break = 'always' if $break && looks_like_number($break); # if true but not a word
      $break ||= 'auto';                                        # if false
      # otherwise, type of break will just be the word given in {new_page}

      # insert into body
      my $style = qq{page-break-before:$break;mso-break-type:section-break};
      $body .= qq{\n};
    }

    # section content
    $body .= qq{\n$section->{content}\n\n};

    $i += 1;
  }

  # assemble head and body into a full document
  my $html
    = qq{
    . qq{      xmlns:o="urn:schemas-microsoft-com:office:office"\n}
    . qq{      xmlns:w="urn:schemas-microsoft-com:office:word"\n}
    . qq{      xmlns:m="http://schemas.microsoft.com/office/2004/12/omml"\n}
    . qq{      xmlns="http://www.w3.org/TR/REC-html40">\n}
    . $self->_head
    . qq{\n$body\n}
    . qq{\n};
  return ["main.htm", $html];
}


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

  # HTML head : link to filelist, title, view format and styles
  my $head
    = qq{\n}
    . qq{\n}
    . qq{\n}
    . qq{$self->{title}\n}
    . $self->_xml_WordDocument
    . qq{\n} . $self->_section_styles . qq{\n}
    . $self->{head}
    . qq{\n};
  return $head;
}



sub _xml_WordDocument {
  my ($self) = @_;
  my $xml_root = $self->{WordDocument} or return "";
  return "\n"
       . _w_xml($xml_root)
       . "\n";
}


sub _w_xml {
  my $node = shift;
  my $xml = "";
  while (my ($k, $v) = each %$node) {
    $xml .= $v ? (               # node with content
                   ""
                  . (ref $v ? _w_xml($v) : $v)
                  . "\n" )
               : "\n";   # node without content
  }
  return $xml;
}


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

  my $styles = "";
  my $i = 1;
  foreach my $section (@{$self->{sections}}) {

    my $properties = "";

    # page properties (size and margin)
    foreach my $prop (qw/size margin/) {
      my $val = $section->{page}{$prop} or next;
      $properties .= qq{  $prop:$val;\n};
    }

    # headers and footers
    my $has_first_page;
    foreach my $prop (qw/header_margin footer_margin
                         page_numbers paper_source/) {
      my $val = $section->{page}{$prop} or next;
      (my $property = $prop) =~ s/_/-/g;
      $properties .= qq{  mso-$property:$val;\n};
    }
    foreach my $hf (qw/header footer first_header first_footer/) {
      $section->{$hf} or next;
      $has_first_page = 1 if $hf =~ /^first/;
      (my $property = $hf) =~ s/_/-/;
      $properties
        .= qq{  mso-$property:url("files/header_footer.htm") $hf$i;\n};
    }
    $properties .= qq{  mso-title-page:yes;\n} if $has_first_page;

    # style definitions for this section
    $styles .= qq[\@page Section$i {\n$properties}\n]
            .  qq[div.Section$i {page:Section$i}\n];
    $i += 1;
  }

  return $styles;
}


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

  # attachments supplied by user
  my @parts = @{$self->{MIME_parts}};

  # additional attachment : computed file with headers and footers
  my $hf_content = $self->_header_footer;
  unshift @parts, ["files/header_footer.htm", $hf_content] if $hf_content;

  return @parts;
}


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

  # create a div for each header/footer in each section
  my $hf_divs = "";
  my $i = 1;
  foreach my $section (@{$self->{sections}}) {

    # deal with headers/footers defined in that section
    foreach my $hf (qw/header footer first_header first_footer/) {
      $section->{$hf} or next;
      (my $style = $hf) =~ s/^first_//;
      $hf_divs .= qq{\n}
               .  $section->{$hf} . "\n"
               .  qq{\n};
    }

    $i += 1;
  }

  # if at least one such div, need to create an attached file
  my $header_footer = !$hf_divs ? "" :
        qq{\n}
      . qq{\n}
      . qq{\n}
      . qq{\n}
      . $self->{hf_head}
      . qq{\n}
      . qq{\n} . $hf_divs . qq{\n}
      . qq{\n};

  return $header_footer;
}



sub _filelist {
  my ($self, @parts) = @_;

  # xml header
  my $xml = qq{\n}
          . qq{ \n};

  # refer to each attached file
  foreach my $part (@parts) {
    $xml .= qq{ \n};
  }

  # the filelist is itself an attached file
  $xml .= qq{ \n};

  # closing tag;
  $xml .=  qq{\n};

  return ["files/filelist.xml", $xml];
}



1;

__END__