lib/Perl/Tidy/HtmlWriter.pm

   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 = '20181120';
  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