File Coverage

blib/lib/EBook/MOBI/Driver/POD.pm

Criterion	Covered	Total	%
statement	235	246	95.5
branch	120	140	85.7
condition	26	39	66.6
subroutine	23	23	100.0
pod	4	10	40.0
total	408	458	89.0

package EBook::MOBI::Driver::POD;

our $VERSION = '0.72'; # TRIAL VERSION (hook for Dist::Zilla::Plugin::OurPkgVersion)

use strict;
use warnings;

use Pod::Parser;
use EBook::MOBI::Driver;
our @ISA = qw(Pod::Parser EBook::MOBI::Driver);

use Text::Trim;
use HTML::Entities;
use Carp;
use EBook::MOBI::Converter;
use IO::String;

# This constants are used for internal replacement
# See interior_sequence() and _html_enc() for usage
use constant { GT  => '1_qpdhcn_thisStringShouldNeverOccurInInput',
               LT  => '2_udtcqk_thisStringShouldNeverOccurInInput',
               AMP => '3_pegjyq_thisStringShouldNeverOccurInInput',
               COL => '4_jdkmso_thisStringShouldNeverOccurInInput',
               QUO => '5_wuehlo_thisStringShouldNeverOccurInInput',
               DQUO=> '6_jrgwpm_thisStringShouldNeverOccurInInput',
             };

# IMPORTANT
# This constant ist JUST a shortcut for readability.
# Because it is used in hases ($parser->{}) a + is used so that it is not
# interpreted as a string, so it looks like this: $parser->{+P . 'bla'}
# See http://perldoc.perl.org/constant.html for details
use constant { P   => 'EBook_MOBI_Pod2Mhtml_' };

# Overwrite sub of Pod::Parser
sub begin_input {
    my $parser = shift;
    my $out_fh = $parser->output_handle();       # handle for parsing output

    $parser->{+P . 'toMobi'} = EBook::MOBI::Converter->new();

    $parser->debug_msg('found POD, parsing...');

    # make sure that this variable is set to 0 at beginning
    $parser->{+P . 'listcontext'} = 0;
    $parser->{+P . 'listjustwentback'} = 0;
    $parser->{+P . 'begin'} = '';
}

# Overwrite sub of Pod::Parser
sub end_input {
    my $parser = shift;
    my $out_fh = $parser->output_handle();

    $parser->debug_msg('...end of POD reached');
}

# Overwrite sub of Pod::Parser
# Here all POD commands starting with '=' are handled
sub command {
    my ($parser, $command, $paragraph, $line_num) = @_;
    my $out_fh = $parser->output_handle();       # handle for parsing output

    # IMAGE is an unofficial command introduced by Renee, its very simple:
    # =image PATH_TO_IMAGE ANY TEXT FOLLOWING UNTIL END OF LINE
    if ($command eq 'image') {

        print
            "WARNING: the unofficial POD command '=image' is deprecated.\n";

        # With this regex we parse the content, coming with the command.
        # An example could look like this:
        # $paragraph = '/home/user/picture.jpg Pic1: A Camel'
        if ($paragraph =~ m/(\S*)\s*(.*)/g) {
            my $img_path = $1;  # e.g.: '/home/user/picture.jpg'
            my $img_desc = $2;  # e.g.: 'A Camel'

            # We convert special chars to HTML, but only in the
            # description, not in the path!
            $img_desc = _html_enc($img_desc);

            # We print out an html image tag.
            # e.g.:
            # recindex is MOBI specific, its the number of the picture,
            # pointing into the picture records of the Mobi-format
            print $out_fh
                $parser->{+P . 'toMobi'}
                    ->image($img_path, $img_desc);
        }
    }
    # POD compatible additional syntax to process images
    # =for image PATH_TO_IMAGE ANY TEXT FOLLOWING UNTIL END OF LINE
    if ($command eq 'for') {

        # With this regex we parse the content, coming with the command.
        # An example could look like this:
        # $paragraph = 'image /home/user/picture.jpg Pic1: A Camel'
        if ($paragraph =~ m/image\s*(\S*)\s*(.*)/g) {
            my $img_path = $1;  # e.g.: '/home/user/picture.jpg'
            my $img_desc = $2;  # e.g.: 'A Camel'

            # We convert special chars to HTML, but only in the
            # description, not in the path!
            $img_desc = _html_enc($img_desc);

            # We print out an html image tag.
            # e.g.:
            # recindex is MOBI specific, its the number of the picture,
            # pointing into the picture records of the Mobi-format
            print $out_fh
                $parser->{+P . 'toMobi'}
                    ->image($img_path, $img_desc);
        }
    }
    # Lists are a bit complex. The commands 'over', 'back' and 'item'
    # are used. They exchange state over a global variable. This state
    # is the listcontext, which can be: 'begin', 'ul' or 'ol'.
    # OVER: starts the listcontext
    elsif ($command eq 'over') {

        # If we reach an 'over' command we can't do anything yet
        # because we don't know if it will be an ordered or an
        # unordered list! So we just set a global variable to 'begin',
        # the first item call can then know that it is the first item
        # and that it defines the rest of the list type.

        if (exists $parser->{+P . 'list'}) {
            # if we reach here, this means that this is a nested list
            $parser->{+P . 'listlvl'}++;
        }
        else {
            $parser->{+P . 'listlvl'} = 0;
        }


        push @{$parser->{+P . 'list'}}
             , {
                 type    => ''     ,
                 items   => 0      ,
                 state   => 'over' ,
                 contentInCmd => 1 ,
                 blockquotes  => 0 ,
               };
    }
    # BACK: ends the listcontext
    elsif ($command eq 'back') {

        my $lvl = $parser->{+P . 'listlvl'};

        # print end-tag according to the lists type
        if ($parser->{+P . 'list'}->[$lvl]->{type} eq 'ul') {
            print $out_fh '' . "\n"; # close last item
            print $out_fh '' . "\n";
        }
        elsif ($parser->{+P . 'list'}->[$lvl]->{type} eq 'ol') {
            print $out_fh '' . "\n"; # close last item
            print $out_fh '' . "\n";
        }
        elsif
          ($parser->{+P . 'list'}->[$lvl]->{type}
           eq 'blockquote') {
            # list is processed
            # there where no items...
        }
        else {
            carp 'POD parsing error. Undefined listcontext: '
                  . $parser->{+P . 'listcontext'};
        }

        # DELETE if list is finish
        if ($parser->{+P . 'listlvl'} == 0) {
            delete $parser->{+P . 'listlvl'};
            delete $parser->{+P . 'list'};
            delete $parser->{+P . 'listjustwentback'};
        }
        else {
            $parser->{+P . 'list'}->[$lvl]->{state} = 'back';
            $parser->{+P . 'listlvl'}--;
            $parser->{+P . 'listjustwentback'} = 1;
        }
    }
    # CUT: end of POD
    elsif ($command eq 'cut') {
        # We don't need to do anything here...
    }
    elsif ($command eq 'begin') {
        if ($paragraph =~ m/^\W*(\w+)\W*$/) {
            my $begin_name = $1;
            $parser->{+P . 'begin'} = $begin_name;
        }
    }
    elsif ($command eq 'end') {
        if ($paragraph =~ m/^\W*(\w+)\W*$/) {
            my $end_name = $1;
            if ($parser->{+P . 'begin'} eq $end_name) {
                $parser->{+P . 'begin'} = '';
            }
            else {
                croak 'no nested begin/end supported';
            }
        }
    }
    # if we reach this ELSE, this means that the command can only be
    # of type HEAD or ITEM (so they contain some text!)
    else {
        # first we remove all whitespace from begin and end of the title
        trim $paragraph;
        # then we call interpolate so that 'interior_sequence' is called.
        # this is replacing inline POD.
        my $expansion = $parser->interpolate($paragraph, $line_num);
        # then we replace special chars with HTML entities
        $expansion = _html_enc($expansion);

        # Now we just need to print the text with the matching HTML tag
        if ($command eq 'head0') {
            # head0 gets only printed if the option is set!
            # (head0 is not official POD standard)
            if ($parser->head0_mode()) {
                # before every head1 we insert a "mobi-pagebreak"
                # but not before the first one!
                if (exists $parser->{+P . 'firstH1passed'}
                and exists $parser->{+P . 'pages'}
                and        $parser->{+P . 'pages'}
                ) {
                    print $out_fh
                        $parser->{+P . 'toMobi'}->pagebreak();
                }
                else {
                    $parser->{+P . 'firstH1passed'} = 1;
                }

                print $out_fh
                    $parser->{+P . 'toMobi'}->title($expansion, 1);
            }
        }
        elsif ($command eq 'head1') {
            # we need to check to which level we translate the headings...
            if ($parser->head0_mode()) {
                print $out_fh
                    $parser->{+P . 'toMobi'}->title($expansion, 2);
            }
            else {
                # before every head1 we insert a "mobi-pagebreak"
                # but not before the first one!
                if (exists $parser->{+P . 'firstH1passed'}
                and exists $parser->{+P . 'pages'}
                and        $parser->{+P . 'pages'}
                ) {
                    print $out_fh
                        $parser->{+P . 'toMobi'}->pagebreak();
                }
                else {
                    $parser->{+P . 'firstH1passed'} = 1;
                }

                print $out_fh
                    $parser->{+P . 'toMobi'}->title($expansion, 1);
            }
        }
        elsif ($command eq 'head2') {
            # we need to check to which level we translate the headings...
            if ($parser->head0_mode()) {
                print $out_fh
                    $parser->{+P . 'toMobi'}->title($expansion, 3);
            }
            else {
                print $out_fh
                    $parser->{+P . 'toMobi'}->title($expansion, 2);
            }
        }
        elsif ($command eq 'head3') {
            # we need to check to which level we translate the headings...
            if ($parser->head0_mode()) {
                print $out_fh
                    $parser->{+P . 'toMobi'}->title($expansion, 4);
            }
            else {
                print $out_fh
                    $parser->{+P . 'toMobi'}->title($expansion, 3);
            }
        }
        elsif ($command eq 'head4') {
            # we need to check to which level we translate the headings...
            if ($parser->head0_mode()) {
                print $out_fh
                    $parser->{+P . 'toMobi'}->title($expansion, 5);
            }
            else {
                print $out_fh
                    $parser->{+P . 'toMobi'}->title($expansion, 4);
            }
        }
        # ITEM: lists items
        elsif ($command eq 'item') {

            # If we are still in listcontext 'begin' this means that this is
            # the first item of the list, which will be used to figure out
            # the type of the list.
            my $lvl = $parser->{+P . 'listlvl'};

            $parser->{+P . 'list'}->[$lvl]->{items}++;

            if ($parser->{+P . 'list'}->[$lvl]->{items} == 1){

                # if we are already in a list...
                if ($parser->{+P . 'list'}->[$lvl]->{state}
                    eq 'over'
                    and $lvl > 0
                    and
                    $parser->{+P . 'list'}->[$lvl-1]->{items}
                    > 0
                    ) {
                    # we need to close the last item!
                    print $out_fh '' . "\n";
                }

                # is there a digit at first, if yes this is an ordered list
                if ($expansion =~ /^\s*\d+\s*(.*)$/) {
                    $expansion = $1;
                    $parser->{+P . 'list'}->[$lvl]
                           ->{type} = 'ol';

                    if ($expansion =~ /[[:alnum:][:punct:]]+/) {
                        print $out_fh '' . "\n";
                    }
                    else {
                        $parser->{+P . 'list'}->[$lvl]->{contentInCmd} = 0;
                        print $out_fh "\n";
                    }
                }
                # is there a '*' at first, if yes this is an unordered list
                elsif ($expansion =~ /^\s*\*{1}\s*(.*)$/) {
                    $expansion = $1;
                    $parser->{+P . 'list'}->[$lvl]->{type} = 'ul';

                    if ($expansion =~ /[[:alnum:][:punct:]]+/) {
                        print $out_fh '' . "\n";
                    }
                    else {
                        $parser->{+P . 'list'}->[$lvl]->{contentInCmd} = 0;
                        print $out_fh "\n";
                        #\n";
                    }
                }
                # are there only prinable chars? We default to unordered
                elsif ($expansion =~ /[[:alnum:][:punct:]]+/) {
                    $parser->{+P . 'list'}->[$lvl]->{type} = 'ul';
                    print $out_fh '' . "\n";
                    # do nothing
                }
                # The lists text may be in a normal text section...
                # we default to unordered
                else {
                    $parser->{+P . 'list'}->[$lvl]->{type} = 'ul';
                    $parser->{+P . 'list'}->[$lvl]->{contentInCmd} = 0;
                    print $out_fh "\n";
                }
            }

            # if it is not the first item we save the checks for list-type
            else {

                # but first we need to close the last item!
                if ($parser->{+P . 'listjustwentback'}) {
                    $parser->{+P . 'listjustwentback'} = 0;
                }
                else {
                    # we need to close the last item!
                    print $out_fh '' . "\n";
                }

                my $type =
                   $parser->{+P . 'list'}->[$lvl]->{type};

                # then we check the type and extract the content
                if ($type eq 'ol') {
                    if ($expansion =~ /^\s*\d+\s*(.*)$/) {
                        $expansion = $1;
                    }
                }
                if ($type eq 'ul') {
                    if ($expansion =~ /^\s*\*{1}\s*(.*)$/) {
                        $expansion = $1;
                    }
                }
            }

            # we print the item... but we don't close it!
            # it get's closed by the next item or the =back call
            print $out_fh '' . $expansion;
        }
    }
}

# Overwrite sub of Pod::Parser
# Here all code parts of POD get parsed
sub verbatim {
    my ($parser, $paragraph, $line_num) = @_;
    my $out_fh = $parser->output_handle();       # handle for parsing output

    # We have to escape the case where there is only a newline, because
    # Pod::Parser calls verbatim() with $paragraph="\n" every time an empty
    # line is found in the Pod. But that is not what we are looking for!
    # We are looking for code-blocks here...
    if ($paragraph eq "\n") { return }

    # we look for POD inline commands
    my $expansion = $parser->interpolate($paragraph, $line_num);
    # then for special chars
    $expansion = _html_enc($expansion);
    # and last but not least we replace whitespace with a HTML tag.
    # this we do only for the verbatim command!
    # this is so, that code format (indenting) is keeped in html
    $expansion = _nbsp($expansion);

    # also only in verbatim we replace newline with the  tag
    # this is so, that code format is keeped in html
    $expansion =~ s/\n/\n/g;

    # trim must be last,
    # otherwise _nbsp() is not working for the first line
    trim $expansion;

    # ok, we are done and print out the result
    print $out_fh "$expansion\n";
}

# Overwrite sub of Pod::Parser
# Here normal POD text paragraphs get parsed
sub textblock {
    my ($parser, $paragraph, $line_num) = @_;
    my $out_fh = $parser->output_handle();       # handle for parsing output

    # we could be in a =begin block so we just check that and return if
    # this is the case
    if ($parser->{+P . 'begin'} eq 'html') {
        # we are in a html block, so just print the plain thing
        print $out_fh "\n";
        print $out_fh $paragraph;
        print $out_fh "\n";
        return
    }

    # no begin block... so do the rest of this complicate code!

    # ok, this one is tricky...
    # textblock() can be called when the parser is actually parsing a list.
    # this happens if the list is written like that:
    # =over
    #
    # =item
    #
    # Text that appears in this sub as $paragraph
    #
    # =back
    # If the text is on the SAME LINE as the =item command, this will not
    # happen. It is only when the text is separated with newline.
    # Ok... we need to check here if we are in a list.. and then do some
    # stuffe to handle that case.

    # we translate the POD inline commands...
    my $expansion = $parser->interpolate($paragraph, $line_num);
    # remove leading and trailing whitespace...
    trim $expansion;
    # and translate special chars to HTML
    $expansion = _html_enc($expansion);

    # store the list-nesting in a local variable (just for readability)
    my $lvl = $parser->{+P . 'listlvl'};

    # if there is no list WE ARE LUCKY and just print the text as paragraph
    if (not exists $parser->{+P . 'list'}) {
        print $out_fh '' . $expansion . '' . "\n";
    }
    # NOOOOOOO... we have a list
    # ok... let's try to figure out what to do!

    # items and some content found already in the command...
    # ... so we add a  before the following textblock.
    elsif ($parser->{+P . 'list'}->[$lvl]->{items} > 0
           and $parser->{+P . 'list'}->[$lvl]->{contentInCmd} == 1
           ) {
        print $out_fh '' . $expansion;
    }
    # if there was not yet content found we just print what we have now
    elsif ($parser->{+P . 'list'}->[$lvl]->{items} > 0) {
        print $out_fh $expansion;
    }
    # if there where no items yet this can only mean that we are in a list
    # without any items but with pure text... so we do blockquotes for
    # each paragraph
    elsif ($parser->{+P . 'list'}->[$lvl]->{items} == 0) {

        # we set the listtype
        $parser->{+P . 'list'}->[$lvl]->{type} = 'blockquote';
        $parser->{+P . 'list'}->[$lvl]->{blockquotes}++;

        if ($parser->{+P . 'list'}->[$lvl]->{blockquotes} == 1
            and $lvl > 0
            and $parser->{+P . 'list'}->[$lvl-1]->{items} > 0
            ) {
            print $out_fh "\n";
        }

        # we do some pseudo-indenting
        # TODO: more nice would be real nesting...
        for (0..$lvl) {
            print $out_fh '';
        }
        print $out_fh $expansion;
        for (0..$lvl) {
            print $out_fh '' ."\n";
        }
    }
    else {
        # we should not reach here...
        croak "POD parsing error. Found undefined textblock in a list.";
    }
}

# Overwrite sub of Pod::Parser
# This method is called for handling inline POD, like e.g. B
sub interior_sequence {
    my ($parser, $cmd, $arg) = @_;

    # IMPORTANT here we do some tricky stuff...
    # what we actually want is this:
    #     B   ->   some text
    # but this is not possible, because then the <> would be replaced by
    # HTML entities later on!
    # So that is why we replace like this:
    #     <   ->   constant: LT
    # and
    #     >   ->   constant: GT
    # So B becomes XLTXsome textXGTX
    # The function which is doing the HTML translation must then replace
    # this words again with < and > (this is what _html_enc() is doing)
    return LT . 'b'    . GT . $arg . LT . '/b'    . GT  if ($cmd eq 'B');
    return LT . 'code' . GT . $arg . LT . '/code' . GT  if ($cmd eq 'C');
    return LT . 'code' . GT . $arg . LT . '/code' . GT  if ($cmd eq 'F');
    return LT . 'i'    . GT . $arg . LT . '/i'    . GT  if ($cmd eq 'I');
    return              AMP . $arg . COL                if ($cmd eq 'E');

    # if there is an L<> we have to take care a little bit more
    if ($cmd eq 'L') {

        # if we have this:
        #     L
        # this means that CHI::Driver::File is the name to be displayed
        # and "File" is the link... which we direct to metacpan...

        # empty vars
        my $text = '';
        my $link = '';

        # if named we set the vars
        if ($arg =~ m/^(.*)\|(.*)$/) {
            $text = $1;
            $link = $2;
        }

        # in case this is not set, we set it to original value
        $link = $arg unless $link;

        # the case
        #     L
        # for relative sections is not handled well here because we
        # don't know the module like that!
        # so we just print the text as is
        if($link =~ m%^/(.*)%) {
            my $section = $1;
            if ($text) {
                return "$text ($section)";
            }
            else {
                return DQUO . $section . DQUO;
            }
            # EXIT
        }

        # if the links seems to be http we also just return!
        elsif ($link =~ /^http.*$/
            or $link =~ /^.*\.{1}\w{2,5}$/ ) {
                # this is a weblink!
                # keep on going...
        }

        # if no special case we continue...
        elsif ($link =~ m%(.*)/(.*)%) {
            my $module  = $1;
            my $section = $2;
            $section =~ s/"//;

            if ($module && $section) {
                $link = "$module#$section";
            }
            elsif ($module && not $section) {
                $link = $module;
            }
            elsif (not $module && $section) {
                # this case should not happen but you never know
                # (it should be handled in the first if!)
                return "\"$section\"";
            }

            # this URL should be valid now
            $link = "https://metacpan.org/module/$link";

        }
        # normal module name
        else {
            # this URL should be valid now
            $link = "https://metacpan.org/module/$link";
        }

        # in case this is not set, we set it to original value
        $text = $arg unless $text;

        return LT.'a href='.QUO.$link.QUO.GT.$text.LT.'/a'.GT
    }

    # if nothing matches we return the content unformated 'as is'
    return $arg;
}

sub parse {
    my ($parser, $input) = @_;

    # INPUT:
    my $input_fh = IO::String->new($input);

    # OUTPUT:
    # We create this IO-object because Pod::Parser does not provide
    # pure string-data as return of result data
    my $buffer4html; # this variable will contain the result!!!
    my $buffer4html_handle = IO::String->new($buffer4html);

    # we call the parser to parse, result will be in $buffer4html
    $parser->parse_from_filehandle($input_fh, $buffer4html_handle);

    return $buffer4html;
};

sub set_options {
    my $self = shift;
    my $args = shift;

    if (ref($args) eq "HASH") {
        $self->head0_mode($args->{head0_mode}) if (exists $args->{head0_mode});
        $self->pagemode  ($args->{pagemode})   if (exists $args->{pagemode});
    }
    else {
        $self->debug_msg('Plugin options are not in a HASH');
    }
}

sub pagemode {
    my ($self, $boolean) = @_;

    if (@_ > 1) {
        $self->{+P . 'pages'} = $boolean;
    }
    else {
        return $self->{+P . 'pages'};
    }
}

sub head0_mode {
    my ($self, $boolean) = @_;

    if (@_ > 1) {
        $self->{+P . 'head0_mode'} = $boolean;
    }
    else {
        return $self->{+P . 'head0_mode'};
    }
}

# encode_entities() from HTML::Entities does not translate it correctly
# this is why I make it here manually as a quick fix
# don't reall know where how to handle this utf8 problem for now...
sub _html_enc {
    my $string = shift;

    $string = encode_entities($string);
                            #    ^
    my $lt = LT;            #    |
    my $gt = GT;            #    |
    my $am = AMP;           #    |
    my $co = COL;           #    |-- don't change this order!
    my $qu = QUO;           #    |
    my $dqu= DQUO;          #    |
    $string =~ s/$lt/
    $string =~ s/$gt/>/g;   #    |
    $string =~ s/$am/&/g;   #    |
    $string =~ s/$co/;/g;   #    |
    $string =~ s/$qu/'/g;   #    |
    $string =~ s/$dqu/"/g;  #<---|

    return $string;
}

## replaces whitespace with html entitie
sub _nbsp {
    my $string = shift;

    $string =~ s/\ / /g;

    return $string;
}

1;

__END__