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