File Coverage

blib/lib/Perl/Tidy/HtmlWriter.pm

Criterion	Covered	Total	%
statement	401	849	47.2
branch	72	352	20.4
condition	11	75	14.6
subroutine	37	50	74.0
pod	0	24	0.0
total	521	1350	38.5

package Perl::Tidy::HtmlWriter;

#####################################################################
#
# The Perl::Tidy::HtmlWriter class writes a copy of the input stream in html
#
#####################################################################

use strict;
use warnings;
our $VERSION = '20260705';

use Carp;
use English qw( -no_match_vars );
use File::Basename;
use Encode ();

use constant EMPTY_STRING => q{};
use constant SPACE        => q{ };

{ #<<< A non-indenting brace to contain all lexical variables

# List of hash keys to prevent -duk from listing them.
my @unique_hash_keys_uu = qw(use-pod-formatter);

# class variables
my (

    # INITIALIZER: BEGIN block
    $missing_html_entities,

    # INITIALIZER: sub load_pod_formatter
    $loaded_pod_formatter,

    # INITIALIZER: BEGIN block
    %short_to_long_names,
    %token_short_names,

    # INITIALIZER: sub check_options
    $rOpts,
    $rOpts_html_entities,
    $css_linkname,
    %html_bold,
    %html_color,
    %html_italic,
    $log_message,

);

# replace unsafe characters with HTML entity representation if HTML::Entities
# is available
#{ eval "use HTML::Entities"; $missing_html_entities = $@; }

BEGIN {

    $missing_html_entities = EMPTY_STRING;
    if ( !eval { require HTML::Entities; 1 } ) {
        $missing_html_entities = $EVAL_ERROR ? $EVAL_ERROR : 1;
    }

} ## end BEGIN

sub AUTOLOAD {

    # Catch any undefined sub calls so that we are sure to get
    # some diagnostic information.  This sub should never be called
    # except for a programming error.
    our $AUTOLOAD;
    return if ( $AUTOLOAD =~ /\bDESTROY$/ );
    my ( $pkg, $fname, $lno ) = caller();
    my $my_package = __PACKAGE__;
    print {*STDERR} <<EOM;
======================================================================
Error detected in package '$my_package', version $VERSION
Received unexpected AUTOLOAD call for sub '$AUTOLOAD'
Called from package: '$pkg'
Called from File '$fname'  at line '$lno'
This error is probably due to a recent programming change
======================================================================
EOM
    exit 1;
} ## end sub AUTOLOAD

sub DESTROY {

    # required to avoid call to AUTOLOAD in some versions of perl
}

sub new {

    my ( $class, @arglist ) = @_;
    if ( @arglist % 2 ) { croak "Odd number of items in arg hash list\n" }

    my %defaults = (
        input_file         => undef,
        html_file          => undef,
        extension          => undef,
        html_toc_extension => undef,
        html_src_extension => undef,
        is_encoded_data    => undef,
        is_pure_ascii_data => undef,
        logger_object      => undef,
    );
    my %args = ( %defaults, @arglist );

    my $input_file         = $args{input_file};
    my $html_file          = $args{html_file};
    my $extension          = $args{extension};
    my $html_toc_extension = $args{html_toc_extension};
    my $html_src_extension = $args{html_src_extension};
    my $is_encoded_data    = $args{is_encoded_data};
    my $is_pure_ascii_data = $args{is_pure_ascii_data};
    my $logger_object      = $args{logger_object};

    my $html_fh = Perl::Tidy::streamhandle( $html_file, 'w' );
    if ( !$html_fh ) {
        Perl::Tidy::Warn("can't open html file '$html_file'\n");
        return;
    }
    my $html_file_opened = 1;

    if ( !$input_file || $input_file eq '-' || ref($input_file) ) {
        $input_file = "NONAME";
    }

    # write the table of contents to a string
    my $toc_string;
    my $html_toc_fh = Perl::Tidy::IOScalar->new( \$toc_string, 'w' );

    my $html_pre_fh;
    my @pre_string_stack;
    if ( $rOpts->{'html-pre-only'} ) {

        # pre section goes directly to the output stream
        $html_pre_fh = $html_fh;
        $html_pre_fh->print(<<"PRE_END");
<pre>
PRE_END
    }
    else {

        # pre section go out to a temporary string
        my $pre_string;
        $html_pre_fh = Perl::Tidy::IOScalar->new( \$pre_string, 'w' );
        push @pre_string_stack, \$pre_string;
    }

    # Output any log message created by sub check_options
    if ( $log_message && $logger_object ) {
        $logger_object->write_logfile_entry($log_message);
        $log_message = EMPTY_STRING;
    }

    # pod text gets diverted if the 'pod2html' is used and possible
    my $pod_string;
    my $html_pod_fh;
    if ( $rOpts->{'pod2html'} ) {
        $html_pod_fh = Perl::Tidy::IOScalar->new( \$pod_string, 'w' );
    }

    my $toc_filename;
    my $src_filename;
    if ( $rOpts->{'frames'} ) {
        if ( !$extension ) {
            Perl::Tidy::Warn(
"cannot use frames without a specified output extension; ignoring -frm\n"
            );
            undef $rOpts->{'frames'};
        }
        else {
            $toc_filename = $input_file . $html_toc_extension . $extension;
            $src_filename = $input_file . $html_src_extension . $extension;
        }
    }

    # ----------------------------------------------------------
    # Output is now directed as follows:
    # html_toc_fh <-- table of contents items
    # html_pre_fh <-- the <pre> section of formatted code, except:
    # html_pod_fh <-- pod goes here with the pod2html option
    # ----------------------------------------------------------

    my $title = $rOpts->{'title'};
    if ( !$title ) {
        ( $title, my $path_uu ) = fileparse($input_file);
    }
    my $toc_item_count = 0;
    my $in_toc_package = EMPTY_STRING;
    my $last_level     = 0;
    return bless {
        _input_file        => $input_file,          # name of input file
        _title             => $title,               # title, unescaped
        _html_file         => $html_file,           # name of .html output file
        _toc_filename      => $toc_filename,        # for frames option
        _src_filename      => $src_filename,        # for frames option
        _html_file_opened  => $html_file_opened,    # a flag
        _html_fh           => $html_fh,             # the output stream
        _html_pre_fh       => $html_pre_fh,         # pre section goes here
        _rpre_string_stack => \@pre_string_stack,   # stack of pre sections
        _html_pod_fh       => $html_pod_fh,         # pod goes here if pod2html
        _rpod_string       => \$pod_string,         # string holding pod
        _pod_cut_count     => 0,                    # how many =cut's?
        _html_toc_fh       => $html_toc_fh,         # fh for table of contents
        _rtoc_string       => \$toc_string,         # string holding toc
        _rtoc_item_count   => \$toc_item_count,     # how many toc items
        _rin_toc_package   => \$in_toc_package,     # package name
        _rtoc_name_count   => {},                   # hash to track unique names
        _rpackage_stack    => [],                   # stack to check for package
                                                    # name changes
        _rlast_level       => \$last_level,         # brace indentation level

        _is_encoded_data    => $is_encoded_data,    # true for utf-8 source
        _is_pure_ascii_data => $is_pure_ascii_data,
    }, $class;
} ## end sub new

sub add_toc_item {

    # Add an item to the html table of contents.
    # This is called even if no table of contents is written,
    # because we still want to put the anchors in the <pre> text.
    # We are given an anchor name and its type; types are:
    #      'package', 'sub', '__END__', '__DATA__', 'EOF'
    # There must be an 'EOF' call at the end to wrap things up.
    my ( $self, $name, $type ) = @_;
    my $html_toc_fh     = $self->{_html_toc_fh};
    my $html_pre_fh     = $self->{_html_pre_fh};
    my $rtoc_name_count = $self->{_rtoc_name_count};
    my $rtoc_item_count = $self->{_rtoc_item_count};
    my $rlast_level     = $self->{_rlast_level};
    my $rin_toc_package = $self->{_rin_toc_package};
    my $rpackage_stack  = $self->{_rpackage_stack};

    # packages contain sublists of subs, so to avoid errors all package
    # items are written and finished with the following routines
    my $end_package_list = sub {
        if ( ${$rin_toc_package} ) {
            $html_toc_fh->print("</ul>\n</li>\n");
            ${$rin_toc_package} = EMPTY_STRING;
        }
        return;
    }; ## end $end_package_list = sub

    my $start_package_list = sub {
        my ( $unique_name, $package ) = @_;
        if ( ${$rin_toc_package} ) { $end_package_list->() }
        $html_toc_fh->print(<<EOM);
<li><a href=\"#$unique_name\">package $package</a>
<ul>
EOM
        ${$rin_toc_package} = $package;
        return;
    }; ## end $start_package_list = sub

    # start the table of contents on the first item
    if ( !${$rtoc_item_count} ) {

        # but just quit if we hit EOF without any other entries
        # in this case, there will be no toc
        return if ( $type eq 'EOF' );
        $html_toc_fh->print(<<"TOC_END");
<!-- BEGIN CODE INDEX --><a name="code-index"></a>
<ul>
TOC_END
    }
    ${$rtoc_item_count}++;

    # make a unique anchor name for this location:
    #   - packages get a 'package-' prefix
    #   - subs use their names
    my $unique_name = $name;
    if ( $type eq 'package' ) { $unique_name = "package-$name" }

    # append '-1', '-2', etc if necessary to make unique; this will
    # be unique because subs and packages cannot have a '-'
    if ( my $count = $rtoc_name_count->{ lc($unique_name) }++ ) {
        $unique_name .= "-$count";
    }

    #   - all names get terminal '-' if pod2html is used, to avoid
    #     conflicts with anchor names created by pod2html
    if ( $rOpts->{'pod2html'} ) { $unique_name .= '-' }

    # start/stop lists of subs
    if ( $type eq 'sub' ) {
        my $package = $rpackage_stack->[ ${$rlast_level} ];
        if ( !$package ) { $package = 'main' }

        # if we're already in a package/sub list, be sure its the right
        # package or else close it
        if ( ${$rin_toc_package} && ${$rin_toc_package} ne $package ) {
            $end_package_list->();
        }

        # start a package/sub list if necessary
        if ( !${$rin_toc_package} ) {
            $start_package_list->( $unique_name, $package );
        }
    }

    # now write an entry in the toc for this item
    if ( $type eq 'package' ) {
        $start_package_list->( $unique_name, $name );
    }
    elsif ( $type eq 'sub' ) {
        $html_toc_fh->print("<li><a href=\"#$unique_name\">$name</a></li>\n");
    }
    else {
        $end_package_list->();
        $html_toc_fh->print("<li><a href=\"#$unique_name\">$name</a></li>\n");
    }

    # write the anchor in the <pre> section
    $html_pre_fh->print("<a name=\"$unique_name\"></a>");

    # end the table of contents, if any, on the end of file
    if ( $type eq 'EOF' ) {
        $html_toc_fh->print(<<"TOC_END");
</ul>
<!-- END CODE INDEX -->
TOC_END
    }
    return;
} ## end sub add_toc_item

BEGIN {

    # This is the official list of tokens which may be identified by the
    # user.  Long names are used as getopt keys.  Short names are
    # convenient short abbreviations for specifying input.  Short names
    # somewhat resemble token type characters, but are often different
    # because they may only be alphanumeric, to allow command line
    # input.  Also, note that because of case insensitivity of html,
    # this table must be in a single case only (I've chosen to use all
    # lower case).
    # When adding NEW_TOKENS: update this hash table
    # short names => long names
    %short_to_long_names = (
        'n'  => 'numeric',
        'p'  => 'paren',
        'q'  => 'quote',
        's'  => 'structure',
        'c'  => 'comment',
        'v'  => 'v-string',
        'cm' => 'comma',
        'w'  => 'bareword',
        'co' => 'colon',
        'pu' => 'punctuation',
        'i'  => 'identifier',
        'j'  => 'label',
        'h'  => 'here-doc-target',
        'hh' => 'here-doc-text',
        'k'  => 'keyword',
        'sc' => 'semicolon',
        'm'  => 'subroutine',
        'pd' => 'pod-text',
    );

    # Now we have to map actual token types into one of the above short
    # names; any token types not mapped will get 'punctuation'
    # properties.

    # The values of this hash table correspond to the keys of the
    # previous hash table.
    # The keys of this hash table are token types and can be seen
    # by running with --dump-token-types (-dtt).

    # When adding NEW_TOKENS: update this hash table
    # $type => $short_name
    # c250: changed 'M' to 'S'
    %token_short_names = (
        '#'  => 'c',
        'n'  => 'n',
        'v'  => 'v',
        'k'  => 'k',
        'F'  => 'k',
        'Q'  => 'q',
        'q'  => 'q',
        'J'  => 'j',
        'j'  => 'j',
        'h'  => 'h',
        'H'  => 'hh',
        'w'  => 'w',
        ','  => 'cm',
        '=>' => 'cm',
        ';'  => 'sc',
        ':'  => 'co',
        'f'  => 'sc',
        '('  => 'p',
        ')'  => 'p',
        'S'  => 'm',
        'pd' => 'pd',
        'A'  => 'co',
    );

    # These token types will all be called identifiers for now
    # Fix for c250: added new type 'P', formerly 'i'
    # ( but package statements will eventually be split into 'k' and 'i')
    my @identifier = qw< i t U C Y Z G P :: CORE::>;
    $token_short_names{$_} = 'i' for @identifier;

    # These token types will be called 'structure'
    my @structure = qw< { } >;
    $token_short_names{$_} = 's' for @structure;

    # OLD NOTES: save for reference
    # Any of these could be added later if it would be useful.
    # For now, they will by default become punctuation
    #    my @list = qw< L R [ ] >;
    #    @token_long_names{@list} = ('non-structure') x scalar(@list);
    #
    #    my @list = qw"
    #      / /= * *= ** **= + += - -= % %= = ++ -- << <<= >> >>= pp p m mm
    #      ";
    #    @token_long_names{@list} = ('math') x scalar(@list);
    #
    #    my @list = qw" & &= ~ ~= ^ ^= | |= ";
    #    @token_long_names{@list} = ('bit') x scalar(@list);
    #
    #    my @list = qw" == != < > <= <=> ";
    #    @token_long_names{@list} = ('numerical-comparison') x scalar(@list);
    #
    #    my @list = qw" && || ! &&= ||= //= ";
    #    @token_long_names{@list} = ('logical') x scalar(@list);
    #
    #    my @list = qw" . .= =~ !~ x x= ";
    #    @token_long_names{@list} = ('string-operators') x scalar(@list);
    #
    #    # Incomplete..
    #    my @list = qw" .. -> <> ... \ ? ";
    #    @token_long_names{@list} = ('misc-operators') x scalar(@list);

} ## end BEGIN

sub make_getopt_long_names {
    my ( $class, $rgetopt_names ) = @_;
    foreach my $short_name ( keys %short_to_long_names ) {
        my $long_name = $short_to_long_names{$short_name};
        push @{$rgetopt_names}, "html-color-$long_name=s";
        push @{$rgetopt_names}, "html-italic-$long_name!";
        push @{$rgetopt_names}, "html-bold-$long_name!";
    }
    push @{$rgetopt_names}, "html-color-background=s";
    push @{$rgetopt_names}, "html-linked-style-sheet=s";
    push @{$rgetopt_names}, "nohtml-style-sheets";
    push @{$rgetopt_names}, "html-pre-only";
    push @{$rgetopt_names}, "html-line-numbers";
    push @{$rgetopt_names}, "html-entities!";
    push @{$rgetopt_names}, "stylesheet";
    push @{$rgetopt_names}, "html-table-of-contents!";
    push @{$rgetopt_names}, "pod2html!";
    push @{$rgetopt_names}, "frames!";
    push @{$rgetopt_names}, "html-toc-extension=s";
    push @{$rgetopt_names}, "html-src-extension=s";

    # Pod::Html parameters:
    push @{$rgetopt_names}, "cachedir=s";
    push @{$rgetopt_names}, "htmlroot=s";
    push @{$rgetopt_names}, "libpods=s";
    push @{$rgetopt_names}, "podpath=s";
    push @{$rgetopt_names}, "podroot=s";
    push @{$rgetopt_names}, "title=s";

    # Pod::Html parameters with leading 'pod' which will be removed
    # before the call to Pod::Html
    push @{$rgetopt_names}, "podbacklink!";
    push @{$rgetopt_names}, "podquiet!";
    push @{$rgetopt_names}, "podverbose!";
    push @{$rgetopt_names}, "podrecurse!";
    push @{$rgetopt_names}, "podflush";
    push @{$rgetopt_names}, "podheader!";
    push @{$rgetopt_names}, "podindex!";
    return;
} ## end sub make_getopt_long_names

sub make_abbreviated_names {

    # We're appending things like this to the expansion list:
    #      'hcc'    => [qw(html-color-comment)],
    #      'hck'    => [qw(html-color-keyword)],
    #  etc
    my ( $class, $rexpansion ) = @_;
    my $add_short_name = sub {

        my ( $short_name, $long_name ) = @_;

        # Add an abbreviation for a long name

        # Given:
        #   $short_name = the abbreviation
        #   $long_name  = the expanded name

        if ( $rexpansion->{$short_name} ) {

            # A new option short name has been added which is already in use
            my $existing_name = $rexpansion->{$short_name}->[0];
            Perl::Tidy::Die(
"redefining abbreviation '$short_name' for '$long_name'; already used for '$existing_name'\n"
            );
        }
        $rexpansion->{$short_name} = [$long_name];
        return;
    }; ## end $add_short_name = sub

    # abbreviations for color/bold/italic properties
    foreach my $short_name ( keys %short_to_long_names ) {
        my $long_name = $short_to_long_names{$short_name};
        $add_short_name->( "hc$short_name",  "html-color-$long_name" );
        $add_short_name->( "hb$short_name",  "html-bold-$long_name" );
        $add_short_name->( "hi$short_name",  "html-italic-$long_name" );
        $add_short_name->( "nhb$short_name", "nohtml-bold-$long_name" );
        $add_short_name->( "nhi$short_name", "nohtml-italic-$long_name" );
    }

    # abbreviations for all other html options
    $add_short_name->( "hcbg",  "html-color-background" );
    $add_short_name->( "pre",   "html-pre-only" );
    $add_short_name->( "toc",   "html-table-of-contents" );
    $add_short_name->( "ntoc",  "nohtml-table-of-contents" );
    $add_short_name->( "nnn",   "html-line-numbers" );
    $add_short_name->( "hent",  "html-entities" );
    $add_short_name->( "nhent", "nohtml-entities" );
    $add_short_name->( "css",   "html-linked-style-sheet" );
    $add_short_name->( "nss",   "nohtml-style-sheets" );
    $add_short_name->( "ss",    "stylesheet" );
    $add_short_name->( "pod",   "pod2html" );
    $add_short_name->( "npod",  "nopod2html" );
    $add_short_name->( "frm",   "frames" );
    $add_short_name->( "nfrm",  "noframes" );
    $add_short_name->( "text",  "html-toc-extension" );
    $add_short_name->( "sext",  "html-src-extension" );
    return;
} ## end sub make_abbreviated_names

sub check_options {

    # This will be called once after options have been parsed
    # Note that we are defining the package variable $rOpts here:
    ( my $class, $rOpts ) = @_;

    # X11 color names for default settings that seemed to look ok
    # (these color names are only used for programming clarity; the hex
    # numbers are actually written)
##  use constant SaddleBrown   => "#8B4513";
    use constant ForestGreen   => "#228B22";
    use constant magenta4      => "#8B008B";
    use constant IndianRed3    => "#CD5555";
    use constant DeepSkyBlue4  => "#00688B";
    use constant MediumOrchid3 => "#B452CD";
    use constant black         => "#000000";
    use constant white         => "#FFFFFF";
    use constant red           => "#FF0000";

    # set default color, bold, italic properties
    # anything not listed here will be given the default (punctuation) color --
    # these types currently not listed and get default: ws pu s sc cm co p
    # When adding NEW_TOKENS: add an entry here if you don't want defaults

    # set_default_properties( $short_name, default_color, bold?, italic? );
    set_default_properties( 'c',  ForestGreen,   0, 0 );
    set_default_properties( 'pd', ForestGreen,   0, 1 );
    set_default_properties( 'k',  magenta4,      1, 0 );    # was SaddleBrown
    set_default_properties( 'q',  IndianRed3,    0, 0 );
    set_default_properties( 'hh', IndianRed3,    0, 1 );
    set_default_properties( 'h',  IndianRed3,    1, 0 );
    set_default_properties( 'i',  DeepSkyBlue4,  0, 0 );
    set_default_properties( 'w',  black,         0, 0 );
    set_default_properties( 'n',  MediumOrchid3, 0, 0 );
    set_default_properties( 'v',  MediumOrchid3, 0, 0 );
    set_default_properties( 'j',  IndianRed3,    1, 0 );
    set_default_properties( 'm',  red,           1, 0 );

    set_default_color( 'html-color-background',  white );
    set_default_color( 'html-color-punctuation', black );

    # setup property lookup tables for tokens based on their short names
    # every token type has a short name, and will use these tables
    # to do the html markup
    foreach my $short_name ( keys %short_to_long_names ) {
        my $long_name = $short_to_long_names{$short_name};
        $html_color{$short_name}  = $rOpts->{"html-color-$long_name"};
        $html_bold{$short_name}   = $rOpts->{"html-bold-$long_name"};
        $html_italic{$short_name} = $rOpts->{"html-italic-$long_name"};
    }

    # write style sheet to STDOUT and die if requested
    if ( defined( $rOpts->{'stylesheet'} ) ) {
        write_style_sheet_file('-');
        Perl::Tidy::Exit(0);
    }

    # make sure user gives a file name after -css
    $css_linkname = EMPTY_STRING;
    if ( defined( $rOpts->{'html-linked-style-sheet'} ) ) {
        $css_linkname = $rOpts->{'html-linked-style-sheet'};
        if ( $css_linkname =~ /^-/ ) {
            Perl::Tidy::Die("You must specify a valid filename after -css\n");
        }
    }

    # check for conflict
    if ( $css_linkname && $rOpts->{'nohtml-style-sheets'} ) {
        $rOpts->{'nohtml-style-sheets'} = 0;
        Perl::Tidy::Warn(
            "You can't specify both -css and -nss; -nss ignored\n");
    }

    # write a style sheet file if necessary
    if ($css_linkname) {

        # if the selected filename exists, don't write, because user may
        # have done some work by hand to create it; use backup name instead
        # Also, this will avoid a potential disaster in which the user
        # forgets to specify the style sheet, like this:
        #    perltidy -html -css myfile1.pl myfile2.pl
        # This would cause myfile1.pl to parsed as the style sheet by GetOpts
        if ( !-e $css_linkname ) {
            write_style_sheet_file($css_linkname);
        }
    }
    $rOpts_html_entities = $rOpts->{'html-entities'};

    if ( $rOpts->{'pod2html'} ) {
        if ( $rOpts->{'html-pre-only'} ) {
            undef $rOpts->{'pod2html'};
        }
        else {
            load_pod_formatter();
            if ( !$loaded_pod_formatter ) {
                undef $rOpts->{'pod2html'};
            }
        }
    }

    return;
} ## end sub check_options

sub load_pod_formatter {

    # Load a Pod to Html formatter
    # Define global variables:
    #   $loaded_pod_formatter
    #      = name of pod formatter found, or
    #      = empty string if not found
    #   $log_message = log message to write for first file

    # Global variables:
    $log_message          = EMPTY_STRING;
    $loaded_pod_formatter = EMPTY_STRING;

    return if ( !$rOpts->{'pod2html'} );

    # Built-in search order is higher values to lower values
    my %formatters = (
        'Pod::Simple::XHTML' => 3,
        'Pod::Simple::HTML'  => 1,
        'Pod::Html'          => 2,
    );

    # Start search with any user-selected formatter
    my $use_pod_formatter = $rOpts->{'use-pod-formatter'};
    if ($use_pod_formatter) {
        my @q  = keys %formatters;
        my %ok = map { $_ => 1 } @q;
        if ( !$ok{$use_pod_formatter} ) {
            my $str = join ', ', @q;
            Perl::Tidy::Die(<<EOM);
--use-pod-formatter='$use_pod_formatter' not recognized; expecting one of:
  $str
EOM
        }
        $formatters{$use_pod_formatter} = 1 + keys %formatters;
    }

    my @sorted = sort { $formatters{$b} <=> $formatters{$a} } keys %formatters;

    foreach my $formatter (@sorted) {
        if ( $formatter eq 'Pod::Simple::XHTML' ) {
            if ( !eval { require Pod::Simple::XHTML; 1 } ) {
                $log_message .= <<EOM;
Unable to load $formatter
EOM
                next;
            }
            else {
                $loaded_pod_formatter = $formatter;
                $log_message .= <<EOM;
Loaded $formatter
EOM
                last;
            }
        }
        if ( $formatter eq 'Pod::Simple::HTML' ) {
            if ( !eval { require Pod::Simple::HTML; 1 } ) {
                $log_message .= <<EOM;
Unable to load $formatter
EOM
                next;
            }
            else {
                $loaded_pod_formatter = $formatter;
                $log_message .= <<EOM;
Loaded $formatter
EOM
                last;
            }
        }
        if ( $formatter eq 'Pod::Html' ) {
            if ( !eval { require Pod::Html; 1 } ) {
                $log_message .= <<EOM;
Unable to load $formatter
EOM
                next;
            }
            else {
                $loaded_pod_formatter = $formatter;
                $log_message .= <<EOM;
Loaded $formatter
EOM
                last;
            }
        }
    }

    if ( !$loaded_pod_formatter ) {
        $log_message .= <<EOM;
unable to find a pod formatter; cannot use pod2html\n-npod disables this message
EOM
    }

    return;
} ## end sub load_pod_formatter

sub write_style_sheet_file {

    my $filename = shift;
    my $fh       = IO::File->new("> $filename");
    if ( !$fh ) {
        Perl::Tidy::Die("can't open $filename: $OS_ERROR\n");
    }
    write_style_sheet_data($fh);
    if ( $fh->can('close') && $filename ne '-' && !ref($filename) ) {
        $fh->close()
          or
          Perl::Tidy::Warn("can't close style sheet '$filename' : $OS_ERROR\n");
    }
    return;
} ## end sub write_style_sheet_file

sub write_style_sheet_data {

    # write the style sheet data to an open file handle
    my $fh = shift;

    my $bg_color   = $rOpts->{'html-color-background'};
    my $text_color = $rOpts->{'html-color-punctuation'};

    # pre-bgcolor is new, and may not be defined
    my $pre_bg_color = $rOpts->{'html-pre-color-background'};
    $pre_bg_color = $bg_color unless ($pre_bg_color);

    $fh->print(<<"EOM");
/* default style sheet generated by perltidy */
body {background: $bg_color; color: $text_color}
pre { color: $text_color;
      background: $pre_bg_color;
      font-family: courier;
    }

EOM

    foreach my $short_name ( sort keys %short_to_long_names ) {
        my $long_name = $short_to_long_names{$short_name};

        my $abbrev = '.' . $short_name;
        if ( length($short_name) == 1 ) { $abbrev .= SPACE }    # for alignment
        my $color = $html_color{$short_name};
        if ( !defined($color) ) { $color = $text_color }
        $fh->print("$abbrev \{ color: $color;");

        if ( $html_bold{$short_name} ) {
            $fh->print(" font-weight:bold;");
        }

        if ( $html_italic{$short_name} ) {
            $fh->print(" font-style:italic;");
        }
        $fh->print("} /* $long_name */\n");
    }
    return;
} ## end sub write_style_sheet_data

sub set_default_color {

    # make sure that options hash $rOpts->{$key} contains a valid color
    my ( $key, $color ) = @_;
    if ( $rOpts->{$key} ) { $color = $rOpts->{$key} }
    $rOpts->{$key} = check_RGB($color);
    return;
} ## end sub set_default_color

sub check_RGB {

    # if color is a 6 digit hex RGB value, prepend a #, otherwise
    # assume that it is a valid ascii color name
    my ($color) = @_;
    if ( $color =~ /^[0-9a-fA-F]{6,6}$/ ) { $color = "#$color" }
    return $color;
} ## end sub check_RGB

sub set_default_properties {
    my ( $short_name, $color, $bold, $italic ) = @_;

    set_default_color( "html-color-$short_to_long_names{$short_name}", $color );
    my $key;
    $key           = "html-bold-$short_to_long_names{$short_name}";
    $rOpts->{$key} = defined( $rOpts->{$key} ) ? $rOpts->{$key} : $bold;
    $key           = "html-italic-$short_to_long_names{$short_name}";
    $rOpts->{$key} = defined( $rOpts->{$key} ) ? $rOpts->{$key} : $italic;
    return;
} ## end sub set_default_properties

sub pod_to_html {

    # Convert the pod to html
    # then merge the perltidy code sections into it.
    # return 1 if success, 0 otherwise
    my ( $self, $pod_string, $css_string, $toc_string, $rpre_string_stack ) =
      @_;
    my $title              = $self->{_title};
    my $is_encoded_data    = $self->{_is_encoded_data};
    my $is_pure_ascii_data = $self->{_is_pure_ascii_data};
    my $success_flag       = 0;

    # don't try to use pod2html if no pod
    if ( !$pod_string ) {
        return $success_flag;
    }

    my $rhtml_string;
    if ( $loaded_pod_formatter eq 'Pod::Simple::XHTML' ) {
        my $psx = Pod::Simple::XHTML->new;
        $rhtml_string = $self->pod_to_html_simple( $pod_string, $psx );
    }
    elsif ( $loaded_pod_formatter eq 'Pod::Simple::HTML' ) {
        my $psx = Pod::Simple::HTML->new;
        $rhtml_string = $self->pod_to_html_simple( $pod_string, $psx );
    }
    elsif ( $loaded_pod_formatter eq 'Pod::Html' ) {
        $rhtml_string = $self->pod_to_html_old($pod_string);
    }
    else {
        # Looks like a pod formatter could not be loaded
        return $success_flag;
    }

    if ( !$rhtml_string ) {
        return $success_flag;
    }

    my $html_fh = $self->{_html_fh};
    my @toc;
    my $in_toc;
    my $ul_level = 0;
    my $no_print;

    # This routine will write the html selectively and store the toc
    my $html_print = sub {
        foreach my $line (@_) {
            $html_fh->print($line) unless ($no_print);
            if ($in_toc) { push @toc, $line }
        }
        return;
    }; ## end $html_print = sub

    # loop over lines of html output from pod2html and merge in
    # the necessary perltidy html sections
    my ( $saw_body, $saw_index, $saw_body_end );

    my $timestamp = EMPTY_STRING;
    if ( $rOpts->{'timestamp'} ) {
        my $date = localtime;
        $timestamp = "on $date";
    }

    my @html_lines = split /^/, ${$rhtml_string};
    my $saw_charset;
    my $want_charset;
    if ( $is_encoded_data || $is_pure_ascii_data ) {
        $want_charset = 'utf-8';
    }
    else {
        $want_charset = 'ISO-8859-1';
    }
    foreach my $line (@html_lines) {

        if ( $line =~ /^\s*<html>\s*$/i ) {
            $html_print->("<!-- Generated by perltidy $timestamp -->\n");
            $html_print->($line);
        }

        # Fix the charset if necessary
        elsif ( !$saw_charset && $line =~ /^\s*<meta.*charset=([\w\-]+)/i ) {
            $saw_charset = $1;
            if ( uc($saw_charset) ne uc($want_charset) ) {
                $line =~ s/$saw_charset/$want_charset/;
            }
            $html_print->($line);
        }

        # Copy the perltidy css, if any, after <body> tag
        elsif ( $line =~ /^\s*<body.*>\s*$/i ) {
            $saw_body = 1;
            $html_print->($css_string) if ($css_string);
            $html_print->($line);

            # add a top anchor and heading
            $html_print->("<a name=\"-top-\"></a>\n");
            $title = escape_html($title);
            $html_print->("<h1>$title</h1>\n");
        }

        # check for start of index, old pod2html
        # before Pod::Html VERSION 1.15_02 it is delimited by comments as:
        #    <!-- INDEX BEGIN -->
        #    <ul>
        #     ...
        #    </ul>
        #    <!-- INDEX END -->
        #
        elsif ( $line =~ /^\s*<!-- INDEX BEGIN -->\s*$/i ) {
            $in_toc = 'INDEX';

            # when frames are used, an extra table of contents in the
            # contents panel is confusing, so don't print it
            $no_print = $rOpts->{'frames'}
              || !$rOpts->{'html-table-of-contents'};
            $html_print->("<h2>Doc Index:</h2>\n") if ( $rOpts->{'frames'} );
            $html_print->($line);
        }

        # check for start of index, new pod2html
        # After Pod::Html VERSION 1.15_02 it is delimited as:
        # <ul id="index">
        # ...
        # </ul>
        elsif ( $line =~ /^\s*<ul\s+id="index">/i ) {
            $in_toc   = 'UL';
            $ul_level = 1;

            # when frames are used, an extra table of contents in the
            # contents panel is confusing, so don't print it
            $no_print = $rOpts->{'frames'}
              || !$rOpts->{'html-table-of-contents'};
            $html_print->("<h2>Doc Index:</h2>\n") if ( $rOpts->{'frames'} );
            $html_print->($line);
        }

        # Check for end of index, old pod2html
        elsif ( $line =~ /^\s*<!-- INDEX END -->\s*$/i ) {
            $saw_index = 1;
            $html_print->($line);

            # Copy the perltidy toc, if any, after the Pod::Html toc
            if ($toc_string) {
                $html_print->("<hr />\n") if ( $rOpts->{'frames'} );
                $html_print->("<h2>Code Index:</h2>\n");
                my @toc_st = split /^/, $toc_string;
                $html_print->(@toc_st);
            }
            $in_toc   = EMPTY_STRING;
            $no_print = 0;
        }

        # must track <ul> depth level for new pod2html
        elsif ( $line =~ /\s*<ul>\s*$/i && $in_toc && $in_toc eq 'UL' ) {
            $ul_level++;
            $html_print->($line);
        }

        # Check for end of index, for new pod2html
        elsif ( $line =~ /\s*<\/ul>/i && $in_toc && $in_toc eq 'UL' ) {
            $ul_level--;
            $html_print->($line);

            # Copy the perltidy toc, if any, after the Pod::Html toc
            if ( $ul_level <= 0 ) {
                $saw_index = 1;
                if ($toc_string) {
                    $html_print->("<hr />\n") if ( $rOpts->{'frames'} );
                    $html_print->("<h2>Code Index:</h2>\n");
                    my @toc_st = split /^/, $toc_string;
                    $html_print->(@toc_st);
                }
                $in_toc   = EMPTY_STRING;
                $ul_level = 0;
                $no_print = 0;
            }
        }

        # Copy one perltidy section after each marker
        elsif ( $line =~ /^(.*)<!-- pERLTIDY sECTION -->(.*)$/ ) {
            $line = $2;
            $html_print->($1) if ($1);

            # Intermingle code and pod sections if we saw multiple =cut's.
            if ( $self->{_pod_cut_count} > 1 ) {
                my $rpre_string = shift @{$rpre_string_stack};
                if ( ${$rpre_string} ) {
                    $html_print->('<pre>');
                    $html_print->( ${$rpre_string} );
                    $html_print->('</pre>');
                }
                else {

                    # shouldn't happen: we stored a string before writing
                    # each marker.
                    Perl::Tidy::Warn(
"Problem merging html stream with pod2html; order may be wrong\n"
                    );
                }
                $html_print->($line);
            }

            # If didn't see multiple =cut lines, we'll put the pod out first
            # and then the code, because it's less confusing.
            else {

                # since we are not intermixing code and pod, we don't need
                # or want any <hr> lines which separated pod and code
                $html_print->($line) unless ( $line =~ /^\s*<hr>\s*$/i );
            }
        }

        # Copy any remaining code section before the </body> tag
        elsif ( $line =~ /^\s*<\/body>/i ) {
            $saw_body_end = 1;
            if ( @{$rpre_string_stack} ) {
                if ( $self->{_pod_cut_count} <= 1 ) {
                    $html_print->('<hr />');
                }
                while ( @{$rpre_string_stack} ) {
                    my $rpre_string = shift @{$rpre_string_stack};
                    $html_print->('<pre>');
                    $html_print->( ${$rpre_string} );
                    $html_print->('</pre>');
                } ## end while ( @{$rpre_string_stack...})
            }
            $html_print->($line);
        }
        else {
            $html_print->($line);
        }
    } ## end while ( defined( my $line...))

    $success_flag = 1;
    if ( !$saw_body ) {
        Perl::Tidy::Warn("Did not see <body> in pod2html output\n");
        $success_flag = 0;
    }
    if ( !$saw_body_end ) {
        Perl::Tidy::Warn("Did not see </body> in pod2html output\n");
        $success_flag = 0;
    }

    # Added check on $in_toc to handle small files without an index at all
    if ( !$saw_index && defined($in_toc) ) {
        Perl::Tidy::Warn("Did not find INDEX END in pod2html output\n");
        $success_flag = 0;
    }

    if ( $html_fh->can('close') ) {
        $html_fh->close();
    }

    if ( $success_flag && $rOpts->{'frames'} ) {
        $self->make_frame( \@toc );
    }
    return $success_flag;
} ## end sub pod_to_html

sub pod_to_html_old {

    my ( $self, $pod_string ) = @_;

    # Use Pod::Html to process pod text
    # Given:
    #    $pod_string = string with pod to process
    # Return:
    #    $rhtml_string = ref to string with pod as html, or
    #                   undef if error

    my $is_encoded_data    = $self->{_is_encoded_data};
    my $is_pure_ascii_data = $self->{_is_pure_ascii_data};

    # Make a temporary named file for data transfer to and from Pod::Html.
    # NOTE: For perl perl-5.10 and later, the default will use one of the
    # Pod::Simple formatters instead. These formatters do not require temp
    # files.  So this routine will not normally be used, unless specifically
    # requested with the -ups flag, or if running on perl-5.8.x. (c539).
    use File::Temp qw();
    my ( $fh_tmp, $tmpfile ) = File::Temp::tempfile( UNLINK => 1 );
    if ( !$fh_tmp ) {
        Perl::Tidy::Warn(
            "unable to open temporary file $tmpfile; cannot use pod2html\n");
        return;
    }

    if ($is_encoded_data) { binmode $fh_tmp, ":raw:encoding(UTF-8)" }
    else                  { binmode $fh_tmp }

    my $pod_is_pure_ascii_data = !( $pod_string =~ /[^[:ascii:]]/ );

    # Pod::Html wants to see =encoding if not pure ascii
    if ($pod_is_pure_ascii_data) {

        # no '=encoding' needed for pure ascii pod text
    }
    elsif ($is_encoded_data) {
        $pod_string = "\n=encoding UTF-8\n\n$pod_string";
    }
    elsif ( !$is_pure_ascii_data ) {
        $pod_string = "\n=encoding CP1252\n\n$pod_string";
    }
    else {
        ## no '=encoding' needed for pure ascii
    }

    # write the pod text to the temporary file
    $fh_tmp->print($pod_string);

    if ( !$fh_tmp->close() ) {
        Perl::Tidy::Warn(
            "unable to close temporary file $tmpfile; cannot use pod2html\n");
        return;
    }

    # Hand off the pod to pod2html.
    # Note that we can use the same temporary filename for input and output
    # because of the way pod2html works.
    {
        my $title = $self->{_title};
        my @args;
        push @args, "--infile=$tmpfile", "--outfile=$tmpfile", "--title=$title";

        # Flags with string args:
        # "cachedir=s", "htmlroot=s", "libpods=s", "podpath=s", "podroot=s"
        # Note: -css=s is handled by perltidy itself
        # Note: backlink=s was incorrectly in this list up to v20250912:
        #   backlink can now be input as 'podbacklink', below
        foreach my $kw (qw( cachedir htmlroot libpods podpath podroot )) {
            if ( $rOpts->{$kw} ) { push @args, "--$kw=$rOpts->{$kw}" }
        }

        # Toggle switches; these have extra leading 'pod'
        # "header!", "index!", "recurse!", "quiet!", "verbose!", "backlink!'
        # See note above regarding the change for backlink.
        foreach my $kw (
            qw( podheader podindex podrecurse podquiet podverbose podbacklink ))
        {
            my $kwd = $kw;    # allows us to strip 'pod'
            if    ( $rOpts->{$kw} ) { $kwd =~ s/^pod//; push @args, "--$kwd" }
            elsif ( defined( $rOpts->{$kw} ) ) {
                $kwd =~ s/^pod//;
                push @args, "--no$kwd";
            }
            else {
                ## user did not set this keyword
            }
        }

        # "flush",
        my $kw = 'podflush';
        if ( $rOpts->{$kw} ) { $kw =~ s/^pod//; push @args, "--$kw" }

        # Must clean up if pod2html dies (it can);
        # Be careful not to overwrite callers __DIE__ routine
        local $SIG{__DIE__} = sub {
            unlink($tmpfile) if ( -e $tmpfile );
            Perl::Tidy::Die( $_[0] );
        };

        Pod::Html::pod2html(@args);
    }

    my $rhtml_string;
    if ( open( my $fh, '<', $tmpfile ) ) {
        local $INPUT_RECORD_SEPARATOR = undef;
        if ($is_encoded_data) { binmode $fh, ":raw:encoding(UTF-8)"; }
        else                  { binmode $fh }
        my $buf = <$fh>;
        $rhtml_string = \$buf;
        $fh->close() or Warn("Cannot close $tmpfile\n");
    }
    else {
        ## this error shouldn't happen ... we just used this filename
        Perl::Tidy::Warn(
            "unable to open temporary file $tmpfile; cannot use Pod::Html\n");
        return;
    }
    if ( -e $tmpfile ) {
        if ( !unlink($tmpfile) ) {
            Perl::Tidy::Warn(
                "couldn't unlink temporary file $tmpfile: $OS_ERROR\n");
            return;
        }
    }
    return $rhtml_string;
} ## end sub pod_to_html_old

sub pod_to_html_simple {

    my ( $self, $pod_string, $psx ) = @_;

    # Use Pod::Simple::HTML or Pod::Simple::XHTML to process pod text
    # Given:
    #    $pod_string = string with pod to process
    #    $psx = either Pod::Simple::HTML->new or Pod::Simple::XHTML->new
    # Return:
    #    $rhtml_string = ref to string with pod as html, or
    #                   undef if error
    my $is_pure_ascii_data = $self->{_is_pure_ascii_data};
    my $is_encoded_data    = $self->{_is_encoded_data};
    my $html_string;

    # make an index if possible
    $psx->index(1)
      if ( $psx->can('index') );

    # pass characters if possible, otherwise pass octets
    my $pass_octets;
    if ( !$is_pure_ascii_data ) {

        # Tell parser to expect characters, not octets, and ignore =encoding if
        # not a pure ascii file, if possible.
        if ( $psx->can('parse_characters') ) {
            $psx->parse_characters(1);
        }

        # Otherwise, add =encoding and pass octets
        else {
            if ($is_encoded_data) {
                $pass_octets = 1;
                $pod_string  = "\n=encoding UTF-8\n\n$pod_string";
                $pod_string  = Encode::encode( 'UTF-8', $pod_string );
            }
            else {
                $pod_string = "\n=encoding CP1252\n\n$pod_string";
            }
        }
    }

    $psx->output_string( \$html_string );
    $psx->parse_string_document($pod_string);

    if ($pass_octets) {
        $html_string = Encode::decode( 'UTF-8', $html_string );
    }
    return \$html_string;
} ## end sub pod_to_html_simple

sub make_frame {

    # Make a frame with table of contents in the left panel
    # and the text in the right panel.
    # On entry:
    #  $html_filename contains the no-frames html output
    #  $rtoc is a reference to an array with the table of contents
    my ( $self, $rtoc ) = @_;
    my $html_filename = $self->{_html_file};
    my $toc_filename  = $self->{_toc_filename};
    my $src_filename  = $self->{_src_filename};
    my $title         = $self->{_title};
    $title = escape_html($title);

    # FUTURE input parameter:
    my $top_basename = EMPTY_STRING;

    # We need to produce 3 html files:
    # 1. - the table of contents
    # 2. - the contents (source code) itself
    # 3. - the frame which contains them

    # get basenames for relative links
    my ( $toc_basename, $toc_path_uu ) = fileparse($toc_filename);
    my ( $src_basename, $src_path_uu ) = fileparse($src_filename);

    # 1. Make the table of contents panel, with appropriate changes
    # to the anchor names
    my $src_frame_name  = 'SRC';
    my $first_anchor_uu = write_toc_html(
        {
            title          => $title,
            toc_filename   => $toc_filename,
            src_basename   => $src_basename,
            rtoc           => $rtoc,
            src_frame_name => $src_frame_name,
        }
    );

    # 2. The current .html filename is renamed to be the contents panel
    rename( $html_filename, $src_filename )
      or Perl::Tidy::Die(
        "Cannot rename $html_filename to $src_filename: $OS_ERROR\n");

    # 3. Then use the original html filename for the frame
    write_frame_html(
        {
            title          => $title,
            frame_filename => $html_filename,
            top_basename   => $top_basename,
            toc_basename   => $toc_basename,
            src_basename   => $src_basename,
            src_frame_name => $src_frame_name,
        }
    );
    return;
} ## end sub make_frame

sub write_toc_html {

    # write a separate html table of contents file for frames
    my ($rarg_hash) = @_;

    my $title          = $rarg_hash->{title};
    my $toc_filename   = $rarg_hash->{toc_filename};
    my $src_basename   = $rarg_hash->{src_basename};
    my $rtoc           = $rarg_hash->{rtoc};
    my $src_frame_name = $rarg_hash->{src_frame_name};

    my $fh = IO::File->new( $toc_filename, 'w' )
      or Perl::Tidy::Die("Cannot open $toc_filename: $OS_ERROR\n");
    $fh->print(<<EOM);
<html>
<head>
<title>$title</title>
</head>
<body>
<h1><a href=\"$src_basename#-top-" target="$src_frame_name">$title</a></h1>
EOM

    my $first_anchor_uu =
      change_anchor_names( $rtoc, $src_basename, "$src_frame_name" );
    $fh->print( join EMPTY_STRING, @{$rtoc} );

    $fh->print(<<EOM);
</body>
</html>
EOM

    return;
} ## end sub write_toc_html

sub write_frame_html {

    # write an html file to be the table of contents frame

    my ($rarg_hash) = @_;

    my $title          = $rarg_hash->{title};
    my $frame_filename = $rarg_hash->{frame_filename};
    my $top_basename   = $rarg_hash->{top_basename};
    my $toc_basename   = $rarg_hash->{toc_basename};
    my $src_basename   = $rarg_hash->{src_basename};
    my $src_frame_name = $rarg_hash->{src_frame_name};

    my $fh = IO::File->new( $frame_filename, 'w' )
      or Perl::Tidy::Die("Cannot open $toc_basename: $OS_ERROR\n");

    $fh->print(<<EOM);
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"
    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd">
<?xml version="1.0" encoding="iso-8859-1" ?>
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<title>$title</title>
</head>
EOM

    # two left panels, one right, if master index file
    if ($top_basename) {
        $fh->print(<<EOM);
<frameset cols="20%,80%">
<frameset rows="30%,70%">
<frame src = "$top_basename" />
<frame src = "$toc_basename" />
</frameset>
EOM
    }

    # one left panels, one right, if no master index file
    else {
        $fh->print(<<EOM);
<frameset cols="20%,*">
<frame src = "$toc_basename" />
EOM
    }
    $fh->print(<<EOM);
<frame src = "$src_basename" name = "$src_frame_name" />
<noframes>
<body>
<p>If you see this message, you are using a non-frame-capable web client.</p>
<p>This document contains:</p>
<ul>
<li><a href="$toc_basename">A table of contents</a></li>
<li><a href="$src_basename">The source code</a></li>
</ul>
</body>
</noframes>
</frameset>
</html>
EOM
    return;
} ## end sub write_frame_html

sub change_anchor_names {

    # add a filename and target to anchors
    # also return the first anchor
    my ( $rlines, $filename, $target ) = @_;
    my $first_anchor;
    foreach my $line ( @{$rlines} ) {

        #  We're looking for lines like this:
        #  <LI><A HREF="#synopsis">SYNOPSIS</A></LI>
        #  ----  -       --------  -----------------
        #  $1              $4            $5
        if ( $line =~ /^(.*)<a(.*)href\s*=\s*"([^#]*)#([^"]+)"[^>]*>(.*)$/i ) {
            my $pre  = $1;
            my $name = $4;
            my $post = $5;
            my $href = "$filename#$name";
            $line = "$pre<a href=\"$href\" target=\"$target\">$post\n";
            if ( !$first_anchor ) { $first_anchor = $href }
        }
    }
    return $first_anchor;
} ## end sub change_anchor_names

sub close_html_file {
    my ($self) = @_;

    # Finish writing an html output file and close it

    return unless ( $self->{_html_file_opened} );

    my $html_fh     = $self->{_html_fh};
    my $rtoc_string = $self->{_rtoc_string};

    # There are 3 basic paths to html output...

    # ---------------------------------
    # Path 1: finish up if in -pre mode
    # ---------------------------------
    if ( $rOpts->{'html-pre-only'} ) {
        $html_fh->print(<<"PRE_END");
</pre>
PRE_END
        $html_fh->close()
          if ( $html_fh->can('close') );
        return;
    }

    # Finish the index
    $self->add_toc_item( 'EOF', 'EOF' );

    my $rpre_string_stack = $self->{_rpre_string_stack};

    # Patch to darken the <pre> background color in case of pod2html and
    # interleaved code/documentation.  Otherwise, the distinction
    # between code and documentation is blurred.
    if (   $rOpts->{pod2html}
        && $self->{_pod_cut_count} >= 1
        && $rOpts->{'html-color-background'} eq '#FFFFFF' )
    {
        $rOpts->{'html-pre-color-background'} = '#F0F0F0';
    }

    # put the css or its link into a string, if used
    my $css_string;
    my $fh_css = Perl::Tidy::IOScalar->new( \$css_string, 'w' );

    # use css linked to another file,
    if ( $rOpts->{'html-linked-style-sheet'} ) {
        $fh_css->print(
            qq(<link rel="stylesheet" href="$css_linkname" type="text/css" />));
    }

    # or no css,
    elsif ( $rOpts->{'nohtml-style-sheets'} ) {

    }

    # or use css embedded in this file
    else {
        $fh_css->print(<<'ENDCSS');
<style type="text/css">
<!--
ENDCSS
        write_style_sheet_data($fh_css);
        $fh_css->print(<<"ENDCSS");
-->
</style>
ENDCSS
    }

    # -----------------------------------------------------------
    # path 2: use pod2html if requested
    #         If we fail for some reason, continue on to path 3
    # -----------------------------------------------------------
    if ( $rOpts->{'pod2html'} ) {
        my $rpod_string = $self->{_rpod_string};
        my $success     = $self->pod_to_html(
            ${$rpod_string}, $css_string,
            ${$rtoc_string}, $rpre_string_stack
        );
        return if ($success);
    }

    # --------------------------------------------------
    # path 3: write code in html, with pod only in italics
    # --------------------------------------------------
    my $input_file = $self->{_input_file};
    my $title      = escape_html($input_file);
    my $timestamp  = EMPTY_STRING;
    if ( $rOpts->{'timestamp'} ) {
        my $date = localtime;
        $timestamp = "on $date";
    }
    $html_fh->print(<<"HTML_START");
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
   "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<!-- Generated by perltidy $timestamp -->
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<title>$title</title>
HTML_START

    # output the css, if used
    if ($css_string) {
        $html_fh->print($css_string);
        $html_fh->print(<<"ENDCSS");
</head>
<body>
ENDCSS
    }
    else {

        $html_fh->print(<<"HTML_START");
</head>
<body bgcolor=\"$rOpts->{'html-color-background'}\" text=\"$rOpts->{'html-color-punctuation'}\">
HTML_START
    }

    $html_fh->print("<a name=\"-top-\"></a>\n");
    $html_fh->print(<<"EOM");
<h1>$title</h1>
EOM

    # copy the table of contents
    if (   ${$rtoc_string}
        && !$rOpts->{'frames'}
        && $rOpts->{'html-table-of-contents'} )
    {
        $html_fh->print( ${$rtoc_string} );
    }

    # copy the pre section(s)
    my $fname_comment = $input_file;
    $fname_comment =~ s/--+/-/g;    # protect HTML comment tags
    $html_fh->print(<<"END_PRE");
<hr />
<!-- contents of filename: $fname_comment -->
<pre>
END_PRE

    foreach my $rpre_string ( @{$rpre_string_stack} ) {
        $html_fh->print( ${$rpre_string} );
    }

    # and finish the html page
    $html_fh->print(<<"HTML_END");
</pre>
</body>
</html>
HTML_END
    $html_fh->close()
      if ( $html_fh->can('close') );

    if ( $rOpts->{'frames'} ) {
        my @toc = split /^/, ${$rtoc_string};
        $self->make_frame( \@toc );
    }
    return;
} ## end sub close_html_file

sub markup_tokens {
    my ( $self, $rtokens, $rtoken_type, $rlevels ) = @_;

    # Loop to add html markup to all tokens

    my ( @colored_tokens, $type, $token, $level );
    my $rlast_level    = $self->{_rlast_level};
    my $rpackage_stack = $self->{_rpackage_stack};

    foreach my $j ( 0 .. @{$rtoken_type} - 1 ) {
        $type  = $rtoken_type->[$j];
        $token = $rtokens->[$j];
        $level = $rlevels->[$j];
        $level = 0 if ( $level < 0 );

        #-------------------------------------------------------
        # Update the package stack.  The package stack is needed to keep
        # the toc correct because some packages may be declared within
        # blocks and go out of scope when we leave the block.
        #-------------------------------------------------------
        if ( $level > ${$rlast_level} ) {
            if ( !$rpackage_stack->[ $level - 1 ] ) {
                $rpackage_stack->[ $level - 1 ] = 'main';
            }
            $rpackage_stack->[$level] = $rpackage_stack->[ $level - 1 ];
        }
        elsif ( $level < ${$rlast_level} ) {
            my $package = $rpackage_stack->[$level];
            if ( !$package ) { $package = 'main' }

            # if we change packages due to a nesting change, we
            # have to make an entry in the toc
            if ( $package ne $rpackage_stack->[ $level + 1 ] ) {
                $self->add_toc_item( $package, 'package' );
            }
        }
        else {
            ## level unchanged
        }
        ${$rlast_level} = $level;

        #-------------------------------------------------------
        # Intercept a sub name here; split it
        # into keyword 'sub' and sub name; and add an
        # entry in the toc
        # Fix for c250: switch from 'i' to 'S'
        #-------------------------------------------------------
        if ( $type eq 'S' && $token =~ /^(\w+\s+)(\w.*)$/ ) {
            $token = $self->markup_html_element( $1, 'k' );
            push @colored_tokens, $token;
            $token = $2;
            $type  = 'S';

            # but don't include sub declarations in the toc;
            # these will have leading token types 'i;'
            my $signature = join EMPTY_STRING, @{$rtoken_type};
            if ( $signature !~ /^i;/ ) {
                my $subname = $token;
                $subname =~ s/[\s\(].*$//; # remove any attributes and prototype
                $self->add_toc_item( $subname, 'sub' );
            }
        }

        #-------------------------------------------------------
        # Intercept a package name here; split it
        # into keyword 'package' and name; add to the toc,
        # and update the package stack
        #-------------------------------------------------------
        # Fix for c250: switch from 'i' to 'P' and allow 'class' or 'package'
        if ( $type eq 'P' && $token =~ /^(\w+\s+)(\w.*)$/ ) {
            $token = $self->markup_html_element( $1, 'k' );
            push @colored_tokens, $token;
            $token = $2;
            $type  = 'i';
            $self->add_toc_item( "$token", 'package' );
            $rpackage_stack->[$level] = $token;
        }

        $token = $self->markup_html_element( $token, $type );
        push @colored_tokens, $token;
    }
    return ( \@colored_tokens );
} ## end sub markup_tokens

sub markup_html_element {
    my ( $self, $token, $type ) = @_;

    # Add html markup to a single token
    # Given:
    #   $token = the token text
    #   $type  = the token type

    return $token if ( $type eq 'b' );         # skip a blank token
    return $token if ( $token =~ /^\s*$/ );    # skip a blank line
    $token = escape_html($token);

    # get the short abbreviation for this token type
    my $short_name = $token_short_names{$type};
    if ( !defined($short_name) ) {
        $short_name = "pu";                    # punctuation is default
    }

    # handle style sheets..
    if ( !$rOpts->{'nohtml-style-sheets'} ) {
        if ( $short_name ne 'pu' ) {
            $token = qq(<span class="$short_name">) . $token . "</span>";
        }
    }

    # handle no style sheets..
    else {
        my $color = $html_color{$short_name};

        if ( $color && ( $color ne $rOpts->{'html-color-punctuation'} ) ) {
            $token = qq(<font color="$color">) . $token . "</font>";
        }
        if ( $html_italic{$short_name} ) { $token = "<i>$token</i>" }
        if ( $html_bold{$short_name} )   { $token = "<b>$token</b>" }
    }
    return $token;
} ## end sub markup_html_element

sub escape_html {

    my $token = shift;
    if ( $missing_html_entities || !$rOpts_html_entities ) {
        $token =~ s/\&/&amp;/g;
        $token =~ s/\</&lt;/g;
        $token =~ s/\>/&gt;/g;
        $token =~ s/\"/&quot;/g;
    }
    else {
        HTML::Entities::encode_entities($token);
    }
    return $token;
} ## end sub escape_html

sub finish_formatting {

    # Called after last line to do the actual html formatting.
    my ( $self, $rtokenization_info_uu ) = @_;

    # Given:
    #   $rtokenization_info, a hash with error info

    # Go ahead and try to format as html in all cases, even if there
    # are syntax errors.
    $self->close_html_file();
    return;
} ## end sub finish_formatting

sub write_line {

    my ( $self, $line_of_tokens ) = @_;

    # Given:
    #    $line_of_tokens = a tokenized line from the input stream
    # Markup the line as html and output it

    return unless ( $self->{_html_file_opened} );
    my $html_pre_fh = $self->{_html_pre_fh};
    my $line_type   = $line_of_tokens->{_line_type};
    my $input_line  = $line_of_tokens->{_line_text};
    my $line_number = $line_of_tokens->{_line_number};
    chomp $input_line;

    # markup line of code..
    my $html_line;
    if ( $line_type eq 'CODE' ) {
        my $rtoken_type = $line_of_tokens->{_rtoken_type};
        my $rtokens     = $line_of_tokens->{_rtokens};
        my $rlevels     = $line_of_tokens->{_rlevels};

        if ( $input_line =~ /(^\s*)/ ) {
            $html_line = $1;
        }
        else {
            $html_line = EMPTY_STRING;
        }
        my ($rcolored_tokens) =
          $self->markup_tokens( $rtokens, $rtoken_type, $rlevels );
        $html_line .= join EMPTY_STRING, @{$rcolored_tokens};
    }

    # markup line of non-code..
    else {
        my $line_character;
        if    ( $line_type eq 'HERE' )       { $line_character = 'H' }
        elsif ( $line_type eq 'HERE_END' )   { $line_character = 'h' }
        elsif ( $line_type eq 'FORMAT' )     { $line_character = 'H' }
        elsif ( $line_type eq 'FORMAT_END' ) { $line_character = 'h' }
        elsif ( $line_type eq 'SKIP' )       { $line_character = 'H' }
        elsif ( $line_type eq 'SKIP_END' )   { $line_character = 'h' }
        elsif ( $line_type eq 'SYSTEM' )     { $line_character = 'c' }
        elsif ( $line_type eq 'END_START' ) {
            $line_character = 'k';
            $self->add_toc_item( '__END__', '__END__' );
        }
        elsif ( $line_type eq 'DATA_START' ) {
            $line_character = 'k';
            $self->add_toc_item( '__DATA__', '__DATA__' );
        }
        elsif ( $line_type =~ /^POD/ ) {

            # fix for c250: changed 'P' to 'pd' here and in %token_short_names
            # to allow use of 'P' as new package token type
            $line_character = 'pd';
            if ( $rOpts->{'pod2html'} ) {
                my $html_pod_fh = $self->{_html_pod_fh};
                if ( $line_type eq 'POD_START' ) {

                    my $rpre_string_stack = $self->{_rpre_string_stack};
                    my $rpre_string       = $rpre_string_stack->[-1];

                    # if we have written any non-blank lines to the
                    # current pre section, start writing to a new output
                    # string
                    if ( ${$rpre_string} =~ /\S/ ) {
                        my $pre_string;
                        $html_pre_fh =
                          Perl::Tidy::IOScalar->new( \$pre_string, 'w' );
                        $self->{_html_pre_fh} = $html_pre_fh;
                        push @{$rpre_string_stack}, \$pre_string;

                        # leave a marker in the pod stream so we know
                        # where to put the pre section we just
                        # finished.
                        my $for_html = '=for html';    # don't confuse pod utils
                        $html_pod_fh->print(<<EOM);

$for_html
<!-- pERLTIDY sECTION -->

EOM
                    }

                    # otherwise, just clear the current string and start
                    # over
                    else {
                        ${$rpre_string} = EMPTY_STRING;
                        $html_pod_fh->print("\n");
                    }
                }
                $html_pod_fh->print( $input_line . "\n" );
                if ( $line_type eq 'POD_END' ) {
                    $self->{_pod_cut_count}++;
                    $html_pod_fh->print("\n");
                }
                return;
            }
        }
        else {
            $line_character = 'Q';
        }
        $html_line = $self->markup_html_element( $input_line, $line_character );
    }

    # add the line number if requested
    if ( $rOpts->{'html-line-numbers'} ) {
        my $extra_space =
            ( $line_number < 10 )   ? SPACE x 3
          : ( $line_number < 100 )  ? SPACE x 2
          : ( $line_number < 1000 ) ? SPACE
          :                           EMPTY_STRING;
        $html_line = $extra_space . $line_number . SPACE . $html_line;
    }

    # write the line
    $html_pre_fh->print("$html_line\n");
    return;
} ## end sub write_line

} ## end package Perl::Tidy::HtmlWriter
1;