re_title( qq[$Doctype_decl] ); $new->html_header_after_title( join "\n" => "", $Content_decl, "\n", $new->version_tag_comment, "\n", ); $new->html_footer( qq[\n\n\n\n] ); $new->{'Tagmap'} = {%Tagmap}; return $new; } sub __adjust_html_h_levels { my ($self) = @_; my $Tagmap = $self->{'Tagmap'}; my $add = $self->html_h_level; return unless defined $add; return if ($self->{'Adjusted_html_h_levels'}||0) == $add; $add -= 1; for (1 .. 4) { $Tagmap->{"head$_"} =~ s/$_/$_ + $add/e; $Tagmap->{"/head$_"} =~ s/$_/$_ + $add/e; } } sub batch_mode_page_object_init { my($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_; DEBUG and print "Initting $self\n for $module\n", " in $infile\n out $outfile\n depth $depth\n"; $self->batch_mode(1); $self->batch_mode_current_level($depth); return $self; } sub run { my $self = $_[0]; return $self->do_middle if $self->bare_output; return $self->do_beginning && $self->do_middle && $self->do_end; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub do_beginning { my $self = $_[0]; my $title; if(defined $self->force_title) { $title = $self->force_title; DEBUG and print "Forcing title to be $title\n"; } else { # Actually try looking for the title in the document: $title = $self->get_short_title(); unless($self->content_seen) { DEBUG and print "No content seen in search for title.\n"; return; } $self->{'Title'} = $title; if(defined $title and $title =~ m/\S/) { $title = $self->title_prefix . esc($title) . $self->title_postfix; } else { $title = $self->default_title; $title = '' unless defined $title; DEBUG and print "Title defaults to $title\n"; } } my $after = $self->html_header_after_title || ''; if($self->html_css) { my $link = $self->html_css =~ m/html_css # It's a big blob of markup, let's drop it in : sprintf( # It's just a URL, so let's wrap it up qq[\n], $self->html_css, ); $after =~ s{()}{$link\n$1}i; # otherwise nevermind } $self->_add_top_anchor(\$after); if($self->html_javascript) { my $link = $self->html_javascript =~ m/html_javascript # It's a big blob of markup, let's drop it in : sprintf( # It's just a URL, so let's wrap it up qq[\n], $self->html_javascript, ); $after =~ s{()}{$link\n$1}i; # otherwise nevermind } print {$self->{'output_fh'}} $self->html_header_before_title || '', $title, # already escaped $after, ; DEBUG and print "Returning from do_beginning...\n"; return 1; } sub _add_top_anchor { my($self, $text_r) = @_; unless($$text_r and $$text_r =~ m/name=['"]___top['"]/) { # a hack $$text_r .= "\n"; } return; } sub version_tag_comment { my $self = shift; return sprintf "\n", esc( ref($self), $self->VERSION(), $ISA[0], $ISA[0]->VERSION(), $], scalar(gmtime), ), $self->_modnote(), ; } sub _modnote { my $class = ref($_[0]) || $_[0]; return join "\n " => grep m/\S/, split "\n", qq{ If you want to change this HTML document, you probably shouldn't do that by changing it directly. Instead, see about changing the calling options to $class, and/or subclassing $class, then reconverting this document from the Pod source. When in doubt, email the author of $class for advice. See 'perldoc $class' for more info. }; } sub do_end { my $self = $_[0]; print {$self->{'output_fh'}} $self->html_footer || ''; return 1; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Normally this would just be a call to _do_middle_main_loop -- but we # have to do some elaborate things to emit all the content and then # summarize it and output it /before/ the content that it's a summary of. sub do_middle { my $self = $_[0]; return $self->_do_middle_main_loop unless $self->index; if( $self->output_string ) { # An efficiency hack my $out = $self->output_string; #it's a reference to it my $sneakytag = "\f\f\e\e\b\bIndex Here\e\e\b\b\f\f\n"; $$out .= $sneakytag; $self->_do_middle_main_loop; $sneakytag = quotemeta($sneakytag); my $index = $self->index_as_html(); if( $$out =~ s/$sneakytag/$index/s ) { # Expected case DEBUG and print "Inserted ", length($index), " bytes of index HTML into $out.\n"; } else { DEBUG and print "Odd, couldn't find where to insert the index in the output!\n"; # I don't think this should ever happen. } return 1; } unless( $self->output_fh ) { require Carp; Carp::confess("Parser object \$p doesn't seem to have any output object! I don't know how to deal with that."); } # If we get here, we're outputting to a FH. So we need to do some magic. # Namely, divert all content to a string, which we output after the index. my $fh = $self->output_fh; my $content = ''; { # Our horrible bait and switch: $self->output_string( \$content ); $self->_do_middle_main_loop; $self->abandon_output_string(); $self->output_fh($fh); } print $fh $self->index_as_html(); print $fh $content; return 1; } ########################################################################### sub index_as_html { my $self = $_[0]; # This is meant to be called AFTER the input document has been parsed! my $points = $self->{'PSHTML_index_points'} || []; @$points > 1 or return qq[
\n]; # There's no point in having a 0-item or 1-item index, I dare say. my(@out) = qq{\n
}; my $level = 0; my( $target_level, $previous_tagname, $tagname, $text, $anchorname, $indent); foreach my $p (@$points, ['head0', '(end)']) { ($tagname, $text) = @$p; $anchorname = $self->section_escape($text); if( $tagname =~ m{^head(\d+)$} ) { $target_level = 0 + $1; } else { # must be some kinda list item if($previous_tagname =~ m{^head\d+$} ) { $target_level = $level + 1; } else { $target_level = $level; # no change needed } } # Get to target_level by opening or closing ULs while($level > $target_level) { --$level; push @out, (" " x $level) . ""; } while($level < $target_level) { ++$level; push @out, (" " x ($level-1)) . "
\n"; return join "\n", @out; } ########################################################################### sub _do_middle_main_loop { my $self = $_[0]; my $fh = $self->{'output_fh'}; my $tagmap = $self->{'Tagmap'}; $self->__adjust_html_h_levels; my($token, $type, $tagname, $linkto, $linktype); my @stack; my $dont_wrap = 0; while($token = $self->get_token) { # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if( ($type = $token->type) eq 'start' ) { if(($tagname = $token->tagname) eq 'L') { $linktype = $token->attr('type') || 'insane'; $linkto = $self->do_link($token); if(defined $linkto and length $linkto) { esc($linkto); # (Yes, SGML-escaping applies on top of %-escaping! # But it's rarely noticeable in practice.) print $fh qq{}; } else { print $fh ""; # Yes, an 'a' element with no attributes! } } elsif ($tagname eq 'item-text' or $tagname =~ m/^head\d$/s) { print $fh $tagmap->{$tagname} || next; my @to_unget; while(1) { push @to_unget, $self->get_token; last if $to_unget[-1]->is_end and $to_unget[-1]->tagname eq $tagname; # TODO: support for X<...>'s found in here? (maybe hack into linearize_tokens) } my $name = $self->linearize_tokens(@to_unget); $name = $self->do_section($name, $token) if defined $name; print $fh "section_name_tidy( $name ) ); print $fh qq[name="$esc"]; DEBUG and print "Linearized ", scalar(@to_unget), " tokens as \"$name\".\n"; push @{ $self->{'PSHTML_index_points'} }, [$tagname, $name] if $ToIndex{ $tagname }; # Obviously, this discards all formatting codes (saving # just their content), but ahwell. } else { # ludicrously long, so nevermind DEBUG and print "Linearized ", scalar(@to_unget), " tokens, but it was too long, so nevermind.\n"; } print $fh "\n>"; $self->unget_token(@to_unget); } elsif ($tagname eq 'Data') { my $next = $self->get_token; next unless defined $next; unless( $next->type eq 'text' ) { $self->unget_token($next); next; } DEBUG and print " raw text ", $next->text, "\n"; print $fh "\n" . $next->text . "\n"; next; } else { if( $tagname =~ m/^over-/s ) { push @stack, ''; } elsif( $tagname =~ m/^item-/s and @stack and $stack[-1] ) { print $fh $stack[-1]; $stack[-1] = ''; } print $fh $tagmap->{$tagname} || next; ++$dont_wrap if $tagname eq 'Verbatim' or $tagname eq "VerbatimFormatted" or $tagname eq 'X'; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - } elsif( $type eq 'end' ) { if( ($tagname = $token->tagname) =~ m/^over-/s ) { if( my $end = pop @stack ) { print $fh $end; } } elsif( $tagname =~ m/^item-/s and @stack) { $stack[-1] = $tagmap->{"/$tagname"}; if( $tagname eq 'item-text' and defined(my $next = $self->get_token) ) { $self->unget_token($next); if( $next->type eq 'start' ) { print $fh $tagmap->{"/item-text"},$tagmap->{"item-body"}; $stack[-1] = $tagmap->{"/item-body"}; } } next; } print $fh $tagmap->{"/$tagname"} || next; --$dont_wrap if $tagname eq 'Verbatim' or $tagname eq 'X'; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - } elsif( $type eq 'text' ) { esc($type = $token->text); # reuse $type, why not $type =~ s/([\?\!\"\'\.\,]) /$1\n/g unless $dont_wrap; print $fh $type; } } return 1; } ########################################################################### # sub do_section { my($self, $name, $token) = @_; return $name; } sub do_link { my($self, $token) = @_; my $type = $token->attr('type'); if(!defined $type) { $self->whine("Typeless L!?", $token->attr('start_line')); } elsif( $type eq 'pod') { return $self->do_pod_link($token); } elsif( $type eq 'url') { return $self->do_url_link($token); } elsif( $type eq 'man') { return $self->do_man_link($token); } else { $self->whine("L of unknown type $type!?", $token->attr('start_line')); } return 'FNORG'; # should never get called } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sub do_url_link { return $_[1]->attr('to') } sub do_man_link { my ($self, $link) = @_; my $to = $link->attr('to'); my $frag = $link->attr('section'); return undef unless defined $to and length $to; # should never happen $frag = $self->section_escape($frag) if defined $frag and length($frag .= ''); # (stringify) DEBUG and print "Resolving \"$to/$frag\"\n\n"; return $self->resolve_man_page_link($to, $frag); } sub do_pod_link { # And now things get really messy... my($self, $link) = @_; my $to = $link->attr('to'); my $section = $link->attr('section'); return undef unless( # should never happen (defined $to and length $to) or (defined $section and length $section) ); $section = $self->section_escape($section) if defined $section and length($section .= ''); # (stringify) DEBUG and printf "Resolving \"%s\" \"%s\"...\n", $to || "(nil)", $section || "(nil)"; { # An early hack: my $complete_url = $self->resolve_pod_link_by_table($to, $section); if( $complete_url ) { DEBUG > 1 and print "resolve_pod_link_by_table(T,S) gives ", $complete_url, "\n (Returning that.)\n"; return $complete_url; } else { DEBUG > 4 and print " resolve_pod_link_by_table(T,S)", " didn't return anything interesting.\n"; } } if(defined $to and length $to) { # Give this routine first hack again my $there = $self->resolve_pod_link_by_table($to); if(defined $there and length $there) { DEBUG > 1 and print "resolve_pod_link_by_table(T) gives $there\n"; } else { $there = $self->resolve_pod_page_link($to, $section); # (I pass it the section value, but I don't see a # particular reason it'd use it.) DEBUG > 1 and print "resolve_pod_page_link gives ", $to || "(nil)", "\n"; unless( defined $there and length $there ) { DEBUG and print "Can't resolve $to\n"; return undef; } # resolve_pod_page_link returning undef is how it # can signal that it gives up on making a link } $to = $there; } #DEBUG and print "So far [", $to||'nil', "] [", $section||'nil', "]\n"; my $out = (defined $to and length $to) ? $to : ''; $out .= "#" . $section if defined $section and length $section; unless(length $out) { # sanity check DEBUG and printf "Oddly, couldn't resolve \"%s\" \"%s\"...\n", $to || "(nil)", $section || "(nil)"; return undef; } DEBUG and print "Resolved to $out\n"; return $out; } # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . sub section_escape { my($self, $section) = @_; return $self->section_url_escape( $self->section_name_tidy($section) ); } sub section_name_tidy { my($self, $section) = @_; $section =~ tr/ /_/; $section =~ tr/\x00-\x1F\x80-\x9F//d if 'A' eq chr(65); # drop crazy characters $section = $self->unicode_escape_url($section); $section = '_' unless length $section; return $section; } sub section_url_escape { shift->general_url_escape(@_) } sub pagepath_url_escape { shift->general_url_escape(@_) } sub manpage_url_escape { shift->general_url_escape(@_) } sub general_url_escape { my($self, $string) = @_; $string =~ s/([^\x00-\xFF])/join '', map sprintf('%%%02X',$_), unpack 'C*', $1/eg; # express Unicode things as urlencode(utf(orig)). # A pretty conservative escaping, behoovey even for query components # of a URL (see RFC 2396) $string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',ord($1))/eg; # Yes, stipulate the list without a range, so that this can work right on # all charsets that this module happens to run under. # Altho, hmm, what about that ord? Presumably that won't work right # under non-ASCII charsets. Something should be done # about that, I guess? return $string; } #-------------------------------------------------------------------------- # # Oh look, a yawning portal to Hell! Let's play touch football right by it! # sub resolve_pod_page_link { # resolve_pod_page_link must return a properly escaped URL my $self = shift; return $self->batch_mode() ? $self->resolve_pod_page_link_batch_mode(@_) : $self->resolve_pod_page_link_singleton_mode(@_) ; } sub resolve_pod_page_link_singleton_mode { my($self, $it) = @_; return undef unless defined $it and length $it; my $url = $self->pagepath_url_escape($it); $url =~ s{::$}{}s; # probably never comes up anyway $url =~ s{::}{/}g unless $self->perldoc_url_prefix =~ m/\?/s; # sane DWIM? return undef unless length $url; return $self->perldoc_url_prefix . $url . $self->perldoc_url_postfix; } sub resolve_pod_page_link_batch_mode { my($self, $to) = @_; DEBUG > 1 and print " During batch mode, resolving $to ...\n"; my @path = grep length($_), split m/::/s, $to, -1; unless( @path ) { # sanity DEBUG and print "Very odd! Splitting $to gives (nil)!\n"; return undef; } $self->batch_mode_rectify_path(\@path); my $out = join('/', map $self->pagepath_url_escape($_), @path) . $HTML_EXTENSION; DEBUG > 1 and print " => $out\n"; return $out; } sub batch_mode_rectify_path { my($self, $pathbits) = @_; my $level = $self->batch_mode_current_level; $level--; # how many levels up to go to get to the root if($level < 1) { unshift @$pathbits, '.'; # just to be pretty } else { unshift @$pathbits, ('..') x $level; } return; } sub resolve_man_page_link { my ($self, $to, $frag) = @_; my ($page, $section) = $to =~ /^([^(]+)(?:[(](\d+)[)])?$/; return undef unless defined $page and length $page; $section ||= 1; return $self->man_url_prefix . "$section/" . $self->manpage_url_escape($page) . $self->man_url_postfix; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub resolve_pod_link_by_table { # A crazy hack to allow specifying custom L => URL mappings return unless $_[0]->{'podhtml_LOT'}; # An optimizy shortcut my($self, $to, $section) = @_; # TODO: add a method that actually populates podhtml_LOT from a file? if(defined $section) { $to = '' unless defined $to and length $to; return $self->{'podhtml_LOT'}{"$to#$section"}; # quite possibly undef! } else { return $self->{'podhtml_LOT'}{$to}; # quite possibly undef! } return; } ########################################################################### sub linearize_tokens { # self, tokens my $self = shift; my $out = ''; my $t; while($t = shift @_) { if(!ref $t or !UNIVERSAL::can($t, 'is_text')) { $out .= $t; # a string, or some insane thing } elsif($t->is_text) { $out .= $t->text; } elsif($t->is_start and $t->tag eq 'X') { # Ignore until the end of this X<...> sequence: my $x_open = 1; while($x_open) { next if( ($t = shift @_)->is_text ); if( $t->is_start and $t->tag eq 'X') { ++$x_open } elsif($t->is_end and $t->tag eq 'X') { --$x_open } } } } return undef if length $out > $Linearization_Limit; return $out; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub unicode_escape_url { my($self, $string) = @_; $string =~ s/([^\x00-\xFF])/'('.ord($1).')'/eg; # Turn char 1234 into "(1234)" return $string; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub esc { # a function. if(defined wantarray) { if(wantarray) { @_ = splice @_; # break aliasing } else { my $x = shift; $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg; return $x; } } foreach my $x (@_) { # Escape things very cautiously: $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg if defined $x; # Leave out "- so that "--" won't make it thru in X-generated comments # with text in them. # Yes, stipulate the list without a range, so that this can work right on # all charsets that this module happens to run under. # Altho, hmm, what about that ord? Presumably that won't work right # under non-ASCII charsets. Something should be done about that. } return @_; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1; __END__ =head1 NAME Pod::Simple::HTML - convert Pod to HTML =head1 SYNOPSIS perl -MPod::Simple::HTML -e Pod::Simple::HTML::go thingy.pod =head1 DESCRIPTION This class is for making an HTML rendering of a Pod document. This is a subclass of L and inherits all its methods (and options). Note that if you want to do a batch conversion of a lot of Pod documents to HTML, you should see the module L. =head1 CALLING FROM THE COMMAND LINE TODO perl -MPod::Simple::HTML -e Pod::Simple::HTML::go Thing.pod Thing.html =head1 CALLING FROM PERL TODO make a new object, set any options, and use parse_from_file =head1 METHODS TODO all (most?) accessorized methods =head1 SUBCLASSING TODO can just set any of: html_css html_javascript title_prefix 'html_header_before_title', 'html_header_after_title', 'html_footer', maybe override do_pod_link maybe override do_beginning do_end =head1 SEE ALSO L, L TODO: a corpus of sample Pod input and HTML output? Or common idioms? =head1 SUPPORT Questions or discussion about POD and Pod::Simple should be sent to the pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, L. Feel free to fork and contribute, or to clone L and send patches! Patches against Pod::Simple are welcome. Please send bug reports to . =head1 COPYRIGHT AND DISCLAIMERS Copyright (c) 2002-2004 Sean M. Burke. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. This program is distributed in the hope that it will be useful, but without any warranty; without even the implied warranty of merchantability or fitness for a particular purpose. =head1 ACKNOWLEDGEMENTS Thanks to L for permission to use its L site for man page links. Thanks to L for permission to use the site for Perl module links. =head1 AUTHOR Pod::Simple was created by Sean M. Burke . But don't bother him, he's retired. Pod::Simple is maintained by: =over =item * Allison Randal C =item * Hans Dieter Pearcey C =item * David E. Wheeler C =back =cut