summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm87
1 files changed, 51 insertions, 36 deletions
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm
index 617190418b6..9aea743a7e0 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm
@@ -8,7 +8,7 @@ package Pod::Simple::RTF;
use strict;
use vars qw($VERSION @ISA %Escape $WRAP %Tagmap);
-$VERSION = '3.29';
+$VERSION = '3.32';
use Pod::Simple::PullParser ();
BEGIN {@ISA = ('Pod::Simple::PullParser')}
@@ -17,6 +17,16 @@ BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
$WRAP = 1 unless defined $WRAP;
+# These are broken for early Perls on EBCDIC; they could be fixed to work
+# better there, but not worth it. These are part of a larger [...] class, so
+# are just the strings to substitute into it, as opposed to compiled patterns.
+my $cntrl = '[:cntrl:]';
+$cntrl = '\x00-\x1F\x7F' unless eval "qr/[$cntrl]/";
+
+my $not_ascii = '[:^ascii:]';
+$not_ascii = '\x80-\xFF' unless eval "qr/[$not_ascii]/";
+
+
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub _openclose {
@@ -101,7 +111,7 @@ sub new {
$new->accept_codes(@_to_accept);
$new->accept_codes('VerbatimFormatted');
- DEBUG > 2 and print "To accept: ", join(' ',@_to_accept), "\n";
+ DEBUG > 2 and print STDERR "To accept: ", join(' ',@_to_accept), "\n";
$new->doc_lang(
( $ENV{'RTFDEFLANG'} || '') =~ m/^(\d{1,10})$/s ? $1
: ($ENV{'RTFDEFLANG'} || '') =~ m/^0?x([a-fA-F0-9]{1,10})$/s ? hex($1)
@@ -161,13 +171,13 @@ sub do_middle { # the main work
if( ($type = $token->type) eq 'text' ) {
if( $self->{'rtfverbatim'} ) {
- DEBUG > 1 and print " $type " , $token->text, " in verbatim!\n";
+ DEBUG > 1 and print STDERR " $type " , $token->text, " in verbatim!\n";
rtf_esc_codely($scratch = $token->text);
print $fh $scratch;
next;
}
- DEBUG > 1 and print " $type " , $token->text, "\n";
+ DEBUG > 1 and print STDERR " $type " , $token->text, "\n";
$scratch = $token->text;
$scratch =~ tr/\t\cb\cc/ /d;
@@ -176,7 +186,7 @@ sub do_middle { # the main work
s/(?:
^
|
- (?<=[\cm\cj\t "\[\<\(])
+ (?<=[\r\n\t "\[\<\(])
) # start on whitespace, sequence-start, or quote
( # something looking like a Perl token:
(?:
@@ -185,7 +195,7 @@ sub do_middle { # the main work
|
# or starting alpha, but containing anything strange:
(?:
- [a-zA-Z'\x80-\xFF]+[\$\@\:_<>\(\\\*]\S+
+ [a-zA-Z'${not_ascii}]+[\$\@\:_<>\(\\\*]\S+
)
)
/\cb$1\cc/xsg
@@ -194,10 +204,10 @@ sub do_middle { # the main work
rtf_esc($scratch);
$scratch =~
s/(
- [^\cm\cj\n]{65} # Snare 65 characters from a line
- [^\cm\cj\n\x20]{0,50} # and finish any current word
+ [^\r\n]{65} # Snare 65 characters from a line
+ [^\r\n ]{0,50} # and finish any current word
)
- (\x20{1,10})(?![\cm\cj\n]) # capture some spaces not at line-end
+ (\ {1,10})(?![\r\n]) # capture some spaces not at line-end
/$1$2\n/gx # and put a NL before those spaces
if $WRAP;
# This may wrap at well past the 65th column, but not past the 120th.
@@ -205,7 +215,7 @@ sub do_middle { # the main work
print $fh $scratch;
} elsif( $type eq 'start' ) {
- DEBUG > 1 and print " +$type ",$token->tagname,
+ DEBUG > 1 and print STDERR " +$type ",$token->tagname,
" (", map("<$_> ", %{$token->attr_hash}), ")\n";
if( ($tagname = $token->tagname) eq 'Verbatim'
@@ -220,7 +230,7 @@ sub do_middle { # the main work
while( $$t =~ m/$/mg ) {
last if ++$line_count > 15; # no point in counting further
}
- DEBUG > 3 and print " verbatim line count: $line_count\n";
+ DEBUG > 3 and print STDERR " verbatim line count: $line_count\n";
}
$self->unget_token($next);
$self->{'rtfkeep'} = ($line_count > 15) ? '' : '\keepn' ;
@@ -242,7 +252,7 @@ sub do_middle { # the main work
if($to_unget[-1]->type eq 'text') {
if( ($text_count_here += length ${$to_unget[-1]->text_r}) > 150 ){
- DEBUG > 1 and print " item-* is too long to be keepn'd.\n";
+ DEBUG > 1 and print STDERR " item-* is too long to be keepn'd.\n";
last;
}
} elsif (@to_unget > 1 and
@@ -254,13 +264,13 @@ sub do_middle { # the main work
$to_unget[-1]->type eq 'start' and
$to_unget[-1]->tagname eq 'Para';
- DEBUG > 1 and printf " item-* before %s(%s) %s keepn'd.\n",
+ DEBUG > 1 and printf STDERR " item-* before %s(%s) %s keepn'd.\n",
$to_unget[-1]->type,
$to_unget[-1]->can('tagname') ? $to_unget[-1]->tagname : '',
$self->{'rtfitemkeepn'} ? "gets" : "doesn't get";
last;
} elsif (@to_unget > 40) {
- DEBUG > 1 and print " item-* now has too many tokens (",
+ DEBUG > 1 and print STDERR " item-* now has too many tokens (",
scalar(@to_unget),
(DEBUG > 4) ? (q<: >, map($_->dump, @to_unget)) : (),
") to be keepn'd.\n";
@@ -275,7 +285,7 @@ sub do_middle { # the main work
push @stack, $1;
push @indent_stack,
int($token->attr('indent') * 4 * $self->normal_halfpoint_size);
- DEBUG and print "Indenting over $indent_stack[-1] twips.\n";
+ DEBUG and print STDERR "Indenting over $indent_stack[-1] twips.\n";
$self->{'rtfindent'} += $indent_stack[-1];
} elsif ($tagname eq 'L') {
@@ -288,7 +298,7 @@ sub do_middle { # the main work
$self->unget_token($next);
next;
}
- DEBUG and print " raw text ", $next->text, "\n";
+ DEBUG and print STDERR " raw text ", $next->text, "\n";
printf $fh "\n" . $next->text . "\n";
next;
}
@@ -300,14 +310,14 @@ sub do_middle { # the main work
if ($tagname eq 'item-number') {
print $fh $token->attr('number'), ". \n";
} elsif ($tagname eq 'item-bullet') {
- print $fh "\\'95 \n";
+ print $fh "\\'", ord("_"), "\n";
#for funky testing: print $fh '', rtf_esc("\x{4E4B}\x{9053}");
}
} elsif( $type eq 'end' ) {
- DEBUG > 1 and print " -$type ",$token->tagname,"\n";
+ DEBUG > 1 and print STDERR " -$type ",$token->tagname,"\n";
if( ($tagname = $token->tagname) =~ m/^over-/s ) {
- DEBUG and print "Indenting back $indent_stack[-1] twips.\n";
+ DEBUG and print STDERR "Indenting back $indent_stack[-1] twips.\n";
$self->{'rtfindent'} -= pop @indent_stack;
pop @stack;
} elsif( $tagname eq 'Verbatim' or $tagname eq 'VerbatimFormatted') {
@@ -441,7 +451,7 @@ END
sub doc_start {
my $self = $_[0];
my $title = $self->get_short_title();
- DEBUG and print "Short Title: <$title>\n";
+ DEBUG and print STDERR "Short Title: <$title>\n";
$title .= ' ' if length $title;
$title =~ s/ *$/ /s;
@@ -454,9 +464,9 @@ sub doc_start {
if $title =~ m/^\S+$/s and $title =~ m/::/s;
# catches the most common case, at least
- DEBUG and print "Title0: <$title>\n";
+ DEBUG and print STDERR "Title0: <$title>\n";
$title = rtf_esc($title);
- DEBUG and print "Title1: <$title>\n";
+ DEBUG and print STDERR "Title1: <$title>\n";
$title = '\lang1024\noproof ' . $title
if $is_obviously_module_name;
@@ -483,19 +493,19 @@ sub rtf_esc {
my $x; # scratch
if(!defined wantarray) { # void context: alter in-place!
for(@_) {
- s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
+ s/([F${cntrl}\-\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER
s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
}
return;
} elsif(wantarray) { # return an array
return map {; ($x = $_) =~
- s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
+ s/([F${cntrl}\-\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER
$x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
$x;
} @_;
} else { # return a single scalar
($x = ((@_ == 1) ? $_[0] : join '', @_)
- ) =~ s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
+ ) =~ s/([F${cntrl}\-\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER
# Escape \, {, }, -, control chars, and 7f-ff.
$x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
return $x;
@@ -512,19 +522,19 @@ sub rtf_esc_codely {
my $x; # scratch
if(!defined wantarray) { # void context: alter in-place!
for(@_) {
- s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
+ s/([F${cntrl}\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER
s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
}
return;
} elsif(wantarray) { # return an array
return map {; ($x = $_) =~
- s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
+ s/([F${cntrl}\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER
$x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
$x;
} @_;
} else { # return a single scalar
($x = ((@_ == 1) ? $_[0] : join '', @_)
- ) =~ s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
+ ) =~ s/([F${cntrl}\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER
# Escape \, {, }, -, control chars, and 7f-ff.
$x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
return $x;
@@ -532,25 +542,30 @@ sub rtf_esc_codely {
}
%Escape = (
- map( (chr($_),chr($_)), # things not apparently needing escaping
+ (($] lt 5.007_003) # Broken for non-ASCII on early Perls
+ ? (map( (chr($_),chr($_)), # things not apparently needing escaping
+ 0x20 .. 0x7E ),
+ map( (chr($_),sprintf("\\'%02x", $_)), # apparently escapeworthy things
+ 0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46))
+ : (map( (chr(utf8::unicode_to_native($_)),chr(utf8::unicode_to_native($_))),
0x20 .. 0x7E ),
- map( (chr($_),sprintf("\\'%02x", $_)), # apparently escapeworthy things
- 0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46),
+ map( (chr($_),sprintf("\\'%02x", utf8::unicode_to_native($_))),
+ 0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46))),
# We get to escape out 'F' so that we can send RTF files thru the mail
# without the slightest worry that paragraphs beginning with "From"
# will get munged.
# And some refinements:
- "\cm" => "\n",
+ "\r" => "\n",
"\cj" => "\n",
"\n" => "\n\\line ",
"\t" => "\\tab ", # Tabs (altho theoretically raw \t's are okay)
"\f" => "\n\\page\n", # Formfeed
"-" => "\\_", # Turn plaintext '-' into a non-breaking hyphen
- "\xA0" => "\\~", # Latin-1 non-breaking space
- "\xAD" => "\\-", # Latin-1 soft (optional) hyphen
+ $Pod::Simple::nbsp => "\\~", # Latin-1 non-breaking space
+ $Pod::Simple::shy => "\\-", # Latin-1 soft (optional) hyphen
# CRAZY HACKS:
"\n" => "\\line\n",
@@ -662,8 +677,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>.