1 #####################################################################
3 # The Perl::Tidy::HtmlWriter class writes a copy of the input stream in html
5 #####################################################################
7 package Perl::Tidy::HtmlWriter;
10 our $VERSION = '20230309';
12 use English qw( -no_match_vars );
15 use constant EMPTY_STRING => q{};
16 use constant SPACE => q{ };
28 $missing_html_entities
32 # replace unsafe characters with HTML entity representation if HTML::Entities
34 #{ eval "use HTML::Entities"; $missing_html_entities = $@; }
37 if ( !eval { require HTML::Entities; 1 } ) {
38 $missing_html_entities = $EVAL_ERROR ? $EVAL_ERROR : 1;
40 if ( !eval { require Pod::Html; 1 } ) {
41 $missing_pod_html = $EVAL_ERROR ? $EVAL_ERROR : 1;
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.
51 return if ( $AUTOLOAD =~ /\bDESTROY$/ );
52 my ( $pkg, $fname, $lno ) = caller();
53 my $my_package = __PACKAGE__;
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 ======================================================================
68 # required to avoid call to AUTOLOAD in some versions of perl
73 my ( $class, @args ) = @_;
79 html_toc_extension => undef,
80 html_src_extension => undef,
82 my %args = ( %defaults, @args );
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};
90 my $html_file_opened = 0;
92 ( $html_fh, my $html_filename ) =
93 Perl::Tidy::streamhandle( $html_file, 'w' );
95 Perl::Tidy::Warn("can't open $html_file: $ERRNO\n");
98 $html_file_opened = 1;
100 if ( !$input_file || $input_file eq '-' || ref($input_file) ) {
101 $input_file = "NONAME";
104 # write the table of contents to a string
106 my $html_toc_fh = Perl::Tidy::IOScalar->new( \$toc_string, 'w' );
109 my @pre_string_stack;
110 if ( $rOpts->{'html-pre-only'} ) {
112 # pre section goes directly to the output stream
113 $html_pre_fh = $html_fh;
114 $html_pre_fh->print( <<"PRE_END");
120 # pre section go out to a temporary string
122 $html_pre_fh = Perl::Tidy::IOScalar->new( \$pre_string, 'w' );
123 push @pre_string_stack, \$pre_string;
126 # pod text gets diverted if the 'pod2html' is used
129 if ( $rOpts->{'pod2html'} ) {
130 if ( $rOpts->{'html-pre-only'} ) {
131 undef $rOpts->{'pod2html'};
134 ##eval "use Pod::Html";
136 if ($missing_pod_html) {
138 "unable to find Pod::Html; cannot use pod2html\n-npod disables this message\n"
140 undef $rOpts->{'pod2html'};
143 $html_pod_fh = Perl::Tidy::IOScalar->new( \$pod_string, 'w' );
150 if ( $rOpts->{'frames'} ) {
151 unless ($extension) {
153 "cannot use frames without a specified output extension; ignoring -frm\n"
155 undef $rOpts->{'frames'};
158 $toc_filename = $input_file . $html_toc_extension . $extension;
159 $src_filename = $input_file . $html_src_extension . $extension;
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 # ----------------------------------------------------------
170 my $title = $rOpts->{'title'};
172 ( $title, my $path ) = fileparse($input_file);
174 my $toc_item_count = 0;
175 my $in_toc_package = EMPTY_STRING;
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
197 _rlast_level => \$last_level, # brace indentation level
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 } ## end sub close_object
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};
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;
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>
243 ${$rin_toc_package} = $package;
247 # start the table of contents on the first item
248 unless ( ${$rtoc_item_count} ) {
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>
258 ${$rtoc_item_count}++;
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" }
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";
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 .= '-' }
276 # start/stop lists of subs
277 if ( $type eq 'sub' ) {
278 my $package = $rpackage_stack->[ ${$rlast_level} ];
279 unless ($package) { $package = 'main' }
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->();
287 # start a package/sub list if necessary
288 unless ( ${$rin_toc_package} ) {
289 $start_package_list->( $unique_name, $package );
293 # now write an entry in the toc for this item
294 if ( $type eq 'package' ) {
295 $start_package_list->( $unique_name, $name );
297 elsif ( $type eq 'sub' ) {
298 $html_toc_fh->print("<li><a href=\"#$unique_name\">$name</a></li>\n");
301 $end_package_list->();
302 $html_toc_fh->print("<li><a href=\"#$unique_name\">$name</a></li>\n");
305 # write the anchor in the <pre> section
306 $html_pre_fh->print("<a name=\"$unique_name\"></a>");
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");
312 <!-- END CODE INDEX -->
316 } ## end sub add_toc_item
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
328 # When adding NEW_TOKENS: update this hash table
329 # short names => long names
330 %short_to_long_names = (
340 'pu' => 'punctuation',
343 'h' => 'here-doc-target',
344 'hh' => 'here-doc-text',
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'
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).
360 # When adding NEW_TOKENS: update this hash table
361 # $type => $short_name
362 %token_short_names = (
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);
391 # These token types will be called 'structure'
392 my @structure = qw< { } >;
393 @token_short_names{@structure} = ('s') x scalar(@structure);
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);
402 # / /= * *= ** **= + += - -= % %= = ++ -- << <<= >> >>= pp p m mm
404 # @token_long_names{@list} = ('math') x scalar(@list);
406 # my @list = qw" & &= ~ ~= ^ ^= | |= ";
407 # @token_long_names{@list} = ('bit') x scalar(@list);
409 # my @list = qw" == != < > <= <=> ";
410 # @token_long_names{@list} = ('numerical-comparison') x scalar(@list);
412 # my @list = qw" && || ! &&= ||= //= ";
413 # @token_long_names{@list} = ('logical') x scalar(@list);
415 # my @list = qw" . .= =~ !~ x x= ";
416 # @token_long_names{@list} = ('string-operators') x scalar(@list);
419 # my @list = qw" .. -> <> ... \ ? ";
420 # @token_long_names{@list} = ('misc-operators') x scalar(@list);
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!";
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";
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";
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!";
462 } ## end sub make_getopt_long_names
464 sub make_abbreviated_names {
466 # We're appending things like this to the expansion list:
467 # 'hcc' => [qw(html-color-comment)],
468 # 'hck' => [qw(html-color-keyword)],
470 my ( $class, $rexpansion ) = @_;
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"];
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"];
499 } ## end sub make_abbreviated_names
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 ) = @_;
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";
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
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 );
539 set_default_color( 'html-color-background', white );
540 set_default_color( 'html-color-punctuation', black );
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"};
551 # write style sheet to STDOUT and die if requested
552 if ( defined( $rOpts->{'stylesheet'} ) ) {
553 write_style_sheet_file('-');
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");
566 if ( $css_linkname && $rOpts->{'nohtml-style-sheets'} ) {
567 $rOpts->{'nohtml-style-sheets'} = 0;
569 "You can't specify both -css and -nss; -nss ignored\n");
572 # write a style sheet file if necessary
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);
586 $missing_html_entities = 1 unless $rOpts->{'html-entities'};
588 } ## end sub check_options
590 sub write_style_sheet_file {
592 my $css_filename = shift;
594 unless ( $fh = IO::File->new("> $css_filename") ) {
595 Perl::Tidy::Die("can't open $css_filename: $ERRNO\n");
597 write_style_sheet_data($fh);
600 } ## end sub write_style_sheet_file
602 sub write_style_sheet_data {
604 # write the style sheet data to an open file handle
607 my $bg_color = $rOpts->{'html-color-background'};
608 my $text_color = $rOpts->{'html-color-punctuation'};
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;
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;
624 foreach my $short_name ( sort keys %short_to_long_names ) {
625 my $long_name = $short_to_long_names{$short_name};
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;");
633 if ( $html_bold{$short_name} ) {
634 $fh->print(" font-weight:bold;");
637 if ( $html_italic{$short_name} ) {
638 $fh->print(" font-style:italic;");
640 $fh->print("} /* $long_name */\n");
643 } ## end sub write_style_sheet_data
645 sub set_default_color {
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);
652 } ## end sub set_default_color
656 # if color is a 6 digit hex RGB value, prepend a #, otherwise
657 # assume that it is a valid ascii color name
659 if ( $color =~ /^[0-9a-fA-F]{6,6}$/ ) { $color = "#$color" }
661 } ## end sub check_RGB
663 sub set_default_properties {
664 my ( $short_name, $color, $bold, $italic ) = @_;
666 set_default_color( "html-color-$short_to_long_names{$short_name}", $color );
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;
673 } ## end sub set_default_properties
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 ) =
682 my $input_file = $self->{_input_file};
683 my $title = $self->{_title};
684 my $success_flag = 0;
686 # don't try to use pod2html if no pod
687 unless ($pod_string) {
688 return $success_flag;
691 # Pod::Html requires a real temporary filename
692 my ( $fh_tmp, $tmpfile ) = File::Temp::tempfile();
695 "unable to open temporary file $tmpfile; cannot use pod2html\n");
696 return $success_flag;
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 #------------------------------------------------------------------
705 # write the pod text to the temporary file
706 $fh_tmp->print($pod_string);
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.
715 push @args, "--infile=$tmpfile", "--outfile=$tmpfile", "--title=$title";
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))
723 if ( $rOpts->{$kw} ) { push @args, "--$kw=$rOpts->{$kw}" }
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} ) ) {
733 push @args, "--no$kwd";
739 if ( $rOpts->{$kw} ) { $kw =~ s/^pod//; push @args, "--$kw" }
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] );
748 Pod::Html::pod2html(@args);
750 $fh_tmp = IO::File->new( $tmpfile, 'r' );
753 # this error shouldn't happen ... we just used this filename
755 "unable to open temporary file $tmpfile; cannot use pod2html\n");
756 return $success_flag;
759 my $html_fh = $self->{_html_fh};
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 }
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 );
778 my $timestamp = EMPTY_STRING;
779 if ( $rOpts->{'timestamp'} ) {
780 my $date = localtime;
781 $timestamp = "on $date";
783 while ( my $line = $fh_tmp->getline() ) {
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);
792 # Copy the perltidy css, if any, after <body> tag
793 elsif ( $line =~ /^\s*<body.*>\s*$/i ) {
795 $html_print->($css_string) if $css_string;
796 $html_print->($line);
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");
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 -->
812 elsif ( $line =~ /^\s*<!-- INDEX BEGIN -->\s*$/i ) {
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);
823 # check for start of index, new pod2html
824 # After Pod::Html VERSION 1.15_02 it is delimited as:
828 elsif ( $line =~ /^\s*<ul\s+id="index">/i ) {
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);
840 # Check for end of index, old pod2html
841 elsif ( $line =~ /^\s*<!-- INDEX END -->\s*$/i ) {
843 $html_print->($line);
845 # Copy the perltidy toc, if any, after the Pod::Html toc
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);
853 $in_toc = EMPTY_STRING;
857 # must track <ul> depth level for new pod2html
858 elsif ( $line =~ /\s*<ul>\s*$/i && $in_toc eq 'UL' ) {
860 $html_print->($line);
863 # Check for end of index, for new pod2html
864 elsif ( $line =~ /\s*<\/ul>/i && $in_toc eq 'UL' ) {
866 $html_print->($line);
868 # Copy the perltidy toc, if any, after the Pod::Html toc
869 if ( $ul_level <= 0 ) {
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);
878 $in_toc = EMPTY_STRING;
884 # Copy one perltidy section after each marker
885 elsif ( $line =~ /^(.*)<!-- pERLTIDY sECTION -->(.*)$/ ) {
887 $html_print->($1) if $1;
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>');
899 # shouldn't happen: we stored a string before writing
902 "Problem merging html stream with pod2html; order may be wrong\n"
905 $html_print->($line);
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.
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 );
918 # Copy any remaining code section before the </body> tag
919 elsif ( $line =~ /^\s*<\/body>\s*$/i ) {
921 if ( @{$rpre_string_stack} ) {
922 unless ( $self->{_pod_cut_count} > 1 ) {
923 $html_print->('<hr />');
925 while ( my $rpre_string = shift( @{$rpre_string_stack} ) ) {
926 $html_print->('<pre>');
927 $html_print->( ${$rpre_string} );
928 $html_print->('</pre>');
931 $html_print->($line);
934 $html_print->($line);
940 Perl::Tidy::Warn("Did not see <body> in pod2html output\n");
943 unless ($saw_body_end) {
944 Perl::Tidy::Warn("Did not see </body> in pod2html output\n");
947 unless ($saw_index) {
948 Perl::Tidy::Warn("Did not find INDEX END in pod2html output\n");
952 close_object($html_fh);
954 # note that we have to unlink tmpfile before making frames
955 # because the tmpfile may be one of the names used for frames
957 unless ( unlink($tmpfile) ) {
959 "couldn't unlink temporary file $tmpfile: $ERRNO\n");
964 if ( $success_flag && $rOpts->{'frames'} ) {
965 $self->make_frame( \@toc );
967 return $success_flag;
968 } ## end sub pod_to_html
972 # Make a frame with table of contents in the left panel
973 # and the text in the right panel.
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);
985 # FUTURE input parameter:
986 my $top_basename = EMPTY_STRING;
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
993 # get basenames for relative links
994 my ( $toc_basename, $toc_path ) = fileparse($toc_filename);
995 my ( $src_basename, $src_path ) = fileparse($src_filename);
997 # 1. Make the table of contents panel, with appropriate changes
998 # to the anchor names
999 my $src_frame_name = 'SRC';
1001 write_toc_html( $title, $toc_filename, $src_basename, $rtoc,
1004 # 2. The current .html filename is renamed to be the contents panel
1005 rename( $html_filename, $src_filename )
1007 "Cannot rename $html_filename to $src_filename: $ERRNO\n");
1009 # 3. Then use the original html filename for the frame
1011 $title, $html_filename, $top_basename,
1012 $toc_basename, $src_basename, $src_frame_name
1015 } ## end sub make_frame
1017 sub write_toc_html {
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");
1026 <title>$title</title>
1029 <h1><a href=\"$src_basename#-top-" target="$src_frame_name">$title</a></h1>
1033 change_anchor_names( $rtoc, $src_basename, "$src_frame_name" );
1034 $fh->print( join EMPTY_STRING, @{$rtoc} );
1042 } ## end sub write_toc_html
1044 sub write_frame_html {
1046 # write an html file to be the table of contents frame
1048 $title, $frame_filename, $top_basename,
1049 $toc_basename, $src_basename, $src_frame_name
1052 my $fh = IO::File->new( $frame_filename, 'w' )
1053 or Perl::Tidy::Die("Cannot open $toc_basename: $ERRNO\n");
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">
1061 <title>$title</title>
1065 # two left panels, one right, if master index file
1066 if ($top_basename) {
1068 <frameset cols="20%,80%">
1069 <frameset rows="30%,70%">
1070 <frame src = "$top_basename" />
1071 <frame src = "$toc_basename" />
1076 # one left panels, one right, if no master index file
1079 <frameset cols="20%,*">
1080 <frame src = "$toc_basename" />
1084 <frame src = "$src_basename" name = "$src_frame_name" />
1087 <p>If you see this message, you are using a non-frame-capable web client.</p>
1088 <p>This document contains:</p>
1090 <li><a href="$toc_basename">A table of contents</a></li>
1091 <li><a href="$src_basename">The source code</a></li>
1099 } ## end sub write_frame_html
1101 sub change_anchor_names {
1103 # add a filename and target to anchors
1104 # also return the first anchor
1105 my ( $rlines, $filename, $target ) = @_;
1107 foreach my $line ( @{$rlines} ) {
1109 # We're looking for lines like this:
1110 # <LI><A HREF="#synopsis">SYNOPSIS</A></LI>
1111 # ---- - -------- -----------------
1113 if ( $line =~ /^(.*)<a(.*)href\s*=\s*"([^#]*)#([^"]+)"[^>]*>(.*)$/i ) {
1117 my $href = "$filename#$name";
1118 $line = "$pre<a href=\"$href\" target=\"$target\">$post\n";
1119 unless ($first_anchor) { $first_anchor = $href }
1122 return $first_anchor;
1123 } ## end sub change_anchor_names
1125 sub close_html_file {
1127 return unless $self->{_html_file_opened};
1129 my $html_fh = $self->{_html_fh};
1130 my $rtoc_string = $self->{_rtoc_string};
1132 # There are 3 basic paths to html output...
1134 # ---------------------------------
1135 # Path 1: finish up if in -pre mode
1136 # ---------------------------------
1137 if ( $rOpts->{'html-pre-only'} ) {
1138 $html_fh->print( <<"PRE_END");
1141 close_object($html_fh);
1146 $self->add_toc_item( 'EOF', 'EOF' );
1148 my $rpre_string_stack = $self->{_rpre_string_stack};
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' )
1157 $rOpts->{'html-pre-color-background'} = '#F0F0F0';
1160 # put the css or its link into a string, if used
1162 my $fh_css = Perl::Tidy::IOScalar->new( \$css_string, 'w' );
1164 # use css linked to another file
1165 if ( $rOpts->{'html-linked-style-sheet'} ) {
1167 qq(<link rel="stylesheet" href="$css_linkname" type="text/css" />));
1170 # use css embedded in this file
1171 elsif ( !$rOpts->{'nohtml-style-sheets'} ) {
1172 $fh_css->print( <<'ENDCSS');
1173 <style type="text/css">
1176 write_style_sheet_data($fh_css);
1177 $fh_css->print( <<"ENDCSS");
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};
1190 ${$rpod_string}, $css_string,
1191 ${$rtoc_string}, $rpre_string_stack
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";
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">
1211 <title>$title</title>
1214 # output the css, if used
1216 $html_fh->print($css_string);
1217 $html_fh->print( <<"ENDCSS");
1224 $html_fh->print( <<"HTML_START");
1226 <body bgcolor=\"$rOpts->{'html-color-background'}\" text=\"$rOpts->{'html-color-punctuation'}\">
1230 $html_fh->print("<a name=\"-top-\"></a>\n");
1231 $html_fh->print( <<"EOM");
1235 # copy the table of contents
1236 if ( ${$rtoc_string}
1237 && !$rOpts->{'frames'}
1238 && $rOpts->{'html-table-of-contents'} )
1240 $html_fh->print( ${$rtoc_string} );
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");
1248 <!-- contents of filename: $fname_comment -->
1252 foreach my $rpre_string ( @{$rpre_string_stack} ) {
1253 $html_fh->print( ${$rpre_string} );
1256 # and finish the html page
1257 $html_fh->print( <<"HTML_END");
1262 close_object($html_fh);
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 );
1270 } ## end sub close_html_file
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};
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 );
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';
1293 $rpackage_stack->[$level] = $rpackage_stack->[ $level - 1 ];
1295 elsif ( $level < ${$rlast_level} ) {
1296 my $package = $rpackage_stack->[$level];
1297 unless ($package) { $package = 'main' }
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' );
1305 ${$rlast_level} = $level;
1307 #-------------------------------------------------------
1308 # Intercept a sub name here; split it
1309 # into keyword 'sub' and sub name; and add an
1311 #-------------------------------------------------------
1312 if ( $type eq 'i' && $token =~ /^(sub\s+)(\w.*)$/ ) {
1313 $token = $self->markup_html_element( $1, 'k' );
1314 push @colored_tokens, $token;
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' );
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;
1338 $self->add_toc_item( "$token", 'package' );
1339 $rpackage_stack->[$level] = $token;
1342 $token = $self->markup_html_element( $token, $type );
1343 push @colored_tokens, $token;
1345 return ( \@colored_tokens );
1346 } ## end sub markup_tokens
1348 sub markup_html_element {
1349 my ( $self, $token, $type ) = @_;
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);
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
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>";
1368 # handle no style sheets..
1370 my $color = $html_color{$short_name};
1372 if ( $color && ( $color ne $rOpts->{'html-color-punctuation'} ) ) {
1373 $token = qq(<font color="$color">) . $token . "</font>";
1375 if ( $html_italic{$short_name} ) { $token = "<i>$token</i>" }
1376 if ( $html_bold{$short_name} ) { $token = "<b>$token</b>" }
1379 } ## end sub markup_html_element
1384 if ($missing_html_entities) {
1385 $token =~ s/\&/&/g;
1386 $token =~ s/\</</g;
1387 $token =~ s/\>/>/g;
1388 $token =~ s/\"/"/g;
1391 HTML::Entities::encode_entities($token);
1394 } ## end sub escape_html
1396 sub finish_formatting {
1398 # called after last line
1400 $self->close_html_file();
1402 } ## end sub finish_formatting
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};
1414 # markup line of code..
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};
1421 if ( $input_line =~ /(^\s*)/ ) {
1425 $html_line = EMPTY_STRING;
1427 my ($rcolored_tokens) =
1428 $self->markup_tokens( $rtokens, $rtoken_type, $rlevels );
1429 $html_line .= join EMPTY_STRING, @{$rcolored_tokens};
1432 # markup line of non-code..
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__' );
1446 elsif ( $line_type eq 'DATA_START' ) {
1447 $line_character = 'k';
1448 $self->add_toc_item( '__DATA__', '__DATA__' );
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' ) {
1456 my $rpre_string_stack = $self->{_rpre_string_stack};
1457 my $rpre_string = $rpre_string_stack->[-1];
1459 # if we have written any non-blank lines to the
1460 # current pre section, start writing to a new output
1462 if ( ${$rpre_string} =~ /\S/ ) {
1465 Perl::Tidy::IOScalar->new( \$pre_string, 'w' );
1466 $self->{_html_pre_fh} = $html_pre_fh;
1467 push @{$rpre_string_stack}, \$pre_string;
1469 # leave a marker in the pod stream so we know
1470 # where to put the pre section we just
1472 my $for_html = '=for html'; # don't confuse pod utils
1473 $html_pod_fh->print(<<EOM);
1476 <!-- pERLTIDY sECTION -->
1481 # otherwise, just clear the current string and start
1484 ${$rpre_string} = EMPTY_STRING;
1485 $html_pod_fh->print("\n");
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");
1496 else { $line_character = 'Q' }
1497 $html_line = $self->markup_html_element( $input_line, $line_character );
1500 # add the line number if requested
1501 if ( $rOpts->{'html-line-numbers'} ) {
1503 ( $line_number < 10 ) ? SPACE x 3
1504 : ( $line_number < 100 ) ? SPACE x 2
1505 : ( $line_number < 1000 ) ? SPACE
1507 $html_line = $extra_space . $line_number . SPACE . $html_line;
1511 $html_pre_fh->print("$html_line\n");
1513 } ## end sub write_line