"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/Pod/Simple/RTF.pm" (8 Mar 2018, 22484 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 
    2 require 5;
    3 package Pod::Simple::RTF;
    4 
    5 #sub DEBUG () {4};
    6 #sub Pod::Simple::DEBUG () {4};
    7 #sub Pod::Simple::PullParser::DEBUG () {4};
    8 
    9 use strict;
   10 use vars qw($VERSION @ISA %Escape $WRAP %Tagmap);
   11 $VERSION = '3.35';
   12 use Pod::Simple::PullParser ();
   13 BEGIN {@ISA = ('Pod::Simple::PullParser')}
   14 
   15 use Carp ();
   16 BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
   17 
   18 $WRAP = 1 unless defined $WRAP;
   19 
   20 # These are broken for early Perls on EBCDIC; they could be fixed to work
   21 # better there, but not worth it.  These are part of a larger [...] class, so
   22 # are just the strings to substitute into it, as opposed to compiled patterns.
   23 my $cntrl = '[:cntrl:]';
   24 $cntrl = '\x00-\x1F\x7F' unless eval "qr/[$cntrl]/";
   25 
   26 my $not_ascii = '[:^ascii:]';
   27 $not_ascii = '\x80-\xFF' unless eval "qr/[$not_ascii]/";
   28 
   29 
   30 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   31 
   32 sub _openclose {
   33  return map {;
   34    m/^([-A-Za-z]+)=(\w[^\=]*)$/s or die "what's <$_>?";
   35    ( $1,  "{\\$2\n",   "/$1",  "}" );
   36  } @_;
   37 }
   38 
   39 my @_to_accept;
   40 
   41 %Tagmap = (
   42  # 'foo=bar' means ('foo' => '{\bar'."\n", '/foo' => '}')
   43  _openclose(
   44   'B=cs18\b',
   45   'I=cs16\i',
   46   'C=cs19\f1\lang1024\noproof',
   47   'F=cs17\i\lang1024\noproof',
   48 
   49   'VerbatimI=cs26\i',
   50   'VerbatimB=cs27\b',
   51   'VerbatimBI=cs28\b\i',
   52 
   53   map {; m/^([-a-z]+)/s && push @_to_accept, $1; $_ }
   54    qw[
   55        underline=ul         smallcaps=scaps  shadow=shad
   56        superscript=super    subscript=sub    strikethrough=strike
   57        outline=outl         emboss=embo      engrave=impr   
   58        dotted-underline=uld          dash-underline=uldash
   59        dot-dash-underline=uldashd    dot-dot-dash-underline=uldashdd     
   60        double-underline=uldb         thick-underline=ulth
   61        word-underline=ulw            wave-underline=ulwave
   62    ]
   63    # But no double-strikethrough, because MSWord can't agree with the
   64    #  RTF spec on whether it's supposed to be \strikedl or \striked1 (!!!)
   65  ),
   66 
   67  # Bit of a hack here:
   68  'L=pod' => '{\cs22\i'."\n",
   69  'L=url' => '{\cs23\i'."\n",
   70  'L=man' => '{\cs24\i'."\n",
   71  '/L' => '}',
   72 
   73  'Data'  => "\n",
   74  '/Data' => "\n",
   75 
   76  'Verbatim'  => "\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n",
   77  '/Verbatim' => "\n\\par}\n",
   78  'VerbatimFormatted'  => "\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n",
   79  '/VerbatimFormatted' => "\n\\par}\n",
   80  'Para'    => "\n{\\pard\\li#rtfindent#\\sa180\n",
   81  '/Para'   => "\n\\par}\n",
   82  'head1'   => "\n{\\pard\\li#rtfindent#\\s31\\keepn\\sb90\\sa180\\f2\\fs#head1_halfpoint_size#\\ul{\n",
   83  '/head1'  => "\n}\\par}\n",
   84  'head2'   => "\n{\\pard\\li#rtfindent#\\s32\\keepn\\sb90\\sa180\\f2\\fs#head2_halfpoint_size#\\ul{\n",
   85  '/head2'  => "\n}\\par}\n",
   86  'head3'   => "\n{\\pard\\li#rtfindent#\\s33\\keepn\\sb90\\sa180\\f2\\fs#head3_halfpoint_size#\\ul{\n",
   87  '/head3'  => "\n}\\par}\n",
   88  'head4'   => "\n{\\pard\\li#rtfindent#\\s34\\keepn\\sb90\\sa180\\f2\\fs#head4_halfpoint_size#\\ul{\n",
   89  '/head4'  => "\n}\\par}\n",
   90    # wordpad borks on \tc\tcl1, or I'd put that in =head1 and =head2
   91 
   92  'item-bullet'  => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
   93  '/item-bullet' => "\n\\par}\n",
   94  'item-number'  => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
   95  '/item-number' => "\n\\par}\n",
   96  'item-text'    => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
   97  '/item-text'   => "\n\\par}\n",
   98 
   99  # we don't need any styles for over-* and /over-*
  100 );
  101 
  102 
  103 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  104 sub new {
  105   my $new = shift->SUPER::new(@_);
  106   $new->nix_X_codes(1);
  107   $new->nbsp_for_S(1);
  108   $new->accept_targets( 'rtf', 'RTF' );
  109 
  110   $new->{'Tagmap'} = {%Tagmap};
  111 
  112   $new->accept_codes(@_to_accept);
  113   $new->accept_codes('VerbatimFormatted');
  114   DEBUG > 2 and print STDERR "To accept: ", join(' ',@_to_accept), "\n";
  115   $new->doc_lang(
  116     (  $ENV{'RTFDEFLANG'} || '') =~ m/^(\d{1,10})$/s ? $1
  117     : ($ENV{'RTFDEFLANG'} || '') =~ m/^0?x([a-fA-F0-9]{1,10})$/s ? hex($1)
  118                                       # yes, tolerate hex!
  119     : ($ENV{'RTFDEFLANG'} || '') =~ m/^([a-fA-F0-9]{4})$/s ? hex($1)
  120                                       # yes, tolerate even more hex!
  121     : '1033'
  122   );
  123 
  124   $new->head1_halfpoint_size(32);
  125   $new->head2_halfpoint_size(28);
  126   $new->head3_halfpoint_size(25);
  127   $new->head4_halfpoint_size(22);
  128   $new->codeblock_halfpoint_size(18);
  129   $new->header_halfpoint_size(17);
  130   $new->normal_halfpoint_size(25);
  131 
  132   return $new;
  133 }
  134 
  135 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  136 
  137 __PACKAGE__->_accessorize(
  138  'doc_lang',
  139  'head1_halfpoint_size',
  140  'head2_halfpoint_size',
  141  'head3_halfpoint_size',
  142  'head4_halfpoint_size',
  143  'codeblock_halfpoint_size',
  144  'header_halfpoint_size',
  145  'normal_halfpoint_size',
  146  'no_proofing_exemptions',
  147 );
  148 
  149 
  150 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  151 sub run {
  152   my $self = $_[0];
  153   return $self->do_middle if $self->bare_output;
  154   return
  155    $self->do_beginning && $self->do_middle && $self->do_end;
  156 }
  157 
  158 
  159 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  160 
  161 sub do_middle {      # the main work
  162   my $self = $_[0];
  163   my $fh = $self->{'output_fh'};
  164   
  165   my($token, $type, $tagname, $scratch);
  166   my @stack;
  167   my @indent_stack;
  168   $self->{'rtfindent'} = 0 unless defined $self->{'rtfindent'};
  169   
  170   while($token = $self->get_token) {
  171   
  172     if( ($type = $token->type) eq 'text' ) {
  173       if( $self->{'rtfverbatim'} ) {
  174         DEBUG > 1 and print STDERR "  $type " , $token->text, " in verbatim!\n";
  175         rtf_esc_codely($scratch = $token->text);
  176         print $fh $scratch;
  177         next;
  178       }
  179 
  180       DEBUG > 1 and print STDERR "  $type " , $token->text, "\n";
  181       
  182       $scratch = $token->text;
  183       $scratch =~ tr/\t\cb\cc/ /d;
  184       
  185       $self->{'no_proofing_exemptions'} or $scratch =~
  186        s/(?:
  187            ^
  188            |
  189            (?<=[\r\n\t "\[\<\(])
  190          )   # start on whitespace, sequence-start, or quote
  191          ( # something looking like a Perl token:
  192           (?:
  193            [\$\@\:\<\*\\_]\S+  # either starting with a sigil, etc.
  194           )
  195           |
  196           # or starting alpha, but containing anything strange:
  197           (?:
  198            [a-zA-Z'${not_ascii}]+[\$\@\:_<>\(\\\*]\S+
  199           )
  200          )
  201         /\cb$1\cc/xsg
  202       ;
  203       
  204       rtf_esc($scratch);
  205       $scratch =~
  206          s/(
  207             [^\r\n]{65}        # Snare 65 characters from a line
  208             [^\r\n ]{0,50}     #  and finish any current word
  209            )
  210            (\ {1,10})(?![\r\n]) # capture some spaces not at line-end
  211           /$1$2\n/gx     # and put a NL before those spaces
  212         if $WRAP;
  213         # This may wrap at well past the 65th column, but not past the 120th.
  214       
  215       print $fh $scratch;
  216 
  217     } elsif( $type eq 'start' ) {
  218       DEBUG > 1 and print STDERR "  +$type ",$token->tagname,
  219         " (", map("<$_> ", %{$token->attr_hash}), ")\n";
  220 
  221       if( ($tagname = $token->tagname) eq 'Verbatim'
  222           or $tagname eq 'VerbatimFormatted'
  223       ) {
  224         ++$self->{'rtfverbatim'};
  225         my $next = $self->get_token;
  226         next unless defined $next;
  227         my $line_count = 1;
  228         if($next->type eq 'text') {
  229           my $t = $next->text_r;
  230           while( $$t =~ m/$/mg ) {
  231             last if  ++$line_count  > 15; # no point in counting further
  232           }
  233           DEBUG > 3 and print STDERR "    verbatim line count: $line_count\n";
  234         }
  235         $self->unget_token($next);
  236         $self->{'rtfkeep'} = ($line_count > 15) ? '' : '\keepn' ;     
  237 
  238       } elsif( $tagname =~ m/^item-/s ) {
  239         my @to_unget;
  240         my $text_count_here = 0;
  241         $self->{'rtfitemkeepn'} = '';
  242         # Some heuristics to stop item-*'s functioning as subheadings
  243         #  from getting split from the things they're subheadings for.
  244         #
  245         # It's not terribly pretty, but it really does make things pretty.
  246         #
  247         while(1) {
  248           push @to_unget, $self->get_token;
  249           pop(@to_unget), last unless defined $to_unget[-1];
  250            # Erroneously used to be "unshift" instead of pop!  Adds instead
  251            # of removes, and operates on the beginning instead of the end!
  252           
  253           if($to_unget[-1]->type eq 'text') {
  254             if( ($text_count_here += length ${$to_unget[-1]->text_r}) > 150 ){
  255               DEBUG > 1 and print STDERR "    item-* is too long to be keepn'd.\n";
  256               last;
  257             }
  258           } elsif (@to_unget > 1 and
  259             $to_unget[-2]->type eq 'end' and
  260             $to_unget[-2]->tagname =~ m/^item-/s
  261           ) {
  262             # Bail out here, after setting rtfitemkeepn yea or nay.
  263             $self->{'rtfitemkeepn'} = '\keepn' if 
  264               $to_unget[-1]->type eq 'start' and
  265               $to_unget[-1]->tagname eq 'Para';
  266 
  267             DEBUG > 1 and printf STDERR "    item-* before %s(%s) %s keepn'd.\n",
  268               $to_unget[-1]->type,
  269               $to_unget[-1]->can('tagname') ? $to_unget[-1]->tagname : '',
  270               $self->{'rtfitemkeepn'} ? "gets" : "doesn't get";
  271             last;
  272           } elsif (@to_unget > 40) {
  273             DEBUG > 1 and print STDERR "    item-* now has too many tokens (",
  274               scalar(@to_unget),
  275               (DEBUG > 4) ? (q<: >, map($_->dump, @to_unget)) : (),
  276               ") to be keepn'd.\n";
  277             last; # give up
  278           }
  279           # else keep while'ing along
  280         }
  281         # Now put it aaaaall back...
  282         $self->unget_token(@to_unget);
  283 
  284       } elsif( $tagname =~ m/^over-/s ) {
  285         push @stack, $1;
  286         push @indent_stack,
  287          int($token->attr('indent') * 4 * $self->normal_halfpoint_size);
  288         DEBUG and print STDERR "Indenting over $indent_stack[-1] twips.\n";
  289         $self->{'rtfindent'} += $indent_stack[-1];
  290         
  291       } elsif ($tagname eq 'L') {
  292         $tagname .= '=' . ($token->attr('type') || 'pod');
  293         
  294       } elsif ($tagname eq 'Data') {
  295         my $next = $self->get_token;
  296         next unless defined $next;
  297         unless( $next->type eq 'text' ) {
  298           $self->unget_token($next);
  299           next;
  300         }
  301         DEBUG and print STDERR "    raw text ", $next->text, "\n";
  302         printf $fh "\n" . $next->text . "\n";
  303         next;
  304       }
  305 
  306       defined($scratch = $self->{'Tagmap'}{$tagname}) or next;
  307       $scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate
  308       print $fh $scratch;
  309       
  310       if ($tagname eq 'item-number') {
  311         print $fh $token->attr('number'), ". \n";
  312       } elsif ($tagname eq 'item-bullet') {
  313         print $fh "\\'", ord("_"), "\n";
  314         #for funky testing: print $fh '', rtf_esc("\x{4E4B}\x{9053}");
  315       }
  316 
  317     } elsif( $type eq 'end' ) {
  318       DEBUG > 1 and print STDERR "  -$type ",$token->tagname,"\n";
  319       if( ($tagname = $token->tagname) =~ m/^over-/s ) {
  320         DEBUG and print STDERR "Indenting back $indent_stack[-1] twips.\n";
  321         $self->{'rtfindent'} -= pop @indent_stack;
  322         pop @stack;
  323       } elsif( $tagname eq 'Verbatim' or $tagname eq 'VerbatimFormatted') {
  324         --$self->{'rtfverbatim'};
  325       }
  326       defined($scratch = $self->{'Tagmap'}{"/$tagname"}) or next;
  327       $scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate
  328       print $fh $scratch;
  329     }
  330   }
  331   return 1;
  332 }
  333 
  334 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  335 sub do_beginning {
  336   my $self = $_[0];
  337   my $fh = $self->{'output_fh'};
  338   return print $fh join '',
  339     $self->doc_init,
  340     $self->font_table,
  341     $self->stylesheet,
  342     $self->color_table,
  343     $self->doc_info,
  344     $self->doc_start,
  345     "\n"
  346   ;
  347 }
  348 
  349 sub do_end {
  350   my $self = $_[0];
  351   my $fh = $self->{'output_fh'};
  352   return print $fh '}'; # that should do it
  353 }
  354 
  355 ###########################################################################
  356 
  357 sub stylesheet {
  358   return sprintf <<'END',
  359 {\stylesheet
  360 {\snext0 Normal;}
  361 {\*\cs10 \additive Default Paragraph Font;}
  362 {\*\cs16 \additive \i \sbasedon10 pod-I;}
  363 {\*\cs17 \additive \i\lang1024\noproof \sbasedon10 pod-F;}
  364 {\*\cs18 \additive \b \sbasedon10 pod-B;}
  365 {\*\cs19 \additive \f1\lang1024\noproof\sbasedon10 pod-C;}
  366 {\s20\ql \li0\ri0\sa180\widctlpar\f1\fs%s\lang1024\noproof\sbasedon0 \snext0 pod-codeblock;}
  367 {\*\cs21 \additive \lang1024\noproof \sbasedon10 pod-computerese;}
  368 {\*\cs22 \additive \i\lang1024\noproof\sbasedon10 pod-L-pod;}
  369 {\*\cs23 \additive \i\lang1024\noproof\sbasedon10 pod-L-url;}
  370 {\*\cs24 \additive \i\lang1024\noproof\sbasedon10 pod-L-man;}
  371 
  372 {\*\cs25 \additive \f1\lang1024\noproof\sbasedon0 pod-codelbock-plain;}
  373 {\*\cs26 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-ital;}
  374 {\*\cs27 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold;}
  375 {\*\cs28 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold-ital;}
  376 
  377 {\s31\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head1;}
  378 {\s32\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head2;}
  379 {\s33\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head3;}
  380 {\s34\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head4;}
  381 }
  382 
  383 END
  384 
  385    $_[0]->codeblock_halfpoint_size(),
  386    $_[0]->head1_halfpoint_size(),
  387    $_[0]->head2_halfpoint_size(),
  388    $_[0]->head3_halfpoint_size(),
  389    $_[0]->head4_halfpoint_size(),
  390   ;
  391 }
  392 
  393 ###########################################################################
  394 # Override these as necessary for further customization
  395 
  396 sub font_table {
  397   return <<'END';  # text font, code font, heading font
  398 {\fonttbl
  399 {\f0\froman Times New Roman;}
  400 {\f1\fmodern Courier New;}
  401 {\f2\fswiss Arial;}
  402 }
  403 
  404 END
  405 }
  406 
  407 sub doc_init {
  408    return <<'END';
  409 {\rtf1\ansi\deff0
  410 
  411 END
  412 }
  413 
  414 sub color_table {
  415    return <<'END';
  416 {\colortbl;\red255\green0\blue0;\red0\green0\blue255;}
  417 END
  418 }
  419 
  420 
  421 sub doc_info {
  422    my $self = $_[0];
  423 
  424    my $class = ref($self) || $self;
  425 
  426    my $tag = __PACKAGE__ . ' ' . $VERSION;
  427    
  428    unless($class eq __PACKAGE__) {
  429      $tag = " ($tag)";
  430      $tag = " v" . $self->VERSION . $tag   if   defined $self->VERSION;
  431      $tag = $class . $tag;
  432    }
  433 
  434    return sprintf <<'END',
  435 {\info{\doccomm
  436 %s
  437  using %s v%s
  438  under Perl v%s at %s GMT}
  439 {\author [see doc]}{\company [see doc]}{\operator [see doc]}
  440 }
  441 
  442 END
  443 
  444   # None of the following things should need escaping, I dare say!
  445     $tag, 
  446     $ISA[0], $ISA[0]->VERSION(),
  447     $], scalar(gmtime),
  448   ;
  449 }
  450 
  451 sub doc_start {
  452   my $self = $_[0];
  453   my $title = $self->get_short_title();
  454   DEBUG and print STDERR "Short Title: <$title>\n";
  455   $title .= ' ' if length $title;
  456   
  457   $title =~ s/ *$/ /s;
  458   $title =~ s/^ //s;
  459   $title =~ s/ $/, /s;
  460    # make sure it ends in a comma and a space, unless it's 0-length
  461 
  462   my $is_obviously_module_name;
  463   $is_obviously_module_name = 1
  464    if $title =~ m/^\S+$/s and $title =~ m/::/s;
  465     # catches the most common case, at least
  466 
  467   DEBUG and print STDERR "Title0: <$title>\n";
  468   $title = rtf_esc($title);
  469   DEBUG and print STDERR "Title1: <$title>\n";
  470   $title = '\lang1024\noproof ' . $title
  471    if $is_obviously_module_name;
  472 
  473   return sprintf <<'END', 
  474 \deflang%s\plain\lang%s\widowctrl
  475 {\header\pard\qr\plain\f2\fs%s
  476 %s
  477 p.\chpgn\par}
  478 \fs%s
  479 
  480 END
  481     ($self->doc_lang) x 2,
  482     $self->header_halfpoint_size,
  483     $title,
  484     $self->normal_halfpoint_size,
  485   ;
  486 }
  487 
  488 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  489 #-------------------------------------------------------------------------
  490 
  491 use integer;
  492 sub rtf_esc {
  493   my $x; # scratch
  494   if(!defined wantarray) { # void context: alter in-place!
  495     for(@_) {
  496       s/([F${cntrl}\-\\\{\}${not_ascii}])/$Escape{$1}/g;  # ESCAPER
  497       s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  498     }
  499     return;
  500   } elsif(wantarray) {  # return an array
  501     return map {; ($x = $_) =~
  502       s/([F${cntrl}\-\\\{\}${not_ascii}])/$Escape{$1}/g;  # ESCAPER
  503       $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  504       $x;
  505     } @_;
  506   } else { # return a single scalar
  507     ($x = ((@_ == 1) ? $_[0] : join '', @_)
  508     ) =~ s/([F${cntrl}\-\\\{\}${not_ascii}])/$Escape{$1}/g;  # ESCAPER
  509              # Escape \, {, }, -, control chars, and 7f-ff.
  510     $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  511     return $x;
  512   }
  513 }
  514 
  515 sub rtf_esc_codely {
  516   # Doesn't change "-" to hard-hyphen, nor apply computerese style-smarts.
  517   # We don't want to change the "-" to hard-hyphen, because we want to
  518   #  be able to paste this into a file and run it without there being
  519   #  dire screaming about the mysterious hard-hyphen character (which
  520   #  looks just like a normal dash character).
  521   
  522   my $x; # scratch
  523   if(!defined wantarray) { # void context: alter in-place!
  524     for(@_) {
  525       s/([F${cntrl}\\\{\}${not_ascii}])/$Escape{$1}/g;  # ESCAPER
  526       s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  527     }
  528     return;
  529   } elsif(wantarray) {  # return an array
  530     return map {; ($x = $_) =~
  531       s/([F${cntrl}\\\{\}${not_ascii}])/$Escape{$1}/g;  # ESCAPER
  532       $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  533       $x;
  534     } @_;
  535   } else { # return a single scalar
  536     ($x = ((@_ == 1) ? $_[0] : join '', @_)
  537     ) =~ s/([F${cntrl}\\\{\}${not_ascii}])/$Escape{$1}/g;  # ESCAPER
  538              # Escape \, {, }, -, control chars, and 7f-ff.
  539     $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  540     return $x;
  541   }
  542 }
  543 
  544 %Escape = (
  545   (($] lt 5.007_003) # Broken for non-ASCII on early Perls
  546    ? (map( (chr($_),chr($_)), # things not apparently needing escaping
  547        0x20 .. 0x7E ),
  548       map( (chr($_),sprintf("\\'%02x", $_)), # apparently escapeworthy things
  549        0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46))
  550    : (map( (chr(utf8::unicode_to_native($_)),chr(utf8::unicode_to_native($_))),
  551        0x20 .. 0x7E ),
  552       map( (chr($_),sprintf("\\'%02x", utf8::unicode_to_native($_))),
  553        0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46))),
  554 
  555   # We get to escape out 'F' so that we can send RTF files thru the mail
  556   # without the slightest worry that paragraphs beginning with "From"
  557   # will get munged.
  558 
  559   # And some refinements:
  560   "\r"  => "\n",
  561   "\cj"  => "\n",
  562   "\n"   => "\n\\line ",
  563 
  564   "\t"   => "\\tab ",     # Tabs (altho theoretically raw \t's are okay)
  565   "\f"   => "\n\\page\n", # Formfeed
  566   "-"    => "\\_",        # Turn plaintext '-' into a non-breaking hyphen
  567   $Pod::Simple::nbsp => "\\~",        # Latin-1 non-breaking space
  568   $Pod::Simple::shy => "\\-",        # Latin-1 soft (optional) hyphen
  569 
  570   # CRAZY HACKS:
  571   "\n" => "\\line\n",
  572   "\r" => "\n",
  573   "\cb" => "{\n\\cs21\\lang1024\\noproof ",  # \\cf1
  574   "\cc" => "}",
  575 );
  576 1;
  577 
  578 __END__
  579 
  580 =head1 NAME
  581 
  582 Pod::Simple::RTF -- format Pod as RTF
  583 
  584 =head1 SYNOPSIS
  585 
  586   perl -MPod::Simple::RTF -e \
  587    "exit Pod::Simple::RTF->filter(shift)->any_errata_seen" \
  588    thingy.pod > thingy.rtf
  589 
  590 =head1 DESCRIPTION
  591 
  592 This class is a formatter that takes Pod and renders it as RTF, good for
  593 viewing/printing in MSWord, WordPad/write.exe, TextEdit, etc.
  594 
  595 This is a subclass of L<Pod::Simple> and inherits all its methods.
  596 
  597 =head1 FORMAT CONTROL ATTRIBUTES
  598 
  599 You can set these attributes on the parser object before you
  600 call C<parse_file> (or a similar method) on it:
  601 
  602 =over
  603 
  604 =item $parser->head1_halfpoint_size( I<halfpoint_integer> );
  605 
  606 =item $parser->head2_halfpoint_size( I<halfpoint_integer> );
  607 
  608 =item $parser->head3_halfpoint_size( I<halfpoint_integer> );
  609 
  610 =item $parser->head4_halfpoint_size( I<halfpoint_integer> );
  611 
  612 These methods set the size (in half-points, like 52 for 26-point)
  613 that these heading levels will appear as.
  614 
  615 =item $parser->codeblock_halfpoint_size( I<halfpoint_integer> );
  616 
  617 This method sets the size (in half-points, like 21 for 10.5-point)
  618 that codeblocks ("verbatim sections") will appear as.
  619 
  620 =item $parser->header_halfpoint_size( I<halfpoint_integer> );
  621 
  622 This method sets the size (in half-points, like 15 for 7.5-point)
  623 that the header on each page will appear in.  The header
  624 is usually just "I<modulename> p. I<pagenumber>".
  625 
  626 =item $parser->normal_halfpoint_size( I<halfpoint_integer> );
  627 
  628 This method sets the size (in half-points, like 26 for 13-point)
  629 that normal paragraphic text will appear in.
  630 
  631 =item $parser->no_proofing_exemptions( I<true_or_false> );
  632 
  633 Set this value to true if you don't want the formatter to try
  634 putting a hidden code on all Perl symbols (as best as it can
  635 notice them) that labels them as being not in English, and
  636 so not worth spellchecking.
  637 
  638 =item $parser->doc_lang( I<microsoft_decimal_language_code> )
  639 
  640 This sets the language code to tag this document as being in. By
  641 default, it is currently the value of the environment variable
  642 C<RTFDEFLANG>, or if that's not set, then the value
  643 1033 (for US English).
  644 
  645 Setting this appropriately is useful if you want to use the RTF
  646 to spellcheck, and/or if you want it to hyphenate right.
  647 
  648 Here are some notable values:
  649 
  650   1033  US English
  651   2057  UK English
  652   3081  Australia English
  653   4105  Canada English
  654   1034  Spain Spanish
  655   2058  Mexico Spanish
  656   1031  Germany German
  657   1036  France French
  658   3084  Canada French
  659   1035  Finnish
  660   1044  Norwegian (Bokmal)
  661   2068  Norwegian (Nynorsk)
  662 
  663 =back
  664 
  665 If you are particularly interested in customizing this module's output
  666 even more, see the source and/or write to me.
  667 
  668 =head1 SEE ALSO
  669 
  670 L<Pod::Simple>, L<RTF::Writer>, L<RTF::Cookbook>, L<RTF::Document>,
  671 L<RTF::Generator>
  672 
  673 =head1 SUPPORT
  674 
  675 Questions or discussion about POD and Pod::Simple should be sent to the
  676 pod-people@perl.org mail list. Send an empty email to
  677 pod-people-subscribe@perl.org to subscribe.
  678 
  679 This module is managed in an open GitHub repository,
  680 L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
  681 to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
  682 
  683 Patches against Pod::Simple are welcome. Please send bug reports to
  684 <bug-pod-simple@rt.cpan.org>.
  685 
  686 =head1 COPYRIGHT AND DISCLAIMERS
  687 
  688 Copyright (c) 2002 Sean M. Burke.
  689 
  690 This library is free software; you can redistribute it and/or modify it
  691 under the same terms as Perl itself.
  692 
  693 This program is distributed in the hope that it will be useful, but
  694 without any warranty; without even the implied warranty of
  695 merchantability or fitness for a particular purpose.
  696 
  697 =head1 AUTHOR
  698 
  699 Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
  700 But don't bother him, he's retired.
  701 
  702 Pod::Simple is maintained by:
  703 
  704 =over
  705 
  706 =item * Allison Randal C<allison@perl.org>
  707 
  708 =item * Hans Dieter Pearcey C<hdp@cpan.org>
  709 
  710 =item * David E. Wheeler C<dwheeler@cpan.org>
  711 
  712 =back
  713 
  714 =cut