line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
|
2
|
|
|
|
|
|
|
require 5.005; # we need m/...\z/ |
3
|
|
|
|
|
|
|
package RTF::Writer; |
4
|
6
|
|
|
6
|
|
66003
|
use strict; # Time-stamp: "2003-11-04 02:13:08 AST" |
|
6
|
|
|
|
|
14
|
|
|
6
|
|
|
|
|
426
|
|
5
|
|
|
|
|
|
|
|
6
|
6
|
50
|
|
6
|
|
11
|
BEGIN { eval {require utf8}; $INC{"utf8.pm"} = "dummy_value" if $@ } |
|
6
|
|
|
|
|
6811
|
|
|
6
|
|
|
|
|
196
|
|
7
|
|
|
|
|
|
|
# hack to allow "use utf8" under old Perls |
8
|
6
|
|
|
6
|
|
29
|
use utf8; |
|
6
|
|
|
|
|
16
|
|
|
6
|
|
|
|
|
30
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
die sprintf "%s can't work (yet) in a non-ASCII world", __PACKAGE__ |
11
|
|
|
|
|
|
|
unless chr(65) eq 'A'; |
12
|
|
|
|
|
|
|
|
13
|
6
|
|
|
|
|
1065
|
use vars qw($VERSION @ISA @EXPORT_OK |
14
|
6
|
|
|
6
|
|
497
|
$AUTOLOAD $AUTO_NL $WRAP @Escape); |
|
6
|
|
|
|
|
11
|
|
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
$AUTO_NL = 1 unless defined $AUTO_NL; # TODO: document |
17
|
|
|
|
|
|
|
$WRAP = 1 unless defined $WRAP; # TODO: document |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
require Exporter; |
20
|
|
|
|
|
|
|
@ISA = ('Exporter'); |
21
|
|
|
|
|
|
|
$VERSION = '1.11'; |
22
|
|
|
|
|
|
|
@EXPORT_OK = qw( inch inches in point points pt cm rtfesc ); |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
sub DEBUG () {0} |
25
|
6
|
|
|
6
|
|
31
|
use Carp (); |
|
6
|
|
|
|
|
12
|
|
|
6
|
|
|
|
|
106
|
|
26
|
6
|
|
|
6
|
|
3799
|
use RTF::Writer::TableRowDecl (); |
|
6
|
|
|
|
|
15
|
|
|
6
|
|
|
|
|
18843
|
|
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
#************************************************************************** |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
sub CHARSET_LATIN1 { |
31
|
0
|
|
|
0
|
0
|
0
|
$Escape[0xA0] = "\\~"; |
32
|
0
|
|
|
|
|
0
|
$Escape[0xAD] = "\\-"; |
33
|
0
|
|
|
|
|
0
|
return; |
34
|
|
|
|
|
|
|
} |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
sub CHARSET_UNICODE { |
37
|
0
|
|
|
0
|
0
|
0
|
$Escape[0xA0] = "\\~"; |
38
|
0
|
|
|
|
|
0
|
$Escape[0xAD] = "\\-"; |
39
|
0
|
|
|
|
|
0
|
return; |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
sub CHARSET_OTHER { |
43
|
0
|
|
|
0
|
0
|
0
|
$Escape[0xA0] = "\\'a0"; |
44
|
0
|
|
|
|
|
0
|
$Escape[0xAD] = "\\'ad"; |
45
|
0
|
|
|
|
|
0
|
return; |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
49
|
|
|
|
|
|
|
# Init: |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
# Using an array for this avoids some problems with nasty UTF8 bugs in |
52
|
|
|
|
|
|
|
# hash lookup algorithms. |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
@Escape = map sprintf("\\'%02x", $_), 0x00 .. 0xFF; |
55
|
|
|
|
|
|
|
foreach my $i ( 0x20 .. 0x7E ) { $Escape[$i] = chr($i) } |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
{ |
58
|
|
|
|
|
|
|
my @refinements = ( |
59
|
|
|
|
|
|
|
"\\" => "\\'5c", |
60
|
|
|
|
|
|
|
"{" => "\\'7b", |
61
|
|
|
|
|
|
|
"}" => "\\'7d", |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
"\cm" => '', |
64
|
|
|
|
|
|
|
"\cj" => '', |
65
|
|
|
|
|
|
|
"\n" => "\n\\line ", |
66
|
|
|
|
|
|
|
# This bit of voodoo means that whichever of \cm | \cj isn't synonymous |
67
|
|
|
|
|
|
|
# with \n, is aliased to empty-string, and whichever of them IS "\n", |
68
|
|
|
|
|
|
|
# turns into the "\n\\line ". |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
"\t" => "\\tab ", # Tabs (altho theoretically raw \t's might be okay) |
71
|
|
|
|
|
|
|
"\f" => "\n\\page\n", # Formfeed |
72
|
|
|
|
|
|
|
"-" => "\\_", # Turn plaintext '-' into a non-breaking hyphen |
73
|
|
|
|
|
|
|
# I /think/ that's for the best. |
74
|
|
|
|
|
|
|
"\xA0" => "\\~", # \xA0 is Latin-1/Unicode non-breaking space |
75
|
|
|
|
|
|
|
"\xAD" => "\\-", # \xAD is Latin-1/Unicode soft (optional) hyphen |
76
|
|
|
|
|
|
|
'.' => "\\'2e", |
77
|
|
|
|
|
|
|
'F' => "\\'46", |
78
|
|
|
|
|
|
|
); |
79
|
|
|
|
|
|
|
my($char, $esc); |
80
|
|
|
|
|
|
|
while(@refinements) { |
81
|
|
|
|
|
|
|
($char, $esc) = splice @refinements,0,2; |
82
|
|
|
|
|
|
|
$Escape[ord $char] = $esc; |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
# The conversion functions, for export: |
89
|
0
|
|
|
0
|
1
|
0
|
sub inch { int(.5 + $_[0] * 1440) } |
90
|
0
|
|
|
0
|
1
|
0
|
sub inches { int(.5 + $_[0] * 1440) } |
91
|
0
|
|
|
0
|
1
|
0
|
sub in { int(.5 + $_[0] * 1440) } |
92
|
0
|
|
|
0
|
1
|
0
|
sub points { int(.5 + $_[0] * 20) } |
93
|
0
|
|
|
0
|
1
|
0
|
sub point { int(.5 + $_[0] * 20) } |
94
|
0
|
|
|
0
|
1
|
0
|
sub pt { int(.5 + $_[0] * 20) } |
95
|
0
|
|
|
0
|
1
|
0
|
sub cm { int(.5 + $_[0] * (1440 / 2.54) ) } # approx 567 |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
sub rtfesc { |
98
|
|
|
|
|
|
|
# Note that this doesn't apply our wrapping algorithm, because |
99
|
|
|
|
|
|
|
# I don't forsee this being used for many-line things. |
100
|
|
|
|
|
|
|
|
101
|
1
|
50
|
50
|
1
|
1
|
2430
|
shift if @_ and ref($_[0] || '') and UNIVERSAL::isa($_[0], __PACKAGE__); |
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
102
|
|
|
|
|
|
|
# that's so we can double as a method |
103
|
|
|
|
|
|
|
|
104
|
1
|
|
|
|
|
2
|
my $x; # scratch |
105
|
1
|
50
|
|
|
|
9
|
if(!defined wantarray) { # void context: alter in-place! |
|
|
50
|
|
|
|
|
|
106
|
0
|
|
|
|
|
0
|
for(@_) { |
107
|
0
|
|
|
|
|
0
|
s/([F\.\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape[ord$1]/g; # ESCAPER |
108
|
0
|
0
|
|
|
|
0
|
s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; |
|
0
|
|
|
|
|
0
|
|
109
|
|
|
|
|
|
|
# We escape F and . because when they're line-initial (or alone |
110
|
|
|
|
|
|
|
# on a line), some mailers eat them or freak out. |
111
|
|
|
|
|
|
|
} |
112
|
0
|
|
|
|
|
0
|
return; |
113
|
|
|
|
|
|
|
} elsif(wantarray) { # return an array |
114
|
0
|
|
|
|
|
0
|
return map {; |
115
|
0
|
|
|
|
|
0
|
($x = $_) =~ |
116
|
|
|
|
|
|
|
s/([F\.\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape[ord$1]/g; # ESCAPER |
117
|
0
|
|
|
|
|
0
|
$x =~ |
118
|
0
|
0
|
|
|
|
0
|
s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; |
119
|
0
|
|
|
|
|
0
|
$x; |
120
|
|
|
|
|
|
|
} @_; |
121
|
|
|
|
|
|
|
} else { # return a single scalar |
122
|
1
|
50
|
|
|
|
18
|
($x = ((@_ == 1) ? $_[0] : join '', @_) |
123
|
|
|
|
|
|
|
) =~ |
124
|
|
|
|
|
|
|
s/([F\.\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape[ord$1]/g; # ESCAPER |
125
|
|
|
|
|
|
|
# Escape \, {, }, -, control chars, and 7f-ff. |
126
|
1
|
|
|
|
|
4
|
$x =~ |
127
|
0
|
0
|
|
|
|
0
|
s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; |
128
|
|
|
|
|
|
|
|
129
|
1
|
|
|
|
|
5
|
return $x; |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
#************************************************************************** |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
sub new_to_file { |
137
|
|
|
|
|
|
|
# just a wrapper around new_to_fh |
138
|
6
|
|
|
6
|
1
|
3958
|
my $class = shift; |
139
|
6
|
50
|
|
|
|
29
|
defined $_[0] or Carp::croak "undef isn't a good filename for new_to_file"; |
140
|
6
|
50
|
|
|
|
27
|
length $_[0] or Carp::croak "\"\" isn't a good filename for new_to_file"; |
141
|
6
|
|
|
|
|
19
|
local(*FH); |
142
|
6
|
50
|
|
|
|
741
|
open(FH, ">$_[0]") or Carp::croak "Can't write-open $_[0]: $!"; |
143
|
6
|
|
|
|
|
13
|
DEBUG and print "Opened-file $_[0] -> ", *FH{IO}, "\n"; |
144
|
6
|
|
|
|
|
52
|
my $new = $class->new_to_fh(*FH{IO}); |
145
|
6
|
|
|
|
|
23
|
return $new; |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
|
148
|
0
|
|
|
0
|
0
|
0
|
sub new_to_filehandle { shift->new_to_handle(@_) } |
149
|
0
|
|
|
0
|
1
|
0
|
sub new_to_handle { shift->new_to_fh( @_) } |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
sub new_to_fh { # legacy |
152
|
6
|
50
|
33
|
6
|
0
|
65
|
Carp::croak "Open to what filehandle?" |
153
|
|
|
|
|
|
|
unless defined $_[1] and length $_[1]; |
154
|
6
|
|
|
|
|
12
|
my $fh = $_[1]; |
155
|
6
|
|
|
|
|
10
|
DEBUG and print "Opened-fh $fh\n"; |
156
|
|
|
|
|
|
|
|
157
|
6
|
|
|
|
|
12
|
my $class = shift; |
158
|
6
|
|
|
|
|
13
|
my $last_was_command = 0; |
159
|
6
|
|
33
|
|
|
28
|
my $new = bless [ |
160
|
|
|
|
|
|
|
_make_emitter_closure($fh), |
161
|
|
|
|
|
|
|
'', # things to be printed, on closing |
162
|
|
|
|
|
|
|
$fh, |
163
|
|
|
|
|
|
|
], ref($class) || $class; |
164
|
6
|
|
|
|
|
20
|
return $new; |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
sub new_to_string { |
168
|
1
|
50
|
33
|
1
|
1
|
202
|
Carp::croak "Open to what scalar-ref?" |
169
|
|
|
|
|
|
|
unless defined $_[1] and ref($_[1]) eq 'SCALAR'; |
170
|
1
|
|
|
|
|
3
|
my($class, $sr) = @_; |
171
|
1
|
|
|
|
|
2
|
DEBUG and print "Opened-sr $sr\n"; |
172
|
|
|
|
|
|
|
|
173
|
1
|
|
33
|
|
|
5
|
my $new = bless [ |
174
|
|
|
|
|
|
|
_make_emitter_closure(undef,$sr), |
175
|
|
|
|
|
|
|
'', # things to be printed, on closing |
176
|
|
|
|
|
|
|
undef, |
177
|
|
|
|
|
|
|
], ref($class) || $class; |
178
|
1
|
|
|
|
|
3
|
return $new; |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
#************************************************************************** |
182
|
|
|
|
|
|
|
# Think twice before outright overriding this method: |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
sub print { |
185
|
520
|
50
|
|
520
|
1
|
1145
|
ref $_[0] or Carp::croak(__PACKAGE__ . |
186
|
|
|
|
|
|
|
"'s print(...) is supposed to be an object method!"); |
187
|
520
|
|
|
|
|
527
|
DEBUG > 1 and print "Calling $_[0][0]\n"; |
188
|
|
|
|
|
|
|
goto &{ |
189
|
520
|
50
|
|
|
|
504
|
$_[0][0] || # call the closure |
|
520
|
|
|
|
|
1857
|
|
190
|
|
|
|
|
|
|
Carp::croak("That " . __PACKAGE__ . " object has been closed!?") |
191
|
|
|
|
|
|
|
}; |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
#************************************************************************** |
195
|
|
|
|
|
|
|
sub printf { |
196
|
0
|
0
|
|
0
|
1
|
0
|
ref $_[0] or Carp::croak(__PACKAGE__ . |
197
|
|
|
|
|
|
|
"'s printf(...) is supposed to be an object method!"); |
198
|
0
|
|
|
|
|
0
|
my($it,$format) = splice(@_,0,2); |
199
|
0
|
0
|
|
|
|
0
|
$format = '' unless defined $format; |
200
|
|
|
|
|
|
|
|
201
|
0
|
0
|
|
|
|
0
|
if(ref($format) ne 'SCALAR') { |
202
|
|
|
|
|
|
|
# Example: $it->printf("%04d: %s\n", @stuff) |
203
|
0
|
|
|
|
|
0
|
DEBUG and print "Nonescaped format <$format> on <@_>\n"; |
204
|
0
|
|
|
|
|
0
|
my $x = sprintf($format, @_); |
205
|
0
|
|
|
|
|
0
|
DEBUG and print "Formatted (not yet esc): $x\n"; |
206
|
0
|
|
|
|
|
0
|
$it->print( $x ); |
207
|
|
|
|
|
|
|
# And, in escaping, this will be wrapped. |
208
|
|
|
|
|
|
|
} else { |
209
|
|
|
|
|
|
|
# Example: $it->printf(\'{\f30\b %s:} {\i %d}', @stuff) |
210
|
0
|
|
|
|
|
0
|
DEBUG and print "Escaped format <", $$format, "> on <@_>\n"; |
211
|
|
|
|
|
|
|
|
212
|
0
|
|
|
|
|
0
|
my $str; # scratch |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
# Escape anything non-numeric: |
215
|
0
|
|
|
|
|
0
|
for(my $i = 0; $i < @_; ++$i) { |
216
|
0
|
0
|
0
|
|
|
0
|
next if !defined($_[$i]) or !length($_[$i]) or |
|
|
|
0
|
|
|
|
|
217
|
|
|
|
|
|
|
$_[$i] =~ m/^[+-]?(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?\z/s; |
218
|
|
|
|
|
|
|
|
219
|
0
|
|
|
|
|
0
|
($str = $_[$i]) =~ |
220
|
|
|
|
|
|
|
s/([F\.\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape[ord$1]/g; # ESCAPER |
221
|
0
|
|
|
|
|
0
|
$str =~ |
222
|
0
|
0
|
|
|
|
0
|
s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
# Don't bother applying wrapping, I guess. |
225
|
|
|
|
|
|
|
|
226
|
0
|
|
|
|
|
0
|
DEBUG > 2 and print "Escaping <$_[$i]> to <$str>\n"; |
227
|
0
|
|
|
|
|
0
|
splice @_, $i, 1, $str; |
228
|
|
|
|
|
|
|
# MAGIC! makes it so we don't alter the original. |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
0
|
|
|
|
|
0
|
my $x = sprintf $$format, @_; |
232
|
0
|
|
|
|
|
0
|
DEBUG and print "Formatted (esc): $x\n"; |
233
|
0
|
|
|
|
|
0
|
$it->print( \$x ); # No wrapping applied. |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
# We mustn't escape things that we might intend, in the sprintf |
236
|
|
|
|
|
|
|
# format, to treat as numbers, since escaping would turn '-' |
237
|
|
|
|
|
|
|
# to '\_', and that would turn something numeric like "-14" |
238
|
|
|
|
|
|
|
# or "1.5E-9" into something non-numeric like "\_14" |
239
|
|
|
|
|
|
|
# or "1.5E\_9". So we use this regexp. |
240
|
|
|
|
|
|
|
# The solution here /could/ fail to apply the escaping of |
241
|
|
|
|
|
|
|
# "-" -> "\_", to number-seeming things we were really going |
242
|
|
|
|
|
|
|
# to use as strings, but that seems relatively harmless. |
243
|
|
|
|
|
|
|
# The only completely correct way to do that would be to |
244
|
|
|
|
|
|
|
# completely reimplement sprintf in pure Perl, or at least |
245
|
|
|
|
|
|
|
# enough of it that we parse the format -- so not only could we |
246
|
|
|
|
|
|
|
# tell what items from @_ were to be treated as numbers and |
247
|
|
|
|
|
|
|
# which as strings, but also so we could take the output of |
248
|
|
|
|
|
|
|
# formatting numbers, and /then/ apply the '-' -> '\_' |
249
|
|
|
|
|
|
|
# escaping. |
250
|
|
|
|
|
|
|
# However, the /only/ benefit of this would be to get the |
251
|
|
|
|
|
|
|
# '-' -> '\_' escaping to apply. And in practice, this could |
252
|
|
|
|
|
|
|
# be a problem only in two cases: a leading minus-sign, as |
253
|
|
|
|
|
|
|
# in '-53.3', which presumably won't occur in a context |
254
|
|
|
|
|
|
|
# where a word-processor would hyphenate; and after an "E", |
255
|
|
|
|
|
|
|
# as in "1.5E-9". While it's more likely that a word-precessor |
256
|
|
|
|
|
|
|
# might hyphenate there, I that think scientific-notation |
257
|
|
|
|
|
|
|
# numbers are in practive relatively rare. So there. |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
262
|
|
|
|
|
|
|
sub AUTOLOAD { |
263
|
0
|
|
|
0
|
|
0
|
DEBUG and print "**** $_[0] hits autoload for $AUTOLOAD\n"; |
264
|
0
|
0
|
0
|
|
|
0
|
if(ref($_[0]) and $AUTOLOAD =~ m<::([A-Z][a-z]*(?:_?[0-9]+)?)$>s) { |
265
|
0
|
|
|
|
|
0
|
my $cmd = "\\" . lc($1); |
266
|
0
|
|
|
|
|
0
|
$cmd =~ tr<_><->; # So: $x->fi_180 -> $x->print(\'\fs-180') |
267
|
0
|
|
|
|
|
0
|
my $it = shift; |
268
|
0
|
0
|
|
|
|
0
|
if(@_) { |
269
|
0
|
|
|
|
|
0
|
return $it->print(\'{', \$cmd, @_, \'}'); |
270
|
|
|
|
|
|
|
# So: $it->Lang1234(...) -> $it->print([\'\lang123', ... ]); |
271
|
|
|
|
|
|
|
# (Well, the { ... } is just an incidental optimization.) |
272
|
|
|
|
|
|
|
} else { |
273
|
0
|
|
|
|
|
0
|
return $it->print(\$cmd); |
274
|
|
|
|
|
|
|
# So: $it->Lang1234() -> $it->print(\'\lang123'); |
275
|
|
|
|
|
|
|
} |
276
|
|
|
|
|
|
|
} else { |
277
|
0
|
|
0
|
|
|
0
|
Carp::croak "Can't locate object method \"$AUTOLOAD\" via package \"" |
278
|
|
|
|
|
|
|
. (ref($_[0]) || $_[0]) . '"'; |
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
283
|
|
|
|
|
|
|
sub close { |
284
|
7
|
50
|
|
7
|
1
|
71
|
return unless $_[0][0]; # Already closed?! |
285
|
7
|
|
|
|
|
64
|
DEBUG > 1 and print "Closing $_[0]\n"; |
286
|
7
|
100
|
|
|
|
55
|
$_[0]->print(\$_[0][1]) if length $_[0][1]; |
287
|
7
|
|
|
|
|
21
|
undef $_[0][0]; # ...presumably clausing any FH to close and destroy. |
288
|
7
|
|
|
|
|
136
|
$_[0][1] = ''; |
289
|
7
|
|
|
|
|
70
|
return; |
290
|
|
|
|
|
|
|
} |
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
293
|
|
|
|
|
|
|
sub DESTROY { |
294
|
|
|
|
|
|
|
# just a rudimentary version of $fh->close() |
295
|
7
|
50
|
33
|
7
|
|
2737
|
$_[0]->print(\$_[0][1]) if $_[0][0] and $_[0][1]; |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
#************************************************************************** |
299
|
6
|
|
|
6
|
|
6965
|
use UNIVERSAL (); |
|
6
|
|
|
|
|
89
|
|
|
6
|
|
|
|
|
25338
|
|
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
sub table { |
302
|
|
|
|
|
|
|
# Wrapper around row(). |
303
|
0
|
|
|
0
|
1
|
0
|
my $it = shift; |
304
|
0
|
0
|
|
|
|
0
|
Carp::croak "table isn't a class method" unless ref $it; |
305
|
0
|
0
|
0
|
|
|
0
|
my $decl = shift |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
306
|
|
|
|
|
|
|
if @_ and defined $_[0] and ref($_[0]) |
307
|
|
|
|
|
|
|
and UNIVERSAL::isa($_[0], __PACKAGE__ . '::TableRowDecl'); |
308
|
|
|
|
|
|
|
# Remaining items are row-arrayrefs. |
309
|
|
|
|
|
|
|
|
310
|
0
|
0
|
|
|
|
0
|
push @_, [''] unless @_; # avoid table with no rows! |
311
|
|
|
|
|
|
|
|
312
|
0
|
|
0
|
|
|
0
|
$decl ||= RTF::Writer::TableRowDecl->new_auto_for_rows(@_); |
313
|
|
|
|
|
|
|
|
314
|
0
|
|
|
|
|
0
|
$it->print(\'\par\pard'); |
315
|
|
|
|
|
|
|
# Because ill things happen unless the paragraph |
316
|
|
|
|
|
|
|
# that the table starts in, is virgin. |
317
|
0
|
|
|
|
|
0
|
foreach my $row_content (@_) { |
318
|
0
|
0
|
0
|
|
|
0
|
Carp::croak "table's row-parameters have to be arrayrefs" |
319
|
|
|
|
|
|
|
unless ref($row_content || '') eq 'ARRAY'; |
320
|
0
|
|
|
|
|
0
|
$it->row($decl, @$row_content); |
321
|
|
|
|
|
|
|
} |
322
|
0
|
|
|
|
|
0
|
return scalar @_; |
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
sub row { |
328
|
|
|
|
|
|
|
# Generate a table row. |
329
|
5
|
|
|
5
|
1
|
19
|
my $it = shift; |
330
|
5
|
50
|
|
|
|
52
|
Carp::croak "row isn't a class method" unless ref $it; |
331
|
5
|
50
|
33
|
|
|
82
|
Carp::croak "row's first parameter has to be a table row declaration" |
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
332
|
|
|
|
|
|
|
unless @_ and defined $_[0] and ref($_[0]) |
333
|
|
|
|
|
|
|
and UNIVERSAL::isa($_[0], __PACKAGE__ . '::TableRowDecl'); |
334
|
5
|
|
|
|
|
18
|
my $decl = shift; |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
# Pad with blank cells, if need be: |
337
|
5
|
50
|
|
|
|
7
|
push @_, (\'') x scalar(@{$decl->[0]} - @_) if @{$decl->[0]} > @_; |
|
0
|
|
|
|
|
0
|
|
|
5
|
|
|
|
|
18
|
|
338
|
|
|
|
|
|
|
# We have to avoid having a cell-less row: |
339
|
5
|
50
|
|
|
|
14
|
push @_, \'' unless @_; |
340
|
|
|
|
|
|
|
|
341
|
5
|
|
|
|
|
8
|
my $cell_count = @_; |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
|
344
|
5
|
|
|
|
|
22
|
my @inits = $decl->cell_content_init; |
345
|
|
|
|
|
|
|
|
346
|
5
|
|
100
|
|
|
34
|
unshift @_, |
347
|
|
|
|
|
|
|
\( |
348
|
|
|
|
|
|
|
'\pard\intbl' . ( shift(@inits) || '' ) |
349
|
|
|
|
|
|
|
); |
350
|
5
|
|
|
|
|
19
|
for(my $i = 1; $i < @_; $i += 2) { |
351
|
20
|
0
|
33
|
|
|
56
|
if(defined($_) and ref($_) eq '' and -1 != index($_[$i], "\f")) { |
|
|
|
33
|
|
|
|
|
352
|
|
|
|
|
|
|
# The one case where we need to mess with things: if there's a |
353
|
|
|
|
|
|
|
# formfeed in this plaintext. |
354
|
0
|
|
|
|
|
0
|
my $x = $_[$i]; |
355
|
0
|
|
|
|
|
0
|
$x =~ tr/\f/\n/; |
356
|
0
|
|
|
|
|
0
|
splice @_, $i, 1, $x; # Swap in the copy, not touching the original. |
357
|
|
|
|
|
|
|
} |
358
|
20
|
|
100
|
|
|
124
|
splice(@_, $i + 1, 0, \( |
359
|
|
|
|
|
|
|
'\cell\pard\intbl' . (shift(@inits) || '') |
360
|
|
|
|
|
|
|
)); |
361
|
|
|
|
|
|
|
} |
362
|
5
|
|
|
|
|
9
|
$_[-1] = \'\cell\row\pard'; |
363
|
|
|
|
|
|
|
|
364
|
5
|
|
|
|
|
22
|
$it->print( |
365
|
|
|
|
|
|
|
\'{', |
366
|
|
|
|
|
|
|
$decl->decl_code($cell_count), |
367
|
|
|
|
|
|
|
@_, |
368
|
|
|
|
|
|
|
\'}', |
369
|
|
|
|
|
|
|
); |
370
|
5
|
|
|
|
|
23
|
return $cell_count; # Might as well return somehting. |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
sub number_pages { |
376
|
4
|
|
|
4
|
1
|
24
|
my $r = shift; |
377
|
4
|
|
|
|
|
15
|
$r->print( |
378
|
|
|
|
|
|
|
\"\n{\\header \\pard\\qr\\plain\\f0", |
379
|
|
|
|
|
|
|
@_, |
380
|
|
|
|
|
|
|
\"\\chpgn\\par}\n\n" |
381
|
|
|
|
|
|
|
); |
382
|
|
|
|
|
|
|
# This is actually a section attribute. To reset, \'\sect\sectd' |
383
|
|
|
|
|
|
|
# to start a new section. |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
#************************************************************************** |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
sub paragraph { |
389
|
10
|
|
|
10
|
1
|
64
|
my $r = shift; |
390
|
10
|
|
|
|
|
50
|
$r->print(\"{\\pard\n", @_, \"\n\\par}\n\n"); |
391
|
|
|
|
|
|
|
} |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
#************************************************************************** |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
sub image_paragraph { |
396
|
2
|
|
|
2
|
1
|
537
|
my $r = shift; |
397
|
2
|
|
|
|
|
9
|
my($filename, $declcode) = $r->_image_params(@_); |
398
|
2
|
50
|
|
|
|
27
|
return unless $r->print( \"{\\pard\\qc\n{\\pict\n", \$declcode); |
399
|
2
|
50
|
|
|
|
16
|
$r->_image_data($filename) or return; |
400
|
2
|
|
|
|
|
26
|
$r->print( \"}\n\\par}\n\n" ); |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
|
403
|
0
|
|
|
0
|
0
|
0
|
sub paragraph_image { shift->image_paragraph(@_) } |
404
|
0
|
|
|
0
|
0
|
0
|
sub paragraph_picture { shift->image_paragraph(@_) } |
405
|
0
|
|
|
0
|
0
|
0
|
sub picture_paragraph { shift->image_paragraph(@_) } |
406
|
|
|
|
|
|
|
|
407
|
0
|
|
|
0
|
0
|
0
|
sub pict { shift->image(@_) } |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
sub image { |
410
|
2
|
50
|
|
2
|
1
|
612
|
Carp::croak "Don't call \$rtf->image(...) in void context!" |
411
|
|
|
|
|
|
|
unless defined wantarray; |
412
|
2
|
|
|
|
|
5
|
my $r = shift; |
413
|
2
|
|
|
|
|
9
|
my($filename, $declcode) = $r->_image_params(@_); |
414
|
2
|
|
|
|
|
8
|
my $out = "{\\pict\n$declcode"; |
415
|
2
|
|
|
|
|
17
|
$r->_image_data($filename, \$out ); |
416
|
2
|
|
|
|
|
5
|
$out .= "}\n"; |
417
|
2
|
|
|
|
|
47
|
return \$out; |
418
|
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
sub _image_params { |
423
|
4
|
|
|
4
|
|
7
|
my $self = shift; |
424
|
|
|
|
|
|
|
|
425
|
4
|
|
|
|
|
21
|
my %o = @_; |
426
|
4
|
|
|
|
|
7
|
my $decl; |
427
|
4
|
|
33
|
|
|
15
|
my $filespec = $o{'filename'} || Carp::croak "What filename?"; |
428
|
4
|
50
|
33
|
|
|
87
|
Carp::croak "No such file as $filespec" |
429
|
|
|
|
|
|
|
unless $filespec and -e $filespec; |
430
|
|
|
|
|
|
|
|
431
|
4
|
50
|
|
|
|
13
|
if(defined $o{'picspecs'}) { |
432
|
0
|
|
|
|
|
0
|
$decl = $o{'picspecs'}; |
433
|
0
|
0
|
|
|
|
0
|
$decl = $$decl if ref $decl; |
434
|
|
|
|
|
|
|
} else { |
435
|
4
|
|
|
|
|
2444
|
require Image::Size; |
436
|
4
|
|
|
|
|
9973
|
my($h,$w, $type) = Image::Size::imgsize( $filespec ); |
437
|
4
|
50
|
33
|
|
|
24474
|
Carp::croak "$filespec - $type" unless $h and $w; |
438
|
|
|
|
|
|
|
|
439
|
4
|
50
|
|
|
|
68
|
my $tag = |
|
|
100
|
|
|
|
|
|
440
|
|
|
|
|
|
|
($type eq 'PNG') ? '\pngblip' |
441
|
|
|
|
|
|
|
: ($type eq 'JPG') ? '\jpegblip' |
442
|
|
|
|
|
|
|
: Carp::croak("I can't handle images of type $type like $filespec"); |
443
|
|
|
|
|
|
|
; |
444
|
4
|
|
|
|
|
28
|
$decl = "$tag\\picw$w\\pich$h\n"; |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
# Now glom on any extra parameters specified: |
447
|
4
|
|
|
|
|
71
|
$decl .= join '', |
448
|
|
|
|
|
|
|
map sprintf("\\pic%s%s", $_, int $o{$_}), |
449
|
|
|
|
|
|
|
grep defined($o{$_}), |
450
|
|
|
|
|
|
|
qw |
451
|
|
|
|
|
|
|
; |
452
|
|
|
|
|
|
|
} |
453
|
4
|
|
|
|
|
14
|
$decl .= "\n"; # So it doesn't run together with the image data. |
454
|
|
|
|
|
|
|
|
455
|
4
|
|
|
|
|
80
|
return( $filespec, $decl ); |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
sub _image_data { |
460
|
4
|
|
|
4
|
|
13
|
my($r, $filename, $to) = @_; |
461
|
|
|
|
|
|
|
|
462
|
4
|
|
|
|
|
93
|
my $buffer; |
463
|
|
|
|
|
|
|
my $in; |
464
|
|
|
|
|
|
|
{ |
465
|
4
|
|
|
|
|
10
|
local(*IMAGE); |
|
4
|
|
|
|
|
18
|
|
466
|
4
|
50
|
|
|
|
140
|
open(IMAGE, $filename) or Carp::croak "Can't read-open $filename: $!"; |
467
|
4
|
|
|
|
|
50
|
$in = *IMAGE; |
468
|
|
|
|
|
|
|
} |
469
|
4
|
|
|
|
|
13
|
binmode($in); |
470
|
4
|
|
|
|
|
92
|
while( read($in, $buffer, 32) ) { |
471
|
968
|
100
|
|
|
|
1616
|
if($to) { |
472
|
484
|
|
|
|
|
1982
|
$$to .= unpack("H*", $buffer) . "\n" ; |
473
|
|
|
|
|
|
|
} else { |
474
|
484
|
50
|
|
|
|
2418
|
$r->print( \( unpack("H*", $buffer) . "\n" ) ) or return 0; |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
# Turn 32 bytes into 64 hex characters, and then add a newline. |
477
|
|
|
|
|
|
|
# (If the last chunk of data is under 32 bytes, then the unpack() |
478
|
|
|
|
|
|
|
# does the right thing.) |
479
|
|
|
|
|
|
|
} |
480
|
4
|
|
|
|
|
82
|
CORE::close($in); |
481
|
4
|
|
|
|
|
23
|
return 1; |
482
|
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
#************************************************************************** |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
# two tolerated variant forms: |
487
|
0
|
|
|
0
|
0
|
0
|
sub prologue { shift->prolog(@_) } |
488
|
0
|
|
|
0
|
0
|
0
|
sub premable { shift->prolog(@_) } |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
sub prolog { |
491
|
|
|
|
|
|
|
# Emit prolog with given parameters |
492
|
6
|
|
|
6
|
1
|
43
|
DEBUG and print "Prolog args: <@_>\n"; |
493
|
6
|
|
|
|
|
22
|
my($it, %h) = (@_); |
494
|
|
|
|
|
|
|
|
495
|
6
|
|
|
|
|
11
|
my $x; #scratch |
496
|
|
|
|
|
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
497
|
|
|
|
|
|
|
|
498
|
6
|
50
|
|
|
|
67
|
$h{'revtim' } = time unless exists $h{'revtim'}; |
499
|
6
|
50
|
|
|
|
38
|
$h{'creatim'} = time unless exists $h{'creatim'}; |
500
|
6
|
50
|
|
|
|
166
|
$h{'doccomm'} = |
501
|
|
|
|
|
|
|
escape_broadly(sprintf 'written by %s [Perl %s v%s]', |
502
|
|
|
|
|
|
|
$0, ref($it), $it->VERSION()) |
503
|
|
|
|
|
|
|
unless exists $h{'doccomm'}; |
504
|
|
|
|
|
|
|
# So you can set each to undef if you want it suppressed. |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
507
|
6
|
|
50
|
|
|
165
|
my $fonts = $h{'fonts'} || $h{'font_table'} || $h{'fonttable'} || []; |
508
|
6
|
50
|
|
|
|
34
|
$fonts = [$fonts] unless ref $fonts; |
509
|
6
|
50
|
33
|
|
|
65
|
push @$fonts, \'\froman Times New Roman' |
510
|
|
|
|
|
|
|
if ref($fonts) eq 'ARRAY' and ! @$fonts; # avoid having an empty font table |
511
|
|
|
|
|
|
|
|
512
|
6
|
|
|
|
|
13
|
my $font_count = -1; |
513
|
6
|
50
|
|
|
|
91
|
$fonts = \join '', |
|
|
50
|
|
|
|
|
|
514
|
|
|
|
|
|
|
# '{' \fonttbl ( | ('{' '}'))+ '}' |
515
|
|
|
|
|
|
|
"{\\fonttbl\n", |
516
|
|
|
|
|
|
|
map( ref($_) |
517
|
|
|
|
|
|
|
? ("{\\f", ++$font_count, ' ', $$_, ";}\n") |
518
|
|
|
|
|
|
|
: ("{\\f", ++$font_count, '\fnil ', escape_broadly($_), ";}\n"), |
519
|
|
|
|
|
|
|
@$fonts |
520
|
|
|
|
|
|
|
# |
521
|
|
|
|
|
|
|
# ? ? ? ? ? ? |
522
|
|
|
|
|
|
|
# ? ';' |
523
|
|
|
|
|
|
|
), "}\n" |
524
|
|
|
|
|
|
|
if ref $fonts eq 'ARRAY' |
525
|
|
|
|
|
|
|
; |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
528
|
0
|
|
|
|
|
0
|
my $info = join '', |
529
|
|
|
|
|
|
|
# And the info group: |
530
|
|
|
|
|
|
|
"\n{\\info \n", |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
# \version? & \vern? & \edmins? & \nofpages? & \nofwords? \nofchars? |
533
|
|
|
|
|
|
|
# & \id? |
534
|
|
|
|
|
|
|
# & ? & ? & ? & ? & ? |
535
|
|
|
|
|
|
|
# & ? & ? & ? & ? & ? |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
# Time things, all optional: |
538
|
|
|
|
|
|
|
map( |
539
|
|
|
|
|
|
|
(!defined($x = $h{$_})) ? () : ( |
540
|
|
|
|
|
|
|
"{\\$_ ", ( |
541
|
|
|
|
|
|
|
ref($x) eq 'SCALAR' ? $$x : |
542
|
|
|
|
|
|
|
ref($x) eq 'ARRAY' ? _time_to_rtf(@$x) : |
543
|
|
|
|
|
|
|
$x =~ m<^\d+$> ? _time_to_rtf( $x) : |
544
|
|
|
|
|
|
|
$x, # dubious, but let it thru |
545
|
|
|
|
|
|
|
), |
546
|
|
|
|
|
|
|
"}\n" |
547
|
|
|
|
|
|
|
), |
548
|
|
|
|
|
|
|
qw(creatim revtim printim buptim) |
549
|
|
|
|
|
|
|
), |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
map( # Optional integer things: |
552
|
|
|
|
|
|
|
(!defined($x = $h{$_})) ? () : |
553
|
|
|
|
|
|
|
$x =~ m<^[0-9]+$> ? "\\$_$x\n" : |
554
|
|
|
|
|
|
|
Carp::croak("value for \"$_\" must be an integer, not \"$_\""), |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
qw(version vern edmins nofpages nofwords nofchars nofcharsws id) |
557
|
|
|
|
|
|
|
), |
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
# Optional non-time non-integer things: |
560
|
|
|
|
|
|
|
map( |
561
|
|
|
|
|
|
|
(!defined($x = $h{$_})) ? () : ( |
562
|
|
|
|
|
|
|
"{\\$_ ", |
563
|
|
|
|
|
|
|
(ref($x) eq 'SCALAR') ? $$x : $x, |
564
|
|
|
|
|
|
|
"}\n" |
565
|
|
|
|
|
|
|
), |
566
|
|
|
|
|
|
|
qw(title subject author manager company operator category |
567
|
|
|
|
|
|
|
keywords comment doccomm hlinkbase) |
568
|
|
|
|
|
|
|
), |
569
|
|
|
|
|
|
|
|
570
|
|
|
|
|
|
|
ref( $h{'more_info'} || '' ) eq 'SCALAR' |
571
|
6
|
50
|
50
|
|
|
122
|
? ${ $h{'more_info'} } : ( $h{'more_info'} || '' ), |
|
|
50
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
"}\n\n", # end of info group |
574
|
|
|
|
|
|
|
; |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
577
|
|
|
|
|
|
|
# Cook up the color table. |
578
|
|
|
|
|
|
|
# |
579
|
|
|
|
|
|
|
# Note that you might want to feed this a null 0th entry: |
580
|
|
|
|
|
|
|
# as in: [ undef, [255,0,0], [0,0,255], ... ] |
581
|
|
|
|
|
|
|
|
582
|
6
|
|
50
|
|
|
160
|
my $color_table = ($h{'colors'} || $h{'color_table'} |
583
|
|
|
|
|
|
|
|| $h{'colortable'} || $h{'colortbl'} || ''); |
584
|
6
|
50
|
|
|
|
32
|
if(ref($color_table) eq 'ARRAY') { |
|
|
50
|
|
|
|
|
|
585
|
|
|
|
|
|
|
#print "R ", ref($color_table), "<", @$color_table, "> =$color_table\n"; |
586
|
0
|
0
|
0
|
|
|
0
|
$color_table = \join '', |
|
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
587
|
|
|
|
|
|
|
'{\colortbl ', |
588
|
|
|
|
|
|
|
map( |
589
|
|
|
|
|
|
|
(ref($_ || '') eq 'ARRAY' ) ? sprintf('\red%d\green%d\blue%d;', |
590
|
|
|
|
|
|
|
$_->[0] || 0, |
591
|
|
|
|
|
|
|
$_->[1] || 0, |
592
|
|
|
|
|
|
|
$_->[2] || 0, |
593
|
|
|
|
|
|
|
) |
594
|
|
|
|
|
|
|
: (ref($_ || '') eq 'SCALAR') ? ( |
595
|
|
|
|
|
|
|
($$_ =~ m/;[\cm\cj\n]*\z/s) ? $$_ : ($$_ . ';') ) |
596
|
|
|
|
|
|
|
# Make sure it ends with a semicolon |
597
|
|
|
|
|
|
|
: ';', # null entry |
598
|
|
|
|
|
|
|
@$color_table |
599
|
|
|
|
|
|
|
), |
600
|
|
|
|
|
|
|
'}' |
601
|
|
|
|
|
|
|
; |
602
|
|
|
|
|
|
|
} elsif(ref($color_table) eq 'SCALAR') { |
603
|
|
|
|
|
|
|
# pass it thru |
604
|
|
|
|
|
|
|
} else { |
605
|
6
|
|
|
|
|
10
|
$color_table = \'{\colortbl;\red255\green0\blue0;\red0\green0\blue255;}'; |
606
|
|
|
|
|
|
|
} |
607
|
|
|
|
|
|
|
|
608
|
6
|
|
|
|
|
19
|
$h{'colortbl'} = $color_table; |
609
|
|
|
|
|
|
|
#print "Color table: <", ${$h{'colortbl'}}, ">\n"; |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
612
|
|
|
|
|
|
|
#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
613
|
|
|
|
|
|
|
# |
614
|
|
|
|
|
|
|
# Now emit the table: |
615
|
|
|
|
|
|
|
# |
616
|
|
|
|
|
|
|
# \rtf \deff? ? ? ? |
617
|
|
|
|
|
|
|
# ? ? |
618
|
|
|
|
|
|
|
|
619
|
6
|
|
|
|
|
135
|
$it->print( \join '', |
620
|
|
|
|
|
|
|
'{\rtf' , |
621
|
|
|
|
|
|
|
defined($h{'rtf_version'}) ? $h{'rtf_version'} : '1', |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
"\\" . ($h{'charset'} || 'ansi'), |
624
|
|
|
|
|
|
|
"\\deff" . int($h{'deff'} || 0), |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
(!defined($x = $h{'more_default'})) ? '' # place to sneak in more stuff |
627
|
|
|
|
|
|
|
: ref($x) eq 'SCALAR' ? $$x |
628
|
|
|
|
|
|
|
: $x, |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
$$fonts, |
631
|
|
|
|
|
|
|
|
632
|
|
|
|
|
|
|
map( ref( $h{$_} || '' ) eq 'SCALAR' |
633
|
6
|
50
|
50
|
|
|
246
|
? ${ $h{$_} } : ( $h{$_} || '' ), |
|
|
0
|
50
|
|
|
|
|
|
|
50
|
100
|
|
|
|
|
|
|
100
|
50
|
|
|
|
|
634
|
|
|
|
|
|
|
qw( filetbl colortbl stylesheet listtables revtbl ) |
635
|
|
|
|
|
|
|
), |
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
$info, |
638
|
|
|
|
|
|
|
|
639
|
|
|
|
|
|
|
); |
640
|
|
|
|
|
|
|
#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
641
|
|
|
|
|
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
642
|
|
|
|
|
|
|
|
643
|
6
|
|
|
|
|
18
|
$it->[1] .= '}'; |
644
|
6
|
|
|
|
|
9
|
DEBUG > 2 and print "Setting $it\'s out-buffer to <$it->[1]>\n"; |
645
|
|
|
|
|
|
|
# to close the group that this document opened in its first char |
646
|
6
|
|
|
|
|
27
|
return 1; |
647
|
|
|
|
|
|
|
} |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
# Two subs used in the "prolog" method: |
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
sub escape_broadly { |
653
|
|
|
|
|
|
|
# Non-destructively quote anything fishy. |
654
|
6
|
|
|
6
|
0
|
23
|
my $scratch = $_[0]; |
655
|
6
|
|
|
|
|
42
|
$scratch =~ |
656
|
18
|
|
|
|
|
105
|
s/([F\.\x00-\x1F\\\{\}\x7F-\xFF])/"\\'".(unpack("H2",$1))/eg; # ESCAPER |
657
|
6
|
|
|
|
|
28
|
$scratch =~ |
658
|
0
|
0
|
|
|
|
0
|
s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; |
659
|
6
|
|
|
|
|
24
|
return $scratch; |
660
|
|
|
|
|
|
|
} |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
sub _time_to_rtf { |
663
|
|
|
|
|
|
|
# accepts no-params (meaning now), an epoch time, or a timelist |
664
|
12
|
50
|
|
12
|
|
40
|
push @_, time() unless @_; |
665
|
12
|
50
|
|
|
|
34
|
if(@_ == 1) { # normal case |
666
|
12
|
|
|
|
|
428
|
@_ = (localtime(shift @_))[5,4,3,2,1,0]; |
667
|
12
|
|
|
|
|
29
|
$_[0] += 1900; # RTF counts 2023 as 2023, not 123. |
668
|
12
|
|
|
|
|
16
|
$_[1]++; # RTF counts January as 1, not 0. |
669
|
|
|
|
|
|
|
} |
670
|
12
|
|
|
|
|
378
|
return sprintf '\yr%d\mo%d\dy%d\hr%d\min%d\sec%d', @_; |
671
|
|
|
|
|
|
|
} |
672
|
|
|
|
|
|
|
|
673
|
|
|
|
|
|
|
#************************************************************************** |
674
|
|
|
|
|
|
|
# |
675
|
|
|
|
|
|
|
# The following makes the scary scary emitter-closure: |
676
|
|
|
|
|
|
|
# |
677
|
|
|
|
|
|
|
|
678
|
|
|
|
|
|
|
my $counter = 0; # for debug purposes |
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
sub _make_emitter_closure { |
681
|
7
|
|
|
7
|
|
16
|
my($fh, $sr) = @_; |
682
|
|
|
|
|
|
|
# sr should either be undef, or a scalar-ref |
683
|
7
|
|
|
|
|
14
|
my $scratch; |
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
# A closure on $fh or $sr, for printing to it. |
686
|
|
|
|
|
|
|
|
687
|
|
|
|
|
|
|
sub { |
688
|
523
|
|
|
523
|
|
773
|
my $this = shift; |
689
|
523
|
|
|
|
|
512
|
DEBUG > 1 and print "Writing (@_) to ", $sr ? "S_$sr\n" : "F_$fh\n"; |
690
|
|
|
|
|
|
|
|
691
|
523
|
|
|
|
|
744
|
foreach my $x (@_) { |
692
|
615
|
50
|
|
|
|
1125
|
next unless defined $x; |
693
|
615
|
100
|
|
|
|
1708
|
if(ref($x) eq 'ARRAY') { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
694
|
3
|
50
|
|
|
|
9
|
next if @$x == 0; |
695
|
3
|
50
|
|
|
|
12
|
$sr ? ( $$sr .= '{' ) : print $fh '{'; |
696
|
3
|
|
|
|
|
4
|
DEBUG > 1 and print " $counter: wrote {\n"; |
697
|
3
|
|
|
|
|
17
|
$this->[0]->($this, @$x); # recurse! |
698
|
3
|
50
|
|
|
|
10
|
$sr ? ( $$sr .= '}' ) : print $fh '}'; |
699
|
3
|
|
|
|
|
6
|
DEBUG > 2 and print " wrote }\n"; |
700
|
|
|
|
|
|
|
} elsif(ref($x) eq 'SCALAR') { |
701
|
579
|
50
|
33
|
|
|
4657
|
if(!defined($$x) or !length($$x)) { |
|
|
100
|
66
|
|
|
|
|
702
|
|
|
|
|
|
|
# no-op |
703
|
0
|
|
|
|
|
0
|
DEBUG > 2 and print " $counter: skipping null sr\n"; |
704
|
|
|
|
|
|
|
} elsif( not( $AUTO_NL and $$x =~ m<[a-zA-Z0-9]\z>s )) { |
705
|
543
|
50
|
|
|
|
2665
|
$sr ? ( $$sr .= $$x ) : print $fh $$x; |
706
|
543
|
|
|
|
|
1414
|
DEBUG > 2 and print " $counter: wrote sr $$x\n"; |
707
|
|
|
|
|
|
|
} else { |
708
|
|
|
|
|
|
|
# $AUTO_NL is true, and $$x's last char is in [a-zA-Z0-9] |
709
|
36
|
50
|
|
|
|
135
|
$sr ? ( $$sr .= $$x . "\n" ) : print $fh $$x, "\n"; |
710
|
36
|
|
|
|
|
83
|
DEBUG > 2 and print " $counter: wrote sr $$x +nl\n"; |
711
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
# Why emit a newline? Because that string might end in a |
713
|
|
|
|
|
|
|
# command, and we want to do the Right Thing in the case of: |
714
|
|
|
|
|
|
|
# $r->print(\'\i', 'donuts') |
715
|
|
|
|
|
|
|
# i.e., printing "\i[newline]donuts", not "\idonuts" |
716
|
|
|
|
|
|
|
# |
717
|
|
|
|
|
|
|
# And why not emit "\i[space]donuts"? because we if we emit a |
718
|
|
|
|
|
|
|
# space and the thing we emitted WASN'T a control word, then |
719
|
|
|
|
|
|
|
# we did a bad thing! Spaces are tricky -- sometimes they're |
720
|
|
|
|
|
|
|
# meaningless, and sometimes they mean a literal space. |
721
|
|
|
|
|
|
|
# But newlines are always ignored -- well, unless preceded |
722
|
|
|
|
|
|
|
# by an escaping backslash, but to get that, the user would |
723
|
|
|
|
|
|
|
# have to have the previous group end in an unmatched backslash, |
724
|
|
|
|
|
|
|
# as in $h->print(\"\\foo\\", ...) So don't do that! |
725
|
|
|
|
|
|
|
} |
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
} elsif(length $x) { # It's plaintext |
728
|
33
|
|
|
|
|
165
|
($scratch = $x) =~ |
729
|
29
|
|
|
|
|
138
|
s/([F\.\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape[ord$1]/eg; # ESCAPER |
730
|
33
|
|
|
|
|
88
|
$scratch =~ |
731
|
0
|
0
|
|
|
|
0
|
s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
# Escape \, {, }, -, control chars, and 7f-ff, and Unicode. |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
# And now: a not terribly clever algorithm for inserting newlines |
736
|
|
|
|
|
|
|
# at a guaranteed harmless place: after a block of whitespace |
737
|
|
|
|
|
|
|
# after the 65th column. |
738
|
|
|
|
|
|
|
# Why not before the block of whitespace? Consider: |
739
|
|
|
|
|
|
|
# q<\foo bar> If we break that into q<\foo>+NL+q< bar>, then |
740
|
|
|
|
|
|
|
# suddenly the space after the newline is significant, instead |
741
|
|
|
|
|
|
|
# of just being the dummy space that ends the \foo command token. |
742
|
33
|
50
|
|
|
|
106
|
$scratch =~ |
743
|
|
|
|
|
|
|
s/( |
744
|
|
|
|
|
|
|
[^\cm\cj\n]{65} # Snare 65 characters from a line |
745
|
|
|
|
|
|
|
[^\cm\cj\n\x20]{0,50} # and finish any current word |
746
|
|
|
|
|
|
|
) |
747
|
|
|
|
|
|
|
(\x20{1,10})(?![\cm\cj\n]) # capture some spaces not at line-end |
748
|
|
|
|
|
|
|
/$1$2\n/gx # and put a NL after those spaces |
749
|
|
|
|
|
|
|
if $WRAP; |
750
|
|
|
|
|
|
|
# This may wrap at well past the 65th column, but not past the 120th. |
751
|
33
|
100
|
|
|
|
119
|
$sr ? ( $$sr .= $scratch ) : print $fh $scratch; |
752
|
33
|
|
|
|
|
47
|
DEBUG > 2 and print " $counter: wrote scalar <$scratch>\n"; |
753
|
33
|
|
|
|
|
73
|
$scratch = ''; |
754
|
|
|
|
|
|
|
} |
755
|
|
|
|
|
|
|
# otherwise it's 0-length plaintext, so ignore. |
756
|
|
|
|
|
|
|
} |
757
|
523
|
|
|
|
|
601
|
DEBUG > 3 and print $fh "{\\v $^T/", ++$counter, "}\n"; |
758
|
523
|
|
|
|
|
2410
|
return 1; |
759
|
7
|
|
|
|
|
150
|
}; |
760
|
|
|
|
|
|
|
} |
761
|
|
|
|
|
|
|
|
762
|
|
|
|
|
|
|
#-------------------------------------------------------------------------- |
763
|
|
|
|
|
|
|
1; |
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
|