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 = '20221112';
  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     my @identifier = qw< i t U C Y Z G :: CORE::>;
 389     @token_short_names{@identifier} = ('i') x scalar(@identifier);
 390
 391     # These token types will be called 'structure'
 392     my @structure = qw< { } >;
 393     @token_short_names{@structure} = ('s') x scalar(@structure);
 394
 395     # OLD NOTES: save for reference
 396     # Any of these could be added later if it would be useful.
 397     # For now, they will by default become punctuation
 398     #    my @list = qw< L R [ ] >;
 399     #    @token_long_names{@list} = ('non-structure') x scalar(@list);
 400     #
 401     #    my @list = qw"
 402     #      / /= * *= ** **= + += - -= % %= = ++ -- << <<= >> >>= pp p m mm
 403     #      ";
 404     #    @token_long_names{@list} = ('math') x scalar(@list);
 405     #
 406     #    my @list = qw" & &= ~ ~= ^ ^= | |= ";
 407     #    @token_long_names{@list} = ('bit') x scalar(@list);
 408     #
 409     #    my @list = qw" == != < > <= <=> ";
 410     #    @token_long_names{@list} = ('numerical-comparison') x scalar(@list);
 411     #
 412     #    my @list = qw" && || ! &&= ||= //= ";
 413     #    @token_long_names{@list} = ('logical') x scalar(@list);
 414     #
 415     #    my @list = qw" . .= =~ !~ x x= ";
 416     #    @token_long_names{@list} = ('string-operators') x scalar(@list);
 417     #
 418     #    # Incomplete..
 419     #    my @list = qw" .. -> <> ... \ ? ";
 420     #    @token_long_names{@list} = ('misc-operators') x scalar(@list);
 421
 422 }
 423
 424 sub make_getopt_long_names {
 425     my ( $class, $rgetopt_names ) = @_;
 426     while ( my ( $short_name, $name ) = each %short_to_long_names ) {
 427         push @{$rgetopt_names}, "html-color-$name=s";
 428         push @{$rgetopt_names}, "html-italic-$name!";
 429         push @{$rgetopt_names}, "html-bold-$name!";
 430     }
 431     push @{$rgetopt_names}, "html-color-background=s";
 432     push @{$rgetopt_names}, "html-linked-style-sheet=s";
 433     push @{$rgetopt_names}, "nohtml-style-sheets";
 434     push @{$rgetopt_names}, "html-pre-only";
 435     push @{$rgetopt_names}, "html-line-numbers";
 436     push @{$rgetopt_names}, "html-entities!";
 437     push @{$rgetopt_names}, "stylesheet";
 438     push @{$rgetopt_names}, "html-table-of-contents!";
 439     push @{$rgetopt_names}, "pod2html!";
 440     push @{$rgetopt_names}, "frames!";
 441     push @{$rgetopt_names}, "html-toc-extension=s";
 442     push @{$rgetopt_names}, "html-src-extension=s";
 443
 444     # Pod::Html parameters:
 445     push @{$rgetopt_names}, "backlink=s";
 446     push @{$rgetopt_names}, "cachedir=s";
 447     push @{$rgetopt_names}, "htmlroot=s";
 448     push @{$rgetopt_names}, "libpods=s";
 449     push @{$rgetopt_names}, "podpath=s";
 450     push @{$rgetopt_names}, "podroot=s";
 451     push @{$rgetopt_names}, "title=s";
 452
 453     # Pod::Html parameters with leading 'pod' which will be removed
 454     # before the call to Pod::Html
 455     push @{$rgetopt_names}, "podquiet!";
 456     push @{$rgetopt_names}, "podverbose!";
 457     push @{$rgetopt_names}, "podrecurse!";
 458     push @{$rgetopt_names}, "podflush";
 459     push @{$rgetopt_names}, "podheader!";
 460     push @{$rgetopt_names}, "podindex!";
 461     return;
 462 }
 463
 464 sub make_abbreviated_names {
 465
 466     # We're appending things like this to the expansion list:
 467     #      'hcc'    => [qw(html-color-comment)],
 468     #      'hck'    => [qw(html-color-keyword)],
 469     #  etc
 470     my ( $class, $rexpansion ) = @_;
 471
 472     # abbreviations for color/bold/italic properties
 473     while ( my ( $short_name, $long_name ) = each %short_to_long_names ) {
 474         ${$rexpansion}{"hc$short_name"}  = ["html-color-$long_name"];
 475         ${$rexpansion}{"hb$short_name"}  = ["html-bold-$long_name"];
 476         ${$rexpansion}{"hi$short_name"}  = ["html-italic-$long_name"];
 477         ${$rexpansion}{"nhb$short_name"} = ["nohtml-bold-$long_name"];
 478         ${$rexpansion}{"nhi$short_name"} = ["nohtml-italic-$long_name"];
 479     }
 480
 481     # abbreviations for all other html options
 482     ${$rexpansion}{"hcbg"}  = ["html-color-background"];
 483     ${$rexpansion}{"pre"}   = ["html-pre-only"];
 484     ${$rexpansion}{"toc"}   = ["html-table-of-contents"];
 485     ${$rexpansion}{"ntoc"}  = ["nohtml-table-of-contents"];
 486     ${$rexpansion}{"nnn"}   = ["html-line-numbers"];
 487     ${$rexpansion}{"hent"}  = ["html-entities"];
 488     ${$rexpansion}{"nhent"} = ["nohtml-entities"];
 489     ${$rexpansion}{"css"}   = ["html-linked-style-sheet"];
 490     ${$rexpansion}{"nss"}   = ["nohtml-style-sheets"];
 491     ${$rexpansion}{"ss"}    = ["stylesheet"];
 492     ${$rexpansion}{"pod"}   = ["pod2html"];
 493     ${$rexpansion}{"npod"}  = ["nopod2html"];
 494     ${$rexpansion}{"frm"}   = ["frames"];
 495     ${$rexpansion}{"nfrm"}  = ["noframes"];
 496     ${$rexpansion}{"text"}  = ["html-toc-extension"];
 497     ${$rexpansion}{"sext"}  = ["html-src-extension"];
 498     return;
 499 }
 500
 501 sub check_options {
 502
 503     # This will be called once after options have been parsed
 504     # Note that we are defining the package variable $rOpts here:
 505     ( my $class, $rOpts ) = @_;
 506
 507     # X11 color names for default settings that seemed to look ok
 508     # (these color names are only used for programming clarity; the hex
 509     # numbers are actually written)
 510     use constant ForestGreen   => "#228B22";
 511     use constant SaddleBrown   => "#8B4513";
 512     use constant magenta4      => "#8B008B";
 513     use constant IndianRed3    => "#CD5555";
 514     use constant DeepSkyBlue4  => "#00688B";
 515     use constant MediumOrchid3 => "#B452CD";
 516     use constant black         => "#000000";
 517     use constant white         => "#FFFFFF";
 518     use constant red           => "#FF0000";
 519
 520     # set default color, bold, italic properties
 521     # anything not listed here will be given the default (punctuation) color --
 522     # these types currently not listed and get default: ws pu s sc cm co p
 523     # When adding NEW_TOKENS: add an entry here if you don't want defaults
 524
 525     # set_default_properties( $short_name, default_color, bold?, italic? );
 526     set_default_properties( 'c',  ForestGreen,   0, 0 );
 527     set_default_properties( 'pd', ForestGreen,   0, 1 );
 528     set_default_properties( 'k',  magenta4,      1, 0 );    # was SaddleBrown
 529     set_default_properties( 'q',  IndianRed3,    0, 0 );
 530     set_default_properties( 'hh', IndianRed3,    0, 1 );
 531     set_default_properties( 'h',  IndianRed3,    1, 0 );
 532     set_default_properties( 'i',  DeepSkyBlue4,  0, 0 );
 533     set_default_properties( 'w',  black,         0, 0 );
 534     set_default_properties( 'n',  MediumOrchid3, 0, 0 );
 535     set_default_properties( 'v',  MediumOrchid3, 0, 0 );
 536     set_default_properties( 'j',  IndianRed3,    1, 0 );
 537     set_default_properties( 'm',  red,           1, 0 );
 538
 539     set_default_color( 'html-color-background',  white );
 540     set_default_color( 'html-color-punctuation', black );
 541
 542     # setup property lookup tables for tokens based on their short names
 543     # every token type has a short name, and will use these tables
 544     # to do the html markup
 545     while ( my ( $short_name, $long_name ) = each %short_to_long_names ) {
 546         $html_color{$short_name}  = $rOpts->{"html-color-$long_name"};
 547         $html_bold{$short_name}   = $rOpts->{"html-bold-$long_name"};
 548         $html_italic{$short_name} = $rOpts->{"html-italic-$long_name"};
 549     }
 550
 551     # write style sheet to STDOUT and die if requested
 552     if ( defined( $rOpts->{'stylesheet'} ) ) {
 553         write_style_sheet_file('-');
 554         Perl::Tidy::Exit(0);
 555     }
 556
 557     # make sure user gives a file name after -css
 558     if ( defined( $rOpts->{'html-linked-style-sheet'} ) ) {
 559         $css_linkname = $rOpts->{'html-linked-style-sheet'};
 560         if ( $css_linkname =~ /^-/ ) {
 561             Perl::Tidy::Die("You must specify a valid filename after -css\n");
 562         }
 563     }
 564
 565     # check for conflict
 566     if ( $css_linkname && $rOpts->{'nohtml-style-sheets'} ) {
 567         $rOpts->{'nohtml-style-sheets'} = 0;
 568         Perl::Tidy::Warn(
 569             "You can't specify both -css and -nss; -nss ignored\n");
 570     }
 571
 572     # write a style sheet file if necessary
 573     if ($css_linkname) {
 574
 575         # if the selected filename exists, don't write, because user may
 576         # have done some work by hand to create it; use backup name instead
 577         # Also, this will avoid a potential disaster in which the user
 578         # forgets to specify the style sheet, like this:
 579         #    perltidy -html -css myfile1.pl myfile2.pl
 580         # This would cause myfile1.pl to parsed as the style sheet by GetOpts
 581         my $css_filename = $css_linkname;
 582         unless ( -e $css_filename ) {
 583             write_style_sheet_file($css_filename);
 584         }
 585     }
 586     $missing_html_entities = 1 unless $rOpts->{'html-entities'};
 587     return;
 588 }
 589
 590 sub write_style_sheet_file {
 591
 592     my $css_filename = shift;
 593     my $fh;
 594     unless ( $fh = IO::File->new("> $css_filename") ) {
 595         Perl::Tidy::Die("can't open $css_filename: $ERRNO\n");
 596     }
 597     write_style_sheet_data($fh);
 598     close_object($fh);
 599     return;
 600 }
 601
 602 sub write_style_sheet_data {
 603
 604     # write the style sheet data to an open file handle
 605     my $fh = shift;
 606
 607     my $bg_color   = $rOpts->{'html-color-background'};
 608     my $text_color = $rOpts->{'html-color-punctuation'};
 609
 610     # pre-bgcolor is new, and may not be defined
 611     my $pre_bg_color = $rOpts->{'html-pre-color-background'};
 612     $pre_bg_color = $bg_color unless $pre_bg_color;
 613
 614     $fh->print(<<"EOM");
 615 /* default style sheet generated by perltidy */
 616 body {background: $bg_color; color: $text_color}
 617 pre { color: $text_color;
 618       background: $pre_bg_color;
 619       font-family: courier;
 620     }
 621
 622 EOM
 623
 624     foreach my $short_name ( sort keys %short_to_long_names ) {
 625         my $long_name = $short_to_long_names{$short_name};
 626
 627         my $abbrev = '.' . $short_name;
 628         if ( length($short_name) == 1 ) { $abbrev .= SPACE }    # for alignment
 629         my $color = $html_color{$short_name};
 630         if ( !defined($color) ) { $color = $text_color }
 631         $fh->print("$abbrev \{ color: $color;");
 632
 633         if ( $html_bold{$short_name} ) {
 634             $fh->print(" font-weight:bold;");
 635         }
 636
 637         if ( $html_italic{$short_name} ) {
 638             $fh->print(" font-style:italic;");
 639         }
 640         $fh->print("} /* $long_name */\n");
 641     }
 642     return;
 643 }
 644
 645 sub set_default_color {
 646
 647     # make sure that options hash $rOpts->{$key} contains a valid color
 648     my ( $key, $color ) = @_;
 649     if ( $rOpts->{$key} ) { $color = $rOpts->{$key} }
 650     $rOpts->{$key} = check_RGB($color);
 651     return;
 652 }
 653
 654 sub check_RGB {
 655
 656     # if color is a 6 digit hex RGB value, prepend a #, otherwise
 657     # assume that it is a valid ascii color name
 658     my ($color) = @_;
 659     if ( $color =~ /^[0-9a-fA-F]{6,6}$/ ) { $color = "#$color" }
 660     return $color;
 661 }
 662
 663 sub set_default_properties {
 664     my ( $short_name, $color, $bold, $italic ) = @_;
 665
 666     set_default_color( "html-color-$short_to_long_names{$short_name}", $color );
 667     my $key;
 668     $key           = "html-bold-$short_to_long_names{$short_name}";
 669     $rOpts->{$key} = ( defined $rOpts->{$key} ) ? $rOpts->{$key} : $bold;
 670     $key           = "html-italic-$short_to_long_names{$short_name}";
 671     $rOpts->{$key} = ( defined $rOpts->{$key} ) ? $rOpts->{$key} : $italic;
 672     return;
 673 }
 674
 675 sub pod_to_html {
 676
 677     # Use Pod::Html to process the pod and make the page
 678     # then merge the perltidy code sections into it.
 679     # return 1 if success, 0 otherwise
 680     my ( $self, $pod_string, $css_string, $toc_string, $rpre_string_stack ) =
 681       @_;
 682     my $input_file   = $self->{_input_file};
 683     my $title        = $self->{_title};
 684     my $success_flag = 0;
 685
 686     # don't try to use pod2html if no pod
 687     unless ($pod_string) {
 688         return $success_flag;
 689     }
 690
 691     # Pod::Html requires a real temporary filename
 692     my ( $fh_tmp, $tmpfile ) = File::Temp::tempfile();
 693     unless ($fh_tmp) {
 694         Perl::Tidy::Warn(
 695             "unable to open temporary file $tmpfile; cannot use pod2html\n");
 696         return $success_flag;
 697     }
 698
 699     #------------------------------------------------------------------
 700     # Warning: a temporary file is open; we have to clean up if
 701     # things go bad.  From here on all returns should be by going to
 702     # RETURN so that the temporary file gets unlinked.
 703     #------------------------------------------------------------------
 704
 705     # write the pod text to the temporary file
 706     $fh_tmp->print($pod_string);
 707     $fh_tmp->close();
 708
 709     # Hand off the pod to pod2html.
 710     # Note that we can use the same temporary filename for input and output
 711     # because of the way pod2html works.
 712     {
 713
 714         my @args;
 715         push @args, "--infile=$tmpfile", "--outfile=$tmpfile", "--title=$title";
 716
 717         # Flags with string args:
 718         # "backlink=s", "cachedir=s", "htmlroot=s", "libpods=s",
 719         # "podpath=s", "podroot=s"
 720         # Note: -css=s is handled by perltidy itself
 721         foreach my $kw (qw(backlink cachedir htmlroot libpods podpath podroot))
 722         {
 723             if ( $rOpts->{$kw} ) { push @args, "--$kw=$rOpts->{$kw}" }
 724         }
 725
 726         # Toggle switches; these have extra leading 'pod'
 727         # "header!", "index!", "recurse!", "quiet!", "verbose!"
 728         foreach my $kw (qw(podheader podindex podrecurse podquiet podverbose)) {
 729             my $kwd = $kw;    # allows us to strip 'pod'
 730             if    ( $rOpts->{$kw} ) { $kwd =~ s/^pod//; push @args, "--$kwd" }
 731             elsif ( defined( $rOpts->{$kw} ) ) {
 732                 $kwd =~ s/^pod//;
 733                 push @args, "--no$kwd";
 734             }
 735         }
 736
 737         # "flush",
 738         my $kw = 'podflush';
 739         if ( $rOpts->{$kw} ) { $kw =~ s/^pod//; push @args, "--$kw" }
 740
 741         # Must clean up if pod2html dies (it can);
 742         # Be careful not to overwrite callers __DIE__ routine
 743         local $SIG{__DIE__} = sub {
 744             unlink $tmpfile if -e $tmpfile;
 745             Perl::Tidy::Die( $_[0] );
 746         };
 747
 748         Pod::Html::pod2html(@args);
 749     }
 750     $fh_tmp = IO::File->new( $tmpfile, 'r' );
 751     unless ($fh_tmp) {
 752
 753         # this error shouldn't happen ... we just used this filename
 754         Perl::Tidy::Warn(
 755             "unable to open temporary file $tmpfile; cannot use pod2html\n");
 756         return $success_flag;
 757     }
 758
 759     my $html_fh = $self->{_html_fh};
 760     my @toc;
 761     my $in_toc;
 762     my $ul_level = 0;
 763     my $no_print;
 764
 765     # This routine will write the html selectively and store the toc
 766     my $html_print = sub {
 767         foreach my $line (@_) {
 768             $html_fh->print($line) unless ($no_print);
 769             if ($in_toc) { push @toc, $line }
 770         }
 771         return;
 772     };
 773
 774     # loop over lines of html output from pod2html and merge in
 775     # the necessary perltidy html sections
 776     my ( $saw_body, $saw_index, $saw_body_end );
 777
 778     my $timestamp = EMPTY_STRING;
 779     if ( $rOpts->{'timestamp'} ) {
 780         my $date = localtime;
 781         $timestamp = "on $date";
 782     }
 783     while ( my $line = $fh_tmp->getline() ) {
 784
 785         if ( $line =~ /^\s*<html>\s*$/i ) {
 786             ##my $date = localtime;
 787             ##$html_print->("<!-- Generated by perltidy on $date -->\n");
 788             $html_print->("<!-- Generated by perltidy $timestamp -->\n");
 789             $html_print->($line);
 790         }
 791
 792         # Copy the perltidy css, if any, after <body> tag
 793         elsif ( $line =~ /^\s*<body.*>\s*$/i ) {
 794             $saw_body = 1;
 795             $html_print->($css_string) if $css_string;
 796             $html_print->($line);
 797
 798             # add a top anchor and heading
 799             $html_print->("<a name=\"-top-\"></a>\n");
 800             $title = escape_html($title);
 801             $html_print->("<h1>$title</h1>\n");
 802         }
 803
 804         # check for start of index, old pod2html
 805         # before Pod::Html VERSION 1.15_02 it is delimited by comments as:
 806         #    <!-- INDEX BEGIN -->
 807         #    <ul>
 808         #     ...
 809         #    </ul>
 810         #    <!-- INDEX END -->
 811         #
 812         elsif ( $line =~ /^\s*<!-- INDEX BEGIN -->\s*$/i ) {
 813             $in_toc = 'INDEX';
 814
 815             # when frames are used, an extra table of contents in the
 816             # contents panel is confusing, so don't print it
 817             $no_print = $rOpts->{'frames'}
 818               || !$rOpts->{'html-table-of-contents'};
 819             $html_print->("<h2>Doc Index:</h2>\n") if $rOpts->{'frames'};
 820             $html_print->($line);
 821         }
 822
 823         # check for start of index, new pod2html
 824         # After Pod::Html VERSION 1.15_02 it is delimited as:
 825         # <ul id="index">
 826         # ...
 827         # </ul>
 828         elsif ( $line =~ /^\s*<ul\s+id="index">/i ) {
 829             $in_toc   = 'UL';
 830             $ul_level = 1;
 831
 832             # when frames are used, an extra table of contents in the
 833             # contents panel is confusing, so don't print it
 834             $no_print = $rOpts->{'frames'}
 835               || !$rOpts->{'html-table-of-contents'};
 836             $html_print->("<h2>Doc Index:</h2>\n") if $rOpts->{'frames'};
 837             $html_print->($line);
 838         }
 839
 840         # Check for end of index, old pod2html
 841         elsif ( $line =~ /^\s*<!-- INDEX END -->\s*$/i ) {
 842             $saw_index = 1;
 843             $html_print->($line);
 844
 845             # Copy the perltidy toc, if any, after the Pod::Html toc
 846             if ($toc_string) {
 847                 $html_print->("<hr />\n") if $rOpts->{'frames'};
 848                 $html_print->("<h2>Code Index:</h2>\n");
 849                 ##my @toc = map { $_ .= "\n" } split /\n/, $toc_string;
 850                 my @toc_st = map { $_ . "\n" } split /\n/, $toc_string;
 851                 $html_print->(@toc_st);
 852             }
 853             $in_toc   = EMPTY_STRING;
 854             $no_print = 0;
 855         }
 856
 857         # must track <ul> depth level for new pod2html
 858         elsif ( $line =~ /\s*<ul>\s*$/i && $in_toc eq 'UL' ) {
 859             $ul_level++;
 860             $html_print->($line);
 861         }
 862
 863         # Check for end of index, for new pod2html
 864         elsif ( $line =~ /\s*<\/ul>/i && $in_toc eq 'UL' ) {
 865             $ul_level--;
 866             $html_print->($line);
 867
 868             # Copy the perltidy toc, if any, after the Pod::Html toc
 869             if ( $ul_level <= 0 ) {
 870                 $saw_index = 1;
 871                 if ($toc_string) {
 872                     $html_print->("<hr />\n") if $rOpts->{'frames'};
 873                     $html_print->("<h2>Code Index:</h2>\n");
 874                     ##my @toc = map { $_ .= "\n" } split /\n/, $toc_string;
 875                     my @toc_st = map { $_ . "\n" } split /\n/, $toc_string;
 876                     $html_print->(@toc_st);
 877                 }
 878                 $in_toc   = EMPTY_STRING;
 879                 $ul_level = 0;
 880                 $no_print = 0;
 881             }
 882         }
 883
 884         # Copy one perltidy section after each marker
 885         elsif ( $line =~ /^(.*)<!-- pERLTIDY sECTION -->(.*)$/ ) {
 886             $line = $2;
 887             $html_print->($1) if $1;
 888
 889             # Intermingle code and pod sections if we saw multiple =cut's.
 890             if ( $self->{_pod_cut_count} > 1 ) {
 891                 my $rpre_string = shift( @{$rpre_string_stack} );
 892                 if ( ${$rpre_string} ) {
 893                     $html_print->('<pre>');
 894                     $html_print->( ${$rpre_string} );
 895                     $html_print->('</pre>');
 896                 }
 897                 else {
 898
 899                     # shouldn't happen: we stored a string before writing
 900                     # each marker.
 901                     Perl::Tidy::Warn(
 902 "Problem merging html stream with pod2html; order may be wrong\n"
 903                     );
 904                 }
 905                 $html_print->($line);
 906             }
 907
 908             # If didn't see multiple =cut lines, we'll put the pod out first
 909             # and then the code, because it's less confusing.
 910             else {
 911
 912                 # since we are not intermixing code and pod, we don't need
 913                 # or want any <hr> lines which separated pod and code
 914                 $html_print->($line) unless ( $line =~ /^\s*<hr>\s*$/i );
 915             }
 916         }
 917
 918         # Copy any remaining code section before the </body> tag
 919         elsif ( $line =~ /^\s*<\/body>\s*$/i ) {
 920             $saw_body_end = 1;
 921             if ( @{$rpre_string_stack} ) {
 922                 unless ( $self->{_pod_cut_count} > 1 ) {
 923                     $html_print->('<hr />');
 924                 }
 925                 while ( my $rpre_string = shift( @{$rpre_string_stack} ) ) {
 926                     $html_print->('<pre>');
 927                     $html_print->( ${$rpre_string} );
 928                     $html_print->('</pre>');
 929                 }
 930             }
 931             $html_print->($line);
 932         }
 933         else {
 934             $html_print->($line);
 935         }
 936     }
 937
 938     $success_flag = 1;
 939     unless ($saw_body) {
 940         Perl::Tidy::Warn("Did not see <body> in pod2html output\n");
 941         $success_flag = 0;
 942     }
 943     unless ($saw_body_end) {
 944         Perl::Tidy::Warn("Did not see </body> in pod2html output\n");
 945         $success_flag = 0;
 946     }
 947     unless ($saw_index) {
 948         Perl::Tidy::Warn("Did not find INDEX END in pod2html output\n");
 949         $success_flag = 0;
 950     }
 951
 952     close_object($html_fh);
 953
 954     # note that we have to unlink tmpfile before making frames
 955     # because the tmpfile may be one of the names used for frames
 956     if ( -e $tmpfile ) {
 957         unless ( unlink($tmpfile) ) {
 958             Perl::Tidy::Warn(
 959                 "couldn't unlink temporary file $tmpfile: $ERRNO\n");
 960             $success_flag = 0;
 961         }
 962     }
 963
 964     if ( $success_flag && $rOpts->{'frames'} ) {
 965         $self->make_frame( \@toc );
 966     }
 967     return $success_flag;
 968 }
 969
 970 sub make_frame {
 971
 972     # Make a frame with table of contents in the left panel
 973     # and the text in the right panel.
 974     # On entry:
 975     #  $html_filename contains the no-frames html output
 976     #  $rtoc is a reference to an array with the table of contents
 977     my ( $self, $rtoc ) = @_;
 978     my $input_file    = $self->{_input_file};
 979     my $html_filename = $self->{_html_file};
 980     my $toc_filename  = $self->{_toc_filename};
 981     my $src_filename  = $self->{_src_filename};
 982     my $title         = $self->{_title};
 983     $title = escape_html($title);
 984
 985     # FUTURE input parameter:
 986     my $top_basename = EMPTY_STRING;
 987
 988     # We need to produce 3 html files:
 989     # 1. - the table of contents
 990     # 2. - the contents (source code) itself
 991     # 3. - the frame which contains them
 992
 993     # get basenames for relative links
 994     my ( $toc_basename, $toc_path ) = fileparse($toc_filename);
 995     my ( $src_basename, $src_path ) = fileparse($src_filename);
 996
 997     # 1. Make the table of contents panel, with appropriate changes
 998     # to the anchor names
 999     my $src_frame_name = 'SRC';
1000     my $first_anchor =
1001       write_toc_html( $title, $toc_filename, $src_basename, $rtoc,
1002         $src_frame_name );
1003
1004     # 2. The current .html filename is renamed to be the contents panel
1005     rename( $html_filename, $src_filename )
1006       or Perl::Tidy::Die(
1007         "Cannot rename $html_filename to $src_filename: $ERRNO\n");
1008
1009     # 3. Then use the original html filename for the frame
1010     write_frame_html(
1011         $title,        $html_filename, $top_basename,
1012         $toc_basename, $src_basename,  $src_frame_name
1013     );
1014     return;
1015 }
1016
1017 sub write_toc_html {
1018
1019     # write a separate html table of contents file for frames
1020     my ( $title, $toc_filename, $src_basename, $rtoc, $src_frame_name ) = @_;
1021     my $fh = IO::File->new( $toc_filename, 'w' )
1022       or Perl::Tidy::Die("Cannot open $toc_filename: $ERRNO\n");
1023     $fh->print(<<EOM);
1024 <html>
1025 <head>
1026 <title>$title</title>
1027 </head>
1028 <body>
1029 <h1><a href=\"$src_basename#-top-" target="$src_frame_name">$title</a></h1>
1030 EOM
1031
1032     my $first_anchor =
1033       change_anchor_names( $rtoc, $src_basename, "$src_frame_name" );
1034     $fh->print( join EMPTY_STRING, @{$rtoc} );
1035
1036     $fh->print(<<EOM);
1037 </body>
1038 </html>
1039 EOM
1040
1041     return;
1042 }
1043
1044 sub write_frame_html {
1045
1046     # write an html file to be the table of contents frame
1047     my (
1048         $title,        $frame_filename, $top_basename,
1049         $toc_basename, $src_basename,   $src_frame_name
1050     ) = @_;
1051
1052     my $fh = IO::File->new( $frame_filename, 'w' )
1053       or Perl::Tidy::Die("Cannot open $toc_basename: $ERRNO\n");
1054
1055     $fh->print(<<EOM);
1056 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"
1057     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd">
1058 <?xml version="1.0" encoding="iso-8859-1" ?>
1059 <html xmlns="http://www.w3.org/1999/xhtml">
1060 <head>
1061 <title>$title</title>
1062 </head>
1063 EOM
1064
1065     # two left panels, one right, if master index file
1066     if ($top_basename) {
1067         $fh->print(<<EOM);
1068 <frameset cols="20%,80%">
1069 <frameset rows="30%,70%">
1070 <frame src = "$top_basename" />
1071 <frame src = "$toc_basename" />
1072 </frameset>
1073 EOM
1074     }
1075
1076     # one left panels, one right, if no master index file
1077     else {
1078         $fh->print(<<EOM);
1079 <frameset cols="20%,*">
1080 <frame src = "$toc_basename" />
1081 EOM
1082     }
1083     $fh->print(<<EOM);
1084 <frame src = "$src_basename" name = "$src_frame_name" />
1085 <noframes>
1086 <body>
1087 <p>If you see this message, you are using a non-frame-capable web client.</p>
1088 <p>This document contains:</p>
1089 <ul>
1090 <li><a href="$toc_basename">A table of contents</a></li>
1091 <li><a href="$src_basename">The source code</a></li>
1092 </ul>
1093 </body>
1094 </noframes>
1095 </frameset>
1096 </html>
1097 EOM
1098     return;
1099 }
1100
1101 sub change_anchor_names {
1102
1103     # add a filename and target to anchors
1104     # also return the first anchor
1105     my ( $rlines, $filename, $target ) = @_;
1106     my $first_anchor;
1107     foreach my $line ( @{$rlines} ) {
1108
1109         #  We're looking for lines like this:
1110         #  <LI><A HREF="#synopsis">SYNOPSIS</A></LI>
1111         #  ----  -       --------  -----------------
1112         #  $1              $4            $5
1113         if ( $line =~ /^(.*)<a(.*)href\s*=\s*"([^#]*)#([^"]+)"[^>]*>(.*)$/i ) {
1114             my $pre  = $1;
1115             my $name = $4;
1116             my $post = $5;
1117             my $href = "$filename#$name";
1118             $line = "$pre<a href=\"$href\" target=\"$target\">$post\n";
1119             unless ($first_anchor) { $first_anchor = $href }
1120         }
1121     }
1122     return $first_anchor;
1123 }
1124
1125 sub close_html_file {
1126     my $self = shift;
1127     return unless $self->{_html_file_opened};
1128
1129     my $html_fh     = $self->{_html_fh};
1130     my $rtoc_string = $self->{_rtoc_string};
1131
1132     # There are 3 basic paths to html output...
1133
1134     # ---------------------------------
1135     # Path 1: finish up if in -pre mode
1136     # ---------------------------------
1137     if ( $rOpts->{'html-pre-only'} ) {
1138         $html_fh->print( <<"PRE_END");
1139 </pre>
1140 PRE_END
1141         close_object($html_fh);
1142         return;
1143     }
1144
1145     # Finish the index
1146     $self->add_toc_item( 'EOF', 'EOF' );
1147
1148     my $rpre_string_stack = $self->{_rpre_string_stack};
1149
1150     # Patch to darken the <pre> background color in case of pod2html and
1151     # interleaved code/documentation.  Otherwise, the distinction
1152     # between code and documentation is blurred.
1153     if (   $rOpts->{pod2html}
1154         && $self->{_pod_cut_count} >= 1
1155         && $rOpts->{'html-color-background'} eq '#FFFFFF' )
1156     {
1157         $rOpts->{'html-pre-color-background'} = '#F0F0F0';
1158     }
1159
1160     # put the css or its link into a string, if used
1161     my $css_string;
1162     my $fh_css = Perl::Tidy::IOScalar->new( \$css_string, 'w' );
1163
1164     # use css linked to another file
1165     if ( $rOpts->{'html-linked-style-sheet'} ) {
1166         $fh_css->print(
1167             qq(<link rel="stylesheet" href="$css_linkname" type="text/css" />));
1168     }
1169
1170     # use css embedded in this file
1171     elsif ( !$rOpts->{'nohtml-style-sheets'} ) {
1172         $fh_css->print( <<'ENDCSS');
1173 <style type="text/css">
1174 <!--
1175 ENDCSS
1176         write_style_sheet_data($fh_css);
1177         $fh_css->print( <<"ENDCSS");
1178 -->
1179 </style>
1180 ENDCSS
1181     }
1182
1183     # -----------------------------------------------------------
1184     # path 2: use pod2html if requested
1185     #         If we fail for some reason, continue on to path 3
1186     # -----------------------------------------------------------
1187     if ( $rOpts->{'pod2html'} ) {
1188         my $rpod_string = $self->{_rpod_string};
1189         $self->pod_to_html(
1190             ${$rpod_string}, $css_string,
1191             ${$rtoc_string}, $rpre_string_stack
1192         ) && return;
1193     }
1194
1195     # --------------------------------------------------
1196     # path 3: write code in html, with pod only in italics
1197     # --------------------------------------------------
1198     my $input_file = $self->{_input_file};
1199     my $title      = escape_html($input_file);
1200     my $timestamp  = EMPTY_STRING;
1201     if ( $rOpts->{'timestamp'} ) {
1202         my $date = localtime;
1203         $timestamp = "on $date";
1204     }
1205     $html_fh->print( <<"HTML_START");
1206 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1207    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1208 <!-- Generated by perltidy $timestamp -->
1209 <html xmlns="http://www.w3.org/1999/xhtml">
1210 <head>
1211 <title>$title</title>
1212 HTML_START
1213
1214     # output the css, if used
1215     if ($css_string) {
1216         $html_fh->print($css_string);
1217         $html_fh->print( <<"ENDCSS");
1218 </head>
1219 <body>
1220 ENDCSS
1221     }
1222     else {
1223
1224         $html_fh->print( <<"HTML_START");
1225 </head>
1226 <body bgcolor=\"$rOpts->{'html-color-background'}\" text=\"$rOpts->{'html-color-punctuation'}\">
1227 HTML_START
1228     }
1229
1230     $html_fh->print("<a name=\"-top-\"></a>\n");
1231     $html_fh->print( <<"EOM");
1232 <h1>$title</h1>
1233 EOM
1234
1235     # copy the table of contents
1236     if (   ${$rtoc_string}
1237         && !$rOpts->{'frames'}
1238         && $rOpts->{'html-table-of-contents'} )
1239     {
1240         $html_fh->print( ${$rtoc_string} );
1241     }
1242
1243     # copy the pre section(s)
1244     my $fname_comment = $input_file;
1245     $fname_comment =~ s/--+/-/g;    # protect HTML comment tags
1246     $html_fh->print( <<"END_PRE");
1247 <hr />
1248 <!-- contents of filename: $fname_comment -->
1249 <pre>
1250 END_PRE
1251
1252     foreach my $rpre_string ( @{$rpre_string_stack} ) {
1253         $html_fh->print( ${$rpre_string} );
1254     }
1255
1256     # and finish the html page
1257     $html_fh->print( <<"HTML_END");
1258 </pre>
1259 </body>
1260 </html>
1261 HTML_END
1262     close_object($html_fh);
1263
1264     if ( $rOpts->{'frames'} ) {
1265         ##my @toc = map { $_ .= "\n" } split /\n/, ${$rtoc_string};
1266         my @toc = map { $_ . "\n" } split /\n/, ${$rtoc_string};
1267         $self->make_frame( \@toc );
1268     }
1269     return;
1270 }
1271
1272 sub markup_tokens {
1273     my ( $self, $rtokens, $rtoken_type, $rlevels ) = @_;
1274     my ( @colored_tokens, $type, $token, $level );
1275     my $rlast_level    = $self->{_rlast_level};
1276     my $rpackage_stack = $self->{_rpackage_stack};
1277
1278     foreach my $j ( 0 .. @{$rtoken_type} - 1 ) {
1279         $type  = $rtoken_type->[$j];
1280         $token = $rtokens->[$j];
1281         $level = $rlevels->[$j];
1282         $level = 0 if ( $level < 0 );
1283
1284         #-------------------------------------------------------
1285         # Update the package stack.  The package stack is needed to keep
1286         # the toc correct because some packages may be declared within
1287         # blocks and go out of scope when we leave the block.
1288         #-------------------------------------------------------
1289         if ( $level > ${$rlast_level} ) {
1290             unless ( $rpackage_stack->[ $level - 1 ] ) {
1291                 $rpackage_stack->[ $level - 1 ] = 'main';
1292             }
1293             $rpackage_stack->[$level] = $rpackage_stack->[ $level - 1 ];
1294         }
1295         elsif ( $level < ${$rlast_level} ) {
1296             my $package = $rpackage_stack->[$level];
1297             unless ($package) { $package = 'main' }
1298
1299             # if we change packages due to a nesting change, we
1300             # have to make an entry in the toc
1301             if ( $package ne $rpackage_stack->[ $level + 1 ] ) {
1302                 $self->add_toc_item( $package, 'package' );
1303             }
1304         }
1305         ${$rlast_level} = $level;
1306
1307         #-------------------------------------------------------
1308         # Intercept a sub name here; split it
1309         # into keyword 'sub' and sub name; and add an
1310         # entry in the toc
1311         #-------------------------------------------------------
1312         if ( $type eq 'i' && $token =~ /^(sub\s+)(\w.*)$/ ) {
1313             $token = $self->markup_html_element( $1, 'k' );
1314             push @colored_tokens, $token;
1315             $token = $2;
1316             $type  = 'M';
1317
1318             # but don't include sub declarations in the toc;
1319             # these will have leading token types 'i;'
1320             my $signature = join EMPTY_STRING, @{$rtoken_type};
1321             unless ( $signature =~ /^i;/ ) {
1322                 my $subname = $token;
1323                 $subname =~ s/[\s\(].*$//; # remove any attributes and prototype
1324                 $self->add_toc_item( $subname, 'sub' );
1325             }
1326         }
1327
1328         #-------------------------------------------------------
1329         # Intercept a package name here; split it
1330         # into keyword 'package' and name; add to the toc,
1331         # and update the package stack
1332         #-------------------------------------------------------
1333         if ( $type eq 'i' && $token =~ /^(package\s+)(\w.*)$/ ) {
1334             $token = $self->markup_html_element( $1, 'k' );
1335             push @colored_tokens, $token;
1336             $token = $2;
1337             $type  = 'i';
1338             $self->add_toc_item( "$token", 'package' );
1339             $rpackage_stack->[$level] = $token;
1340         }
1341
1342         $token = $self->markup_html_element( $token, $type );
1343         push @colored_tokens, $token;
1344     }
1345     return ( \@colored_tokens );
1346 }
1347
1348 sub markup_html_element {
1349     my ( $self, $token, $type ) = @_;
1350
1351     return $token if ( $type eq 'b' );         # skip a blank token
1352     return $token if ( $token =~ /^\s*$/ );    # skip a blank line
1353     $token = escape_html($token);
1354
1355     # get the short abbreviation for this token type
1356     my $short_name = $token_short_names{$type};
1357     if ( !defined($short_name) ) {
1358         $short_name = "pu";                    # punctuation is default
1359     }
1360
1361     # handle style sheets..
1362     if ( !$rOpts->{'nohtml-style-sheets'} ) {
1363         if ( $short_name ne 'pu' ) {
1364             $token = qq(<span class="$short_name">) . $token . "</span>";
1365         }
1366     }
1367
1368     # handle no style sheets..
1369     else {
1370         my $color = $html_color{$short_name};
1371
1372         if ( $color && ( $color ne $rOpts->{'html-color-punctuation'} ) ) {
1373             $token = qq(<font color="$color">) . $token . "</font>";
1374         }
1375         if ( $html_italic{$short_name} ) { $token = "<i>$token</i>" }
1376         if ( $html_bold{$short_name} )   { $token = "<b>$token</b>" }
1377     }
1378     return $token;
1379 }
1380
1381 sub escape_html {
1382
1383     my $token = shift;
1384     if ($missing_html_entities) {
1385         $token =~ s/\&/&amp;/g;
1386         $token =~ s/\</&lt;/g;
1387         $token =~ s/\>/&gt;/g;
1388         $token =~ s/\"/&quot;/g;
1389     }
1390     else {
1391         HTML::Entities::encode_entities($token);
1392     }
1393     return $token;
1394 }
1395
1396 sub finish_formatting {
1397
1398     # called after last line
1399     my $self = shift;
1400     $self->close_html_file();
1401     return;
1402 }
1403
1404 sub write_line {
1405
1406     my ( $self, $line_of_tokens ) = @_;
1407     return unless $self->{_html_file_opened};
1408     my $html_pre_fh = $self->{_html_pre_fh};
1409     my $line_type   = $line_of_tokens->{_line_type};
1410     my $input_line  = $line_of_tokens->{_line_text};
1411     my $line_number = $line_of_tokens->{_line_number};
1412     chomp $input_line;
1413
1414     # markup line of code..
1415     my $html_line;
1416     if ( $line_type eq 'CODE' ) {
1417         my $rtoken_type = $line_of_tokens->{_rtoken_type};
1418         my $rtokens     = $line_of_tokens->{_rtokens};
1419         my $rlevels     = $line_of_tokens->{_rlevels};
1420
1421         if ( $input_line =~ /(^\s*)/ ) {
1422             $html_line = $1;
1423         }
1424         else {
1425             $html_line = EMPTY_STRING;
1426         }
1427         my ($rcolored_tokens) =
1428           $self->markup_tokens( $rtokens, $rtoken_type, $rlevels );
1429         $html_line .= join EMPTY_STRING, @{$rcolored_tokens};
1430     }
1431
1432     # markup line of non-code..
1433     else {
1434         my $line_character;
1435         if    ( $line_type eq 'HERE' )       { $line_character = 'H' }
1436         elsif ( $line_type eq 'HERE_END' )   { $line_character = 'h' }
1437         elsif ( $line_type eq 'FORMAT' )     { $line_character = 'H' }
1438         elsif ( $line_type eq 'FORMAT_END' ) { $line_character = 'h' }
1439         elsif ( $line_type eq 'SKIP' )       { $line_character = 'H' }
1440         elsif ( $line_type eq 'SKIP_END' )   { $line_character = 'h' }
1441         elsif ( $line_type eq 'SYSTEM' )     { $line_character = 'c' }
1442         elsif ( $line_type eq 'END_START' ) {
1443             $line_character = 'k';
1444             $self->add_toc_item( '__END__', '__END__' );
1445         }
1446         elsif ( $line_type eq 'DATA_START' ) {
1447             $line_character = 'k';
1448             $self->add_toc_item( '__DATA__', '__DATA__' );
1449         }
1450         elsif ( $line_type =~ /^POD/ ) {
1451             $line_character = 'P';
1452             if ( $rOpts->{'pod2html'} ) {
1453                 my $html_pod_fh = $self->{_html_pod_fh};
1454                 if ( $line_type eq 'POD_START' ) {
1455
1456                     my $rpre_string_stack = $self->{_rpre_string_stack};
1457                     my $rpre_string       = $rpre_string_stack->[-1];
1458
1459                     # if we have written any non-blank lines to the
1460                     # current pre section, start writing to a new output
1461                     # string
1462                     if ( ${$rpre_string} =~ /\S/ ) {
1463                         my $pre_string;
1464                         $html_pre_fh =
1465                           Perl::Tidy::IOScalar->new( \$pre_string, 'w' );
1466                         $self->{_html_pre_fh} = $html_pre_fh;
1467                         push @{$rpre_string_stack}, \$pre_string;
1468
1469                         # leave a marker in the pod stream so we know
1470                         # where to put the pre section we just
1471                         # finished.
1472                         my $for_html = '=for html';    # don't confuse pod utils
1473                         $html_pod_fh->print(<<EOM);
1474
1475 $for_html
1476 <!-- pERLTIDY sECTION -->
1477
1478 EOM
1479                     }
1480
1481                     # otherwise, just clear the current string and start
1482                     # over
1483                     else {
1484                         ${$rpre_string} = EMPTY_STRING;
1485                         $html_pod_fh->print("\n");
1486                     }
1487                 }
1488                 $html_pod_fh->print( $input_line . "\n" );
1489                 if ( $line_type eq 'POD_END' ) {
1490                     $self->{_pod_cut_count}++;
1491                     $html_pod_fh->print("\n");
1492                 }
1493                 return;
1494             }
1495         }
1496         else { $line_character = 'Q' }
1497         $html_line = $self->markup_html_element( $input_line, $line_character );
1498     }
1499
1500     # add the line number if requested
1501     if ( $rOpts->{'html-line-numbers'} ) {
1502         my $extra_space =
1503             ( $line_number < 10 )   ? SPACE x 3
1504           : ( $line_number < 100 )  ? SPACE x 2
1505           : ( $line_number < 1000 ) ? SPACE
1506           :                           EMPTY_STRING;
1507         $html_line = $extra_space . $line_number . SPACE . $html_line;
1508     }
1509
1510     # write the line
1511     $html_pre_fh->print("$html_line\n");
1512     return;
1513 }
1514 1;