line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Imager::Color; |
2
|
58
|
|
|
58
|
|
768
|
use 5.006; |
|
58
|
|
|
|
|
163
|
|
3
|
58
|
|
|
58
|
|
244
|
use Imager; |
|
58
|
|
|
|
|
97
|
|
|
58
|
|
|
|
|
1199
|
|
4
|
58
|
|
|
58
|
|
269
|
use strict; |
|
58
|
|
|
|
|
113
|
|
|
58
|
|
|
|
|
1241
|
|
5
|
58
|
|
|
58
|
|
276
|
use Scalar::Util (); |
|
58
|
|
|
|
|
84
|
|
|
58
|
|
|
|
|
894
|
|
6
|
58
|
|
|
58
|
|
24364
|
use POSIX (); |
|
58
|
|
|
|
|
347568
|
|
|
58
|
|
|
|
|
182906
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
our $VERSION = "1.015"; |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
# It's just a front end to the XS creation functions. |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# used in converting hsv to rgb |
13
|
|
|
|
|
|
|
my @hsv_map = |
14
|
|
|
|
|
|
|
( |
15
|
|
|
|
|
|
|
'vkm', 'nvm', 'mvk', 'mnv', 'kmv', 'vmn' |
16
|
|
|
|
|
|
|
); |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
sub _hsv_to_rgb { |
19
|
5
|
|
|
5
|
|
12
|
my ($hue, $sat, $val) = @_; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
# HSV conversions from pages 401-403 "Procedural Elements for Computer |
22
|
|
|
|
|
|
|
# Graphics", 1985, ISBN 0-07-053534-5. |
23
|
|
|
|
|
|
|
|
24
|
5
|
|
|
|
|
11
|
my @result; |
25
|
5
|
100
|
|
|
|
19
|
if ($sat <= 0) { |
26
|
1
|
|
|
|
|
6
|
return ( 255 * $val, 255 * $val, 255 * $val ); |
27
|
|
|
|
|
|
|
} |
28
|
|
|
|
|
|
|
else { |
29
|
4
|
50
|
|
|
|
16
|
$val >= 0 or $val = 0; |
30
|
4
|
50
|
|
|
|
12
|
$val <= 1 or $val = 1; |
31
|
4
|
50
|
|
|
|
13
|
$sat <= 1 or $sat = 1; |
32
|
4
|
50
|
|
|
|
12
|
$hue >= 360 and $hue %= 360; |
33
|
4
|
50
|
|
|
|
11
|
$hue < 0 and $hue += 360; |
34
|
4
|
|
|
|
|
26
|
$hue /= 60.0; |
35
|
4
|
|
|
|
|
11
|
my $i = int($hue); |
36
|
4
|
|
|
|
|
6
|
my $f = $hue - $i; |
37
|
4
|
|
|
|
|
8
|
$val *= 255; |
38
|
4
|
|
|
|
|
10
|
my $m = $val * (1.0 - $sat); |
39
|
4
|
|
|
|
|
11
|
my $n = $val * (1.0 - $sat * $f); |
40
|
4
|
|
|
|
|
11
|
my $k = $val * (1.0 - $sat * (1 - $f)); |
41
|
4
|
|
|
|
|
8
|
my $v = $val; |
42
|
4
|
|
|
|
|
22
|
my %fields = ( 'm'=>$m, 'n'=>$n, 'v'=>$v, 'k'=>$k, ); |
43
|
4
|
|
|
|
|
47
|
return @fields{split //, $hsv_map[$i]}; |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
} |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
# cache of loaded gimp files |
48
|
|
|
|
|
|
|
# each key is a filename, under each key is a hashref with the following |
49
|
|
|
|
|
|
|
# keys: |
50
|
|
|
|
|
|
|
# mod_time => last mod_time of file |
51
|
|
|
|
|
|
|
# colors => hashref name to arrayref of colors |
52
|
|
|
|
|
|
|
my %gimp_cache; |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
# palette search locations |
55
|
|
|
|
|
|
|
# this is pretty rude |
56
|
|
|
|
|
|
|
# $HOME is replaced at runtime |
57
|
|
|
|
|
|
|
my @gimp_search = |
58
|
|
|
|
|
|
|
( |
59
|
|
|
|
|
|
|
'$HOME/.gimp-1.2/palettes/Named_Colors', |
60
|
|
|
|
|
|
|
'$HOME/.gimp-1.1/palettes/Named_Colors', |
61
|
|
|
|
|
|
|
'$HOME/.gimp/palettes/Named_Colors', |
62
|
|
|
|
|
|
|
'/usr/share/gimp/1.2/palettes/Named_Colors', |
63
|
|
|
|
|
|
|
'/usr/share/gimp/1.1/palettes/Named_Colors', |
64
|
|
|
|
|
|
|
'/usr/share/gimp/palettes/Named_Colors', |
65
|
|
|
|
|
|
|
); |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
my $default_gimp_palette; |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
sub _load_gimp_palette { |
70
|
2
|
|
|
2
|
|
8
|
my ($filename) = @_; |
71
|
|
|
|
|
|
|
|
72
|
2
|
50
|
|
|
|
112
|
if (open PAL, "< $filename") { |
73
|
2
|
|
|
|
|
88
|
my $hdr = ; |
74
|
2
|
|
|
|
|
9
|
chomp $hdr; |
75
|
2
|
50
|
|
|
|
15
|
unless ($hdr =~ /GIMP Palette/) { |
76
|
0
|
|
|
|
|
0
|
close PAL; |
77
|
0
|
|
|
|
|
0
|
$Imager::ERRSTR = "$filename is not a GIMP palette file"; |
78
|
0
|
|
|
|
|
0
|
return; |
79
|
|
|
|
|
|
|
} |
80
|
2
|
|
|
|
|
6
|
my $line; |
81
|
|
|
|
|
|
|
my %pal; |
82
|
2
|
|
|
|
|
19
|
my $mod_time = (stat PAL)[9]; |
83
|
2
|
|
|
|
|
14
|
while (defined($line = )) { |
84
|
4
|
100
|
66
|
|
|
38
|
next if $line =~ /^#/ || $line =~ /^\s*$/; |
85
|
2
|
|
|
|
|
3
|
chomp $line; |
86
|
2
|
|
|
|
|
15
|
my ($r,$g, $b, $name) = split ' ', $line, 4; |
87
|
2
|
50
|
|
|
|
10
|
if ($name) { |
88
|
2
|
|
|
|
|
16
|
$name =~ s/\s*\([\d\s]+\)\s*$//; |
89
|
2
|
|
|
|
|
28
|
$pal{lc $name} = [ $r, $g, $b ]; |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
} |
92
|
2
|
|
|
|
|
51
|
close PAL; |
93
|
|
|
|
|
|
|
|
94
|
2
|
|
|
|
|
19
|
$gimp_cache{$filename} = { mod_time=>$mod_time, colors=>\%pal }; |
95
|
|
|
|
|
|
|
|
96
|
2
|
|
|
|
|
15
|
return 1; |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
else { |
99
|
0
|
|
|
|
|
0
|
$Imager::ERRSTR = "Cannot open palette file $filename: $!"; |
100
|
0
|
|
|
|
|
0
|
return; |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
sub _get_gimp_color { |
105
|
18
|
|
|
18
|
|
52
|
my %args = @_; |
106
|
|
|
|
|
|
|
|
107
|
18
|
|
|
|
|
30
|
my $filename; |
108
|
18
|
100
|
|
|
|
70
|
if ($args{palette}) { |
|
|
100
|
|
|
|
|
|
109
|
2
|
|
|
|
|
5
|
$filename = $args{palette}; |
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
elsif (defined $default_gimp_palette) { |
112
|
|
|
|
|
|
|
# don't search again and again and again ... |
113
|
8
|
50
|
33
|
|
|
26
|
if (!length $default_gimp_palette |
114
|
|
|
|
|
|
|
|| !-f $default_gimp_palette) { |
115
|
8
|
|
|
|
|
17
|
$Imager::ERRSTR = "No GIMP palette found"; |
116
|
8
|
|
|
|
|
12
|
$default_gimp_palette = ""; |
117
|
8
|
|
|
|
|
24
|
return; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
0
|
|
|
|
|
0
|
$filename = $default_gimp_palette; |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
else { |
123
|
|
|
|
|
|
|
# try to make one up - this is intended to die if tainting is |
124
|
|
|
|
|
|
|
# enabled and $ENV{HOME} is tainted. To avoid that untaint $ENV{HOME} |
125
|
|
|
|
|
|
|
# or set the palette parameter |
126
|
8
|
|
|
|
|
25
|
for my $attempt (@gimp_search) { |
127
|
48
|
|
|
|
|
92
|
my $work = $attempt; # don't modify the source array |
128
|
|
|
|
|
|
|
$work =~ /\$HOME/ && !defined $ENV{HOME} |
129
|
48
|
100
|
100
|
|
|
179
|
and next; |
130
|
45
|
|
|
|
|
120
|
$work =~ s/\$HOME/$ENV{HOME}/; |
131
|
45
|
50
|
|
|
|
425
|
if (-e $work) { |
132
|
0
|
|
|
|
|
0
|
$filename = $work; |
133
|
0
|
|
|
|
|
0
|
last; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
} |
136
|
8
|
50
|
|
|
|
33
|
if (!$filename) { |
137
|
8
|
|
|
|
|
26
|
$Imager::ERRSTR = "No GIMP palette found"; |
138
|
8
|
|
|
|
|
18
|
$default_gimp_palette = ""; |
139
|
8
|
|
|
|
|
43
|
return (); |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
0
|
|
|
|
|
0
|
$default_gimp_palette = $filename; |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
2
|
50
|
66
|
|
|
49
|
if ((!$gimp_cache{$filename} |
|
|
|
33
|
|
|
|
|
146
|
|
|
|
|
|
|
|| (stat $filename)[9] != $gimp_cache{$filename}) |
147
|
|
|
|
|
|
|
&& !_load_gimp_palette($filename)) { |
148
|
0
|
|
|
|
|
0
|
return (); |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
2
|
50
|
|
|
|
11
|
if (!$gimp_cache{$filename}{colors}{lc $args{name}}) { |
152
|
0
|
|
|
|
|
0
|
$Imager::ERRSTR = "Color '$args{name}' isn't in $filename"; |
153
|
0
|
|
|
|
|
0
|
return (); |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
|
156
|
2
|
|
|
|
|
4
|
return @{$gimp_cache{$filename}{colors}{lc $args{name}}}; |
|
2
|
|
|
|
|
21
|
|
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
my @x_search = |
160
|
|
|
|
|
|
|
( |
161
|
|
|
|
|
|
|
'/usr/share/X11/rgb.txt', # newer Xorg X11 dists use this |
162
|
|
|
|
|
|
|
'/usr/lib/X11/rgb.txt', # seems fairly standard |
163
|
|
|
|
|
|
|
'/usr/local/lib/X11/rgb.txt', # seems possible |
164
|
|
|
|
|
|
|
'/usr/X11R6/lib/X11/rgb.txt', # probably the same as the first |
165
|
|
|
|
|
|
|
'/usr/openwin/lib/rgb.txt', |
166
|
|
|
|
|
|
|
'/usr/openwin/lib/X11/rgb.txt', |
167
|
|
|
|
|
|
|
); |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
my $default_x_rgb; |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
# called by the test code to check if we can test this stuff |
172
|
|
|
|
|
|
|
sub _test_x_palettes { |
173
|
1
|
|
|
1
|
|
8296
|
@x_search; |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
# x rgb.txt cache |
177
|
|
|
|
|
|
|
# same structure as %gimp_cache |
178
|
|
|
|
|
|
|
my %x_cache; |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
sub _load_x_rgb { |
181
|
0
|
|
|
0
|
|
0
|
my ($filename) = @_; |
182
|
|
|
|
|
|
|
|
183
|
0
|
|
|
|
|
0
|
local *RGB; |
184
|
0
|
0
|
|
|
|
0
|
if (open RGB, "< $filename") { |
185
|
0
|
|
|
|
|
0
|
my $line; |
186
|
|
|
|
|
|
|
my %pal; |
187
|
0
|
|
|
|
|
0
|
my $mod_time = (stat RGB)[9]; |
188
|
0
|
|
|
|
|
0
|
while (defined($line = )) { |
189
|
|
|
|
|
|
|
# the version of rgb.txt supplied with GNU Emacs uses # for comments |
190
|
0
|
0
|
0
|
|
|
0
|
next if $line =~ /^[!#]/ || $line =~ /^\s*$/; |
191
|
0
|
|
|
|
|
0
|
chomp $line; |
192
|
0
|
|
|
|
|
0
|
my ($r,$g, $b, $name) = split ' ', $line, 4; |
193
|
0
|
0
|
|
|
|
0
|
if ($name) { |
194
|
0
|
|
|
|
|
0
|
$pal{lc $name} = [ $r, $g, $b ]; |
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
} |
197
|
0
|
|
|
|
|
0
|
close RGB; |
198
|
|
|
|
|
|
|
|
199
|
0
|
|
|
|
|
0
|
$x_cache{$filename} = { mod_time=>$mod_time, colors=>\%pal }; |
200
|
|
|
|
|
|
|
|
201
|
0
|
|
|
|
|
0
|
return 1; |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
else { |
204
|
0
|
|
|
|
|
0
|
$Imager::ERRSTR = "Cannot open palette file $filename: $!"; |
205
|
0
|
|
|
|
|
0
|
return; |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
sub _get_x_color { |
210
|
15
|
|
|
15
|
|
37
|
my %args = @_; |
211
|
|
|
|
|
|
|
|
212
|
15
|
|
|
|
|
21
|
my $filename; |
213
|
15
|
50
|
|
|
|
49
|
if ($args{palette}) { |
|
|
100
|
|
|
|
|
|
214
|
0
|
|
|
|
|
0
|
$filename = $args{palette}; |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
elsif (defined $default_x_rgb) { |
217
|
8
|
50
|
|
|
|
30
|
unless (length $default_x_rgb) { |
218
|
8
|
|
|
|
|
14
|
$Imager::ERRSTR = "No X rgb.txt palette found"; |
219
|
8
|
|
|
|
|
21
|
return (); |
220
|
|
|
|
|
|
|
} |
221
|
0
|
|
|
|
|
0
|
$filename = $default_x_rgb; |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
else { |
224
|
7
|
|
|
|
|
19
|
for my $attempt (@x_search) { |
225
|
42
|
50
|
|
|
|
363
|
if (-e $attempt) { |
226
|
0
|
|
|
|
|
0
|
$filename = $attempt; |
227
|
0
|
|
|
|
|
0
|
last; |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
} |
230
|
7
|
50
|
|
|
|
27
|
if (!$filename) { |
231
|
7
|
|
|
|
|
19
|
$Imager::ERRSTR = "No X rgb.txt palette found"; |
232
|
7
|
|
|
|
|
13
|
$default_x_rgb = ""; |
233
|
7
|
|
|
|
|
73
|
return (); |
234
|
|
|
|
|
|
|
} |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
|
237
|
0
|
0
|
0
|
|
|
0
|
if ((!$x_cache{$filename} |
|
|
|
0
|
|
|
|
|
238
|
|
|
|
|
|
|
|| (stat $filename)[9] != $x_cache{$filename}{mod_time}) |
239
|
|
|
|
|
|
|
&& !_load_x_rgb($filename)) { |
240
|
0
|
|
|
|
|
0
|
return (); |
241
|
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
|
243
|
0
|
|
|
|
|
0
|
$default_x_rgb = $filename; |
244
|
|
|
|
|
|
|
|
245
|
0
|
0
|
|
|
|
0
|
if (!$x_cache{$filename}{colors}{lc $args{name}}) { |
246
|
0
|
|
|
|
|
0
|
$Imager::ERRSTR = "Color '$args{name}' isn't in $filename"; |
247
|
0
|
|
|
|
|
0
|
return (); |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
|
250
|
0
|
|
|
|
|
0
|
return @{$x_cache{$filename}{colors}{lc $args{name}}}; |
|
0
|
|
|
|
|
0
|
|
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
sub _pc_to_byte { |
254
|
24
|
|
|
24
|
|
98
|
POSIX::ceil($_[0] * 255 / 100); |
255
|
|
|
|
|
|
|
} |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
sub _rgb_alpha { |
258
|
26
|
|
|
26
|
|
57
|
my ($alpha) = @_; |
259
|
26
|
100
|
|
|
|
65
|
if ($alpha =~ /^(.*)%\z/) { |
260
|
7
|
|
|
|
|
41
|
return POSIX::ceil($1 * 255 / 100); |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
else { |
263
|
19
|
|
|
|
|
95
|
return POSIX::ceil($alpha * 255); |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
my $rgb_key = qr/rgba?/; |
268
|
|
|
|
|
|
|
my $rgb_samp = qr/(\d+(?:\.\d*)?)/; |
269
|
|
|
|
|
|
|
my $rgb_pc = qr/(\d+(?:\.\d*)?)%/; |
270
|
|
|
|
|
|
|
my $rgb_sep = qr/ *[, ] */; |
271
|
|
|
|
|
|
|
my $rgb_rgb = qr/$rgb_samp $rgb_sep $rgb_samp $rgb_sep $rgb_samp/x; |
272
|
|
|
|
|
|
|
my $rgb_rgb_pc = qr/$rgb_pc $rgb_sep $rgb_pc $rgb_sep $rgb_pc/x; |
273
|
|
|
|
|
|
|
my $rgb_alpha_sep = qr/ *[\/,] */; |
274
|
|
|
|
|
|
|
my $rgb_alpha = qr/((?:\.\d+|\d+(?:\.\d*)?)%?)/; |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
# Parse color spec into an a set of 4 colors |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
sub _pspec { |
279
|
2486
|
100
|
100
|
2486
|
|
8236
|
if (@_ == 1 && Scalar::Util::blessed($_[0])) { |
280
|
2
|
50
|
|
|
|
24
|
if ($_[0]->isa("Imager::Color")) { |
|
|
50
|
|
|
|
|
|
281
|
0
|
|
|
|
|
0
|
return $_[0]->rgba; |
282
|
|
|
|
|
|
|
} elsif ($_[0]->isa("Imager::Color::Float")) { |
283
|
2
|
|
|
|
|
8
|
return $_[0]->as_8bit->rgba; |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
} |
286
|
2484
|
100
|
|
|
|
4275
|
if (@_ == 1) { |
287
|
|
|
|
|
|
|
# CSS Color 4 says that color values are rounded to +Inf |
288
|
1467
|
100
|
|
|
|
16362
|
if ($_[0] =~ /\A$rgb_key\( *$rgb_rgb *\)\z/) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
289
|
29
|
|
|
|
|
201
|
return ( POSIX::ceil($1), POSIX::ceil($2), POSIX::ceil($3), 255 ); |
290
|
|
|
|
|
|
|
} |
291
|
|
|
|
|
|
|
elsif ($_[0] =~ /\A$rgb_key\( *$rgb_rgb_pc *\)\z/) { |
292
|
4
|
|
|
|
|
15
|
return ( _pc_to_byte($1), _pc_to_byte($2), _pc_to_byte($3), 255 ); |
293
|
|
|
|
|
|
|
} |
294
|
|
|
|
|
|
|
elsif ($_[0] =~ /\A$rgb_key\( *$rgb_rgb$rgb_alpha_sep$rgb_alpha *\)\z/) { |
295
|
22
|
|
|
|
|
122
|
return ( POSIX::ceil($1), POSIX::ceil($2), POSIX::ceil($3), _rgb_alpha($4) ); |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
elsif ($_[0] =~ /\A$rgb_key\( *$rgb_rgb_pc$rgb_alpha_sep$rgb_alpha *\)\z/) { |
298
|
4
|
|
|
|
|
15
|
return ( _pc_to_byte($1), _pc_to_byte($2), _pc_to_byte($3), _rgb_alpha($4) ); |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
} |
301
|
|
|
|
|
|
|
|
302
|
2425
|
100
|
66
|
|
|
7482
|
return (@_,255) if @_ == 3 && !grep /[^\d.+eE-]/, @_; |
303
|
2028
|
100
|
100
|
|
|
7049
|
return (@_ ) if @_ == 4 && !grep /[^\d.+eE-]/, @_; |
304
|
1434
|
100
|
|
|
|
2150
|
if ($_[0] =~ |
305
|
|
|
|
|
|
|
/^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i) { |
306
|
13
|
|
|
|
|
61
|
return (hex($1),hex($2),hex($3),hex($4)); |
307
|
|
|
|
|
|
|
} |
308
|
1421
|
100
|
|
|
|
4524
|
if ($_[0] =~ /^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i) { |
309
|
1235
|
|
|
|
|
4405
|
return (hex($1),hex($2),hex($3),255); |
310
|
|
|
|
|
|
|
} |
311
|
186
|
100
|
|
|
|
671
|
if ($_[0] =~ /^\#([\da-f])([\da-f])([\da-f])$/i) { |
312
|
145
|
|
|
|
|
580
|
return (hex($1) * 17, hex($2) * 17, hex($3) * 17, 255); |
313
|
|
|
|
|
|
|
} |
314
|
41
|
|
|
|
|
58
|
my %args; |
315
|
41
|
100
|
|
|
|
101
|
if (@_ == 1) { |
316
|
|
|
|
|
|
|
# a named color |
317
|
15
|
|
|
|
|
41
|
%args = ( name => @_ ); |
318
|
|
|
|
|
|
|
} |
319
|
|
|
|
|
|
|
else { |
320
|
26
|
|
|
|
|
128
|
%args = @_; |
321
|
|
|
|
|
|
|
} |
322
|
41
|
|
|
|
|
66
|
my @result; |
323
|
41
|
100
|
100
|
|
|
543
|
if (exists $args{gray}) { |
|
|
100
|
66
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
100
|
33
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
50
|
66
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
100
|
33
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
324
|
1
|
|
|
|
|
3
|
@result = $args{gray}; |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
elsif (exists $args{grey}) { |
327
|
1
|
|
|
|
|
3
|
@result = $args{grey}; |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
elsif ((exists $args{red} || exists $args{r}) |
330
|
|
|
|
|
|
|
&& (exists $args{green} || exists $args{g}) |
331
|
|
|
|
|
|
|
&& (exists $args{blue} || exists $args{b})) { |
332
|
|
|
|
|
|
|
@result = ( exists $args{red} ? $args{red} : $args{r}, |
333
|
|
|
|
|
|
|
exists $args{green} ? $args{green} : $args{g}, |
334
|
2
|
100
|
|
|
|
12
|
exists $args{blue} ? $args{blue} : $args{b} ); |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
elsif ((exists $args{hue} || exists $args{h}) |
337
|
|
|
|
|
|
|
&& (exists $args{saturation} || exists $args{'s'}) |
338
|
|
|
|
|
|
|
&& (exists $args{value} || exists $args{v})) { |
339
|
4
|
100
|
|
|
|
10
|
my $hue = exists $args{hue} ? $args{hue} : $args{h}; |
340
|
4
|
100
|
|
|
|
12
|
my $sat = exists $args{saturation} ? $args{saturation} : $args{'s'}; |
341
|
4
|
100
|
|
|
|
11
|
my $val = exists $args{value} ? $args{value} : $args{v}; |
342
|
|
|
|
|
|
|
|
343
|
4
|
|
|
|
|
13
|
@result = _hsv_to_rgb($hue, $sat, $val); |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
elsif (exists $args{web}) { |
346
|
2
|
100
|
|
|
|
19
|
if ($args{web} =~ /^#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])$/i) { |
|
|
50
|
|
|
|
|
|
347
|
1
|
|
|
|
|
8
|
@result = (hex($1),hex($2),hex($3)); |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
elsif ($args{web} =~ /^#?([\da-f])([\da-f])([\da-f])$/i) { |
350
|
1
|
|
|
|
|
8
|
@result = (hex($1) * 17, hex($2) * 17, hex($3) * 17); |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
elsif ($args{name}) { |
354
|
16
|
100
|
|
|
|
70
|
unless (@result = _get_gimp_color(%args)) { |
355
|
15
|
50
|
|
|
|
53
|
unless (@result = _get_x_color(%args)) { |
356
|
15
|
|
|
|
|
4372
|
require Imager::Color::Table; |
357
|
15
|
100
|
|
|
|
117
|
unless (@result = Imager::Color::Table->get($args{name})) { |
358
|
6
|
|
|
|
|
23
|
$Imager::ERRSTR = "No color named $args{name} found"; |
359
|
6
|
|
|
|
|
27
|
return (); |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
} |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
elsif ($args{gimp}) { |
365
|
2
|
|
|
|
|
13
|
@result = _get_gimp_color(name=>$args{gimp}, %args); |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
elsif ($args{xname}) { |
368
|
0
|
|
|
|
|
0
|
@result = _get_x_color(name=>$args{xname}, %args); |
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
elsif ($args{builtin}) { |
371
|
3
|
|
|
|
|
1493
|
require Imager::Color::Table; |
372
|
3
|
|
|
|
|
32
|
@result = Imager::Color::Table->get($args{builtin}); |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
elsif ($args{rgb}) { |
375
|
1
|
|
|
|
|
3
|
@result = @{$args{rgb}}; |
|
1
|
|
|
|
|
4
|
|
376
|
|
|
|
|
|
|
} |
377
|
|
|
|
|
|
|
elsif ($args{rgba}) { |
378
|
2
|
|
|
|
|
4
|
@result = @{$args{rgba}}; |
|
2
|
|
|
|
|
38
|
|
379
|
2
|
50
|
|
|
|
16
|
return @result if @result == 4; |
380
|
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
elsif ($args{hsv}) { |
382
|
1
|
|
|
|
|
4
|
@result = _hsv_to_rgb(@{$args{hsv}}); |
|
1
|
|
|
|
|
5
|
|
383
|
|
|
|
|
|
|
} |
384
|
|
|
|
|
|
|
elsif ($args{channels}) { |
385
|
4
|
|
|
|
|
6
|
my @ch = @{$args{channels}}; |
|
4
|
|
|
|
|
11
|
|
386
|
4
|
|
|
|
|
16
|
return ( @ch, (0) x (4 - @ch) ); |
387
|
|
|
|
|
|
|
} |
388
|
|
|
|
|
|
|
elsif (exists $args{channel0} || $args{c0}) { |
389
|
2
|
|
|
|
|
5
|
my $i = 0; |
390
|
2
|
|
100
|
|
|
24
|
while (exists $args{"channel$i"} || exists $args{"c$i"}) { |
391
|
|
|
|
|
|
|
push(@result, |
392
|
8
|
100
|
|
|
|
22
|
exists $args{"channel$i"} ? $args{"channel$i"} : $args{"c$i"}); |
393
|
8
|
|
|
|
|
22
|
++$i; |
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
} |
396
|
|
|
|
|
|
|
else { |
397
|
0
|
|
|
|
|
0
|
$Imager::ERRSTR = "No color specification found"; |
398
|
0
|
|
|
|
|
0
|
return (); |
399
|
|
|
|
|
|
|
} |
400
|
29
|
100
|
|
|
|
80
|
if (@result) { |
401
|
28
|
50
|
33
|
|
|
104
|
if (exists $args{alpha} || exists $args{a}) { |
402
|
0
|
0
|
|
|
|
0
|
push(@result, exists $args{alpha} ? $args{alpha} : $args{a}); |
403
|
|
|
|
|
|
|
} |
404
|
28
|
|
|
|
|
80
|
while (@result < 4) { |
405
|
30
|
|
|
|
|
67
|
push(@result, 255); |
406
|
|
|
|
|
|
|
} |
407
|
28
|
|
|
|
|
111
|
return @result; |
408
|
|
|
|
|
|
|
} |
409
|
1
|
|
|
|
|
3
|
return (); |
410
|
|
|
|
|
|
|
} |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
sub new { |
413
|
2486
|
|
|
2486
|
1
|
17987
|
shift; # get rid of class name. |
414
|
2486
|
|
|
|
|
4465
|
my @arg = _pspec(@_); |
415
|
2486
|
100
|
|
|
|
226716
|
return @arg ? new_internal($arg[0],$arg[1],$arg[2],$arg[3]) : (); |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
sub set { |
419
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
420
|
0
|
|
|
|
|
0
|
my @arg = _pspec(@_); |
421
|
0
|
0
|
|
|
|
0
|
return @arg ? set_internal($self, $arg[0],$arg[1],$arg[2],$arg[3]) : (); |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
sub equals { |
425
|
3
|
|
|
3
|
1
|
19
|
my ($self, %opts) = @_; |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
my $other = $opts{other} |
428
|
3
|
50
|
|
|
|
46
|
or return Imager->_set_error("'other' parameter required"); |
429
|
3
|
|
100
|
|
|
12
|
my $ignore_alpha = $opts{ignore_alpha} || 0; |
430
|
|
|
|
|
|
|
|
431
|
3
|
|
|
|
|
15
|
my @left = $self->rgba; |
432
|
3
|
|
|
|
|
8
|
my @right = $other->rgba; |
433
|
3
|
100
|
|
|
|
7
|
my $last_chan = $ignore_alpha ? 2 : 3; |
434
|
3
|
|
|
|
|
8
|
for my $ch (0 .. $last_chan) { |
435
|
11
|
100
|
|
|
|
27
|
$left[$ch] == $right[$ch] |
436
|
|
|
|
|
|
|
or return; |
437
|
|
|
|
|
|
|
} |
438
|
|
|
|
|
|
|
|
439
|
2
|
|
|
|
|
8
|
return 1; |
440
|
|
|
|
|
|
|
} |
441
|
|
|
|
|
|
|
|
442
|
0
|
|
|
0
|
|
0
|
sub CLONE_SKIP { 1 } |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
# Lifted from Graphics::Color::RGB |
445
|
|
|
|
|
|
|
# Thank you very much |
446
|
|
|
|
|
|
|
sub hsv { |
447
|
5
|
|
|
5
|
1
|
35
|
my( $self ) = @_; |
448
|
|
|
|
|
|
|
|
449
|
5
|
|
|
|
|
26
|
my( $red, $green, $blue, $alpha ) = $self->rgba; |
450
|
5
|
|
|
|
|
10
|
my $max = $red; |
451
|
5
|
|
|
|
|
11
|
my $maxc = 'r'; |
452
|
5
|
|
|
|
|
8
|
my $min = $red; |
453
|
|
|
|
|
|
|
|
454
|
5
|
100
|
|
|
|
16
|
if($green > $max) { |
455
|
1
|
|
|
|
|
2
|
$max = $green; |
456
|
1
|
|
|
|
|
4
|
$maxc = 'g'; |
457
|
|
|
|
|
|
|
} |
458
|
5
|
100
|
|
|
|
12
|
if($blue > $max) { |
459
|
1
|
|
|
|
|
3
|
$max = $blue; |
460
|
1
|
|
|
|
|
2
|
$maxc = 'b'; |
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
|
463
|
5
|
100
|
|
|
|
14
|
if($green < $min) { |
464
|
1
|
|
|
|
|
2
|
$min = $green; |
465
|
|
|
|
|
|
|
} |
466
|
5
|
50
|
|
|
|
11
|
if($blue < $min) { |
467
|
0
|
|
|
|
|
0
|
$min = $blue; |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
|
470
|
5
|
|
|
|
|
7
|
my ($h, $s, $v); |
471
|
|
|
|
|
|
|
|
472
|
5
|
100
|
|
|
|
24
|
if($max == $min) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
473
|
2
|
|
|
|
|
5
|
$h = 0; |
474
|
|
|
|
|
|
|
} |
475
|
|
|
|
|
|
|
elsif($maxc eq 'r') { |
476
|
1
|
|
|
|
|
8
|
$h = 60 * (($green - $blue) / ($max - $min)) % 360; |
477
|
|
|
|
|
|
|
} |
478
|
|
|
|
|
|
|
elsif($maxc eq 'g') { |
479
|
1
|
|
|
|
|
5
|
$h = (60 * (($blue - $red) / ($max - $min)) + 120); |
480
|
|
|
|
|
|
|
} |
481
|
|
|
|
|
|
|
elsif($maxc eq 'b') { |
482
|
1
|
|
|
|
|
6
|
$h = (60 * (($red - $green) / ($max - $min)) + 240); |
483
|
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
|
485
|
5
|
|
|
|
|
12
|
$v = $max/255; |
486
|
5
|
100
|
|
|
|
12
|
if($max == 0) { |
487
|
1
|
|
|
|
|
4
|
$s = 0; |
488
|
|
|
|
|
|
|
} |
489
|
|
|
|
|
|
|
else { |
490
|
4
|
|
|
|
|
9
|
$s = 1 - ($min / $max); |
491
|
|
|
|
|
|
|
} |
492
|
|
|
|
|
|
|
|
493
|
5
|
|
|
|
|
17
|
return int($h), $s, $v, $alpha; |
494
|
|
|
|
|
|
|
} |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
sub as_float { |
497
|
11
|
|
|
11
|
1
|
45
|
my ($self) = @_; |
498
|
|
|
|
|
|
|
|
499
|
11
|
|
|
|
|
44
|
return Imager::Color::Float->new(map { $_ / 255 } $self->rgba); |
|
44
|
|
|
|
|
99
|
|
500
|
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
sub as_css_rgb { |
503
|
43
|
|
|
43
|
1
|
149
|
my ($self) = @_; |
504
|
|
|
|
|
|
|
|
505
|
43
|
|
|
|
|
146
|
my ($r, $g, $b, $alpha) = $self->rgba; |
506
|
|
|
|
|
|
|
|
507
|
43
|
100
|
|
|
|
85
|
if ($alpha == 255) { |
508
|
24
|
|
|
|
|
110
|
return "rgb($r, $g, $b)"; |
509
|
|
|
|
|
|
|
} |
510
|
|
|
|
|
|
|
else { |
511
|
19
|
|
|
|
|
75
|
my $ac = POSIX::floor($alpha * 1000 / 255) / 10; |
512
|
19
|
100
|
|
|
|
106
|
if (POSIX::ceil(POSIX::floor($ac/10) * 10 * 255 / 100) == $alpha) { |
|
|
100
|
|
|
|
|
|
513
|
|
|
|
|
|
|
# simple one decimal fraction |
514
|
13
|
|
|
|
|
35
|
$ac = POSIX::floor($ac/10)/10; |
515
|
|
|
|
|
|
|
} |
516
|
|
|
|
|
|
|
elsif (POSIX::ceil(POSIX::floor($ac) * 255 / 100) == $alpha) { |
517
|
3
|
|
|
|
|
21
|
$ac = POSIX::floor($ac) . "%"; |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
else { |
520
|
3
|
|
|
|
|
20
|
$ac = "$ac%"; |
521
|
|
|
|
|
|
|
} |
522
|
19
|
|
|
|
|
138
|
return "rgba($r, $g, $b, $ac)"; |
523
|
|
|
|
|
|
|
} |
524
|
|
|
|
|
|
|
} |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
1; |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
__END__ |