"Fossies" - the Fresh Open Source Software Archive

Member "Perl-Tidy-20200110/lib/Perl/Tidy/HtmlWriter.pm" (7 Jan 2020, 49147 Bytes) of package /linux/misc/Perl-Tidy-20200110.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "HtmlWriter.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 20191203_vs_20200110.

    1 #####################################################################
    2 #
    3 # The Perl::Tidy::HtmlWriter class writes a copy of the input stream in html
    4 #
    5 #####################################################################
    6 
    7 package Perl::Tidy::HtmlWriter;
    8 use strict;
    9 use warnings;
   10 our $VERSION = '20200110';
   11 
   12 use File::Basename;
   13 
   14 # class variables
   15 use vars qw{
   16   %html_color
   17   %html_bold
   18   %html_italic
   19   %token_short_names
   20   %short_to_long_names
   21   $rOpts
   22   $css_filename
   23   $css_linkname
   24   $missing_html_entities
   25   $missing_pod_html
   26 };
   27 
   28 # replace unsafe characters with HTML entity representation if HTML::Entities
   29 # is available
   30 #{ eval "use HTML::Entities"; $missing_html_entities = $@; }
   31 
   32 BEGIN {
   33     if ( !eval { require HTML::Entities; 1 } ) {
   34         $missing_html_entities = $@ ? $@ : 1;
   35     }
   36     if ( !eval { require Pod::Html; 1 } ) {
   37         $missing_pod_html = $@ ? $@ : 1;
   38     }
   39 }
   40 
   41 sub new {
   42 
   43     my ( $class, $input_file, $html_file, $extension, $html_toc_extension,
   44         $html_src_extension )
   45       = @_;
   46 
   47     my $html_file_opened = 0;
   48     my $html_fh;
   49     ( $html_fh, my $html_filename ) =
   50       Perl::Tidy::streamhandle( $html_file, 'w' );
   51     unless ($html_fh) {
   52         Perl::Tidy::Warn("can't open $html_file: $!\n");
   53         return;
   54     }
   55     $html_file_opened = 1;
   56 
   57     if ( !$input_file || $input_file eq '-' || ref($input_file) ) {
   58         $input_file = "NONAME";
   59     }
   60 
   61     # write the table of contents to a string
   62     my $toc_string;
   63     my $html_toc_fh = Perl::Tidy::IOScalar->new( \$toc_string, 'w' );
   64 
   65     my $html_pre_fh;
   66     my @pre_string_stack;
   67     if ( $rOpts->{'html-pre-only'} ) {
   68 
   69         # pre section goes directly to the output stream
   70         $html_pre_fh = $html_fh;
   71         $html_pre_fh->print( <<"PRE_END");
   72 <pre>
   73 PRE_END
   74     }
   75     else {
   76 
   77         # pre section go out to a temporary string
   78         my $pre_string;
   79         $html_pre_fh = Perl::Tidy::IOScalar->new( \$pre_string, 'w' );
   80         push @pre_string_stack, \$pre_string;
   81     }
   82 
   83     # pod text gets diverted if the 'pod2html' is used
   84     my $html_pod_fh;
   85     my $pod_string;
   86     if ( $rOpts->{'pod2html'} ) {
   87         if ( $rOpts->{'html-pre-only'} ) {
   88             undef $rOpts->{'pod2html'};
   89         }
   90         else {
   91             ##eval "use Pod::Html";
   92             #if ($@) {
   93             if ($missing_pod_html) {
   94                 Perl::Tidy::Warn(
   95 "unable to find Pod::Html; cannot use pod2html\n-npod disables this message\n"
   96                 );
   97                 undef $rOpts->{'pod2html'};
   98             }
   99             else {
  100                 $html_pod_fh = Perl::Tidy::IOScalar->new( \$pod_string, 'w' );
  101             }
  102         }
  103     }
  104 
  105     my $toc_filename;
  106     my $src_filename;
  107     if ( $rOpts->{'frames'} ) {
  108         unless ($extension) {
  109             Perl::Tidy::Warn(
  110 "cannot use frames without a specified output extension; ignoring -frm\n"
  111             );
  112             undef $rOpts->{'frames'};
  113         }
  114         else {
  115             $toc_filename = $input_file . $html_toc_extension . $extension;
  116             $src_filename = $input_file . $html_src_extension . $extension;
  117         }
  118     }
  119 
  120     # ----------------------------------------------------------
  121     # Output is now directed as follows:
  122     # html_toc_fh <-- table of contents items
  123     # html_pre_fh <-- the <pre> section of formatted code, except:
  124     # html_pod_fh <-- pod goes here with the pod2html option
  125     # ----------------------------------------------------------
  126 
  127     my $title = $rOpts->{'title'};
  128     unless ($title) {
  129         ( $title, my $path ) = fileparse($input_file);
  130     }
  131     my $toc_item_count = 0;
  132     my $in_toc_package = "";
  133     my $last_level     = 0;
  134     return bless {
  135         _input_file        => $input_file,          # name of input file
  136         _title             => $title,               # title, unescaped
  137         _html_file         => $html_file,           # name of .html output file
  138         _toc_filename      => $toc_filename,        # for frames option
  139         _src_filename      => $src_filename,        # for frames option
  140         _html_file_opened  => $html_file_opened,    # a flag
  141         _html_fh           => $html_fh,             # the output stream
  142         _html_pre_fh       => $html_pre_fh,         # pre section goes here
  143         _rpre_string_stack => \@pre_string_stack,   # stack of pre sections
  144         _html_pod_fh       => $html_pod_fh,         # pod goes here if pod2html
  145         _rpod_string       => \$pod_string,         # string holding pod
  146         _pod_cut_count     => 0,                    # how many =cut's?
  147         _html_toc_fh       => $html_toc_fh,         # fh for table of contents
  148         _rtoc_string       => \$toc_string,         # string holding toc
  149         _rtoc_item_count   => \$toc_item_count,     # how many toc items
  150         _rin_toc_package   => \$in_toc_package,     # package name
  151         _rtoc_name_count   => {},                   # hash to track unique names
  152         _rpackage_stack    => [],                   # stack to check for package
  153                                                     # name changes
  154         _rlast_level       => \$last_level,         # brace indentation level
  155     }, $class;
  156 }
  157 
  158 sub close_object {
  159     my ($object) = @_;
  160 
  161     # returns true if close works, false if not
  162     # failure probably means there is no close method
  163     return eval { $object->close(); 1 };
  164 }
  165 
  166 sub add_toc_item {
  167 
  168     # Add an item to the html table of contents.
  169     # This is called even if no table of contents is written,
  170     # because we still want to put the anchors in the <pre> text.
  171     # We are given an anchor name and its type; types are:
  172     #      'package', 'sub', '__END__', '__DATA__', 'EOF'
  173     # There must be an 'EOF' call at the end to wrap things up.
  174     my ( $self, $name, $type ) = @_;
  175     my $html_toc_fh     = $self->{_html_toc_fh};
  176     my $html_pre_fh     = $self->{_html_pre_fh};
  177     my $rtoc_name_count = $self->{_rtoc_name_count};
  178     my $rtoc_item_count = $self->{_rtoc_item_count};
  179     my $rlast_level     = $self->{_rlast_level};
  180     my $rin_toc_package = $self->{_rin_toc_package};
  181     my $rpackage_stack  = $self->{_rpackage_stack};
  182 
  183     # packages contain sublists of subs, so to avoid errors all package
  184     # items are written and finished with the following routines
  185     my $end_package_list = sub {
  186         if ( ${$rin_toc_package} ) {
  187             $html_toc_fh->print("</ul>\n</li>\n");
  188             ${$rin_toc_package} = "";
  189         }
  190     };
  191 
  192     my $start_package_list = sub {
  193         my ( $unique_name, $package ) = @_;
  194         if ( ${$rin_toc_package} ) { $end_package_list->() }
  195         $html_toc_fh->print(<<EOM);
  196 <li><a href=\"#$unique_name\">package $package</a>
  197 <ul>
  198 EOM
  199         ${$rin_toc_package} = $package;
  200     };
  201 
  202     # start the table of contents on the first item
  203     unless ( ${$rtoc_item_count} ) {
  204 
  205         # but just quit if we hit EOF without any other entries
  206         # in this case, there will be no toc
  207         return if ( $type eq 'EOF' );
  208         $html_toc_fh->print( <<"TOC_END");
  209 <!-- BEGIN CODE INDEX --><a name="code-index"></a>
  210 <ul>
  211 TOC_END
  212     }
  213     ${$rtoc_item_count}++;
  214 
  215     # make a unique anchor name for this location:
  216     #   - packages get a 'package-' prefix
  217     #   - subs use their names
  218     my $unique_name = $name;
  219     if ( $type eq 'package' ) { $unique_name = "package-$name" }
  220 
  221     # append '-1', '-2', etc if necessary to make unique; this will
  222     # be unique because subs and packages cannot have a '-'
  223     if ( my $count = $rtoc_name_count->{ lc $unique_name }++ ) {
  224         $unique_name .= "-$count";
  225     }
  226 
  227     #   - all names get terminal '-' if pod2html is used, to avoid
  228     #     conflicts with anchor names created by pod2html
  229     if ( $rOpts->{'pod2html'} ) { $unique_name .= '-' }
  230 
  231     # start/stop lists of subs
  232     if ( $type eq 'sub' ) {
  233         my $package = $rpackage_stack->[ ${$rlast_level} ];
  234         unless ($package) { $package = 'main' }
  235 
  236         # if we're already in a package/sub list, be sure its the right
  237         # package or else close it
  238         if ( ${$rin_toc_package} && ${$rin_toc_package} ne $package ) {
  239             $end_package_list->();
  240         }
  241 
  242         # start a package/sub list if necessary
  243         unless ( ${$rin_toc_package} ) {
  244             $start_package_list->( $unique_name, $package );
  245         }
  246     }
  247 
  248     # now write an entry in the toc for this item
  249     if ( $type eq 'package' ) {
  250         $start_package_list->( $unique_name, $name );
  251     }
  252     elsif ( $type eq 'sub' ) {
  253         $html_toc_fh->print("<li><a href=\"#$unique_name\">$name</a></li>\n");
  254     }
  255     else {
  256         $end_package_list->();
  257         $html_toc_fh->print("<li><a href=\"#$unique_name\">$name</a></li>\n");
  258     }
  259 
  260     # write the anchor in the <pre> section
  261     $html_pre_fh->print("<a name=\"$unique_name\"></a>");
  262 
  263     # end the table of contents, if any, on the end of file
  264     if ( $type eq 'EOF' ) {
  265         $html_toc_fh->print( <<"TOC_END");
  266 </ul>
  267 <!-- END CODE INDEX -->
  268 TOC_END
  269     }
  270     return;
  271 }
  272 
  273 BEGIN {
  274 
  275     # This is the official list of tokens which may be identified by the
  276     # user.  Long names are used as getopt keys.  Short names are
  277     # convenient short abbreviations for specifying input.  Short names
  278     # somewhat resemble token type characters, but are often different
  279     # because they may only be alphanumeric, to allow command line
  280     # input.  Also, note that because of case insensitivity of html,
  281     # this table must be in a single case only (I've chosen to use all
  282     # lower case).
  283     # When adding NEW_TOKENS: update this hash table
  284     # short names => long names
  285     %short_to_long_names = (
  286         'n'  => 'numeric',
  287         'p'  => 'paren',
  288         'q'  => 'quote',
  289         's'  => 'structure',
  290         'c'  => 'comment',
  291         'v'  => 'v-string',
  292         'cm' => 'comma',
  293         'w'  => 'bareword',
  294         'co' => 'colon',
  295         'pu' => 'punctuation',
  296         'i'  => 'identifier',
  297         'j'  => 'label',
  298         'h'  => 'here-doc-target',
  299         'hh' => 'here-doc-text',
  300         'k'  => 'keyword',
  301         'sc' => 'semicolon',
  302         'm'  => 'subroutine',
  303         'pd' => 'pod-text',
  304     );
  305 
  306     # Now we have to map actual token types into one of the above short
  307     # names; any token types not mapped will get 'punctuation'
  308     # properties.
  309 
  310     # The values of this hash table correspond to the keys of the
  311     # previous hash table.
  312     # The keys of this hash table are token types and can be seen
  313     # by running with --dump-token-types (-dtt).
  314 
  315     # When adding NEW_TOKENS: update this hash table
  316     # $type => $short_name
  317     %token_short_names = (
  318         '#'  => 'c',
  319         'n'  => 'n',
  320         'v'  => 'v',
  321         'k'  => 'k',
  322         'F'  => 'k',
  323         'Q'  => 'q',
  324         'q'  => 'q',
  325         'J'  => 'j',
  326         'j'  => 'j',
  327         'h'  => 'h',
  328         'H'  => 'hh',
  329         'w'  => 'w',
  330         ','  => 'cm',
  331         '=>' => 'cm',
  332         ';'  => 'sc',
  333         ':'  => 'co',
  334         'f'  => 'sc',
  335         '('  => 'p',
  336         ')'  => 'p',
  337         'M'  => 'm',
  338         'P'  => 'pd',
  339         'A'  => 'co',
  340     );
  341 
  342     # These token types will all be called identifiers for now
  343     # FIXME: could separate user defined modules as separate type
  344     my @identifier = qw< i t U C Y Z G :: CORE::>;
  345     @token_short_names{@identifier} = ('i') x scalar(@identifier);
  346 
  347     # These token types will be called 'structure'
  348     my @structure = qw< { } >;
  349     @token_short_names{@structure} = ('s') x scalar(@structure);
  350 
  351     # OLD NOTES: save for reference
  352     # Any of these could be added later if it would be useful.
  353     # For now, they will by default become punctuation
  354     #    my @list = qw< L R [ ] >;
  355     #    @token_long_names{@list} = ('non-structure') x scalar(@list);
  356     #
  357     #    my @list = qw"
  358     #      / /= * *= ** **= + += - -= % %= = ++ -- << <<= >> >>= pp p m mm
  359     #      ";
  360     #    @token_long_names{@list} = ('math') x scalar(@list);
  361     #
  362     #    my @list = qw" & &= ~ ~= ^ ^= | |= ";
  363     #    @token_long_names{@list} = ('bit') x scalar(@list);
  364     #
  365     #    my @list = qw" == != < > <= <=> ";
  366     #    @token_long_names{@list} = ('numerical-comparison') x scalar(@list);
  367     #
  368     #    my @list = qw" && || ! &&= ||= //= ";
  369     #    @token_long_names{@list} = ('logical') x scalar(@list);
  370     #
  371     #    my @list = qw" . .= =~ !~ x x= ";
  372     #    @token_long_names{@list} = ('string-operators') x scalar(@list);
  373     #
  374     #    # Incomplete..
  375     #    my @list = qw" .. -> <> ... \ ? ";
  376     #    @token_long_names{@list} = ('misc-operators') x scalar(@list);
  377 
  378 }
  379 
  380 sub make_getopt_long_names {
  381     my ( $class, $rgetopt_names ) = @_;
  382     while ( my ( $short_name, $name ) = each %short_to_long_names ) {
  383         push @{$rgetopt_names}, "html-color-$name=s";
  384         push @{$rgetopt_names}, "html-italic-$name!";
  385         push @{$rgetopt_names}, "html-bold-$name!";
  386     }
  387     push @{$rgetopt_names}, "html-color-background=s";
  388     push @{$rgetopt_names}, "html-linked-style-sheet=s";
  389     push @{$rgetopt_names}, "nohtml-style-sheets";
  390     push @{$rgetopt_names}, "html-pre-only";
  391     push @{$rgetopt_names}, "html-line-numbers";
  392     push @{$rgetopt_names}, "html-entities!";
  393     push @{$rgetopt_names}, "stylesheet";
  394     push @{$rgetopt_names}, "html-table-of-contents!";
  395     push @{$rgetopt_names}, "pod2html!";
  396     push @{$rgetopt_names}, "frames!";
  397     push @{$rgetopt_names}, "html-toc-extension=s";
  398     push @{$rgetopt_names}, "html-src-extension=s";
  399 
  400     # Pod::Html parameters:
  401     push @{$rgetopt_names}, "backlink=s";
  402     push @{$rgetopt_names}, "cachedir=s";
  403     push @{$rgetopt_names}, "htmlroot=s";
  404     push @{$rgetopt_names}, "libpods=s";
  405     push @{$rgetopt_names}, "podpath=s";
  406     push @{$rgetopt_names}, "podroot=s";
  407     push @{$rgetopt_names}, "title=s";
  408 
  409     # Pod::Html parameters with leading 'pod' which will be removed
  410     # before the call to Pod::Html
  411     push @{$rgetopt_names}, "podquiet!";
  412     push @{$rgetopt_names}, "podverbose!";
  413     push @{$rgetopt_names}, "podrecurse!";
  414     push @{$rgetopt_names}, "podflush";
  415     push @{$rgetopt_names}, "podheader!";
  416     push @{$rgetopt_names}, "podindex!";
  417     return;
  418 }
  419 
  420 sub make_abbreviated_names {
  421 
  422     # We're appending things like this to the expansion list:
  423     #      'hcc'    => [qw(html-color-comment)],
  424     #      'hck'    => [qw(html-color-keyword)],
  425     #  etc
  426     my ( $class, $rexpansion ) = @_;
  427 
  428     # abbreviations for color/bold/italic properties
  429     while ( my ( $short_name, $long_name ) = each %short_to_long_names ) {
  430         ${$rexpansion}{"hc$short_name"}  = ["html-color-$long_name"];
  431         ${$rexpansion}{"hb$short_name"}  = ["html-bold-$long_name"];
  432         ${$rexpansion}{"hi$short_name"}  = ["html-italic-$long_name"];
  433         ${$rexpansion}{"nhb$short_name"} = ["nohtml-bold-$long_name"];
  434         ${$rexpansion}{"nhi$short_name"} = ["nohtml-italic-$long_name"];
  435     }
  436 
  437     # abbreviations for all other html options
  438     ${$rexpansion}{"hcbg"}  = ["html-color-background"];
  439     ${$rexpansion}{"pre"}   = ["html-pre-only"];
  440     ${$rexpansion}{"toc"}   = ["html-table-of-contents"];
  441     ${$rexpansion}{"ntoc"}  = ["nohtml-table-of-contents"];
  442     ${$rexpansion}{"nnn"}   = ["html-line-numbers"];
  443     ${$rexpansion}{"hent"}  = ["html-entities"];
  444     ${$rexpansion}{"nhent"} = ["nohtml-entities"];
  445     ${$rexpansion}{"css"}   = ["html-linked-style-sheet"];
  446     ${$rexpansion}{"nss"}   = ["nohtml-style-sheets"];
  447     ${$rexpansion}{"ss"}    = ["stylesheet"];
  448     ${$rexpansion}{"pod"}   = ["pod2html"];
  449     ${$rexpansion}{"npod"}  = ["nopod2html"];
  450     ${$rexpansion}{"frm"}   = ["frames"];
  451     ${$rexpansion}{"nfrm"}  = ["noframes"];
  452     ${$rexpansion}{"text"}  = ["html-toc-extension"];
  453     ${$rexpansion}{"sext"}  = ["html-src-extension"];
  454     return;
  455 }
  456 
  457 sub check_options {
  458 
  459     # This will be called once after options have been parsed
  460     # Note that we are defining the package variable $rOpts here:
  461     ( my $class, $rOpts ) = @_;
  462 
  463     # X11 color names for default settings that seemed to look ok
  464     # (these color names are only used for programming clarity; the hex
  465     # numbers are actually written)
  466     use constant ForestGreen   => "#228B22";
  467     use constant SaddleBrown   => "#8B4513";
  468     use constant magenta4      => "#8B008B";
  469     use constant IndianRed3    => "#CD5555";
  470     use constant DeepSkyBlue4  => "#00688B";
  471     use constant MediumOrchid3 => "#B452CD";
  472     use constant black         => "#000000";
  473     use constant white         => "#FFFFFF";
  474     use constant red           => "#FF0000";
  475 
  476     # set default color, bold, italic properties
  477     # anything not listed here will be given the default (punctuation) color --
  478     # these types currently not listed and get default: ws pu s sc cm co p
  479     # When adding NEW_TOKENS: add an entry here if you don't want defaults
  480 
  481     # set_default_properties( $short_name, default_color, bold?, italic? );
  482     set_default_properties( 'c',  ForestGreen,   0, 0 );
  483     set_default_properties( 'pd', ForestGreen,   0, 1 );
  484     set_default_properties( 'k',  magenta4,      1, 0 );    # was SaddleBrown
  485     set_default_properties( 'q',  IndianRed3,    0, 0 );
  486     set_default_properties( 'hh', IndianRed3,    0, 1 );
  487     set_default_properties( 'h',  IndianRed3,    1, 0 );
  488     set_default_properties( 'i',  DeepSkyBlue4,  0, 0 );
  489     set_default_properties( 'w',  black,         0, 0 );
  490     set_default_properties( 'n',  MediumOrchid3, 0, 0 );
  491     set_default_properties( 'v',  MediumOrchid3, 0, 0 );
  492     set_default_properties( 'j',  IndianRed3,    1, 0 );
  493     set_default_properties( 'm',  red,           1, 0 );
  494 
  495     set_default_color( 'html-color-background',  white );
  496     set_default_color( 'html-color-punctuation', black );
  497 
  498     # setup property lookup tables for tokens based on their short names
  499     # every token type has a short name, and will use these tables
  500     # to do the html markup
  501     while ( my ( $short_name, $long_name ) = each %short_to_long_names ) {
  502         $html_color{$short_name}  = $rOpts->{"html-color-$long_name"};
  503         $html_bold{$short_name}   = $rOpts->{"html-bold-$long_name"};
  504         $html_italic{$short_name} = $rOpts->{"html-italic-$long_name"};
  505     }
  506 
  507     # write style sheet to STDOUT and die if requested
  508     if ( defined( $rOpts->{'stylesheet'} ) ) {
  509         write_style_sheet_file('-');
  510         Perl::Tidy::Exit(0);
  511     }
  512 
  513     # make sure user gives a file name after -css
  514     if ( defined( $rOpts->{'html-linked-style-sheet'} ) ) {
  515         $css_linkname = $rOpts->{'html-linked-style-sheet'};
  516         if ( $css_linkname =~ /^-/ ) {
  517             Perl::Tidy::Die("You must specify a valid filename after -css\n");
  518         }
  519     }
  520 
  521     # check for conflict
  522     if ( $css_linkname && $rOpts->{'nohtml-style-sheets'} ) {
  523         $rOpts->{'nohtml-style-sheets'} = 0;
  524         warning("You can't specify both -css and -nss; -nss ignored\n");
  525     }
  526 
  527     # write a style sheet file if necessary
  528     if ($css_linkname) {
  529 
  530         # if the selected filename exists, don't write, because user may
  531         # have done some work by hand to create it; use backup name instead
  532         # Also, this will avoid a potential disaster in which the user
  533         # forgets to specify the style sheet, like this:
  534         #    perltidy -html -css myfile1.pl myfile2.pl
  535         # This would cause myfile1.pl to parsed as the style sheet by GetOpts
  536         my $css_filename = $css_linkname;
  537         unless ( -e $css_filename ) {
  538             write_style_sheet_file($css_filename);
  539         }
  540     }
  541     $missing_html_entities = 1 unless $rOpts->{'html-entities'};
  542     return;
  543 }
  544 
  545 sub write_style_sheet_file {
  546 
  547     my $css_filename = shift;
  548     my $fh;
  549     unless ( $fh = IO::File->new("> $css_filename") ) {
  550         Perl::Tidy::Die("can't open $css_filename: $!\n");
  551     }
  552     write_style_sheet_data($fh);
  553     close_object($fh);
  554     return;
  555 }
  556 
  557 sub write_style_sheet_data {
  558 
  559     # write the style sheet data to an open file handle
  560     my $fh = shift;
  561 
  562     my $bg_color   = $rOpts->{'html-color-background'};
  563     my $text_color = $rOpts->{'html-color-punctuation'};
  564 
  565     # pre-bgcolor is new, and may not be defined
  566     my $pre_bg_color = $rOpts->{'html-pre-color-background'};
  567     $pre_bg_color = $bg_color unless $pre_bg_color;
  568 
  569     $fh->print(<<"EOM");
  570 /* default style sheet generated by perltidy */
  571 body {background: $bg_color; color: $text_color}
  572 pre { color: $text_color; 
  573       background: $pre_bg_color;
  574       font-family: courier;
  575     } 
  576 
  577 EOM
  578 
  579     foreach my $short_name ( sort keys %short_to_long_names ) {
  580         my $long_name = $short_to_long_names{$short_name};
  581 
  582         my $abbrev = '.' . $short_name;
  583         if ( length($short_name) == 1 ) { $abbrev .= ' ' }    # for alignment
  584         my $color = $html_color{$short_name};
  585         if ( !defined($color) ) { $color = $text_color }
  586         $fh->print("$abbrev \{ color: $color;");
  587 
  588         if ( $html_bold{$short_name} ) {
  589             $fh->print(" font-weight:bold;");
  590         }
  591 
  592         if ( $html_italic{$short_name} ) {
  593             $fh->print(" font-style:italic;");
  594         }
  595         $fh->print("} /* $long_name */\n");
  596     }
  597     return;
  598 }
  599 
  600 sub set_default_color {
  601 
  602     # make sure that options hash $rOpts->{$key} contains a valid color
  603     my ( $key, $color ) = @_;
  604     if ( $rOpts->{$key} ) { $color = $rOpts->{$key} }
  605     $rOpts->{$key} = check_RGB($color);
  606     return;
  607 }
  608 
  609 sub check_RGB {
  610 
  611     # if color is a 6 digit hex RGB value, prepend a #, otherwise
  612     # assume that it is a valid ascii color name
  613     my ($color) = @_;
  614     if ( $color =~ /^[0-9a-fA-F]{6,6}$/ ) { $color = "#$color" }
  615     return $color;
  616 }
  617 
  618 sub set_default_properties {
  619     my ( $short_name, $color, $bold, $italic ) = @_;
  620 
  621     set_default_color( "html-color-$short_to_long_names{$short_name}", $color );
  622     my $key;
  623     $key           = "html-bold-$short_to_long_names{$short_name}";
  624     $rOpts->{$key} = ( defined $rOpts->{$key} ) ? $rOpts->{$key} : $bold;
  625     $key           = "html-italic-$short_to_long_names{$short_name}";
  626     $rOpts->{$key} = ( defined $rOpts->{$key} ) ? $rOpts->{$key} : $italic;
  627     return;
  628 }
  629 
  630 sub pod_to_html {
  631 
  632     # Use Pod::Html to process the pod and make the page
  633     # then merge the perltidy code sections into it.
  634     # return 1 if success, 0 otherwise
  635     my ( $self, $pod_string, $css_string, $toc_string, $rpre_string_stack ) =
  636       @_;
  637     my $input_file   = $self->{_input_file};
  638     my $title        = $self->{_title};
  639     my $success_flag = 0;
  640 
  641     # don't try to use pod2html if no pod
  642     unless ($pod_string) {
  643         return $success_flag;
  644     }
  645 
  646     # Pod::Html requires a real temporary filename
  647     my ( $fh_tmp, $tmpfile ) = File::Temp::tempfile();
  648     unless ($fh_tmp) {
  649         Perl::Tidy::Warn(
  650             "unable to open temporary file $tmpfile; cannot use pod2html\n");
  651         return $success_flag;
  652     }
  653 
  654     #------------------------------------------------------------------
  655     # Warning: a temporary file is open; we have to clean up if
  656     # things go bad.  From here on all returns should be by going to
  657     # RETURN so that the temporary file gets unlinked.
  658     #------------------------------------------------------------------
  659 
  660     # write the pod text to the temporary file
  661     $fh_tmp->print($pod_string);
  662     $fh_tmp->close();
  663 
  664     # Hand off the pod to pod2html.
  665     # Note that we can use the same temporary filename for input and output
  666     # because of the way pod2html works.
  667     {
  668 
  669         my @args;
  670         push @args, "--infile=$tmpfile", "--outfile=$tmpfile", "--title=$title";
  671 
  672         # Flags with string args:
  673         # "backlink=s", "cachedir=s", "htmlroot=s", "libpods=s",
  674         # "podpath=s", "podroot=s"
  675         # Note: -css=s is handled by perltidy itself
  676         foreach my $kw (qw(backlink cachedir htmlroot libpods podpath podroot))
  677         {
  678             if ( $rOpts->{$kw} ) { push @args, "--$kw=$rOpts->{$kw}" }
  679         }
  680 
  681         # Toggle switches; these have extra leading 'pod'
  682         # "header!", "index!", "recurse!", "quiet!", "verbose!"
  683         foreach my $kw (qw(podheader podindex podrecurse podquiet podverbose)) {
  684             my $kwd = $kw;    # allows us to strip 'pod'
  685             if ( $rOpts->{$kw} ) { $kwd =~ s/^pod//; push @args, "--$kwd" }
  686             elsif ( defined( $rOpts->{$kw} ) ) {
  687                 $kwd =~ s/^pod//;
  688                 push @args, "--no$kwd";
  689             }
  690         }
  691 
  692         # "flush",
  693         my $kw = 'podflush';
  694         if ( $rOpts->{$kw} ) { $kw =~ s/^pod//; push @args, "--$kw" }
  695 
  696         # Must clean up if pod2html dies (it can);
  697         # Be careful not to overwrite callers __DIE__ routine
  698         local $SIG{__DIE__} = sub {
  699             unlink $tmpfile if -e $tmpfile;
  700             Perl::Tidy::Die( $_[0] );
  701         };
  702 
  703         pod2html(@args);
  704     }
  705     $fh_tmp = IO::File->new( $tmpfile, 'r' );
  706     unless ($fh_tmp) {
  707 
  708         # this error shouldn't happen ... we just used this filename
  709         Perl::Tidy::Warn(
  710             "unable to open temporary file $tmpfile; cannot use pod2html\n");
  711         goto RETURN;
  712     }
  713 
  714     my $html_fh = $self->{_html_fh};
  715     my @toc;
  716     my $in_toc;
  717     my $ul_level = 0;
  718     my $no_print;
  719 
  720     # This routine will write the html selectively and store the toc
  721     my $html_print = sub {
  722         foreach (@_) {
  723             $html_fh->print($_) unless ($no_print);
  724             if ($in_toc) { push @toc, $_ }
  725         }
  726     };
  727 
  728     # loop over lines of html output from pod2html and merge in
  729     # the necessary perltidy html sections
  730     my ( $saw_body, $saw_index, $saw_body_end );
  731 
  732     my $timestamp = "";
  733     if ( $rOpts->{'timestamp'} ) {
  734         my $date = localtime;
  735         $timestamp = "on $date";
  736     }
  737     while ( my $line = $fh_tmp->getline() ) {
  738 
  739         if ( $line =~ /^\s*<html>\s*$/i ) {
  740             ##my $date = localtime;
  741             ##$html_print->("<!-- Generated by perltidy on $date -->\n");
  742             $html_print->("<!-- Generated by perltidy $timestamp -->\n");
  743             $html_print->($line);
  744         }
  745 
  746         # Copy the perltidy css, if any, after <body> tag
  747         elsif ( $line =~ /^\s*<body.*>\s*$/i ) {
  748             $saw_body = 1;
  749             $html_print->($css_string) if $css_string;
  750             $html_print->($line);
  751 
  752             # add a top anchor and heading
  753             $html_print->("<a name=\"-top-\"></a>\n");
  754             $title = escape_html($title);
  755             $html_print->("<h1>$title</h1>\n");
  756         }
  757 
  758         # check for start of index, old pod2html
  759         # before Pod::Html VERSION 1.15_02 it is delimited by comments as:
  760         #    <!-- INDEX BEGIN -->
  761         #    <ul>
  762         #     ...
  763         #    </ul>
  764         #    <!-- INDEX END -->
  765         #
  766         elsif ( $line =~ /^\s*<!-- INDEX BEGIN -->\s*$/i ) {
  767             $in_toc = 'INDEX';
  768 
  769             # when frames are used, an extra table of contents in the
  770             # contents panel is confusing, so don't print it
  771             $no_print = $rOpts->{'frames'}
  772               || !$rOpts->{'html-table-of-contents'};
  773             $html_print->("<h2>Doc Index:</h2>\n") if $rOpts->{'frames'};
  774             $html_print->($line);
  775         }
  776 
  777         # check for start of index, new pod2html
  778         # After Pod::Html VERSION 1.15_02 it is delimited as:
  779         # <ul id="index">
  780         # ...
  781         # </ul>
  782         elsif ( $line =~ /^\s*<ul\s+id="index">/i ) {
  783             $in_toc   = 'UL';
  784             $ul_level = 1;
  785 
  786             # when frames are used, an extra table of contents in the
  787             # contents panel is confusing, so don't print it
  788             $no_print = $rOpts->{'frames'}
  789               || !$rOpts->{'html-table-of-contents'};
  790             $html_print->("<h2>Doc Index:</h2>\n") if $rOpts->{'frames'};
  791             $html_print->($line);
  792         }
  793 
  794         # Check for end of index, old pod2html
  795         elsif ( $line =~ /^\s*<!-- INDEX END -->\s*$/i ) {
  796             $saw_index = 1;
  797             $html_print->($line);
  798 
  799             # Copy the perltidy toc, if any, after the Pod::Html toc
  800             if ($toc_string) {
  801                 $html_print->("<hr />\n") if $rOpts->{'frames'};
  802                 $html_print->("<h2>Code Index:</h2>\n");
  803                 ##my @toc = map { $_ .= "\n" } split /\n/, $toc_string;
  804                 my @toc = map { $_ . "\n" } split /\n/, $toc_string;
  805                 $html_print->(@toc);
  806             }
  807             $in_toc   = "";
  808             $no_print = 0;
  809         }
  810 
  811         # must track <ul> depth level for new pod2html
  812         elsif ( $line =~ /\s*<ul>\s*$/i && $in_toc eq 'UL' ) {
  813             $ul_level++;
  814             $html_print->($line);
  815         }
  816 
  817         # Check for end of index, for new pod2html
  818         elsif ( $line =~ /\s*<\/ul>/i && $in_toc eq 'UL' ) {
  819             $ul_level--;
  820             $html_print->($line);
  821 
  822             # Copy the perltidy toc, if any, after the Pod::Html toc
  823             if ( $ul_level <= 0 ) {
  824                 $saw_index = 1;
  825                 if ($toc_string) {
  826                     $html_print->("<hr />\n") if $rOpts->{'frames'};
  827                     $html_print->("<h2>Code Index:</h2>\n");
  828                     ##my @toc = map { $_ .= "\n" } split /\n/, $toc_string;
  829                     my @toc = map { $_ . "\n" } split /\n/, $toc_string;
  830                     $html_print->(@toc);
  831                 }
  832                 $in_toc   = "";
  833                 $ul_level = 0;
  834                 $no_print = 0;
  835             }
  836         }
  837 
  838         # Copy one perltidy section after each marker
  839         elsif ( $line =~ /^(.*)<!-- pERLTIDY sECTION -->(.*)$/ ) {
  840             $line = $2;
  841             $html_print->($1) if $1;
  842 
  843             # Intermingle code and pod sections if we saw multiple =cut's.
  844             if ( $self->{_pod_cut_count} > 1 ) {
  845                 my $rpre_string = shift( @{$rpre_string_stack} );
  846                 if ( ${$rpre_string} ) {
  847                     $html_print->('<pre>');
  848                     $html_print->( ${$rpre_string} );
  849                     $html_print->('</pre>');
  850                 }
  851                 else {
  852 
  853                     # shouldn't happen: we stored a string before writing
  854                     # each marker.
  855                     Perl::Tidy::Warn(
  856 "Problem merging html stream with pod2html; order may be wrong\n"
  857                     );
  858                 }
  859                 $html_print->($line);
  860             }
  861 
  862             # If didn't see multiple =cut lines, we'll put the pod out first
  863             # and then the code, because it's less confusing.
  864             else {
  865 
  866                 # since we are not intermixing code and pod, we don't need
  867                 # or want any <hr> lines which separated pod and code
  868                 $html_print->($line) unless ( $line =~ /^\s*<hr>\s*$/i );
  869             }
  870         }
  871 
  872         # Copy any remaining code section before the </body> tag
  873         elsif ( $line =~ /^\s*<\/body>\s*$/i ) {
  874             $saw_body_end = 1;
  875             if ( @{$rpre_string_stack} ) {
  876                 unless ( $self->{_pod_cut_count} > 1 ) {
  877                     $html_print->('<hr />');
  878                 }
  879                 while ( my $rpre_string = shift( @{$rpre_string_stack} ) ) {
  880                     $html_print->('<pre>');
  881                     $html_print->( ${$rpre_string} );
  882                     $html_print->('</pre>');
  883                 }
  884             }
  885             $html_print->($line);
  886         }
  887         else {
  888             $html_print->($line);
  889         }
  890     }
  891 
  892     $success_flag = 1;
  893     unless ($saw_body) {
  894         Perl::Tidy::Warn("Did not see <body> in pod2html output\n");
  895         $success_flag = 0;
  896     }
  897     unless ($saw_body_end) {
  898         Perl::Tidy::Warn("Did not see </body> in pod2html output\n");
  899         $success_flag = 0;
  900     }
  901     unless ($saw_index) {
  902         Perl::Tidy::Warn("Did not find INDEX END in pod2html output\n");
  903         $success_flag = 0;
  904     }
  905 
  906   RETURN:
  907     close_object($html_fh);
  908 
  909     # note that we have to unlink tmpfile before making frames
  910     # because the tmpfile may be one of the names used for frames
  911     if ( -e $tmpfile ) {
  912         unless ( unlink($tmpfile) ) {
  913             Perl::Tidy::Warn("couldn't unlink temporary file $tmpfile: $!\n");
  914             $success_flag = 0;
  915         }
  916     }
  917 
  918     if ( $success_flag && $rOpts->{'frames'} ) {
  919         $self->make_frame( \@toc );
  920     }
  921     return $success_flag;
  922 }
  923 
  924 sub make_frame {
  925 
  926     # Make a frame with table of contents in the left panel
  927     # and the text in the right panel.
  928     # On entry:
  929     #  $html_filename contains the no-frames html output
  930     #  $rtoc is a reference to an array with the table of contents
  931     my ( $self, $rtoc ) = @_;
  932     my $input_file    = $self->{_input_file};
  933     my $html_filename = $self->{_html_file};
  934     my $toc_filename  = $self->{_toc_filename};
  935     my $src_filename  = $self->{_src_filename};
  936     my $title         = $self->{_title};
  937     $title = escape_html($title);
  938 
  939     # FUTURE input parameter:
  940     my $top_basename = "";
  941 
  942     # We need to produce 3 html files:
  943     # 1. - the table of contents
  944     # 2. - the contents (source code) itself
  945     # 3. - the frame which contains them
  946 
  947     # get basenames for relative links
  948     my ( $toc_basename, $toc_path ) = fileparse($toc_filename);
  949     my ( $src_basename, $src_path ) = fileparse($src_filename);
  950 
  951     # 1. Make the table of contents panel, with appropriate changes
  952     # to the anchor names
  953     my $src_frame_name = 'SRC';
  954     my $first_anchor =
  955       write_toc_html( $title, $toc_filename, $src_basename, $rtoc,
  956         $src_frame_name );
  957 
  958     # 2. The current .html filename is renamed to be the contents panel
  959     rename( $html_filename, $src_filename )
  960       or Perl::Tidy::Die("Cannot rename $html_filename to $src_filename:$!\n");
  961 
  962     # 3. Then use the original html filename for the frame
  963     write_frame_html(
  964         $title,        $html_filename, $top_basename,
  965         $toc_basename, $src_basename,  $src_frame_name
  966     );
  967     return;
  968 }
  969 
  970 sub write_toc_html {
  971 
  972     # write a separate html table of contents file for frames
  973     my ( $title, $toc_filename, $src_basename, $rtoc, $src_frame_name ) = @_;
  974     my $fh = IO::File->new( $toc_filename, 'w' )
  975       or Perl::Tidy::Die("Cannot open $toc_filename:$!\n");
  976     $fh->print(<<EOM);
  977 <html>
  978 <head>
  979 <title>$title</title>
  980 </head>
  981 <body>
  982 <h1><a href=\"$src_basename#-top-" target="$src_frame_name">$title</a></h1>
  983 EOM
  984 
  985     my $first_anchor =
  986       change_anchor_names( $rtoc, $src_basename, "$src_frame_name" );
  987     $fh->print( join "", @{$rtoc} );
  988 
  989     $fh->print(<<EOM);
  990 </body>
  991 </html>
  992 EOM
  993 
  994     return;
  995 }
  996 
  997 sub write_frame_html {
  998 
  999     # write an html file to be the table of contents frame
 1000     my (
 1001         $title,        $frame_filename, $top_basename,
 1002         $toc_basename, $src_basename,   $src_frame_name
 1003     ) = @_;
 1004 
 1005     my $fh = IO::File->new( $frame_filename, 'w' )
 1006       or Perl::Tidy::Die("Cannot open $toc_basename:$!\n");
 1007 
 1008     $fh->print(<<EOM);
 1009 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"
 1010     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd">
 1011 <?xml version="1.0" encoding="iso-8859-1" ?>
 1012 <html xmlns="http://www.w3.org/1999/xhtml">
 1013 <head>
 1014 <title>$title</title>
 1015 </head>
 1016 EOM
 1017 
 1018     # two left panels, one right, if master index file
 1019     if ($top_basename) {
 1020         $fh->print(<<EOM);
 1021 <frameset cols="20%,80%">
 1022 <frameset rows="30%,70%">
 1023 <frame src = "$top_basename" />
 1024 <frame src = "$toc_basename" />
 1025 </frameset>
 1026 EOM
 1027     }
 1028 
 1029     # one left panels, one right, if no master index file
 1030     else {
 1031         $fh->print(<<EOM);
 1032 <frameset cols="20%,*">
 1033 <frame src = "$toc_basename" />
 1034 EOM
 1035     }
 1036     $fh->print(<<EOM);
 1037 <frame src = "$src_basename" name = "$src_frame_name" />
 1038 <noframes>
 1039 <body>
 1040 <p>If you see this message, you are using a non-frame-capable web client.</p>
 1041 <p>This document contains:</p>
 1042 <ul>
 1043 <li><a href="$toc_basename">A table of contents</a></li>
 1044 <li><a href="$src_basename">The source code</a></li>
 1045 </ul>
 1046 </body>
 1047 </noframes>
 1048 </frameset>
 1049 </html>
 1050 EOM
 1051     return;
 1052 }
 1053 
 1054 sub change_anchor_names {
 1055 
 1056     # add a filename and target to anchors
 1057     # also return the first anchor
 1058     my ( $rlines, $filename, $target ) = @_;
 1059     my $first_anchor;
 1060     foreach my $line ( @{$rlines} ) {
 1061 
 1062         #  We're looking for lines like this:
 1063         #  <LI><A HREF="#synopsis">SYNOPSIS</A></LI>
 1064         #  ----  -       --------  -----------------
 1065         #  $1              $4            $5
 1066         if ( $line =~ /^(.*)<a(.*)href\s*=\s*"([^#]*)#([^"]+)"[^>]*>(.*)$/i ) {
 1067             my $pre  = $1;
 1068             my $name = $4;
 1069             my $post = $5;
 1070             my $href = "$filename#$name";
 1071             $line = "$pre<a href=\"$href\" target=\"$target\">$post\n";
 1072             unless ($first_anchor) { $first_anchor = $href }
 1073         }
 1074     }
 1075     return $first_anchor;
 1076 }
 1077 
 1078 sub close_html_file {
 1079     my $self = shift;
 1080     return unless $self->{_html_file_opened};
 1081 
 1082     my $html_fh     = $self->{_html_fh};
 1083     my $rtoc_string = $self->{_rtoc_string};
 1084 
 1085     # There are 3 basic paths to html output...
 1086 
 1087     # ---------------------------------
 1088     # Path 1: finish up if in -pre mode
 1089     # ---------------------------------
 1090     if ( $rOpts->{'html-pre-only'} ) {
 1091         $html_fh->print( <<"PRE_END");
 1092 </pre>
 1093 PRE_END
 1094         close_object($html_fh);
 1095         return;
 1096     }
 1097 
 1098     # Finish the index
 1099     $self->add_toc_item( 'EOF', 'EOF' );
 1100 
 1101     my $rpre_string_stack = $self->{_rpre_string_stack};
 1102 
 1103     # Patch to darken the <pre> background color in case of pod2html and
 1104     # interleaved code/documentation.  Otherwise, the distinction
 1105     # between code and documentation is blurred.
 1106     if (   $rOpts->{pod2html}
 1107         && $self->{_pod_cut_count} >= 1
 1108         && $rOpts->{'html-color-background'} eq '#FFFFFF' )
 1109     {
 1110         $rOpts->{'html-pre-color-background'} = '#F0F0F0';
 1111     }
 1112 
 1113     # put the css or its link into a string, if used
 1114     my $css_string;
 1115     my $fh_css = Perl::Tidy::IOScalar->new( \$css_string, 'w' );
 1116 
 1117     # use css linked to another file
 1118     if ( $rOpts->{'html-linked-style-sheet'} ) {
 1119         $fh_css->print(
 1120             qq(<link rel="stylesheet" href="$css_linkname" type="text/css" />));
 1121     }
 1122 
 1123     # use css embedded in this file
 1124     elsif ( !$rOpts->{'nohtml-style-sheets'} ) {
 1125         $fh_css->print( <<'ENDCSS');
 1126 <style type="text/css">
 1127 <!--
 1128 ENDCSS
 1129         write_style_sheet_data($fh_css);
 1130         $fh_css->print( <<"ENDCSS");
 1131 -->
 1132 </style>
 1133 ENDCSS
 1134     }
 1135 
 1136     # -----------------------------------------------------------
 1137     # path 2: use pod2html if requested
 1138     #         If we fail for some reason, continue on to path 3
 1139     # -----------------------------------------------------------
 1140     if ( $rOpts->{'pod2html'} ) {
 1141         my $rpod_string = $self->{_rpod_string};
 1142         $self->pod_to_html(
 1143             ${$rpod_string}, $css_string,
 1144             ${$rtoc_string}, $rpre_string_stack
 1145         ) && return;
 1146     }
 1147 
 1148     # --------------------------------------------------
 1149     # path 3: write code in html, with pod only in italics
 1150     # --------------------------------------------------
 1151     my $input_file = $self->{_input_file};
 1152     my $title      = escape_html($input_file);
 1153     my $timestamp  = "";
 1154     if ( $rOpts->{'timestamp'} ) {
 1155         my $date = localtime;
 1156         $timestamp = "on $date";
 1157     }
 1158     $html_fh->print( <<"HTML_START");
 1159 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" 
 1160    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 1161 <!-- Generated by perltidy $timestamp -->
 1162 <html xmlns="http://www.w3.org/1999/xhtml">
 1163 <head>
 1164 <title>$title</title>
 1165 HTML_START
 1166 
 1167     # output the css, if used
 1168     if ($css_string) {
 1169         $html_fh->print($css_string);
 1170         $html_fh->print( <<"ENDCSS");
 1171 </head>
 1172 <body>
 1173 ENDCSS
 1174     }
 1175     else {
 1176 
 1177         $html_fh->print( <<"HTML_START");
 1178 </head>
 1179 <body bgcolor=\"$rOpts->{'html-color-background'}\" text=\"$rOpts->{'html-color-punctuation'}\">
 1180 HTML_START
 1181     }
 1182 
 1183     $html_fh->print("<a name=\"-top-\"></a>\n");
 1184     $html_fh->print( <<"EOM");
 1185 <h1>$title</h1>
 1186 EOM
 1187 
 1188     # copy the table of contents
 1189     if (   ${$rtoc_string}
 1190         && !$rOpts->{'frames'}
 1191         && $rOpts->{'html-table-of-contents'} )
 1192     {
 1193         $html_fh->print( ${$rtoc_string} );
 1194     }
 1195 
 1196     # copy the pre section(s)
 1197     my $fname_comment = $input_file;
 1198     $fname_comment =~ s/--+/-/g;    # protect HTML comment tags
 1199     $html_fh->print( <<"END_PRE");
 1200 <hr />
 1201 <!-- contents of filename: $fname_comment -->
 1202 <pre>
 1203 END_PRE
 1204 
 1205     foreach my $rpre_string ( @{$rpre_string_stack} ) {
 1206         $html_fh->print( ${$rpre_string} );
 1207     }
 1208 
 1209     # and finish the html page
 1210     $html_fh->print( <<"HTML_END");
 1211 </pre>
 1212 </body>
 1213 </html>
 1214 HTML_END
 1215     close_object($html_fh);
 1216 
 1217     if ( $rOpts->{'frames'} ) {
 1218         ##my @toc = map { $_ .= "\n" } split /\n/, ${$rtoc_string};
 1219         my @toc = map { $_ . "\n" } split /\n/, ${$rtoc_string};
 1220         $self->make_frame( \@toc );
 1221     }
 1222     return;
 1223 }
 1224 
 1225 sub markup_tokens {
 1226     my ( $self, $rtokens, $rtoken_type, $rlevels ) = @_;
 1227     my ( @colored_tokens, $type, $token, $level );
 1228     my $rlast_level    = $self->{_rlast_level};
 1229     my $rpackage_stack = $self->{_rpackage_stack};
 1230 
 1231     for ( my $j = 0 ; $j < @{$rtoken_type} ; $j++ ) {
 1232         $type  = $rtoken_type->[$j];
 1233         $token = $rtokens->[$j];
 1234         $level = $rlevels->[$j];
 1235         $level = 0 if ( $level < 0 );
 1236 
 1237         #-------------------------------------------------------
 1238         # Update the package stack.  The package stack is needed to keep
 1239         # the toc correct because some packages may be declared within
 1240         # blocks and go out of scope when we leave the block.
 1241         #-------------------------------------------------------
 1242         if ( $level > ${$rlast_level} ) {
 1243             unless ( $rpackage_stack->[ $level - 1 ] ) {
 1244                 $rpackage_stack->[ $level - 1 ] = 'main';
 1245             }
 1246             $rpackage_stack->[$level] = $rpackage_stack->[ $level - 1 ];
 1247         }
 1248         elsif ( $level < ${$rlast_level} ) {
 1249             my $package = $rpackage_stack->[$level];
 1250             unless ($package) { $package = 'main' }
 1251 
 1252             # if we change packages due to a nesting change, we
 1253             # have to make an entry in the toc
 1254             if ( $package ne $rpackage_stack->[ $level + 1 ] ) {
 1255                 $self->add_toc_item( $package, 'package' );
 1256             }
 1257         }
 1258         ${$rlast_level} = $level;
 1259 
 1260         #-------------------------------------------------------
 1261         # Intercept a sub name here; split it
 1262         # into keyword 'sub' and sub name; and add an
 1263         # entry in the toc
 1264         #-------------------------------------------------------
 1265         if ( $type eq 'i' && $token =~ /^(sub\s+)(\w.*)$/ ) {
 1266             $token = $self->markup_html_element( $1, 'k' );
 1267             push @colored_tokens, $token;
 1268             $token = $2;
 1269             $type  = 'M';
 1270 
 1271             # but don't include sub declarations in the toc;
 1272             # these wlll have leading token types 'i;'
 1273             my $signature = join "", @{$rtoken_type};
 1274             unless ( $signature =~ /^i;/ ) {
 1275                 my $subname = $token;
 1276                 $subname =~ s/[\s\(].*$//; # remove any attributes and prototype
 1277                 $self->add_toc_item( $subname, 'sub' );
 1278             }
 1279         }
 1280 
 1281         #-------------------------------------------------------
 1282         # Intercept a package name here; split it
 1283         # into keyword 'package' and name; add to the toc,
 1284         # and update the package stack
 1285         #-------------------------------------------------------
 1286         if ( $type eq 'i' && $token =~ /^(package\s+)(\w.*)$/ ) {
 1287             $token = $self->markup_html_element( $1, 'k' );
 1288             push @colored_tokens, $token;
 1289             $token = $2;
 1290             $type  = 'i';
 1291             $self->add_toc_item( "$token", 'package' );
 1292             $rpackage_stack->[$level] = $token;
 1293         }
 1294 
 1295         $token = $self->markup_html_element( $token, $type );
 1296         push @colored_tokens, $token;
 1297     }
 1298     return ( \@colored_tokens );
 1299 }
 1300 
 1301 sub markup_html_element {
 1302     my ( $self, $token, $type ) = @_;
 1303 
 1304     return $token if ( $type eq 'b' );         # skip a blank token
 1305     return $token if ( $token =~ /^\s*$/ );    # skip a blank line
 1306     $token = escape_html($token);
 1307 
 1308     # get the short abbreviation for this token type
 1309     my $short_name = $token_short_names{$type};
 1310     if ( !defined($short_name) ) {
 1311         $short_name = "pu";                    # punctuation is default
 1312     }
 1313 
 1314     # handle style sheets..
 1315     if ( !$rOpts->{'nohtml-style-sheets'} ) {
 1316         if ( $short_name ne 'pu' ) {
 1317             $token = qq(<span class="$short_name">) . $token . "</span>";
 1318         }
 1319     }
 1320 
 1321     # handle no style sheets..
 1322     else {
 1323         my $color = $html_color{$short_name};
 1324 
 1325         if ( $color && ( $color ne $rOpts->{'html-color-punctuation'} ) ) {
 1326             $token = qq(<font color="$color">) . $token . "</font>";
 1327         }
 1328         if ( $html_italic{$short_name} ) { $token = "<i>$token</i>" }
 1329         if ( $html_bold{$short_name} )   { $token = "<b>$token</b>" }
 1330     }
 1331     return $token;
 1332 }
 1333 
 1334 sub escape_html {
 1335 
 1336     my $token = shift;
 1337     if ($missing_html_entities) {
 1338         $token =~ s/\&/&amp;/g;
 1339         $token =~ s/\</&lt;/g;
 1340         $token =~ s/\>/&gt;/g;
 1341         $token =~ s/\"/&quot;/g;
 1342     }
 1343     else {
 1344         HTML::Entities::encode_entities($token);
 1345     }
 1346     return $token;
 1347 }
 1348 
 1349 sub finish_formatting {
 1350 
 1351     # called after last line
 1352     my $self = shift;
 1353     $self->close_html_file();
 1354     return;
 1355 }
 1356 
 1357 sub write_line {
 1358 
 1359     my ( $self, $line_of_tokens ) = @_;
 1360     return unless $self->{_html_file_opened};
 1361     my $html_pre_fh = $self->{_html_pre_fh};
 1362     my $line_type   = $line_of_tokens->{_line_type};
 1363     my $input_line  = $line_of_tokens->{_line_text};
 1364     my $line_number = $line_of_tokens->{_line_number};
 1365     chomp $input_line;
 1366 
 1367     # markup line of code..
 1368     my $html_line;
 1369     if ( $line_type eq 'CODE' ) {
 1370         my $rtoken_type = $line_of_tokens->{_rtoken_type};
 1371         my $rtokens     = $line_of_tokens->{_rtokens};
 1372         my $rlevels     = $line_of_tokens->{_rlevels};
 1373 
 1374         if ( $input_line =~ /(^\s*)/ ) {
 1375             $html_line = $1;
 1376         }
 1377         else {
 1378             $html_line = "";
 1379         }
 1380         my ($rcolored_tokens) =
 1381           $self->markup_tokens( $rtokens, $rtoken_type, $rlevels );
 1382         $html_line .= join '', @{$rcolored_tokens};
 1383     }
 1384 
 1385     # markup line of non-code..
 1386     else {
 1387         my $line_character;
 1388         if    ( $line_type eq 'HERE' )       { $line_character = 'H' }
 1389         elsif ( $line_type eq 'HERE_END' )   { $line_character = 'h' }
 1390         elsif ( $line_type eq 'FORMAT' )     { $line_character = 'H' }
 1391         elsif ( $line_type eq 'FORMAT_END' ) { $line_character = 'h' }
 1392         elsif ( $line_type eq 'SYSTEM' )     { $line_character = 'c' }
 1393         elsif ( $line_type eq 'END_START' ) {
 1394             $line_character = 'k';
 1395             $self->add_toc_item( '__END__', '__END__' );
 1396         }
 1397         elsif ( $line_type eq 'DATA_START' ) {
 1398             $line_character = 'k';
 1399             $self->add_toc_item( '__DATA__', '__DATA__' );
 1400         }
 1401         elsif ( $line_type =~ /^POD/ ) {
 1402             $line_character = 'P';
 1403             if ( $rOpts->{'pod2html'} ) {
 1404                 my $html_pod_fh = $self->{_html_pod_fh};
 1405                 if ( $line_type eq 'POD_START' ) {
 1406 
 1407                     my $rpre_string_stack = $self->{_rpre_string_stack};
 1408                     my $rpre_string       = $rpre_string_stack->[-1];
 1409 
 1410                     # if we have written any non-blank lines to the
 1411                     # current pre section, start writing to a new output
 1412                     # string
 1413                     if ( ${$rpre_string} =~ /\S/ ) {
 1414                         my $pre_string;
 1415                         $html_pre_fh =
 1416                           Perl::Tidy::IOScalar->new( \$pre_string, 'w' );
 1417                         $self->{_html_pre_fh} = $html_pre_fh;
 1418                         push @{$rpre_string_stack}, \$pre_string;
 1419 
 1420                         # leave a marker in the pod stream so we know
 1421                         # where to put the pre section we just
 1422                         # finished.
 1423                         my $for_html = '=for html';    # don't confuse pod utils
 1424                         $html_pod_fh->print(<<EOM);
 1425 
 1426 $for_html
 1427 <!-- pERLTIDY sECTION -->
 1428 
 1429 EOM
 1430                     }
 1431 
 1432                     # otherwise, just clear the current string and start
 1433                     # over
 1434                     else {
 1435                         ${$rpre_string} = "";
 1436                         $html_pod_fh->print("\n");
 1437                     }
 1438                 }
 1439                 $html_pod_fh->print( $input_line . "\n" );
 1440                 if ( $line_type eq 'POD_END' ) {
 1441                     $self->{_pod_cut_count}++;
 1442                     $html_pod_fh->print("\n");
 1443                 }
 1444                 return;
 1445             }
 1446         }
 1447         else { $line_character = 'Q' }
 1448         $html_line = $self->markup_html_element( $input_line, $line_character );
 1449     }
 1450 
 1451     # add the line number if requested
 1452     if ( $rOpts->{'html-line-numbers'} ) {
 1453         my $extra_space =
 1454             ( $line_number < 10 )   ? "   "
 1455           : ( $line_number < 100 )  ? "  "
 1456           : ( $line_number < 1000 ) ? " "
 1457           :                           "";
 1458         $html_line = $extra_space . $line_number . " " . $html_line;
 1459     }
 1460 
 1461     # write the line
 1462     $html_pre_fh->print("$html_line\n");
 1463     return;
 1464 }
 1465 1;
 1466