line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package ICC::Profile::mAB_; |
2
|
|
|
|
|
|
|
|
3
|
2
|
|
|
2
|
|
89916
|
use strict; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
53
|
|
4
|
2
|
|
|
2
|
|
10
|
use Carp; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
140
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
our $VERSION = 2.51; |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
# revised 2018-08-07 |
9
|
|
|
|
|
|
|
# |
10
|
|
|
|
|
|
|
# Copyright © 2004-2019 by William B. Birkett |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# add development directory |
13
|
2
|
|
|
2
|
|
15
|
use lib 'lib'; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
11
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
# inherit from Shared |
16
|
2
|
|
|
2
|
|
252
|
use parent qw(ICC::Shared); |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
13
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
# use POSIX math |
19
|
2
|
|
|
2
|
|
109
|
use POSIX (); |
|
2
|
|
|
|
|
13
|
|
|
2
|
|
|
|
|
9878
|
|
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
# create new mAB_ object |
22
|
|
|
|
|
|
|
# hash may contain pointers to B-curves, matrix, M-curves, CLUT, or A-curves |
23
|
|
|
|
|
|
|
# keys are: ('b_curves', 'matrix', 'm_curves', 'clut', 'a_curves') |
24
|
|
|
|
|
|
|
# tag elements not specified in the hash are left empty |
25
|
|
|
|
|
|
|
# parameters: () |
26
|
|
|
|
|
|
|
# parameters: (ref_to_attribute_hash) |
27
|
|
|
|
|
|
|
# parameters: (ref_to_matrix-based_profile_object) |
28
|
|
|
|
|
|
|
# returns: (ref_to_object) |
29
|
|
|
|
|
|
|
sub new { |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
# get object class |
32
|
1
|
|
|
1
|
0
|
1117
|
my $class = shift(); |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
# create empty mAB_ object |
35
|
1
|
|
|
|
|
4
|
my $self = [ |
36
|
|
|
|
|
|
|
{}, # object header |
37
|
|
|
|
|
|
|
[], # processing elements |
38
|
|
|
|
|
|
|
0x00, # transform mask |
39
|
|
|
|
|
|
|
0x00 # clipping mask |
40
|
|
|
|
|
|
|
]; |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
# if there are parameters |
43
|
1
|
50
|
|
|
|
5
|
if (@_) { |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
# if one parameter, a hash reference |
46
|
0
|
0
|
0
|
|
|
0
|
if (@_ == 1 && ref($_[0]) eq 'HASH') { |
|
|
0
|
0
|
|
|
|
|
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
# make new mAB_ tag from attribute hash |
49
|
0
|
|
|
|
|
0
|
_new_from_hash($self, @_); |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
# if one parameter, an ICC::Profile object |
52
|
|
|
|
|
|
|
} elsif (@_ == 1 && UNIVERSAL::isa($_[0], 'ICC::Profile')) { |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
# make new mAB_ tag from ICC::Profile object |
55
|
0
|
|
|
|
|
0
|
_newICCmatrix($self, @_); |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
} else { |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
# error |
60
|
0
|
|
|
|
|
0
|
croak('parameter must be a hash reference or a display matrix profile'); |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
# bless object |
67
|
1
|
|
|
|
|
3
|
bless($self, $class); |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
# return object reference |
70
|
1
|
|
|
|
|
2
|
return($self); |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
} |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
# get/set reference to header hash |
75
|
|
|
|
|
|
|
# parameters: ([ref_to_new_hash]) |
76
|
|
|
|
|
|
|
# returns: (ref_to_hash) |
77
|
|
|
|
|
|
|
sub header { |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
# get object reference |
80
|
0
|
|
|
0
|
0
|
0
|
my $self = shift(); |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
# if there are parameters |
83
|
0
|
0
|
|
|
|
0
|
if (@_) { |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
# if one parameter, a hash reference |
86
|
0
|
0
|
0
|
|
|
0
|
if (@_ == 1 && ref($_[0]) eq 'HASH') { |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
# set header to new hash |
89
|
0
|
|
|
|
|
0
|
$self->[0] = shift(); |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
} else { |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
# error |
94
|
0
|
|
|
|
|
0
|
croak('parameter must be a hash reference'); |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
# return reference |
101
|
0
|
|
|
|
|
0
|
return($self->[0]); |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
# get/set processing element array reference |
106
|
|
|
|
|
|
|
# parameters: ([ref_to_array]) |
107
|
|
|
|
|
|
|
# returns: (ref_to_array) |
108
|
|
|
|
|
|
|
sub array { |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
# get object reference |
111
|
0
|
|
|
0
|
0
|
0
|
my $self = shift(); |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
# if parameter |
114
|
0
|
0
|
|
|
|
0
|
if (@_) { |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
# verify array reference |
117
|
0
|
0
|
|
|
|
0
|
(ref($_[0]) eq 'ARRAY') or croak('not an array reference'); |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
# set array reference |
120
|
0
|
|
|
|
|
0
|
$self->[1] = [@{shift()}]; |
|
0
|
|
|
|
|
0
|
|
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
# return array reference |
125
|
0
|
|
|
|
|
0
|
return($self->[1]); |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
# get/set reference to B-curves 'cvst' object |
130
|
|
|
|
|
|
|
# parameters: ([ref_to_new_object]) |
131
|
|
|
|
|
|
|
# returns: (ref_to_object) |
132
|
|
|
|
|
|
|
sub b_curves { |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
# get object reference |
135
|
0
|
|
|
0
|
0
|
0
|
my $self = shift(); |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
# if there are parameters |
138
|
0
|
0
|
|
|
|
0
|
if (@_) { |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
# if one parameter, a 'cvst' object |
141
|
0
|
0
|
0
|
|
|
0
|
if (@_ == 1 && UNIVERSAL::isa($_[0], 'ICC::Profile::cvst')) { |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
# set B-curves to new object |
144
|
0
|
|
|
|
|
0
|
$self->[1][0] = shift(); |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
# set transform mask bit |
147
|
0
|
|
|
|
|
0
|
$self->[2] |= 0x01; |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
} else { |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
# error |
152
|
0
|
|
|
|
|
0
|
croak('parameter must be a \'cvst\' object'); |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
# return object reference |
159
|
0
|
|
|
|
|
0
|
return($self->[1][0]); |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
# get/set reference to matrix 'matf' object |
164
|
|
|
|
|
|
|
# parameters: ([ref_to_new_object]) |
165
|
|
|
|
|
|
|
# returns: (ref_to_object) |
166
|
|
|
|
|
|
|
sub matrix { |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
# get object reference |
169
|
0
|
|
|
0
|
0
|
0
|
my $self = shift(); |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
# if there are parameters |
172
|
0
|
0
|
|
|
|
0
|
if (@_) { |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
# if one parameter, an 'matf' object |
175
|
0
|
0
|
0
|
|
|
0
|
if (@_ == 1 && UNIVERSAL::isa($_[0], 'ICC::Profile::matf')) { |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
# set matrix to new object |
178
|
0
|
|
|
|
|
0
|
$self->[1][1] = shift(); |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
# set transform mask bit |
181
|
0
|
|
|
|
|
0
|
$self->[2] |= 0x02; |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
} else { |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
# error |
186
|
0
|
|
|
|
|
0
|
croak('parameter must be an \'matf\' object'); |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
# return object reference |
193
|
0
|
|
|
|
|
0
|
return($self->[1][1]); |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
# get/set reference to M-curves 'cvst' object |
198
|
|
|
|
|
|
|
# parameters: ([ref_to_new_object]) |
199
|
|
|
|
|
|
|
# returns: (ref_to_object) |
200
|
|
|
|
|
|
|
sub m_curves { |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
# get object reference |
203
|
0
|
|
|
0
|
0
|
0
|
my $self = shift(); |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
# if there are parameters |
206
|
0
|
0
|
|
|
|
0
|
if (@_) { |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
# if one parameter, a 'cvst' object |
209
|
0
|
0
|
0
|
|
|
0
|
if (@_ == 1 && UNIVERSAL::isa($_[0], 'ICC::Profile::cvst')) { |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
# set M-curves to new object |
212
|
0
|
|
|
|
|
0
|
$self->[1][2] = shift(); |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
# set transform mask bit |
215
|
0
|
|
|
|
|
0
|
$self->[2] |= 0x04; |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
} else { |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
# error |
220
|
0
|
|
|
|
|
0
|
croak('parameter must be a \'cvst\' object'); |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
# return object reference |
227
|
0
|
|
|
|
|
0
|
return($self->[1][2]); |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
# get/set reference to CLUT 'clut' object |
232
|
|
|
|
|
|
|
# parameters: ([ref_to_new_object]) |
233
|
|
|
|
|
|
|
# returns: (ref_to_object) |
234
|
|
|
|
|
|
|
sub clut { |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
# get object reference |
237
|
0
|
|
|
0
|
0
|
0
|
my $self = shift(); |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
# if there are parameters |
240
|
0
|
0
|
|
|
|
0
|
if (@_) { |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
# if one parameter, a 'clut' object |
243
|
0
|
0
|
0
|
|
|
0
|
if (@_ == 1 && UNIVERSAL::isa($_[0], 'ICC::Profile::clut')) { |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
# set CLUT to new object |
246
|
0
|
|
|
|
|
0
|
$self->[1][3] = shift(); |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
# set transform mask bit |
249
|
0
|
|
|
|
|
0
|
$self->[2] |= 0x08; |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
} else { |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
# error |
254
|
0
|
|
|
|
|
0
|
croak('parameter must be a \'clut\' object'); |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
# return object reference |
261
|
0
|
|
|
|
|
0
|
return($self->[1][3]); |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
# get/set reference to A-curves 'cvst' object |
266
|
|
|
|
|
|
|
# parameters: ([ref_to_new_object]) |
267
|
|
|
|
|
|
|
# returns: (ref_to_object) |
268
|
|
|
|
|
|
|
sub a_curves { |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
# get object reference |
271
|
0
|
|
|
0
|
0
|
0
|
my $self = shift(); |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
# if there are parameters |
274
|
0
|
0
|
|
|
|
0
|
if (@_) { |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
# if one parameter, a 'cvst' object |
277
|
0
|
0
|
0
|
|
|
0
|
if (@_ == 1 && UNIVERSAL::isa($_[0], 'ICC::Profile::cvst')) { |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
# set A-curves to new object |
280
|
0
|
|
|
|
|
0
|
$self->[1][4] = shift(); |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
# set transform mask bit |
283
|
0
|
|
|
|
|
0
|
$self->[2] |= 0x10; |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
} else { |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
# error |
288
|
0
|
|
|
|
|
0
|
croak('parameter must be a \'cvst\' object'); |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
} |
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
# return object reference |
295
|
0
|
|
|
|
|
0
|
return($self->[1][4]); |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
} |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
# get/set transform mask |
300
|
|
|
|
|
|
|
# bits 4-3-2-1-0 correpsond to A-CLUT-M-MATRIX-B |
301
|
|
|
|
|
|
|
# parameters: ([new_mask_value]) |
302
|
|
|
|
|
|
|
# returns: (mask_value) |
303
|
|
|
|
|
|
|
sub mask { |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
# get object reference |
306
|
0
|
|
|
0
|
0
|
0
|
my $self = shift(); |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
# if there are parameters |
309
|
0
|
0
|
|
|
|
0
|
if (@_) { |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
# if one parameter |
312
|
0
|
0
|
|
|
|
0
|
if (@_ == 1) { |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
# set object transform mask value |
315
|
0
|
|
|
|
|
0
|
$self->[2] = shift(); |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
} else { |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
# error |
320
|
0
|
|
|
|
|
0
|
croak('more than one parameter'); |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
# return transform mask value |
327
|
0
|
|
|
|
|
0
|
return($self->[2]); |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
} |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
# get/set clipping mask |
332
|
|
|
|
|
|
|
# bits 4-3-2-1-0 correpsond to A-CLUT-M-MATRIX-B |
333
|
|
|
|
|
|
|
# parameters: ([new_mask_value]) |
334
|
|
|
|
|
|
|
# returns: (mask_value) |
335
|
|
|
|
|
|
|
sub clip { |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
# get object reference |
338
|
0
|
|
|
0
|
1
|
0
|
my $self = shift(); |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
# if there are parameters |
341
|
0
|
0
|
|
|
|
0
|
if (@_) { |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
# if one parameter |
344
|
0
|
0
|
|
|
|
0
|
if (@_ == 1) { |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
# set object clipping mask value |
347
|
0
|
|
|
|
|
0
|
$self->[3] = shift(); |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
} else { |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
# error |
352
|
0
|
|
|
|
|
0
|
croak('more than one parameter'); |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
# return clipping mask value |
359
|
0
|
|
|
|
|
0
|
return($self->[3]); |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
# create mAB_ tag object from ICC profile |
364
|
|
|
|
|
|
|
# parameters: (ref_to_parent_object, file_handle, ref_to_tag_table_entry) |
365
|
|
|
|
|
|
|
# returns: (ref_to_object) |
366
|
|
|
|
|
|
|
sub new_fh { |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
# get object class |
369
|
1
|
|
|
1
|
0
|
1007
|
my $class = shift(); |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
# create empty mAB_ object |
372
|
1
|
|
|
|
|
4
|
my $self = [ |
373
|
|
|
|
|
|
|
{}, # object header |
374
|
|
|
|
|
|
|
[], # processing elements |
375
|
|
|
|
|
|
|
0x00, # transform mask |
376
|
|
|
|
|
|
|
0x00 # clipping mask |
377
|
|
|
|
|
|
|
]; |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
# verify 3 parameters |
380
|
1
|
50
|
|
|
|
5
|
(@_ == 3) or croak('wrong number of parameters'); |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
# read mAB_ data from profile |
383
|
1
|
|
|
|
|
5
|
_readICCmAB_($self, @_); |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
# bless object |
386
|
1
|
|
|
|
|
3
|
bless($self, $class); |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
# return object reference |
389
|
1
|
|
|
|
|
19
|
return($self); |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
} |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
# writes mAB_ tag object to ICC profile |
394
|
|
|
|
|
|
|
# parameters: (ref_to_parent_object, file_handle, ref_to_tag_table_entry) |
395
|
|
|
|
|
|
|
sub write_fh { |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
# verify 4 parameters |
398
|
1
|
50
|
|
1
|
0
|
2904
|
(@_ == 4) or croak('wrong number of parameters'); |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
# write mAB_ data to profile |
401
|
1
|
|
|
|
|
6
|
goto &_writeICCmAB_; |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
} |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
# get tag size (for writing to profile) |
406
|
|
|
|
|
|
|
# returns: (tag_clut_size) |
407
|
|
|
|
|
|
|
sub size { |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
# get parameters |
410
|
3
|
|
|
3
|
0
|
506
|
my ($self) = @_; |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
# local variables |
413
|
3
|
|
|
|
|
7
|
my ($size); |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
# set header size |
416
|
3
|
|
|
|
|
3
|
$size = 32; |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
# for each B-curve |
419
|
3
|
|
|
|
|
4
|
for my $curve (@{$self->[1][0]->array()}) { |
|
3
|
|
|
|
|
15
|
|
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
# add curve size |
422
|
9
|
|
|
|
|
20
|
$size += $curve->size; |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
# pad to 4-bytes |
425
|
9
|
|
|
|
|
15
|
$size += (-$size % 4); |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
# if matrix defined |
430
|
3
|
50
|
|
|
|
10
|
if (defined($self->[1][1])) { |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
# add matrix size (48 bytes) |
433
|
3
|
|
|
|
|
4
|
$size += 48; |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
# if M-curves defined |
438
|
3
|
50
|
|
|
|
5
|
if (defined($self->[1][2])) { |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
# for each M-curve |
441
|
3
|
|
|
|
|
5
|
for my $curve (@{$self->[1][2]->array()}) { |
|
3
|
|
|
|
|
15
|
|
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
# add curve size |
444
|
9
|
|
|
|
|
14
|
$size += $curve->size; |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
# pad to 4-bytes |
447
|
9
|
|
|
|
|
15
|
$size += (-$size % 4); |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
} |
450
|
|
|
|
|
|
|
|
451
|
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
# if CLUT defined |
454
|
3
|
50
|
|
|
|
8
|
if (defined($self->[1][3])) { |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
# add CLUT size (nCLUT object) |
457
|
3
|
|
50
|
|
|
14
|
$size += 20 + $self->[1][3]->_clut_size($self->[1][3][0]{'clut_bytes'} || 2); |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
# pad to 4-byte boundary |
460
|
3
|
|
|
|
|
5
|
$size += (-$size % 4); |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
} |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
# if A-curves defined |
465
|
3
|
50
|
|
|
|
7
|
if (defined($self->[1][4])) { |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
# for each A-curve |
468
|
3
|
|
|
|
|
4
|
for my $curve (@{$self->[1][4]->array()}) { |
|
3
|
|
|
|
|
5
|
|
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
# add curve size |
471
|
9
|
|
|
|
|
16
|
$size += $curve->size; |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
# pad to 4-bytes |
474
|
9
|
|
|
|
|
18
|
$size += (-$size % 4); |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
} |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
} |
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
# return size |
481
|
3
|
|
|
|
|
127
|
return($size); |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
# get number of input channels |
486
|
|
|
|
|
|
|
# returns: (number) |
487
|
|
|
|
|
|
|
sub cin { |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
# get object reference |
490
|
0
|
|
|
0
|
0
|
0
|
my $self = shift(); |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
# return |
493
|
0
|
|
|
|
|
0
|
return($self->[1][-1]->cin()); |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
# get number of output channels |
498
|
|
|
|
|
|
|
# returns: (number) |
499
|
|
|
|
|
|
|
sub cout { |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
# get object reference |
502
|
0
|
|
|
0
|
0
|
0
|
my $self = shift(); |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
# return |
505
|
0
|
|
|
|
|
0
|
return($self->[1][0]->cout()); |
506
|
|
|
|
|
|
|
|
507
|
|
|
|
|
|
|
} |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
# transform data |
510
|
|
|
|
|
|
|
# transform mask enables/disables individual tag elements |
511
|
|
|
|
|
|
|
# clipping mask enables/disables individual tag output clipping |
512
|
|
|
|
|
|
|
# supported input types: |
513
|
|
|
|
|
|
|
# parameters: (list, [hash]) |
514
|
|
|
|
|
|
|
# parameters: (vector, [hash]) |
515
|
|
|
|
|
|
|
# parameters: (matrix, [hash]) |
516
|
|
|
|
|
|
|
# parameters: (Math::Matrix_object, [hash]) |
517
|
|
|
|
|
|
|
# parameters: (structure, [hash]) |
518
|
|
|
|
|
|
|
# returns: (same_type_as_input) |
519
|
|
|
|
|
|
|
sub transform { |
520
|
|
|
|
|
|
|
|
521
|
|
|
|
|
|
|
# set hash value (0 or 1) |
522
|
0
|
0
|
|
0
|
0
|
0
|
my $h = ref($_[-1]) eq 'HASH' ? 1 : 0; |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
# if input a 'Math::Matrix' object |
525
|
0
|
0
|
0
|
|
|
0
|
if (@_ == $h + 2 && UNIVERSAL::isa($_[1], 'Math::Matrix')) { |
|
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
# call matrix transform |
528
|
0
|
|
|
|
|
0
|
&_trans2; |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
# if input an array reference |
531
|
|
|
|
|
|
|
} elsif (@_ == $h + 2 && ref($_[1]) eq 'ARRAY') { |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
# if array contains numbers (vector) |
534
|
0
|
0
|
0
|
|
|
0
|
if (! ref($_[1][0]) && @{$_[1]} == grep {Scalar::Util::looks_like_number($_)} @{$_[1]}) { |
|
0
|
0
|
0
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
# call vector transform |
537
|
0
|
|
|
|
|
0
|
&_trans1; |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
# if array contains vectors (2-D array) |
540
|
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
|
|
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
# call matrix transform |
543
|
0
|
|
|
|
|
0
|
&_trans2; |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
} else { |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
# call structure transform |
548
|
0
|
|
|
|
|
0
|
&_trans3; |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
} |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
# if input a list (of numbers) |
553
|
0
|
|
|
|
|
0
|
} elsif (@_ == $h + 1 + grep {Scalar::Util::looks_like_number($_)} @_) { |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
# call list transform |
556
|
0
|
|
|
|
|
0
|
&_trans0; |
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
} else { |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
# error |
561
|
0
|
|
|
|
|
0
|
croak('invalid transform input'); |
562
|
|
|
|
|
|
|
|
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
} |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
# inverse transform |
568
|
|
|
|
|
|
|
# note: number of undefined output values must equal number of defined input values |
569
|
|
|
|
|
|
|
# note: the input and output vectors contain the final solution on return |
570
|
|
|
|
|
|
|
# hash key 'init' specifies initial value vector |
571
|
|
|
|
|
|
|
# hash key 'ubox' enables unit box extrapolation |
572
|
|
|
|
|
|
|
# parameters: (input_vector, output_vector, [hash]) |
573
|
|
|
|
|
|
|
# returns: (RMS_error_value) |
574
|
|
|
|
|
|
|
sub inverse { |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
# get parameters |
577
|
0
|
|
|
0
|
0
|
0
|
my ($self, $in, $out, $hash) = @_; |
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
# local variables |
580
|
0
|
|
|
|
|
0
|
my ($i, $j, @si, @so, $init); |
581
|
0
|
|
|
|
|
0
|
my ($int, $jac, $mat, $delta); |
582
|
0
|
|
|
|
|
0
|
my ($max, $elim, $dlim, $accum, $error); |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
# initialize indices |
585
|
0
|
|
|
|
|
0
|
$i = $j = -1; |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
# build slice arrays while validating input and output arrays |
588
|
0
|
0
|
|
|
|
0
|
((grep {$i++; defined() && push(@si, $i)} @{$in}) == (grep {$j++; ! defined() && push(@so, $j)} @{$out})) or croak('wrong number of undefined values'); |
|
0
|
0
|
|
|
|
0
|
|
|
0
|
0
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
# get init array |
591
|
0
|
|
|
|
|
0
|
$init = $hash->{'init'}; |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
# for each undefined output value |
594
|
0
|
|
|
|
|
0
|
for my $i (@so) { |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
# set to supplied initial value or 0.5 |
597
|
0
|
0
|
|
|
|
0
|
$out->[$i] = defined($init->[$i]) ? $init->[$i] : 0.5; |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
} |
600
|
|
|
|
|
|
|
|
601
|
|
|
|
|
|
|
# set maximum loop count |
602
|
0
|
|
0
|
|
|
0
|
$max = $hash->{'inv_max'} || 10; |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
# loop error limit |
605
|
0
|
|
0
|
|
|
0
|
$elim = $hash->{'inv_elim'} || 1E-6; |
606
|
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
# set delta limit |
608
|
0
|
|
0
|
|
|
0
|
$dlim = $hash->{'inv_dlim'} || 0.5; |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
# create empty solution matrix |
611
|
0
|
|
|
|
|
0
|
$mat = Math::Matrix->new([]); |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
# compute initial transform values |
614
|
0
|
|
|
|
|
0
|
($jac, $int) = jacobian($self, $out, $hash); |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
# solution loop |
617
|
0
|
|
|
|
|
0
|
for (1 .. $max) { |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
# for each input |
620
|
0
|
|
|
|
|
0
|
for my $i (0 .. $#si) { |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
# for each output |
623
|
0
|
|
|
|
|
0
|
for my $j (0 .. $#so) { |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
# copy Jacobian value to solution matrix |
626
|
0
|
|
|
|
|
0
|
$mat->[$i][$j] = $jac->[$si[$i]][$so[$j]]; |
627
|
|
|
|
|
|
|
|
628
|
|
|
|
|
|
|
} |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
# save residual value to solution matrix |
631
|
0
|
|
|
|
|
0
|
$mat->[$i][$#si + 1] = $in->[$si[$i]] - $int->[$si[$i]]; |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
} |
634
|
|
|
|
|
|
|
|
635
|
|
|
|
|
|
|
# solve for delta values |
636
|
0
|
|
|
|
|
0
|
$delta = $mat->solve; |
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
# for each output value |
639
|
0
|
|
|
|
|
0
|
for my $i (0 .. $#so) { |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
# add delta (limited using hyperbolic tangent) |
642
|
0
|
|
|
|
|
0
|
$out->[$so[$i]] += POSIX::tanh($delta->[$i][0]/$dlim) * $dlim; |
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
} |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
# compute updated transform values |
647
|
0
|
|
|
|
|
0
|
($jac, $int) = jacobian($self, $out, $hash); |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
# initialize error accumulator |
650
|
0
|
|
|
|
|
0
|
$accum = 0; |
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
# for each input |
653
|
0
|
|
|
|
|
0
|
for my $i (0 .. $#si) { |
654
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
# accumulate delta squared |
656
|
0
|
|
|
|
|
0
|
$accum += ($in->[$si[$i]] - $int->[$si[$i]])**2; |
657
|
|
|
|
|
|
|
|
658
|
|
|
|
|
|
|
} |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
# compute RMS error |
661
|
0
|
|
|
|
|
0
|
$error = sqrt($accum/@si); |
662
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
# if error less than limit |
664
|
0
|
0
|
|
|
|
0
|
last if ($error < $elim); |
665
|
|
|
|
|
|
|
|
666
|
|
|
|
|
|
|
} |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
# update input vector with final values |
669
|
0
|
|
|
|
|
0
|
@{$in} = @{$int}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
670
|
|
|
|
|
|
|
|
671
|
|
|
|
|
|
|
# return |
672
|
0
|
|
|
|
|
0
|
return($error); |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
} |
675
|
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
# compute Jacobian matrix |
677
|
|
|
|
|
|
|
# transform mask enables/disables individual tag elements |
678
|
|
|
|
|
|
|
# parameters: (input_vector, [hash]) |
679
|
|
|
|
|
|
|
# returns: (Jacobian_matrix, [output_vector]) |
680
|
|
|
|
|
|
|
sub jacobian { |
681
|
|
|
|
|
|
|
|
682
|
|
|
|
|
|
|
# get parameters |
683
|
0
|
|
|
0
|
0
|
0
|
my ($self, $data, $hash) = @_; |
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
# local variables |
686
|
0
|
|
|
|
|
0
|
my ($jac, $jaci); |
687
|
|
|
|
|
|
|
|
688
|
|
|
|
|
|
|
# for each processing element (note: sequence is from the last element to the first) |
689
|
0
|
|
|
|
|
0
|
for my $i (reverse(0 .. $#{$self->[1]})) { |
|
0
|
|
|
|
|
0
|
|
690
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
# if processing element defined, and transform mask bit set |
692
|
0
|
0
|
0
|
|
|
0
|
if (defined($self->[1][$i]) && $self->[2] & 0x01 << $i) { |
693
|
|
|
|
|
|
|
|
694
|
|
|
|
|
|
|
# compute Jacobian matrix and transform data |
695
|
0
|
|
|
|
|
0
|
($jaci, $data) = $self->[1][$i]->jacobian($data, $hash); |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
# multiply Jacobian matrices |
698
|
0
|
0
|
|
|
|
0
|
$jac = defined($jac) ? $jaci * $jac : $jaci; |
699
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
} |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
} |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
# if Jacobian matrix is undefined, use identity matrix |
705
|
0
|
0
|
|
|
|
0
|
$jac = Math::Matrix->diagonal((1) x @{$data}) if (! defined($jac)); |
|
0
|
|
|
|
|
0
|
|
706
|
|
|
|
|
|
|
|
707
|
|
|
|
|
|
|
# if output values wanted |
708
|
0
|
0
|
|
|
|
0
|
if (wantarray) { |
709
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
# return Jacobian and output values |
711
|
0
|
|
|
|
|
0
|
return($jac, $data); |
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
} else { |
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
# return Jacobian only |
716
|
0
|
|
|
|
|
0
|
return($jac); |
717
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
} |
719
|
|
|
|
|
|
|
|
720
|
|
|
|
|
|
|
} |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
# get/set PCS encoding |
723
|
|
|
|
|
|
|
# for use with ICC::Support::PCS objects |
724
|
|
|
|
|
|
|
# parameters: ([PCS_encoding]) |
725
|
|
|
|
|
|
|
# returns: (PCS_encoding) |
726
|
|
|
|
|
|
|
sub pcs { |
727
|
|
|
|
|
|
|
|
728
|
|
|
|
|
|
|
# get parameters |
729
|
0
|
|
|
0
|
0
|
0
|
my ($self, $pcs) = @_; |
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
# if PCS parameter is supplied |
732
|
0
|
0
|
|
|
|
0
|
if (defined($pcs)) { |
733
|
|
|
|
|
|
|
|
734
|
|
|
|
|
|
|
# if a valid PCS encoding |
735
|
0
|
0
|
|
|
|
0
|
if (grep {$pcs == $_} (3, 8)) { |
|
0
|
|
|
|
|
0
|
|
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
# copy to tag header hash |
738
|
0
|
|
|
|
|
0
|
$self->[0]{'pcs_encoding'} = $pcs; |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
# return PCS encoding |
741
|
0
|
|
|
|
|
0
|
return($pcs); |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
} else { |
744
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
# error |
746
|
0
|
|
|
|
|
0
|
croak('invalid PCS encoding'); |
747
|
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
} |
749
|
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
} else { |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
# if PCS is defined in tag header |
753
|
0
|
0
|
|
|
|
0
|
if (defined($self->[0]{'pcs_encoding'})) { |
754
|
|
|
|
|
|
|
|
755
|
|
|
|
|
|
|
# return PCS encoding |
756
|
0
|
|
|
|
|
0
|
return($self->[0]{'pcs_encoding'}); |
757
|
|
|
|
|
|
|
|
758
|
|
|
|
|
|
|
} else { |
759
|
|
|
|
|
|
|
|
760
|
|
|
|
|
|
|
# error |
761
|
0
|
|
|
|
|
0
|
croak('can\'t determine PCS encoding'); |
762
|
|
|
|
|
|
|
|
763
|
|
|
|
|
|
|
} |
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
} |
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
} |
768
|
|
|
|
|
|
|
|
769
|
|
|
|
|
|
|
# get/set white point |
770
|
|
|
|
|
|
|
# parameters: ([white_point]) |
771
|
|
|
|
|
|
|
# returns: (white_point) |
772
|
|
|
|
|
|
|
sub wtpt { |
773
|
|
|
|
|
|
|
|
774
|
|
|
|
|
|
|
# get parameters |
775
|
0
|
|
|
0
|
0
|
0
|
my ($self, $wtpt) = @_; |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
# if white point parameter is supplied |
778
|
0
|
0
|
|
|
|
0
|
if (defined($wtpt)) { |
779
|
|
|
|
|
|
|
|
780
|
|
|
|
|
|
|
# if an array of three scalars |
781
|
0
|
0
|
0
|
|
|
0
|
if (@{$wtpt} == 3 && 3 == grep {! ref()} @{$wtpt}) { |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
# copy to tag header hash |
784
|
0
|
|
|
|
|
0
|
$self->[0]{'wtpt'} = $wtpt; |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
# return white point |
787
|
0
|
|
|
|
|
0
|
return($wtpt); |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
} else { |
790
|
|
|
|
|
|
|
|
791
|
|
|
|
|
|
|
# error |
792
|
0
|
|
|
|
|
0
|
croak('invalid white point'); |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
} |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
} else { |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
# if white point is defined in tag header |
799
|
0
|
0
|
|
|
|
0
|
if (defined($self->[0]{'wtpt'})) { |
800
|
|
|
|
|
|
|
|
801
|
|
|
|
|
|
|
# return return white point |
802
|
0
|
|
|
|
|
0
|
return($self->[0]{'wtpt'}); |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
} else { |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
# error |
807
|
0
|
|
|
|
|
0
|
croak('can\'t determine white point'); |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
} |
810
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
} |
812
|
|
|
|
|
|
|
|
813
|
|
|
|
|
|
|
} |
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
# print object contents to string |
816
|
|
|
|
|
|
|
# format is an array structure |
817
|
|
|
|
|
|
|
# parameter: ([format]) |
818
|
|
|
|
|
|
|
# returns: (string) |
819
|
|
|
|
|
|
|
sub sdump { |
820
|
|
|
|
|
|
|
|
821
|
|
|
|
|
|
|
# get parameters |
822
|
0
|
|
|
0
|
1
|
0
|
my ($self, $p) = @_; |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
# local variables |
825
|
0
|
|
|
|
|
0
|
my ($element, $fmt, $s, $pt, $st); |
826
|
|
|
|
|
|
|
|
827
|
|
|
|
|
|
|
# resolve parameter to an array reference |
828
|
0
|
0
|
|
|
|
0
|
$p = defined($p) ? ref($p) eq 'ARRAY' ? $p : [$p] : []; |
|
|
0
|
|
|
|
|
|
829
|
|
|
|
|
|
|
|
830
|
|
|
|
|
|
|
# get format string |
831
|
0
|
0
|
0
|
|
|
0
|
$fmt = defined($p->[0]) && ! ref($p->[0]) ? $p->[0] : 's'; |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
# set string to object ID |
834
|
0
|
|
|
|
|
0
|
$s = sprintf("'%s' object, (0x%x)\n", ref($self), $self); |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
# if format contains 'o' |
837
|
0
|
0
|
|
|
|
0
|
if ($fmt =~ m/s/) { |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
# get default parameter |
840
|
0
|
|
|
|
|
0
|
$pt = $p->[-1]; |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
# for each processing element |
843
|
0
|
|
|
|
|
0
|
for my $i (0 .. $#{$self->[1]}) { |
|
0
|
|
|
|
|
0
|
|
844
|
|
|
|
|
|
|
|
845
|
|
|
|
|
|
|
# get element reference |
846
|
0
|
|
|
|
|
0
|
$element = $self->[1][$i]; |
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
# if processing element is undefined |
849
|
0
|
0
|
|
|
|
0
|
if (! defined($element)) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
850
|
|
|
|
|
|
|
|
851
|
|
|
|
|
|
|
# append message |
852
|
0
|
|
|
|
|
0
|
$s .= "\tprocessing element is undefined\n"; |
853
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
# if processing element is not a blessed object |
855
|
|
|
|
|
|
|
} elsif (! Scalar::Util::blessed($element)) { |
856
|
|
|
|
|
|
|
|
857
|
|
|
|
|
|
|
# append message |
858
|
0
|
|
|
|
|
0
|
$s .= "\tprocessing element is not a blessed object\n"; |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
# if processing element has an 'sdump' method |
861
|
|
|
|
|
|
|
} elsif ($element->can('sdump')) { |
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
# get 'sdump' string |
864
|
0
|
0
|
|
|
|
0
|
$st = $element->sdump(defined($p->[$i + 1]) ? $p->[$i + 1] : $pt); |
865
|
|
|
|
|
|
|
|
866
|
|
|
|
|
|
|
# prepend tabs to each line |
867
|
0
|
|
|
|
|
0
|
$st =~ s/^/\t/mg; |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
# append 'sdump' string |
870
|
0
|
|
|
|
|
0
|
$s .= $st; |
871
|
|
|
|
|
|
|
|
872
|
|
|
|
|
|
|
# processing element is object without an 'sdump' method |
873
|
|
|
|
|
|
|
} else { |
874
|
|
|
|
|
|
|
|
875
|
|
|
|
|
|
|
# append object info |
876
|
0
|
|
|
|
|
0
|
$s .= sprintf("\t'%s' object, (0x%x)\n", ref($element), $element); |
877
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
} |
879
|
|
|
|
|
|
|
|
880
|
|
|
|
|
|
|
} |
881
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
} |
883
|
|
|
|
|
|
|
|
884
|
|
|
|
|
|
|
# return |
885
|
0
|
|
|
|
|
0
|
return($s); |
886
|
|
|
|
|
|
|
|
887
|
|
|
|
|
|
|
} |
888
|
|
|
|
|
|
|
|
889
|
|
|
|
|
|
|
# transform list |
890
|
|
|
|
|
|
|
# parameters: (object_reference, list, [hash]) |
891
|
|
|
|
|
|
|
# returns: (list) |
892
|
|
|
|
|
|
|
sub _trans0 { |
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
# local variables |
895
|
0
|
|
|
0
|
|
0
|
my ($self, $hash, $data); |
896
|
|
|
|
|
|
|
|
897
|
|
|
|
|
|
|
# get object reference |
898
|
0
|
|
|
|
|
0
|
$self = shift(); |
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
# get optional hash |
901
|
0
|
0
|
|
|
|
0
|
$hash = pop() if (ref($_[-1]) eq 'HASH'); |
902
|
|
|
|
|
|
|
|
903
|
|
|
|
|
|
|
# process data |
904
|
0
|
|
|
|
|
0
|
$data = _trans1($self, [@_], $hash); |
905
|
|
|
|
|
|
|
|
906
|
|
|
|
|
|
|
# return list |
907
|
0
|
|
|
|
|
0
|
return(@{$data}); |
|
0
|
|
|
|
|
0
|
|
908
|
|
|
|
|
|
|
|
909
|
|
|
|
|
|
|
} |
910
|
|
|
|
|
|
|
|
911
|
|
|
|
|
|
|
# transform vector |
912
|
|
|
|
|
|
|
# parameters: (object_reference, vector, [hash]) |
913
|
|
|
|
|
|
|
# returns: (vector) |
914
|
|
|
|
|
|
|
sub _trans1 { |
915
|
|
|
|
|
|
|
|
916
|
|
|
|
|
|
|
# get parameters |
917
|
0
|
|
|
0
|
|
0
|
my ($self, $data, $hash) = @_; |
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
# for each processing element (note: sequence is from the last element to the first) |
920
|
0
|
|
|
|
|
0
|
for my $i (reverse(0 .. $#{$self->[1]})) { |
|
0
|
|
|
|
|
0
|
|
921
|
|
|
|
|
|
|
|
922
|
|
|
|
|
|
|
# if processing element defined, and transform mask bit set |
923
|
0
|
0
|
0
|
|
|
0
|
if (defined($self->[1][$i]) && $self->[2] & 0x01 << $i) { |
924
|
|
|
|
|
|
|
|
925
|
|
|
|
|
|
|
# transform data |
926
|
0
|
|
|
|
|
0
|
$data = $self->[1][$i]->_trans1($data, $hash); |
927
|
|
|
|
|
|
|
|
928
|
|
|
|
|
|
|
# clip output values if clipping mask bit set |
929
|
0
|
0
|
|
|
|
0
|
ICC::Shared::clip_struct($data) if ($self->[3] & 0x01 << $i); |
930
|
|
|
|
|
|
|
|
931
|
|
|
|
|
|
|
} |
932
|
|
|
|
|
|
|
|
933
|
|
|
|
|
|
|
} |
934
|
|
|
|
|
|
|
|
935
|
|
|
|
|
|
|
# return |
936
|
0
|
|
|
|
|
0
|
return($data); |
937
|
|
|
|
|
|
|
|
938
|
|
|
|
|
|
|
} |
939
|
|
|
|
|
|
|
|
940
|
|
|
|
|
|
|
# transform matrix (2-D array -or- Math::Matrix object) |
941
|
|
|
|
|
|
|
# parameters: (object_reference, matrix, [hash]) |
942
|
|
|
|
|
|
|
# returns: (matrix) |
943
|
|
|
|
|
|
|
sub _trans2 { |
944
|
|
|
|
|
|
|
|
945
|
|
|
|
|
|
|
# get parameters |
946
|
0
|
|
|
0
|
|
0
|
my ($self, $data, $hash) = @_; |
947
|
|
|
|
|
|
|
|
948
|
|
|
|
|
|
|
# for each processing element (note: sequence is from the last element to the first) |
949
|
0
|
|
|
|
|
0
|
for my $i (reverse(0 .. $#{$self->[1]})) { |
|
0
|
|
|
|
|
0
|
|
950
|
|
|
|
|
|
|
|
951
|
|
|
|
|
|
|
# if processing element defined, and transform mask bit set |
952
|
0
|
0
|
0
|
|
|
0
|
if (defined($self->[1][$i]) && $self->[2] & 0x01 << $i) { |
953
|
|
|
|
|
|
|
|
954
|
|
|
|
|
|
|
# transform data |
955
|
0
|
|
|
|
|
0
|
$data = $self->[1][$i]->_trans2($data, $hash); |
956
|
|
|
|
|
|
|
|
957
|
|
|
|
|
|
|
# clip output values if clipping mask bit set |
958
|
0
|
0
|
|
|
|
0
|
ICC::Shared::clip_struct($data) if ($self->[3] & 0x01 << $i); |
959
|
|
|
|
|
|
|
|
960
|
|
|
|
|
|
|
} |
961
|
|
|
|
|
|
|
|
962
|
|
|
|
|
|
|
} |
963
|
|
|
|
|
|
|
|
964
|
|
|
|
|
|
|
# return |
965
|
0
|
|
|
|
|
0
|
return($data); |
966
|
|
|
|
|
|
|
|
967
|
|
|
|
|
|
|
} |
968
|
|
|
|
|
|
|
|
969
|
|
|
|
|
|
|
# transform structure |
970
|
|
|
|
|
|
|
# parameters: (object_reference, structure, [hash]) |
971
|
|
|
|
|
|
|
# returns: (structure) |
972
|
|
|
|
|
|
|
sub _trans3 { |
973
|
|
|
|
|
|
|
|
974
|
|
|
|
|
|
|
# get parameters |
975
|
0
|
|
|
0
|
|
0
|
my ($self, $in, $hash) = @_; |
976
|
|
|
|
|
|
|
|
977
|
|
|
|
|
|
|
# transform the array structure |
978
|
0
|
|
|
|
|
0
|
_crawl($self, $in, my $out = [], $hash); |
979
|
|
|
|
|
|
|
|
980
|
|
|
|
|
|
|
# return |
981
|
0
|
|
|
|
|
0
|
return($out); |
982
|
|
|
|
|
|
|
|
983
|
|
|
|
|
|
|
} |
984
|
|
|
|
|
|
|
|
985
|
|
|
|
|
|
|
# recursive transform |
986
|
|
|
|
|
|
|
# array structure is traversed until scalar arrays are found and transformed |
987
|
|
|
|
|
|
|
# parameters: (ref_to_object, input_array_reference, output_array_reference, hash) |
988
|
|
|
|
|
|
|
sub _crawl { |
989
|
|
|
|
|
|
|
|
990
|
|
|
|
|
|
|
# get parameters |
991
|
0
|
|
|
0
|
|
0
|
my ($self, $in, $out, $hash) = @_; |
992
|
|
|
|
|
|
|
|
993
|
|
|
|
|
|
|
# if input is a vector (reference to a scalar array) |
994
|
0
|
0
|
|
|
|
0
|
if (@{$in} == grep {! ref()} @{$in}) { |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
995
|
|
|
|
|
|
|
|
996
|
|
|
|
|
|
|
# transform input vector and copy to output |
997
|
0
|
|
|
|
|
0
|
@{$out} = @{_trans1($self, $in, $hash)}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
998
|
|
|
|
|
|
|
|
999
|
|
|
|
|
|
|
} else { |
1000
|
|
|
|
|
|
|
|
1001
|
|
|
|
|
|
|
# for each input element |
1002
|
0
|
|
|
|
|
0
|
for my $i (0 .. $#{$in}) { |
|
0
|
|
|
|
|
0
|
|
1003
|
|
|
|
|
|
|
|
1004
|
|
|
|
|
|
|
# if an array reference |
1005
|
0
|
0
|
|
|
|
0
|
if (ref($in->[$i]) eq 'ARRAY') { |
1006
|
|
|
|
|
|
|
|
1007
|
|
|
|
|
|
|
# transform next level |
1008
|
0
|
|
|
|
|
0
|
_crawl($self, $in->[$i], $out->[$i] = [], $hash); |
1009
|
|
|
|
|
|
|
|
1010
|
|
|
|
|
|
|
} else { |
1011
|
|
|
|
|
|
|
|
1012
|
|
|
|
|
|
|
# error |
1013
|
0
|
|
|
|
|
0
|
croak('invalid transform input'); |
1014
|
|
|
|
|
|
|
|
1015
|
|
|
|
|
|
|
} |
1016
|
|
|
|
|
|
|
|
1017
|
|
|
|
|
|
|
} |
1018
|
|
|
|
|
|
|
|
1019
|
|
|
|
|
|
|
} |
1020
|
|
|
|
|
|
|
|
1021
|
|
|
|
|
|
|
} |
1022
|
|
|
|
|
|
|
|
1023
|
|
|
|
|
|
|
# check object structure |
1024
|
|
|
|
|
|
|
# parameter: (ref_to_object) |
1025
|
|
|
|
|
|
|
# returns: (number_input_channels, number_output_channels) |
1026
|
|
|
|
|
|
|
sub _check { |
1027
|
|
|
|
|
|
|
|
1028
|
|
|
|
|
|
|
# get object reference |
1029
|
1
|
|
|
1
|
|
2
|
my $self = shift(); |
1030
|
|
|
|
|
|
|
|
1031
|
|
|
|
|
|
|
# local variables |
1032
|
1
|
|
|
|
|
2
|
my (@class, $ci, $co); |
1033
|
|
|
|
|
|
|
|
1034
|
|
|
|
|
|
|
# make object class array |
1035
|
1
|
|
|
|
|
4
|
@class = qw(ICC::Profile::cvst ICC::Profile::matf ICC::Profile::cvst ICC::Profile::clut ICC::Profile::cvst); |
1036
|
|
|
|
|
|
|
|
1037
|
|
|
|
|
|
|
# verify number of processing elements |
1038
|
1
|
50
|
|
|
|
2
|
($#{$self->[1]} <= 4) or croak('\'mAB_\' object has too many processing elements'); |
|
1
|
|
|
|
|
21
|
|
1039
|
|
|
|
|
|
|
|
1040
|
|
|
|
|
|
|
# for each processing element (note: sequence is from the last element to the first) |
1041
|
1
|
|
|
|
|
3
|
for my $i (reverse(0 .. $#{$self->[1]})) { |
|
1
|
|
|
|
|
4
|
|
1042
|
|
|
|
|
|
|
|
1043
|
|
|
|
|
|
|
# if element is defined (matrix and M-curves to may be undefined) |
1044
|
5
|
50
|
|
|
|
16
|
if (defined($self->[1][$i])) { |
1045
|
|
|
|
|
|
|
|
1046
|
|
|
|
|
|
|
# verify element has correct class |
1047
|
5
|
50
|
|
|
|
13
|
(ref($self->[1][$i]) eq $class[$i]) or croak("'mAB_' processing element $i has wrong class"); |
1048
|
|
|
|
|
|
|
|
1049
|
|
|
|
|
|
|
# if element has 'cin' method |
1050
|
5
|
50
|
|
|
|
45
|
if ($self->[1][$i]->can('cin')) { |
1051
|
|
|
|
|
|
|
|
1052
|
|
|
|
|
|
|
# if number of input channels is undefined |
1053
|
5
|
100
|
|
|
|
11
|
if (! defined($ci)) { |
1054
|
|
|
|
|
|
|
|
1055
|
|
|
|
|
|
|
# set number of input channels |
1056
|
1
|
|
|
|
|
6
|
$ci = $self->[1][$i]->cin(); |
1057
|
|
|
|
|
|
|
|
1058
|
|
|
|
|
|
|
} |
1059
|
|
|
|
|
|
|
|
1060
|
|
|
|
|
|
|
# if number of output channels is defined |
1061
|
5
|
100
|
|
|
|
10
|
if (defined($co)) { |
1062
|
|
|
|
|
|
|
|
1063
|
|
|
|
|
|
|
# verify input channels of this element match output channels of previous element |
1064
|
4
|
50
|
|
|
|
14
|
($self->[1][$i]->cin() == $co) or croak("'mAB_' processing element $i has wrong number of channels"); |
1065
|
|
|
|
|
|
|
|
1066
|
|
|
|
|
|
|
} |
1067
|
|
|
|
|
|
|
|
1068
|
|
|
|
|
|
|
} |
1069
|
|
|
|
|
|
|
|
1070
|
|
|
|
|
|
|
# if element has 'cout' method |
1071
|
5
|
50
|
|
|
|
22
|
if ($self->[1][$i]->can('cout')) { |
1072
|
|
|
|
|
|
|
|
1073
|
|
|
|
|
|
|
# set number of output channels |
1074
|
5
|
|
|
|
|
13
|
$co = $self->[1][$i]->cout(); |
1075
|
|
|
|
|
|
|
|
1076
|
|
|
|
|
|
|
} |
1077
|
|
|
|
|
|
|
|
1078
|
|
|
|
|
|
|
} |
1079
|
|
|
|
|
|
|
|
1080
|
|
|
|
|
|
|
} |
1081
|
|
|
|
|
|
|
|
1082
|
|
|
|
|
|
|
# verify B-curves are defined |
1083
|
1
|
50
|
|
|
|
6
|
(defined($self->[1][0])) or croak('B-curves are required'); |
1084
|
|
|
|
|
|
|
|
1085
|
|
|
|
|
|
|
# verify matrix and M-curves are both defined, or neither |
1086
|
1
|
50
|
25
|
|
|
10
|
(defined($self->[1][1]) xor defined($self->[1][2])) && croak('matrix and M-curves must both be defined, or neither'); |
1087
|
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
|
# verify CLUT and A-curves are both defined, or neither |
1089
|
1
|
50
|
25
|
|
|
7
|
(defined($self->[1][3]) xor defined($self->[1][4])) && croak('CLUT and A-curves must both be defined, or neither'); |
1090
|
|
|
|
|
|
|
|
1091
|
|
|
|
|
|
|
# if matrix defined |
1092
|
1
|
50
|
|
|
|
4
|
if (defined($self->[1][1])) { |
1093
|
|
|
|
|
|
|
|
1094
|
|
|
|
|
|
|
# verify object has 3 output channels |
1095
|
1
|
50
|
|
|
|
3
|
($co == 3) or croak("matrix processing element not permitted with $co output channels"); |
1096
|
|
|
|
|
|
|
|
1097
|
|
|
|
|
|
|
# verify matrix size (3x3) |
1098
|
1
|
50
|
33
|
|
|
4
|
($self->[1][1]->cin() == 3 && $self->[1][1]->cout() == 3) or croak('matrix processing element matrix wrong size'); |
1099
|
|
|
|
|
|
|
|
1100
|
|
|
|
|
|
|
# verify offset size (undefined, 0 or 3) |
1101
|
1
|
50
|
33
|
|
|
4
|
(! defined($self->[1][1][2]) || @{$self->[1][1][2]} == 0 || @{$self->[1][1][2]} == 3) or croak('matrix processing element offset wrong size'); |
|
1
|
|
33
|
|
|
6
|
|
|
1
|
|
|
|
|
4
|
|
1102
|
|
|
|
|
|
|
|
1103
|
|
|
|
|
|
|
} |
1104
|
|
|
|
|
|
|
|
1105
|
|
|
|
|
|
|
# return |
1106
|
1
|
|
|
|
|
5
|
return($ci, $co); |
1107
|
|
|
|
|
|
|
|
1108
|
|
|
|
|
|
|
} |
1109
|
|
|
|
|
|
|
|
1110
|
|
|
|
|
|
|
# set M-curves, matrix, and B-curves |
1111
|
|
|
|
|
|
|
# equivalent to a matrix-based display profile |
1112
|
|
|
|
|
|
|
# parameters: (ref_to_object, ref_to_profile_object) |
1113
|
|
|
|
|
|
|
sub _newICCmatrix { |
1114
|
|
|
|
|
|
|
|
1115
|
|
|
|
|
|
|
# get parameters |
1116
|
0
|
|
|
0
|
|
0
|
my ($self, $disp) = @_; |
1117
|
|
|
|
|
|
|
|
1118
|
|
|
|
|
|
|
# local variables |
1119
|
0
|
|
|
|
|
0
|
my (@XYZ, @TRC, $wtpt, $bkpt, $id, $mat); |
1120
|
|
|
|
|
|
|
|
1121
|
|
|
|
|
|
|
# verify an RGB/XYZ display profile |
1122
|
0
|
0
|
0
|
|
|
0
|
(UNIVERSAL::isa($disp, 'ICC::Profile') && $disp->profile_header->[3] eq 'mntr' && $disp->profile_header->[4] eq 'RGB ' && $disp->profile_header->[5] eq 'XYZ ') or croak('not an RGB-XYZ display profile'); |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
1123
|
|
|
|
|
|
|
|
1124
|
|
|
|
|
|
|
# get primary tags |
1125
|
0
|
|
|
|
|
0
|
@XYZ = $disp->tag(qw(rXYZ gXYZ bXYZ)); |
1126
|
|
|
|
|
|
|
|
1127
|
|
|
|
|
|
|
# get TRC tags |
1128
|
0
|
|
|
|
|
0
|
@TRC = $disp->tag(qw(rTRC gTRC bTRC)); |
1129
|
|
|
|
|
|
|
|
1130
|
|
|
|
|
|
|
# verify a matrix profile |
1131
|
0
|
0
|
0
|
|
|
0
|
(@XYZ == 3 && @TRC == 3) or croak('not a matrix profile'); |
1132
|
|
|
|
|
|
|
|
1133
|
|
|
|
|
|
|
# set input colorspace |
1134
|
0
|
|
|
|
|
0
|
$self->[0]{'input_cs'} = 'RGB '; |
1135
|
|
|
|
|
|
|
|
1136
|
|
|
|
|
|
|
# set output colorspace |
1137
|
0
|
|
|
|
|
0
|
$self->[0]{'output_cs'} = 'XYZ '; |
1138
|
|
|
|
|
|
|
|
1139
|
|
|
|
|
|
|
# set PCS encoding |
1140
|
0
|
|
|
|
|
0
|
$self->[0]{'pcs_encoding'} = 7; |
1141
|
|
|
|
|
|
|
|
1142
|
|
|
|
|
|
|
# get white point tag |
1143
|
0
|
|
|
|
|
0
|
$wtpt = $disp->tag('wtpt'); |
1144
|
|
|
|
|
|
|
|
1145
|
|
|
|
|
|
|
# set white point value |
1146
|
0
|
0
|
|
|
|
0
|
$self->[0]{'wtpt'} = [@{$wtpt->XYZ}] if (defined($wtpt)); |
|
0
|
|
|
|
|
0
|
|
1147
|
|
|
|
|
|
|
|
1148
|
|
|
|
|
|
|
# get black point tag |
1149
|
0
|
|
|
|
|
0
|
$bkpt = $disp->tag('bkpt'); |
1150
|
|
|
|
|
|
|
|
1151
|
|
|
|
|
|
|
# set black point value |
1152
|
0
|
0
|
|
|
|
0
|
$self->[0]{'bkpt'} = [@{$bkpt->XYZ}] if (defined($bkpt)); |
|
0
|
|
|
|
|
0
|
|
1153
|
|
|
|
|
|
|
|
1154
|
|
|
|
|
|
|
# make identity curve |
1155
|
0
|
|
|
|
|
0
|
$id = ICC::Profile::curv->new(); |
1156
|
|
|
|
|
|
|
|
1157
|
|
|
|
|
|
|
# make Math::Matrix object from primary tags |
1158
|
0
|
|
|
|
|
0
|
$mat = Math::Matrix->new(map {$_->XYZ()} @XYZ)->transpose->multiply_scalar(32768/65535); |
|
0
|
|
|
|
|
0
|
|
1159
|
|
|
|
|
|
|
|
1160
|
|
|
|
|
|
|
# set B-curves |
1161
|
0
|
|
|
|
|
0
|
$self->[1][0] = ICC::Profile::cvst->new([$id, $id, $id]); |
1162
|
|
|
|
|
|
|
|
1163
|
|
|
|
|
|
|
# set matrix |
1164
|
0
|
|
|
|
|
0
|
$self->[1][1] = ICC::Profile::matf->new({'matrix' => $mat}); |
1165
|
|
|
|
|
|
|
|
1166
|
|
|
|
|
|
|
# set M-curves |
1167
|
0
|
|
|
|
|
0
|
$self->[1][2] = ICC::Profile::cvst->new(Storable::dclone(\@TRC)); |
1168
|
|
|
|
|
|
|
|
1169
|
|
|
|
|
|
|
# set transform mask |
1170
|
0
|
|
|
|
|
0
|
$self->[2] = 0x07; |
1171
|
|
|
|
|
|
|
|
1172
|
|
|
|
|
|
|
} |
1173
|
|
|
|
|
|
|
|
1174
|
|
|
|
|
|
|
# make new mAB_ tag from attribute hash |
1175
|
|
|
|
|
|
|
# hash may contain pointers to B-curves, matrix, M-curves, CLUT, or A-curves |
1176
|
|
|
|
|
|
|
# keys are: ('b_curves', 'matrix', 'm_curves', 'clut', 'a_curves') |
1177
|
|
|
|
|
|
|
# tag elements not specified in the hash are left empty |
1178
|
|
|
|
|
|
|
# parameters: (ref_to_object, ref_to_attribute_hash) |
1179
|
|
|
|
|
|
|
sub _new_from_hash { |
1180
|
|
|
|
|
|
|
|
1181
|
|
|
|
|
|
|
# get parameters |
1182
|
0
|
|
|
0
|
|
0
|
my ($self, $hash) = @_; |
1183
|
|
|
|
|
|
|
|
1184
|
|
|
|
|
|
|
# set attribute list (key => [reference_type, array_index]) |
1185
|
0
|
|
|
|
|
0
|
my %list = ('b_curves' => ['ICC::Profile::cvst', 0], 'matrix' => ['ICC::Profile::matf', 1], 'm_curves' => ['ICC::Profile::cvst', 2], 'clut' => ['ICC::Profile::clut', 3], 'a_curves' => ['ICC::Profile::cvst', 4]); |
1186
|
|
|
|
|
|
|
|
1187
|
|
|
|
|
|
|
# for each attribute |
1188
|
0
|
|
|
|
|
0
|
for my $attr (keys(%{$hash})) { |
|
0
|
|
|
|
|
0
|
|
1189
|
|
|
|
|
|
|
|
1190
|
|
|
|
|
|
|
# if value defined |
1191
|
0
|
0
|
|
|
|
0
|
if (defined($hash->{$attr})) { |
1192
|
|
|
|
|
|
|
|
1193
|
|
|
|
|
|
|
# if correct reference type |
1194
|
0
|
0
|
|
|
|
0
|
if (ref($hash->{$attr}) eq $list{$attr}[0]) { |
1195
|
|
|
|
|
|
|
|
1196
|
|
|
|
|
|
|
# set tag element |
1197
|
0
|
|
|
|
|
0
|
$self->[1][$list{$attr}[1]] = $hash->{$attr}; |
1198
|
|
|
|
|
|
|
|
1199
|
|
|
|
|
|
|
# set transform mask bit |
1200
|
0
|
|
|
|
|
0
|
$self->[2] |= (0x01 << $list{$attr}[1]); |
1201
|
|
|
|
|
|
|
|
1202
|
|
|
|
|
|
|
} else { |
1203
|
|
|
|
|
|
|
|
1204
|
|
|
|
|
|
|
# error |
1205
|
0
|
|
|
|
|
0
|
croak("wrong object type for $attr key"); |
1206
|
|
|
|
|
|
|
|
1207
|
|
|
|
|
|
|
} |
1208
|
|
|
|
|
|
|
|
1209
|
|
|
|
|
|
|
} |
1210
|
|
|
|
|
|
|
|
1211
|
|
|
|
|
|
|
} |
1212
|
|
|
|
|
|
|
|
1213
|
|
|
|
|
|
|
} |
1214
|
|
|
|
|
|
|
|
1215
|
|
|
|
|
|
|
# read mAB_ tag from ICC profile |
1216
|
|
|
|
|
|
|
# parameters: (ref_to_object, ref_to_parent_object, file_handle, ref_to_tag_table_entry) |
1217
|
|
|
|
|
|
|
sub _readICCmAB_ { |
1218
|
|
|
|
|
|
|
|
1219
|
|
|
|
|
|
|
# get parameters |
1220
|
1
|
|
|
1
|
|
3
|
my ($self, $parent, $fh, $tag) = @_; |
1221
|
|
|
|
|
|
|
|
1222
|
|
|
|
|
|
|
# local variables |
1223
|
1
|
|
|
|
|
3
|
my ($buf, @mft, $pel, $mark, @mat, $bytes, $gsa); |
1224
|
|
|
|
|
|
|
|
1225
|
|
|
|
|
|
|
# set tag signature |
1226
|
1
|
|
|
|
|
2
|
$self->[0]{'signature'} = $tag->[0]; |
1227
|
|
|
|
|
|
|
|
1228
|
|
|
|
|
|
|
# set input colorspace |
1229
|
1
|
|
|
|
|
3
|
$self->[0]{'input_cs'} = $parent->[1][4]; |
1230
|
|
|
|
|
|
|
|
1231
|
|
|
|
|
|
|
# set output colorspace |
1232
|
1
|
|
|
|
|
3
|
$self->[0]{'output_cs'} = $parent->[1][5]; |
1233
|
|
|
|
|
|
|
|
1234
|
|
|
|
|
|
|
# seek start of tag |
1235
|
1
|
|
|
|
|
13
|
seek($fh, $tag->[1], 0); |
1236
|
|
|
|
|
|
|
|
1237
|
|
|
|
|
|
|
# read tag header |
1238
|
1
|
|
|
|
|
11
|
read($fh, $buf, 32); |
1239
|
|
|
|
|
|
|
|
1240
|
|
|
|
|
|
|
# unpack header |
1241
|
1
|
|
|
|
|
7
|
@mft = unpack('a4 x4 C2 x2 N5', $buf); |
1242
|
|
|
|
|
|
|
|
1243
|
|
|
|
|
|
|
# verify tag signature |
1244
|
1
|
50
|
|
|
|
4
|
($mft[0] eq 'mAB ') or croak('wrong tag type'); |
1245
|
|
|
|
|
|
|
|
1246
|
|
|
|
|
|
|
# verify number input channels (1 to 15) |
1247
|
1
|
50
|
33
|
|
|
9
|
($mft[1] > 0 && $mft[1] < 16) or croak('unsupported number of input channels'); |
1248
|
|
|
|
|
|
|
|
1249
|
|
|
|
|
|
|
# verify number output channels (1 to 15) |
1250
|
1
|
50
|
33
|
|
|
8
|
($mft[2] > 0 && $mft[2] < 16) or croak('unsupported number of output channels'); |
1251
|
|
|
|
|
|
|
|
1252
|
|
|
|
|
|
|
# if B-curves are defined |
1253
|
1
|
50
|
|
|
|
3
|
if ($mft[3]) { |
1254
|
|
|
|
|
|
|
|
1255
|
|
|
|
|
|
|
# make 'cvst' object for B-curves |
1256
|
1
|
|
|
|
|
8
|
$pel = ICC::Profile::cvst->new(); |
1257
|
|
|
|
|
|
|
|
1258
|
|
|
|
|
|
|
# set file pointer to start of first B-curve |
1259
|
1
|
|
|
|
|
3
|
$mark = $tag->[1] + $mft[3]; |
1260
|
|
|
|
|
|
|
|
1261
|
|
|
|
|
|
|
# for each output channel |
1262
|
1
|
|
|
|
|
3
|
for my $i (0 .. $mft[2] - 1) { |
1263
|
|
|
|
|
|
|
|
1264
|
|
|
|
|
|
|
# adjust file pointer to 4-byte boundary |
1265
|
3
|
|
|
|
|
7
|
$mark += (-$mark % 4); |
1266
|
|
|
|
|
|
|
|
1267
|
|
|
|
|
|
|
# seek to start of curve |
1268
|
3
|
|
|
|
|
30
|
seek($fh, $mark, 0); |
1269
|
|
|
|
|
|
|
|
1270
|
|
|
|
|
|
|
# read curve type |
1271
|
3
|
|
|
|
|
25
|
read($fh, $buf, 4); |
1272
|
|
|
|
|
|
|
|
1273
|
|
|
|
|
|
|
# if 'curv' type |
1274
|
3
|
50
|
|
|
|
14
|
if ($buf eq 'curv') { |
|
|
50
|
|
|
|
|
|
1275
|
|
|
|
|
|
|
|
1276
|
|
|
|
|
|
|
# parse 'curv' object |
1277
|
0
|
|
|
|
|
0
|
$pel->[1][$i] = ICC::Profile::curv->new_fh($self, $fh, ['cvst', $mark, 0, 0]); |
1278
|
|
|
|
|
|
|
|
1279
|
|
|
|
|
|
|
} elsif ($buf eq 'para') { |
1280
|
|
|
|
|
|
|
|
1281
|
|
|
|
|
|
|
# parse 'para' object |
1282
|
3
|
|
|
|
|
15
|
$pel->[1][$i] = ICC::Profile::para->new_fh($self, $fh, ['cvst', $mark, 0, 0]); |
1283
|
|
|
|
|
|
|
|
1284
|
|
|
|
|
|
|
} else { |
1285
|
|
|
|
|
|
|
|
1286
|
|
|
|
|
|
|
# error |
1287
|
0
|
|
|
|
|
0
|
croak('unsupported curve type or invalid tag structure'); |
1288
|
|
|
|
|
|
|
|
1289
|
|
|
|
|
|
|
} |
1290
|
|
|
|
|
|
|
|
1291
|
|
|
|
|
|
|
# mark current file pointer location |
1292
|
3
|
|
|
|
|
10
|
$mark = tell($fh); |
1293
|
|
|
|
|
|
|
|
1294
|
|
|
|
|
|
|
} |
1295
|
|
|
|
|
|
|
|
1296
|
|
|
|
|
|
|
# set signature |
1297
|
1
|
|
|
|
|
3
|
$pel->[0]{'signature'} = 'mAB_'; |
1298
|
|
|
|
|
|
|
|
1299
|
|
|
|
|
|
|
# add processing element |
1300
|
1
|
|
|
|
|
2
|
$self->[1][0] = $pel; |
1301
|
|
|
|
|
|
|
|
1302
|
|
|
|
|
|
|
# set transform mask |
1303
|
1
|
|
|
|
|
2
|
$self->[2] |= 0x01; |
1304
|
|
|
|
|
|
|
|
1305
|
|
|
|
|
|
|
} |
1306
|
|
|
|
|
|
|
|
1307
|
|
|
|
|
|
|
# if matrix is defined |
1308
|
1
|
50
|
|
|
|
3
|
if ($mft[4]) { |
1309
|
|
|
|
|
|
|
|
1310
|
|
|
|
|
|
|
# make 'matf' object for matrix |
1311
|
1
|
|
|
|
|
8
|
$pel = ICC::Profile::matf->new(); |
1312
|
|
|
|
|
|
|
|
1313
|
|
|
|
|
|
|
# seek to start of matrix |
1314
|
1
|
|
|
|
|
12
|
seek($fh, $tag->[1] + $mft[4], 0); |
1315
|
|
|
|
|
|
|
|
1316
|
|
|
|
|
|
|
# read matrix |
1317
|
1
|
|
|
|
|
7
|
$pel->_read_matf($fh, 3, 3, 1, 2); |
1318
|
|
|
|
|
|
|
|
1319
|
|
|
|
|
|
|
# set signature |
1320
|
1
|
|
|
|
|
3
|
$pel->[0]{'signature'} = 'mAB_'; |
1321
|
|
|
|
|
|
|
|
1322
|
|
|
|
|
|
|
# add processing element |
1323
|
1
|
|
|
|
|
2
|
$self->[1][1] = $pel; |
1324
|
|
|
|
|
|
|
|
1325
|
|
|
|
|
|
|
# set transform mask |
1326
|
1
|
|
|
|
|
2
|
$self->[2] |= 0x02; |
1327
|
|
|
|
|
|
|
|
1328
|
|
|
|
|
|
|
} |
1329
|
|
|
|
|
|
|
|
1330
|
|
|
|
|
|
|
# if M-curves are defined |
1331
|
1
|
50
|
|
|
|
3
|
if ($mft[5]) { |
1332
|
|
|
|
|
|
|
|
1333
|
|
|
|
|
|
|
# make 'cvst' object for M-curves |
1334
|
1
|
|
|
|
|
4
|
$pel = ICC::Profile::cvst->new(); |
1335
|
|
|
|
|
|
|
|
1336
|
|
|
|
|
|
|
# set file pointer to start of first M-curve |
1337
|
1
|
|
|
|
|
3
|
$mark = $tag->[1] + $mft[5]; |
1338
|
|
|
|
|
|
|
|
1339
|
|
|
|
|
|
|
# for each output channel |
1340
|
1
|
|
|
|
|
3
|
for my $i (0 .. $mft[2] - 1) { |
1341
|
|
|
|
|
|
|
|
1342
|
|
|
|
|
|
|
# adjust file pointer to 4-byte boundary |
1343
|
3
|
|
|
|
|
5
|
$mark += (-$mark % 4); |
1344
|
|
|
|
|
|
|
|
1345
|
|
|
|
|
|
|
# seek to start of curve |
1346
|
3
|
|
|
|
|
31
|
seek($fh, $mark, 0); |
1347
|
|
|
|
|
|
|
|
1348
|
|
|
|
|
|
|
# read curve type |
1349
|
3
|
|
|
|
|
33
|
read($fh, $buf, 4); |
1350
|
|
|
|
|
|
|
|
1351
|
|
|
|
|
|
|
# if 'curv' type |
1352
|
3
|
50
|
|
|
|
11
|
if ($buf eq 'curv') { |
|
|
50
|
|
|
|
|
|
1353
|
|
|
|
|
|
|
|
1354
|
|
|
|
|
|
|
# parse 'curv' object |
1355
|
0
|
|
|
|
|
0
|
$pel->[1][$i] = ICC::Profile::curv->new_fh($self, $fh, ['cvst', $mark, 0, 0]); |
1356
|
|
|
|
|
|
|
|
1357
|
|
|
|
|
|
|
} elsif ($buf eq 'para') { |
1358
|
|
|
|
|
|
|
|
1359
|
|
|
|
|
|
|
# parse 'para' object |
1360
|
3
|
|
|
|
|
14
|
$pel->[1][$i] = ICC::Profile::para->new_fh($self, $fh, ['cvst', $mark, 0, 0]); |
1361
|
|
|
|
|
|
|
|
1362
|
|
|
|
|
|
|
} else { |
1363
|
|
|
|
|
|
|
|
1364
|
|
|
|
|
|
|
# error |
1365
|
0
|
|
|
|
|
0
|
croak('unsupported curve type or invalid tag structure'); |
1366
|
|
|
|
|
|
|
|
1367
|
|
|
|
|
|
|
} |
1368
|
|
|
|
|
|
|
|
1369
|
|
|
|
|
|
|
# mark current file pointer location |
1370
|
3
|
|
|
|
|
7
|
$mark = tell($fh); |
1371
|
|
|
|
|
|
|
|
1372
|
|
|
|
|
|
|
} |
1373
|
|
|
|
|
|
|
|
1374
|
|
|
|
|
|
|
# set signature |
1375
|
1
|
|
|
|
|
3
|
$pel->[0]{'signature'} = 'mAB_'; |
1376
|
|
|
|
|
|
|
|
1377
|
|
|
|
|
|
|
# add processing element |
1378
|
1
|
|
|
|
|
2
|
$self->[1][2] = $pel; |
1379
|
|
|
|
|
|
|
|
1380
|
|
|
|
|
|
|
# set transform mask |
1381
|
1
|
|
|
|
|
2
|
$self->[2] |= 0x04; |
1382
|
|
|
|
|
|
|
|
1383
|
|
|
|
|
|
|
} |
1384
|
|
|
|
|
|
|
|
1385
|
|
|
|
|
|
|
# if CLUT defined |
1386
|
1
|
50
|
|
|
|
4
|
if ($mft[6]) { |
1387
|
|
|
|
|
|
|
|
1388
|
|
|
|
|
|
|
# make 'clut' object for CLUT |
1389
|
1
|
|
|
|
|
7
|
$pel = ICC::Profile::clut->new(); |
1390
|
|
|
|
|
|
|
|
1391
|
|
|
|
|
|
|
# seek to start of CLUT |
1392
|
1
|
|
|
|
|
11
|
seek($fh, $tag->[1] + $mft[6], 0); |
1393
|
|
|
|
|
|
|
|
1394
|
|
|
|
|
|
|
# read header |
1395
|
1
|
|
|
|
|
10
|
read($fh, $buf, 20); |
1396
|
|
|
|
|
|
|
|
1397
|
|
|
|
|
|
|
# unpack header |
1398
|
1
|
|
|
|
|
5
|
@mat = unpack('C17', $buf); |
1399
|
|
|
|
|
|
|
|
1400
|
|
|
|
|
|
|
# get CLUT byte width |
1401
|
1
|
|
|
|
|
2
|
$bytes = pop(@mat); |
1402
|
|
|
|
|
|
|
|
1403
|
|
|
|
|
|
|
# save CLUT byte width |
1404
|
1
|
|
|
|
|
8
|
$pel->[0]{'clut_bytes'} = $bytes; |
1405
|
|
|
|
|
|
|
|
1406
|
|
|
|
|
|
|
# set number of input channels |
1407
|
1
|
|
|
|
|
2
|
$pel->[0]{'input_channels'} = $mft[1]; |
1408
|
|
|
|
|
|
|
|
1409
|
|
|
|
|
|
|
# set number of output channels |
1410
|
1
|
|
|
|
|
3
|
$pel->[0]{'output_channels'} = $mft[2]; |
1411
|
|
|
|
|
|
|
|
1412
|
|
|
|
|
|
|
# make grid size array |
1413
|
1
|
|
|
|
|
3
|
$gsa = [grep {$_} @mat]; |
|
16
|
|
|
|
|
18
|
|
1414
|
|
|
|
|
|
|
|
1415
|
|
|
|
|
|
|
# read 'clut' data |
1416
|
1
|
|
|
|
|
4
|
$pel->_read_clut($fh, $mft[2], $gsa, $bytes); |
1417
|
|
|
|
|
|
|
|
1418
|
|
|
|
|
|
|
# save grid size array |
1419
|
1
|
|
|
|
|
2
|
$pel->[2] = [@{$gsa}]; |
|
1
|
|
|
|
|
3
|
|
1420
|
|
|
|
|
|
|
|
1421
|
|
|
|
|
|
|
# set signature |
1422
|
1
|
|
|
|
|
4
|
$pel->[0]{'signature'} = 'mAB_'; |
1423
|
|
|
|
|
|
|
|
1424
|
|
|
|
|
|
|
# add processing element |
1425
|
1
|
|
|
|
|
2
|
$self->[1][3] = $pel; |
1426
|
|
|
|
|
|
|
|
1427
|
|
|
|
|
|
|
# set transform mask |
1428
|
1
|
|
|
|
|
2
|
$self->[2] |= 0x08; |
1429
|
|
|
|
|
|
|
|
1430
|
|
|
|
|
|
|
} |
1431
|
|
|
|
|
|
|
|
1432
|
|
|
|
|
|
|
# if A-curves are defined |
1433
|
1
|
50
|
|
|
|
4
|
if ($mft[7]) { |
1434
|
|
|
|
|
|
|
|
1435
|
|
|
|
|
|
|
# make 'cvst' object for A-curves |
1436
|
1
|
|
|
|
|
6
|
$pel = ICC::Profile::cvst->new(); |
1437
|
|
|
|
|
|
|
|
1438
|
|
|
|
|
|
|
# set file pointer to start of first A-curve |
1439
|
1
|
|
|
|
|
3
|
$mark = $tag->[1] + $mft[7]; |
1440
|
|
|
|
|
|
|
|
1441
|
|
|
|
|
|
|
# for each input channel |
1442
|
1
|
|
|
|
|
4
|
for my $i (0 .. $mft[1] - 1) { |
1443
|
|
|
|
|
|
|
|
1444
|
|
|
|
|
|
|
# adjust file pointer to 4-byte boundary |
1445
|
3
|
|
|
|
|
6
|
$mark += (-$mark % 4); |
1446
|
|
|
|
|
|
|
|
1447
|
|
|
|
|
|
|
# seek to start of curve |
1448
|
3
|
|
|
|
|
31
|
seek($fh, $mark, 0); |
1449
|
|
|
|
|
|
|
|
1450
|
|
|
|
|
|
|
# read curve type |
1451
|
3
|
|
|
|
|
25
|
read($fh, $buf, 4); |
1452
|
|
|
|
|
|
|
|
1453
|
|
|
|
|
|
|
# if 'curv' type |
1454
|
3
|
50
|
|
|
|
11
|
if ($buf eq 'curv') { |
|
|
0
|
|
|
|
|
|
1455
|
|
|
|
|
|
|
|
1456
|
|
|
|
|
|
|
# parse 'curv' object |
1457
|
3
|
|
|
|
|
19
|
$pel->[1][$i] = ICC::Profile::curv->new_fh($self, $fh, ['cvst', $mark, 0, 0]); |
1458
|
|
|
|
|
|
|
|
1459
|
|
|
|
|
|
|
} elsif ($buf eq 'para') { |
1460
|
|
|
|
|
|
|
|
1461
|
|
|
|
|
|
|
# parse 'para' object |
1462
|
0
|
|
|
|
|
0
|
$pel->[1][$i] = ICC::Profile::para->new_fh($self, $fh, ['cvst', $mark, 0, 0]); |
1463
|
|
|
|
|
|
|
|
1464
|
|
|
|
|
|
|
} else { |
1465
|
|
|
|
|
|
|
|
1466
|
|
|
|
|
|
|
# error |
1467
|
0
|
|
|
|
|
0
|
croak('unsupported curve type or invalid tag structure'); |
1468
|
|
|
|
|
|
|
|
1469
|
|
|
|
|
|
|
} |
1470
|
|
|
|
|
|
|
|
1471
|
|
|
|
|
|
|
# mark current file pointer location |
1472
|
3
|
|
|
|
|
9
|
$mark = tell($fh); |
1473
|
|
|
|
|
|
|
|
1474
|
|
|
|
|
|
|
} |
1475
|
|
|
|
|
|
|
|
1476
|
|
|
|
|
|
|
# set signature |
1477
|
1
|
|
|
|
|
3
|
$pel->[0]{'signature'} = 'mAB_'; |
1478
|
|
|
|
|
|
|
|
1479
|
|
|
|
|
|
|
# add processing element |
1480
|
1
|
|
|
|
|
3
|
$self->[1][4] = $pel; |
1481
|
|
|
|
|
|
|
|
1482
|
|
|
|
|
|
|
# set transform mask |
1483
|
1
|
|
|
|
|
4
|
$self->[2] |= 0x10; |
1484
|
|
|
|
|
|
|
|
1485
|
|
|
|
|
|
|
} |
1486
|
|
|
|
|
|
|
|
1487
|
|
|
|
|
|
|
} |
1488
|
|
|
|
|
|
|
|
1489
|
|
|
|
|
|
|
# write mAB_ tag to ICC profile |
1490
|
|
|
|
|
|
|
# parameters: (ref_to_object, ref_to_parent_object, file_handle, ref_to_tag_table_entry) |
1491
|
|
|
|
|
|
|
sub _writeICCmAB_ { |
1492
|
|
|
|
|
|
|
|
1493
|
|
|
|
|
|
|
# get parameters |
1494
|
1
|
|
|
1
|
|
4
|
my ($self, $parent, $fh, $tag) = @_; |
1495
|
|
|
|
|
|
|
|
1496
|
|
|
|
|
|
|
# local variables |
1497
|
1
|
|
|
|
|
4
|
my (@mft, $offset, @mat, $bytes, $size); |
1498
|
|
|
|
|
|
|
|
1499
|
|
|
|
|
|
|
# set tag type |
1500
|
1
|
|
|
|
|
4
|
$mft[0] = 'mAB '; |
1501
|
|
|
|
|
|
|
|
1502
|
|
|
|
|
|
|
# check object structure |
1503
|
1
|
|
|
|
|
5
|
@mft[1, 2] = _check($self); |
1504
|
|
|
|
|
|
|
|
1505
|
|
|
|
|
|
|
# initialize offset |
1506
|
1
|
|
|
|
|
2
|
$offset = 32; |
1507
|
|
|
|
|
|
|
|
1508
|
|
|
|
|
|
|
# set offset to B-curves |
1509
|
1
|
|
|
|
|
2
|
$mft[3] = 32; |
1510
|
|
|
|
|
|
|
|
1511
|
|
|
|
|
|
|
# if B-curves defined |
1512
|
1
|
50
|
|
|
|
4
|
if (defined($self->[1][0])) { |
1513
|
|
|
|
|
|
|
|
1514
|
|
|
|
|
|
|
# for each B-curve |
1515
|
1
|
|
|
|
|
2
|
for my $curve (@{$self->[1][0]->array()}) { |
|
1
|
|
|
|
|
3
|
|
1516
|
|
|
|
|
|
|
|
1517
|
|
|
|
|
|
|
# add curve size |
1518
|
3
|
|
|
|
|
6
|
$offset += $curve->size; |
1519
|
|
|
|
|
|
|
|
1520
|
|
|
|
|
|
|
# pad to 4-bytes |
1521
|
3
|
|
|
|
|
6
|
$offset += (-$offset % 4); |
1522
|
|
|
|
|
|
|
|
1523
|
|
|
|
|
|
|
} |
1524
|
|
|
|
|
|
|
|
1525
|
|
|
|
|
|
|
} else { |
1526
|
|
|
|
|
|
|
|
1527
|
|
|
|
|
|
|
# error |
1528
|
0
|
|
|
|
|
0
|
croak('B-curves are required'); |
1529
|
|
|
|
|
|
|
|
1530
|
|
|
|
|
|
|
} |
1531
|
|
|
|
|
|
|
|
1532
|
|
|
|
|
|
|
# if matrix is defined |
1533
|
1
|
50
|
|
|
|
4
|
if (defined($self->[1][1])) { |
1534
|
|
|
|
|
|
|
|
1535
|
|
|
|
|
|
|
# verify output channels |
1536
|
1
|
50
|
|
|
|
3
|
($mft[2] == 3) or croak('3 output channels required for matrix'); |
1537
|
|
|
|
|
|
|
|
1538
|
|
|
|
|
|
|
# set offset |
1539
|
1
|
|
|
|
|
2
|
$mft[4] = $offset; |
1540
|
|
|
|
|
|
|
|
1541
|
|
|
|
|
|
|
# increment offset for matrix size |
1542
|
1
|
|
|
|
|
2
|
$offset += 48; |
1543
|
|
|
|
|
|
|
|
1544
|
|
|
|
|
|
|
} else { |
1545
|
|
|
|
|
|
|
|
1546
|
|
|
|
|
|
|
# set offset |
1547
|
0
|
|
|
|
|
0
|
$mft[4] = 0; |
1548
|
|
|
|
|
|
|
|
1549
|
|
|
|
|
|
|
} |
1550
|
|
|
|
|
|
|
|
1551
|
|
|
|
|
|
|
# if M-curves defined |
1552
|
1
|
50
|
|
|
|
3
|
if (defined($self->[1][2])) { |
1553
|
|
|
|
|
|
|
|
1554
|
|
|
|
|
|
|
# verify output channels |
1555
|
1
|
50
|
|
|
|
11
|
($mft[2] == 3) or croak('3 output channels required for M-curves'); |
1556
|
|
|
|
|
|
|
|
1557
|
|
|
|
|
|
|
# set offset |
1558
|
1
|
|
|
|
|
3
|
$mft[5] = $offset; |
1559
|
|
|
|
|
|
|
|
1560
|
|
|
|
|
|
|
# for each M-curve |
1561
|
1
|
|
|
|
|
3
|
for my $curve (@{$self->[1][2]->array()}) { |
|
1
|
|
|
|
|
4
|
|
1562
|
|
|
|
|
|
|
|
1563
|
|
|
|
|
|
|
# add curve size |
1564
|
3
|
|
|
|
|
8
|
$offset += $curve->size; |
1565
|
|
|
|
|
|
|
|
1566
|
|
|
|
|
|
|
# pad to 4-bytes |
1567
|
3
|
|
|
|
|
6
|
$offset += (-$offset % 4); |
1568
|
|
|
|
|
|
|
|
1569
|
|
|
|
|
|
|
} |
1570
|
|
|
|
|
|
|
|
1571
|
|
|
|
|
|
|
} else { |
1572
|
|
|
|
|
|
|
|
1573
|
|
|
|
|
|
|
# set offset |
1574
|
0
|
|
|
|
|
0
|
$mft[5] = 0; |
1575
|
|
|
|
|
|
|
|
1576
|
|
|
|
|
|
|
} |
1577
|
|
|
|
|
|
|
|
1578
|
|
|
|
|
|
|
# if CLUT defined |
1579
|
1
|
50
|
|
|
|
4
|
if (defined($self->[1][3])) { |
1580
|
|
|
|
|
|
|
|
1581
|
|
|
|
|
|
|
# set offset |
1582
|
1
|
|
|
|
|
10
|
$mft[6] = $offset; |
1583
|
|
|
|
|
|
|
|
1584
|
|
|
|
|
|
|
# get CLUT data size |
1585
|
1
|
|
50
|
|
|
5
|
$bytes = $self->[1][3][0]{'clut_bytes'} || 2; |
1586
|
|
|
|
|
|
|
|
1587
|
|
|
|
|
|
|
# add CLUT size to offset |
1588
|
1
|
|
|
|
|
4
|
$offset += 20 + $self->[1][3]->_clut_size($bytes); |
1589
|
|
|
|
|
|
|
|
1590
|
|
|
|
|
|
|
# pad to 4-byte boundary |
1591
|
1
|
|
|
|
|
3
|
$offset += (-$offset % 4); |
1592
|
|
|
|
|
|
|
|
1593
|
|
|
|
|
|
|
} else { |
1594
|
|
|
|
|
|
|
|
1595
|
|
|
|
|
|
|
# set offset |
1596
|
0
|
|
|
|
|
0
|
$mft[6] = 0; |
1597
|
|
|
|
|
|
|
|
1598
|
|
|
|
|
|
|
} |
1599
|
|
|
|
|
|
|
|
1600
|
|
|
|
|
|
|
# if A-curves defined |
1601
|
1
|
50
|
|
|
|
3
|
if (defined($self->[1][4])) { |
1602
|
|
|
|
|
|
|
|
1603
|
|
|
|
|
|
|
# set offset |
1604
|
1
|
|
|
|
|
3
|
$mft[7] = $offset; |
1605
|
|
|
|
|
|
|
|
1606
|
|
|
|
|
|
|
} else { |
1607
|
|
|
|
|
|
|
|
1608
|
|
|
|
|
|
|
# set offset |
1609
|
0
|
|
|
|
|
0
|
$mft[7] = 0; |
1610
|
|
|
|
|
|
|
|
1611
|
|
|
|
|
|
|
} |
1612
|
|
|
|
|
|
|
|
1613
|
|
|
|
|
|
|
# seek start of tag |
1614
|
1
|
|
|
|
|
9
|
seek($fh, $tag->[1], 0); |
1615
|
|
|
|
|
|
|
|
1616
|
|
|
|
|
|
|
# write header |
1617
|
1
|
|
|
|
|
34
|
print $fh pack('a4 x4 C2 x2 N5', @mft); |
1618
|
|
|
|
|
|
|
|
1619
|
|
|
|
|
|
|
# seek start of B-curves |
1620
|
1
|
|
|
|
|
50
|
seek($fh, $tag->[1] + $mft[3], 0); |
1621
|
|
|
|
|
|
|
|
1622
|
|
|
|
|
|
|
# for each B-curve |
1623
|
1
|
|
|
|
|
3
|
for my $curve (@{$self->[1][0]->array()}) { |
|
1
|
|
|
|
|
6
|
|
1624
|
|
|
|
|
|
|
|
1625
|
|
|
|
|
|
|
# write curve object |
1626
|
3
|
|
|
|
|
27
|
$curve->write_fh($self->[1][0], $fh, ['cvst', tell($fh), 0, 0]); |
1627
|
|
|
|
|
|
|
|
1628
|
|
|
|
|
|
|
# add padding to 4-byte boundary |
1629
|
3
|
|
|
|
|
49
|
seek($fh, (-tell($fh) % 4), 1); |
1630
|
|
|
|
|
|
|
|
1631
|
|
|
|
|
|
|
} |
1632
|
|
|
|
|
|
|
|
1633
|
|
|
|
|
|
|
# if matrix is defined |
1634
|
1
|
50
|
|
|
|
6
|
if (defined($self->[1][1])) { |
1635
|
|
|
|
|
|
|
|
1636
|
|
|
|
|
|
|
# seek start of matrix |
1637
|
1
|
|
|
|
|
7
|
seek($fh, $tag->[1] + $mft[4], 0); |
1638
|
|
|
|
|
|
|
|
1639
|
|
|
|
|
|
|
# write matrix |
1640
|
1
|
|
|
|
|
7
|
$self->[1][1]->_write_matf($fh, 1, 2); |
1641
|
|
|
|
|
|
|
|
1642
|
|
|
|
|
|
|
} |
1643
|
|
|
|
|
|
|
|
1644
|
|
|
|
|
|
|
# if M-curves are defined |
1645
|
1
|
50
|
|
|
|
4
|
if (defined($self->[1][2])) { |
1646
|
|
|
|
|
|
|
|
1647
|
|
|
|
|
|
|
# seek start of M-curves |
1648
|
1
|
|
|
|
|
18
|
seek($fh, $tag->[1] + $mft[5], 0); |
1649
|
|
|
|
|
|
|
|
1650
|
|
|
|
|
|
|
# for each M-curve |
1651
|
1
|
|
|
|
|
4
|
for my $curve (@{$self->[1][2]->array()}) { |
|
1
|
|
|
|
|
5
|
|
1652
|
|
|
|
|
|
|
|
1653
|
|
|
|
|
|
|
# write curve object |
1654
|
3
|
|
|
|
|
15
|
$curve->write_fh($self->[1][2], $fh, ['cvst', tell($fh), 0, 0]); |
1655
|
|
|
|
|
|
|
|
1656
|
|
|
|
|
|
|
# add padding to 4-byte boundary |
1657
|
3
|
|
|
|
|
45
|
seek($fh, (-tell($fh) % 4), 1); |
1658
|
|
|
|
|
|
|
|
1659
|
|
|
|
|
|
|
} |
1660
|
|
|
|
|
|
|
|
1661
|
|
|
|
|
|
|
} |
1662
|
|
|
|
|
|
|
|
1663
|
|
|
|
|
|
|
# if CLUT is defined |
1664
|
1
|
50
|
|
|
|
6
|
if (defined($self->[1][3])) { |
1665
|
|
|
|
|
|
|
|
1666
|
|
|
|
|
|
|
# for each possible input channel |
1667
|
1
|
|
|
|
|
3
|
for my $i (0 .. 15) { |
1668
|
|
|
|
|
|
|
|
1669
|
|
|
|
|
|
|
# set grid size |
1670
|
16
|
|
100
|
|
|
31
|
$mat[$i] = $self->[1][3]->gsa->[$i] || 0; |
1671
|
|
|
|
|
|
|
|
1672
|
|
|
|
|
|
|
} |
1673
|
|
|
|
|
|
|
|
1674
|
|
|
|
|
|
|
# set CLUT byte width |
1675
|
1
|
|
|
|
|
2
|
$mat[16] = $bytes; |
1676
|
|
|
|
|
|
|
|
1677
|
|
|
|
|
|
|
# seek start of CLUT |
1678
|
1
|
|
|
|
|
17
|
seek($fh, $tag->[1] + $mft[6], 0); |
1679
|
|
|
|
|
|
|
|
1680
|
|
|
|
|
|
|
# write CLUT header |
1681
|
1
|
|
|
|
|
6
|
print $fh pack('C17 x3', @mat); |
1682
|
|
|
|
|
|
|
|
1683
|
|
|
|
|
|
|
# write CLUT |
1684
|
1
|
|
|
|
|
5
|
$self->[1][3]->_write_clut($fh, $self->[1][3]->gsa(), $bytes); |
1685
|
|
|
|
|
|
|
|
1686
|
|
|
|
|
|
|
} |
1687
|
|
|
|
|
|
|
|
1688
|
|
|
|
|
|
|
# if A-curves are defined |
1689
|
1
|
50
|
|
|
|
7
|
if (defined($self->[1][4])) { |
1690
|
|
|
|
|
|
|
|
1691
|
|
|
|
|
|
|
# seek start of A-curves |
1692
|
1
|
|
|
|
|
25
|
seek($fh, $tag->[1] + $mft[7], 0); |
1693
|
|
|
|
|
|
|
|
1694
|
|
|
|
|
|
|
# for each M-curve |
1695
|
1
|
|
|
|
|
4
|
for my $curve (@{$self->[1][4]->array()}) { |
|
1
|
|
|
|
|
5
|
|
1696
|
|
|
|
|
|
|
|
1697
|
|
|
|
|
|
|
# write curve object |
1698
|
3
|
|
|
|
|
18
|
$curve->write_fh($self->[1][4], $fh, ['cvst', tell($fh), 0, 0]); |
1699
|
|
|
|
|
|
|
|
1700
|
|
|
|
|
|
|
# add padding to 4-byte boundary |
1701
|
3
|
|
|
|
|
48
|
seek($fh, (-tell($fh) % 4), 1); |
1702
|
|
|
|
|
|
|
|
1703
|
|
|
|
|
|
|
} |
1704
|
|
|
|
|
|
|
|
1705
|
|
|
|
|
|
|
} |
1706
|
|
|
|
|
|
|
|
1707
|
|
|
|
|
|
|
} |
1708
|
|
|
|
|
|
|
|
1709
|
|
|
|
|
|
|
1; |