File Coverage

blib/lib/Pod/Simple/RTF.pm
Criterion Covered Total %
statement 137 180 76.1
branch 52 100 52.0
condition 12 37 32.4
subroutine 23 23 100.0
pod 1 14 7.1
total 225 354 63.5


line stmt bran cond sub pod time code
1             package Pod::Simple::RTF;
2 3     3   5799 use strict;
  3         6  
  3         100  
3 3     3   16 use warnings;
  3         5  
  3         142  
4              
5             #sub DEBUG () {4};
6             #sub Pod::Simple::DEBUG () {4};
7             #sub Pod::Simple::PullParser::DEBUG () {4};
8              
9             our $VERSION = '3.45';
10 3     3   568 use Pod::Simple::PullParser ();
  3         6  
  3         103  
11             our @ISA;
12 3     3   181 BEGIN {@ISA = ('Pod::Simple::PullParser')}
13              
14 3     3   20 use Carp ();
  3         6  
  3         127  
15 3 50   3   9581 BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
16              
17             sub to_uni ($) { # Convert native code point to Unicode
18 270     270 0 465 my $x = shift;
19              
20             # Broken for early EBCDICs
21 270 50 50     976 $x = chr utf8::native_to_unicode(ord $x) if $] ge 5.007_003
22             && ord("A") != 65;
23 270         1248 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 '_'
29             my $map_to_self = ' !"#$%&\'()*+,-./0123456789:;<=>?@ABCDEGHIJKLMNOPQRSTUVWXYZ[]^`abcdefghijklmnopqrstuvwxyz|~';
30              
31             our $WRAP;
32             $WRAP = 1 unless defined $WRAP;
33             our %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.
64             my $escaped_sans_hyphen = "";
65             $escaped_sans_hyphen .= $_ for grep { $_ ne $Escape{$_} && $_ ne '-' }
66             sort keys %Escape;
67             my $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              
75             sub _openclose {
76 3     3   6 return map {;
77 72 50       214 m/^([-A-Za-z]+)=(\w[^\=]*)$/s or die "what's <$_>?";
78 72         360 ( $1, "{\\$2\n", "/$1", "}" );
79             } @_;
80             }
81              
82             my @_to_accept;
83              
84             our %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             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
147             sub new {
148 3     3 1 1073 my $new = shift->SUPER::new(@_);
149 3         14 $new->nix_X_codes(1);
150 3         14 $new->nbsp_for_S(1);
151 3         11 $new->accept_targets( 'rtf', 'RTF' );
152              
153 3         84 $new->{'Tagmap'} = {%Tagmap};
154              
155 3         29 $new->accept_codes(@_to_accept);
156 3         11 $new->accept_codes('VerbatimFormatted');
157 3         4 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 3 50 50     38 : ($ENV{'RTFDEFLANG'} || '') =~ m/^([a-fA-F0-9]{4})$/s ? hex($1)
    50 50        
    50 50        
163             # yes, tolerate even more hex!
164             : '1033'
165             );
166              
167 3         8 $new->head1_halfpoint_size(32);
168 3         8 $new->head2_halfpoint_size(28);
169 3         55 $new->head3_halfpoint_size(25);
170 3         8 $new->head4_halfpoint_size(22);
171 3         10 $new->codeblock_halfpoint_size(18);
172 3         7 $new->header_halfpoint_size(17);
173 3         7 $new->normal_halfpoint_size(25);
174              
175 3         35 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             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
194             sub run {
195 3     3 0 5 my $self = $_[0];
196 3 50       17 return $self->do_middle if $self->bare_output;
197             return
198 3   33     7 $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
206             my $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              
211             sub do_middle { # the main work
212 3     3 0 6 my $self = $_[0];
213 3         16 my $fh = $self->{'output_fh'};
214              
215 3         24 my($token, $type, $tagname, $scratch);
216 3         0 my @stack;
217 3         0 my @indent_stack;
218 3 50       10 $self->{'rtfindent'} = 0 unless defined $self->{'rtfindent'};
219              
220 3         11 while($token = $self->get_token) {
221              
222 63 100       150 if( ($type = $token->type) eq 'text' ) {
    100          
    50          
223 19 100       39 if( $self->{'rtfverbatim'} ) {
224 1         2 DEBUG > 1 and print STDERR " $type " , $token->text, " in verbatim!\n";
225 1         3 rtf_esc(0, $scratch = $token->text); # 0 => Don't escape hyphen
226 1         5 print $fh $scratch;
227 1         5 next;
228             }
229              
230 18         24 DEBUG > 1 and print STDERR " $type " , $token->text, "\n";
231              
232 18         47 $scratch = $token->text;
233 18         82 $scratch =~ tr/\t\cb\cc/ /d;
234              
235 18 50       471 $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 18         717 rtf_esc(1, $scratch); # 1 => escape hyphen
255 18 50       185 $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 18         63 print $fh $scratch;
266              
267             } elsif( $type eq 'start' ) {
268             DEBUG > 1 and print STDERR " +$type ",$token->tagname,
269 22         29 " (", map("<$_> ", %{$token->attr_hash}), ")\n";
270              
271 22 100 66     48 if( ($tagname = $token->tagname) eq 'Verbatim'
    50          
    50          
    50          
    50          
272             or $tagname eq 'VerbatimFormatted'
273             ) {
274 1         3 ++$self->{'rtfverbatim'};
275 1         3 my $next = $self->get_token;
276 1 50       4 next unless defined $next;
277 1         1 my $line_count = 1;
278 1 50       3 if($next->type eq 'text') {
279 1         4 my $t = $next->text_r;
280 1         8 while( $$t =~ m/$/mg ) {
281 15 100       42 last if ++$line_count > 15; # no point in counting further
282             }
283 1         2 DEBUG > 3 and print STDERR " verbatim line count: $line_count\n";
284             }
285 1         3 $self->unget_token($next);
286 1 50       4 $self->{'rtfkeep'} = ($line_count > 15) ? '' : '\keepn' ;
287              
288             } elsif( $tagname =~ m/^item-/s ) {
289 0         0 my @to_unget;
290 0         0 my $text_count_here = 0;
291 0         0 $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 0         0 while(1) {
298 0         0 push @to_unget, $self->get_token;
299 0 0       0 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 0 0 0     0 if($to_unget[-1]->type eq 'text') {
    0 0        
    0          
304 0 0       0 if( ($text_count_here += length ${$to_unget[-1]->text_r}) > 150 ){
  0         0  
305 0         0 DEBUG > 1 and print STDERR " item-* is too long to be keepn'd.\n";
306 0         0 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 0 0 0     0 $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 0         0 $self->{'rtfitemkeepn'} ? "gets" : "doesn't get";
321 0         0 last;
322             } elsif (@to_unget > 40) {
323 0         0 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 0         0 last; # give up
328             }
329             # else keep while'ing along
330             }
331             # Now put it aaaaall back...
332 0         0 $self->unget_token(@to_unget);
333              
334             } elsif( $tagname =~ m/^over-/s ) {
335 0         0 push @stack, $1;
336 0         0 push @indent_stack,
337             int($token->attr('indent') * 4 * $self->normal_halfpoint_size);
338 0         0 DEBUG and print STDERR "Indenting over $indent_stack[-1] twips.\n";
339 0         0 $self->{'rtfindent'} += $indent_stack[-1];
340              
341             } elsif ($tagname eq 'L') {
342 0   0     0 $tagname .= '=' . ($token->attr('type') || 'pod');
343              
344             } elsif ($tagname eq 'Data') {
345 0         0 my $next = $self->get_token;
346 0 0       0 next unless defined $next;
347 0 0       0 unless( $next->type eq 'text' ) {
348 0         0 $self->unget_token($next);
349 0         0 next;
350             }
351 0         0 DEBUG and print STDERR " raw text ", $next->text, "\n";
352 0         0 printf $fh "\n" . $next->text . "\n";
353 0         0 next;
354             }
355              
356 22 100       71 defined($scratch = $self->{'Tagmap'}{$tagname}) or next;
357 19         104 $scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate
  26         98  
358 19         61 print $fh $scratch;
359              
360 19 50       93 if ($tagname eq 'item-number') {
    50          
361 0         0 print $fh $token->attr('number'), ". \n";
362             } elsif ($tagname eq 'item-bullet') {
363 0         0 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 22         27 DEBUG > 1 and print STDERR " -$type ",$token->tagname,"\n";
369 22 50 66     49 if( ($tagname = $token->tagname) =~ m/^over-/s ) {
    100          
370 0         0 DEBUG and print STDERR "Indenting back $indent_stack[-1] twips.\n";
371 0         0 $self->{'rtfindent'} -= pop @indent_stack;
372 0         0 pop @stack;
373             } elsif( $tagname eq 'Verbatim' or $tagname eq 'VerbatimFormatted') {
374 1         2 --$self->{'rtfverbatim'};
375             }
376 22 100       80 defined($scratch = $self->{'Tagmap'}{"/$tagname"}) or next;
377 19         37 $scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate
  0         0  
378 19         42 print $fh $scratch;
379             }
380             }
381 3         22 return 1;
382             }
383              
384             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
385             sub do_beginning {
386 3     3 0 6 my $self = $_[0];
387 3         5 my $fh = $self->{'output_fh'};
388 3         6 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              
399             sub do_end {
400 3     3 0 16 my $self = $_[0];
401 3         6 my $fh = $self->{'output_fh'};
402 3         10 return print $fh '}'; # that should do it
403             }
404              
405             ###########################################################################
406              
407             sub stylesheet {
408 3     3 0 8 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              
433             END
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              
446             sub font_table {
447 3     3 0 6 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              
454             END
455             }
456              
457             sub doc_init {
458 3     3 0 9 return <<'END';
459             {\rtf1\ansi\deff0
460              
461             END
462             }
463              
464             sub color_table {
465 3     3 0 11 return <<'END';
466             {\colortbl;\red255\green0\blue0;\red0\green0\blue255;}
467             END
468             }
469              
470              
471             sub doc_info {
472 3     3 0 6 my $self = $_[0];
473              
474 3   33     8 my $class = ref($self) || $self;
475              
476 3         8 my $tag = __PACKAGE__ . ' ' . $VERSION;
477              
478 3 50       8 unless($class eq __PACKAGE__) {
479 0         0 $tag = " ($tag)";
480 0 0       0 $tag = " v" . $self->VERSION . $tag if defined $self->VERSION;
481 0         0 $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              
492             END
493              
494             # None of the following things should need escaping, I dare say!
495             $tag,
496             $ISA[0], $ISA[0]->VERSION(),
497 3   33     109 $], scalar(gmtime($ENV{SOURCE_DATE_EPOCH} || time)),
498             ;
499             }
500              
501             sub doc_start {
502 3     3 0 8 my $self = $_[0];
503 3         14 my $title = $self->get_short_title();
504 3         7 DEBUG and print STDERR "Short Title: <$title>\n";
505 3 50       12 $title .= ' ' if length $title;
506              
507 3         25 $title =~ s/ *$/ /s;
508 3         7 $title =~ s/^ //s;
509 3         11 $title =~ s/ $/, /s;
510             # make sure it ends in a comma and a space, unless it's 0-length
511              
512 3         5 my $is_obviously_module_name;
513 3 50 33     17 $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 3         4 DEBUG and print STDERR "Title0: <$title>\n";
518 3         19 $title = rtf_esc(1, $title); # 1 => escape hyphen
519 3         4 DEBUG and print STDERR "Title1: <$title>\n";
520 3 50       13 $title = '\lang1024\noproof ' . $title
521             if $is_obviously_module_name;
522              
523 3         12 return sprintf <<'END',
524             \deflang%s\plain\lang%s\widowctrl
525             {\header\pard\qr\plain\f2\fs%s
526             %s
527             p.\chpgn\par}
528             \fs%s
529              
530             END
531             ($self->doc_lang) x 2,
532             $self->header_halfpoint_size,
533             $title,
534             $self->normal_halfpoint_size,
535             ;
536             }
537              
538             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
539             #-------------------------------------------------------------------------
540              
541 3     3   30 use integer;
  3         6  
  3         41  
542              
543             my $question_mark_code_points =
544             Pod::Simple::BlackBox::my_qr('([^\x00-\x{D7FF}\x{E000}-\x{10FFFF}])',
545             "\x{110000}");
546             my $plane0 =
547             Pod::Simple::BlackBox::my_qr('([\x{100}-\x{FFFF}])', "\x{100}");
548             my $other_unicode =
549             Pod::Simple::BlackBox::my_qr('([\x{10000}-\x{10FFFF}])', "\x{10000}");
550              
551             sub esc_uni($) {
552 3     3   305 use if $] le 5.006002, 'utf8';
  3         7  
  3         34  
553              
554 22     22 0 35 my $x = shift;
555              
556             # The output is expected to be UTF-16. Surrogates and above-Unicode get
557             # mapped to '?'
558 22 50       124 $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 22 100       112 $x =~ s/$plane0/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg
  69 50       272  
563             if $plane0;
564              
565             # Use surrogate pairs for the rest
566 22 50       173 $x =~ s/$other_unicode/'\\uc1\\u' . ((ord($1) >> 10) + 0xD7C0 - 65536) . '\\u' . (((ord$1) & 0x03FF) + 0xDC00 - 65536) . '?'/eg if $other_unicode;
  2         28  
567              
568 22         68 return $x;
569             }
570              
571             sub rtf_esc ($$) {
572             # The parameter is true if we should escape hyphens
573 22 100   22 0 47 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 22         31 my $x; # scratch
584 22 100       44 if(!defined wantarray) { # void context: alter in-place!
    50          
585 19         33 for(@_) {
586 19         334 s/($escape_re)/$Escape{$1}/g; # ESCAPER
587 19         43 $_ = esc_uni($_);
588             }
589 19         44 return;
590             } elsif(wantarray) { # return an array
591 0         0 return map {; ($x = $_) =~
  0         0  
592             s/($escape_re)/$Escape{$1}/g; # ESCAPER
593 0         0 $x = esc_uni($x);
594 0         0 $x;
595             } @_;
596             } else { # return a single scalar
597 3 50       110 ($x = ((@_ == 1) ? $_[0] : join '', @_)
598             ) =~ s/($escape_re)/$Escape{$1}/g; # ESCAPER
599             # Escape \, {, }, -, control chars, and 7f-ff.
600 3         13 $x = esc_uni($x);
601 3         10 return $x;
602             }
603             }
604              
605             1;
606              
607             __END__