kdesdk-kio-plugins 4:17.12.3-0ubuntu1 / usr / share / kio_perldoc / pod2html.pl

#!/usr/bin/perl
#
# Code adapted from Pod::HtmlEasy for kio_perldoc.  See CPAN for the real deal.
# Integrated and crap^H^H^H^H unnecessary dependencies removed by Michael Pyne
# <michael.pyne@kdemail.net>
#
# Copyright 2007, 2008 Michael Pyne.
# Original source is licensed to be distributed under the same terms as Perl
# itself.  All changes by Michael Pyne retain this license.
#
# Based on Pod::HtmlEasy by M. P. Graciliano and Geoffrey Leach.
# http://search.cpan.org/~gleach/Pod-HtmlEasy/

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

# The function of this package is to provide a print function that is
# tied to a filehandle which is then passed as the output file to
# Pod::Parser. Note that only PRINT() and CLOSE() are defined.
# PRINT() accumulates output in an anon array, which is then referenced
# by the defining function.

package Pod::HtmlEasy::TieHandler;

use strict;
use warnings;

our $VERSION = 0.02;

sub TIEHANDLE {
    my $class  = shift;
    my $scalar = shift;

    return bless $scalar, $class;
}

sub PRINT {
    my $this = shift;

    push @{$this}, @_;
    return 1;
}

sub FILENO { return 1; }
sub CLOSE  { return 1; }

#######
# END #
#######

1;

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

package Pod::HtmlEasy::Parser;

use base qw{ Pod::Parser };

use Carp;
use English qw{ -no_match_vars };
use feature "switch";

use strict;
use warnings;
no warnings 'experimental::smartmatch';

our $VERSION = 0.03;

our $EMPTY = q{};
our $NL    = qq{\n};
our $NUL   = qq{\0};
our $SPACE = q{ };

# Set to 1 for URIs like /functions/foo to fixup links in evt_on_L
our $fnPage = 0;

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

my $MAIL_RE = qr{
         (         # grab all of this
         [\w-]+    # some word chars with '-' included   foo
         \0?       # possible NUL escape
         \@        # literal '@'                         @
         [\w\\-]+  # another word                        bar
         (?:       # non-grabbing pattern
          \.       # literal '.'                        .
          [\w\-\.]+# that word stuff                    stuff
          \.       # another literal '.'                .
          [\w\-]+  # another word                       and
          |        # or
          \.       # literal '.'                        .   
          [\w\-]+  # word                               nonsense
          |        # or empty?
         )        # end of non-grab
         )        # end of grab
        }smx;    # [6062]

# Treatment of embedded HTML-significant characters and embedded URIs.

# There are some characters (%html_entities below) which may in some
# circumstances be interpreted by a browser, and you probably don't want that
# Consequently, they are replaced by names defined by the W3C UNICODE spec,
# http://www.w3.org/TR/MathML2/bycodes.html, bracketed by '&' and ';'
# Thus, '>' becomes '&lt;' This is handled by _encode_entities()
# There's a "gotchya" in this process. As we are generating HTML,
# the encoding needs to take place _before_ any HTML is generated.

# If the HTML appears garbled, and UNICODE entities appear where they
# shouldn't, this encoding has happened to late at some point.

# This is all further complicated by the fact that the POD formatting
# codes syntax uses some of the same characters, as in "L<...>", for example,
# and we can't expand those first, because some of them generate
# HTML. This is resolved by tagging the characters that we want
# to distinguish from HTML with ASCII NUL ('\0', $NUL). Thus, '$lt;' becomes
# '\0&amp;' in _encode_entities().  Generated HTML is also handled
# this way by _nul_escape(). After all processing of the  POD formatting
# codes are processed, this is reversed by _remove _nul_escapes().

# Then there's the issue of embedded URIs. URIs are also generated
# by the processing of L<...>, and can show up _inside L<...>, we
# delay processing of embedded URIs until after all of the POD
# formatting codes is complete. URIs that result from that processing
# are tagged (you guessed it!) with a NUL character, but not preceeding
# the generated URI, but after the first character. These NULs are removed
# by _remove _nul_escapes()

my %html_entities = (
    q{&} => q{amp},
    q{>} => q{gt},
    q{<} => q{lt},
    q{"} => q{quot},
);

my $HTML_ENTITIES_RE = '[' . join ('', keys %html_entities) . ']';
$HTML_ENTITIES_RE = qr{$HTML_ENTITIES_RE};

#################
# _NUL_ESCAPE   #
#################

# Escape HTML-significant characters with ASCII NUL to differentiate them
# from the same characters that get converted to entity names

sub _nul_escape {
    my $txt_ref = shift;

    ${$txt_ref} =~ s{($HTML_ENTITIES_RE)}{$NUL$1}gsm;
    return;
}

#######################
# _REMOVE_NUL_ESCAPSE #
#######################

sub _remove_nul_escapes {
    my $txt_ref = shift;

    ${$txt_ref} =~ s{$NUL}{}gsm;
    return;
}

####################
# _ENCODE_ENTITIES #
####################

sub _encode_entities {
    my ( $txt_ref ) = @_;

    return unless $$txt_ref;

    foreach my $chr ( keys %html_entities ) {

        my $re = qr{(?<!$NUL)$chr};
        my $replacement = '&' . $html_entities{$chr} . ';';
        ${$txt_ref} =~ s{$re}{$NUL$replacement}gsm;
    }

    return;
}

sub setFunctionPage {
    my $this = shift;
    our $fnPage = shift;
}

###########
# COMMAND #
###########

# Overrides command() provided by base class in Pod::Parser
sub command {
    my ( $parser, $command, $paragraph, $line_num, $pod ) = @_;

    if ( defined $parser->{POD_HTMLEASY}->{VERBATIM_BUFFER} ) {
        _verbatim($parser);
    }    # [6062]

    my $expansion = $parser->interpolate( $paragraph, $line_num );

    $expansion =~ s{^\s*}{}gsm;    # delete surrounding whitespace
    $expansion =~ s{\s*$}{}gsm;    # delete surrounding whitespace

    # Encoding puts in a NUL; we're finished with the text, so remove them
    _encode_entities( \$expansion );
    _remove_nul_escapes( \$expansion );

# Create the index tag
# a_name has the text of the expansion _without_ anything between '<' and '>',
# which amounts to the HTML formatting codes, which are not processed by
# the name directive.
    my $a_name = $expansion;
    $a_name =~ s{<.*?>}{}gsm;

    $a_name =~ /</g;
    my $pos = pos($a_name);
    my $start = $pos;
    my $count = 0;
    $count++ if defined $pos;

    while(defined $pos and $count != 0)
    {
        my $match = $a_name =~ /\G[^<>]*([<>])/g;

        last unless $match;
        $pos = pos($a_name);

        $count++ if $1 eq '<';
        $count-- if $1 eq '>';
    }

    if (defined $pos and defined $start) {
        $pos = $pos - $start + 1;
        $start = $start - 1;
        $a_name =~ s/^(.{$start}).{$pos}/$1/;
    }

    my $html;
    given ($command) {
        when ("head1") {
            _add_tree_point( $parser, $expansion, 1 );
            $html = $parser->{POD_HTMLEASY}
                ->{ON_HEAD1}( $parser->{POD_HTMLEASY}, $expansion, $a_name );
        }
        when ("head2") {
            _add_tree_point( $parser, $expansion, 2 );
            $html = $parser->{POD_HTMLEASY}
                ->{ON_HEAD2}( $parser->{POD_HTMLEASY}, $expansion, $a_name );
        }
        when ("head3") {
            _add_tree_point( $parser, $expansion, 3 );
            $html = $parser->{POD_HTMLEASY}
                ->{ON_HEAD3}( $parser->{POD_HTMLEASY}, $expansion, $a_name );
        }
        when ("head4") {
            _add_tree_point( $parser, $expansion, 4 );
            $html = $parser->{POD_HTMLEASY}
                ->{ON_HEAD4}( $parser->{POD_HTMLEASY}, $expansion, $a_name );
        }
        when ("begin") {
            _add_tree_point( $parser, $expansion, 4 );
            $html = $parser->{POD_HTMLEASY}
                ->{ON_BEGIN}( $parser->{POD_HTMLEASY}, $expansion, $a_name );
        }
        when ("end") {
            $html = $parser->{POD_HTMLEASY}
                ->{ON_END}( $parser->{POD_HTMLEASY}, $expansion, $a_name );
        }
        when ("over") {
            if ( $parser->{INDEX_ITEM} ) {
                $parser->{INDEX_ITEM_LEVEL}++;
            }
            $html = $parser->{POD_HTMLEASY}
                ->{ON_OVER}( $parser->{POD_HTMLEASY}, $expansion );
        }
        when ("item") {
            if ( $parser->{INDEX_ITEM} ) {
                _add_tree_point( $parser, $expansion,
                    ( 3 + ( $parser->{INDEX_ITEM_LEVEL} || 1 ) ) );
            }
            $html = $parser->{POD_HTMLEASY}
                ->{ON_ITEM}( $parser->{POD_HTMLEASY}, $expansion, $a_name );
        }
        when ("back") {
            if ( $parser->{INDEX_ITEM} ) {
                $parser->{INDEX_ITEM_LEVEL}--;
            }
            $html = $parser->{POD_HTMLEASY}
                ->{ON_BACK}( $parser->{POD_HTMLEASY}, $expansion );
        }
        when ("for") {
            $html = $parser->{POD_HTMLEASY}
                ->{ON_FOR}( $parser->{POD_HTMLEASY}, $expansion, $a_name );
        }
        when ("include") {
            my $file = $parser->{POD_HTMLEASY}
                ->{ON_INCLUDE}( $parser->{POD_HTMLEASY}, $expansion );
            if (   -e $file
                && -r _ ) # _ is the last checked filehandle.
            {
                $parser->{POD_HTMLEASY}->parse_include($file);
            }
        }
        default {
            if ( defined $parser->{POD_HTMLEASY}->{qq{ON_\U$command\E}} ) {
                $html = $parser->{POD_HTMLEASY}
                    ->{qq{ON_\U$command\E}}( $parser->{POD_HTMLEASY},
                    $expansion );
            }
            elsif ( $command !~ /^(?:pod|cut)$/imx ) {
                $html = qq{<pre>=$command $expansion</pre>};
            }
            else { $html = $EMPTY; }
        }
    };

    if ( $html ne $EMPTY ) {
        print { $parser->output_handle() } $html;
    }    # [6062]

    return;
}

############
# VERBATIM #
############

# Overrides verbatim() provided by base class in Pod::Parser
sub verbatim {
    my ( $parser, $paragraph, $line_num ) = @_;

    if ( exists $parser->{POD_HTMLEASY}->{IN_BEGIN} ) { return; }
    $parser->{POD_HTMLEASY}->{VERBATIM_BUFFER} .= $paragraph;

    return;
}

sub _verbatim {
    my ($parser) = @_;

    if ( exists $parser->{POD_HTMLEASY}->{IN_BEGIN} ) { return; }
    my $expansion = $parser->{POD_HTMLEASY}->{VERBATIM_BUFFER};
    $parser->{POD_HTMLEASY}->{VERBATIM_BUFFER} = $EMPTY;

    _encode_entities( \$expansion );

    my $html = $parser->{POD_HTMLEASY}
        ->{ON_VERBATIM}( $parser->{POD_HTMLEASY}, $expansion );

    # And remove any NUL escapes
    _remove_nul_escapes( \$html );

    if ( $html ne $EMPTY ) {
        print { $parser->output_handle() } $html;
    }    # [6062]

    return;
}

#############
# TEXTBLOCK #
#############

# Overrides textblock() provided by base class in Pod::Parser
sub textblock {
    my ( $parser, $paragraph, $line_num ) = @_;

    if ( exists $parser->{POD_HTMLEASY}->{IN_BEGIN} ) { return; }
    if ( defined $parser->{POD_HTMLEASY}->{VERBATIM_BUFFER} ) {
        _verbatim($parser);
    }    # [6062]

    my $expansion = $parser->interpolate( $paragraph, $line_num );

    $expansion =~ s{^\s+}{}gsmx;
    $expansion =~ s{\s+$}{}gsmx;

    # Encode HTML-specific characters before adding any HTML (eg <p>)
    _encode_entities( \$expansion );

    my $html = $parser->{POD_HTMLEASY}
        ->{ON_TEXTBLOCK}( $parser->{POD_HTMLEASY}, $expansion );

    # And remove any NUL escapes
    _remove_nul_escapes( \$html );

    if ( $html ne $EMPTY ) { print { $parser->output_handle() } $html; }

    return;
}

#####################
# INTERIOR_SEQUENCE #
#####################

# Overrides interior_sequence() provided by base class in Pod::Parser
sub interior_sequence {
    my ( $parser, $seq_command, $seq_argument, $pod_seq ) = @_;

    my $ret;

    # If we're in the middle of a link then escaping now could break some of
    # the link uncracking code.
    _encode_entities(\$seq_argument) unless $seq_command eq 'L';

    # Not sure how these get in here but HTML doesn't support &sol; (which is
    # simply forward slash
    $seq_argument =~ s/&sol;/\//g;

    if ($pod_seq->nested() and $pod_seq->nested()->cmd_name() eq 'L'
        and $seq_command ne 'E')
    {
        # Interpolating into a hyperlink, ignore formatting, unless we are
        # processing an escape code
        return $seq_argument;
    }

    given ($seq_command) {
        when ("B") {
            $ret = $parser->{POD_HTMLEASY}
                ->{ON_B}( $parser->{POD_HTMLEASY}, $seq_argument );
        }
        when ("C") {
            $ret = $parser->{POD_HTMLEASY}
                ->{ON_C}( $parser->{POD_HTMLEASY}, $seq_argument );
        }
        when ("E") {
            $ret = $parser->{POD_HTMLEASY}
                ->{ON_E}( $parser->{POD_HTMLEASY}, $seq_argument );
        }
        when ("F") {
            $ret = $parser->{POD_HTMLEASY}
                ->{ON_F}( $parser->{POD_HTMLEASY}, $seq_argument );
        }
        when ("I") {
            $ret = $parser->{POD_HTMLEASY}
                ->{ON_I}( $parser->{POD_HTMLEASY}, $seq_argument );
        }
        when ("L") {
            my ( $text, $name, $section, $type ) = _parselink($seq_argument);

            # Held off on escaping these earlier, take care of it now.
            _encode_entities(\$text);
            _encode_entities(\$section) if $section;
            _encode_entities(\$name) if $name;

            $ret = $parser->{POD_HTMLEASY}->{ON_L}(
                $parser->{POD_HTMLEASY},
                $seq_argument, $text, $name, $section, $type, $fnPage,
            );
        }
        when ("S") {
            $ret = $parser->{POD_HTMLEASY}
                ->{ON_S}( $parser->{POD_HTMLEASY}, $seq_argument );
        }
        when ("Z") {
            $ret = $parser->{POD_HTMLEASY}
                ->{ON_Z}( $parser->{POD_HTMLEASY}, $seq_argument );
        }
        default {
            if ( defined $parser->{POD_HTMLEASY}->{qq{ON_\U$seq_command\E}} )
            {
                $ret = $parser->{POD_HTMLEASY}
                    ->{qq{ON_\U$seq_command\E}}( $parser->{POD_HTMLEASY},
                    $seq_argument );
            }
            else {
                $ret = qq{$seq_command<$seq_argument>};
            }
        }
    }

    # Escape HTML-significant characters to prevent them from being escaped
    # later.
    _nul_escape( \$ret );

    return $ret;
}

########################
# PREPROCESS_PARAGRAPH #
########################

# Overrides preprocess_paragraph() provided by base class in Pod::Parser
# NB: the text is _not altered.
sub preprocess_paragraph {
    my $parser = shift;
    my ( $text, $line_num ) = @_;

    if ( $parser->{POD_HTMLEASY}{INFO_COUNT} == 3 ) {
        return $text;
    }

    if ( not exists $parser->{POD_HTMLEASY}{PACKAGE} ) {
        if ( $text =~ m{package}smx ) {
            my ($pack) = $text =~ m{(\w+(?:::\w+)*)}smx;
            if ( defined $pack ) {
                $parser->{POD_HTMLEASY}{PACKAGE} = $pack;
                $parser->{POD_HTMLEASY}{INFO_COUNT}++;
            }
        }
    }

    if ( not exists $parser->{POD_HTMLEASY}{VERSION} ) {
        if ( $text =~ m{VERSION}smx ) {
            my ($ver) = $text =~ m{(\d)(?:\.\d*)?}smx;
            if ( defined $ver ) {
                $parser->{POD_HTMLEASY}{VERSION} = $ver;
                $parser->{POD_HTMLEASY}{INFO_COUNT}++;
            }
        }
    }

    # This situation is created by evt_on_head1()
    if (    ( exists $parser->{POD_HTMLEASY}{TITLE} )
        and ( not defined $parser->{POD_HTMLEASY}{TITLE} ) )
    {
        my @lines = split m{\n}smx, $text;
        my $tmp_text = shift @lines;
        if ( not defined $tmp_text ) { return $text; }
        $tmp_text =~ s{^\s*}{}gsmx;   # delete surrounding whitespace
        $tmp_text =~ s{\s*$}{}gsmx;   # delete surrounding whitespace
        $parser->{POD_HTMLEASY}{TITLE} = $tmp_text;
        $parser->{POD_HTMLEASY}{INFO_COUNT}++;
    }

    return $text;
}

##################
# _PARSE_SECTION #
##################

# Parse a link that is not a URL to get the name and/or section
# Algorithm may be found in perlpodspec. "About L<...> Codes"

sub _parse_section {
    my $link = shift;
    $link =~ s{^\s*}{}sm;    # delete surrounding whitespace
    $link =~ s{\s*$}{}sm;    # delete surrounding whitespace

    # L<"FooBar"> is a the way to specify a section without a name.
    # However, L<Foo Bar> is possible, though deprecated. See below.
    if ($link =~ m/^"/) {
        $link =~ s{^"+\s*}{}sm;  # strip the "s
        $link =~ s{\s*"+$}{}sm;
        return ( undef, $link );
    }

    # So now we have either a name by itself, or name/section
    my ( $name, $section ) = split m[\s*/\s*]sm, $link, 2;

    # Trim leading and trailing whitespace and quotes from section
    if ($section) {
        $section =~ s{"}{}gsm;                # quotes
        $section =~ s{^\s*}{}sm;    # delete surrounding whitespace
        $section =~ s{\s*$}{}sm;    # delete surrounding whitespace
    }    # new leading/trailing

# Perlpodspec observes that and acceptable way to distinguish between L<name> and
# L<section> is that if the link contains any whitespace, then it is a section.
# The construct L<section> is deprecated.
    if ( $name && $name =~ m{\s}sm && !defined $section ) {
        $section = $name;
        $name    = undef;
    }

    return ( $name, $section );
}

###############
# _INFER_TEXT #
###############

# Infer the text content of a L<...> with no text| part (ie a text|-less link)
# By definition (?) either name or section is nonempty, Algorithm from perlpodspec

sub _infer_text {
    my ( $name, $section ) = @_;

    if ($name) {
        return $section
            ? "\"$section\" in $name"
            : $name;
    }

    return $section;
}

##############
# _PARSELINK #
##############

# Parse the content of L<...> and return
#   The text label
#   The name or URL
#   The section (if relevant)
#   The type of link discovered: url, man or pod

sub _parselink {
    my $link = shift;
    my $text;

    # Squeeze out multiple spaces
    $link =~ s{\s+}{$SPACE}gsm;

    if ( $link =~ m{\|}smx ) {

        # Link is in the form "L<Foo|Foo::Bar>"
        ( $text, $link ) = split m{\|}sm, $link, 2;
    }

# Check for a generalized URL. The regex is defined in perlpodspec.
# Quoting perlpodspec: "Authors wanting to link to a particular (absolute) URL, must do so
# only with "L<scheme:...>" codes and must not attempt "L<Some Site Name|scheme:...>"
# Consequently, although $text might be nonempty, we ignore it.
    if ($link =~ m{
                    \A      # The beginning of the string
                    \w+     # followed by some alphanumerics, which would be the protocol (or scheme)
                    :       # literal ":"
                    [^:\s]  # one char that is neither a ":" or whitespace
                    \S*     # maybe some non-whitespace
                    \z      # the end of the string
                   }smx
        )
    {
        return ( $link, $link, undef, q{url} );
    }

    # OK, we've eliminated URLs, so we must be dealing with something else

    my ( $name, $section ) = _parse_section($link);
    if ( not defined $text ) { $text = _infer_text( $name, $section ); }

# A link with parenthesized non-whitespace is assumed to be a manpage reference
# (per perlpodspec))
    my $type =
        ( $name && $name =~ m{\(\S*\)}smx )
        ? q{man}
        : q{pod};

    return ( $text, $name, $section, $type );
}

###################
# _ADD_TREE_POINT #
###################

sub _add_tree_point {
    my ( $parser, $name, $level ) = @_;
    $level ||= 1;

    if ( $level == 1 ) {
        $parser->{POD_HTMLEASY}->{INDEX}{p}
            = $parser->{POD_HTMLEASY}->{INDEX}{tree};
    }
    else {
        if ( exists $parser->{POD_HTMLEASY}->{INDEX}{p} ) {
            while ( $parser->{POD_HTMLEASY}
                ->{INDEX}{l}{ $parser->{POD_HTMLEASY}->{INDEX}{p} }
                > ( $level - 1 ) )
            {
                last
                    if !$parser->{POD_HTMLEASY}
                    ->{INDEX}{b}{ $parser->{POD_HTMLEASY}->{INDEX}{p} };
                $parser->{POD_HTMLEASY}->{INDEX}{p} = $parser->{POD_HTMLEASY}
                    ->{INDEX}{b}{ $parser->{POD_HTMLEASY}->{INDEX}{p} };
            }
        }
    }

    my $array = [];

    $parser->{POD_HTMLEASY}->{INDEX}{l}{$array} = $level;
    $parser->{POD_HTMLEASY}->{INDEX}{b}{$array}
        = $parser->{POD_HTMLEASY}->{INDEX}{p};

    push @{ $parser->{POD_HTMLEASY}->{INDEX}{p} }, $name, $array;
    $parser->{POD_HTMLEASY}->{INDEX}{p} = $array;

    return;

}

#############
# BEGIN_POD #
#############

# Overrides begin_pod() provided by base class in Pod::Parser
sub begin_pod {
    my ($parser) = @_;

    if ( $parser->{POD_HTMLEASY_INCLUDE} ) { return; }

    delete $parser->{POD_HTMLEASY}->{INDEX};
    $parser->{POD_HTMLEASY}->{INDEX} = { tree => [] };

    return 1;
}

###########
# END_POD #
###########

# Overrides end_pod() provided by base class in Pod::Parser
sub end_pod {
    my ($parser) = @_;

    if ( $parser->{POD_HTMLEASY_INCLUDE} ) { return; }

    if ( defined $parser->{POD_HTMLEASY}->{VERBATIM_BUFFER} ) {
        _verbatim($parser);
    }

    my $tree = $parser->{POD_HTMLEASY}->{INDEX}{tree};

    delete $parser->{POD_HTMLEASY}->{INDEX};

    $parser->{POD_HTMLEASY}->{INDEX} = $tree;

    return 1;
}

###########
# _ERRORS #
###########

sub _errors {
    my ( $parser, $error ) = @_;

    carp "$error";
    $error =~ s{^\s*\**\s*errors?:?\s*}{}ismx;
    $error =~ s{\s+$}{}smx;

    my $html = $parser->{POD_HTMLEASY}
        ->{ON_ERROR}( $parser->{POD_HTMLEASY}, $error );
    if ( $html ne $EMPTY ) {
        print { $parser->output_handle() } $html, $NL;
    }

    return 1;
}

###########
# DESTROY #
###########

sub DESTROY { }

#######
# END #
#######

1;

#############################################################################
## Name:        HtmlEasy.pm
## Purpose:     Pod::HtmlEasy
## Author:      Graciliano M. P.
## Modified by: Geoffrey Leach
## Created:     2004-01-11
## Updated:	    2007-02-28
## Copyright:   (c) 2004 Graciliano M. P.
## 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.008;

use Carp;
use English qw{ -no_match_vars };

use strict;
use warnings;

our $VERSION = 0.09;    # Also appears in "=head1 VERSION" in the POD below

our $EMPTY = q{};
our $NL    = qq{\n};
our $NUL   = qq{\0};
our $SPACE = q{ };

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

my %BODY_DEF = (
    bgcolor => '#FFFFFF',
    text    => '#000000',
    link    => '#000000',
    vlink   => '#000066',
    alink   => '#FF0000',
);

# This keeps track of valid options
my %OPTS = (
    basic_entities  => 1,
    body            => 1,
    common_entities => 1,
    css             => 1,
    faq_page        => 0,
    function_page   => 0,
    index           => 1,
    index_item      => 1,
    no_css          => 1,
    no_generator    => 1,
    no_index        => 1,
    only_content    => 1,
    parserwarn      => 1,
    title           => 1,
    top             => 1,
);

my $output_file;

#######
# CSS #
#######

my $CSS_DEF = q`
/*
** HTML elements
*/

body {
    margin: 10px;
    padding: 0;
    text-align: center;
    font-size: 0.8em;
    font-family: "Bitstream Vera Sans", "Lucida Grande", "Trebuchet MS", sans-serif;
    color: #535353;
    background: #ffffff;
}


/*
** HTML Tags
*/

h1, h2, h3, h4
{
    padding: 0;
    text-align: left;
    font-weight: bold;
    color: #f7800a;
    background: transparent;
}

h1 {
    margin: 0 0 0.3em 0;
    font-size: 1.7em;
}

h1.name + p {
    font-size: larger;
    font-style: oblique;
}

h2, h3, h4 {
    margin: 1.3em 0 0 0.3em
}

h2 {
    font-size: 1.5em;
}

h3 {
    font-size: 1.4em;
}

h4 {
    font-size: 1.3em;
}

h5 {
    font-size: 1.2em;
}

a:link {
    padding-bottom: 0;
    text-decoration: none;
    color: #0057ae;
}

a:visited {
    padding-bottom: 0;
    text-decoration: none;
    color: #644A9B;
}


a[href]:hover {
    text-decoration: underline;
}

hr {
    margin: 0.3em 1em 0.3em 1em;
    height: 1px;
    border: #bcbcbc dashed;
    border-width: 0 0 1px 0;
}

pre {
    display: block;
    margin: 0.3em;
    padding: 0.3em;
    font-size: 1em;
    color: #000000;
    text-align: left;
    background: #f9f9f9;
    border: #2f6fab dashed;
    border-width: 1px;
    overflow: auto;
    line-height: 1.1em;
}

input, textarea, select {
    margin: 0.2em;
    padding: 0.1em;
    color: #888888;
    background: #ffffff;
    border: 1px solid;
}

blockquote {
    margin: 0.3em;
    padding-left: 2.5em;
    background: transparent;
}

del {
    color: #800000;
    text-decoration: line-through;
}

dt {
    font-weight: bold;
    font-size: 1.05em;
    color: #0057ae;
}

dd {
    margin-left: 1em;
}

p {
    margin-top: 0.5em;
    margin-bottom: 0.9em;
    text-align: justify;
}
fieldset {
    border: #cccccc 1px solid;
}

li {
    text-align: left;
}

fieldset {
    margin-bottom: 1em;
    padding: .5em;
}

form {
    margin: 0;
    padding: 0;
}

hr {
    height: 1px;
    border: #888888 1px solid;
    background: #888888;
    margin: 0.5em 0 0.5em 0 ;
}

.toc a {
    text-decoration: none;
}

.toc li {
    list-style-type: none;
    line-height: larger;
}

img {
    border: 0;
}

table {
    border-collapse: collapse;
    font-size: 1em;
}

th {
    text-align: left;
    padding-right: 1em;
    border: #cccccc solid;
    border-width: 0 0 3px 0;
}
`;

###############
# DEFAULT_CSS #
###############

sub default_css {
    return $CSS_DEF;
}

#######################
# _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_INDEX_NODE_START} = \&evt_on_index_node_start;
    $this->{ON_INDEX_NODE_END}   = \&evt_on_index_node_end;

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

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

    return;
}

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

sub new {
    my $this = shift;
    return $this if ref $this;
    my $class = $this || __PACKAGE__;
    $this = bless {}, $class;

    my (%args) = @_;
    _organize_callbacks($this);

    # Backwards compatibility
    if ( exists $args{on_verbatin} ) {
        $this->{ON_VERBATIM} = $args{on_verbatin};
    }

    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 {
    my $this = shift;
    my $file = shift;

    # Assume a non-option second arg is a file name
    my $save = (exists $OPTS{ $_[0] } ? undef: shift) if defined $_[0];
    my %args = @_;

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

    # No /x please
    if ( defined $save && $save =~ m{$NL}sm ) {

        # Is this a M$ way of saying "nothing there"?
        $save = undef;
    }

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

    $parser->errorsub( sub { Pod::HtmlEasy::Parser::errors( $parser, @_ ); }
    );

    # Pod::Parser wiii complain about multiple blank lines in the 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
    $parser->parseopts( -want_nonPODs => 1 );

    if (exists $args{'function_page'}) { $parser->setFunctionPage($args{'function_page'}); }

    # 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; }
    if ( exists $args{basic_entities} ) {
        carp q{"basic_entities" is deprecated.};
    }
    if ( exists $args{common_entities} ) {
        carp q{"common_entities" is deprecated.};
    }

    # *HTML supplies a PRINT method that's used by the parser to do output
    # It gets accumulated into HTML, which is tied to $output.
    # You'll also see calls to  print {$parser->output_handle()} ...
    # which accomplishes the same thing. When all is said and done, the output
    # of the parse winds up in $output declared below, and used in the construction
    # of @html.

    my $output = [];
    local *HTML;
    tie *HTML => 'Pod::HtmlEasy::TieHandler', $output;
    my $html = \*HTML;
    $this->{TIEDOUTPUT} = $html;

    my $title = $args{title};
    if ( ref $file eq q{GLOB} ) {    # $file is an open filehandle
        if ( not defined $title ) { $title = q{<DATA>}; }
    }
    else {
        if ( !-e $file ) {
            carp qq{No file $file};
            return;
        }
        if ( not defined $title ) { $title = $file; }
    }

    # Build the header to the HTML file
    my @html;
    push @html,
        qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">$NL};
    push @html, qq{<html><head>$NL};
    push @html,
        qq{<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">$NL};

    if ( not exists $args{no_generator} ) {
        push @html,
            qq{<meta name="GENERATOR" content="kio_perldoc Pod::HtmlEasy/$VERSION Pod::Parser/$Pod::Parser::VERSION Perl/$] [$^O]">$NL};
    }
    push @html, qq{<title>$title</title>$NL};
    my $title_line_ref = \$html[-1];
    push @html, _organize_css( \%args );
    push @html, qq{</head>$NL};
    if ( not exists $args{only_content} ) {
        push @html, _organize_body( \%args );
    }

    delete $this->{UPARROW};
    delete $this->{UPARROW_FILE};
    push @html, qq{<div id="header"><div id="header_top"><div><div>$NL};
    push @html, qq{<img src="help:/kdoctools5-common/part_of_the_kde_family_horizontal_190.png" alt="Part of the KDE family"> $title - KDE Perldoc Viewer</div></div></div></div>};
    push @html, q{<div class="pod">};

    if ( exists $args{top} ) {
        push @html, qq{$NL<a name='_top'></a>$NL};
        if ( -e $args{top} ) {
            $this->{UPARROW_FILE} = $args{top};
        }
        else {
            $this->{UPARROW} = $args{top};
        }
    }

    if ($args{'faq_page'}) {
        push @html, qq{$NL<p>The following FAQ results were found:</p>$NL};
    }

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

    # A filehandle as both args is not documented, but is supported
    # Everything that Pod::Parser prints winds up in $output
    $parser->parse_from_file( $file, $html );

    # If there's a head1 NAME, we've picked this up during processing
    if ( defined $this->{TITLE} && length $this->{TITLE} > 0 ) {
        ${$title_line_ref} = qq{<title>$this->{TITLE}</title>$NL};
    }

  # Note conflict here: user can specify an index, and no_index; no_index wins
    if ( not exists $args{index} ) { $args{index} = $this->build_index(); }
    if ( exists $args{no_index} )  { $args{index} = $EMPTY; }

    if ( $args{'faq_page'} && not @{$output} ) {
        @{$output} = ("<b>None</b>");
    }

    my $kio_perldoc_version = $ENV{'KIO_PERLDOC_VERSION'} || "Unknown";

    push @html, qq{$args{index}$NL};
    push @html, @{$output};                      # The pod converted to HTML
    push @html, qq{</div><div id="footer"><div id="footer_text">Generated by kio_perldoc, version $kio_perldoc_version</div></div>};
    push @html, qq{</body></html>$NL};

    delete $this->{TIEDOUTPUT};
    close $html or carp q{Could not close html};
    untie $html or carp q{Could not untie html};

    if ( defined $save ) {
        open my $out, q{>}, $save or croak qq{Unable to open $save - $!};
        print {$out} @html;
        close $out;
    }

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

#################
# PARSE_INCLUDE #
#################

sub parse_include {
    my $this = shift;
    my $file = shift;

    my $parser = Pod::HtmlEasy::Parser->new();
    $parser->errorsub( sub { Pod::HtmlEasy::Parser::errors( $parser, @_ ); }
    );
    $parser->{POD_HTMLEASY}         = $this;
    $parser->{POD_HTMLEASY_INCLUDE} = 1;

    $parser->parse_from_file( $file, $this->{TIEDOUTPUT} );

    return 1;
}

##############
# WALK_INDEX #
##############

sub walk_index {
    my ( $this, $tree, $on_open, $on_close, $output ) = @_;

    my $i = 0;
    while ( $i < @{$tree} ) {
        my $nk =
            ref( ${$tree}[ $i + 1 ] ) eq q{ARRAY}
            ? @{ ${$tree}[ $i + 1 ] }
            : undef;
        $nk = $nk >= 1 ? 1 : undef;

        my $a_name = ${$tree}[$i];
        $a_name =~ s{<.*?>}{}gsmx;

        #$a_name =~ s{&\w+;}{}gsmx;
        #$a_name =~ s{\W+}{-}gsmx;

        if ($on_open) {
            my $ret = $on_open->( $this, ${$tree}[$i], $a_name, $nk );
            if ( $output and defined $ret ) {
                ${$output} .= $ret;
            }    # [6062]
        }

        if ($nk) {
            walk_index( $this, ${$tree}[ $i + 1 ],
                $on_open, $on_close, $output );
        }

        if ($on_close) {
            my $ret = $on_close->( $this, ${$tree}[$i], $a_name, $nk );
            if ( $output and defined $ret ) {
                ${$output} .= $ret;
            }    # [6062]
        }
        $i += 2;
    }
    return;
}

###############
# BUILD_INDEX #
###############

sub build_index {
    my $this = shift;

    my $index = $EMPTY;    # [6062]
    $this->walk_index(
        $this->{INDEX},
        $this->{ON_INDEX_NODE_START},
        $this->{ON_INDEX_NODE_END}, \$index
    );

    return qq{<div class="toc">$NL<ul>$NL$index</ul>$NL</div>$NL};
}

#################
# _ORGANIZE_BODY #
#################

sub _organize_body {
    my $args_ref = shift;

    my ( $body, %body );

    $body = $EMPTY;
    if ( ref $args_ref->{body} eq q{HASH} ) {
        %body = %BODY_DEF;
        my %body_attr = %{ $args_ref->{body} };
        foreach my $key ( keys %body_attr ) {
            $body{$key} = $body_attr{$key};
        }
    }
    elsif ( !exists $args_ref->{body} ) { %body = %BODY_DEF; }

    if (%body) {
        foreach my $key ( sort keys %body ) {
            if ( $body{$key} !~ m{\#}smx && defined $BODY_DEF{$key} ) {
                $body{$key} = qq{#$body{$key}};
            }
            my $value =
                $body{$key} !~ m{"}smx
                ? qq{"$body{$key}"}
                : qq{'$body{$key}'};
            $body .= qq{ $key=$value};
        }
    }
    else { $body = $args_ref->{body}; }

    return qq{<body $body>};
}

################
# ORGANIZE_CSS #
################

sub _organize_css {
    my $perldoc_css = $ENV{'KIO_PERLDOC_CSSLOCATION'};
    chomp $perldoc_css;

    return <<"EOL";
<link rel="stylesheet" href="help:/kdoctools5-common/kde-default.css" type="text/css">
<link rel="stylesheet" href="file://$perldoc_css" type="text/css">
<style>
    #header_top {
        background-image: url("help:/kdoctools5-common/top.jpg");
    }
    #header_top div {
        background-image: url("help:/kdoctools5-common/top-left.jpg");
    }
    #header_top div div {
        background-image: url("help:/kdoctools5-common/top-right.jpg");
    }
    div.pod {
        margin-left: 5em;
        margin-right: 5em;
    }
</style>
EOL
}

##################
# EVENT SUPPORT  #
##################

sub do_title {
    my $this = shift;
    my ( $txt, $a_name ) = @_;

    # 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{^\s*}{}gsmx;  # delete surrounding whitespace
            $title =~ s{\s*$}{}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 = shift;
    my ( $txt, $a_name ) = @_;

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

    do_title( $this, $txt, $a_name );

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

    my $style = '';
    $style = 'class="name"' if $txt =~ m{\ANAME};

    return qq{<a name='$a_name'></a><h1 $style>$txt</h1>$NL};
}

sub evt_on_head2 {
    my $this = shift;
    my ( $txt, $a_name ) = @_;
    return qq{<a name='$a_name'></a><h2>$txt</h2>$NL$NL};
}

sub evt_on_head3 {
    my $this = shift;
    my ( $txt, $a_name ) = @_;
    return qq{<a name='$a_name'></a><h3>$txt</h3>$NL$NL};
}

sub evt_on_head4 {
    my $this = shift;
    my ( $txt, $a_name ) = @_;
    return qq{<a name='$a_name'></a><h4>$txt</h4>$NL$NL};
}

sub evt_on_begin {
    my $this = shift;
    my ( $txt, $a_name ) = @_;
    $this->{IN_BEGIN} = 1;
    return $EMPTY;
}

sub evt_on_end {
    my $this = shift;
    my ( $txt, $a_name ) = @_;
    delete $this->{IN_BEGIN};
    return $EMPTY;
}

sub evt_on_L {
    my ($this, $L, $text, $page, $section, $type, $fnPage) = @_;

    Pod::HtmlEasy::Parser::_encode_entities(\$page);

    if($type eq 'pod') {
        $page = '' unless defined $page;

        if($fnPage and not $page) {
            $page = "functions/";
            $section = "" unless defined $section;
        }
        else {
            $section = defined $section ? "#$section" : "";
        }

        # Keep later escaping functions from incorrectly messing this up.
        $section =~ s/^(.)/$1$NUL/;

        # The browser knows what to do for simple links in the same page,
        # and knows how to do it better than we do.
        return "<a href=\"$section\">$text</a>" unless $page;

        $page =~ s/^(.)/$1$NUL/;
        return "<a href=\"perldoc:$page$section\">$text</a>";
    }
    elsif($type eq 'man') {
        return "<a href=\"man:/$page\">$text</a>";
    }
    elsif($type eq 'url') {
        # Keep later escaping functions from incorrectly messing this up.
        $page =~ s/^(.)/$1$NUL/;
        $text =~ s/^(.)/$1$NUL/;

        return "<a href=\"$page\" target=\"_blank\">$text</a>";
    }
}

sub evt_on_B {
    my $this = shift;
    my $txt  = shift;
    return qq{<b>$txt</b>};
}

sub evt_on_I {
    my $this = shift;
    my $txt  = shift;
    return qq{<i>$txt</i>};
}

sub evt_on_C {
    my $this = shift;
    my $txt  = shift;

    # Who would put IMG tags in this?
    return $EMPTY if $txt =~ m{<IMG}i;
    return "<tt>$txt</tt>";
}

sub evt_on_E {
    my $this = shift;
    my $txt  = shift;

    # Hey guess what, not all &foo; entities are part of HTML!  So don't go
    # throwing them out without checking.
    return "/" if $txt eq '&sol;';

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

sub evt_on_F {
    my $this = shift;
    my $txt  = shift;

    # Some pod encoders put hyperlinks in F<>??
    return qq{<a href="$txt">$txt</a>} if $txt =~ m'^http://';
    return qq{<b><i>$txt</i></b>};
}

sub evt_on_S {
    my $this = shift;
    my $txt  = shift;
    $txt =~ s{$SPACE}{&nbsp;}gs;
    return $txt;
}

sub evt_on_X { return $EMPTY; }    # [20078]

sub evt_on_Z { return $EMPTY; }

sub evt_on_verbatim {
    my $this = shift;
    my $txt  = shift;

    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; }
    return qq{<pre>$txt</pre>$NL};
}

sub evt_on_textblock {
    my $this = shift;
    my $txt  = shift;
    return if exists $this->{IN_BEGIN};
    return qq{<p>$txt</p>$NL};
}

sub evt_on_over {
    my $this  = shift;
    my $level = shift;
    return qq{<ul>$NL};
}

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

    # POD has no list item tag, so most authors simulate it, breaking the HTML.
    # So, strip out most bullet characters.
    $txt =~ s/^\s*[\*oO\+\-\.](?!\S)//;

    # If POD authors are going so far as to number the list, it's already too
    # late to fix it by using <ol> tag, but we can change the CSS style.
    my $style = '';
    if ($txt =~ m/^\d+\.?/) {
        $style = qq{ style="list-style-type:decimal;"};
        $txt =~ s/^\d+\.?\s*//;
    }

    return qq{<li$style>$NL} if $txt =~ /^\s*$/;
    return qq{<li$style><a name='$a_name'></a><b>$txt</b></li>$NL};
}

sub evt_on_back {
    my $this = shift;
    return qq{</ul>$NL};
}

sub evt_on_for { return $EMPTY; }

sub evt_on_error {
    my $this = shift;
    my $txt  = shift;
    return qq{<!-- POD_ERROR: $txt -->};
}

sub evt_on_include {
    my $this = shift;
    my $file = shift;
    return $file;
}

sub evt_on_uri {
    my $this = shift;
    my $uri  = shift;
    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>};
}

sub evt_on_index_node_start {
    my $this = shift;
    my ( $txt, $a_name, $has_children ) = @_;

    my $ret = qq{<li><a href='#$a_name'>$txt</a>$NL};
    if ($has_children) {
        $ret .= qq{$NL<ul>$NL};
    }
    return $ret;
}

sub evt_on_index_node_end {
    my $this = shift;
    my ( $txt, $a_name, $has_children ) = @_;

    my $ret = $has_children ? q{</ul>} : undef;
    return $ret;
}

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

sub pm_version {
    my $this = ref( $_[0] ) ? shift: undef;
    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 = ref( $_[0] ) ? shift: undef;
    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 = ref( $_[0] ) ? shift: undef;
    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 = ref( $_[0] ) ? shift: undef;
    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() );
}

#######
# END #
#######

1;

package main;

# Pass argv to perldoc, which we will redirect the output of perldoc to this
# process.  This syntax only works in Perl 5.8 and higher, but that's OK, the
# rest of the code also requires Perl 5.8.
open my $perlDocInput, "-|", qw/perldoc -u -T/, @ARGV
     or die "Unable to open pipe: $!";

my $usingFunctionPage = 0;
if(exists $ARGV[0] and $ARGV[0] eq '-f')
{
    # Looking for a function, rewrite some URLs that refer to other functions
    # on the same page.
    $usingFunctionPage = 1;
}

my $podhtml = Pod::HtmlEasy->new();

print $podhtml->pod2html($perlDocInput,
                         'function_page'=>$usingFunctionPage,
                         'faq_page' => exists $ARGV[0] && $ARGV[0] eq '-q',
                         title=>"$ARGV[-1]"), "\n";