File Coverage

blib/lib/HTML/FormatRTF.pm
Criterion Covered Total %
statement 111 148 75.0
branch 22 54 40.7
condition 6 12 50.0
subroutine 34 45 75.5
pod 0 40 0.0
total 173 299 57.8


line stmt bran cond sub pod time code
1             package HTML::FormatRTF;
2              
3             # ABSTRACT: Format HTML as RTF
4              
5              
6 1     1   816 use 5.006_001;
  1         3  
7 1     1   4 use strict;
  1         2  
  1         22  
8 1     1   5 use warnings;
  1         2  
  1         34  
9              
10             # We now use Smart::Comments in place of the old DEBUG framework.
11             # this should be commented out in release versions....
12             ##use Smart::Comments;
13              
14 1     1   4 use base 'HTML::Formatter';
  1         2  
  1         480  
15              
16             our $VERSION = '2.16'; # VERSION
17             our $AUTHORITY = 'cpan:NIGELM'; # AUTHORITY
18              
19             # ------------------------------------------------------------------------
20             my %Escape = (
21             map( ( chr($_), chr($_) ), # things not apparently needing escaping
22             0x20 .. 0x7E ),
23             map( ( chr($_), sprintf( "\\'%02x", $_ ) ), # apparently escapeworthy things
24             0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46 ),
25              
26             # We get to escape out 'F' so that we can send RTF files thru the mail
27             # without the slightest worry that paragraphs beginning with "From"
28             # will get munged.
29              
30             # And some refinements:
31             #"\n" => "\n\\line ",
32             #"\cm" => "\n\\line ",
33             #"\cj" => "\n\\line ",
34              
35             "\t" => "\\tab ", # Tabs (altho theoretically raw \t's are okay)
36              
37             # "\f" => "\n\\page\n", # Formfeed
38             "-" => "\\_", # Turn plaintext '-' into a non-breaking hyphen
39             "\xA0" => "\\~", # Latin-1 non-breaking space
40             "\xAD" => "\\-", # Latin-1 soft (optional) hyphen
41              
42             # CRAZY HACKS:
43             "\n" => "\\line\n",
44             "\r" => "\n",
45              
46             # "\cb" => "{\n\\cs21\\lang1024\\noproof ", # \\cf1
47             # "\cc" => "}",
48             );
49              
50             # ------------------------------------------------------------------------
51             sub default_values {
52 3     3 0 12 ( shift->SUPER::default_values(),
53             'lm' => 0, # left margin
54             'rm' => 0, # right margin (actually, maximum text width)
55              
56             'head1_halfpoint_size' => 32,
57             'head2_halfpoint_size' => 28,
58             'head3_halfpoint_size' => 25,
59             'head4_halfpoint_size' => 22,
60             'head5_halfpoint_size' => 20,
61             'head6_halfpoint_size' => 18,
62             'codeblock_halfpoint_size' => 18,
63             'header_halfpoint_size' => 17,
64             'normal_halfpoint_size' => 22,
65             );
66             }
67              
68             # ------------------------------------------------------------------------
69             sub configure {
70 1     1 0 2 my ( $self, $hash ) = shift;
71              
72 1         7 $self->{lm} = 0;
73 1         1 $self->{rm} = 0;
74              
75             # include the hash parameters into self - as RT#56278
76 1 50       7 map { $self->{$_} = $hash->{$_} } keys %$hash if ( ref($hash) );
  0         0  
77 1         2 $self;
78             }
79              
80             # ------------------------------------------------------------------------
81             sub begin {
82 1     1 0 2 my $self = shift;
83              
84             ### Start document...
85 1         6 $self->SUPER::begin;
86              
87             $self->collect( $self->doc_init, $self->font_table, $self->stylesheet, $self->color_table, $self->doc_info,
88             $self->doc_really_start, "\n" )
89 1 50       7 unless $self->{'no_prolog'};
90              
91 1         2 $self->{'Para'} = '';
92 1         2 $self->{'quotelevel'} = 0;
93              
94 1         2 return;
95             }
96              
97             # ------------------------------------------------------------------------
98             sub end {
99 1     1 0 2 my $self = shift;
100              
101 1         3 $self->vspace(0);
102 1         3 $self->out('THIS IS NEVER SEEN');
103              
104             # just to force the previous para to be written out.
105 1 50       5 $self->collect("}") unless $self->{'no_trailer'}; # ends the document
106              
107             ### End document...
108 1         2 return;
109             }
110              
111             # ------------------------------------------------------------------------
112             sub vspace {
113 41     41 0 40 my $self = shift;
114              
115             #$self->emit_para if defined $self->{'vspace'};
116 41         82 my $rv = $self->SUPER::vspace(@_);
117 41 50       110 $self->emit_para if defined $self->{'vspace'};
118 41         60 $rv;
119             }
120              
121             # ------------------------------------------------------------------------
122             sub stylesheet {
123              
124             # TODO: maybe actually /use/ the character styles?
125              
126             return sprintf <<'END', # snazzy styles
127             {\stylesheet
128             {\snext0 Normal;}
129             {\*\cs1 \additive Default Paragraph Font;}
130             {\*\cs2 \additive \i\sbasedon1 html-ital;}
131             {\*\cs3 \additive \b\sbasedon1 html-bold;}
132             {\*\cs4 \additive \f1\sbasedon1 html-code;}
133              
134             {\s20\ql \f1\fs%s\lang1024\noproof\sbasedon0 \snext0 html-pre;}
135              
136             {\s31\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 html-head1;}
137             {\s32\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 html-head2;}
138             {\s33\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 html-head3;}
139             {\s34\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 html-head4;}
140             {\s35\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 html-head5;}
141             {\s36\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 html-head6;}
142             }
143              
144             END
145              
146 1         14 @{ $_[0] }{
147 1     1 0 3 qw<
148             codeblock_halfpoint_size
149             head1_halfpoint_size
150             head2_halfpoint_size
151             head3_halfpoint_size
152             head4_halfpoint_size
153             head5_halfpoint_size
154             head6_halfpoint_size
155             >
156             };
157             }
158              
159             # ------------------------------------------------------------------------
160             # Override these as necessary for further customization
161              
162             sub font_table {
163 1     1 0 2 my $self = shift;
164              
165             return sprintf <<'END' , # text font, code font, heading font
166             {\fonttbl
167             {\f0\froman %s;}
168             {\f1\fmodern %s;}
169             {\f2\fswiss %s;}
170             }
171              
172             END
173              
174             map {
175             ; # custom-dumb escaper:
176 3         3 my $x = $_;
177 3         5 $x =~ s/([\x00-\x1F\\\{\}\x7F-\xFF])/sprintf("\\'%02x", $1)/g;
178 3 0       4 $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  0         0  
179 3         9 $x;
180             }
181             $self->{'fontname_body'} || 'Times',
182             $self->{'fontname_code'} || 'Courier New',
183 1   50     13 $self->{'fontname_headings'} || 'Arial',
      50        
      50        
184             ;
185             }
186              
187             # ------------------------------------------------------------------------
188             sub doc_init {
189 1     1 0 4 return <<'END';
190             {\rtf1\ansi\deff0
191              
192             END
193             }
194              
195             # ------------------------------------------------------------------------
196             sub color_table {
197 1     1 0 4 return <<'END';
198             {\colortbl;\red255\green0\blue0;\red0\green0\blue255;}
199             END
200             }
201              
202             # ------------------------------------------------------------------------
203             sub doc_info {
204 1     1 0 3 my $self = $_[0];
205              
206 1         6 return sprintf <<'END', $self->version_tag;
207             {\info{\doccomm generated by %s}
208             {\author [see doc]}{\company [see doc]}{\operator [see doc]}
209             }
210              
211             END
212              
213             }
214              
215             # ------------------------------------------------------------------------
216             sub doc_really_start {
217 1     1 0 2 my $self = $_[0];
218              
219             return sprintf <<'END',
220             \deflang%s\widowctrl
221             {\header\pard\qr\plain\f2\fs%s
222             p.\chpgn\par}
223             \fs%s
224              
225             END
226 1   50     13 $self->{'document_language'} || 1033, $self->{"header_halfpoint_size"}, $self->{"normal_halfpoint_size"},;
227             }
228              
229             # ------------------------------------------------------------------------
230             sub emit_para { # rather like showline in FormatPS
231 57     57 0 50 my $self = shift;
232              
233 57         53 my $para = $self->{'Para'};
234 57         53 $self->{'Para'} = undef;
235              
236             #### emit_para called by: (caller(1) )[3];
237              
238 57 100       89 unless ( defined $para ) {
239             #### emit_para with empty buffer...
240 36         38 return;
241             }
242              
243 21         35 $para =~ s/^ +//s;
244 21         102 $para =~ s/ +$//s;
245              
246             # And now: a not terribly clever algorithm for inserting newlines
247             # at a guaranteed harmless place: after a block of whitespace
248             # after the 65th column. This was copied from RTF::Writer.
249 21         127 $para =~ s/(
250             [^\cm\cj\n]{65} # Snare 65 characters from a line
251             [^\cm\cj\n\x20]{0,50} # and finish any current word
252             )
253             (\x20{1,10})(?![\cm\cj\n]) # capture some spaces not at line-end
254             /$1$2\n/gx # and put a NL before those spaces
255             ;
256              
257             $self->collect(
258             sprintf(
259             '{\pard\sa%d\li%d\ri%d%s\plain' . "\n",
260              
261             #100 +
262             10 * $self->{'normal_halfpoint_size'} * ( $self->{'vspace'} || 0 ),
263              
264             $self->{'lm'},
265             $self->{'rm'},
266              
267             $self->{'center'} ? '\qc' : '\ql',
268             ),
269              
270             defined( $self->{'next_bullet'} )
271 21 50 50     184 ? do {
    100          
272 4         5 my $bullet = $self->{'next_bullet'};
273 4         3 $self->{'next_bullet'} = undef;
274             sprintf "\\fi-%d\n%s",
275 4 100       21 4.5 * $self->{'normal_halfpoint_size'},
276             ( $bullet eq '*' ) ? "\\'95 " : ( rtf_esc($bullet) . ". " );
277             }
278             : (),
279              
280             $para,
281             "\n\\par}\n\n",
282             );
283              
284 21         21 $self->{'vspace'} = undef; # we finally get to clear it here!
285              
286 21         30 return;
287             }
288              
289             # ------------------------------------------------------------------------
290             sub new_font_size {
291 0     0 0 0 my $self = $_[0];
292              
293 0         0 $self->out( \sprintf "{\\fs%u\n", $self->scale_font_for( $self->{'normal_halfpoint_size'} ) );
294             }
295              
296             # ------------------------------------------------------------------------
297 0     0 0 0 sub restore_font_size { shift->out( \'}' ) }
298              
299             # ------------------------------------------------------------------------
300             sub hr_start {
301 1     1 0 1 my $self = shift;
302              
303             # A bit of a hack:
304              
305 1         2 $self->vspace(.3);
306 1   50     10 $self->out( \( '\qc\ul\f1\fs20\nocheck\lang1024 ' . ( '\~' x ( $self->{'hr_width'} || 50 ) ) ) );
307 1         2 $self->vspace(.7);
308 1         2 1;
309             }
310              
311             # ------------------------------------------------------------------------
312              
313             sub br_start {
314 0     0 0 0 $_[0]->out( \"\\line\n" );
315             }
316              
317             # ------------------------------------------------------------------------
318             sub header_start {
319 2     2 0 3 my ( $self, $level ) = @_;
320              
321             # for h1 ... h6's
322             # This really should have been called heading_start, but it's too late
323             # to change now.
324              
325             ### Heading of level: $level
326             #$self->adjust_lm(0); # assert new paragraph
327 2         5 $self->vspace(1.5);
328              
329             ## TODO: work out why that extra $level was there and what its for
330             $self->out(
331 2         13 \( sprintf '\s3%s\ql\keepn\f2\fs%s\ul' . "\n", $level, $self->{ 'head' . $level . '_halfpoint_size' }, #$level,
332             )
333             );
334              
335 2         5 return 1;
336             }
337              
338             # ------------------------------------------------------------------------
339             sub header_end {
340              
341             # This really should have been called heading_end but it's too late
342             # to change now.
343              
344 2     2 0 10 $_[0]->vspace(1);
345 2         5 1;
346             }
347              
348             # ------------------------------------------------------------------------
349             sub bullet {
350 4     4 0 48 my ( $self, $bullet ) = @_;
351              
352 4         6 $self->{'next_bullet'} = $bullet;
353 4         5 return;
354             }
355              
356             # ------------------------------------------------------------------------
357             sub adjust_lm {
358 14     14 0 19 $_[0]->emit_para();
359 14         19 $_[0]->{'lm'} += $_[1] * $_[0]->{'normal_halfpoint_size'} * 5;
360 14         19 1;
361             }
362              
363             # ------------------------------------------------------------------------
364             sub adjust_rm {
365 2     2 0 3 $_[0]->emit_para();
366 2         3 $_[0]->{'rm'} -= $_[1] * $_[0]->{'normal_halfpoint_size'} * 5;
367 2         4 1;
368             } # Yes, flip the sign on the right margin!
369              
370             # BTW, halfpoints * 10 = twips
371              
372             # ------------------------------------------------------------------------
373             sub pre_start {
374 1     1 0 2 my $self = shift;
375              
376 1         6 $self->SUPER::pre_start(@_);
377 1         4 $self->out( \sprintf '\s20\f1\fs%s\noproof\lang1024\lang1076 ', $self->{'codeblock_halfpoint_size'}, );
378 1         2 return 1;
379             }
380              
381             # ------------------------------------------------------------------------
382 1     1 0 2 sub b_start { shift->out( \'{\b ' ) }
383 1     1 0 3 sub b_end { shift->out( \'}' ) }
384 1     1 0 2 sub i_start { shift->out( \'{\i ' ) }
385 1     1 0 3 sub i_end { shift->out( \'}' ) }
386 1     1 0 3 sub tt_start { shift->out( \'{\f1\noproof\lang1024\lang1076 ' ) }
387 1     1 0 3 sub tt_end { shift->out( \'}' ) }
388 0     0 0 0 sub sub_start { shift->out( \'{\sub ' ) }
389 0     0 0 0 sub sub_end { shift->out( \'}' ) }
390 0     0 0 0 sub sup_start { shift->out( \'{\super ' ) }
391 0     0 0 0 sub sup_end { shift->out( \'}' ) }
392 0     0 0 0 sub strike_start { shift->out( \'{\strike ' ) }
393 0     0 0 0 sub strike_end { shift->out( \'}' ) }
394              
395             # ------------------------------------------------------------------------
396             sub q_start {
397 0     0 0 0 my $self = $_[0];
398              
399 0 0       0 $self->out( ( ( ++$self->{'quotelevel'} ) % 2 ) ? \'\ldblquote ' : \'\lquote ' );
400             }
401              
402             # ------------------------------------------------------------------------
403             sub q_end {
404 0     0 0 0 my $self = $_[0];
405              
406 0 0       0 $self->out( ( ( --$self->{'quotelevel'} ) % 2 ) ? \'\rquote ' : \'\rdblquote ' );
407             }
408              
409             # ------------------------------------------------------------------------
410 1 50   1 0 5 sub pre_out { $_[0]->out( ref( $_[1] ) ? $_[1] : \rtf_esc_codely( $_[1] ) ) }
411              
412             # ------------------------------------------------------------------------
413             sub out { # output a word (or, if escaped, chunk of RTF)
414 755     755 0 596 my $self = shift;
415              
416             #return $self->pre_out(@_) if $self->{pre};
417              
418             #### out called by: $_[0], (caller(1) )[3]
419              
420 755 50       1005 return unless defined $_[0]; # and length $_[0];
421              
422 755 100       1107 $self->{'Para'} = '' unless defined $self->{'Para'};
423 755 100       1129 $self->{'Para'} .= ref( $_[0] ) ? ${ $_[0] } : rtf_esc( $_[0] );
  11         16  
424              
425 755         1157 return 1;
426             }
427              
428             # ------------------------------------------------------------------------
429 1     1   15 use integer;
  1         2  
  1         6  
430              
431             sub rtf_esc {
432 746     746 0 501 my $x; # scratch
433 746 50       1113 if ( !defined wantarray ) { # void context: alter in-place!
    50          
434 0         0 for (@_) {
435 0         0 s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
436 0 0       0 s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  0         0  
437             }
438 0         0 return;
439             }
440             elsif (wantarray) { # return an array
441             return map {
442 0         0 ;
443 0         0 ( $x = $_ ) =~ s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
444 0 0       0 $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  0         0  
445              
446             # Hyper-escape all Unicode characters.
447 0         0 $x;
448             } @_;
449             }
450             else { # return a single scalar
451 746 50       1224 ( $x = ( ( @_ == 1 ) ? $_[0] : join '', @_ ) ) =~ s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
452             # Escape \, {, }, -, control chars, and 7f-ff.
453 746 0       612 $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  0         0  
454              
455             # Hyper-escape all Unicode characters.
456 746         942 return $x;
457             }
458             }
459              
460             # ------------------------------------------------------------------------
461             sub rtf_esc_codely {
462              
463             # Doesn't change "-" to hard-hyphen, nor apply computerese style
464              
465 1     1 0 2 my $x; # scratch
466 1 50       4 if ( !defined wantarray ) { # void context: alter in-place!
    50          
467 0         0 for (@_) {
468 0         0 s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g;
469 0 0       0 s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  0         0  
470              
471             # Hyper-escape all Unicode characters.
472             }
473 0         0 return;
474             }
475             elsif (wantarray) { # return an array
476             return map {
477 1         2 ;
478 1         10 ( $x = $_ ) =~ s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g;
479 1 0       3 $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  0         0  
480              
481             # Hyper-escape all Unicode characters.
482 1         13 $x;
483             } @_;
484             }
485             else { # return a single scalar
486 0 0         ( $x = ( ( @_ == 1 ) ? $_[0] : join '', @_ ) ) =~ s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g;
487              
488             # Escape \, {, }, -, control chars, and 7f-ff.
489 0 0         $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  0            
490              
491             # Hyper-escape all Unicode characters.
492 0           return $x;
493             }
494             }
495              
496             1;
497              
498             __END__