summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm86
1 files changed, 49 insertions, 37 deletions
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm
index 2c6494b9ba2..9d8f978eea1 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm
@@ -9,7 +9,7 @@ use vars qw(
$Doctype_decl $Content_decl
);
@ISA = ('Pod::Simple::PullParser');
-$VERSION = '3.29';
+$VERSION = '3.32';
BEGIN {
if(defined &DEBUG) { } # no-op
elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG }
@@ -188,7 +188,7 @@ sub new {
$new->accept_targets( 'html', 'HTML' );
$new->accept_codes('VerbatimFormatted');
$new->accept_codes(@_to_accept);
- DEBUG > 2 and print "To accept: ", join(' ',@_to_accept), "\n";
+ DEBUG > 2 and print STDERR "To accept: ", join(' ',@_to_accept), "\n";
$new->perldoc_url_prefix( $Perldoc_URL_Prefix );
$new->perldoc_url_postfix( $Perldoc_URL_Postfix );
@@ -232,7 +232,7 @@ sub __adjust_html_h_levels {
sub batch_mode_page_object_init {
my($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_;
- DEBUG and print "Initting $self\n for $module\n",
+ DEBUG and print STDERR "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);
@@ -255,12 +255,12 @@ sub do_beginning {
if(defined $self->force_title) {
$title = $self->force_title;
- DEBUG and print "Forcing title to be $title\n";
+ DEBUG and print STDERR "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";
+ DEBUG and print STDERR "No content seen in search for title.\n";
return;
}
$self->{'Title'} = $title;
@@ -270,7 +270,7 @@ sub do_beginning {
} else {
$title = $self->default_title;
$title = '' unless defined $title;
- DEBUG and print "Title defaults to $title\n";
+ DEBUG and print STDERR "Title defaults to $title\n";
}
}
@@ -305,7 +305,7 @@ sub do_beginning {
$after,
;
- DEBUG and print "Returning from do_beginning...\n";
+ DEBUG and print STDERR "Returning from do_beginning...\n";
return 1;
}
@@ -368,9 +368,9 @@ sub do_middle {
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";
+ DEBUG and print STDERR "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";
+ DEBUG and print STDERR "Odd, couldn't find where to insert the index in the output!\n";
# I don't think this should ever happen.
}
return 1;
@@ -502,7 +502,7 @@ sub _do_middle_main_loop {
if(defined $name) {
my $esc = esc( $self->section_name_tidy( $name ) );
print $fh qq[name="$esc"];
- DEBUG and print "Linearized ", scalar(@to_unget),
+ DEBUG and print STDERR "Linearized ", scalar(@to_unget),
" tokens as \"$name\".\n";
push @{ $self->{'PSHTML_index_points'} }, [$tagname, $name]
if $ToIndex{ $tagname };
@@ -510,7 +510,7 @@ sub _do_middle_main_loop {
# just their content), but ahwell.
} else { # ludicrously long, so nevermind
- DEBUG and print "Linearized ", scalar(@to_unget),
+ DEBUG and print STDERR "Linearized ", scalar(@to_unget),
" tokens, but it was too long, so nevermind.\n";
}
print $fh "\n>";
@@ -523,7 +523,7 @@ sub _do_middle_main_loop {
$self->unget_token($next);
next;
}
- DEBUG and print " raw text ", $next->text, "\n";
+ DEBUG and print STDERR " raw text ", $next->text, "\n";
# The parser sometimes preserves newlines and sometimes doesn't!
(my $text = $next->text) =~ s/\n\z//;
print $fh $text, "\n";
@@ -608,7 +608,7 @@ sub do_man_link {
$frag = $self->section_escape($frag)
if defined $frag and length($frag .= ''); # (stringify)
- DEBUG and print "Resolving \"$to/$frag\"\n\n";
+ DEBUG and print STDERR "Resolving \"$to/$frag\"\n\n";
return $self->resolve_man_page_link($to, $frag);
}
@@ -627,18 +627,18 @@ sub do_pod_link {
$section = $self->section_escape($section)
if defined $section and length($section .= ''); # (stringify)
- DEBUG and printf "Resolving \"%s\" \"%s\"...\n",
+ DEBUG and printf STDERR "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 ",
+ DEBUG > 1 and print STDERR "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)",
+ DEBUG > 4 and print STDERR " resolve_pod_link_by_table(T,S)",
" didn't return anything interesting.\n";
}
}
@@ -648,15 +648,15 @@ sub do_pod_link {
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";
+ and print STDERR "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";
+ DEBUG > 1 and print STDERR "resolve_pod_page_link gives ", $there || "(nil)", "\n";
unless( defined $there and length $there ) {
- DEBUG and print "Can't resolve $to\n";
+ DEBUG and print STDERR "Can't resolve $to\n";
return undef;
}
# resolve_pod_page_link returning undef is how it
@@ -665,18 +665,18 @@ sub do_pod_link {
$to = $there;
}
- #DEBUG and print "So far [", $to||'nil', "] [", $section||'nil', "]\n";
+ #DEBUG and print STDERR "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",
+ DEBUG and printf STDERR "Oddly, couldn't resolve \"%s\" \"%s\"...\n",
$to || "(nil)", $section || "(nil)";
return undef;
}
- DEBUG and print "Resolved to $out\n";
+ DEBUG and print STDERR "Resolved to $out\n";
return $out;
}
@@ -695,7 +695,11 @@ sub section_name_tidy {
$section =~ s/^\s+//;
$section =~ s/\s+$//;
$section =~ tr/ /_/;
- $section =~ tr/\x00-\x1F\x80-\x9F//d if 'A' eq chr(65); # drop crazy characters
+ if ($] ge 5.006) {
+ $section =~ s/[[:cntrl:][:^ascii:]]//g; # drop crazy characters
+ } elsif ('A' eq chr(65)) { # But not on early EBCDIC
+ $section =~ tr/\x00-\x1F\x80-\x9F//d;
+ }
$section = $self->unicode_escape_url($section);
$section = '_' unless length $section;
return $section;
@@ -714,12 +718,13 @@ sub general_url_escape {
# A pretty conservative escaping, behoovey even for query components
# of a URL (see RFC 2396)
- $string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',ord($1))/eg;
+ if ($] ge 5.007_003) {
+ $string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',utf8::native_to_unicode(ord($1)))/eg;
+ } else { # Is broken for non-ASCII platforms on early perls
+ $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;
}
@@ -752,16 +757,16 @@ sub resolve_pod_page_link_singleton_mode {
sub resolve_pod_page_link_batch_mode {
my($self, $to) = @_;
- DEBUG > 1 and print " During batch mode, resolving $to ...\n";
+ DEBUG > 1 and print STDERR " 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";
+ DEBUG and print STDERR "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";
+ DEBUG > 1 and print STDERR " => $out\n";
return $out;
}
@@ -851,21 +856,28 @@ sub esc { # a function.
@_ = splice @_; # break aliasing
} else {
my $x = shift;
- $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
+ if ($] ge 5.007_003) {
+ $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(utf8::native_to_unicode(ord($1))).';'/eg;
+ } else { # Is broken for non-ASCII platforms on early perls
+ $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;
+ if (defined $x) {
+ if ($] ge 5.007_003) {
+ $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(utf8::native_to_unicode(ord($1))).';'/eg
+ } else { # Is broken for non-ASCII platforms on early perls
+ $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg
+ }
+ }
# 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 @_;
}
@@ -1100,8 +1112,8 @@ 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<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
-to clone L<git://github.com/theory/pod-simple.git> and send patches!
+L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
Patches against Pod::Simple are welcome. Please send bug reports to
<bug-pod-simple@rt.cpan.org>.