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