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