File Coverage

blib/lib/HTML/FormatExternal.pm

Criterion	Covered	Total	%
statement	34	139	24.4
branch	3	66	4.5
condition	0	26	0.0
subroutine	10	18	55.5
pod	4	4	100.0
total	51	253	20.1

# Copyright 2008, 2009, 2010, 2011, 2012, 2013, 2015 Kevin Ryde

# HTML-FormatExternal is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as published
# by the Free Software Foundation; either version 3, or (at your option) any
# later version.
#
# HTML-FormatExternal is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with HTML-FormatExternal.  If not, see .



# Maybe:
#     capture error output
#     errors_to => \$var
#     combine error messages
#


package HTML::FormatExternal;
use 5.006;
use strict;
use warnings;
use Carp;
use File::Spec 0.80; # version 0.80 of perl 5.6.0 or thereabouts for devnull()
use IPC::Run;

# uncomment this to run the ### lines
# use Smart::Comments;

our $VERSION = 23;

sub new {
  my ($class, %self) = @_;
  return bless \%self, $class;
}
sub format {
  my ($self, $html) = @_;
  if (ref $html) { $html = $html->as_HTML; }
  return $self->format_string ($html, %$self);
}

use constant _WIDE_INPUT_CHARSET => 'UTF-8';
use constant _WIDE_OUTPUT_CHARSET => 'UTF-8';

# format_string() takes the easy approach of putting the string in a temp
# file and letting format_file() do the real work.  The formatter programs
# can generally read stdin and write stdout, so might do that with select()
# to simultaneously write and read back.
#
sub format_string {
  my ($class, $html_str, %options) = @_;

  my $fh = _tempfile();
  my $input_wide = eval { utf8::is_utf8($html_str) };
  _output_wide(\%options, $input_wide);

  # insert  while in wide chars
  if (defined $options{'base'}) {
    $html_str = _base_prefix(\%options, $html_str, $input_wide);
  }

  if ($input_wide) {
    if (! $options{'input_charset'}) {
      $options{'input_charset'} = $class->_WIDE_INPUT_CHARSET;
    }
    ### input_charset for wide: $options{'input_charset'}
    if ($options{'input_charset'} eq 'entitize') {
      $html_str = _entitize($html_str);
      delete $options{'input_charset'};
    } else {
      my $layer = ":encoding($options{'input_charset'})";
      binmode ($fh, $layer) or die 'Cannot add layer ',$layer;
    }
  }

  do {
    print $fh $html_str
      and close($fh)
    } || die 'Cannot write temp file: ',$!;

  return $class->format_file ($fh->filename, %options);
}

# Left margin is synthesized by adding spaces afterwards because the various
# programs have pretty variable support for a specified margin.
#   * w3m doesn't seem to have a left margin option at all
#   * lynx has one but it's too well hidden in its style sheet or something
#   * elinks has document.browse.margin_width but it's limited to 8 or so
#   * netrik doesn't seem to have one at all
#   * vilistextum has a "spaces" internally for lists etc but no apparent
#     way to initialize from the command line
#
sub format_file {
  my ($class, $filename, %options) = @_;

  # If neither leftmargin nor rightmargin are specified then '_width' is
  # unset and the _make_run() funcs leave it to the program defaults.
  #
  # If either leftmargin or rightmargin are set then '_width' is established
  # and the _make_run() funcs use it and and zero left margin, then the
  # actual left margin is applied below.
  #
  # The DEFAULT_LEFTMARGIN and DEFAULT_RIGHTMARGIN establish the defaults
  # when just one of the two is set.  Not good hard coding those values,
  # but the programs don't have anything to set one but not the other.
  #
  my $leftmargin  = $options{'leftmargin'};
  my $rightmargin = $options{'rightmargin'};
  if (defined $leftmargin || defined $rightmargin) {
    if (! defined $leftmargin)  { $leftmargin  = $class->DEFAULT_LEFTMARGIN; }
    if (! defined $rightmargin) { $rightmargin = $class->DEFAULT_RIGHTMARGIN; }
    $options{'_width'} = $rightmargin - $leftmargin;
  }

  _output_wide(\%options, 0);   # file input is reckoned as not wide
  if ($options{'output_wide'}) {
    $options{'output_charset'} ||= $class->_WIDE_OUTPUT_CHARSET;
  }

  my $tempfh;
  if (defined $options{'base'}) {
    # insert  by copying to a temp file

    # File::Copy rudely calls eq() to compare $from and $to.  Need either
    # File::Temp 0.18 to have that work on $tempfh, or File::Copy 2.??? for
    # it to check an overload method exists first.  Newer File::Temp is
    # available from cpan, where File::Copy may not be, so ask for
    # File::Temp 0.18.
    require File::Temp;
    File::Temp->VERSION(0.18);

    # must sysread()/syswrite() because that's what File::Copy does (as of
    # its version 2.30) so anything held in the perl buffering by the normal
    # read() is lost.

    my $initial;
    my $fh;
    do {
      open $fh, '<', $filename
        and binmode $fh
        and defined (sysread $fh, $initial, 4)
      } || croak "Cannot open $filename: $!";
    ### $initial

    $initial = _base_prefix(\%options, $initial, 0);

    $tempfh = _tempfile();
    $tempfh->autoflush(1);
    require File::Copy;
    do {
      defined(syswrite($tempfh, $initial))
        and File::Copy::copy($fh, $tempfh)
        and close $tempfh
        and close $fh
      } || croak "Cannot copy $filename to temp file: $!";


    $filename = $tempfh->filename;
  }

  # # dump the file being crunched
  # print "Bytes passed to program:\n";
  # IPC::Run::run(['hd'], '<',$filename, '|',['cat']);

  # _make_run() can set $options{'ENV'} too
  my ($command_aref, @run) = $class->_make_run($filename, \%options);
  my $env = $options{'ENV'} || {};

  ### $command_aref
  ### @run
  ### $env

  if (! @run) {
    push @run, '<', File::Spec->devnull;
  }

  my $str;
  {
    local %ENV = (%ENV, %$env); # overrides from _make_command()
    eval { IPC::Run::run($command_aref,
                         @run,
                         '>', \$str,
                         # FIXME: what to do with stderr ?
                         # '2>', File::Spec->devnull,
                        ) };
  }
  _die_on_insecure();
  ### $str

  ### final output_wide: $options{'output_wide'}
  if ($options{'output_wide'}) {
    require Encode;
    $str = Encode::decode ($options{'output_charset'}, $str);
  }

  if ($leftmargin) {
    my $fill = ' ' x $leftmargin;
    $str =~ s/^(.)/$fill$1/mg;  # non-empty lines only
  }
  return $str;
}

# most program running errors are quietly ignored for now, but re-throw
# "Insecure $ENV{PATH}" when cannot run due to taintedness.
sub _die_on_insecure {
  if ($@ =~ /^Insecure/) {
    die $@;
  }
}

sub _run_version {
  my ($self_or_class, $command_aref, @ipc_options) = @_;
  ### _run_version() ...
  ###  $command_aref
  ### @ipc_options

  if (! @ipc_options) {
    @ipc_options = ('2>', File::Spec->devnull);
  }

  my $version;  # left undef if any exec/slurp problem
  eval { IPC::Run::run($command_aref,
                       '<', File::Spec->devnull,
                       '>', \$version,
                       @ipc_options) };

  # strip blank lines at end of lynx, maybe others
  if (defined $version) { $version =~ s/\n+$/\n/s; }
  return $version;
}

# return a File::Temp filehandle object
sub _tempfile {
  require File::Temp;
  my $fh = File::Temp->new (TEMPLATE => 'HTML-FormatExternal-XXXXXX',
                            SUFFIX => '.html',
                            TMPDIR => 1);
  binmode($fh) or die 'Oops, cannot set binmode() on temp file';

  ### tempfile: $fh->filename
  #  $fh->unlink_on_destroy(0);  # to preserve for debugging ...

  return $fh;
}

sub _output_wide {
  my ($options, $input_wide) = @_;
  if (! defined $options->{'output_wide'}
      || $options->{'output_wide'} eq 'as_input') {
    $options->{'output_wide'} = $input_wide;
  }
}

# $str is HTML or some initial bytes.
# Return a new string with  at the start.
#
sub _base_prefix {
  my ($options, $str, $input_wide) = @_;
  my $base = delete $options->{'base'};
  ### _base_prefix: $base

  $base = "$base";           # stringize possible URI object
  $base = _entitize($base);  # probably shouldn't be any non-ascii in a url
  $base = "\n";

  my $pos = 0;
  unless ($input_wide) {
    # encode $base in the input_charset, and possibly after a BOM.
    #
    # Lynx recognises a BOM, if it doesn't have other -assume_charset.  It
    # recognises it only at the start of the file, so must insert
    # after it here to preserve that feature of Lynx.
    #
    # If input_charset is utf-32 or utf-16 then it seems reasonable to step
    # over any BOM.  But Lynx for some reason doesn't like a BOM together
    # with utf-32 or utf-16 specified.  Dunno if that's a bug or a feature
    # on its part.

    my $input_charset = $options->{'input_charset'};
    if (! defined $input_charset || lc($input_charset) eq 'utf-32') {
      if ($str =~ /^\000\000\376\377/) {
        $input_charset = 'utf-32be';
        $pos = 4;
      } elsif ($str =~ /^\377\376\000\000/) {
        $input_charset = 'utf-32le';
        $pos = 4;
      }
    }
    if (! defined $input_charset || lc($input_charset) eq 'utf-16') {
      if ($str =~ /^\376\377/) {
        $input_charset = 'utf-16be';
        $pos = 4;
      } elsif ($str =~ /^\377\376/) {
        $input_charset = 'utf-16le';
        $pos = 2;
      }
    }
    if (defined $input_charset) {
      # encode() errors out if unknown charset, and doesn't exist for older
      # Perl, in which case leave $base as ascii.  May not be right, but
      # ought to work with the various ASCII superset encodings.
      eval {
        require Encode;
        $base = Encode::encode ($input_charset, $base);
      };
    }
  }
  substr($str, $pos,0, $base);  # insert $base at $pos
  return $str;
}

# return $str with non-ascii replaced by { entities
sub _entitize {
  my ($str) = @_;
  $str =~ s{([^\x20-\x7E])}{'&#'.ord($1).';'}eg;
  ### $str
  return $str;
}

1;
__END__