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