File Coverage

blib/lib/EBook/Ishmael/EBook/CHM.pm

Criterion	Covered	Total	%
statement	40	201	19.9
branch	0	56	0.0
condition	0	23	0.0
subroutine	13	26	50.0
pod	0	9	0.0
total	53	315	16.8

package EBook::Ishmael::EBook::CHM;
use 5.016;
our $VERSION = '2.01';
use strict;
use warnings;

use File::Basename;
use File::Temp qw(tempdir);
use File::Spec;

use File::Which;
use XML::LibXML;

use EBook::Ishmael::Dir;
use EBook::Ishmael::EBook::Metadata;
use EBook::Ishmael::ImageID;
use EBook::Ishmael::ShellQuote qw(safe_qx);

# TODO: Make more of an effort to find metadata
# TODO: Add support for Windows via hh.exe
# I have tried to add hh support before, and it didn't work out well because
# hh doesn't know how to handle quoted arguments for some reason.

my $HAS_CHMLIB = defined which('extract_chmLib');
our $CAN_TEST = $HAS_CHMLIB;

my $MAGIC = 'ITSF';

sub heuristic {

    my $class = shift;
    my $file  = shift;
    my $fh    = shift;

    read $fh, my $mag, length $MAGIC;

    return $mag eq $MAGIC;

}

sub _extract {

    my $self = shift;

    if (!$HAS_CHMLIB) {
        die "Cannot extract CHM $self->{Source}; extract_chmLib not installed\n";
    }

    safe_qx('extract_chmLib', $self->{Source}, $self->{_extract});
    unless ($? >> 8 == 0) {
        die "Failed to run 'extract_chmLib' on $self->{Source}\n";
    }

    return 1;

}

sub _urlstr {

    my $self = shift;

    my $strfile = File::Spec->catfile($self->{_extract}, '#URLSTR');

    unless (-f $strfile) {
        die "Cannot read CHM $self->{Source}; #URLSTR missing\n";
    }

    open my $fh, '<', $strfile
        or die "Failed to open $strfile for reading: $!\n";
    binmode $fh;

    my @urls = split /\0+/, do { local $/ = undef; readline $fh };

    for my $url (@urls) {
        next unless $url =~ /\.html$/;
        $url = File::Spec->catfile($self->{_extract}, $url);
        next unless -f $url;
        push @{ $self->{_content} }, $url;
    }

    close $fh;

    return 1;

}

sub _hhc {

    my $self = shift;

    my ($hhc) = grep { /\.hhc$/ } dir($self->{_extract});

    unless (defined $hhc) {
        die "CHM $self->{Source} is missing HHC\n";
    }

    my $dom = XML::LibXML->load_html(
        location => $hhc,
        recover => 2,
        no_network => !$self->{Network},
    );

    my @locals = $dom->findnodes('//li/object/param[@name="Local"]');

    @{ $self->{_content} } =
        grep { /\.html?$/ }
        grep { -f }
        map { File::Spec->catfile($self->{_extract}, $_->getAttribute('value')) }
        grep { defined $_->getAttribute('value') }
        @locals;

    my ($gen) = $dom->findnodes('/html/head/meta[@name="GENERATOR"]/@content');

    if (defined $gen) {
        $self->{Metadata}->contributor([ $gen->value ]);
    }

    return 1;

}

sub _images {

    my $self = shift;
    my $dir  = shift // $self->{_extract};

    for my $f (dir($dir)) {
        if (-d $f) {
            $self->_images($f);
        } elsif (is_image_path($f)) {
            push @{ $self->{_images} }, $f;
        }
    }

    # Get image and data pairs.
    my @imgdat = map {

        open my $fh, '<', $_
            or die "Failed to open $_ for reading: $!\n";
        binmode $fh;

        [ $_, do { local $/ = undef; readline $fh } ];

    } @{ $self->{_images} };

    my @covers =
        map { $_->[0] }
        # Sort by size, we want the largest image
        sort { -s $a->[0] <=> -s $b->[0] }
        # Cover images probably have at least a 1.3 height-width ratio.
        grep { $_->[1][1] / $_->[1][0] >= 1.3 }
        grep { defined $_->[1] }
        map { [ $_->[0], image_size(\$_->[1]) ] }
        @imgdat;

    $self->{_cover} = $covers[-1] if @covers;

    return 1;

}

sub _clean_html {

    my $node = shift;

    my @children = grep { $_->isa('XML::LibXML::Element') } $node->childNodes;

    # Remove the ugly nav bars from the top and bottom of the page. We
    # determine if a node is a navbar node if it contains an image that is
    # alt-tagged with either next or prev.
    if (@children and my ($alt) = $children[0]->findnodes('.//img/@alt')) {
        if ($alt->value =~ m/next|prev/i) {
            $node->removeChild(shift @children);
        }
    }
    if (@children and my ($alt) = $children[-1]->findnodes('.//img/@alt')) {
        if ($alt->value =~ m/next|prev/i) {
            $node->removeChild(pop @children);
        }
    }

    # Now get rid of the horizontal space placed before/after each nav bar.
    if (@children and $children[0]->nodeName eq 'hr') {
        $node->removeChild(shift @children);
    }
    if (@children and $children[-1]->nodeName eq 'hr') {
        $node->removeChild(pop @children);
    }

    return 1;

}

sub new {

    my $class = shift;
    my $file  = shift;
    my $enc   = shift;
    my $net   = shift // 1;

    my $self = {
        Source   => undef,
        Metadata => EBook::Ishmael::EBook::Metadata->new,
        Network  => $net,
        _extract => undef,
        _images  => [],
        _content => [],
        _cover   => undef,
    };

    bless $self, $class;

    $self->{Source} = File::Spec->rel2abs($file);

    $self->{_extract} = tempdir(CLEANUP => 1);
    $self->_extract;
    #$self->_urlstr;
    $self->_hhc;
    $self->_images;

    $self->{Metadata}->set_title((fileparse($self->{Source}, qr/\.[^.]*/))[0]);
    $self->{Metadata}->set_modified((stat $self->{Source})[9]);
    $self->{Metadata}->set_format('CHM');

    return $self;

}

sub html {

    my $self = shift;
    my $out  = shift;

    my $html = join '', map {

        my $dom = XML::LibXML->load_html(
            location => $_,
            recover => 2,
            no_network => !$self->{Network},
        );

        my ($body) = $dom->findnodes('/html/body');
        $body //= $dom->documentElement;

        _clean_html($body);

        map { $_->toString } $body->childNodes;

    } @{ $self->{_content} };

    if (defined $out) {
        open my $fh, '>', $out
            or die "Failed to open $out for writing: $!\n";
        binmode $fh, ':utf8';
        print { $fh } $html;
        close $fh;
        return $out;
    } else {
        return $html;
    }

}

sub raw {

    my $self = shift;
    my $out  = shift;

    my $raw = join '', map {

        my $dom = XML::LibXML->load_html(
            location => $_,
            recover => 2,
            no_network => !$self->{Network},
        );

        my ($body) = $dom->findnodes('/html/body');
        $body //= $dom->documentElement;

        $body->textContent;

    } @{ $self->{_content} };

    if (defined $out) {
        open my $fh, '>', $out
            or die "Failed to open $out for writing: $!\n";
        binmode $fh, ':utf8';
        print { $fh } $raw;
        close $fh;
        return $out;
    } else {
        return $raw;
    }

}

sub metadata {

    my $self = shift;

    return $self->{Metadata};

}

sub has_cover {

    my $self = shift;

    return defined $self->{_cover};

}

sub cover {

    my $self = shift;
    my $out  = shift;

    return undef unless $self->has_cover;

    open my $rh, '<', $self->{_cover}
        or die "Failed to open $self->{_cover} for reading: $!\n";
    binmode $rh;
    my $bin = do { local $/ = undef; readline $rh };
    close $rh;

    if (defined $out) {
        open my $wh, '>', $out
            or die "Failed to open $out for writing: $!\n";
        binmode $wh;
        print { $wh } $bin;
        close $wh;
        return $out;
    } else {
        return $bin;
    }

}

sub image_num {

    my $self = shift;

    return scalar @{ $self->{_images} };

}

sub image {

    my $self = shift;
    my $n    = shift;

    if ($n >= $self->image_num) {
        return undef;
    }

    open my $fh, '<', $self->{_images}[$n]
        or die "Failed to open $self->{_images}[$n] for reading: $!\n";
    binmode $fh;
    my $img = do { local $/ =  undef; readline $fh };
    close $fh;

    return \$img;

}

1;