Pod::HtmlEasy - Generate personalized HTML from PODs.

#############################################################################
## Name:        HtmlEasy.pm
## Purpose:     Pod::HtmlEasy
## Author:      Graciliano M. P.
## Modified by: Geoffrey Leach
## Created:     2004-01-11
## Updated:	    2010-06-13
## Copyright:   (c) 2004 Graciliano M. P. (c) 2007 - 2010 Geoffrey Leach
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

package Pod::HtmlEasy;
use 5.006002;

use strict;
use warnings;

use Pod::HtmlEasy::Parser;
use Pod::HtmlEasy::Data
    qw( EMPTY NL NUL TRUE FALSE body css gen head headend title top toc toc_tag podon podoff );
use Carp;
use English qw{ -no_match_vars };
use File::Slurp;
use Readonly;
use Regexp::Common qw{ whitespace };

use version;
our $VER = qv('1.1.8');    # Also appears in "=head1 VERSION" in the POD below

# Why this? CPAN (a/o 1/1/2008) does not grok qv.
our $VERSION = '1.1.8';

########
# VARS #
########

Readonly::Scalar my $NUL                  => NUL;
Readonly::Scalar my $TITLE_TEXT_LOC       => -2;
Readonly::Scalar my $DEFAULT_INDEX_LENGTH => 60;

# This keeps track of valid options
Readonly::Hash my %OPTS => (
    body         => 1,
    css          => 1,
    index        => 1,
    index_item   => 1,
    index_length => 1,
    output       => 1,
    no_css       => 1,
    no_generator => 1,
    no_index     => 1,
    only_content => 1,
    parserwarn   => 1,
    title        => 1,
    top          => 1,
);

#######################
# _ORGANIZE_CALLBACKS #
#######################

sub _organize_callbacks {
    my $this = shift;

    $this->{ON_B} = \&evt_on_b;
    $this->{ON_C} = \&evt_on_c;
    $this->{ON_E} = \&evt_on_e;
    $this->{ON_F} = \&evt_on_f;
    $this->{ON_I} = \&evt_on_i;
    $this->{ON_L} = \&evt_on_l;
    $this->{ON_S} = \&evt_on_s;
    $this->{ON_X} = \&evt_on_x;    # [20078]
    $this->{ON_Z} = \&evt_on_z;

    $this->{ON_HEAD1} = \&evt_on_head1;
    $this->{ON_HEAD2} = \&evt_on_head2;
    $this->{ON_HEAD3} = \&evt_on_head3;
    $this->{ON_HEAD4} = \&evt_on_head4;

    $this->{ON_VERBATIM}  = \&evt_on_verbatim;
    $this->{ON_TEXTBLOCK} = \&evt_on_textblock;

    $this->{ON_OVER} = \&evt_on_over;
    $this->{ON_ITEM} = \&evt_on_item;
    $this->{ON_BACK} = \&evt_on_back;

    $this->{ON_FOR}   = \&evt_on_for;
    $this->{ON_BEGIN} = \&evt_on_begin;
    $this->{ON_END}   = \&evt_on_end;

    $this->{ON_URI} = \&evt_on_uri;

    $this->{ON_ERROR} = \&evt_on_error;

    return;
}

#######
# NEW #
#######

sub new {
    my ( $this, %args ) = @_;
    return $this if ref $this;
    my $class = $this || __PACKAGE__;
    $this = bless {}, $class;

    _organize_callbacks($this);

    foreach my $key ( keys %args ) {

        # Add in any ON_ callbacks
        if ( $key =~ m{^on_(\w+)$}ismx ) {
            my $cmd = uc $1;
            $this->{qq{ON_$cmd}} = $args{$key};
        }
        elsif ( $key =~ m{^(?:=(\w+)|(\w)<>)$}smx ) {
            my $cmd = uc $1 || $2;
            $this->{$cmd} = $args{$key};
        }
    }

    return $this;
}

############
# POD2HTML #
############

sub pod2html {    ## no critic (ProhibitExcessComplexity)
    my @args = @_;
    my $this = shift @args;

    # The first argument is either the input file or an option,
    # In the latter case, input must be coming from STDIN
    my $pod = shift @args;
    if ( exists $OPTS{$pod} ) {

        # Oops, its an arg;
        unshift @args, $pod;
        $pod = q{-};
    }

    # If the following assignment is to work, we must have pairs in @args
    if ( @args & 1 ) {
        carp q{All options must be paired with values};
        exit 1;
    }
    my %args = @args;

    # Check options for validity
    foreach my $key ( keys %args ) {
        if ( not exists $OPTS{$key} ) {
            carp qq{option $key is not supported};
        }
    }

    my $save;
    if ( exists $args{output} ) { $save = $args{output}; }

   # Personal pecularity: I hate double negatives, and perlcritic hates unless
    my ( $do_css, $do_generator, $do_index, $do_content );
    if ( not exists $args{no_css} )       { $do_css       = 1; }
    if ( not exists $args{no_generator} ) { $do_generator = 1; }
    if ( not exists $args{no_index} )     { $do_index     = 1; }
    if ( not exists $args{only_content} ) { $do_content   = 1; }

    # This will fall through to Pod::Parser::new
    # which is the base for Pod::HtmlEasy::Parser.
    # Pod::HtmlEasy::Parser does not implement new()
    my $parser = Pod::HtmlEasy::Parser->new();

    $parser->errorsub(
        sub {    ## no critic (ProtectPrivateSubs)
            Pod::HtmlEasy::Parser::_errors( $parser, @_ );
        }
    );

 # Pod::Parser wiii complain about multiple blank lines in INDEX_ITEMthe input
 # which is moderately annoying
    if ( exists $args{parserwarn} ) { $parser->parseopts( -warnings => 1 ); }

    # This allows us to search for non-POD stuff is preprocess_paragraph
    # my $VERSION ..., for example
    $parser->parseopts( -want_nonPODs => 1 );

    # This puts a subsection in the $parser hash that will record data
    # that is "local" to this code.  Throughout, $parser will refer to
    # Pod::Parser and $this to Pod::HtmlEasy
    $parser->{POD_HTMLEASY} = $this;

    if ( exists $args{index_item} ) {
        $parser->{INDEX_ITEM} = 1;
        $parser->{INDEX_LENGTH}
            = exists $args{index_length}
            ? $args{index_length}
            : $DEFAULT_INDEX_LENGTH;
    }

    # This is where we accumulate the results of Pod::Parser
    my @output;
    $parser->{POD_HTMLEASY}->{HTML} = \@output;

    my $title = $args{title};
    if ( ref $pod eq q{GLOB} ) {    # $pod is an open file handle
        if ( not defined $title ) { $title = q{<DATA>}; }
    }
    else {
        if ( ( !-e $pod ) && ( $pod ne q{-} ) ) {
            carp qq{No file $pod};
            exit 1;
        }
        if ( not defined $title ) {
            $title = defined $save ? $save : $pod eq q{-} ? q{STDIN} : $pod;
        }
    }

    # Build the header to the HTML file
    my ( @html, $title_line_ref );
    if ( defined $do_content ) {    # [31784]
        push @html, head();

        if ( defined $do_generator ) {
            push @html, gen( $VER, $Pod::Parser::VERSION );
        }

        push @html, title($title);

        # Save  pointer for later, in case title gets replaced
        # NB: index depends on the structure of the returned HTML
        $title_line_ref = \$html[$TITLE_TEXT_LOC];

        if ( defined $do_css ) { push @html, css( $args{css} ); }

        push @html, headend;

        push @html, body( $args{body} );
    }

    delete $this->{UPARROW};
    delete $this->{UPARROW_FILE};
    if ( exists $args{top} ) {
        push @html, top;

        # Checking for the file is the only way I know of to distinguish
        if   ( -e $args{top} ) { $this->{UPARROW_FILE} = $args{top}; }
        else                   { $this->{UPARROW}      = $args{top}; }
    }

    # Avoid carry-over on multiple files
    delete $this->{IN_BEGIN};
    delete $this->{PACKAGE};
    delete $this->{TITLE};
    delete $this->{VERSION};
    $this->{INFO_COUNT} = 0;

    $parser->parse_from_file($pod);

    # If there's a head1 NAME, we've picked this up during processing
    # BUT, let the caller force override of NAME content
    if (   exists $this->{TITLE}
        && length $this->{TITLE} > 0
        && !exists $args{title}
        && defined $title_line_ref )
    {
        ${$title_line_ref} = $this->{TITLE};
    }

    if ( defined $do_index ) {
        push @html, $this->_do_index( $args{index} );
    }

    push @html, podon;
    push @html, @output;    # The pod converted to HTML
    push @html, podoff( defined $args{only_content} ? 1 : undef );   # [31784]

    # Add newlines to the HTML
    @html = map { $_ . NL } @html;

    if ( defined $save ) {
        open my $out, q{>}, $save or carp qq{Unable to open $save - $ERRNO};
        print {$out} @html or carp qq{Could not write to $out};
        close $out or carp qq{Could not close $out};
    }
    else {
        if ( $pod eq q{-} ) { print @html or carp q{Could not print}; }
    }

    return wantarray ? @html : join EMPTY, @html;
}

#############
# _DO_INDEX #
#############

sub _do_index {
    my ( $this, $add ) = @_;

    if ( defined $add )             { return toc($add); }
    if ( @{ $this->{INDEX} } == 0 ) { return toc(); }

    my @index;
    my $index_ref  = $this->{INDEX};
    my $cur_level  = 1;
    my $doing_item = FALSE;
    while ( my $index_element = shift @{$index_ref} ) {
        my ( $level, $txt ) = @{$index_element};

       # Eliminate http references. This is in aid of persons who use =item to
       # list URLs.
        my $tag = toc_tag($txt);

   # =item lists are level 0 and generate a level change wherever they show up
   # so, when we get a non-zero level we're indexing a non-item
        if ($level) {
            if ($doing_item) {
                push @index, q{</ul>};
                $cur_level--;
                $doing_item = FALSE;
            }

            while ( $level > $cur_level ) {
                $cur_level++;
                push @index, q{<ul>};
            }

            while ( $level < $cur_level ) {
                $cur_level--;
                push @index, q{</ul>};
            }
        }
        else {

            # Indexing an =item
            if ( not $doing_item ) {
                push @index, q{<ul>};
                $cur_level++;
                $doing_item = TRUE;
            }

            # Strip http to conform to =item
            $txt =~ s{\Ahttps?://}{}gmsx;
            $tag = toc_tag($txt);
        }

        push @index, qq{<li><a href='#$tag'>$txt</a></li>};
    }

    while ( $cur_level > 1 ) {
        $cur_level--;

        # =item without an enclosing =head will get duplicate <ul> and </ul>s.
        # That's OK, because its supposed to be illegal POD.
        push @index, q{</ul>};
    }

    # Note LIST return. Result is pushed onto @html
    return ( toc(@index) );
}

#############
# _DO_TITLE #
#############

sub _do_title {
    my ( $this, $txt ) = @_;

    # This happens only on the _first_ head1 NAME
    if ( ( not exists $this->{TITLE} ) and ( $txt =~ m{\ANAME}smx ) ) {
        my ($title) = $txt =~ m{\ANAME\s+(.*)}smx;
        if ( defined $title ) {

            # Oh, goody
            $title =~ s{$RE{ws}{crop}}{}gsmx;  # delete surrounding whitespace
            $this->{TITLE} = $title;
        }
        else {

# If we don't get anything off of NAME, it will be filled in by preprocess_paragraph()
            $this->{TITLE} = undef;
        }
    }
    return;
}

##################
# DEFAULT EVENTS #
##################

sub evt_on_head1 {
    my ( $this, $txt ) = @_;

    if ( not defined $txt ) { $txt = EMPTY; }

    my $tag = toc_tag($txt);

    _do_title( $this, $txt );

    # "Go to top" is attached to =head1 if selected.
    if ( exists $this->{UPARROW} ) {
        return
              q{<h1><a href='#_top'} 
            . NL
            . q{title='click to go to top of document'}
            . NL
            . qq{name='$tag'>$txt&$this->{UPARROW};</a></h1>};
    }

    if ( exists $this->{UPARROW_FILE} ) {
        return
              q{<h1><a href='#_top'} 
            . NL
            . q{title='click to go to top of document'}
            . NL
            . qq{name='$tag'>$txt<img src='$this->{UPARROW_FILE}'}
            . NL
            . q{alt=&uArr;></a></h1>};
    }

    return qq{<a name='$tag'></a><h1>$txt</h1>};
}

sub evt_on_head2 {
    my ( $this, $txt ) = @_;

    my $tag = toc_tag($txt);

    return qq{<a name='$tag'></a><h2>$txt</h2>};
}

sub evt_on_head3 {
    my ( $this, $txt ) = @_;

    my $tag = toc_tag($txt);

    return qq{<a name='$tag'></a><h3>$txt</h3>};
}

sub evt_on_head4 {
    my ( $this, $txt ) = @_;

    my $tag = toc_tag($txt);

    return qq{<a name='$tag'></a><h4>$txt</h4>};
}

sub evt_on_begin {
    my ( $this, $txt ) = @_;

    # We don't do any processing for =begin/=end other than ignore
    # However, without a command, the construct is illegal
    # Embedded =head, etc are also illegal, but we don't check
    if ( length $txt == 0 ) { $this->{IN_BEGIN} = 1; }
    return EMPTY;
}

sub evt_on_end {
    my ( $this, $txt ) = @_;

    # Ignore any commands
    delete $this->{IN_BEGIN};
    return EMPTY;
}

# See perlpodsec for details on interpreting the items
sub evt_on_l {    ## no critic (ProhibitManyArgs)
    my ( $this, $text, $inferred, $name, $section, $type ) = @_;

    if ( $type eq q{pod} ) {
        $section = defined $section ? qq{#$section} : EMPTY;    # [6062]
            # Corrupt the href to avoid having it recognized (and converted) by _add_uri_href
        $inferred =~ s{\A(.)}{$1$NUL}smx;
        my $toc_tag = toc_tag($section);

        if ( defined $name ) {
            return qq{<i><a href='h${NUL}ttp://search.cpan.org/perldoc?}
                . qq{$name$section'>$inferred</a></i>};
        }
        return qq{<i><a href='$toc_tag'>$inferred</a></i>};
    }

    if ( $type eq q{man} ) {

 # $name probably looks like "foo(1)", and the () are interpreted as metachars
        if ( $inferred !~ m{\Q$name\E}msx ) { $inferred .= qq{ in $name}; }
        return qq{<i>$inferred</i>};
    }
    if ( $type eq q{url} ) {

        # We'll let _add_uri_href handle this.
        return $name;
    }

    # Unknown type
    return $inferred;
}

sub evt_on_b {
    my ( $this, $txt ) = @_;
    return qq{<b>$txt</b>};
}

sub evt_on_i {
    my ( $this, $txt ) = @_;
    return qq{<i>$txt</i>};
}

sub evt_on_c {
    my ( $this, $txt ) = @_;
    return qq{<code>$txt</code>};
}

sub evt_on_e {
    my ( $this, $txt ) = @_;

    $txt =~ s{^&}{}smx;
    $txt =~ s{;$}{}smx;
    if ( $txt =~ m{^\d+$}smx ) { $txt = qq{#$txt}; }
    return qq{&$txt;};
}

sub evt_on_f {
    my ( $this, $txt ) = @_;
    return qq{<b><i>$txt</i></b>};
}

sub evt_on_s {
    my ( $this, $txt ) = @_;

    # Eliminate newlines; dos files use \r\n
    # \r\n is said to be not portable
    $txt =~ s{[\cM\cJ]}{}gsmx;
    return $txt;
}

sub evt_on_x { return EMPTY; }    # [20078]

sub evt_on_z { return EMPTY; }

sub evt_on_verbatim {
    my ( $this, $txt ) = @_;

    return if exists $this->{IN_BEGIN};

    # Multiple empty lines are parsed as verbatim text by Pod::Parser
    # And will show up as empty <pre> blocks, which is mucho messy
    {
        local $RS = EMPTY;
        chomp $txt;
    }

    if ( not length $txt ) { return EMPTY; }
    if ( exists $this->{IN_ITEM} ) {
        delete $this->{IN_ITEM};
        return evt_on_item( $this, $txt );
    }
    return qq{<pre>$txt</pre>};
}

sub evt_on_textblock {
    my ( $this, $txt ) = @_;
    if ( exists $this->{IN_BEGIN} ) { return; }
    if ( exists $this->{IN_ITEM} ) {
        delete $this->{IN_ITEM};
        return evt_on_item( $this, $txt );
    }
    return qq{<p>$txt</p>};
}

sub evt_on_over {
    my ( $this, $txt ) = @_;

    # Note that level is ignored
    return q{<ul>};
}

sub evt_on_item {
    my ( $this, $txt ) = @_;

    if ( ( length($txt) == 1 ) && ( $txt !~ m{\d}msx ) ) {

        # Use the content for the tag
        $this->{IN_ITEM} = 1;
        return EMPTY;
    }

    my $tag = toc_tag($txt);
    return qq{<li><a name='$tag'></a>$txt</li>};
}

sub evt_on_back { return q{</ul>}; }

sub evt_on_for { return EMPTY; }

sub evt_on_error {
    my ( $this, $txt ) = @_;
    return qq{<!-- POD_ERROR: $txt -->};
}

sub evt_on_uri {
    my ( $this, $uri ) = @_;
    my $target
        = $uri !~ m{^(?:mailto|telnet|ssh|irc):}ismx
        ? q{ target='_blank'}
        : EMPTY;    # [6062]
    my $txt = $uri;
    $txt =~ s{^mailto:}{}ismx;
    return qq{<a href='$uri'$target>$txt</a>};
}

##############
# PM_VERSION #
##############

sub pm_version {
    my $this = shift;
    if ( not defined $this ) {
        carp q{pm_version must be referenced through Pod::HtmlEasy};
        return;
    }

    return $this->{VERSION};
}

##############
# PM_PACKAGE #
##############

sub pm_package {
    my $this = shift;
    if ( not defined $this ) {
        carp q{pm_package must be referenced through Pod::HtmlEasy};
        return;
    }

    return $this->{PACKAGE};
}

###########
# PM_NAME #
###########

sub pm_name {
    my $this = shift;
    if ( not defined $this ) {
        carp q{pm_name must be referenced through Pod::HtmlEasy};
        return;
    }
    return $this->{TITLE};
}

###########################
# PM_PACKAGE_VERSION_NAME #
###########################

sub pm_package_version_name {
    my $this = shift;
    if ( not defined $this ) {
        carp
            q{pm_package_version_name must be referenced through Pod::HtmlEasy};
        return;
    }

    return ( $this->pm_package(), $this->pm_version(), $this->pm_name() );
}

################
# DEFAULOT_CSS #
################

sub default_css { return css(); }

1;

__END__