tags
before and after C is invoked, so you might want to override these
together with C if this wrapping isn't suiteable.
Note that the code might be broken into mulitple segments if there are
nested formatting codes inside a C<< CE...> >> sequence. In between the
calls to C other markup tags might have been emitted in that
case. The same is true for verbatim sections if the C
option is turned on.
=head2 accept_targets_as_html
This method behaves like C, but also marks the region
as one whose content should be emitted literally, without HTML entity escaping
or wrapping in a C element.
=cut
sub __in_literal_xhtml_region {
return unless @{ $_[0]{__region_targets} };
my $target = $_[0]{__region_targets}[-1];
return $_[0]{__literal_targets}{ $target };
}
sub accept_targets_as_html {
my ($self, @targets) = @_;
$self->accept_targets(@targets);
$self->{__literal_targets}{$_} = 1 for @targets;
}
sub handle_text {
# escape special characters in HTML (<, >, &, etc)
my $text = $_[0]->__in_literal_xhtml_region
? $_[1]
: $_[0]->encode_entities( $_[1] );
if ($_[0]{'in_code'} && @{$_[0]{'in_code'}}) {
# Intentionally use the raw text in $_[1], even if we're not in a
# literal xhtml region, since handle_code calls encode_entities.
$_[0]->handle_code( $_[1], $_[0]{'in_code'}[-1] );
} else {
$_[0]{'scratch'} .= $text;
}
$_[0]{htext} .= $text if $_[0]{'in_head'};
}
sub start_code {
$_[0]{'scratch'} .= '';
}
sub end_code {
$_[0]{'scratch'} .= '
';
}
sub handle_code {
$_[0]{'scratch'} .= $_[0]->encode_entities( $_[1] );
}
sub start_Para {
$_[0]{'scratch'} = '';
}
sub start_Verbatim {
$_[0]{'scratch'} = '
';
push(@{$_[0]{'in_code'}}, 'Verbatim');
$_[0]->start_code($_[0]{'in_code'}[-1]);
}
sub start_head1 { $_[0]{'in_head'} = 1; $_[0]{htext} = ''; }
sub start_head2 { $_[0]{'in_head'} = 2; $_[0]{htext} = ''; }
sub start_head3 { $_[0]{'in_head'} = 3; $_[0]{htext} = ''; }
sub start_head4 { $_[0]{'in_head'} = 4; $_[0]{htext} = ''; }
sub start_item_number {
$_[0]{'scratch'} = "\n" if ($_[0]{'in_li'}->[-1] && pop @{$_[0]{'in_li'}});
$_[0]{'scratch'} .= '
';
push @{$_[0]{'in_li'}}, 1;
}
sub start_item_bullet {
$_[0]{'scratch'} = "
\n" if ($_[0]{'in_li'}->[-1] && pop @{$_[0]{'in_li'}});
$_[0]{'scratch'} .= '';
push @{$_[0]{'in_li'}}, 1;
}
sub start_item_text {
# see end_item_text
}
sub start_over_bullet { $_[0]{'scratch'} = '
'; push @{$_[0]{'in_li'}}, 0; $_[0]->emit }
sub start_over_block { $_[0]{'scratch'} = ''; $_[0]->emit }
sub start_over_number { $_[0]{'scratch'} = ''; push @{$_[0]{'in_li'}}, 0; $_[0]->emit }
sub start_over_text {
$_[0]{'scratch'} = '';
$_[0]{'dl_level'}++;
$_[0]{'in_dd'} ||= [];
$_[0]->emit
}
sub end_over_block { $_[0]{'scratch'} .= '
'; $_[0]->emit }
sub end_over_number {
$_[0]{'scratch'} = "
\n" if ( pop @{$_[0]{'in_li'}} );
$_[0]{'scratch'} .= '';
pop @{$_[0]{'in_li'}};
$_[0]->emit;
}
sub end_over_bullet {
$_[0]{'scratch'} = "\n" if ( pop @{$_[0]{'in_li'}} );
$_[0]{'scratch'} .= '';
pop @{$_[0]{'in_li'}};
$_[0]->emit;
}
sub end_over_text {
if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
$_[0]{'scratch'} = "\n";
$_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
}
$_[0]{'scratch'} .= '';
$_[0]{'dl_level'}--;
$_[0]->emit;
}
# . . . . . Now the actual formatters:
sub end_Para { $_[0]{'scratch'} .= ''; $_[0]->emit }
sub end_Verbatim {
$_[0]->end_code(pop(@{$_[0]->{'in_code'}}));
$_[0]{'scratch'} .= '';
$_[0]->emit;
}
sub _end_head {
my $h = delete $_[0]{in_head};
my $add = $_[0]->html_h_level;
$add = 1 unless defined $add;
$h += $add - 1;
my $id = $_[0]->idify($_[0]{htext});
my $text = $_[0]{scratch};
$_[0]{'scratch'} = $_[0]->backlink && ($h - $add == 0)
# backlinks enabled && =head1
? qq{$text }
: qq{$text };
$_[0]->emit;
push @{ $_[0]{'to_index'} }, [$h, $id, delete $_[0]{'htext'}];
}
sub end_head1 { shift->_end_head(@_); }
sub end_head2 { shift->_end_head(@_); }
sub end_head3 { shift->_end_head(@_); }
sub end_head4 { shift->_end_head(@_); }
sub end_item_bullet { $_[0]{'scratch'} .= ''; $_[0]->emit }
sub end_item_number { $_[0]{'scratch'} .= ''; $_[0]->emit }
sub end_item_text {
# idify and anchor =item content if wanted
my $dt_id = $_[0]{'anchor_items'}
? ' id="'. $_[0]->idify($_[0]{'scratch'}) .'"'
: '';
# reset scratch
my $text = $_[0]{scratch};
$_[0]{'scratch'} = '';
if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
$_[0]{'scratch'} = "\n";
$_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
}
$_[0]{'scratch'} .= qq{$text \n};
$_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 1;
$_[0]->emit;
}
# This handles =begin and =for blocks of all kinds.
sub start_for {
my ($self, $flags) = @_;
push @{ $self->{__region_targets} }, $flags->{target_matching};
unless ($self->__in_literal_xhtml_region) {
$self->{scratch} .= '{scratch} .= qq( class="$flags->{target}") if $flags->{target};
$self->{scratch} .= '>';
}
$self->emit;
}
sub end_for {
my ($self) = @_;
$self->{'scratch'} .= '' unless $self->__in_literal_xhtml_region;
pop @{ $self->{__region_targets} };
$self->emit;
}
sub start_Document {
my ($self) = @_;
if (defined $self->html_header) {
$self->{'scratch'} .= $self->html_header;
$self->emit unless $self->html_header eq "";
} else {
my ($doctype, $title, $metatags, $bodyid);
$doctype = $self->html_doctype || '';
$title = $self->force_title || $self->title || $self->default_title || '';
$metatags = $self->html_header_tags || '';
if (my $css = $self->html_css) {
$metatags .= $css;
if ($css !~ /encode_entities($css) . '" type="text/css" />';
}
}
if ($self->html_javascript) {
$metatags .= qq{\n";
}
$bodyid = $self->backlink ? ' id="_podtop_"' : '';
$self->{'scratch'} .= <<"HTML";
$doctype
$title
$metatags
HTML
$self->emit;
}
}
sub end_Document {
my ($self) = @_;
my $to_index = $self->{'to_index'};
if ($self->index && @{ $to_index } ) {
my @out;
my $level = 0;
my $indent = -1;
my $space = '';
my $id = ' id="index"';
for my $h (@{ $to_index }, [0]) {
my $target_level = $h->[0];
# Get to target_level by opening or closing ULs
if ($level == $target_level) {
$out[-1] .= '';
} elsif ($level > $target_level) {
$out[-1] .= '' if $out[-1] =~ /^\s+/;
while ($level > $target_level) {
--$level;
push @out, (' ' x --$indent) . ' ' if @out && $out[-1] =~ m{^\s+<\/ul};
push @out, (' ' x --$indent) . '';
}
push @out, (' ' x --$indent) . '' if $level;
} else {
while ($level < $target_level) {
++$level;
push @out, (' ' x ++$indent) . '' if @out && $out[-1]=~ /^\s*";
$id = '';
}
++$indent;
}
next unless $level;
$space = ' ' x $indent;
push @out, sprintf '%s- %s',
$space, $h->[1], $h->[2];
}
# Splice the index in between the HTML headers and the first element.
my $offset = defined $self->html_header ? $self->html_header eq '' ? 0 : 1 : 1;
splice @{ $self->{'output'} }, $offset, 0, join "\n", @out;
}
if (defined $self->html_footer) {
$self->{'scratch'} .= $self->html_footer;
$self->emit unless $self->html_footer eq "";
} else {
$self->{'scratch'} .= "\n";
$self->emit;
}
if ($self->index) {
print {$self->{'output_fh'}} join ("\n\n", @{ $self->{'output'} }), "\n\n";
@{$self->{'output'}} = ();
}
}
# Handling code tags
sub start_B { $_[0]{'scratch'} .= '' }
sub end_B { $_[0]{'scratch'} .= '' }
sub start_C { push(@{$_[0]{'in_code'}}, 'C'); $_[0]->start_code($_[0]{'in_code'}[-1]); }
sub end_C { $_[0]->end_code(pop(@{$_[0]{'in_code'}})); }
sub start_F { $_[0]{'scratch'} .= '' }
sub end_F { $_[0]{'scratch'} .= '' }
sub start_I { $_[0]{'scratch'} .= '' }
sub end_I { $_[0]{'scratch'} .= '' }
sub start_L {
my ($self, $flags) = @_;
my ($type, $to, $section) = @{$flags}{'type', 'to', 'section'};
my $url = $self->encode_entities(
$type eq 'url' ? $to
: $type eq 'pod' ? $self->resolve_pod_page_link($to, $section)
: $type eq 'man' ? $self->resolve_man_page_link($to, $section)
: undef
);
# If it's an unknown type, use an attribute-less like HTML.pm.
$self->{'scratch'} .= '' : '>');
}
sub end_L { $_[0]{'scratch'} .= '' }
sub start_S { $_[0]{'scratch'} .= '' }
sub end_S { $_[0]{'scratch'} .= '' }
sub emit {
my($self) = @_;
if ($self->index) {
push @{ $self->{'output'} }, $self->{'scratch'};
} else {
print {$self->{'output_fh'}} $self->{'scratch'}, "\n\n";
}
$self->{'scratch'} = '';
return;
}
=head2 resolve_pod_page_link
my $url = $pod->resolve_pod_page_link('Net::Ping', 'INSTALL');
my $url = $pod->resolve_pod_page_link('perlpodspec');
my $url = $pod->resolve_pod_page_link(undef, 'SYNOPSIS');
Resolves a POD link target (typically a module or POD file name) and section
name to a URL. The resulting link will be returned for the above examples as:
http://search.cpan.org/perldoc?Net::Ping#INSTALL
http://search.cpan.org/perldoc?perlpodspec
#SYNOPSIS
Note that when there is only a section argument the URL will simply be a link
to a section in the current document.
=cut
sub resolve_pod_page_link {
my ($self, $to, $section) = @_;
return undef unless defined $to || defined $section;
if (defined $section) {
$section = '#' . $self->idify($self->encode_entities($section), 1);
return $section unless defined $to;
} else {
$section = ''
}
return ($self->perldoc_url_prefix || '')
. $self->encode_entities($to) . $section
. ($self->perldoc_url_postfix || '');
}
=head2 resolve_man_page_link
my $url = $pod->resolve_man_page_link('crontab(5)', 'EXAMPLE CRON FILE');
my $url = $pod->resolve_man_page_link('crontab');
Resolves a man page link target and numeric section to a URL. The resulting
link will be returned for the above examples as:
http://man.he.net/man5/crontab
http://man.he.net/man1/crontab
Note that the first argument is required. The section number will be parsed
from it, and if it's missing will default to 1. The second argument is
currently ignored, as L
does not currently
include linkable IDs or anchor names in its pages. Subclass to link to a
different man page HTTP server.
=cut
sub resolve_man_page_link {
my ($self, $to, $section) = @_;
return undef unless defined $to;
my ($page, $part) = $to =~ /^([^(]+)(?:[(](\d+)[)])?$/;
return undef unless $page;
return ($self->man_url_prefix || '')
. ($part || 1) . "/" . $self->encode_entities($page)
. ($self->man_url_postfix || '');
}
=head2 idify
my $id = $pod->idify($text);
my $hash = $pod->idify($text, 1);
This method turns an arbitrary string into a valid XHTML ID attribute value.
The rules enforced, following
L, are:
=over
=item *
The id must start with a letter (a-z or A-Z)
=item *
All subsequent characters can be letters, numbers (0-9), hyphens (-),
underscores (_), colons (:), and periods (.).
=item *
The final character can't be a hyphen, colon, or period. URLs ending with these
characters, while allowed by XHTML, can be awkward to extract from plain text.
=item *
Each id must be unique within the document.
=back
In addition, the returned value will be unique within the context of the
Pod::Simple::XHTML object unless a second argument is passed a true value. ID
attributes should always be unique within a single XHTML document, but pass
the true value if you are creating not an ID but a URL hash to point to
an ID (i.e., if you need to put the "#foo" in C<< foo >>.
=cut
sub idify {
my ($self, $t, $not_unique) = @_;
for ($t) {
s/<[^>]+>//g; # Strip HTML.
s/&[^;]+;//g; # Strip entities.
s/^\s+//; s/\s+$//; # Strip white space.
s/^([^a-zA-Z]+)$/pod$1/; # Prepend "pod" if no valid chars.
s/^[^a-zA-Z]+//; # First char must be a letter.
s/[^-a-zA-Z0-9_:.]+/-/g; # All other chars must be valid.
s/[-:.]+$//; # Strip trailing punctuation.
}
return $t if $not_unique;
my $i = '';
$i++ while $self->{ids}{"$t$i"}++;
return "$t$i";
}
=head2 batch_mode_page_object_init
$pod->batch_mode_page_object_init($batchconvobj, $module, $infile, $outfile, $depth);
Called by L so that the class has a chance to
initialize the converter. Internally it sets the C property to
true and sets C, but Pod::Simple::XHTML does not
currently use those features. Subclasses might, though.
=cut
sub batch_mode_page_object_init {
my ($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_;
$self->batch_mode(1);
$self->batch_mode_current_level($depth);
return $self;
}
sub html_header_after_title {
}
1;
__END__
=head1 SEE ALSO
L, L, L
=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) 2003-2005 Allison Randal.
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::Simpele::XHTML was created by Allison Randal .
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