diff options
author | Karl Berry <karl@freefriends.org> | 2017-04-18 23:10:57 +0000 |
---|---|---|
committer | Karl Berry <karl@freefriends.org> | 2017-04-18 23:10:57 +0000 |
commit | 40b4b6e177c62a14c166dbba6adf3abc415af4b2 (patch) | |
tree | 2996bf29509c806bd8064fb6cf38092c1b375ff8 /Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm | |
parent | 8e743c86b6872f30b7a35c72aa944455157d4b3f (diff) |
tlperl 5.24.1 from siep
git-svn-id: svn://tug.org/texlive/trunk@43914 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm | 87 |
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>. |