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