line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#======================================================================= |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# THIS IS A REUSED PERL MODULE, FOR PROPER LICENCING TERMS SEE BELOW: |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# Copyright Martin Hosken |
6
|
|
|
|
|
|
|
# |
7
|
|
|
|
|
|
|
# No warranty or expression of effectiveness, least of all regarding |
8
|
|
|
|
|
|
|
# anyone's safety, is implied in this software or documentation. |
9
|
|
|
|
|
|
|
# |
10
|
|
|
|
|
|
|
# This specific module is licensed under the Perl Artistic License. |
11
|
|
|
|
|
|
|
# Effective 28 January 2021, the original author and copyright holder, |
12
|
|
|
|
|
|
|
# Martin Hosken, has given permission to use and redistribute this module |
13
|
|
|
|
|
|
|
# under the MIT license. |
14
|
|
|
|
|
|
|
# |
15
|
|
|
|
|
|
|
#======================================================================= |
16
|
|
|
|
|
|
|
package PDF::Builder::Basic::PDF::Objind; |
17
|
|
|
|
|
|
|
|
18
|
37
|
|
|
37
|
|
314
|
use strict; |
|
37
|
|
|
|
|
80
|
|
|
37
|
|
|
|
|
1075
|
|
19
|
37
|
|
|
37
|
|
191
|
use warnings; |
|
37
|
|
|
|
|
70
|
|
|
37
|
|
|
|
|
1241
|
|
20
|
37
|
|
|
37
|
|
239
|
use Scalar::Util 'isweak'; |
|
37
|
|
|
|
|
96
|
|
|
37
|
|
|
|
|
3584
|
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
our $VERSION = '3.023'; # VERSION |
23
|
|
|
|
|
|
|
our $LAST_UPDATE = '3.022'; # manually update whenever code is changed |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
=head1 NAME |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
PDF::Builder::Basic::PDF::Objind - PDF indirect object reference. Also acts as an |
28
|
|
|
|
|
|
|
abstract superclass for all elements in a PDF file. |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
=head1 INSTANCE VARIABLES |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
Instance variables differ from content variables in that they all start with |
33
|
|
|
|
|
|
|
a space. |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
=over |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
=item ' parent' |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
For an object which is a reference to an object in some source, this holds the |
40
|
|
|
|
|
|
|
reference to the source object, so that should the reference have to be |
41
|
|
|
|
|
|
|
de-referenced, then we know where to go and get the info. |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
=item ' objnum' (R) |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
The object number in the source (only for object references) |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
=item ' objgen' (R) |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
The object generation in the source |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
There are other instance variables which are used by the parent for file control. |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
=item ' isfree' |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
This marks whether the object is in the free list and available for re-use as |
56
|
|
|
|
|
|
|
another object elsewhere in the file. |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
=item ' nextfree' |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
Holds a direct reference to the next free object in the free list. |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
=back |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
=head1 METHODS |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
=cut |
67
|
|
|
|
|
|
|
|
68
|
37
|
|
|
37
|
|
258
|
use Scalar::Util qw(blessed reftype weaken); |
|
37
|
|
|
|
|
94
|
|
|
37
|
|
|
|
|
2474
|
|
69
|
|
|
|
|
|
|
|
70
|
37
|
|
|
37
|
|
261
|
use vars qw($uidc @inst %inst); |
|
37
|
|
|
|
|
70
|
|
|
37
|
|
|
|
|
45258
|
|
71
|
|
|
|
|
|
|
$uidc = "pdfuid000"; |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
# protected keys during emptying and copying, etc. |
74
|
|
|
|
|
|
|
@inst = qw(parent objnum objgen isfree nextfree uid realised); |
75
|
|
|
|
|
|
|
$inst{" $_"} = 1 for @inst; |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
=head2 PDF::Builder::Basic::PDF::Objind->new() |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
Creates a new indirect object |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
=cut |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
sub new { |
84
|
1650
|
|
|
1650
|
1
|
3253
|
my ($class) = @_; |
85
|
|
|
|
|
|
|
|
86
|
1650
|
|
33
|
|
|
7462
|
return bless {}, ref $class || $class; |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
=head2 $UID = $r->uid() |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
Returns a Unique id for this object, creating one if it didn't have one before |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
=cut |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
sub uid { |
96
|
26047
|
100
|
|
26047
|
1
|
65223
|
$_[0]->{' uid'} || ($_[0]->{' uid'} = $uidc++); |
97
|
26047
|
|
|
|
|
67098
|
return $_[0]->{' uid'}; |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
=head2 $r->release() |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
Releases ALL of the memory used by this indirect object, and all of |
103
|
|
|
|
|
|
|
its component/child objects. This method is called automatically by |
104
|
|
|
|
|
|
|
'Crelease>' (so you don't have to |
105
|
|
|
|
|
|
|
call it yourself). |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
B it is important that this method get called at some point |
108
|
|
|
|
|
|
|
prior to the actual destruction of the object. Internally, PDF files |
109
|
|
|
|
|
|
|
have an enormous amount of cross-references and this causes circular |
110
|
|
|
|
|
|
|
references within our own internal data structures. Calling |
111
|
|
|
|
|
|
|
'C' forces these circular references to be cleaned up and |
112
|
|
|
|
|
|
|
the entire internal data structure purged. |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
=cut |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
# Maintainer's Question: Couldn't this be handled by a DESTROY method |
117
|
|
|
|
|
|
|
# instead of requiring an explicit call to release()? |
118
|
|
|
|
|
|
|
sub release { |
119
|
13959
|
|
|
13959
|
1
|
21688
|
my ($self) = @_; |
120
|
|
|
|
|
|
|
|
121
|
13959
|
|
|
|
|
28707
|
my @tofree = grep { !isweak $_ } values %$self; |
|
43012
|
|
|
|
|
90230
|
|
122
|
13959
|
|
|
|
|
24495
|
%$self = (); |
123
|
|
|
|
|
|
|
|
124
|
13959
|
|
|
|
|
27804
|
while (my $item = shift @tofree) { |
125
|
|
|
|
|
|
|
# common case: value is not reference |
126
|
47635
|
|
100
|
|
|
104555
|
my $ref = ref($item) || next; |
127
|
|
|
|
|
|
|
|
128
|
12901
|
100
|
100
|
|
|
57545
|
if (blessed($item) and $item->can('release')) { |
|
|
100
|
33
|
|
|
|
|
|
|
50
|
|
|
|
|
|
129
|
12159
|
|
|
|
|
21998
|
$item->release(); |
130
|
|
|
|
|
|
|
} elsif ($ref eq 'ARRAY') { |
131
|
723
|
|
|
|
|
3050
|
push @tofree, @$item; |
132
|
|
|
|
|
|
|
} elsif (defined(reftype($ref)) and reftype($ref) eq 'HASH') { |
133
|
0
|
|
|
|
|
0
|
release($item); |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
} |
136
|
13959
|
|
|
|
|
38527
|
return; |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
=head2 $value = $r->val() |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
Returns the value of this object or reads the object and then returns |
142
|
|
|
|
|
|
|
its value. |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
Note that all direct subclasses *must* make their own versions of this |
145
|
|
|
|
|
|
|
subroutine otherwise we could be in for a very deep loop! |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
=cut |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
sub val { |
150
|
0
|
|
|
0
|
1
|
0
|
my ($self) = @_; |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
# this original code is very confusing. is this a |
153
|
|
|
|
|
|
|
# recursive call to this val(), or another? what is |
154
|
|
|
|
|
|
|
# supposed to be returned when self->realised is True? |
155
|
|
|
|
|
|
|
# perlcritic doesn't like this... |
156
|
|
|
|
|
|
|
#$self->{' parent'}->read_obj(@_)->val() |
157
|
|
|
|
|
|
|
# unless $self->{' realised'}; ## no critic |
158
|
|
|
|
|
|
|
|
159
|
0
|
0
|
|
|
|
0
|
if ($self->{' realised'}) { |
160
|
0
|
|
|
|
|
0
|
return $self->{' realised'}; # return undef in any cases? |
161
|
|
|
|
|
|
|
} else { |
162
|
0
|
|
|
|
|
0
|
return $self->{' parent'}->read_obj(@_)->val(); |
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
=head2 $r->realise() |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
Makes sure that the object is fully read in, etc. |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
=cut |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
sub realise { |
173
|
2009
|
|
|
2009
|
1
|
3076
|
my $self = shift(); |
174
|
|
|
|
|
|
|
|
175
|
2009
|
100
|
|
|
|
6872
|
return $self if $self->{' realised'}; |
176
|
98
|
100
|
|
|
|
401
|
return $self->{' parent'}->read_obj($self, @_) if $self->{' objnum'}; |
177
|
30
|
|
|
|
|
115
|
return $self; |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
=head2 $v = $r->outobjdeep($fh, $pdf) |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
If you really want to output this object, then you need to read it first. |
183
|
|
|
|
|
|
|
This also means that all direct subclasses must subclass this method, or they |
184
|
|
|
|
|
|
|
will loop forever! |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
=cut |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
sub outobjdeep { |
189
|
0
|
|
|
0
|
1
|
0
|
my ($self, $fh, $pdf) = @_; |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
# this original code is very confusing. is this a |
192
|
|
|
|
|
|
|
# recursive call to this outobjdeep(), or another? what is |
193
|
|
|
|
|
|
|
# supposed to be returned when self->realised is True? |
194
|
|
|
|
|
|
|
# perlcritic doesn't like the lack of explicit return... |
195
|
|
|
|
|
|
|
#$self->{' parent'}->read_obj($self)->outobjdeep($fh, $pdf) |
196
|
|
|
|
|
|
|
# unless $self->{' realised'}; ## no critic |
197
|
|
|
|
|
|
|
|
198
|
0
|
0
|
|
|
|
0
|
if ($self->{' realised'}) { |
199
|
0
|
|
|
|
|
0
|
return $self->{' realised'}; # return undef in any cases? |
200
|
|
|
|
|
|
|
} else { |
201
|
0
|
|
|
|
|
0
|
return $self->{' parent'}->read_obj($self)->outobjdeep($fh, $pdf); |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
=head2 $r->outobj($fh, $pdf) |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
If this is a full object then outputs a reference to the object, otherwise calls |
208
|
|
|
|
|
|
|
outobjdeep to output the contents of the object at this point. |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
=cut |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
sub outobj { |
213
|
13328
|
|
|
13328
|
1
|
22077
|
my ($self, $fh, $pdf) = @_; |
214
|
|
|
|
|
|
|
|
215
|
13328
|
100
|
|
|
|
23596
|
if (defined $pdf->{' objects'}{$self->uid()}) { |
216
|
878
|
|
|
|
|
1486
|
$fh->printf("%d %d R", @{$pdf->{' objects'}{$self->uid()}}[0..1]); |
|
878
|
|
|
|
|
1658
|
|
217
|
|
|
|
|
|
|
} else { |
218
|
12450
|
|
|
|
|
26121
|
$self->outobjdeep($fh, $pdf); |
219
|
|
|
|
|
|
|
} |
220
|
13328
|
|
|
|
|
28328
|
return; |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
=head2 $s = $r->elements() |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
Abstract superclass function filler. Returns self here but should return |
226
|
|
|
|
|
|
|
something more useful if an array. |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
The old name of this method, C, has been B and will |
229
|
|
|
|
|
|
|
be removed in the future. |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
=cut |
232
|
|
|
|
|
|
|
|
233
|
0
|
|
|
0
|
0
|
0
|
sub elementsof { return elements(@_); } |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
sub elements { |
236
|
3
|
|
|
3
|
1
|
10
|
my ($self) = @_; |
237
|
|
|
|
|
|
|
|
238
|
3
|
50
|
|
|
|
9
|
if ($self->{' realised'}) { |
239
|
3
|
|
|
|
|
14
|
return $self; |
240
|
|
|
|
|
|
|
} else { |
241
|
0
|
|
|
|
|
0
|
return $self->{' parent'}->read_obj($self)->elements(); |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
=head2 $s = $r->empty() |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
Empties all content from this object to free up memory or to be read to pass |
248
|
|
|
|
|
|
|
the object into the free list. Simplistically undefs all instance variables |
249
|
|
|
|
|
|
|
other than object number and generation. |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
=cut |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
sub empty { |
254
|
0
|
|
|
0
|
1
|
0
|
my ($self) = @_; |
255
|
|
|
|
|
|
|
|
256
|
0
|
|
|
|
|
0
|
for my $k (keys %$self) { |
257
|
0
|
0
|
|
|
|
0
|
undef $self->{$k} unless $inst{$k}; |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
|
260
|
0
|
|
|
|
|
0
|
return $self; |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
=head2 $o = $r->merge($objind) |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
This merges content information into an object reference placeholder. |
266
|
|
|
|
|
|
|
This occurs when an object reference is read before the object definition |
267
|
|
|
|
|
|
|
and the information in the read data needs to be merged into the object |
268
|
|
|
|
|
|
|
placeholder. |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
=cut |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
sub merge { |
273
|
72
|
|
|
72
|
1
|
141
|
my ($self, $other) = @_; |
274
|
|
|
|
|
|
|
|
275
|
72
|
|
|
|
|
357
|
for my $k (keys %$other) { |
276
|
349
|
100
|
|
|
|
684
|
next if $inst{$k}; |
277
|
277
|
|
|
|
|
533
|
$self->{$k} = $other->{$k}; |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
# This doesn't seem like the right place to do this, but I haven't |
280
|
|
|
|
|
|
|
# yet found all of the places where Parent is being set |
281
|
277
|
100
|
|
|
|
691
|
weaken $self->{$k} if $k eq 'Parent'; |
282
|
|
|
|
|
|
|
} |
283
|
72
|
|
|
|
|
151
|
$self->{' realised'} = 1; |
284
|
72
|
|
|
|
|
200
|
return bless $self, ref($other); |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
=head2 $r->is_obj($pdf) |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
Returns whether this object is a full object with its own object number or |
290
|
|
|
|
|
|
|
whether it is purely a sub-object. C<$pdf> indicates which output file we are |
291
|
|
|
|
|
|
|
concerned that the object is an object in. |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
=cut |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
sub is_obj { |
296
|
3954
|
|
|
3954
|
1
|
8270
|
return defined $_[1]->{' objects'}{$_[0]->uid()}; |
297
|
|
|
|
|
|
|
} |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
=head2 $r->copy($pdf, $res) |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
Returns a new copy of this object. The object is assumed to be some kind |
302
|
|
|
|
|
|
|
of associative array and the copy is a deep copy for elements which are |
303
|
|
|
|
|
|
|
not PDF objects, according to C<$pdf>, and shallow copy for those that are. |
304
|
|
|
|
|
|
|
Notice that calling C on an object forces at least a one level |
305
|
|
|
|
|
|
|
copy even if it is a PDF object. The returned object loses its PDF |
306
|
|
|
|
|
|
|
object status though. |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
If C<$res> is defined then the copy goes into that object rather than creating a |
309
|
|
|
|
|
|
|
new one. It is up to the caller to bless C<$res>, etc. Notice that elements from |
310
|
|
|
|
|
|
|
C<$self> are not copied into C<$res> if there is already an entry for them |
311
|
|
|
|
|
|
|
existing in C<$res>. |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
=cut |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
sub copy { |
316
|
2758
|
|
|
2758
|
1
|
4133
|
my ($self, $pdf, $res) = @_; |
317
|
|
|
|
|
|
|
|
318
|
2758
|
50
|
|
|
|
4633
|
unless (defined $res) { |
319
|
2758
|
|
|
|
|
3706
|
$res = {}; |
320
|
2758
|
|
|
|
|
4083
|
bless $res, ref($self); |
321
|
|
|
|
|
|
|
} |
322
|
2758
|
|
|
|
|
5997
|
foreach my $k (keys %$self) { |
323
|
8299
|
100
|
|
|
|
13446
|
next if $inst{$k}; |
324
|
2769
|
50
|
|
|
|
4258
|
next if defined $res->{$k}; |
325
|
2769
|
100
|
66
|
|
|
7540
|
if (blessed($self->{$k}) and $self->{$k}->can('is_obj') and not $self->{$k}->is_obj($pdf)) { |
|
|
|
66
|
|
|
|
|
326
|
155
|
|
|
|
|
555
|
$res->{$k} = $self->{$k}->copy($pdf); |
327
|
|
|
|
|
|
|
} else { |
328
|
2614
|
|
|
|
|
5108
|
$res->{$k} = $self->{$k}; |
329
|
|
|
|
|
|
|
} |
330
|
|
|
|
|
|
|
} |
331
|
2758
|
|
|
|
|
6188
|
return $res; |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
1; |