File Coverage

blib/lib/ICC/Profile/pseq.pm
Criterion Covered Total %
statement 9 126 7.1
branch 0 60 0.0
condition 0 3 0.0
subroutine 3 12 25.0
pod 1 6 16.6
total 13 207 6.2


line stmt bran cond sub pod time code
1             package ICC::Profile::pseq;
2              
3 2     2   79755 use strict;
  2         11  
  2         46  
4 2     2   9 use Carp;
  2         3  
  2         119  
5              
6             our $VERSION = 0.22;
7              
8             # revised 2018-08-07
9             #
10             # Copyright © 2004-2020 by William B. Birkett
11              
12             # inherit from Shared
13 2     2   359 use parent qw(ICC::Shared);
  2         228  
  2         8  
14              
15             # create new pseq tag object
16             # parameters: ([array_of_profile_objects])
17             # returns: (ref_to_object)
18             sub new {
19              
20             # get object class
21 0     0 0   my $class = shift();
22            
23             # create empty pseq object
24 0           my $self = [
25             {}, # object header
26             [], # array of profile description structures
27             ];
28              
29             # if parameter(s) supplied
30 0 0         if (@_) {
31            
32             # make new pseq tag
33 0           _newICCpseq($self, @_);
34            
35             }
36              
37             # bless object
38 0           bless($self, $class);
39            
40             # return object reference
41 0           return($self);
42              
43             }
44              
45             # create pseq tag object from ICC profile
46             # parameters: (ref_to_parent_object, file_handle, ref_to_tag_table_entry)
47             # returns: (ref_to_object)
48             sub new_fh {
49              
50             # get object class
51 0     0 0   my $class = shift();
52              
53             # create empty pseq object
54 0           my $self = [
55             {}, # object header
56             [] # array of profile description structures
57             ];
58              
59             # verify 3 parameters
60 0 0         (@_ == 3) or croak('wrong number of parameters');
61              
62             # read pseq data from profile
63 0           _readICCpseq($self, @_);
64              
65             # bless object
66 0           bless($self, $class);
67              
68             # return object reference
69 0           return($self);
70              
71             }
72              
73             # writes pseq tag object to ICC profile
74             # parameters: (ref_to_parent_object, file_handle, ref_to_tag_table_entry)
75             sub write_fh {
76              
77             # verify 4 parameters
78 0 0   0 0   (@_ == 4) or croak('wrong number of parameters');
79              
80             # write pseq data to profile
81 0           goto &_writeICCpseq;
82              
83             }
84              
85             # get tag size (for writing to profile)
86             # returns: (tag_size)
87             sub size {
88            
89             # get parameters
90 0     0 0   my ($self) = @_;
91            
92             # local variables
93 0           my ($size);
94            
95             # set base size
96 0           $size = 12;
97            
98             # for each profile description structure
99 0           for my $pds (@{$self->[1]}) {
  0            
100            
101             # add size of profile description structure
102 0           $size += 20 + $pds->[5]->size + $pds->[6]->size;
103            
104             # add padding if mluc tag (version 4)
105 0 0         $size += (-$pds->[5]->size % 4) if (UNIVERSAL::isa($pds->[5], 'ICC::Profile::mluc'));
106            
107             # add padding if mluc tag (version 4)
108 0 0         $size += (-$pds->[6]->size % 4) if (UNIVERSAL::isa($pds->[6], 'ICC::Profile::mluc'));
109            
110             }
111            
112             # return size
113 0           return($size);
114            
115             }
116              
117             # get pds (profile description structure) reference(s)
118             # parameters: (index)
119             # returns: (ref_to_pds)
120             # parameters: (list_of_indices)
121             # returns: (list_of_refs_to_pds)
122             sub pds {
123              
124             # get object reference
125 0     0 0   my $self = shift();
126            
127             # if parameters
128 0 0         if (@_) {
129            
130             # if list is wanted
131 0 0         if (wantarray) {
132            
133             # return list of pds references
134 0           return(map {$self->[1][$_]} @_);
  0            
135            
136             # single value wanted
137             } else {
138            
139             # return single pds reference
140 0           return($self->[1][$_[0]]);
141            
142             }
143            
144             }
145            
146             }
147              
148             # print object contents to string
149             # format is an array structure
150             # parameter: ([format])
151             # returns: (string)
152             sub sdump {
153              
154             # get parameters
155 0     0 1   my ($self, $p) = @_;
156              
157             # local variables
158 0           my ($s, $fmt);
159              
160             # resolve parameter to an array reference
161 0 0         $p = defined($p) ? ref($p) eq 'ARRAY' ? $p : [$p] : [];
    0          
162              
163             # get format string
164 0 0 0       $fmt = defined($p->[0]) && ! ref($p->[0]) ? $p->[0] : 'undef';
165              
166             # set string to object ID
167 0           $s = sprintf("'%s' object, (0x%x)\n", ref($self), $self);
168              
169             # return
170 0           return($s);
171              
172             }
173              
174             # make new pseq tag from array of profile objects
175             # parameters: (ref_to_object, array_of_profile_objects)
176             sub _newICCpseq {
177            
178             # get object reference
179 0     0     my $self = shift();
180            
181             # local variables
182 0           my ($vmaj, @pds);
183            
184             # verify array of profile objects
185 0 0         (! grep {ref() ne 'ICC::Profile'} @_) or croak('not a profile object');
  0            
186            
187             # for each profile
188 0           for my $profile (@_) {
189            
190             # get profile major version
191 0           $vmaj = substr($profile->profile_header->[2], 0, 2);
192            
193             # copy profile header info
194 0           @pds[0 .. 3] = @{$profile->profile_header}[15 .. 18];
  0            
195            
196             # if profile technology tag defined
197 0 0         if (defined($profile->tag('tech'))) {
198            
199             # copy technology signature
200 0           $pds[4] = $profile->tag('tech')->text;
201            
202             } else {
203            
204             # set to nulls
205 0           $pds[4] = "\x00" x 4;
206            
207             }
208            
209             # if profile device manufacturer tag defined
210 0 0         if (defined($profile->tag('dmnd'))) {
    0          
211            
212             # copy profile device manufacturer tag
213 0           $pds[5] = $profile->tag('dmnd');
214            
215             } elsif ($vmaj == 2) {
216            
217             # make empty 'desc' tag
218 0           $pds[5] = ICC::Profile::desc->new();
219            
220             } else {
221            
222             # make empty 'mluc' tag
223 0           $pds[5] = ICC::Profile::mluc->new();
224            
225             }
226            
227             # if profile device model tag defined
228 0 0         if (defined($profile->tag('dmdd'))) {
    0          
229            
230             # copy profile device manufacturer tag
231 0           $pds[6] = $profile->tag('dmdd');
232            
233             } elsif ($vmaj == 2) {
234            
235             # make empty 'desc' tag
236 0           $pds[6] = ICC::Profile::desc->new();
237            
238             } else {
239            
240             # make empty 'mluc' tag
241 0           $pds[6] = ICC::Profile::mluc->new();
242            
243             }
244            
245             # add structure to tag
246 0           push(@{$self->[1]}, [@pds]);
  0            
247            
248             }
249            
250             }
251              
252             # read pseq tag from ICC profile
253             # note: mluc tag sizes and padding are ambiguous, see "PSD_TechNote.pdf"
254             # parameters: (ref_to_object, ref_to_parent_object, file_handle, ref_to_tag_table_entry)
255             sub _readICCpseq {
256            
257             # get parameters
258 0     0     my ($self, $parent, $fh, $tag) = @_;
259            
260             # local variables
261 0           my ($buf, $cnt, $sig, $tab);
262 0           my ($mark, $eot, $eos);
263            
264             # save tag signature
265 0           $self->[0]{'signature'} = $tag->[0];
266            
267             # seek start of tag
268 0           seek($fh, $tag->[1], 0);
269            
270             # read count
271 0           read($fh, $buf, 12);
272            
273             # unpack count
274 0           $cnt = unpack('x8 N', $buf);
275            
276             # for each profile description structure
277 0           for my $i (0 .. $cnt - 1) {
278            
279             # if index > 0
280 0 0         if ($i > 0) {
281            
282             # set file position to end of pervious tag
283 0           seek($fh, $eot, 0);
284              
285             # read ahead 100 bytes
286 0           read($fh, $buf, 100);
287            
288             # match allowed tag type signatures
289 0 0         ($buf =~ m/(desc|mluc|\x3f\x00)/g) or croak('invalid profile description structure');
290            
291             # seek start of next profile description structure
292 0           seek($fh, $eot + pos($buf) - 20 - length($1), 0);
293            
294             }
295            
296             # read structure signatures and attributes
297 0           read($fh, $buf, 20);
298            
299             # unpack structure signatures and attributes
300 0           @{$self->[1][$i]}[0 .. 4] = unpack('a4 a4 N2 a4', $buf);
  0            
301            
302             # mark file position
303 0           $mark = tell($fh);
304            
305             # get tag type signature ('desc' or 'mluc')
306 0           read($fh, $sig, 4);
307            
308             # if 'desc' type
309 0 0         if ($sig eq 'desc') {
    0          
    0          
310            
311             # parse manufacturer description object
312 0           $self->[1][$i][5] = ICC::Profile::desc->new_fh($self, $fh, ['pseq', $mark, 0, 0]);
313            
314             # set end of tag
315 0           $eot = $mark + $self->[1][$i][5]->size;
316            
317             # if 'mluc' type
318             } elsif ($sig eq 'mluc') {
319            
320             # parse manufacturer description object
321 0           $self->[1][$i][5] = ICC::Profile::mluc->new_fh($self, $fh, ['pseq', $mark, 0, 0]);
322            
323             # set end of tag
324 0           $eot = $mark + 12;
325            
326             # if name record count > 0
327 0 0         if (@{$self->[1][$i][5][2]}) {
  0            
328            
329             # for each name record
330 0           for my $rec (@{$self->[1][$i][5][2]}) {
  0            
331            
332             # compute end of string (eos)
333 0           $eos = $mark + $rec->[2] + $rec->[3];
334            
335             # set eot to greater value
336 0 0         $eot = $eot > $eos ? $eot : $eos;
337            
338             }
339            
340             }
341            
342             # if Monaco non-standard notation
343             } elsif (substr($sig, 0, 2) eq "\x3f\x00") {
344            
345             # create an empty 'desc' tag object
346 0           $self->[1][$i][5] = ICC::Profile::desc->new();
347            
348             # set end of tag
349 0           $eot = $mark + 2;
350            
351             } else {
352            
353             # error
354 0           croak('invalid profile description structure');
355            
356             }
357            
358             # set file position to end of tag
359 0           seek($fh, $eot, 0);
360            
361             # read ahead 100 bytes
362 0           read($fh, $buf, 100);
363            
364             # match allowed tag type signatures
365 0 0         ($buf =~ m/(desc|mluc|\x3f\x00)/g) or croak('invalid profile description structure');
366            
367             # mark start of next tag
368 0           $mark = $eot + pos($buf) - length($1);
369            
370             # if 'desc' type
371 0 0         if ($1 eq 'desc') {
    0          
372            
373             # parse model description object
374 0           $self->[1][$i][6] = ICC::Profile::desc->new_fh($self, $fh, ['pseq', $mark, 0, 0]);
375            
376             # set end of tag
377 0           $eot = $mark + $self->[1][$i][5]->size;
378            
379             # if 'mluc' type
380             } elsif ($1 eq 'mluc') {
381            
382             # parse model description object
383 0           $self->[1][$i][6] = ICC::Profile::mluc->new_fh($self, $fh, ['pseq', $mark, 0, 0]);
384            
385             # set end of tag
386 0           $eot = $mark + 12;
387            
388             # if name record count > 0
389 0 0         if (@{$self->[1][$i][5][2]}) {
  0            
390            
391             # for each name record
392 0           for my $rec (@{$self->[1][$i][5][2]}) {
  0            
393            
394             # compute end of string (eos)
395 0           $eos = $mark + $rec->[2] + $rec->[3];
396            
397             # set eot to greater value
398 0 0         $eot = $eot > $eos ? $eot : $eos;
399            
400             }
401            
402             }
403            
404             # if Monaco non-standard notation
405             } else {
406            
407             # create an empty 'desc' tag object
408 0           $self->[1][$i][6] = ICC::Profile::desc->new();
409            
410             # set end of tag
411 0           $eot = $mark + 2;
412            
413             }
414            
415             }
416            
417             }
418              
419             # write pseq tag to ICC profile
420             # parameters: (ref_to_object, ref_to_parent_object, file_handle, ref_to_tag_table_entry)
421             sub _writeICCpseq {
422              
423             # get parameters
424 0     0     my ($self, $parent, $fh, $tag) = @_;
425              
426             # seek start of tag
427 0           seek($fh, $tag->[1], 0);
428              
429             # write tag type and pds count
430 0           print $fh pack('a4 x4 N', 'pseq', scalar(@{$self->[1]}));
  0            
431              
432             # for each profile description structure
433 0           for my $pds (@{$self->[1]}) {
  0            
434            
435             # write structure signatures and attributes
436 0           print $fh pack('a4 a4 N2 a4', @{$pds}[0 .. 4]);
  0            
437            
438             # write manufacturer description object
439 0           $pds->[5]->write_fh($parent, $fh, ['pseq', tell($fh), 0, 0]);
440            
441             # add padding if mluc tag (version 4)
442 0 0         seek($fh, (-tell($fh) % 4), 1) if (UNIVERSAL::isa($pds->[5], 'ICC::Profile::mluc'));
443            
444             # write model description object
445 0           $pds->[6]->write_fh($parent, $fh, ['pseq', tell($fh), 0, 0]);
446            
447             # add padding if mluc tag (version 4)
448 0 0         seek($fh, (-tell($fh) % 4), 1) if (UNIVERSAL::isa($pds->[6], 'ICC::Profile::mluc'));
449            
450             }
451            
452             }
453              
454             1;