File Coverage

blib/lib/HTML/FormatRTF.pm
Criterion Covered Total %
statement 112 149 75.1
branch 22 54 40.7
condition 6 12 50.0
subroutine 34 45 75.5
pod 0 40 0.0
total 174 300 58.0


line stmt bran cond sub pod time code
1             package HTML::FormatRTF;
2              
3             # ABSTRACT: Format HTML as RTF
4              
5              
6 1     1   21720 use 5.006_001;
  1         3  
  1         36  
7 1     1   11 use strict;
  1         2  
  1         29  
8 1     1   10 use warnings;
  1         2  
  1         30  
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   6 use base 'HTML::Formatter';
  1         1  
  1         656  
15              
16             our $VERSION = '2.11'; # 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 2     2 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 3 my ( $self, $hash ) = shift;
71              
72 1         7 $self->{lm} = 0;
73 1         2 $self->{rm} = 0;
74              
75             # include the hash parameters into self - as RT#56278
76 1 50       5 map { $self->{$_} = $hash->{$_} } keys %$hash if ( ref($hash) );
  0         0  
77 1         3 $self;
78             }
79              
80             # ------------------------------------------------------------------------
81             sub begin {
82 1     1 0 2 my $self = shift;
83              
84             ### Start document...
85 1         8 $self->SUPER::begin;
86              
87 1 50       6 $self->collect( $self->doc_init, $self->font_table, $self->stylesheet, $self->color_table, $self->doc_info,
88             $self->doc_really_start, "\n" )
89             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 1 my $self = shift;
100              
101 1         3 $self->vspace(0);
102 1         4 $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 41 my $self = shift;
114              
115             #$self->emit_para if defined $self->{'vspace'};
116 41         93 my $rv = $self->SUPER::vspace(@_);
117 41 50       110 $self->emit_para if defined $self->{'vspace'};
118 41         72 $rv;
119             }
120              
121             # ------------------------------------------------------------------------
122             sub stylesheet {
123              
124             # TODO: maybe actually /use/ the character styles?
125              
126 1         16 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             @{ $_[0] }{
147 1     1 0 2 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 1   50     12 ; # custom-dumb escaper:
      50        
      50        
176 3         5 my $x = $_;
177 3         4 $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         10 $x;
180             }
181             $self->{'fontname_body'} || 'Times',
182             $self->{'fontname_code'} || 'Courier New',
183             $self->{'fontname_headings'} || 'Arial',
184             ;
185             }
186              
187             # ------------------------------------------------------------------------
188             sub doc_init {
189 1     1 0 5 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 2 my $self = $_[0];
205              
206 1         7 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 1   50     13 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             $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 56 my $self = shift;
232              
233 57         69 my $para = $self->{'Para'};
234 57         67 $self->{'Para'} = undef;
235              
236             #### emit_para called by: (caller(1) )[3];
237              
238 57 100       88 unless ( defined $para ) {
239             #### emit_para with empty buffer...
240 36         46 return;
241             }
242              
243 21         32 $para =~ s/^ +//s;
244 21         113 $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         143 $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     165 ? do {
    100          
272 4         6 my $bullet = $self->{'next_bullet'};
273 4         4 $self->{'next_bullet'} = undef;
274 4 100       20 sprintf "\\fi-%d\n%s",
275             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         32 $self->{'vspace'} = undef; # we finally get to clear it here!
285              
286 21         29 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 2 my $self = shift;
302              
303             # A bit of a hack:
304              
305 1         31 $self->vspace(.3);
306 1   50     10 $self->out( \( '\qc\ul\f1\fs20\nocheck\lang1024 ' . ( '\~' x ( $self->{'hr_width'} || 50 ) ) ) );
307 1         3 $self->vspace(.7);
308 1         3 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 4 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         4 $self->vspace(1.5);
328              
329 2         14 $self->out(
330             \( sprintf '\s3%s\ql\keepn\f2\fs%s\ul' . "\n", $level, $self->{ 'head' . $level . '_halfpoint_size' }, $level,
331             )
332             );
333              
334 2         6 return 1;
335             }
336              
337             # ------------------------------------------------------------------------
338             sub header_end {
339              
340             # This really should have been called heading_end but it's too late
341             # to change now.
342              
343 2     2 0 6 $_[0]->vspace(1);
344 2         5 1;
345             }
346              
347             # ------------------------------------------------------------------------
348             sub bullet {
349 4     4 0 50 my ( $self, $bullet ) = @_;
350              
351 4         4 $self->{'next_bullet'} = $bullet;
352 4         8 return;
353             }
354              
355             # ------------------------------------------------------------------------
356             sub adjust_lm {
357 14     14 0 25 $_[0]->emit_para();
358 14         28 $_[0]->{'lm'} += $_[1] * $_[0]->{'normal_halfpoint_size'} * 5;
359 14         23 1;
360             }
361              
362             # ------------------------------------------------------------------------
363             sub adjust_rm {
364 2     2 0 5 $_[0]->emit_para();
365 2         5 $_[0]->{'rm'} -= $_[1] * $_[0]->{'normal_halfpoint_size'} * 5;
366 2         6 1;
367             } # Yes, flip the sign on the right margin!
368              
369             # BTW, halfpoints * 10 = twips
370              
371             # ------------------------------------------------------------------------
372             sub pre_start {
373 1     1 0 2 my $self = shift;
374              
375 1         7 $self->SUPER::pre_start(@_);
376 1         4 $self->out( \sprintf '\s20\f1\fs%s\noproof\lang1024\lang1076 ', $self->{'codeblock_halfpoint_size'}, );
377 1         2 return 1;
378             }
379              
380             # ------------------------------------------------------------------------
381 1     1 0 3 sub b_start { shift->out( \'{\b ' ) }
382 1     1 0 3 sub b_end { shift->out( \'}' ) }
383 1     1 0 3 sub i_start { shift->out( \'{\i ' ) }
384 1     1 0 4 sub i_end { shift->out( \'}' ) }
385 1     1 0 4 sub tt_start { shift->out( \'{\f1\noproof\lang1024\lang1076 ' ) }
386 1     1 0 3 sub tt_end { shift->out( \'}' ) }
387 0     0 0 0 sub sub_start { shift->out( \'{\sub ' ) }
388 0     0 0 0 sub sub_end { shift->out( \'}' ) }
389 0     0 0 0 sub sup_start { shift->out( \'{\super ' ) }
390 0     0 0 0 sub sup_end { shift->out( \'}' ) }
391 0     0 0 0 sub strike_start { shift->out( \'{\strike ' ) }
392 0     0 0 0 sub strike_end { shift->out( \'}' ) }
393              
394             # ------------------------------------------------------------------------
395             sub q_start {
396 0     0 0 0 my $self = $_[0];
397              
398 0 0       0 $self->out( ( ( ++$self->{'quotelevel'} ) % 2 ) ? \'\ldblquote ' : \'\lquote ' );
399             }
400              
401             # ------------------------------------------------------------------------
402             sub q_end {
403 0     0 0 0 my $self = $_[0];
404              
405 0 0       0 $self->out( ( ( --$self->{'quotelevel'} ) % 2 ) ? \'\rquote ' : \'\rdblquote ' );
406             }
407              
408             # ------------------------------------------------------------------------
409 1 50   1 0 6 sub pre_out { $_[0]->out( ref( $_[1] ) ? $_[1] : \rtf_esc_codely( $_[1] ) ) }
410              
411             # ------------------------------------------------------------------------
412             sub out { # output a word (or, if escaped, chunk of RTF)
413 755     755 0 691 my $self = shift;
414              
415             #return $self->pre_out(@_) if $self->{pre};
416              
417             #### out called by: $_[0], (caller(1) )[3]
418              
419 755 50       1089 return unless defined $_[0]; # and length $_[0];
420              
421 755 100       1206 $self->{'Para'} = '' unless defined $self->{'Para'};
422 755 100       1395 $self->{'Para'} .= ref( $_[0] ) ? ${ $_[0] } : rtf_esc( $_[0] );
  11         23  
423              
424 755         1477 return 1;
425             }
426              
427             # ------------------------------------------------------------------------
428 1     1   12 use integer;
  1         1  
  1         6  
429              
430             sub rtf_esc {
431 746     746 0 571 my $x; # scratch
432 746 50       1229 if ( !defined wantarray ) { # void context: alter in-place!
    50          
433 0         0 for (@_) {
434 0         0 s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
435 0 0       0 s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  0         0  
436             }
437 0         0 return;
438             }
439             elsif (wantarray) { # return an array
440             return map {
441 0         0 ;
442 0         0 ( $x = $_ ) =~ s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
443 0 0       0 $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  0         0  
444              
445             # Hyper-escape all Unicode characters.
446 0         0 $x;
447             } @_;
448             }
449             else { # return a single scalar
450 746 50       1435 ( $x = ( ( @_ == 1 ) ? $_[0] : join '', @_ ) ) =~ s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
451             # Escape \, {, }, -, control chars, and 7f-ff.
452 746 0       741 $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  0         0  
453              
454             # Hyper-escape all Unicode characters.
455 746         1137 return $x;
456             }
457             }
458              
459             # ------------------------------------------------------------------------
460             sub rtf_esc_codely {
461              
462             # Doesn't change "-" to hard-hyphen, nor apply computerese style
463              
464 1     1 0 1 my $x; # scratch
465 1 50       5 if ( !defined wantarray ) { # void context: alter in-place!
    50          
466 0         0 for (@_) {
467 0         0 s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g;
468 0 0       0 s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  0         0  
469              
470             # Hyper-escape all Unicode characters.
471             }
472 0         0 return;
473             }
474             elsif (wantarray) { # return an array
475             return map {
476 1         3 ;
477 1         10 ( $x = $_ ) =~ s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g;
478 1 0       3 $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  0         0  
479              
480             # Hyper-escape all Unicode characters.
481 1         4 $x;
482             } @_;
483             }
484             else { # return a single scalar
485 0 0         ( $x = ( ( @_ == 1 ) ? $_[0] : join '', @_ ) ) =~ s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g;
486              
487             # Escape \, {, }, -, control chars, and 7f-ff.
488 0 0         $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
  0            
489              
490             # Hyper-escape all Unicode characters.
491 0           return $x;
492             }
493             }
494              
495             1;
496              
497             __END__