File Coverage

blib/lib/ICC/Profile/cvst.pm
Criterion Covered Total %
statement 42 1010 4.1
branch 6 394 1.5
condition 2 212 0.9
subroutine 12 61 19.6
pod 1 35 2.8
total 63 1712 3.6


line stmt bran cond sub pod time code
1             package ICC::Profile::cvst;
2              
3 7     7   83963 use strict;
  7         24  
  7         165  
4 7     7   30 use Carp;
  7         32  
  7         392  
5              
6             our $VERSION = 0.48;
7              
8             # revised 2019-09-28
9             #
10             # Copyright © 2004-2020 by William B. Birkett
11              
12             # inherit from Shared
13 7     7   399 use parent qw(ICC::Shared);
  7         246  
  7         35  
14              
15             # support modules
16 7     7   3325 use Template;
  7         110432  
  7         188  
17 7     7   3016 use Time::Piece;
  7         53477  
  7         26  
18 7     7   4067 use XML::LibXML;
  7         281006  
  7         46  
19              
20             # enable static variables
21 7     7   866 use feature 'state';
  7         15  
  7         85956  
22              
23             # create new cvst object
24             # array contains curve objects for each channel
25             # file path to 'iso_18620', 'store', or 'text' format curves
26             # curve objects must have 'transform' and 'derivative' methods
27             # parameters: ([ref_to_array])
28             # parameters: ([file_path])
29             # returns: (ref_to_object)
30             sub new {
31              
32             # get object class
33 11     11 0 1774 my $class = shift;
34              
35             # create empty cvst object
36 11         29 my $self = [
37             {}, # object header
38             [], # curve object array
39             ];
40              
41             # if there are parameters
42 11 100       33 if (@_) {
43            
44             # if one parameter, an array reference
45 4 50 33     33 if (@_ == 1 && ref($_[0]) eq 'ARRAY') {
    0 0        
46            
47             # make new cvst object from array
48 4         18 _new_from_array($self, shift());
49            
50             # if one parameter, a scalar
51             } elsif (@_ == 1 && ! ref($_[0])) {
52            
53             # make new cvst object from curve file
54 0         0 _new_from_file($self, shift());
55            
56             } else {
57            
58             # error
59 0         0 croak('\'cvst\' invalid parameter');
60            
61             }
62            
63             }
64              
65             # bless object
66 11         22 bless($self, $class);
67              
68             # return object reference
69 11         23 return($self);
70              
71             }
72              
73             # create inverse 'cvst' object
74             # returns: (ref_to_object)
75             sub inv {
76              
77             # get object
78 0     0 0 0 my $self = shift();
79              
80             # local variables
81 0         0 my ($array);
82              
83             # for each curve object
84 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
85            
86             # verify curve object has 'inv' method
87 0 0       0 ($self->[1][$i]->can('inv')) or croak('curve element lacks \'inv\' method');
88            
89             # make inverse curve object
90 0         0 $array->[$i] = $self->[1][$i]->inv();
91            
92             }
93              
94             # return
95 0         0 return(ICC::Profile::cvst->new($array));
96              
97             }
98              
99             # create cvst object from ICC profile
100             # assumes file handle is positioned at start of cvst data
101             # header information must be read separately by the calling function
102             # parameters: (ref_to_parent_object, file_handle, input_channels, output_channels)
103             # returns: (ref_to_object)
104             sub new_fh {
105              
106             # get object class
107 0     0 0 0 my $class = shift();
108              
109             # create empty cvst object
110 0         0 my $self = [
111             {}, # object header
112             [], # curve object array
113             ];
114              
115             # verify 3 parameters
116 0 0       0 (@_ == 3) or croak('wrong number of parameters');
117              
118             # read cvst data from profile
119 0         0 _readICCcvst($self, @_);
120              
121             # bless object
122 0         0 bless($self, $class);
123            
124             # return object reference
125 0         0 return($self);
126              
127             }
128              
129             # writes cvst tag object to ICC profile
130             # parameters: (ref_to_parent_object, file_handle, ref_to_tag_table_entry)
131             sub write_fh {
132              
133             # verify 4 parameters
134 0 0   0 0 0 (@_ == 4) or croak('wrong number of parameters');
135              
136             # write cvst data to profile
137 0         0 goto &_writeICCcvst;
138              
139             }
140              
141             # get cvst size (for writing to profile)
142             # returns: (cvst_size)
143             sub size {
144              
145             # get parameter
146 0     0 0 0 my $self = shift();
147              
148             # get size of header and table
149 0         0 my $size = 12 + 8 * @{$self->[1]};
  0         0  
150              
151             # for each curve object
152 0         0 for my $crv (@{$self->[1]}) {
  0         0  
153            
154             # add size
155 0         0 $size += $crv->size();
156            
157             # adjust to 4-byte boundary
158 0         0 $size += -$size % 4;
159            
160             }
161              
162             # return size
163 0         0 return($size);
164              
165             }
166              
167             # get number of input channels
168             # returns: (number)
169             sub cin {
170              
171             # get object reference
172 22     22 0 29 my $self = shift();
173              
174             # return
175 22         38 return(scalar(@{$self->[1]}));
  22         66  
176              
177             }
178              
179             # get number of output channels
180             # returns: (number)
181             sub cout {
182              
183             # get object reference
184 10     10 0 14 my $self = shift();
185              
186             # return
187 10         13 return(scalar(@{$self->[1]}));
  10         24  
188              
189             }
190              
191             # transform data
192             # hash key: 'clip'
193             # supported input types:
194             # parameters: (list, [hash])
195             # parameters: (vector, [hash])
196             # parameters: (matrix, [hash])
197             # parameters: (Math::Matrix_object, [hash])
198             # parameters: (structure, [hash])
199             # returns: (same_type_as_input)
200             sub transform {
201              
202             # set hash value (0 or 1)
203 0 0   0 0 0 my $h = ref($_[-1]) eq 'HASH' ? 1 : 0;
204              
205             # if input a 'Math::Matrix' object
206 0 0 0     0 if (@_ == $h + 2 && UNIVERSAL::isa($_[1], 'Math::Matrix')) {
    0 0        
    0          
207            
208             # call matrix transform
209 0         0 &_trans2;
210            
211             # if input an array reference
212             } elsif (@_ == $h + 2 && ref($_[1]) eq 'ARRAY') {
213            
214             # if array contains numbers (vector)
215 0 0 0     0 if (! ref($_[1][0]) && @{$_[1]} == grep {Scalar::Util::looks_like_number($_)} @{$_[1]}) {
  0 0 0     0  
  0         0  
  0         0  
216            
217             # call vector transform
218 0         0 &_trans1;
219            
220             # if array contains vectors (2-D array)
221 0 0       0 } elsif (ref($_[1][0]) eq 'ARRAY' && @{$_[1]} == grep {ref($_) eq 'ARRAY' && Scalar::Util::looks_like_number($_->[0])} @{$_[1]}) {
  0         0  
  0         0  
222            
223             # call matrix transform
224 0         0 &_trans2;
225            
226             } else {
227            
228             # call structure transform
229 0         0 &_trans3;
230            
231             }
232            
233             # if input a list (of numbers)
234 0         0 } elsif (@_ == $h + 1 + grep {Scalar::Util::looks_like_number($_)} @_) {
235            
236             # call list transform
237 0         0 &_trans0;
238            
239             } else {
240            
241             # error
242 0         0 croak('invalid transform input');
243            
244             }
245              
246             }
247              
248             # invert data
249             # hash key: 'clip'
250             # supported input types:
251             # parameters: (list, [hash])
252             # parameters: (vector, [hash])
253             # parameters: (matrix, [hash])
254             # parameters: (Math::Matrix_object, [hash])
255             # parameters: (structure, [hash])
256             # returns: (same_type_as_input)
257             sub inverse {
258              
259             # set hash value (0 or 1)
260 0 0   0 0 0 my $h = ref($_[-1]) eq 'HASH' ? 1 : 0;
261              
262             # if input a 'Math::Matrix' object
263 0 0 0     0 if (@_ == $h + 2 && UNIVERSAL::isa($_[1], 'Math::Matrix')) {
    0 0        
    0          
264            
265             # call matrix transform
266 0         0 &_inv2;
267            
268             # if input an array reference
269             } elsif (@_ == $h + 2 && ref($_[1]) eq 'ARRAY') {
270            
271             # if array contains numbers (vector)
272 0 0 0     0 if (! ref($_[1][0]) && @{$_[1]} == grep {Scalar::Util::looks_like_number($_)} @{$_[1]}) {
  0 0 0     0  
  0         0  
  0         0  
273            
274             # call vector transform
275 0         0 &_inv1;
276            
277             # if array contains vectors (2-D array)
278 0 0       0 } elsif (ref($_[1][0]) eq 'ARRAY' && @{$_[1]} == grep {ref($_) eq 'ARRAY' && Scalar::Util::looks_like_number($_->[0])} @{$_[1]}) {
  0         0  
  0         0  
279            
280             # call matrix transform
281 0         0 &_inv2;
282            
283             } else {
284            
285             # call structure transform
286 0         0 &_inv3;
287            
288             }
289            
290             # if input a list (of numbers)
291 0         0 } elsif (@_ == $h + 1 + grep {Scalar::Util::looks_like_number($_)} @_) {
292            
293             # call list transform
294 0         0 &_inv0;
295            
296             } else {
297            
298             # error
299 0         0 croak('invalid transform input');
300            
301             }
302              
303             }
304              
305             # compute Jacobian matrix
306             # hash key 'diag' for diagonal vector
307             # parameters: (input_vector, [hash])
308             # returns: (Jacobian_matrix, [output_vector])
309             sub jacobian {
310              
311             # get parameters
312 0     0 0 0 my ($self, $in, $hash) = @_;
313              
314             # local variables
315 0         0 my (@drv, $out, $jac);
316              
317             # for each channel
318 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
319            
320             # compute derivative
321 0         0 $drv[$i] = $self->[1][$i]->derivative($in->[$i]);
322            
323             # compute transform
324 0 0       0 $out->[$i] = $self->[1][$i]->transform($in->[$i]) if wantarray;
325            
326             }
327              
328             # if 'diag' enabled
329 0 0       0 if ($hash->{'diag'}) {
330            
331             # make diagonal vector
332 0         0 $jac = [@drv];
333            
334             } else {
335            
336             # make diagonal matrix
337 0         0 $jac = Math::Matrix->diagonal(@drv);
338            
339             }
340              
341             # if output values wanted
342 0 0       0 if (wantarray) {
343            
344             # return Jacobian matrix and output vector
345 0         0 return($jac, $out);
346            
347             } else {
348            
349             # return Jacobian matrix only
350 0         0 return($jac);
351            
352             }
353            
354             }
355              
356             # compute parametric Jacobian matrix
357             # parameters are selected by the 'slice' array -or- matrix
358             # note: see 'cvst_parajac_matrix.plx' for explanation
359             # parameters: (input_vector)
360             # returns: (parametric_jacobian_matrix)
361             sub parajac {
362              
363             # get parameters
364 0     0 0 0 my ($self, $in) = @_;
365              
366             # local variables
367 0         0 my ($s, $type, @pj, $jac);
368              
369             # verify curve object has 'parametric' method
370 0 0       0 ($self->[1][0]->can('parametric')) or croak("curve object has no 'parametric' method");
371              
372             # get 'slice' value
373 0         0 $s = $self->[0]{'slice'};
374              
375             # determine 'slice' type (0 is undef, 1 is vector, 2 is matrix)
376 0 0 0     0 $type = ! defined($s) ? 0 : ICC::Shared::is_num_vector($s) ? 1 : ICC::Shared::is_num_matrix($s) && @{$s} == @{$self->[1]} ? 2 : croak("invalid slice for 'parajac' method");
    0          
    0          
377              
378             # initialize matrix
379 0         0 $jac = [map {[]} 0 .. $#{$self->[1]}];
  0         0  
  0         0  
380              
381             # for each channel
382 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
383            
384             # skip if slice empty
385 0 0 0     0 next if (($type == 1 && ! @{$s}) || ($type == 2 && ! @{$s->[$i]}));
  0   0     0  
  0   0     0  
386            
387             # get parametric partial derivatives
388 0         0 @pj = $self->[1][$i]->parametric($in->[$i]);
389            
390             # for each channel
391 0         0 for my $j (0 .. $#{$self->[1]}) {
  0         0  
392            
393             # if current channel
394 0 0       0 if ($j == $i) {
395            
396             # if vector slice
397 0 0       0 if ($type == 1) {
    0          
398            
399             # push slice parameters on matrix row
400 0         0 push(@{$jac->[$j]}, @pj[@{$s}]);
  0         0  
  0         0  
401            
402             # if matrix slice
403             } elsif ($type == 2) {
404            
405             # push slice parameters on matrix row
406 0         0 push(@{$jac->[$j]}, @pj[@{$s->[$i]}]);
  0         0  
  0         0  
407            
408             } else {
409            
410             # push all parameters on matrix row
411 0         0 push(@{$jac->[$j]}, @pj);
  0         0  
412            
413             }
414            
415             } else {
416            
417             # if vector slice
418 0 0       0 if ($type == 1) {
    0          
419            
420             # push zeros on matrix row
421 0         0 push(@{$jac->[$j]}, (0) x @{$s});
  0         0  
  0         0  
422            
423             # if matrix slice
424             } elsif ($type == 2) {
425            
426             # push zeros on matrix row
427 0         0 push(@{$jac->[$j]}, (0) x @{$s->[$i]});
  0         0  
  0         0  
428            
429             } else {
430            
431             # push zeros on matrix row
432 0         0 push(@{$jac->[$j]}, (0) x @pj);
  0         0  
433            
434             }
435            
436             }
437            
438             }
439            
440             }
441              
442             # return Jacobian matrix
443 0         0 return(bless($jac, 'Math::Matrix'));
444              
445             }
446              
447             # get/set reference to header hash
448             # parameters: ([ref_to_new_hash])
449             # returns: (ref_to_hash)
450             sub header {
451            
452             # get object reference
453 0     0 0 0 my $self = shift();
454            
455             # if there are parameters
456 0 0       0 if (@_) {
457            
458             # if one parameter, a hash reference
459 0 0 0     0 if (@_ == 1 && ref($_[0]) eq 'HASH') {
460            
461             # set header to new hash
462 0         0 $self->[0] = {%{shift()}};
  0         0  
463            
464             } else {
465            
466             # error
467 0         0 croak('parameter must be a hash reference');
468            
469             }
470            
471             }
472            
473             # return reference
474 0         0 return($self->[0]);
475            
476             }
477              
478             # get/set array reference
479             # parameters: ([ref_to_new_array])
480             # returns: (ref_to_array)
481             sub array {
482              
483             # get object reference
484 65     65 0 98 my $self = shift();
485              
486             # if one parameter supplied
487 65 50       187 if (@_ == 1) {
    50          
488            
489             # verify array reference
490 0 0       0 (ref($_[0]) eq 'ARRAY') or croak('not an array reference');
491              
492             # get array reference
493 0         0 my $array = shift();
494            
495             # for each curve element
496 0         0 for my $i (0 .. $#{$array}) {
  0         0  
497            
498             # verify object has processing methods
499 0 0 0     0 ($array->[$i]->can('transform') && $array->[$i]->can('derivative')) or croak('curve element lacks \'transform\' or \'derivative\' method');
500            
501             # add curve element
502 0         0 $self->[1][$i] = $array->[$i];
503            
504             }
505            
506             } elsif (@_) {
507            
508             # error
509 0         0 croak("too many parameters\n");
510            
511             }
512            
513             # return array reference
514 65         180 return($self->[1]);
515            
516             }
517              
518             # get 'para' or 'parf' curve parameters
519             # returns: (ref_to_array)
520             sub pars {
521              
522             # get object reference
523 0     0 0 0 my $self = shift();
524              
525             # local variables
526 0         0 my ($pars);
527              
528             # for each curve
529 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
530            
531             # verify curve is a 'para' or 'parf' object
532 0 0 0     0 (UNIVERSAL::isa($self->[1][$i], 'ICC::Profile::para') || UNIVERSAL::isa($self->[1][$i], 'ICC::Profile::parf')) or croak('curve is not a \'para\' or \'parf\' object');
533            
534             # copy parameters
535 0         0 $pars->[$i] = [@{$self->[1][$i]->array}];
  0         0  
536            
537             }
538              
539             # return parameter array
540 0         0 return($pars);
541              
542             }
543              
544             # make new 'cvst' object containing 'curv' objects
545             # assumes curve domain/range is (0 - 1)
546             # direction: 0 - normal, 1 - inverse
547             # parameters: (number_of_table_entries, [direction])
548             # returns: (cvst_object)
549             sub curv {
550              
551             # get parameters
552 0     0 0 0 my ($self, $n, $dir) = @_;
553              
554             # local variables
555 0         0 my ($curv);
556              
557             # for each channel
558 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
559            
560             # create table array
561 0         0 $curv->[$i] = $self->[1][$i]->curv($n, $dir);
562            
563             }
564              
565             # return 'cvst' object
566 0         0 return(ICC::Profile::cvst->new($curv));
567              
568             }
569              
570             # write Agfa Apogee tone curve file
571             # assumes curve domain/range is (0 - 1)
572             # options parameter may be a hash reference or direction flag
573             # hash keys: 'dir', 'steps'
574             # direction: 0 - normal, 1 - inverse
575             # parameters: (file_path, [options])
576             sub apogee {
577              
578             # get parameters
579 0     0 0 0 my ($self, $path, $opts) = @_;
580              
581             # local variables
582 0         0 my ($dir, $steps, %ink);
583 0         0 my ($dom, $root, @obj);
584 0         0 my ($i, @out);
585              
586             # process options
587 0         0 ($dir, $steps) = _options($opts);
588              
589             # set ink hash
590 0         0 %ink = ('Cyan', 0, 'Magenta', 1, 'Yellow', 2, 'Black', 3);
591              
592             # filter path
593 0         0 ICC::Shared::filterPath($path);
594              
595             # open curve set template
596 0 0       0 eval {$dom = XML::LibXML->load_xml('location' => ICC::Shared::getICCPath('Templates/Apogee_template.xml'))} or croak('can\'t load Apogee curve template');
  0         0  
597              
598             # get the root element
599 0         0 $root = $dom->documentElement();
600              
601             # get the 'Curve' nodes
602 0         0 @obj = $root->findnodes('Curve');
603              
604             # for each 'Curve' node
605 0         0 for my $n (@obj) {
606            
607             # look-up the color index (0 - 3)
608 0         0 $i = $ink{$n->getAttribute('Name')};
609            
610             # set the 'Stimuli' values
611 0         0 $n->setAttribute('Stimuli', join(' ', @{$steps}));
  0         0  
612            
613             # set the 'Measured' values
614 0         0 $n->setAttribute('Measured', join(' ', @{$steps}));
  0         0  
615            
616             # compute and set the 'Wanted' values
617 0         0 $n->setAttribute('Wanted', join(' ', map {sprintf("%f", 100 * ($self->[1][$i]->_transform($dir, $_/100)))} @{$steps}));
  0         0  
  0         0  
618            
619             # compute and set the 'TransferCurve' values
620 0         0 $n->setAttribute('TransferCurve', join(' ', map {sprintf("%f", 100 * ($self->[1][$i]->_transform($dir, $_/255)))} (0 .. 255)));
  0         0  
621            
622             }
623              
624             # add namespace attribute
625 0         0 $root->setAttribute('xmlns', 'file:///procres');
626              
627             # write XML file
628 0         0 $dom->toFile($path, 1);
629              
630             }
631              
632             # write CGATS tone curve file
633             # assumes curve domain/range is (0 - 1)
634             # options parameter may be a hash reference or direction flag
635             # hash keys: 'dir', 'steps'
636             # direction: 0 - normal, 1 - inverse
637             # parameters: (file_path, [options])
638             sub cgats {
639              
640             # get parameters
641 0     0 0 0 my ($self, $path, $opts) = @_;
642              
643             # local variables
644 0         0 my ($dir, $steps, $mat, $fmt, $chart);
645              
646             # process options
647 0         0 ($dir, $steps) = _options($opts);
648              
649             # filter path
650 0         0 ICC::Shared::filterPath($path);
651              
652             # for each step
653 0         0 for my $i (0 .. $#{$steps}) {
  0         0  
654            
655             # add SampleID
656 0         0 $mat->[$i][0] = "A$i";
657            
658             # add input step value
659 0         0 $mat->[$i][1] = sprintf("\"%.2f\"", $steps->[$i]);
660            
661             # for each curve
662 0         0 for my $j (0 .. $#{$self->[1]}) {
  0         0  
663            
664             # add output step value
665 0         0 $mat->[$i][$j + 2] = sprintf("%.2f", 100 * ($self->[1][$j]->_transform($dir, $steps->[$i]/100)));
666            
667             }
668            
669             }
670              
671             # make format string
672 0         0 $fmt = [qw(SampleID SAMPLE_NAME CMYK_C CMYK_M CMYK_Y CMYK_K), map {"SPOT_$_"} 1 .. ($#{$self->[1]} - 3)];
  0         0  
  0         0  
673              
674             # make Chart object
675 0         0 $chart = ICC::Support::Chart->new($mat, {'format' => $fmt});
676              
677             # add keywords
678 0         0 $chart->keyword('ORIGINATOR', '"PressCal"');
679 0         0 $chart->created(time);
680 0         0 $chart->keyword('LGOROWLENGTH', 5);
681              
682             # write chart object
683 0         0 $chart->write($path);
684              
685             }
686              
687             # write device link profile containing tone curves
688             # assumes curve domain/range is (0 - 1)
689             # options parameter may be a hash reference or direction flag
690             # hash key: 'dir'
691             # direction: 0 - normal, 1 - inverse
692             # parameters: (file_path, [options])
693             sub device_link {
694              
695             # get parameters
696 0     0 0 0 my ($self, $path, $opts) = @_;
697              
698             # local variables
699 0         0 my ($dir, $n, $sig, $clrt, $profile, $b);
700              
701             # process options
702 0         0 ($dir) = _options($opts);
703              
704             # get number of channels
705 0         0 $n = @{$self->[1]};
  0         0  
706              
707             # filter path
708 0         0 ICC::Shared::filterPath($path);
709              
710             # if grayscale
711 0 0       0 if ($n == 1) {
    0          
    0          
712            
713             # make signature
714 0         0 $sig = 'GRAY';
715            
716             } elsif ($n == 3) {
717            
718             # make signature
719 0         0 $sig = 'RGB ';
720            
721             } elsif ($n == 4) {
722            
723             # make signature
724 0         0 $sig = 'CMYK';
725            
726             } else {
727            
728             # make signature
729 0         0 $sig = sprintf("%XCLR", $n);
730            
731             # make colorant tag (could be developed further)
732 0         0 $clrt = ICC::Profile::clrt->new();
733            
734             }
735              
736             # make device link profile object
737 0         0 $profile = ICC::Profile->new({'class' => 'link', 'data' => $sig, 'PCS' => $sig, 'version' => '04200000'});
738              
739             # add copyright tag
740 0         0 $profile->tag({'cprt' => ICC::Profile::mluc->new('en', 'US', 'Copyright (c) 2004-2019 by William B. Birkett')});
741              
742             # add description tag
743 0         0 $profile->tag({'desc' => ICC::Profile::mluc->new('en', 'US', 'tone curves')});
744              
745             # add profile sequence tag
746 0         0 $profile->tag({'pseq' => ICC::Profile::pseq->new()});
747              
748             # for each curve
749 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
750            
751             # if direction is forward and curve is an ICC::Profile object
752 0 0 0     0 if ($dir == 0 && (UNIVERSAL::isa($self->[1][$i], 'ICC::Profile::curv') || UNIVERSAL::isa($self->[1][$i], 'ICC::Profile::para'))) {
      0        
753            
754             # use curve object as-is
755 0         0 $b->[$i] = $self->[1][$i];
756            
757             } else {
758            
759             # use ICC::Profile::curv equivalent
760 0         0 $b->[$i] = $self->[1][$i]->curv(1285, $dir);
761            
762             }
763            
764             }
765              
766             # add A2B0 tag (B-curves only)
767 0         0 $profile->tag({'A2B0' => ICC::Profile::mAB_->new({'b_curves' => ICC::Profile::cvst->new($b)})});
768              
769             # add colorant tags, if nCLR
770 0 0       0 $profile->tag({'clrt' => $clrt, 'clot' => $clrt}) if (defined($clrt));
771              
772             # write profile
773 0         0 $profile->write($path);
774              
775             }
776              
777             # write EFI (.vpc/.vcc) tone curve file
778             # assumes curve domain/range is (0 - 1)
779             # options parameter may be a hash reference or direction flag
780             # hash keys: 'dir', 'steps'
781             # direction: 0 - normal, 1 - inverse
782             # parameters: (file_path, [options])
783             sub efi {
784              
785             # get parameters
786 0     0 0 0 my ($self, $path, $opts) = @_;
787              
788             # local variables
789 0         0 my ($dir, $steps, @ch, $include, $tt, $t, $fh, $str, $vars);
790              
791             # process options
792 0         0 ($dir, $steps) = _options($opts);
793              
794             # filter path
795 0         0 ICC::Shared::filterPath($path);
796              
797             # channel lookup (EFI ink sequence is YMCK)
798 0         0 @ch = (2, 1, 0, 3, 4, 5, 6, 7);
799              
800             # if ICC::Templates folder is found in @INC (may be relative)
801 0 0       0 if (($include) = grep {-d} map {File::Spec->catdir($_, 'ICC', 'Templates')} @INC) {
  0         0  
  0         0  
802            
803             # make a template processing object
804 0         0 $tt = Template->new({'INCLUDE_PATH' => $include});
805            
806             # for each curve
807 0         0 for my $i (0 .. 7) {
808            
809             # open file handle to string
810 0         0 open($fh, '>', \$str);
811            
812             # print header
813 0         0 print $fh "BEGIN\n";
814            
815             # if curve object is defined
816 0 0       0 if (defined($self->[1][$i])) {
817            
818             # print number of points
819 0         0 printf $fh "%d\n", scalar(@{$steps});
  0         0  
820            
821             # for each curve input
822 0         0 for my $t (@{$steps}) {
  0         0  
823            
824             # print output and input device values
825 0         0 printf $fh "%.5f %.5f\n", $self->[1][$i]->_transform($dir, $t/100), $t/100;
826            
827             }
828            
829             # for each integer byte value
830 0         0 for my $t (0 .. 255) {
831            
832             # print input and output values
833 0         0 printf $fh "%d %.0f\n", $t, 255 * $self->[1][$i]->_transform($dir, $t/255);
834            
835             }
836            
837             } else {
838            
839             # print identity curve
840 0         0 print $fh "2\n0.00000 0.00000\n1.00000 1.00000\n";
841            
842             # for each integer byte value
843 0         0 for my $t (0 .. 255) {
844            
845             # print input and output values
846 0         0 printf $fh "%d %d\n", $t, $t;
847            
848             }
849            
850             }
851            
852             # print footer
853 0         0 print $fh "END";
854            
855             # add string to template hash
856 0         0 $vars->{"curve$ch[$i]"} = $str;
857            
858             # close file handle
859 0         0 close($fh);
860            
861             }
862            
863             # make Time::Piece object
864 0         0 $t = localtime;
865            
866             # add date to template hash
867 0         0 $vars->{'date'} = $t->strftime('%m-%d-%y');
868            
869             # process the template
870 0 0       0 $tt->process('cvst_efi_vcc.tt2', $vars, $path) || CORE::die $tt->error();
871            
872             }
873            
874             }
875              
876             # write Fuji XMF tone curve file
877             # assumes curve domain/range is (0 - 1)
878             # options parameter may be a hash reference or direction flag
879             # hash key: 'dir'
880             # direction: 0 - normal, 1 - inverse
881             # parameters: (file_path, [options])
882             sub fuji_xmf {
883              
884             # get parameters
885 0     0 0 0 my ($self, $path, $opts) = @_;
886              
887             # local variables
888 0         0 my ($dir, $steps, $fh, $rs, @colors, @Tdot);
889              
890             # process options
891 0         0 ($dir, $steps) = _options($opts);
892              
893             # filter path
894 0         0 ICC::Shared::filterPath($path);
895              
896             # open the file
897 0 0       0 open($fh, '>', $path) or croak("can't open $path: $!");
898              
899             # disable :crlf translation
900 0         0 binmode($fh);
901              
902             # set output record separator (Windows CR-LF)
903 0         0 $rs = "\015\012";
904              
905             # set color list
906 0         0 @colors = qw(Cyan Magenta Yellow Black);
907              
908             # print colors
909 0         0 print $fh join(';', @colors), $rs;
910              
911             # for each step
912 0         0 for my $j (0 .. 100) {
913            
914             # if a valid dot value
915 0 0       0 if (grep {$j == $_} @{$steps}) {
  0         0  
  0         0  
916            
917             # for each channel
918 0         0 for my $i (0 .. 3) {
919            
920             # compute transformed dot value
921 0         0 $Tdot[$i] = sprintf("%.2f", 100 * ($self->[1][$i]->_transform($dir, $j/100)));
922            
923             }
924            
925             # print transformed values
926 0         0 print $fh join(';', @Tdot), $rs;
927            
928             } else {
929            
930             # print empty line
931 0         0 print $fh '‐;‐;‐;‐', $rs;
932            
933             }
934            
935             }
936              
937             # close the file
938 0         0 close($fh);
939              
940             }
941              
942             # write Harlequin tone curve file
943             # assumes curve domain/range is (0 - 1)
944             # options parameter may be a hash reference or direction flag
945             # hash key: 'dir'
946             # direction: 0 - normal, 1 - inverse
947             # note: values must be entered manually in RIP
948             # use 'navigator' method to make Postscript curves
949             # parameters: (file_path, [options])
950             sub harlequin {
951              
952             # get parameters
953 0     0 0 0 my ($self, $path, $opts) = @_;
954              
955             # local variables
956 0         0 my ($dir, $steps, @files, $fh, $rs, @colors);
957              
958             # process options
959 0         0 ($dir, $steps) = _options($opts);
960              
961             # filter path
962 0         0 ICC::Shared::filterPath($path);
963              
964             # open the file
965 0 0       0 open($fh, '>', $path) or croak("can't open $path: $!");
966              
967             # disable :crlf translation
968 0         0 binmode($fh);
969              
970             # set output record separator (Windows CR-LF)
971 0         0 $rs = "\015\012";
972            
973             # set color list
974 0         0 @colors = qw(Cyan Magenta Yellow Black);
975              
976             # for each channel
977 0         0 for my $i (0 .. 3) {
978            
979             # print color
980 0         0 print $fh "$colors[$i]$rs";
981            
982             # for each step
983 0         0 for my $j (0 .. $#{$steps}) {
  0         0  
984            
985             # print input and transformed values
986 0         0 printf $fh "%7.2f %7.2f$rs", $steps->[$j], 100 * ($self->[1][$i]->_transform($dir, $steps->[$j]/100));
987            
988             }
989            
990             # print space
991 0         0 print $fh "$rs$rs";
992            
993             }
994              
995             # close the file
996 0         0 close($fh);
997              
998             }
999              
1000             # write HP Indigo tone curve file set
1001             # assumes curve domain/range is (0 - 1)
1002             # options parameter may be a hash reference or direction flag
1003             # hash key: 'dir'
1004             # direction: 0 - normal, 1 - inverse
1005             # parameters: (folder_path, [options])
1006             sub indigo {
1007              
1008             # get parameters
1009 0     0 0 0 my ($self, $path, $opts) = @_;
1010              
1011             # local variables
1012 0         0 my ($dir, $steps, $rs, $fh, $file);
1013 0         0 my (@CMYK, $dotr, $dotp);
1014              
1015             # process options
1016 0         0 ($dir, $steps) = _options($opts);
1017              
1018             # set output record separator (Windows CR-LF)
1019 0         0 $rs = "\015\012";
1020              
1021             # filter path
1022 0         0 ICC::Shared::filterPath($path);
1023              
1024             # make the folder
1025 0         0 File::Path::make_path($path);
1026              
1027             # ink color array (for building file names)
1028 0         0 @CMYK = qw(Cyan Magenta Yellow Black);
1029              
1030             # for each color
1031 0         0 for my $i (0 .. 3) {
1032            
1033             # build the file path
1034 0 0       0 $file = $^O eq 'MSWin32' ? "$path\\tone_curve-$CMYK[$i].lut" : "$path/tone_curve-$CMYK[$i].lut";
1035            
1036             # create the file
1037 0 0       0 open($fh, '>', $file) or croak("can't open $file: $!");
1038            
1039             # disable :crlf translation
1040 0         0 binmode($fh);
1041              
1042             # for each step
1043 0         0 for my $j (0 .. $#{$steps}) {
  0         0  
1044            
1045             # get reference device value
1046 0         0 $dotr = $steps->[$j]/100;
1047            
1048             # get press device value
1049 0         0 $dotp = $self->[1][$i]->_transform($dir, $dotr);
1050            
1051             # limit %-dot (0 - 100)
1052 0 0       0 $dotr = ($dotr < 0) ? 0 : $dotr;
1053 0 0       0 $dotp = ($dotp < 0) ? 0 : $dotp;
1054 0 0       0 $dotr = ($dotr > 1) ? 1 : $dotr;
1055 0 0       0 $dotp = ($dotp > 1) ? 1 : $dotp;
1056            
1057             # print step info
1058 0         0 printf $fh "%4.2f\t%6.4f$rs", $dotr, $dotp;
1059            
1060             }
1061            
1062             # close file
1063 0         0 close($fh);
1064            
1065             }
1066            
1067             }
1068              
1069             # write ISO 18620 (TED) tone curve file
1070             # assumes curve domain/range is (0 - 1)
1071             # options parameter may be a hash reference or direction flag
1072             # hash keys: 'dir', 'steps', 'inks', 'origin',
1073             # 'Creator', 'OperatorName', 'PressName', 'MediaName',
1074             # 'TransferCurveSetID', 'Side'
1075             # direction: 0 - normal, 1 - inverse
1076             # parameters: (file_path, [options])
1077             sub iso_18620 {
1078              
1079             # get parameters
1080 0     0 0 0 my ($self, $path, $opts) = @_;
1081              
1082             # local variables
1083 0         0 my ($dir, $steps, @inks, $zflag);
1084 0         0 my ($doc, $root, $t, $datetime, $curve, @out);
1085              
1086             # process options
1087 0         0 ($dir, $steps) = _options($opts);
1088              
1089             # set ink colors
1090 0 0       0 @inks = $#{$self->[1]} ? qw(Cyan Magenta Yellow Black) : qw(Black);
  0         0  
1091              
1092             # for each curve
1093 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
1094            
1095             # set ink value, defaults to 'inkN'
1096 0   0     0 $inks[$i] = $opts->{'inks'}[$i] // $self->[0]{'inks'}[$i] // $inks[$i] // sprintf("ink%d", $i + 1);
      0        
      0        
1097            
1098             }
1099              
1100             # filter path
1101 0         0 ICC::Shared::filterPath($path);
1102              
1103             # create XML document
1104 0         0 $doc = XML::LibXML->createDocument('1.0', 'UTF-8');
1105              
1106             # create root element
1107 0         0 $root = $doc->createElement('TransferCurveSet');
1108              
1109             # add root node
1110 0         0 $doc->setDocumentElement($root);
1111              
1112             # make Time::Piece object
1113 0         0 $t = localtime;
1114              
1115             # set 'CreationDate' attribute
1116 0         0 $root->setAttribute('CreationDate', sprintf("%s%+03d:00", $t->datetime, $t->tzoffset->hours));
1117              
1118             # verify 'Side' attribute
1119 0 0 0     0 (! defined($opts->{'Side'}) || $opts->{'Side'} eq 'Front' || $opts->{'Side'} eq 'Back') or croak('invalid \'Side\' attribute');
      0        
1120              
1121             # for each optional TransferCurveSet attribute
1122 0         0 for my $key (qw(Creator OperatorName PressName MediaName TransferCurveSetID Side)) {
1123            
1124             # if attribute contained in hash
1125 0 0       0 if (defined($opts->{$key})) {
1126            
1127             # set attribute value
1128 0         0 $root->setAttribute($key, $opts->{$key});
1129            
1130             }
1131            
1132             }
1133              
1134             # set 'Creator' attribute, if undefined
1135 0 0       0 $root->setAttribute('Creator', 'ICC-Profile Toolkit') if (! defined($opts->{'Creator'}));
1136              
1137             # get 'origin' flag
1138 0   0     0 $zflag = $opts->{'origin'} // 0;
1139              
1140             # for each curve
1141 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
1142            
1143             # create curve element
1144 0         0 $curve = $doc->createElement('TransferCurve');
1145            
1146             # set the 'Separation' attribute
1147 0         0 $curve->setAttribute('Separation', $inks[$i]);
1148            
1149             # compute and set the 'Curve' values
1150 0 0 0     0 $curve->setAttribute('Curve', join(' ', map {sprintf("%f %f", $_/100, ($_ == 0 && $zflag) ? 0 : $self->[1][$i]->_transform($dir, $_/100))} @{$steps}));
  0         0  
  0         0  
1151            
1152             # add curve node
1153 0         0 $root->addChild($curve);
1154            
1155             }
1156              
1157             # add namespace attribute
1158 0         0 $root->setAttribute('xmlns', 'http://www.npes.org/schema/ISO18620/');
1159              
1160             # write XML file
1161 0         0 $doc->toFile($path, 1);
1162              
1163             }
1164              
1165             # write Xitron Navigator tone curve file
1166             # assumes curve domain/range is (0 - 1)
1167             # options parameter may be a hash reference or direction flag
1168             # hash key: 'dir', 'inks', 'name', 'colorspace'
1169             # direction: 0 - normal, 1 - inverse
1170             # note: makes a Postscript file for 'push calibration'
1171             # see Harlequin technical note Hqn081
1172             # parameters: (file_path, [options])
1173             sub navigator {
1174              
1175             # get parameters
1176 0     0 0 0 my ($self, $path, $opts) = @_;
1177              
1178             # local variables
1179 0         0 my ($dir, $steps, @inks, $tt, $include, $vars, $fh, $str);
1180              
1181             # process options
1182 0         0 ($dir, $steps) = _options($opts);
1183              
1184             # set ink colors
1185 0 0       0 @inks = $#{$self->[1]} ? qw(Cyan Magenta Yellow Black) : qw(Black);
  0         0  
1186              
1187             # for each curve
1188 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
1189            
1190             # set ink value, defaults to 'inkN'
1191 0   0     0 $inks[$i] = $opts->{'inks'}[$i] // $self->[0]{'inks'}[$i] // $inks[$i] // sprintf("ink%d", $i + 1);
      0        
      0        
1192            
1193             }
1194              
1195             # filter path
1196 0         0 ICC::Shared::filterPath($path);
1197              
1198             # if ICC::Templates folder is found in @INC (may be relative)
1199 0 0       0 if (($include) = grep {-d} map {File::Spec->catdir($_, 'ICC', 'Templates')} @INC) {
  0         0  
  0         0  
1200            
1201             # make a template processing object
1202 0         0 $tt = Template->new({'INCLUDE_PATH' => $include});
1203            
1204             # set channels
1205 0         0 $vars->{'channels'} = join(' ', map {"/$_"} @inks);
  0         0  
1206            
1207             # set channel colors
1208 0         0 $vars->{'channelcolors'} = join(' ', map {"($_)"} @inks);
  0         0  
1209            
1210             # set number of channels
1211 0         0 $vars->{'number'} = @inks;
1212            
1213             # set name
1214 0   0     0 $vars->{'name'} = $opts->{'name'} // 'PressCal Calset ' . time();
1215            
1216             # set colorspace
1217 0   0     0 $vars->{'colorspace'} = $opts->{'colorspace'} // 'DeviceCMYK';
1218            
1219             # open file handle to string
1220 0         0 open($fh, '>', \$str);
1221            
1222             # for each channel
1223 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
1224            
1225             # start curve
1226 0         0 printf $fh " /%s [\n", $inks[$i];
1227            
1228             # for each step
1229 0         0 for my $j (0 .. $#{$steps}) {
  0         0  
1230            
1231             # print input and transformed values
1232 0         0 printf $fh " %.2f %% C%s\n", 100 * ($self->[1][$i]->_transform($dir, $steps->[$j]/100)), $steps->[$j];
1233            
1234             }
1235            
1236             # end curve
1237 0         0 print $fh " ]\n";
1238            
1239             }
1240            
1241             # add string to template hash
1242 0         0 $vars->{'curves'} = $str;
1243            
1244             # close file handle
1245 0         0 close($fh);
1246            
1247             # process the template
1248 0 0       0 $tt->process('cvst_navigator.tt2', $vars, $path) || CORE::die $tt->error();
1249            
1250             }
1251              
1252             }
1253              
1254             # write Photoshop tone curve file
1255             # assumes curve domain/range is (0 - 1)
1256             # options parameter may be a hash reference or direction flag
1257             # hash keys: 'dir', 'steps'
1258             # direction: 0 - normal, 1 - inverse
1259             # note: Photoshop curves must have between 2 and 16 steps
1260             # parameters: (file_path, [options])
1261             sub photoshop {
1262              
1263             # get parameters
1264 0     0 0 0 my ($self, $path, $opts) = @_;
1265              
1266             # local variables
1267 0         0 my ($dir, $steps, $xval, $n, $fh, $x, $y, $xmin, $xmax, $xp, @yx);
1268              
1269             # process options
1270 0         0 ($dir, $steps) = _options($opts);
1271              
1272             # if 'steps' array supplied
1273 0 0       0 if (@{$steps}) {
  0 0       0  
    0          
1274            
1275             # copy step values
1276 0         0 $xval = [map {$_/100} @{$steps}];
  0         0  
  0         0  
1277            
1278             # verify maximum number of curve points
1279 0 0       0 ($#{$xval} < 16) or croak('photoshop curve steps array has more than 16 points');
  0         0  
1280            
1281             # verify minimum number of curve points
1282 0 0       0 ($#{$xval} > 0) or croak('photoshop curve steps array has less than 2 points');
  0         0  
1283            
1284             # if 'bern' curve objects
1285             } elsif (UNIVERSAL::isa($self->[1][0], 'ICC::Support::bern')) {
1286            
1287             # get maximum upper index of Bernstein coefficient arrays
1288 0 0       0 $n = ($#{$self->[1][0]->input} > $#{$self->[1][0]->output}) ? $#{$self->[1][0]->input} : $#{$self->[1][0]->output};
  0         0  
  0         0  
  0         0  
  0         0  
1289            
1290             # compute upper index
1291 0 0       0 $n = 2 * $n < 16 ? 2 * $n : 15;
1292            
1293             # make x-value array
1294 0         0 $xval = [map {$_/$n} (0 .. $n)];
  0         0  
1295            
1296             # if 'spline' curve objects
1297             } elsif (UNIVERSAL::isa($self->[1][0], 'ICC::Support::spline')) {
1298            
1299             # compute upper index
1300 0 0       0 $n = 2 * $#{$self->[1][0]->output} < 16 ? 2 * $#{$self->[1][0]->output} : 15;
  0         0  
  0         0  
1301            
1302             # make x-value array
1303 0         0 $xval = [map {$_/$n} (0 .. $n)];
  0         0  
1304            
1305             } else {
1306            
1307             # use default array (5 points)
1308 0         0 $xval = [map {$_/4} (0 .. 4)];
  0         0  
1309            
1310             }
1311              
1312             # sort the x-values from low to high
1313 0         0 @{$xval} = sort {$a <=> $b} @{$xval};
  0         0  
  0         0  
  0         0  
1314              
1315             # filter path
1316 0         0 ICC::Shared::filterPath($path);
1317              
1318             # open the file
1319 0 0       0 open($fh, '>', $path) or croak("can't open $path: $!");
1320              
1321             # set binary mode
1322 0         0 binmode($fh);
1323              
1324             # print the version and number of curves (including master curve)
1325 0         0 print $fh pack('n2', 4, scalar(@{$self->[1]}) + 1);
  0         0  
1326              
1327             # print null master curve
1328 0         0 print $fh pack('n5', 2, 0, 0, 255, 255);
1329              
1330             # for each channel
1331 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
1332            
1333             # compute min and max x-values (correspond to y-values of 0 and 1)
1334 0         0 $xmin = $self->[1][$i]->_transform((1 - $dir), 0);
1335 0         0 $xmax = $self->[1][$i]->_transform((1 - $dir), 1);
1336            
1337             # swap min and max if negative curve
1338 0 0       0 ($xmax, $xmin) = ($xmin, $xmax) if ($xmin > $xmax);
1339            
1340             # initialize point array
1341 0         0 @yx = ();
1342            
1343             # initialize previous x-value
1344 0         0 $xp = -1;
1345            
1346             # for each point
1347 0         0 for my $j (0 .. $#{$xval}) {
  0         0  
1348            
1349             # get x-value
1350 0         0 $x = $xval->[$j];
1351            
1352             # limit x-value (previously limited domain 0 - 1)
1353 0 0       0 $x = $x > $xmax ? $xmax : ($x < $xmin ? $xmin : $x);
    0          
1354            
1355             # skip if x-value same as previous
1356 0 0       0 next if ($x == $xp);
1357            
1358             # set previous x-value
1359 0         0 $xp = $x;
1360            
1361             # get y-value
1362 0         0 $y = $self->[1][$i]->_transform($dir, $x);
1363            
1364             # limit y-value
1365 0 0       0 $y = $y > 1 ? 1 : ($y < 0 ? 0 : $y);
    0          
1366            
1367             # push y-x pair on array (Photoshop curve points are [output, input])
1368 0         0 push(@yx, [$y, $x]);
1369            
1370             }
1371            
1372             # print number of points
1373 0         0 print $fh pack('n', scalar(@yx));
1374            
1375             # if 3 channels (RGB)
1376 0 0       0 if (@{$self->[1]} == 3) {
  0         0  
1377            
1378             # for each point
1379 0         0 for (@yx) {
1380            
1381             # print point value (y, x), normal for RGB
1382 0         0 print $fh pack('n2', map {255 * $_ + 0.5} @{$_});
  0         0  
  0         0  
1383            
1384             }
1385            
1386             } else {
1387            
1388             # for each point (in reverse order)
1389 0         0 for (reverse(@yx)) {
1390            
1391             # print point value (y, x), complemented for Grayscale, CMYK, Multichannel
1392 0         0 print $fh pack('n2', map {255 * (1 - $_) + 0.5} @{$_});
  0         0  
  0         0  
1393            
1394             }
1395            
1396             }
1397            
1398             }
1399              
1400             # close the file
1401 0         0 close($fh);
1402              
1403             # set file creator and type (OS X only)
1404 0         0 ICC::Shared::setFile($path, '8BIM', '8BSC');
1405              
1406             }
1407              
1408             # write Prinergy (Harmony) tone curve file
1409             # assumes curve domain/range is (0 - 1)
1410             # options parameter may be a hash reference or direction flag
1411             # hash keys: 'dir', 'Comments', 'CurveSet', 'DefaultFrequency', 'DefaultMedium',
1412             # 'DefaultResolution', 'DefaultSpotFunction', 'Enabled', 'FirstName', 'FreqFrom', 'FreqTo',
1413             # 'ID', 'Medium', 'Resolution', 'ScreeningType', 'SpotFunction', 'SpotFunctionMode'
1414             # direction: 0 - normal, 1 - inverse
1415             # parameters: (file_path, [options])
1416             sub prinergy {
1417              
1418             # get parameters
1419 0     0 0 0 my ($self, $path, $opts) = @_;
1420              
1421             # local variables
1422 0         0 my ($dir, $steps, @inks, $tt, $include, $vars, @time, @month, $fh, $rs, @map, $str);
1423              
1424             # process options
1425 0         0 ($dir, $steps) = _options($opts);
1426              
1427             # set ink colors
1428 0 0       0 @inks = $#{$self->[1]} ? qw(Cyan Magenta Yellow Black) : qw(Black);
  0         0  
1429              
1430             # for each curve
1431 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
1432            
1433             # set ink value, defaults to 'inkN'
1434 0   0     0 $inks[$i] = $opts->{'inks'}[$i] // $self->[0]{'inks'}[$i] // $inks[$i] // sprintf("ink%d", $i + 1);
      0        
      0        
1435            
1436             }
1437              
1438             # filter path
1439 0         0 ICC::Shared::filterPath($path);
1440              
1441             # if ICC::Templates folder is found in @INC (may be relative)
1442 0 0       0 if (($include) = grep {-d} map {File::Spec->catdir($_, 'ICC', 'Templates')} @INC) {
  0         0  
  0         0  
1443            
1444             # make a template processing object
1445 0         0 $tt = Template->new({'INCLUDE_PATH' => $include});
1446            
1447             # copy options hash
1448 0         0 $vars = Storable::dclone($opts);
1449            
1450             # set time
1451 0         0 $vars->{'Time'} = time();
1452            
1453             # get localtime
1454 0         0 @time = localtime($vars->{'Time'});
1455            
1456             # set date as string
1457 0         0 $vars->{'date'} = sprintf "%d/%d/%d %2.2d:%2.2d:%2.2d", $time[4] + 1, $time[3], $time[5] + 1900, $time[2], $time[1], $time[0];
1458              
1459             # make array of months
1460 0         0 @month = qw(January February March April May June July August September October November December);
1461              
1462             # set DateTime as string
1463 0         0 $vars->{'DateTime'} = sprintf "%2.2d %s %d %2.2d:%2.2d:%2.2d", $time[3], $month[$time[4]], $time[5] + 1900, $time[2], $time[1], $time[0];
1464            
1465             # set defaults
1466 0   0     0 $vars->{'FirstName'} = $vars->{'FirstName'} // 'PressCal';
1467 0   0     0 $vars->{'ID'} = $vars->{'ID'} // '0001';
1468 0   0     0 $vars->{'Enabled'} = $vars->{'Enabled'} // 'FALSE';
1469 0   0     0 $vars->{'CurveSet'} = $vars->{'CurveSet'} // 'CmykCurves';
1470 0   0     0 $vars->{'SpotFunctionMode'} = $vars->{'SpotFunctionMode'} // 'UserDefined';
1471            
1472             # set true or false
1473 0 0       0 $vars->{'MediumUsed'} = defined($vars->{'Medium'}) ? 'TRUE' : 'FALSE';
1474 0 0       0 $vars->{'ScreeningTypeUsed'} = defined($vars->{'ScreeningType'}) ? 'TRUE' : 'FALSE';
1475 0 0       0 $vars->{'ResolutionUsed'} = defined($vars->{'Resolution'}) ? 'TRUE' : 'FALSE';
1476 0 0 0     0 $vars->{'FrequencyUsed'} = (defined($vars->{'FreqFrom'}) && defined($vars->{'FreqFrom'})) ? 'TRUE' : 'FALSE';
1477 0 0       0 $vars->{'SpotFunctionUsed'} = defined($vars->{'SpotFunction'}) ? 'TRUE' : 'FALSE';
1478            
1479             # set combined description
1480 0         0 $vars->{'description'} = join(' ', grep {$_} @{$vars}{qw(FirstName Medium CurveSet FreqFrom Resolution)});
  0         0  
  0         0  
1481              
1482             # open file handle to string
1483 0         0 open($fh, '>', \$str);
1484            
1485             # disable :crlf translation
1486 0         0 binmode($fh);
1487            
1488             # set output record separator (Windows CR-LF)
1489 0         0 $rs = "\015\012";
1490              
1491             # set color map (KCMY + spot)
1492 0         0 @map = (3, 0, 1, 2, 4 .. 15);
1493            
1494             # for each channel
1495 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
1496            
1497             # print curve dropoff
1498 0         0 printf $fh "Curve%d DropOff = %d$rs", $i + 1, 0;
1499            
1500             # print curve color
1501 0         0 printf $fh "Curve%d Color = %s$rs", $i + 1, $inks[$map[$i]];
1502            
1503             # print curve start
1504 0         0 printf $fh "Curve%d = ", $i + 1;
1505            
1506             # print curve points
1507 0         0 for my $t (@{$steps}) {
  0         0  
1508            
1509             # print curve values
1510 0         0 printf $fh "%d %d ", 1E7 * $t/100 + 0.5, 1E7 * $self->[1][$map[$i]]->_transform($dir, $t/100) + 0.5;
1511            
1512             }
1513            
1514             # print curve end
1515 0         0 print $fh "$rs";
1516            
1517             }
1518            
1519             # add string to template hash
1520 0         0 $vars->{'curves'} = $str;
1521            
1522             # close the file
1523 0         0 close($fh);
1524            
1525             # process the template
1526 0 0       0 $tt->process('cvst_prinergy.tt2', $vars, $path) || CORE::die $tt->error();
1527            
1528             }
1529              
1530             }
1531              
1532             # write Rampage tone curve file set
1533             # assumes curve domain/range is (0 - 1)
1534             # options parameter may be a hash reference or direction flag
1535             # hash key: 'dir'
1536             # direction: 0 - normal, 1 - inverse
1537             # parameters: (folder_path, [options])
1538             sub rampage {
1539              
1540             # get parameters
1541 0     0 0 0 my ($self, $path, $opts) = @_;
1542              
1543             # local variables
1544 0         0 my ($dir, $steps, $name, $rs, $fh0, $fh1, $file);
1545 0         0 my (@CMYK, $dotr, $dotp);
1546              
1547             # process options
1548 0         0 ($dir, $steps) = _options($opts);
1549              
1550             # filter path
1551 0         0 ICC::Shared::filterPath($path);
1552              
1553             # make the folder, if needed
1554 0         0 File::Path::make_path($path);
1555              
1556             # get the folder name
1557 0         0 $name = (File::Spec->splitdir($path))[-1];
1558              
1559             # set output record separator (Windows CR-LF)
1560 0         0 $rs = "\015\012";
1561              
1562             # ink color array (for building file names)
1563 0         0 @CMYK = qw(C M Y K);
1564              
1565             # for each color
1566 0         0 for my $i (0 .. 3) {
1567            
1568             # build the DESIRED file path
1569 0         0 $file = $path . '/' . $name . '_DESIRED_' . $CMYK[$i];
1570            
1571             # create the DESIRED file
1572 0 0       0 open($fh0, '>', $file) or croak("can't open $file: $!");
1573            
1574             # disable :crlf translation
1575 0         0 binmode($fh0);
1576              
1577             # set file creator and type
1578 0         0 ICC::Shared::setFile($file, 'RamC', 'Clst');
1579            
1580             # build the ACT file path
1581 0         0 $file = $path . '/' . $name . '_ACT_' . $CMYK[$i];
1582            
1583             # create the ACT file
1584 0 0       0 open($fh1, '>', $file) or croak("can't open $file: $!");
1585            
1586             # disable :crlf translation
1587 0         0 binmode($fh1);
1588              
1589             # set file creator and type
1590 0         0 ICC::Shared::setFile($file, 'RamC', 'Clst');
1591            
1592             # print DESIRED header
1593 0         0 print $fh0 "2$rs";
1594 0         0 print $fh0 "0.0000000000$rs";
1595 0         0 print $fh0 "0.0000000000$rs";
1596 0         0 printf $fh0 "%2d$rs", $steps + 1;
1597            
1598             # print ACT header
1599 0         0 print $fh1 "2$rs";
1600 0         0 print $fh1 "0.0000000000$rs";
1601 0         0 print $fh1 "0.0000000000$rs";
1602 0         0 printf $fh1 "%2d$rs", $steps + 1;
1603            
1604             # for each step
1605 0         0 for my $j (0 .. $#{$steps}) {
  0         0  
1606            
1607             # get reference %-dot
1608 0         0 $dotr = $steps->[$j];
1609            
1610             # get press %-dot
1611 0         0 $dotp = 100 * $self->[1][$i]->_transform($dir, $dotr/100);
1612            
1613             # limit %-dot (0 - 100)
1614 0 0       0 $dotr = ($dotr < 0) ? 0 : $dotr;
1615 0 0       0 $dotp = ($dotp < 0) ? 0 : $dotp;
1616 0 0       0 $dotr = ($dotr > 100) ? 100 : $dotr;
1617 0 0       0 $dotp = ($dotp > 100) ? 100 : $dotp;
1618            
1619             # print DESIRED step info
1620 0         0 printf $fh0 "%3.1f %3.1f$rs", $dotr, $dotp;
1621            
1622             # print ACT step info
1623 0         0 printf $fh1 "%3.1f %3.1f$rs", $dotr, $dotr;
1624            
1625             }
1626            
1627             # print DESIRED footer
1628 0         0 print $fh0 "Version: 2.0$rs";
1629            
1630             # print ACT footer
1631 0         0 print $fh1 "Version: 2.0$rs";
1632            
1633             # close the DESIRED file
1634 0         0 close($fh0);
1635            
1636             # close the ACT file
1637 0         0 close($fh1);
1638            
1639             }
1640            
1641             }
1642              
1643             # write Xitron Sierra tone curve file
1644             # assumes curve domain/range is (0 - 1)
1645             # options parameter may be a hash reference or direction flag
1646             # hash key: 'dir'
1647             # direction: 0 - normal, 1 - inverse
1648             # parameters: (file_path, [options])
1649             sub sierra {
1650              
1651             # get parameters
1652 0     0 0 0 my ($self, $path, $opts) = @_;
1653              
1654             # local variables
1655 0         0 my ($dir, $steps, $fh, $rs, @colors, @Tdot);
1656              
1657             # process options
1658 0         0 ($dir, $steps) = _options($opts);
1659              
1660             # filter path
1661 0         0 ICC::Shared::filterPath($path);
1662              
1663             # open the file
1664 0 0       0 open($fh, '>', $path) or croak("can't open $path: $!");
1665              
1666             # disable :crlf translation
1667 0         0 binmode($fh);
1668              
1669             # set output record separator (Windows CR-LF)
1670 0         0 $rs = "\015\012";
1671              
1672             # set color list
1673 0         0 @colors = qw(Cyan Magenta Yellow Black);
1674              
1675             # print colors
1676 0         0 print $fh join(';', @colors), $rs;
1677              
1678             # for each step
1679 0         0 for my $j (0 .. $#{$steps}) {
  0         0  
1680            
1681             # for each channel
1682 0         0 for my $i (0 .. 3) {
1683            
1684             # compute transformed dot value
1685 0         0 $Tdot[$i] = sprintf("%.4f", 100 * ($self->[1][$i]->_transform($dir, $steps->[$j]/100)));
1686            
1687             }
1688            
1689             # print transformed values
1690 0         0 print $fh join(';', @Tdot), $rs;
1691            
1692             }
1693              
1694             # close the file
1695 0         0 close($fh);
1696              
1697             }
1698              
1699             # write Trueflow tone curve file
1700             # assumes curve domain/range is (0 - 1)
1701             # options parameter may be a hash reference or direction flag
1702             # hash key: 'dir'
1703             # direction: 0 - normal, 1 - inverse
1704             # parameters: (file_path, [options])
1705             sub trueflow {
1706              
1707             # get parameters
1708 0     0 0 0 my ($self, $path, $opts) = @_;
1709              
1710             # local variables
1711 0         0 my ($dir, $steps, @names, @colors, @map);
1712 0         0 my ($fh, $in, $out, $dg, @lut, $float);
1713              
1714             # process options
1715 0         0 ($dir, $steps) = _options($opts);
1716              
1717             # set curve names
1718 0         0 @names = qw(Y M C K);
1719              
1720             # set curve display colors (YMCK)
1721 0         0 @colors = (0x00ffff, 0xff00ff, 0xffff00, 0x000000);
1722              
1723             # set color map (YMCK)
1724 0         0 @map = (2, 1, 0, 3);
1725              
1726             # filter path
1727 0         0 ICC::Shared::filterPath($path);
1728              
1729             # open the file
1730 0 0       0 open($fh, '>', $path) or croak("can't open $path: $!");
1731              
1732             # set binary mode
1733 0         0 binmode($fh);
1734              
1735             # print the header
1736 0         0 print $fh pack('C4a4', 4, 3, 2, 1, 'DGT'); # file signature
1737 0         0 print $fh pack('V', 256); # offset to first curve
1738 0         0 print $fh pack('V', 100); #
1739 0         0 print $fh pack('V', 4); # number of curves
1740 0         0 print $fh pack('V4', 640, 640, 640, 640); # curve block sizes
1741              
1742             # seek start of first curve
1743 0         0 seek($fh, 256, 0);
1744              
1745             # loop thru colors (0-3) (YMCK)
1746 0         0 for my $i (0 .. 3) {
1747            
1748             # print curve name
1749 0         0 print $fh pack('a128', $names[$i]);
1750            
1751             # print display color
1752 0         0 print $fh pack('V', $colors[$i]);
1753            
1754             # print curve parameters (LUT_size, dot_gain_steps, dot_gain_table_size)
1755 0         0 print $fh pack('V3', 256, 15, 240);
1756            
1757             # print binary LUT
1758             #
1759             # for each step
1760 0         0 for my $j (0 .. 255) {
1761            
1762             # compute output value
1763 0         0 $out = $self->[1][$map[$i]]->_transform($dir, $j/255);
1764            
1765             # print LUT value (limited and rounded)
1766 0 0       0 print $fh pack('C', 255 * ($out < 0 ? 0 : ($out > 1 ? 1 : $out)) + 0.5);
    0          
1767            
1768             }
1769            
1770             # print dot gain table
1771             #
1772             # for each tone curve step
1773 0         0 for my $j (0 .. $#{$steps}) {
  0         0  
1774            
1775             # compute input value
1776 0         0 $in = $steps->[$j]/100;
1777            
1778             # compute output value
1779 0         0 $out = $self->[1][$map[$i]]->_transform($dir, $in);
1780            
1781             # compute dot gain (rounded to 0.1%)
1782 0         0 $dg = POSIX::floor(1000 * ($out - $in) + 0.5)/10;
1783            
1784             # print dot gain value (little-endian double)
1785 0         0 print $fh pack('C2 x6 d<', $steps->[$j], 1, $dg);
1786            
1787             }
1788            
1789             }
1790              
1791             # close the file
1792 0         0 close($fh);
1793              
1794             }
1795              
1796             # write tab delimited text tone curve file
1797             # assumes curve domain/range is (0 - 1)
1798             # options parameter may be a hash reference or direction flag
1799             # hash keys: 'dir', 'steps'
1800             # direction: 0 - normal, 1 - inverse
1801             # parameters: (file_path, [options])
1802             sub text {
1803              
1804             # get parameters
1805 0     0 0 0 my ($self, $path, $opts) = @_;
1806              
1807             # local variables
1808 0         0 my ($dir, $steps, $fp, $fh, $rs, @Tdot);
1809              
1810             # process options
1811 0         0 ($dir, $steps) = _options($opts);
1812              
1813             # check for non-integer values
1814 0         0 $fp = grep {$_ != int($_)} @{$steps};
  0         0  
  0         0  
1815              
1816             # filter path
1817 0         0 ICC::Shared::filterPath($path);
1818              
1819             # open the file
1820 0 0       0 open($fh, '>', $path) or croak("can't open $path: $!");
1821              
1822             # disable :crlf translation
1823 0         0 binmode($fh);
1824              
1825             # set output record separator (Windows CR-LF)
1826 0         0 $rs = "\015\012";
1827              
1828             # for each step
1829 0         0 for my $t (@{$steps}) {
  0         0  
1830            
1831             # format input value
1832 0 0       0 $Tdot[0] = $fp ? sprintf("%.2f", $t) : $t;
1833            
1834             # for each channel
1835 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
1836            
1837             # compute transformed dot value
1838 0         0 $Tdot[$i + 1] = sprintf("%.2f", 100 * ($self->[1][$i]->_transform($dir, $t/100)));
1839            
1840             }
1841            
1842             # print step values
1843 0         0 print $fh join("\t", @Tdot), $rs;
1844            
1845             }
1846              
1847             # close the file
1848 0         0 close($fh);
1849              
1850             }
1851              
1852             # graph tone curves
1853             # assumes curve domain/range is (0 - 1)
1854             # options parameter may be a hash reference or direction flag
1855             # hash keys: 'dir', 'lib', 'composite', 'titles', 'inks', 'files', 'open'
1856             # direction: 0 - normal, 1 - inverse
1857             # parameters: (folder_path, [options])
1858             # returns: (graph_path_list)
1859             sub graph {
1860              
1861             # get parameters
1862 0     0 0 0 my ($self, $path, $opts) = @_;
1863              
1864             # local variables
1865 0         0 my ($dir, $include, $tt, $vars, $min, $max, @inks, %exc, @colors, @data, @tooltips, $file, $s, @html);
1866              
1867             # process options
1868 0         0 ($dir) = _options($opts);
1869              
1870             # if ICC::Templates folder is found in @INC (may be relative)
1871 0 0       0 if (($include) = grep {-d} map {File::Spec->catdir($_, 'ICC', 'Templates')} @INC) {
  0         0  
  0         0  
1872            
1873             # purify folder path
1874 0         0 ICC::Shared::filterPath($path);
1875            
1876             # make a template processing object
1877 0         0 $tt = Template->new({'INCLUDE_PATH' => $include, 'OUTPUT_PATH' => $path});
1878            
1879             # if gray scale curve
1880 0 0       0 if ($#{$self->[1]} == 0) {
  0 0       0  
1881            
1882             # set default ink color
1883 0         0 @inks = qw(gray);
1884            
1885             # if RGB curves
1886 0         0 } elsif ($#{$self->[1]} == 2) {
1887            
1888             # set default ink colors
1889 0         0 @inks = qw(red green blue);
1890            
1891             # if CMYK+ curves
1892             } else {
1893            
1894             # set default ink colors
1895 0         0 @inks = qw(cyan magenta yellow black);
1896            
1897             }
1898            
1899             # for each curve
1900 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
1901            
1902             # set ink value, defaults to 'inkN'
1903 0   0     0 $inks[$i] = $opts->{'inks'}[$i] // $self->[0]{'inks'}[$i] // $inks[$i] // sprintf("ink%d", $i + 1);
      0        
      0        
1904            
1905             }
1906            
1907             # graph color exceptions
1908 0         0 %exc = ('yellow' => '#ee0', 'orange' => '#f80', 'violet' => '#80f', 'gray' => '#777');
1909            
1910             # get graph colors, mapping exceptions
1911 0 0 0     0 @colors = map {$exc{$_} // $_} map {m/^ink_/ ? 'gray' : $_} @inks;
  0         0  
  0         0  
1912            
1913             # set RGraph library folder
1914 0   0     0 $vars->{'libjs'} = $opts->{'lib'} // 'lib';
1915            
1916             # set yaxis scale
1917 0   0     0 $vars->{'yscalemin'} = $min = $opts->{'yscalemin'} // 0.0;
1918 0   0     0 $vars->{'yscalemax'} = $max = $opts->{'yscalemax'} // 1.0;
1919            
1920             # if 'composite' curve
1921 0 0       0 if ($opts->{'composite'}) {
1922            
1923             # for each curve
1924 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
1925            
1926             # compute curve data
1927 0         0 @data = map {sprintf("%.3f", $self->[1][$i]->_transform($dir, $_/100))} (0 .. 100);
  0         0  
1928            
1929             # clip the data
1930 0 0       0 @data = map {$_ < $min ? $min : $_ > $max ? $max : $_} @data;
  0 0       0  
1931            
1932             # make javascript string of curve data
1933 0         0 $s->[$i] = '[' . join(', ', @data) . ']';
1934            
1935             }
1936            
1937             # make composite javascript string of curve data
1938 0         0 $vars->{'data'} = '[' . join(', ', @{$s}) . ']';
  0         0  
1939            
1940             # disable tooltips
1941 0         0 $vars->{'tooltips'} = '[]';
1942            
1943             # set graph title
1944 0   0     0 $vars->{'title'} = $opts->{'titles'}[0] // "composite tone curves";
1945            
1946             # set graph colors
1947 0         0 $vars->{'colors'} = '[' . join(', ', map {"'$_'"} @colors) . ']';
  0         0  
1948            
1949             # get file name
1950 0   0     0 $file = $opts->{'files'}[0] // 'composite';
1951            
1952             # process the template
1953 0 0       0 $tt->process('cvst_graph_svg.tt2', $vars, "$file.html") || CORE::die $tt->error();
1954            
1955             } else {
1956            
1957             # for each curve
1958 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
1959            
1960             # compute curve data
1961 0         0 @data = map {sprintf("%.3f", $self->[1][$i]->_transform($dir, $_/100))} (0 .. 100);
  0         0  
1962            
1963             # clip the data
1964 0 0       0 @data = map {$_ < $min ? $min : $_ > $max ? $max : $_} @data;
  0 0       0  
1965            
1966             # make javascript string of curve data
1967 0         0 $vars->{'data'} = '[[' . join(', ', @data) . ']]';
1968            
1969             # compute tooltips array
1970 0 0       0 @tooltips = map {$_ % 5 ? 'null' : sprintf("'%d%% ➔ %.1f%%'", $_, 100 * $data[$_])} (0 .. 100);
  0         0  
1971            
1972             # make tooltips
1973 0         0 $vars->{'tooltips'} = '[' . join(', ', @tooltips) . ']';
1974            
1975             # set graph title
1976 0   0     0 $vars->{'title'} = $opts->{'titles'}[$i] // "$inks[$i] tone curve";
1977            
1978             # set graph color
1979 0         0 $vars->{'colors'} = "['$colors[$i]']";
1980            
1981             # get file name
1982 0   0     0 $file = $opts->{'files'}[$i] // $inks[$i];
1983            
1984             # process the template
1985 0 0       0 $tt->process('cvst_graph_svg.tt2', $vars, "$file.html") || CORE::die $tt->error();
1986            
1987             }
1988            
1989             }
1990            
1991             # if 'composite' curve
1992 0 0       0 if ($opts->{'composite'}) {
1993            
1994             # if Windows OS
1995 0 0       0 if ($^O eq 'MSWin32') {
1996            
1997             # set file list
1998 0         0 @html = ("$path\\$file.html");
1999            
2000             } else {
2001            
2002             # set file list
2003 0         0 @html = ("$path/$file.html");
2004            
2005             }
2006            
2007             } else {
2008            
2009             # for each curve
2010 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
2011            
2012             # get file name
2013 0   0     0 $file = $opts->{'files'}[$i] // $inks[$i];
2014            
2015             # if Windows OS
2016 0 0       0 if ($^O eq 'MSWin32') {
2017            
2018             # add path to file list
2019 0         0 push(@html, "$path\\$file.html");
2020            
2021             } else {
2022            
2023             # add path to file list
2024 0         0 push(@html, "$path/$file.html");
2025            
2026             }
2027            
2028             }
2029            
2030             }
2031            
2032             }
2033              
2034             # open files, if enabled
2035 0 0 0     0 open_files(\@html) if ($opts->{'open'} // 1);
2036              
2037             # return
2038 0         0 return(@html);
2039              
2040             }
2041              
2042             # display graphs in web browser
2043             # parameters: (ref_to_file_list)
2044             sub open_files {
2045              
2046             # get file list
2047 0     0 0 0 my $files = shift();
2048              
2049             # local parameters
2050 0         0 my ($RGraph, $vol, $dir, $file, $lib, $app, @fox, @pid, @esc, $esc0, $flag, $timeout);
2051              
2052             # find RGraph folder path in @INC (may be relative)
2053 0         0 ($RGraph) = grep {-d} map {File::Spec->catdir($_, 'ICC', 'JavaScripts', 'RGraph')} @INC;
  0         0  
  0         0  
2054              
2055             # if valid file list and RGraph folder found
2056 0 0 0     0 if (ref($files) eq 'ARRAY' && defined($files->[0]) && -f $files->[0] && defined($RGraph)) {
      0        
      0        
2057            
2058             # split first file path
2059 0         0 ($vol, $dir, $file) = File::Spec->splitpath($files->[0]);
2060            
2061             # make 'lib' folder path
2062 0         0 $lib = File::Spec->catdir($vol, $dir, 'lib');
2063            
2064             # if macOS
2065 0 0       0 if ($^O eq 'darwin') {
    0          
2066            
2067             # copy RGraph JavaScripts to 'lib' folder
2068 0         0 qx(cp -Rp '$RGraph/' '$lib');
2069            
2070             # escape the file paths
2071 0         0 @esc = map {quotemeta()} @{$files};
  0         0  
  0         0  
2072            
2073             # get default app (using JXA)
2074 0         0 $app = qx(osascript -l JavaScript -e "Application('System Events').files.byName('$files->[0]').defaultApplication.name()");
2075            
2076             # remove endline
2077 0         0 chomp($app);
2078            
2079             # if default app is Firefox
2080 0 0       0 if ($app eq 'Firefox.app') {
2081            
2082             # get first file path
2083 0         0 $esc0 = shift(@esc);
2084            
2085             # open first graph
2086 0         0 qx(open $esc0);
2087            
2088             # if more graphs
2089 0 0       0 if (@esc) {
2090            
2091             # set timeout (5 secs)
2092 0         0 $timeout = time() + 5;
2093            
2094             # loop until we get Firefox pid -or- timeout
2095 0   0     0 while (! @fox && time() < $timeout) {
2096            
2097             # get Firefox pid
2098 0         0 @fox = split(/\s+/, qx(pgrep firefox));
2099            
2100             }
2101            
2102             # set flag
2103 0         0 $flag = 1;
2104            
2105             # loop until flag is cleared -or- timeout
2106 0   0     0 while ($flag && time() < $timeout) {
2107            
2108             # if 4 or more child processes
2109 0 0       0 if ((@pid = split(/\s+/, qx(pgrep -P $fox[0]))) > 3) {
2110            
2111             # for each child process
2112 0         0 for (@pid) {
2113            
2114             # clear flag if ps command contains '-sbAllowFileAccess'
2115 0 0       0 $flag = 0 if (qx(ps -p $_ -o command) =~ m/-sbAllowFileAccess/m);
2116            
2117             }
2118            
2119             }
2120            
2121             }
2122            
2123             # open remaining graphs
2124 0         0 qx(open @esc);
2125            
2126             }
2127            
2128             } else {
2129            
2130             # open all graphs
2131 0         0 qx(open @esc);
2132            
2133             }
2134            
2135             # if Windows OS
2136             } elsif ($^O eq 'MSWin32') {
2137            
2138             # copy RGraph JavaScripts to 'lib' folder
2139 0         0 qx(xcopy /I "$RGraph\\" "$lib\\");
2140            
2141 0         0 print "to be implemented\n\n"; ###########
2142            
2143             } else {
2144            
2145 0         0 print "unsupported OS\n\n";
2146            
2147             }
2148            
2149             }
2150              
2151             # return
2152 0         0 return();
2153              
2154             }
2155              
2156             # normalize all curve objects
2157             # sets the domain and range of curves
2158             # parameters: (as_appropriate_for_curve_objects)
2159             sub normalize {
2160              
2161             # get object reference
2162 0     0 0 0 my $self = shift();
2163              
2164             # for each channel
2165 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
2166            
2167             # if curve object has 'normalize' method
2168 0 0       0 if ($self->[1][$i]->can('normalize')) {
2169            
2170             # call 'normalize' method
2171 0         0 $self->[1][$i]->normalize(@_);
2172            
2173             } else {
2174            
2175             # warning
2176 0         0 carp('\'normalize\' method not supported by ' . ref($self->[1][$i]) . ' object');
2177            
2178             }
2179            
2180             }
2181            
2182             }
2183              
2184             # update all curve objects
2185             # update internal object elements
2186             # this method used primarily when optimizing
2187             # parameters: (as_appropriate_for_curve_objects)
2188             sub update {
2189              
2190             # get object reference
2191 0     0 0 0 my $self = shift();
2192              
2193             # for each channel
2194 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
2195            
2196             # if curve object has 'update' method
2197 0 0       0 if ($self->[1][$i]->can('update')) {
2198            
2199             # call 'update' method
2200 0         0 $self->[1][$i]->update(@_);
2201            
2202             } else {
2203            
2204             # warning
2205 0         0 carp('\'update\' method not supported by ' . ref($self->[1][$i]) . ' object');
2206            
2207             }
2208            
2209             }
2210            
2211             }
2212              
2213             # print object contents to string
2214             # format is an array structure
2215             # parameter: ([format])
2216             # returns: (string)
2217             sub sdump {
2218              
2219             # get parameters
2220 0     0 1 0 my ($self, $p) = @_;
2221              
2222             # local variables
2223 0         0 my ($element, $fmt, $s, $pt, $st);
2224              
2225             # resolve parameter to an array reference
2226 0 0       0 $p = defined($p) ? ref($p) eq 'ARRAY' ? $p : [$p] : [];
    0          
2227              
2228             # get format string
2229 0 0 0     0 $fmt = defined($p->[0]) && ! ref($p->[0]) ? $p->[0] : 's';
2230              
2231             # set string to object ID
2232 0         0 $s = sprintf("'%s' object, (0x%x)\n", ref($self), $self);
2233              
2234             # if format contains 'o'
2235 0 0       0 if ($fmt =~ m/s/) {
2236            
2237             # get default parameter
2238 0         0 $pt = $p->[-1];
2239            
2240             # for each processing element
2241 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
2242            
2243             # get element reference
2244 0         0 $element = $self->[1][$i];
2245            
2246             # if processing element is undefined
2247 0 0       0 if (! defined($element)) {
    0          
    0          
2248            
2249             # append message
2250 0         0 $s .= "\tprocessing element is undefined\n";
2251            
2252             # if processing element is not a blessed object
2253             } elsif (! Scalar::Util::blessed($element)) {
2254            
2255             # append message
2256 0         0 $s .= "\tprocessing element is not a blessed object\n";
2257            
2258             # if processing element has an 'sdump' method
2259             } elsif ($element->can('sdump')) {
2260            
2261             # get 'sdump' string
2262 0 0       0 $st = $element->sdump(defined($p->[$i + 1]) ? $p->[$i + 1] : $pt);
2263            
2264             # prepend tabs to each line
2265 0         0 $st =~ s/^/\t/mg;
2266            
2267             # append 'sdump' string
2268 0         0 $s .= $st;
2269            
2270             # processing element is object without an 'sdump' method
2271             } else {
2272            
2273             # append object info
2274 0         0 $s .= sprintf("\t'%s' object, (0x%x)\n", ref($element), $element);
2275            
2276             }
2277            
2278             }
2279            
2280             }
2281              
2282             # return
2283 0         0 return($s);
2284              
2285             }
2286              
2287             # transform list
2288             # parameters: (ref_to_object, list, [hash])
2289             # returns: (list)
2290             sub _trans0 {
2291              
2292             # local variables
2293 0     0   0 my ($self, @out, $hash);
2294              
2295             # get object reference
2296 0         0 $self = shift();
2297              
2298             # get optional hash
2299 0 0       0 $hash = pop() if (ref($_[-1]) eq 'HASH');
2300              
2301             # for each channel
2302 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
2303            
2304             # compute transform
2305 0         0 $out[$i] = $self->[1][$i]->transform($_[$i]);
2306            
2307             }
2308              
2309             # clip, if enabled
2310 0 0 0     0 ICC::Shared::clip_struct(\@out) if ($self->[0]{'clip'} || $hash->{'clip'});
2311              
2312             # return output array
2313 0         0 return(@out);
2314              
2315             }
2316              
2317             # transform vector
2318             # parameters: (ref_to_object, vector, [hash])
2319             # returns: (vector)
2320             sub _trans1 {
2321              
2322             # get parameters
2323 0     0   0 my ($self, $in, $hash) = @_;
2324              
2325             # local variable
2326 0         0 my ($out);
2327              
2328             # for each channel
2329 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
2330            
2331             # compute transform
2332 0         0 $out->[$i] = $self->[1][$i]->transform($in->[$i]);
2333            
2334             }
2335              
2336             # clip, if enabled
2337 0 0 0     0 ICC::Shared::clip_struct($out) if ($self->[0]{'clip'} || $hash->{'clip'});
2338              
2339             # return
2340 0         0 return($out);
2341              
2342             }
2343              
2344             # transform matrix (2-D array -or- Math::Matrix object)
2345             # parameters: (ref_to_object, matrix, [hash])
2346             # returns: (matrix)
2347             sub _trans2 {
2348              
2349             # get parameters
2350 0     0   0 my ($self, $in, $hash) = @_;
2351              
2352             # local variable
2353 0         0 my ($out);
2354              
2355             # for each input vector
2356 0         0 for my $i (0 .. $#{$in}) {
  0         0  
2357            
2358             # for each channel
2359 0         0 for my $j (0 .. $#{$self->[1]}) {
  0         0  
2360            
2361             # compute transform
2362 0         0 $out->[$i][$j] = $self->[1][$j]->transform($in->[$i][$j]);
2363            
2364             }
2365            
2366             }
2367              
2368             # clip, if enabled
2369 0 0 0     0 ICC::Shared::clip_struct($out) if ($self->[0]{'clip'} || $hash->{'clip'});
2370              
2371             # return
2372 0 0       0 return(UNIVERSAL::isa($in, 'Math::Matrix') ? bless($out, 'Math::Matrix') : $out);
2373              
2374             }
2375              
2376             # transform structure
2377             # parameters: (ref_to_object, structure, [hash])
2378             # returns: (structure)
2379             sub _trans3 {
2380              
2381             # get parameters
2382 0     0   0 my ($self, $in, $hash) = @_;
2383              
2384             # transform the array structure
2385 0         0 _crawl($self, $in, my $out = [], $hash);
2386              
2387             # clip, if enabled
2388 0 0 0     0 ICC::Shared::clip_struct($out) if ($self->[0]{'clip'} || $hash->{'clip'});
2389              
2390             # return
2391 0         0 return($out);
2392              
2393             }
2394              
2395             # recursive transform
2396             # array structure is traversed until scalar arrays are found and transformed
2397             # parameters: (ref_to_object, input_array_reference, output_array_reference, hash)
2398             sub _crawl {
2399              
2400             # get parameters
2401 0     0   0 my ($self, $in, $out, $hash) = @_;
2402              
2403             # if input is a vector (reference to a scalar array)
2404 0 0       0 if (@{$in} == grep {! ref()} @{$in}) {
  0         0  
  0         0  
  0         0  
2405            
2406             # transform input vector and copy to output
2407 0         0 @{$out} = @{_trans1($self, $in, $hash)};
  0         0  
  0         0  
2408            
2409             } else {
2410            
2411             # for each input element
2412 0         0 for my $i (0 .. $#{$in}) {
  0         0  
2413            
2414             # if an array reference
2415 0 0       0 if (ref($in->[$i]) eq 'ARRAY') {
2416            
2417             # transform next level
2418 0         0 _crawl($self, $in->[$i], $out->[$i] = [], $hash);
2419            
2420             } else {
2421            
2422             # error
2423 0         0 croak('invalid transform input');
2424            
2425             }
2426            
2427             }
2428            
2429             }
2430            
2431             }
2432              
2433             # invert list
2434             # parameters: (ref_to_object, list, [hash])
2435             # returns: (list)
2436             sub _inv0 {
2437              
2438             # local variables
2439 0     0   0 my ($self, $hash, @out);
2440              
2441             # get object reference
2442 0         0 $self = shift();
2443              
2444             # get optional hash
2445 0 0       0 $hash = pop() if (ref($_[-1]) eq 'HASH');
2446              
2447             # for each channel
2448 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
2449            
2450             # compute invert
2451 0         0 $out[$i] = $self->[1][$i]->inverse($_[$i]);
2452            
2453             }
2454              
2455             # clip, if enabled
2456 0 0 0     0 ICC::Shared::clip_struct(\@out) if ($self->[0]{'clip'} || $hash->{'clip'});
2457              
2458             # return output array
2459 0         0 return(@out);
2460              
2461             }
2462              
2463             # invert vector
2464             # parameters: (ref_to_object, vector, [hash])
2465             # returns: (vector)
2466             sub _inv1 {
2467              
2468             # get parameters
2469 0     0   0 my ($self, $in, $hash) = @_;
2470              
2471             # local variable
2472 0         0 my ($out);
2473              
2474             # for each channel
2475 0         0 for my $i (0 .. $#{$self->[1]}) {
  0         0  
2476            
2477             # compute invert
2478 0         0 $out->[$i] = $self->[1][$i]->inverse($in->[$i]);
2479            
2480             }
2481              
2482             # clip, if enabled
2483 0 0 0     0 ICC::Shared::clip_struct($out) if ($self->[0]{'clip'} || $hash->{'clip'});
2484              
2485             # return
2486 0         0 return($out);
2487              
2488             }
2489              
2490             # invert matrix (2-D array -or- Math::Matrix object)
2491             # parameters: (ref_to_object, matrix, [hash])
2492             # returns: (matrix)
2493             sub _inv2 {
2494              
2495             # get parameters
2496 0     0   0 my ($self, $in, $hash) = @_;
2497              
2498             # local variable
2499 0         0 my ($out);
2500              
2501             # for each input vector
2502 0         0 for my $i (0 .. $#{$in}) {
  0         0  
2503            
2504             # for each channel
2505 0         0 for my $j (0 .. $#{$self->[1]}) {
  0         0  
2506            
2507             # compute invert
2508 0         0 $out->[$i][$j] = $self->[1][$j]->inverse($in->[$i][$j]);
2509            
2510             }
2511            
2512             }
2513              
2514             # clip, if enabled
2515 0 0 0     0 ICC::Shared::clip_struct($out) if ($self->[0]{'clip'} || $hash->{'clip'});
2516              
2517             # return
2518 0 0       0 return(UNIVERSAL::isa($in, 'Math::Matrix') ? bless($out, 'Math::Matrix') : $out);
2519              
2520             }
2521              
2522             # invert structure
2523             # parameters: (ref_to_object, structure, [hash])
2524             # returns: (structure)
2525             sub _inv3 {
2526              
2527             # get parameters
2528 0     0   0 my ($self, $in, $hash) = @_;
2529              
2530             # recursive inverse
2531 0         0 _crawl2($self, $in, my $out = []);
2532              
2533             # clip, if enabled
2534 0 0 0     0 ICC::Shared::clip_struct($out) if ($self->[0]{'clip'} || $hash->{'clip'});
2535              
2536             # return
2537 0         0 return($out);
2538              
2539             }
2540              
2541             # recursive inverse
2542             # array structure is traversed until scalar arrays are found and inverted
2543             # parameters: (ref_to_object, input_array_reference, output_array_reference, hash)
2544             sub _crawl2 {
2545            
2546             # get parameters
2547 0     0   0 my ($self, $in, $out, $hash) = @_;
2548            
2549             # if input is a vector (reference to a scalar array)
2550 0 0       0 if (@{$in} == grep {! ref()} @{$in}) {
  0         0  
  0         0  
  0         0  
2551            
2552             # invert input vector and copy to output
2553 0         0 @{$out} = @{_inv1($self, $in, $hash)};
  0         0  
  0         0  
2554            
2555             } else {
2556            
2557             # for each input element
2558 0         0 for my $i (0 .. $#{$in}) {
  0         0  
2559            
2560             # if an array reference
2561 0 0       0 if (ref($in->[$i]) eq 'ARRAY') {
2562            
2563             # invert next level
2564 0         0 _crawl2($self, $in->[$i], $out->[$i] = []);
2565            
2566             } else {
2567            
2568             # error
2569 0         0 croak('invalid inverse input');
2570            
2571             }
2572            
2573             }
2574            
2575             }
2576            
2577             }
2578              
2579             # process the curve output options parameter
2580             # the parameter may be a scalar or hash reference
2581             # output is based on the name of the calling method
2582             # parameter: ([options])
2583             # returns: (direction_flag, steps)
2584             sub _options {
2585              
2586             # get options
2587 0     0   0 my $opts = $_[0];
2588              
2589             # local variable
2590 0         0 my ($dir, $steps, @ctx, $caller, $n);
2591              
2592             # make hash of standard step ramps (method_name => [ref_to_steps_array, custom_flag])
2593             # steps array contains device values (%), flag indicate values may be custom
2594             state $std = {
2595 0         0 'apogee' => [[0 .. 6, (map {5 * $_} 2 .. 18), 94 .. 100], 1],
2596             'device_link' => [[], 0],
2597 0         0 'cgats' => [[0, 2, 4, 6, 8, (map {5 * $_} 2 .. 19), 98, 100], 1], # P2P51 ramp
2598 0         0 'efi' => [[0 .. 3, map {5 * $_} 1 .. 20], 0],
2599             'fuji_xmf' => [[0 .. 5, 10, 20, 25, 30, 40, 50, 60, 70, 75, 80, 90, 95 .. 100], 0],
2600             'harlequin' => [[100, 95, 90, 85, 80, 70, 60, 50, 40, 30, 20, 15, 10, 8, 6, 4, 2, 0], 0],
2601 0         0 'indigo' => [[map {5 * $_} 0 .. 20], 0],
2602 0         0 'iso_18620' => [[0, 1, 2, 5, (map {10 * $_} (1 .. 9)), 95, 100], 1],
2603             'navigator' => [[100, 95, 90, 85, 80, 70, 60, 50, 40, 30, 20, 15, 10, 8, 6, 4, 2, 0], 0],
2604             'photoshop' => [[], 1],
2605             'prinergy' => [[0 .. 100], 0],
2606 0         0 'rampage' => [[0, 1, 3, (map {5 * $_} 1 .. 19), 97, 99, 100], 0],
2607             'sierra' => [[0 .. 5, 10, 20, 25, 30, 40, 50, 60, 70, 75, 80, 90, 95 .. 100], 0],
2608 0         0 'trueflow' => [[0, 2, 5, (map {10 * $_} 1 .. 9), 95, 98, 100], 0],
2609 0         0 'text' => [[map {$_ * 5} 0 .. 20], 1],
  0         0  
2610             'graph' => [[], 0],
2611             };
2612              
2613             # match caller method name
2614 0 0       0 $ctx[3] =~ m/::(\w+)$/ if (@ctx = caller(1));
2615              
2616             # set caller, default is 'text'
2617 0 0 0     0 $caller = defined($1) && exists($std->{$1}) ? $1 : 'text';
2618              
2619             # set default direction (forward)
2620 0         0 $dir = 0;
2621              
2622             # set default steps value for caller
2623 0         0 $steps = $std->{$caller}[0];
2624              
2625             # return if options undefined
2626 0 0       0 return($dir, $steps) if (! defined($opts));
2627              
2628             # if options is a scalar
2629 0 0       0 if (! ref($opts)) {
    0          
2630            
2631             # set direction
2632 0 0       0 $dir = $opts ? 1 : 0;
2633            
2634             # undefine options (for caller, $_[0] is an alias)
2635 0         0 undef($_[0]);
2636            
2637             # if options is a hash ref
2638             } elsif (ref($opts) eq 'HASH') {
2639            
2640             # use 'dir' hash value, if any
2641 0   0     0 $dir = $opts->{'dir'} // 0;
2642            
2643             # if 'steps' defined in hash
2644 0 0       0 if (defined($opts->{'steps'})) {
2645            
2646             # if custom step values allowed
2647 0 0       0 if ($std->{$caller}[1]) {
2648            
2649             # set steps to hash value
2650 0         0 $steps = $opts->{'steps'};
2651            
2652             # if 'steps' value is a numeric vector
2653 0 0       0 if (ICC::Shared::is_num_vector($steps)) {
    0          
    0          
2654            
2655             # warn if values out of range (0 - 100)
2656 0 0       0 (0 == grep {$_ < 0 || $_ > 100} @{$steps}) or carp("'steps' value(s) out of range\n");
  0 0       0  
  0         0  
2657            
2658             # if 'steps' value is a number
2659             } elsif (Scalar::Util::looks_like_number($steps)) {
2660            
2661             # set upper range
2662 0         0 $n = int($steps) - 1;
2663            
2664             # limit number of steps (1 - 255)
2665 0 0       0 $n = $n < 1 ? 1 : $n > 255 ? 255 : $n;
    0          
2666            
2667             # set steps
2668 0         0 $steps = [map {100 * $_/$n} (0 .. $n)];
  0         0  
2669            
2670             # if 'steps' value is a string
2671             } elsif (! ref($steps)) {
2672            
2673             # if string a valid key
2674 0 0       0 if (exists($std->{$steps})) {
2675            
2676             # set steps
2677 0         0 $steps = $std->{$steps}[0];
2678            
2679             } else {
2680            
2681             # print warning
2682 0         0 carp("'steps' value '$steps' is invalid, using default steps\n");
2683            
2684             # set steps
2685 0         0 $steps = $std->{$caller}[0];
2686            
2687             }
2688            
2689             } else {
2690            
2691             # print warning
2692 0         0 carp("'steps' value must be a scalar or an array reference\n");
2693            
2694             }
2695            
2696             } else {
2697            
2698             # print warning
2699 0         0 carp("custom step values not allowed in $caller curves\n");
2700            
2701             }
2702            
2703             }
2704            
2705             } else {
2706            
2707             # print warning
2708 0         0 carp("options parameter must be a scalar or hash reference\n");
2709            
2710             }
2711              
2712             # return
2713 0         0 return($dir, $steps);
2714              
2715             }
2716              
2717             # read curves from text file
2718             # returns true if successful
2719             # parameters: (ref_to_object, file_handle)
2720             # returns: (flag)
2721             sub _read_text {
2722              
2723             # get parameters
2724 0     0   0 my ($self, $fh) = @_;
2725              
2726             # local variables
2727 0         0 my (@data, @cnt, $n, $last, $f, $mat);
2728              
2729             # localize input record separator
2730 0         0 local $/ = $self->[0]{'read_rs'};
2731              
2732             # localize loop variable
2733 0         0 local $_;
2734              
2735             # read the file, line by line
2736 0         0 while (<$fh>) {
2737            
2738             # split the line, and filter numeric values
2739 0         0 push(@data, [grep {Scalar::Util::looks_like_number($_)} split('[\s"]')]);
  0         0  
2740            
2741             }
2742              
2743             # for each line
2744 0         0 for my $line (@data) {
2745            
2746             # increment count
2747 0         0 $cnt[@{$line}]++
  0         0  
2748            
2749             }
2750              
2751             # get index with max count
2752 0 0 0 0   0 $n = List::Util::reduce {($cnt[$a] // 0) > ($cnt[$b] // 0) ? $a : $b} (1 .. $#cnt);
  0   0     0  
2753              
2754             # filter out extraneous lines
2755 0         0 @data = grep {$n == @{$_}} @data;
  0         0  
  0         0  
2756              
2757             # verify data table size
2758 0 0 0     0 (@data > 1 && @{$data[0]} > 1) or return(0);
  0         0  
2759              
2760             # sort by first value in each line
2761 0         0 @data = sort {$a->[0] <=> $b->[0]} @data;
  0         0  
2762              
2763             # filter any duplicates
2764 0 0       0 @data = grep {$f = (defined($last) ? $last->[0] != $_->[0] : 1); $last = $_; $f} @data;
  0         0  
  0         0  
  0         0  
2765              
2766             # convert to device values
2767 0         0 @data = map {[map {$_/100} @{$_}]} @data;
  0         0  
  0         0  
  0         0  
2768              
2769             # make a transposed matrix of the data
2770 0         0 $mat = Math::Matrix->new(@data)->transpose();
2771              
2772             # for each channel
2773 0         0 for my $i (1 .. $#{$mat}) {
  0         0  
2774            
2775             # it is assumed the first column of numbers are the input values
2776             # and the remaining columns are output values for each channel
2777            
2778             # add a 'spline' curve
2779 0         0 $self->[1][$i - 1] = ICC::Support::spline->new({'input' => $mat->[0], 'output' => $mat->[$i], 'type' => 'akima'});
2780            
2781             }
2782              
2783             # return
2784 0         0 return(1);
2785              
2786             }
2787              
2788             # read curves from ISO 18620 file
2789             # returns true if successful
2790             # parameters: (ref_to_object, file_handle)
2791             # returns: (flag)
2792             sub _read_iso_18620 {
2793              
2794             # get parameters
2795 0     0   0 my ($self, $fh) = @_;
2796              
2797             # local variables
2798 0         0 my ($dom, $root, @obj, $k, @sep, $curve, @xy, @x, @y);
2799              
2800             # parse ISO 18620 document
2801 0 0       0 eval{$dom = XML::LibXML->load_xml('IO' => $fh)} or return(0);
  0         0  
2802              
2803             # get root element
2804 0         0 $root = $dom->documentElement();
2805              
2806             # get all nodes (we select later)
2807 0         0 @obj = $root->findnodes('*');
2808              
2809             # init curve counter
2810 0         0 $k = 0;
2811              
2812             # for each element
2813 0         0 for my $s (@obj) {
2814            
2815             # if a 'TransferCurve' node
2816 0 0       0 if ($s->nodeName() eq 'TransferCurve') {
2817            
2818             # get the Separation attribute
2819 0         0 $sep[$k] = $s->getAttribute('Separation');
2820            
2821             # get the Curve attribute
2822 0         0 $curve = $s->getAttribute('Curve');
2823            
2824             # split the Curve data
2825 0         0 @xy = split('\s', $curve);
2826            
2827             # init value arrays
2828 0         0 @x = @y = ();
2829            
2830             # for each value
2831 0         0 for my $i (0 .. $#xy) {
2832            
2833             # if index is odd
2834 0 0       0 if ($i % 2) {
2835            
2836             # save as y-value
2837 0         0 $y[int($i/2)] = $xy[$i];
2838            
2839             } else {
2840            
2841             # save as x-value
2842 0         0 $x[int($i/2)] = $xy[$i];
2843            
2844             }
2845            
2846             }
2847            
2848             # add a 'spline' curve to object
2849 0         0 $self->[1][$k++] = ICC::Support::spline->new({'input' => \@x, 'output' => \@y, 'type' => 'akima'});
2850            
2851             }
2852            
2853             }
2854              
2855             # add ink sequence
2856 0         0 $self->[0]{'inks'} = \@sep;
2857              
2858             # return
2859 0         0 return($k);
2860              
2861             }
2862              
2863             # read curves from Esko .icpro/.dgc file set
2864             # returns true if successful
2865             # parameters: (ref_to_object, file_handle, path)
2866             # returns: (flag)
2867             sub _read_icpro {
2868              
2869             # get parameters
2870 0     0   0 my ($self, $fh, $path) = @_;
2871              
2872             # local variables
2873 0         0 my ($dom, $root, @obj, $k, @sep, $dgc, $curve);
2874 0         0 my ($vol, $dir, $file, $fh2, $buf, $ptr, $n, $max, @data);
2875              
2876             # split .icpro path
2877 0         0 ($vol, $dir, $file) = File::Spec->splitpath($path);
2878              
2879             # parse .icpro document
2880 0 0       0 eval{$dom = XML::LibXML->load_xml('IO' => $fh)} or return(0);
  0         0  
2881              
2882             # get root element
2883 0         0 $root = $dom->documentElement();
2884              
2885             # get all 'ink' nodes
2886 0         0 @obj = $root->findnodes('*/ink');
2887              
2888             # init curve counter
2889 0         0 $k = 0;
2890              
2891             # for each 'ink' node
2892 0         0 for my $s (@obj) {
2893            
2894             # if there is a 'dgc' node
2895 0 0       0 if (($dgc) = $s->findnodes('dgc')) {
2896            
2897             # get the 'fileName' attribute
2898 0         0 $file = $dgc->getAttribute('fileName');
2899            
2900             # concatenate file path
2901 0         0 $path = File::Spec->catfile($vol, $dir, $file);
2902            
2903             # open the file (read-only)
2904 0 0       0 open($fh2, '<', $path) or croak("$! when opening file $path");
2905            
2906             # seek table 4 index
2907 0         0 seek($fh2, 0x0000020C, 0);
2908            
2909             # read index to table 4
2910 0         0 read($fh2, $buf, 12);
2911            
2912             # unpack table pointer, number of points
2913 0         0 ($ptr, $n, $max) = unpack('N*', $buf);
2914            
2915             # seek table 4
2916 0         0 seek($fh2, $ptr, 0);
2917            
2918             # read table data
2919 0         0 read($fh2, $buf, $n * 4);
2920            
2921             # unpack table data
2922 0         0 @data = map {$_/$max} unpack('N*', $buf);
  0         0  
2923            
2924             # close file
2925 0         0 close($fh2);
2926            
2927             # make 'curv' object
2928 0         0 $self->[1][$k] = ICC::Profile::curv->new(\@data);
2929            
2930             # get the 'inkName' attribute
2931 0         0 $sep[$k++] = $s->getAttribute('inkName');
2932            
2933             }
2934            
2935             }
2936              
2937             # add ink sequence
2938 0         0 $self->[0]{'inks'} = \@sep;
2939              
2940             # return
2941 0         0 return($k);
2942              
2943             }
2944              
2945             # read curves from file
2946             # file path to 'iso_18620', 'icpro', 'text' or 'store' format curves
2947             # parameters: (ref_to_object, file_path)
2948             sub _new_from_file {
2949              
2950             # get parameters
2951 0     0   0 my ($self, $path) = @_;
2952              
2953             # local variables
2954 0         0 my ($fh, $buf, $result, $obj);
2955              
2956             # filter path name
2957 0         0 ICC::Shared::filterPath($path);
2958              
2959             # open the file (read-only)
2960 0 0       0 open($fh, '<', $path) or croak("$! when opening file $path");
2961              
2962             # set binary mode
2963 0         0 binmode($fh);
2964              
2965             # read start of file
2966 0 0       0 read($fh, $buf, 1024) or croak("file $path is zero length");
2967              
2968             # reset file pointer
2969 0         0 seek($fh, 0, 0);
2970              
2971             # if an ISO 18620 (.ted) file
2972 0 0 0     0 if ($buf =~ m/<\?xml.*\?>/ && $buf =~ m/ISO18620/) {
    0 0        
    0          
2973            
2974             # read ISO 18620 file
2975 0 0       0 _read_iso_18620($self, $fh) or croak("failed parsing ISO 18620 (XML) file $path");
2976            
2977             # save file type
2978 0         0 $self->[0]{'file_type'} = 'ISO_18620';
2979            
2980             # if an Esko .icpro file
2981             } elsif ($buf =~ m/<\?xml.*\?>/ && $buf =~ m/colDgc_xml/) {
2982            
2983             # read .icpro/.dgc file set
2984 0 0       0 _read_icpro($self, $fh, $path) or croak("failed parsing .icpro/.dgc file set $path");
2985            
2986             # save file type
2987 0         0 $self->[0]{'file_type'} = 'ESKO_ICPRO';
2988            
2989             # if a Storable file
2990             } elsif ($buf =~ m/ICC::Profile::cvst/) {
2991            
2992             # retrieve 'cvst' object from Storable file
2993 0 0       0 ($obj = Storable::fd_retrieve($fh)) or croak("failed retrieving Storable object $path");
2994            
2995             # verify a cvst object
2996 0 0       0 (UNIVERSAL::isa($obj, 'ICC::Profile::cvst')) or croak("not a 'cvst' object, retrieved from $path");
2997            
2998             # copy object elements
2999 0         0 @{$self} = @{$obj};
  0         0  
  0         0  
3000            
3001             # save file type
3002 0         0 $self->[0]{'file_type'} = 'STORABLE';
3003            
3004             } else {
3005            
3006             # check for CR-LF (DOS/Windows)
3007 0 0       0 if ($buf =~ m/\015\012/) {
    0          
    0          
3008            
3009             # set record separator
3010 0         0 $self->[0]{'read_rs'} = "\015\012";
3011            
3012             # check for LF (Unix/OSX)
3013             } elsif ($buf =~ m/\012/) {
3014            
3015             # set record separator
3016 0         0 $self->[0]{'read_rs'} = "\012";
3017            
3018             # check for CR (Mac)
3019             } elsif ($buf =~ m/\015/) {
3020            
3021             # set record separator
3022 0         0 $self->[0]{'read_rs'} = "\015";
3023            
3024             # not a text file
3025             } else {
3026            
3027             # close the file
3028 0         0 close($fh);
3029            
3030             # error
3031 0         0 croak('unknown file type');
3032            
3033             }
3034            
3035             # read text file
3036 0 0       0 _read_text($self, $fh) or croak("failed parsing text file $path");
3037            
3038             # save file type
3039 0         0 $self->[0]{'file_type'} = 'TEXT';
3040            
3041             }
3042              
3043             # close the file
3044 0         0 close($fh);
3045              
3046             }
3047              
3048             # make new cvst object from array
3049             # parameters: (ref_to_object, ref_to_array)
3050             sub _new_from_array {
3051              
3052             # get parameters
3053 4     4   12 my ($self, $array) = @_;
3054              
3055             # for each curve element
3056 4         8 for my $i (0 .. $#{$array}) {
  4         14  
3057            
3058             # verify object has processing methods
3059 11 50 33     75 ($array->[$i]->can('transform') && $array->[$i]->can('derivative')) or croak('curve element lacks \'transform\' or \'derivative\' method');
3060            
3061             # add curve element
3062 11         25 $self->[1][$i] = $array->[$i];
3063            
3064             }
3065              
3066             }
3067              
3068             # read cvst tag from ICC profile
3069             # parameters: (ref_to_object, ref_to_parent_object, file_handle, ref_to_tag_table_entry)
3070             sub _readICCcvst {
3071              
3072             # get parameters
3073 0     0     my ($self, $parent, $fh, $tag) = @_;
3074              
3075             # local variables
3076 0           my ($buf, @mft, $table, $tag2, $type, $class, %hash);
3077              
3078             # set tag signature
3079 0           $self->[0]{'signature'} = $tag->[0];
3080              
3081             # seek start of tag
3082 0           seek($fh, $tag->[1], 0);
3083              
3084             # read tag header
3085 0           read($fh, $buf, 12);
3086              
3087             # unpack header
3088 0           @mft = unpack('a4 x4 n2', $buf);
3089              
3090             # verify tag signature
3091 0 0         ($mft[0] eq 'cvst') or croak('wrong tag type');
3092              
3093             # for each curve set element
3094 0           for my $i (0 .. $mft[1] - 1) {
3095            
3096             # read positionNumber
3097 0           read($fh, $buf, 8);
3098            
3099             # unpack to processing element tag table
3100 0           $table->[$i] = ['cvst', unpack('N2', $buf)];
3101            
3102             }
3103              
3104             # for each curve set element
3105 0           for my $i (0 .. $mft[1] - 1) {
3106            
3107             # get tag table entry
3108 0           $tag2 = $table->[$i];
3109            
3110             # make offset absolute
3111 0           $tag2->[1] += $tag->[1];
3112            
3113             # if a duplicate tag
3114 0 0         if (exists($hash{$tag2->[1]})) {
3115            
3116             # use original tag object
3117 0           $self->[1][$i] = $hash{$tag2->[1]};
3118            
3119             } else {
3120            
3121             # seek to start of tag
3122 0           seek($fh, $tag2->[1], 0);
3123            
3124             # read tag type signature
3125 0           read($fh, $type, 4);
3126            
3127             # convert non-word characters to underscores
3128 0           $type =~ s|\W|_|g;
3129            
3130             # form class specifier
3131 0           $class = "ICC::Profile::$type";
3132            
3133             # if 'class->new_fh' method exists
3134 0 0         if ($class->can('new_fh')) {
3135            
3136             # create specific tag object
3137 0           $self->[1][$i] = $class->new_fh($self, $fh, $tag2);
3138            
3139             } else {
3140            
3141             # create generic tag object
3142 0           $self->[1][$i] = ICC::Profile::Generic->new_fh($self, $fh, $tag2);
3143            
3144             # print warning
3145 0           print "curve set element $type opened as generic\n";
3146            
3147             }
3148            
3149             # save tag object in hash
3150 0           $hash{$tag2->[1]} = $self->[1][$i];
3151            
3152             }
3153            
3154             }
3155            
3156             }
3157              
3158             # write cvst tag to ICC profile
3159             # parameters: (ref_to_object, ref_to_parent_object, file_handle, ref_to_tag_table_entry)
3160             sub _writeICCcvst {
3161              
3162             # get parameters
3163 0     0     my ($self, $parent, $fh, $tag) = @_;
3164              
3165             # local variables
3166 0           my ($n, $offset, $size, @cept, %hash);
3167              
3168             # get number of curve elements
3169 0           $n = @{$self->[1]};
  0            
3170              
3171             # verify number of channels (1 to 15)
3172 0 0 0       ($n > 0 && $n < 16) or croak('unsupported number of channels');
3173              
3174             # seek start of tag
3175 0           seek($fh, $tag->[1], 0);
3176              
3177             # write tag type signature and number channels
3178 0           print $fh pack('a4 x4 n2', 'cvst', $n, $n);
3179              
3180             # initialize tag offset
3181 0           $offset = 12 + 8 * $n;
3182              
3183             # for each curve element
3184 0           for my $i (0 .. $#{$self->[1]}) {
  0            
3185            
3186             # verify curve element is 'curf' object
3187 0 0         (UNIVERSAL::isa($self->[1][$i], 'ICC::Profile::curf')) or croak('curve element must a \'curf\' object');
3188            
3189             # if tag not in hash
3190 0 0         if (! exists($hash{$self->[1][$i]})) {
3191            
3192             # get size
3193 0           $size = $self->[1][$i]->size();
3194            
3195             # set table entry and add to hash
3196 0           $cept[$i] = $hash{$self->[1][$i]} = [$offset, $size];
3197            
3198             # update offset
3199 0           $offset += $size;
3200            
3201             # adjust to 4-byte boundary
3202 0           $offset += -$offset % 4;
3203            
3204             } else {
3205            
3206             # set table entry
3207 0           $cept[$i] = $hash{$self->[1][$i]};
3208            
3209             }
3210            
3211             # write curve element position entry
3212 0           print $fh pack('N2', @{$cept[$i]});
  0            
3213            
3214             }
3215              
3216             # initialize hash
3217 0           %hash = ();
3218              
3219             # for each curve element
3220 0           for my $i (0 .. $#{$self->[1]}) {
  0            
3221            
3222             # if tag not in hash
3223 0 0         if (! exists($hash{$self->[1][$i]})) {
3224            
3225             # make offset absolute
3226 0           $cept[$i][0] += $tag->[1];
3227            
3228             # write tag
3229 0           $self->[1][$i]->write_fh($self, $fh, ['cvst', $cept[$i][0], $cept[$i][1]]);
3230            
3231             # add key to hash
3232 0           $hash{$self->[1][$i]}++;
3233            
3234             }
3235            
3236             }
3237            
3238             }
3239              
3240             1;