line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package PDF::Builder::Util; |
2
|
|
|
|
|
|
|
|
3
|
34
|
|
|
34
|
|
250
|
use strict; |
|
34
|
|
|
|
|
68
|
|
|
34
|
|
|
|
|
1084
|
|
4
|
34
|
|
|
34
|
|
179
|
use warnings; |
|
34
|
|
|
|
|
72
|
|
|
34
|
|
|
|
|
1996
|
|
5
|
|
|
|
|
|
|
#no warnings qw[ recursion uninitialized ]; |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
our $VERSION = '3.023'; # VERSION |
8
|
|
|
|
|
|
|
our $LAST_UPDATE = '3.021'; # manually update whenever code is changed |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
# note: $a and $b are "Magic variables" according to perlcritic, and so it |
11
|
|
|
|
|
|
|
# has conniptions over using them as variable names (even with "my"). so, I |
12
|
|
|
|
|
|
|
# changed most of the single letter names to double letters (r,g,b -> rr,gg,bb |
13
|
|
|
|
|
|
|
# etc.) |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
BEGIN { |
16
|
34
|
|
|
34
|
|
204
|
use Encode qw(:all); |
|
34
|
|
|
|
|
74
|
|
|
34
|
|
|
|
|
9679
|
|
17
|
34
|
|
|
34
|
|
20209
|
use Math::Trig; # CAUTION: deg2rad(0) = deg2rad(360) = 0! |
|
34
|
|
|
|
|
487775
|
|
|
34
|
|
|
|
|
5525
|
|
18
|
34
|
|
|
34
|
|
374
|
use List::Util qw(min max); |
|
34
|
|
|
|
|
82
|
|
|
34
|
|
|
|
|
3750
|
|
19
|
34
|
|
|
34
|
|
280
|
use PDF::Builder::Basic::PDF::Utils; |
|
34
|
|
|
|
|
79
|
|
|
34
|
|
|
|
|
2582
|
|
20
|
34
|
|
|
34
|
|
232
|
use PDF::Builder::Basic::PDF::Filter; |
|
34
|
|
|
|
|
75
|
|
|
34
|
|
|
|
|
1013
|
|
21
|
34
|
|
|
34
|
|
22246
|
use PDF::Builder::Resource::Colors; |
|
34
|
|
|
|
|
99
|
|
|
34
|
|
|
|
|
1285
|
|
22
|
34
|
|
|
34
|
|
49005
|
use PDF::Builder::Resource::Glyphs; |
|
34
|
|
|
|
|
198
|
|
|
34
|
|
|
|
|
15720
|
|
23
|
34
|
|
|
34
|
|
22510
|
use PDF::Builder::Resource::PaperSizes; |
|
34
|
|
|
|
|
146
|
|
|
34
|
|
|
|
|
1343
|
|
24
|
34
|
|
|
34
|
|
238
|
use POSIX qw( HUGE_VAL floor ); |
|
34
|
|
|
|
|
79
|
|
|
34
|
|
|
|
|
322
|
|
25
|
|
|
|
|
|
|
|
26
|
34
|
|
|
|
|
3188
|
use vars qw( |
27
|
|
|
|
|
|
|
@ISA |
28
|
|
|
|
|
|
|
@EXPORT |
29
|
|
|
|
|
|
|
@EXPORT_OK |
30
|
|
|
|
|
|
|
%colors |
31
|
|
|
|
|
|
|
$key_var |
32
|
|
|
|
|
|
|
%u2n |
33
|
|
|
|
|
|
|
%n2u |
34
|
|
|
|
|
|
|
$pua |
35
|
|
|
|
|
|
|
%PaperSizes |
36
|
34
|
|
|
34
|
|
4185
|
); |
|
34
|
|
|
|
|
131
|
|
37
|
|
|
|
|
|
|
|
38
|
34
|
|
|
34
|
|
226
|
use Exporter; |
|
34
|
|
|
|
|
71
|
|
|
34
|
|
|
|
|
5488
|
|
39
|
34
|
|
|
34
|
|
829
|
@ISA = qw(Exporter); |
40
|
34
|
|
|
|
|
239
|
@EXPORT = qw( |
41
|
|
|
|
|
|
|
pdfkey |
42
|
|
|
|
|
|
|
float floats floats5 intg intgs |
43
|
|
|
|
|
|
|
mMin mMax |
44
|
|
|
|
|
|
|
HSVtoRGB RGBtoHSV HSLtoRGB RGBtoHSL RGBtoLUM |
45
|
|
|
|
|
|
|
namecolor namecolor_cmyk namecolor_lab optInvColor defineColor |
46
|
|
|
|
|
|
|
dofilter unfilter |
47
|
|
|
|
|
|
|
nameByUni uniByName initNameTable defineName |
48
|
|
|
|
|
|
|
page_size |
49
|
|
|
|
|
|
|
getPaperSizes |
50
|
|
|
|
|
|
|
str2dim |
51
|
|
|
|
|
|
|
); |
52
|
34
|
|
|
|
|
166
|
@EXPORT_OK = qw( |
53
|
|
|
|
|
|
|
pdfkey |
54
|
|
|
|
|
|
|
digest digestx digest16 digest32 |
55
|
|
|
|
|
|
|
float floats floats5 intg intgs |
56
|
|
|
|
|
|
|
mMin mMax |
57
|
|
|
|
|
|
|
cRGB cRGB8 RGBasCMYK |
58
|
|
|
|
|
|
|
HSVtoRGB RGBtoHSV HSLtoRGB RGBtoHSL RGBtoLUM |
59
|
|
|
|
|
|
|
namecolor namecolor_cmyk namecolor_lab optInvColor defineColor |
60
|
|
|
|
|
|
|
dofilter unfilter |
61
|
|
|
|
|
|
|
nameByUni uniByName initNameTable defineName |
62
|
|
|
|
|
|
|
page_size getPaperSizes |
63
|
|
|
|
|
|
|
str2dim |
64
|
|
|
|
|
|
|
); |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
=head1 NAME |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
PDF::Builder::Util - utility package for often-used methods across the package. |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
=cut |
71
|
|
|
|
|
|
|
|
72
|
34
|
|
|
|
|
312
|
%colors = PDF::Builder::Resource::Colors->get_colors(); |
73
|
34
|
|
|
|
|
979
|
%PaperSizes = PDF::Builder::Resource::PaperSizes->get_paper_sizes(); |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
# no warnings qw[ recursion uninitialized ]; |
76
|
|
|
|
|
|
|
|
77
|
34
|
|
|
|
|
256
|
$key_var = 'CBA'; |
78
|
|
|
|
|
|
|
|
79
|
34
|
|
|
|
|
95
|
$pua = 0xE000; |
80
|
|
|
|
|
|
|
|
81
|
34
|
|
|
|
|
67
|
%u2n = %{$PDF::Builder::Resource::Glyphs::u2n}; |
|
34
|
|
|
|
|
83830
|
|
82
|
34
|
|
|
|
|
4920
|
%n2u = %{$PDF::Builder::Resource::Glyphs::n2u}; |
|
34
|
|
|
|
|
287523
|
|
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
sub pdfkey { |
86
|
82
|
|
|
82
|
0
|
1664
|
return $PDF::Builder::Util::key_var++; |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
sub digestx { |
90
|
0
|
|
|
0
|
0
|
0
|
my $len = shift; |
91
|
|
|
|
|
|
|
|
92
|
0
|
|
|
|
|
0
|
my $mask = $len - 1; |
93
|
0
|
|
|
|
|
0
|
my $ddata = join('', @_); |
94
|
0
|
|
|
|
|
0
|
my $mdkey = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789gT'; |
95
|
0
|
|
|
|
|
0
|
my $xdata = '0' x $len; |
96
|
0
|
|
|
|
|
0
|
my $off = 0; |
97
|
0
|
|
|
|
|
0
|
foreach my $set (0 .. (length($ddata) << 1)) { |
98
|
0
|
|
|
|
|
0
|
$off += vec($ddata, $set, 4); |
99
|
0
|
|
|
|
|
0
|
$off += vec($xdata, ($set & $mask), 8); |
100
|
0
|
|
|
|
|
0
|
vec($xdata, ($set & ($mask << 1 | 1)), 4) = vec($mdkey, ($off & 0x7f), 4); |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
# foreach $set (0 .. $mask) { |
104
|
|
|
|
|
|
|
# vec($xdata, $set, 8) = (vec($xdata, $set, 8) & 0x7f) | 0x40; |
105
|
|
|
|
|
|
|
# } |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
# $off = 0; |
108
|
|
|
|
|
|
|
# foreach $set (0 .. $mask) { |
109
|
|
|
|
|
|
|
# $off += vec($xdata, $set, 8); |
110
|
|
|
|
|
|
|
# vec($xdata, $set, 8) = vec($mdkey, ($off & 0x3f), 8); |
111
|
|
|
|
|
|
|
# } |
112
|
|
|
|
|
|
|
|
113
|
0
|
|
|
|
|
0
|
return $xdata; |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
sub digest { |
117
|
0
|
|
|
0
|
0
|
0
|
return digestx(32, @_); |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
sub digest16 { |
121
|
0
|
|
|
0
|
0
|
0
|
return digestx(16, @_); |
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
sub digest32 { |
125
|
0
|
|
|
0
|
0
|
0
|
return digestx(32, @_); |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
sub xlog10 { |
129
|
2232
|
|
|
2232
|
0
|
2904
|
my $n = shift; |
130
|
|
|
|
|
|
|
|
131
|
2232
|
100
|
|
|
|
3668
|
if ($n) { |
132
|
1486
|
|
|
|
|
5140
|
return log(abs($n)) / log(10); |
133
|
|
|
|
|
|
|
} else { |
134
|
746
|
|
|
|
|
2552
|
return 0; |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
sub float { |
139
|
2232
|
|
|
2232
|
0
|
3373
|
my $f = shift; |
140
|
2232
|
|
100
|
|
|
5906
|
my $mxd = shift() || 4; |
141
|
|
|
|
|
|
|
|
142
|
2232
|
100
|
|
|
|
4672
|
$f = 0 if abs($f) < 0.0000000000000001; |
143
|
2232
|
|
|
|
|
3584
|
my $ad = floor(xlog10($f) - $mxd); |
144
|
2232
|
100
|
|
|
|
7167
|
if (abs($f - int($f)) < (10 ** (-$mxd))) { |
|
|
50
|
|
|
|
|
|
145
|
|
|
|
|
|
|
# just in case we have an integer |
146
|
1589
|
|
|
|
|
6943
|
return sprintf('%i', $f); |
147
|
|
|
|
|
|
|
} elsif ($ad > 0) { |
148
|
0
|
|
|
|
|
0
|
my $value = sprintf('%f', $f); |
149
|
|
|
|
|
|
|
# Remove trailing zeros |
150
|
0
|
|
|
|
|
0
|
$value =~ s/(\.\d*?)0+$/$1/; |
151
|
0
|
|
|
|
|
0
|
$value =~ s/\.$//; |
152
|
0
|
|
|
|
|
0
|
return $value; |
153
|
|
|
|
|
|
|
} else { |
154
|
643
|
|
|
|
|
3014
|
my $value = sprintf('%.*f', abs($ad), $f); |
155
|
|
|
|
|
|
|
# Remove trailing zeros |
156
|
643
|
|
|
|
|
2187
|
$value =~ s/(\.\d*?)0+$/$1/; |
157
|
643
|
|
|
|
|
957
|
$value =~ s/\.$//; |
158
|
643
|
|
|
|
|
1681
|
return $value; |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
325
|
|
|
325
|
0
|
560
|
sub floats { return map { float($_) } @_; } |
|
1105
|
|
|
|
|
1779
|
|
163
|
51
|
|
|
51
|
0
|
110
|
sub floats5 { return map { float($_, 5) } @_; } |
|
155
|
|
|
|
|
264
|
|
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
sub intg { |
166
|
1
|
|
|
1
|
0
|
3
|
my $f = shift; |
167
|
|
|
|
|
|
|
|
168
|
1
|
|
|
|
|
10
|
return sprintf('%i', $f); |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
|
171
|
0
|
|
|
0
|
0
|
0
|
sub intgs { return map { intg($_) } @_; } |
|
0
|
|
|
|
|
0
|
|
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
sub mMin { |
174
|
2
|
|
|
2
|
0
|
5
|
my $n = HUGE_VAL(); |
175
|
2
|
100
|
|
|
|
5
|
map { $n = ($n > $_) ? $_ : $n } @_; |
|
6
|
|
|
|
|
26
|
|
176
|
2
|
|
|
|
|
4
|
return $n; |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
sub mMax { |
180
|
2
|
|
|
2
|
0
|
6
|
my $n = -HUGE_VAL(); |
181
|
2
|
100
|
|
|
|
4
|
map { $n = ($n < $_) ? $_ : $n } @_; |
|
6
|
|
|
|
|
31
|
|
182
|
2
|
|
|
|
|
7
|
return $n; |
183
|
|
|
|
|
|
|
} |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
=head2 PREDEFINED COLORS |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
See the source of L for a complete list. |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
B This is an amalgamation of the X11, SGML and (X)HTML |
190
|
|
|
|
|
|
|
specification sets. |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
There are many color model conversion and input conversion routines |
193
|
|
|
|
|
|
|
defined here. |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
=cut |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
sub cRGB { |
198
|
0
|
|
|
0
|
0
|
0
|
my @cmy = (map { 1 - $_ } @_); |
|
0
|
|
|
|
|
0
|
|
199
|
0
|
|
|
|
|
0
|
my $k = mMin(@cmy); |
200
|
0
|
|
|
|
|
0
|
return (map { $_ - $k } @cmy), $k; |
|
0
|
|
|
|
|
0
|
|
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
sub cRGB8 { |
204
|
0
|
|
|
0
|
0
|
0
|
return cRGB(map { $_ / 255 } @_); |
|
0
|
|
|
|
|
0
|
|
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
sub RGBtoLUM { |
208
|
0
|
|
|
0
|
0
|
0
|
my ($rr, $gg, $bb) = @_; |
209
|
0
|
|
|
|
|
0
|
return $rr * 0.299 + $gg * 0.587 + $bb * 0.114; |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
sub RGBasCMYK { |
213
|
0
|
|
|
0
|
0
|
0
|
my @rgb = @_; |
214
|
0
|
|
|
|
|
0
|
my @cmy = map { 1 - $_ } @rgb; |
|
0
|
|
|
|
|
0
|
|
215
|
0
|
|
|
|
|
0
|
my $k = mMin(@cmy) * 0.44; |
216
|
0
|
|
|
|
|
0
|
return (map { $_ - $k } @cmy), $k; |
|
0
|
|
|
|
|
0
|
|
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
sub HSVtoRGB { |
220
|
26
|
|
|
26
|
0
|
56
|
my ($h,$s,$v) = @_; |
221
|
26
|
|
|
|
|
37
|
my ($rr,$gg,$bb, $i, $f, $p, $q, $t); |
222
|
|
|
|
|
|
|
|
223
|
26
|
50
|
|
|
|
67
|
if ($s == 0) { |
224
|
|
|
|
|
|
|
# achromatic (grey) |
225
|
0
|
|
|
|
|
0
|
return ($v,$v,$v); |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
|
228
|
26
|
|
|
|
|
46
|
$h %= 360; |
229
|
26
|
|
|
|
|
37
|
$h /= 60; # sector 0 to 5 |
230
|
26
|
|
|
|
|
52
|
$i = POSIX::floor($h); |
231
|
26
|
|
|
|
|
42
|
$f = $h - $i; # factorial part of h |
232
|
26
|
|
|
|
|
32
|
$p = $v * (1 - $s); |
233
|
26
|
|
|
|
|
43
|
$q = $v * (1 - $s * $f); |
234
|
26
|
|
|
|
|
39
|
$t = $v * (1 - $s * ( 1 - $f )); |
235
|
|
|
|
|
|
|
|
236
|
26
|
100
|
|
|
|
79
|
if ($i < 1) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
237
|
5
|
|
|
|
|
6
|
$rr = $v; |
238
|
5
|
|
|
|
|
8
|
$gg = $t; |
239
|
5
|
|
|
|
|
6
|
$bb = $p; |
240
|
|
|
|
|
|
|
} elsif ($i < 2) { |
241
|
4
|
|
|
|
|
6
|
$rr = $q; |
242
|
4
|
|
|
|
|
6
|
$gg = $v; |
243
|
4
|
|
|
|
|
6
|
$bb = $p; |
244
|
|
|
|
|
|
|
} elsif ($i < 3) { |
245
|
3
|
|
|
|
|
5
|
$rr = $p; |
246
|
3
|
|
|
|
|
5
|
$gg = $v; |
247
|
3
|
|
|
|
|
4
|
$bb = $t; |
248
|
|
|
|
|
|
|
} elsif ($i < 4) { |
249
|
5
|
|
|
|
|
9
|
$rr = $p; |
250
|
5
|
|
|
|
|
7
|
$gg = $q; |
251
|
5
|
|
|
|
|
15
|
$bb = $v; |
252
|
|
|
|
|
|
|
} elsif ($i < 5) { |
253
|
3
|
|
|
|
|
6
|
$rr = $t; |
254
|
3
|
|
|
|
|
4
|
$gg = $p; |
255
|
3
|
|
|
|
|
4
|
$bb = $v; |
256
|
|
|
|
|
|
|
} else { |
257
|
6
|
|
|
|
|
8
|
$rr = $v; |
258
|
6
|
|
|
|
|
9
|
$gg = $p; |
259
|
6
|
|
|
|
|
8
|
$bb = $q; |
260
|
|
|
|
|
|
|
} |
261
|
|
|
|
|
|
|
|
262
|
26
|
|
|
|
|
63
|
return ($rr, $gg, $bb); |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
sub RGBquant { |
266
|
6
|
|
|
6
|
0
|
13
|
my ($q1, $q2, $h) = @_; |
267
|
6
|
|
|
|
|
14
|
while ($h < 0) { |
268
|
0
|
|
|
|
|
0
|
$h += 360; |
269
|
|
|
|
|
|
|
} |
270
|
6
|
|
|
|
|
11
|
$h %= 360; |
271
|
6
|
100
|
|
|
|
21
|
if ($h < 60) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
272
|
1
|
|
|
|
|
3
|
return $q1 + (($q2 - $q1) * $h / 60); |
273
|
|
|
|
|
|
|
} elsif ($h < 180) { |
274
|
2
|
|
|
|
|
4
|
return $q2; |
275
|
|
|
|
|
|
|
} elsif ($h < 240) { |
276
|
1
|
|
|
|
|
4
|
return $q1 + (($q2 - $q1) * (240 - $h) / 60); |
277
|
|
|
|
|
|
|
} else { |
278
|
2
|
|
|
|
|
6
|
return $q1; |
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
sub RGBtoHSV { |
283
|
2
|
|
|
2
|
0
|
7
|
my ($rr,$gg,$bb) = @_; |
284
|
|
|
|
|
|
|
|
285
|
2
|
|
|
|
|
5
|
my ($h,$s,$v, $min, $max, $delta); |
286
|
|
|
|
|
|
|
|
287
|
2
|
|
|
|
|
9
|
$min = mMin($rr, $gg, $bb); |
288
|
2
|
|
|
|
|
7
|
$max = mMax($rr, $gg, $bb); |
289
|
|
|
|
|
|
|
|
290
|
2
|
|
|
|
|
3
|
$v = $max; |
291
|
2
|
|
|
|
|
6
|
$delta = $max - $min; |
292
|
|
|
|
|
|
|
|
293
|
2
|
50
|
|
|
|
6
|
if ($delta > 0.000000001) { |
294
|
2
|
|
|
|
|
4
|
$s = $delta / $max; |
295
|
|
|
|
|
|
|
} else { |
296
|
0
|
|
|
|
|
0
|
$s = 0; |
297
|
0
|
|
|
|
|
0
|
$h = 0; |
298
|
0
|
|
|
|
|
0
|
return ($h,$s,$v); |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
|
301
|
2
|
50
|
|
|
|
10
|
if ( $rr == $max ) { |
|
|
100
|
|
|
|
|
|
302
|
0
|
|
|
|
|
0
|
$h = ($gg - $bb) / $delta; |
303
|
|
|
|
|
|
|
} elsif ( $gg == $max ) { |
304
|
1
|
|
|
|
|
3
|
$h = 2 + ($bb - $rr) / $delta; |
305
|
|
|
|
|
|
|
} else { |
306
|
1
|
|
|
|
|
4
|
$h = 4 + ($rr - $gg) / $delta; |
307
|
|
|
|
|
|
|
} |
308
|
2
|
|
|
|
|
6
|
$h *= 60; |
309
|
2
|
50
|
|
|
|
7
|
if ($h < 0) { |
310
|
0
|
|
|
|
|
0
|
$h += 360; |
311
|
|
|
|
|
|
|
} |
312
|
2
|
|
|
|
|
7
|
return ($h,$s,$v); |
313
|
|
|
|
|
|
|
} |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
sub RGBtoHSL { |
316
|
0
|
|
|
0
|
0
|
0
|
my ($rr,$gg,$bb) = @_; |
317
|
|
|
|
|
|
|
|
318
|
0
|
|
|
|
|
0
|
my ($h,$s,$v, $l, $min, $max, $delta); |
319
|
|
|
|
|
|
|
|
320
|
0
|
|
|
|
|
0
|
$min = mMin($rr, $gg, $bb); |
321
|
0
|
|
|
|
|
0
|
$max = mMax($rr, $gg, $bb); |
322
|
0
|
|
|
|
|
0
|
($h, $s, $v) = RGBtoHSV($rr, $gg, $bb); |
323
|
0
|
|
|
|
|
0
|
$l = ($max + $min) / 2.0; |
324
|
0
|
|
|
|
|
0
|
$delta = $max - $min; |
325
|
0
|
0
|
|
|
|
0
|
if ($delta < 0.00000000001) { |
326
|
0
|
|
|
|
|
0
|
return (0, 0, $l); |
327
|
|
|
|
|
|
|
} else { |
328
|
0
|
0
|
|
|
|
0
|
if ($l <= 0.5) { |
329
|
0
|
|
|
|
|
0
|
$s = $delta / ($max + $min); |
330
|
|
|
|
|
|
|
} else { |
331
|
0
|
|
|
|
|
0
|
$s = $delta / (2 - $max - $min); |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
} |
334
|
0
|
|
|
|
|
0
|
return ($h, $s, $l); |
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
sub HSLtoRGB { |
338
|
2
|
|
|
2
|
0
|
8
|
my($h,$s,$l, $rr,$gg,$bb, $p1, $p2) = @_; |
339
|
|
|
|
|
|
|
|
340
|
2
|
50
|
|
|
|
7
|
if ($l <= 0.5) { |
341
|
0
|
|
|
|
|
0
|
$p2 = $l * (1 + $s); |
342
|
|
|
|
|
|
|
} else { |
343
|
2
|
|
|
|
|
5
|
$p2 = $l + $s - ($l * $s); |
344
|
|
|
|
|
|
|
} |
345
|
2
|
|
|
|
|
5
|
$p1 = 2 * $l - $p2; |
346
|
2
|
50
|
|
|
|
6
|
if ($s < 0.0000000000001) { |
347
|
0
|
|
|
|
|
0
|
$rr = $gg = $bb = $l; |
348
|
|
|
|
|
|
|
} else { |
349
|
2
|
|
|
|
|
11
|
$rr = RGBquant($p1, $p2, $h + 120); |
350
|
2
|
|
|
|
|
6
|
$gg = RGBquant($p1, $p2, $h); |
351
|
2
|
|
|
|
|
6
|
$bb = RGBquant($p1, $p2, $h - 120); |
352
|
|
|
|
|
|
|
} |
353
|
2
|
|
|
|
|
9
|
return ($rr,$gg,$bb); |
354
|
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
sub optInvColor { |
357
|
0
|
|
|
0
|
0
|
0
|
my ($rr,$gg,$bb) = @_; |
358
|
|
|
|
|
|
|
|
359
|
0
|
|
|
|
|
0
|
my $ab = (0.2 * $rr) + (0.7 * $gg) + (0.1 * $bb); |
360
|
|
|
|
|
|
|
|
361
|
0
|
0
|
|
|
|
0
|
if ($ab > 0.45) { |
362
|
0
|
|
|
|
|
0
|
return(0,0,0); |
363
|
|
|
|
|
|
|
} else { |
364
|
0
|
|
|
|
|
0
|
return(1,1,1); |
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
sub defineColor { |
369
|
0
|
|
|
0
|
0
|
0
|
my ($name, $mx, $rr,$gg,$bb) = @_; |
370
|
0
|
|
0
|
|
|
0
|
$colors{$name} ||= [ map {$_ / $mx} ($rr,$gg,$bb) ]; |
|
0
|
|
|
|
|
0
|
|
371
|
0
|
|
|
|
|
0
|
return $colors{$name}; |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
# convert 3n (n=1..4) hex digits to RGB 0-1 values |
375
|
|
|
|
|
|
|
# returns a triplet of values 0.0..1.0 |
376
|
|
|
|
|
|
|
sub rgbHexValues { |
377
|
21
|
|
|
21
|
0
|
48
|
my $name = lc(shift()); # # plus 3n hex digits |
378
|
|
|
|
|
|
|
# if <3 digits, pad with '0' (silent error) |
379
|
|
|
|
|
|
|
# if not 3n digits, ignore extras (silent error) |
380
|
|
|
|
|
|
|
# if >12 digits, ignore extras (silent error) |
381
|
21
|
|
|
|
|
35
|
my ($rr,$gg,$bb); |
382
|
21
|
|
|
|
|
69
|
while (length($name) < 4) { $name .= '0'; } |
|
0
|
|
|
|
|
0
|
|
383
|
21
|
50
|
|
|
|
92
|
if (length($name) < 5) { # zb. #fa4, #cf0 |
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
384
|
0
|
|
|
|
|
0
|
$rr = hex(substr($name, 1, 1)) / 0xf; |
385
|
0
|
|
|
|
|
0
|
$gg = hex(substr($name, 2, 1)) / 0xf; |
386
|
0
|
|
|
|
|
0
|
$bb = hex(substr($name, 3, 1)) / 0xf; |
387
|
|
|
|
|
|
|
} elsif (length($name) < 8) { # zb. #ffaa44, #ccff00 |
388
|
21
|
|
|
|
|
84
|
$rr = hex(substr($name, 1, 2)) / 0xff; |
389
|
21
|
|
|
|
|
50
|
$gg = hex(substr($name, 3, 2)) / 0xff; |
390
|
21
|
|
|
|
|
44
|
$bb = hex(substr($name, 5, 2)) / 0xff; |
391
|
|
|
|
|
|
|
} elsif (length($name) < 11) { # zb. #fffaaa444, #cccfff000 |
392
|
0
|
|
|
|
|
0
|
$rr = hex(substr($name, 1, 3)) / 0xfff; |
393
|
0
|
|
|
|
|
0
|
$gg = hex(substr($name, 4, 3)) / 0xfff; |
394
|
0
|
|
|
|
|
0
|
$bb = hex(substr($name, 7, 3)) / 0xfff; |
395
|
|
|
|
|
|
|
} else { # zb. #ffffaaaa4444, #ccccffff0000 |
396
|
0
|
|
|
|
|
0
|
$rr = hex(substr($name, 1, 4)) / 0xffff; |
397
|
0
|
|
|
|
|
0
|
$gg = hex(substr($name, 5, 4)) / 0xffff; |
398
|
0
|
|
|
|
|
0
|
$bb = hex(substr($name, 9, 4)) / 0xffff; |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
|
401
|
21
|
|
|
|
|
91
|
return ($rr,$gg,$bb); |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
# convert 4n (n=1..4) hex digits to CMYK 0-1 values |
405
|
|
|
|
|
|
|
# returns a quadruple of values 0.0..1.0 |
406
|
|
|
|
|
|
|
sub cmykHexValues { |
407
|
2
|
|
|
2
|
0
|
7
|
my $name = lc(shift()); # % plus 4n hex digits |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
# if <4 digits, pad with '0' (silent error) |
410
|
|
|
|
|
|
|
# if not 4n digits, ignore extras (silent error) |
411
|
|
|
|
|
|
|
# if >16 digits, ignore extras (silent error) |
412
|
2
|
|
|
|
|
6
|
my ($c,$m,$y,$k); |
413
|
2
|
|
|
|
|
8
|
while (length($name) < 5) { $name .= '0'; } |
|
0
|
|
|
|
|
0
|
|
414
|
2
|
50
|
|
|
|
11
|
if (length($name) < 6) { # zb. %cmyk |
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
415
|
0
|
|
|
|
|
0
|
$c = hex(substr($name, 1, 1)) / 0xf; |
416
|
0
|
|
|
|
|
0
|
$m = hex(substr($name, 2, 1)) / 0xf; |
417
|
0
|
|
|
|
|
0
|
$y = hex(substr($name, 3, 1)) / 0xf; |
418
|
0
|
|
|
|
|
0
|
$k = hex(substr($name, 4, 1)) / 0xf; |
419
|
|
|
|
|
|
|
} elsif (length($name) < 10) { # zb. %ccmmyykk |
420
|
2
|
|
|
|
|
8
|
$c = hex(substr($name, 1, 2)) / 0xff; |
421
|
2
|
|
|
|
|
8
|
$m = hex(substr($name, 3, 2)) / 0xff; |
422
|
2
|
|
|
|
|
5
|
$y = hex(substr($name, 5, 2)) / 0xff; |
423
|
2
|
|
|
|
|
5
|
$k = hex(substr($name, 7, 2)) / 0xff; |
424
|
|
|
|
|
|
|
} elsif (length($name) < 14) { # zb. %cccmmmyyykkk |
425
|
0
|
|
|
|
|
0
|
$c = hex(substr($name, 1, 3)) / 0xfff; |
426
|
0
|
|
|
|
|
0
|
$m = hex(substr($name, 4, 3)) / 0xfff; |
427
|
0
|
|
|
|
|
0
|
$y = hex(substr($name, 7, 3)) / 0xfff; |
428
|
0
|
|
|
|
|
0
|
$k = hex(substr($name, 10, 3)) /0xfff; |
429
|
|
|
|
|
|
|
} else { # zb. %ccccmmmmyyyykkkk |
430
|
0
|
|
|
|
|
0
|
$c = hex(substr($name, 1, 4)) / 0xffff; |
431
|
0
|
|
|
|
|
0
|
$m = hex(substr($name, 5, 4)) / 0xffff; |
432
|
0
|
|
|
|
|
0
|
$y = hex(substr($name, 9, 4)) / 0xffff; |
433
|
0
|
|
|
|
|
0
|
$k = hex(substr($name, 13, 4)) / 0xffff; |
434
|
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
|
436
|
2
|
|
|
|
|
11
|
return ($c,$m,$y,$k); |
437
|
|
|
|
|
|
|
} |
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
# convert 3n (n=1..4) hex digits to HSV 0-360, 0-1 values |
440
|
|
|
|
|
|
|
# returns a triplet of values 0.0..360.0, 2x0.0..1.0 |
441
|
|
|
|
|
|
|
sub hsvHexValues { |
442
|
28
|
|
|
28
|
0
|
51
|
my $name = lc(shift()); # ! plus 3n hex digits |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
# if <3 digits, pad with '0' (silent error) |
445
|
|
|
|
|
|
|
# if not 3n digits, ignore extras (silent error) |
446
|
|
|
|
|
|
|
# if >12 digits, ignore extras (silent error) |
447
|
28
|
|
|
|
|
40
|
my ($h,$s,$v); |
448
|
28
|
|
|
|
|
78
|
while (length($name) < 4) { $name .= '0'; } |
|
0
|
|
|
|
|
0
|
|
449
|
28
|
100
|
|
|
|
80
|
if (length($name) < 5) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
450
|
1
|
|
|
|
|
6
|
$h = 360 * hex(substr($name, 1, 1)) / 0x10; |
451
|
1
|
|
|
|
|
3
|
$s = hex(substr($name, 2, 1)) / 0xf; |
452
|
1
|
|
|
|
|
3
|
$v = hex(substr($name, 3, 1)) / 0xf; |
453
|
|
|
|
|
|
|
} elsif (length($name) < 8) { |
454
|
25
|
|
|
|
|
56
|
$h = 360 * hex(substr($name, 1, 2)) / 0x100; |
455
|
25
|
|
|
|
|
43
|
$s = hex(substr($name, 3, 2)) / 0xff; |
456
|
25
|
|
|
|
|
41
|
$v = hex(substr($name, 5, 2)) / 0xff; |
457
|
|
|
|
|
|
|
} elsif (length($name) < 11) { |
458
|
0
|
|
|
|
|
0
|
$h = 360 * hex(substr($name, 1, 3)) / 0x1000; |
459
|
0
|
|
|
|
|
0
|
$s = hex(substr($name, 4, 3)) / 0xfff; |
460
|
0
|
|
|
|
|
0
|
$v = hex(substr($name, 7, 3)) / 0xfff; |
461
|
|
|
|
|
|
|
} else { |
462
|
2
|
|
|
|
|
12
|
$h = 360 * hex(substr($name, 1, 4)) / 0x10000; |
463
|
2
|
|
|
|
|
6
|
$s = hex(substr($name, 5, 4)) / 0xffff; |
464
|
2
|
|
|
|
|
7
|
$v = hex(substr($name, 9, 4)) / 0xffff; |
465
|
|
|
|
|
|
|
} |
466
|
|
|
|
|
|
|
|
467
|
28
|
|
|
|
|
71
|
return ($h,$s,$v); |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
# convert 3n (n=1..4) hex digits to LAB 0-100, -100-100 values |
471
|
|
|
|
|
|
|
# returns a triplet of values 0.0..100.0, 2x-100.0..100.0 |
472
|
|
|
|
|
|
|
sub labHexValues { |
473
|
0
|
|
|
0
|
0
|
0
|
my $name = lc(shift()); # & plus 3n hex digits |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
# if <3 digits, pad with '0' (silent error) |
476
|
|
|
|
|
|
|
# if not 3n digits, ignore extras (silent error) |
477
|
|
|
|
|
|
|
# if >12 digits, ignore extras (silent error) |
478
|
0
|
|
|
|
|
0
|
my ($ll,$aa,$bb); |
479
|
0
|
|
|
|
|
0
|
while (length($name) < 4) { $name .= '0'; } |
|
0
|
|
|
|
|
0
|
|
480
|
0
|
0
|
|
|
|
0
|
if (length($name) < 5) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
481
|
0
|
|
|
|
|
0
|
$ll = 100*hex(substr($name, 1, 1)) / 0xf; |
482
|
0
|
|
|
|
|
0
|
$aa = (200*hex(substr($name, 2, 1)) / 0xf) - 100; |
483
|
0
|
|
|
|
|
0
|
$bb = (200*hex(substr($name, 3, 1)) / 0xf) - 100; |
484
|
|
|
|
|
|
|
} elsif (length($name) < 8) { |
485
|
0
|
|
|
|
|
0
|
$ll = 100*hex(substr($name, 1, 2)) / 0xff; |
486
|
0
|
|
|
|
|
0
|
$aa = (200*hex(substr($name, 3, 2)) / 0xff) - 100; |
487
|
0
|
|
|
|
|
0
|
$bb = (200*hex(substr($name, 5, 2)) / 0xff) - 100; |
488
|
|
|
|
|
|
|
} elsif (length($name) < 11) { |
489
|
0
|
|
|
|
|
0
|
$ll = 100*hex(substr($name, 1, 3)) / 0xfff; |
490
|
0
|
|
|
|
|
0
|
$aa = (200*hex(substr($name, 4, 3)) / 0xfff) - 100; |
491
|
0
|
|
|
|
|
0
|
$bb = (200*hex(substr($name, 7, 3)) / 0xfff) - 100; |
492
|
|
|
|
|
|
|
} else { |
493
|
0
|
|
|
|
|
0
|
$ll = 100*hex(substr($name, 1, 4)) / 0xffff; |
494
|
0
|
|
|
|
|
0
|
$aa = (200*hex(substr($name, 5, 4)) / 0xffff) - 100; |
495
|
0
|
|
|
|
|
0
|
$bb = (200*hex(substr($name, 9, 4)) / 0xffff) - 100; |
496
|
|
|
|
|
|
|
} |
497
|
|
|
|
|
|
|
|
498
|
0
|
|
|
|
|
0
|
return ($ll,$aa,$bb); |
499
|
|
|
|
|
|
|
} |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
sub namecolor { |
502
|
66
|
|
|
66
|
0
|
156
|
my $name = shift; |
503
|
|
|
|
|
|
|
|
504
|
66
|
50
|
|
|
|
133
|
unless (ref $name) { |
505
|
66
|
|
|
|
|
129
|
$name = lc($name); |
506
|
66
|
|
|
|
|
198
|
$name =~ s/[^\#!%\&\$a-z0-9]//g; |
507
|
|
|
|
|
|
|
} |
508
|
|
|
|
|
|
|
|
509
|
66
|
100
|
|
|
|
317
|
if ($name =~ /^[a-z]/) { # name spec. |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
510
|
19
|
|
|
|
|
68
|
return namecolor($colors{$name}); |
511
|
|
|
|
|
|
|
} elsif ($name =~ /^#/) { # rgb spec. |
512
|
21
|
|
|
|
|
77
|
return floats5(rgbHexValues($name)); |
513
|
|
|
|
|
|
|
} elsif ($name =~ /^%/) { # cmyk spec. |
514
|
0
|
|
|
|
|
0
|
return floats5(cmykHexValues($name)); |
515
|
|
|
|
|
|
|
} elsif ($name =~ /^!/) { # hsv spec. |
516
|
26
|
|
|
|
|
60
|
return floats5(HSVtoRGB(hsvHexValues($name))); |
517
|
|
|
|
|
|
|
} elsif ($name =~ /^&/) { # hsl spec. |
518
|
0
|
|
|
|
|
0
|
return floats5(HSLtoRGB(hsvHexValues($name))); |
519
|
|
|
|
|
|
|
} else { # or it is a ref ? |
520
|
0
|
0
|
|
|
|
0
|
return floats5(@{$name || [0.5,0.5,0.5]}); |
|
0
|
|
|
|
|
0
|
|
521
|
|
|
|
|
|
|
} |
522
|
|
|
|
|
|
|
} |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
sub namecolor_cmyk { |
525
|
2
|
|
|
2
|
0
|
6
|
my $name = shift; |
526
|
|
|
|
|
|
|
|
527
|
2
|
50
|
|
|
|
7
|
unless (ref($name)) { |
528
|
2
|
|
|
|
|
7
|
$name = lc($name); |
529
|
2
|
|
|
|
|
6
|
$name =~ s/[^\#!%\&\$a-z0-9]//g; |
530
|
|
|
|
|
|
|
} |
531
|
|
|
|
|
|
|
|
532
|
2
|
50
|
|
|
|
19
|
if ($name =~ /^[a-z]/) { # name spec. |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
533
|
0
|
|
|
|
|
0
|
return namecolor_cmyk($colors{$name}); |
534
|
|
|
|
|
|
|
} elsif ($name =~ /^#/) { # rgb spec. |
535
|
0
|
|
|
|
|
0
|
return floats5(RGBasCMYK(rgbHexValues($name))); |
536
|
|
|
|
|
|
|
} elsif ($name =~ /^%/) { # cmyk spec. |
537
|
2
|
|
|
|
|
10
|
return floats5(cmykHexValues($name)); |
538
|
|
|
|
|
|
|
} elsif ($name =~ /^!/) { # hsv spec. |
539
|
0
|
|
|
|
|
0
|
return floats5(RGBasCMYK(HSVtoRGB(hsvHexValues($name)))); |
540
|
|
|
|
|
|
|
} elsif ($name =~ /^&/) { # hsl spec. |
541
|
0
|
|
|
|
|
0
|
return floats5(RGBasCMYK(HSLtoRGB(hsvHexValues($name)))); |
542
|
|
|
|
|
|
|
} else { # or it is a ref ? |
543
|
0
|
0
|
|
|
|
0
|
return floats5(RGBasCMYK(@{$name || [0.5,0.5,0.5]})); |
|
0
|
|
|
|
|
0
|
|
544
|
|
|
|
|
|
|
} |
545
|
|
|
|
|
|
|
} |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
# note that an angle of 360 degrees is treated as 0 radians by deg2rad. |
548
|
|
|
|
|
|
|
sub namecolor_lab { |
549
|
2
|
|
|
2
|
0
|
5
|
my $name = shift; |
550
|
|
|
|
|
|
|
|
551
|
2
|
50
|
|
|
|
7
|
unless (ref($name)) { |
552
|
2
|
|
|
|
|
15
|
$name = lc($name); |
553
|
2
|
|
|
|
|
11
|
$name =~ s/[^\#!%\&\$a-z0-9]//g; |
554
|
|
|
|
|
|
|
} |
555
|
|
|
|
|
|
|
|
556
|
2
|
50
|
|
|
|
26
|
if ($name =~ /^[a-z]/) { # name spec. |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
557
|
0
|
|
|
|
|
0
|
return namecolor_lab($colors{$name}); |
558
|
|
|
|
|
|
|
} elsif ($name =~ /^\$/) { # lab spec. |
559
|
0
|
|
|
|
|
0
|
return floats5(labHexValues($name)); |
560
|
|
|
|
|
|
|
} elsif ($name =~ /^#/) { # rgb spec. |
561
|
0
|
|
|
|
|
0
|
my ($h,$s,$v) = RGBtoHSV(rgbHexValues($name)); |
562
|
0
|
|
|
|
|
0
|
my $aa = cos(deg2rad($h)) * $s * 100; |
563
|
0
|
|
|
|
|
0
|
my $bb = sin(deg2rad($h)) * $s * 100; |
564
|
0
|
|
|
|
|
0
|
my $ll = 100 * $v; |
565
|
0
|
|
|
|
|
0
|
return floats5($ll,$aa,$bb); |
566
|
|
|
|
|
|
|
} elsif ($name =~ /^!/) { # hsv spec. |
567
|
|
|
|
|
|
|
# fake conversion |
568
|
0
|
|
|
|
|
0
|
my ($h,$s,$v) = hsvHexValues($name); |
569
|
0
|
|
|
|
|
0
|
my $aa = cos(deg2rad($h)) * $s * 100; |
570
|
0
|
|
|
|
|
0
|
my $bb = sin(deg2rad($h)) * $s * 100; |
571
|
0
|
|
|
|
|
0
|
my $ll = 100 * $v; |
572
|
0
|
|
|
|
|
0
|
return floats5($ll,$aa,$bb); |
573
|
|
|
|
|
|
|
} elsif ($name =~ /^&/) { # hsl spec. |
574
|
2
|
|
|
|
|
8
|
my ($h,$s,$v) = hsvHexValues($name); |
575
|
2
|
|
|
|
|
29
|
my $aa = cos(deg2rad($h)) * $s * 100; |
576
|
2
|
|
|
|
|
46
|
my $bb = sin(deg2rad($h)) * $s * 100; |
577
|
2
|
|
|
|
|
33
|
($h,$s,$v) = RGBtoHSV(HSLtoRGB($h,$s,$v)); |
578
|
2
|
|
|
|
|
6
|
my $ll = 100 * $v; |
579
|
2
|
|
|
|
|
6
|
return floats5($ll,$aa,$bb); |
580
|
|
|
|
|
|
|
} else { # or it is a ref ? |
581
|
0
|
0
|
|
|
|
0
|
my ($h,$s,$v) = RGBtoHSV(@{$name || [0.5,0.5,0.5]}); |
|
0
|
|
|
|
|
0
|
|
582
|
0
|
|
|
|
|
0
|
my $aa = cos(deg2rad($h)) * $s * 100; |
583
|
0
|
|
|
|
|
0
|
my $bb = sin(deg2rad($h)) * $s * 100; |
584
|
0
|
|
|
|
|
0
|
my $ll = 100 * $v; |
585
|
0
|
|
|
|
|
0
|
return floats5($ll,$aa,$bb); |
586
|
|
|
|
|
|
|
} |
587
|
|
|
|
|
|
|
} |
588
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
=head2 STREAM FILTERS |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
There are a number of functions here to handle stream filtering. |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
=cut |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
sub unfilter { |
596
|
7
|
|
|
7
|
0
|
21
|
my ($filter, $stream) = @_; |
597
|
|
|
|
|
|
|
|
598
|
7
|
50
|
|
|
|
19
|
if (defined $filter) { |
599
|
|
|
|
|
|
|
# we need to fix filter because it MAY be |
600
|
|
|
|
|
|
|
# an array BUT IT COULD BE only a name |
601
|
7
|
50
|
|
|
|
51
|
if (ref($filter) !~ /Array$/) { |
602
|
0
|
|
|
|
|
0
|
$filter = PDFArray($filter); |
603
|
|
|
|
|
|
|
} |
604
|
7
|
|
|
|
|
15
|
my @filts; |
605
|
7
|
|
|
|
|
14
|
my ($hasflate) = -1; |
606
|
7
|
|
|
|
|
14
|
my ($temp, $i, $temp1); |
607
|
|
|
|
|
|
|
|
608
|
7
|
|
|
|
|
31
|
@filts = map { ("PDF::Builder::Basic::PDF::Filter::" . $_->val())->new() } $filter->elements(); |
|
7
|
|
|
|
|
23
|
|
609
|
|
|
|
|
|
|
|
610
|
7
|
|
|
|
|
17
|
foreach my $f (@filts) { |
611
|
7
|
|
|
|
|
28
|
$stream = $f->infilt($stream, 1); |
612
|
|
|
|
|
|
|
} |
613
|
|
|
|
|
|
|
} |
614
|
|
|
|
|
|
|
|
615
|
7
|
|
|
|
|
50
|
return $stream; |
616
|
|
|
|
|
|
|
} |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
sub dofilter { |
619
|
4
|
|
|
4
|
0
|
13
|
my ($filter, $stream) = @_; |
620
|
|
|
|
|
|
|
|
621
|
4
|
50
|
|
|
|
20
|
if (defined $filter) { |
622
|
|
|
|
|
|
|
# we need to fix filter because it MAY be |
623
|
|
|
|
|
|
|
# an array BUT IT COULD BE only a name |
624
|
4
|
50
|
|
|
|
25
|
if (ref($filter) !~ /Array$/) { |
625
|
0
|
|
|
|
|
0
|
$filter = PDFArray($filter); |
626
|
|
|
|
|
|
|
} |
627
|
4
|
|
|
|
|
9
|
my @filts; |
628
|
4
|
|
|
|
|
6
|
my $hasflate = -1; |
629
|
4
|
|
|
|
|
9
|
my ($temp, $i, $temp1); |
630
|
|
|
|
|
|
|
|
631
|
4
|
|
|
|
|
17
|
@filts = map { ("PDF::Builder::Basic::PDF::Filter::" . $_->val())->new() } $filter->elements(); |
|
4
|
|
|
|
|
14
|
|
632
|
|
|
|
|
|
|
|
633
|
4
|
|
|
|
|
12
|
foreach my $f (@filts) { |
634
|
4
|
|
|
|
|
16
|
$stream = $f->outfilt($stream, 1); |
635
|
|
|
|
|
|
|
} |
636
|
|
|
|
|
|
|
} |
637
|
|
|
|
|
|
|
|
638
|
4
|
|
|
|
|
17
|
return $stream; |
639
|
|
|
|
|
|
|
} |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
=head2 PREDEFINED GLYPH-NAMES |
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
See the file C for a complete list. |
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
B You may notice that apart from the 'AGL/WGL4', names |
646
|
|
|
|
|
|
|
from the XML, (X)HTML and SGML specification sets have been included |
647
|
|
|
|
|
|
|
to enable interoperability towards PDF. |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
There are a number of functions here to handle various |
650
|
|
|
|
|
|
|
aspects of glyph identification. |
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
=cut |
653
|
|
|
|
|
|
|
|
654
|
|
|
|
|
|
|
sub nameByUni { |
655
|
512
|
|
|
512
|
0
|
626
|
my $e = shift; |
656
|
|
|
|
|
|
|
|
657
|
512
|
|
66
|
|
|
2004
|
return $u2n{$e} || sprintf('uni%04X', $e); |
658
|
|
|
|
|
|
|
} |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
sub uniByName { |
661
|
13109
|
|
|
13109
|
0
|
17476
|
my $e = shift; |
662
|
13109
|
50
|
|
|
|
21197
|
if ($e =~ /^uni([0-9A-F]{4})$/) { |
663
|
0
|
|
|
|
|
0
|
return hex($1); |
664
|
|
|
|
|
|
|
} |
665
|
13109
|
|
100
|
|
|
46462
|
return $n2u{$e} || undef; |
666
|
|
|
|
|
|
|
} |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
sub initNameTable { |
669
|
0
|
|
|
0
|
0
|
0
|
%u2n = %{$PDF::Builder::Resource::Glyphs::u2n}; |
|
0
|
|
|
|
|
0
|
|
670
|
0
|
|
|
|
|
0
|
%n2u = %{$PDF::Builder::Resource::Glyphs::n2u}; |
|
0
|
|
|
|
|
0
|
|
671
|
0
|
|
|
|
|
0
|
$pua = 0xE000; |
672
|
0
|
|
|
|
|
0
|
return; |
673
|
|
|
|
|
|
|
} |
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
sub defineName { |
676
|
0
|
|
|
0
|
0
|
0
|
my $name = shift; |
677
|
|
|
|
|
|
|
|
678
|
0
|
0
|
|
|
|
0
|
return $n2u{$name} if defined $n2u{$name}; |
679
|
|
|
|
|
|
|
|
680
|
0
|
|
|
|
|
0
|
$pua++ while defined $u2n{$pua}; |
681
|
|
|
|
|
|
|
|
682
|
0
|
|
|
|
|
0
|
$u2n{$pua} = $name; |
683
|
0
|
|
|
|
|
0
|
$n2u{$name} = $pua; |
684
|
|
|
|
|
|
|
|
685
|
0
|
|
|
|
|
0
|
return $pua; |
686
|
|
|
|
|
|
|
} |
687
|
|
|
|
|
|
|
|
688
|
|
|
|
|
|
|
=head2 PREDEFINED PAPER SIZES |
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
Dimensions are in points. |
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
=over |
693
|
|
|
|
|
|
|
|
694
|
|
|
|
|
|
|
=item @box_corners = paper_size($x1,$y1, $x2,$y2); |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
Returns an array ($x1,$y1, $x2,$y2) (full bounding box). |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
=item @box_corners = paper_size($x1,$y1); |
699
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
Returns an array (0,0, $x1,$y1) (half bounding box). |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
=item @box_corners = paper_size($media_name); |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
Returns an array (0,0, paper_width,paper_height) for the named media. |
705
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
=item @box_corners = paper_size($x1); |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
Returns an array (0,0, $x1,$x1) (single quadratic). |
709
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
Otherwise, array (0,0, 612,792) (US Letter dimensions) is returned. |
711
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
=cut |
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
sub page_size { |
715
|
226
|
|
|
226
|
0
|
635
|
my ($x1,$y1, $x2,$y2) = @_; |
716
|
|
|
|
|
|
|
|
717
|
226
|
100
|
|
|
|
1181
|
if (defined $x2) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
718
|
|
|
|
|
|
|
# full bbox |
719
|
23
|
|
|
|
|
89
|
return ($x1,$y1, $x2,$y2); |
720
|
|
|
|
|
|
|
} elsif (defined $y1) { |
721
|
|
|
|
|
|
|
# half bbox |
722
|
11
|
|
|
|
|
42
|
return (0,0, $x1,$y1); |
723
|
|
|
|
|
|
|
} elsif (defined $PaperSizes{lc $x1}) { |
724
|
|
|
|
|
|
|
# textual spec. |
725
|
191
|
|
|
|
|
352
|
return (0,0, @{$PaperSizes{lc $x1}}); |
|
191
|
|
|
|
|
803
|
|
726
|
|
|
|
|
|
|
} elsif ($x1 =~ /^[\d\.]+$/) { |
727
|
|
|
|
|
|
|
# single quadratic |
728
|
0
|
|
|
|
|
0
|
return(0,0, $x1,$x1); |
729
|
|
|
|
|
|
|
} else { |
730
|
|
|
|
|
|
|
# PDF default (US letter) |
731
|
1
|
|
|
|
|
5
|
return (0,0, 612,792); |
732
|
|
|
|
|
|
|
} |
733
|
|
|
|
|
|
|
} |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
=item %sizes = getPaperSizes(); |
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
Returns a hash containing the available paper size aliases as keys and |
738
|
|
|
|
|
|
|
their dimensions as a two-element array reference. |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
See the source of L for the complete list. |
741
|
|
|
|
|
|
|
|
742
|
|
|
|
|
|
|
=cut |
743
|
|
|
|
|
|
|
|
744
|
|
|
|
|
|
|
sub getPaperSizes { |
745
|
0
|
|
|
0
|
1
|
|
my %sizes = (); |
746
|
0
|
|
|
|
|
|
foreach my $type (keys %PaperSizes) { |
747
|
0
|
|
|
|
|
|
$sizes{$type} = [@{$PaperSizes{$type}}]; |
|
0
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
} |
749
|
0
|
|
|
|
|
|
return %sizes; |
750
|
|
|
|
|
|
|
} |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
=back |
753
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
=head2 STRING TO DIMENSION |
755
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
Convert a string "number [unit]" to the value in desired units. Units are |
757
|
|
|
|
|
|
|
case-insensitive (the input is first folded to lower case). |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
Supported units: mm, cm, in (inch), pt (Big point, 72/inch), ppt (printer's |
760
|
|
|
|
|
|
|
point, 72.27/inch), pc (pica, 6/inch), dd (Didot point, 67.5532/inch), and |
761
|
|
|
|
|
|
|
cc (Ciceros, 5.62943/inch). More can be added easily. |
762
|
|
|
|
|
|
|
Invalid units are a fatal error. |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
=over |
765
|
|
|
|
|
|
|
|
766
|
|
|
|
|
|
|
=item $value = str2dim($string, $type, $default_units); |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
C<$string> contains a number and optionally, a unit. Space(s) between the number |
769
|
|
|
|
|
|
|
and the unit are optional. E.g., '200', '35.2 mm', and '1.5in' are all allowable |
770
|
|
|
|
|
|
|
input strings. |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
C<$type> is for validation of the input $string's numeric value. The first |
773
|
|
|
|
|
|
|
character is B for an I is required (no decimal point), or B for |
774
|
|
|
|
|
|
|
other (floating point) numbers. Next is an optional B to indicate that an |
775
|
|
|
|
|
|
|
out-of-range input value is to be silently I to be within the given |
776
|
|
|
|
|
|
|
range (the default is to raise a fatal error). Finally, an optional I |
777
|
|
|
|
|
|
|
expression: {lower limit,upper limit}. The limits are either numbers or B<*> (to |
778
|
|
|
|
|
|
|
indicate +/- infinity (no limit) on that end of the range). B<{> is B<[> to say |
779
|
|
|
|
|
|
|
that the lower limit is I in the range, while B<(> says that the |
780
|
|
|
|
|
|
|
lower limit is I from the range. Likewise, B<}> is B<]> for |
781
|
|
|
|
|
|
|
I upper limit, and B<)> for I. The limits (and silent |
782
|
|
|
|
|
|
|
clamping, or fatal error if the input is out of range) are against the input |
783
|
|
|
|
|
|
|
value, before conversion to the output units. |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
Example types: |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
=over |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
=item C<'f(*,*)'> no limits (the default) -- all values OK |
790
|
|
|
|
|
|
|
|
791
|
|
|
|
|
|
|
=item C<'i(0,*)'> integer greater than 0 |
792
|
|
|
|
|
|
|
|
793
|
|
|
|
|
|
|
=item C<'fc[-3.2,7.86]'> a number between -3.2 and 7.86, with value clamped to |
794
|
|
|
|
|
|
|
be within that range (including the endpoints) |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
=back |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
C<$default_units> is a required string, giving the units that the input is |
799
|
|
|
|
|
|
|
converted to. For example, if the default units are 'pt', and the input string |
800
|
|
|
|
|
|
|
'2 in', the output value would be '144'. If the input string has no explicit |
801
|
|
|
|
|
|
|
units, it is assumed to be in the default units (no conversion is done). |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
=back |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
=cut |
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
# convert string to numeric, converting units to default unit |
808
|
|
|
|
|
|
|
# recognized units are mm, cm, in, pt, ppt (printer's point, 72.27/inch), pc |
809
|
|
|
|
|
|
|
# allow space between number and unit |
810
|
|
|
|
|
|
|
# TBD for floats being clamped and limit is not-inclusive, what value to clamp? |
811
|
|
|
|
|
|
|
# currently limit +/- 1.0 |
812
|
|
|
|
|
|
|
# if string is empty or all blank, return 0 |
813
|
|
|
|
|
|
|
sub str2dim { |
814
|
0
|
|
|
0
|
1
|
|
my ($string, $type, $defUnit) = @_; |
815
|
|
|
|
|
|
|
|
816
|
0
|
|
|
|
|
|
my ($defUnitIdx, $value, $unit, $unitIdx); |
817
|
|
|
|
|
|
|
# unit names, divisor to get inches |
818
|
|
|
|
|
|
|
# ppt = printer's (old) points, dd = didot ppoints, cc = ciceros |
819
|
0
|
|
|
|
|
|
my @units = ( 'mm', 'cm', 'in', 'pt', 'ppt', 'pc', |
820
|
|
|
|
|
|
|
'dd', 'cc' ); |
821
|
0
|
|
|
|
|
|
my @convert = ( 25.4, 2.54, 1, 72, 72.27, 6, |
822
|
|
|
|
|
|
|
67.5532, 5.62943 ); |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
# validate default unit |
825
|
0
|
|
|
|
|
|
$defUnit = lc($defUnit); |
826
|
0
|
|
|
|
|
|
for ($defUnitIdx = 0; $defUnitIdx < @units; $defUnitIdx++) { |
827
|
0
|
0
|
|
|
|
|
if ($units[$defUnitIdx] eq $defUnit) { last; } |
|
0
|
|
|
|
|
|
|
828
|
|
|
|
|
|
|
} |
829
|
|
|
|
|
|
|
# fell through? invalid default unit |
830
|
0
|
0
|
|
|
|
|
if ($defUnitIdx >= @units) { |
831
|
0
|
|
|
|
|
|
die "Error: Unknown default dimensional unit '$defUnit'\n"; |
832
|
|
|
|
|
|
|
} |
833
|
|
|
|
|
|
|
|
834
|
0
|
|
|
|
|
|
$string =~ s/\s//g; # remove all whitespace |
835
|
0
|
0
|
|
|
|
|
if ($string eq '') { return 0; } |
|
0
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
|
837
|
0
|
0
|
|
|
|
|
if ($string =~ m/^([.0-9-]+)$/i) { |
|
|
0
|
|
|
|
|
|
838
|
0
|
|
|
|
|
|
$value = $1; |
839
|
0
|
|
|
|
|
|
$unit = ''; |
840
|
|
|
|
|
|
|
} elsif ($string =~ m/^([.0-9-]+)(.*)$/i) { |
841
|
0
|
|
|
|
|
|
$value = $1; |
842
|
0
|
|
|
|
|
|
$unit = lc($2); |
843
|
|
|
|
|
|
|
} else { |
844
|
0
|
|
|
|
|
|
die "Error: Unable to decipher dimensional string '$string'\n"; |
845
|
|
|
|
|
|
|
} |
846
|
|
|
|
|
|
|
# is unit good? leaves unitIdx as index into arrays |
847
|
0
|
0
|
|
|
|
|
if ($unit ne '') { |
848
|
0
|
|
|
|
|
|
for ($unitIdx = 0; $unitIdx < @units; $unitIdx++) { |
849
|
0
|
0
|
|
|
|
|
if ($units[$unitIdx] eq $unit) { last; } |
|
0
|
|
|
|
|
|
|
850
|
|
|
|
|
|
|
} |
851
|
|
|
|
|
|
|
# fell through? invalid unit |
852
|
0
|
0
|
|
|
|
|
if ($unitIdx >= @units) { |
853
|
0
|
|
|
|
|
|
die "Error: Unknown dimensional unit '$unit' in '$string'\n"; |
854
|
|
|
|
|
|
|
} |
855
|
|
|
|
|
|
|
} # else is bare number |
856
|
|
|
|
|
|
|
|
857
|
|
|
|
|
|
|
# validate number. if type = i (int), only integer permitted |
858
|
|
|
|
|
|
|
# if type = f (float), any valid float OK (no E notation) |
859
|
|
|
|
|
|
|
# in either case, must not be negative |
860
|
|
|
|
|
|
|
# note: no range checking (might be overflow) |
861
|
0
|
0
|
|
|
|
|
if ($value =~ m/^-/) { die "Error: Dimensional value '$value $unit' cannot be negative\n"; } |
|
0
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
|
863
|
0
|
|
|
|
|
|
$type = lc($type); |
864
|
0
|
|
|
|
|
|
$type =~ s/\s//g; |
865
|
0
|
0
|
|
|
|
|
if ($type =~ m/^[fi]/) { |
866
|
|
|
|
|
|
|
# OK type |
867
|
|
|
|
|
|
|
} else { |
868
|
0
|
|
|
|
|
|
die "Error: Invalid type for dimension. Must be 'f' or 'i'\n"; |
869
|
|
|
|
|
|
|
} |
870
|
0
|
0
|
|
|
|
|
if ($type =~ m/^i/) { |
871
|
0
|
0
|
|
|
|
|
if (!($value =~ m/^\d+$/)) { |
872
|
0
|
|
|
|
|
|
die "Error: $value is not a valid integer\n"; |
873
|
|
|
|
|
|
|
} |
874
|
|
|
|
|
|
|
} else { # presumably f (float) |
875
|
0
|
0
|
0
|
|
|
|
if (!($value =~ m/^\.\d+$/ || |
|
|
|
0
|
|
|
|
|
876
|
|
|
|
|
|
|
$value =~ m/^\d+\.\d+$/ || |
877
|
|
|
|
|
|
|
$value =~ m/^\d+\.?$/)) { |
878
|
0
|
|
|
|
|
|
die "Error: $value is not a valid float\n"; |
879
|
|
|
|
|
|
|
} |
880
|
|
|
|
|
|
|
} |
881
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
# $value is a legit number, $unit is OK unit. convert if unit different |
883
|
|
|
|
|
|
|
# from default unit |
884
|
0
|
0
|
0
|
|
|
|
if ($unit eq '' || $unit eq $defUnit) { |
885
|
|
|
|
|
|
|
# assume bare number is default unit |
886
|
|
|
|
|
|
|
} else { |
887
|
|
|
|
|
|
|
# convert to inches, and back to defUnit |
888
|
0
|
|
|
|
|
|
$value /= $convert[$unitIdx]; |
889
|
0
|
|
|
|
|
|
$value *= $convert[$defUnitIdx]; |
890
|
|
|
|
|
|
|
} |
891
|
|
|
|
|
|
|
|
892
|
|
|
|
|
|
|
# range check and optionally clamp: look at remainder of type |
893
|
0
|
|
|
|
|
|
$type = substr($type, 1); |
894
|
0
|
0
|
|
|
|
|
if ($type ne '') { |
895
|
|
|
|
|
|
|
# format is optional c (for clamp) |
896
|
|
|
|
|
|
|
# [ or ( for lower value is included or excluded from range |
897
|
|
|
|
|
|
|
# lower value or * (- infinity) |
898
|
|
|
|
|
|
|
# comma , |
899
|
|
|
|
|
|
|
# upper value or * (+ infinity) |
900
|
|
|
|
|
|
|
# ] or ) for upper value is included or excluded from range |
901
|
0
|
|
|
|
|
|
my $clamp = 0; # default to False (error if out of range) |
902
|
0
|
0
|
|
|
|
|
if ($type =~ m/^c/) { |
903
|
0
|
|
|
|
|
|
$clamp = 1; |
904
|
0
|
|
|
|
|
|
$type = substr($type, 1); # MUST be at least 5 more char |
905
|
|
|
|
|
|
|
} |
906
|
|
|
|
|
|
|
|
907
|
|
|
|
|
|
|
# get lower and upper bounds |
908
|
0
|
|
|
|
|
|
my $lbInf = 1; # * for value T |
909
|
0
|
|
|
|
|
|
my $ubInf = 1; # * for value T |
910
|
0
|
|
|
|
|
|
my ($lb,$ub); # non-* values |
911
|
0
|
|
|
|
|
|
my $lbInc = 0; # [ include T, ( include F |
912
|
0
|
|
|
|
|
|
my $ubInc = 0; # ] include T, ) include F |
913
|
0
|
0
|
|
|
|
|
if ($type =~ m/^([\[\(])([^,]+),([^\]\)]+)([\]\)])$/) { |
914
|
0
|
|
|
|
|
|
$lbInc = ($1 eq '['); |
915
|
0
|
|
|
|
|
|
$lbInf = ($2 eq '*'); |
916
|
0
|
|
|
|
|
|
$ubInf = ($3 eq '*'); |
917
|
0
|
|
|
|
|
|
$ubInc = ($4 eq ']'); |
918
|
0
|
0
|
|
|
|
|
if (!$lbInf) { |
919
|
0
|
|
|
|
|
|
$lb = $2; |
920
|
|
|
|
|
|
|
# must be numeric. don't care int/float |
921
|
0
|
0
|
0
|
|
|
|
if ($lb =~ m/^-?\.\d+$/ || |
|
|
|
0
|
|
|
|
|
922
|
|
|
|
|
|
|
$lb =~ m/^-?\d+\.\d+/ || |
923
|
|
|
|
|
|
|
$lb =~ m/^-?\d+\.?$/ ) { |
924
|
|
|
|
|
|
|
# is numeric |
925
|
0
|
0
|
0
|
|
|
|
if ($lbInc && $value < $lb) { |
926
|
0
|
0
|
|
|
|
|
if ($clamp) { $value = $lb; } |
|
0
|
|
|
|
|
|
|
927
|
0
|
|
|
|
|
|
else { die "Error: Value $value is smaller than the limit $lb\n"; } |
928
|
|
|
|
|
|
|
} |
929
|
0
|
0
|
0
|
|
|
|
if (!$lbInc && $value <= $lb) { |
930
|
0
|
0
|
|
|
|
|
if ($clamp) { $value = $lb+1; } |
|
0
|
|
|
|
|
|
|
931
|
0
|
|
|
|
|
|
else { die "Error: Value $value is smaller or equal to the limit $lb\n"; } |
932
|
|
|
|
|
|
|
} |
933
|
|
|
|
|
|
|
} else { |
934
|
0
|
|
|
|
|
|
die "Error: Range lower bound '$lb' not * or number\n"; |
935
|
|
|
|
|
|
|
} |
936
|
|
|
|
|
|
|
} # if lb is -inf, don't care what value is |
937
|
0
|
0
|
|
|
|
|
if (!$ubInf) { |
938
|
0
|
|
|
|
|
|
$ub = $3; |
939
|
|
|
|
|
|
|
# must be numeric. don't care int/float |
940
|
0
|
0
|
0
|
|
|
|
if ($ub =~ m/^-?\.\d+$/ || |
|
|
|
0
|
|
|
|
|
941
|
|
|
|
|
|
|
$ub =~ m/^-?\d+\.\d+/ || |
942
|
|
|
|
|
|
|
$ub =~ m/^-?\d+\.?$/ ) { |
943
|
|
|
|
|
|
|
# is numeric |
944
|
0
|
0
|
0
|
|
|
|
if ($ubInc && $value > $ub) { |
945
|
0
|
0
|
|
|
|
|
if ($clamp) { $value = $ub; } |
|
0
|
|
|
|
|
|
|
946
|
0
|
|
|
|
|
|
else { die "Error: Value $value is larger than the limit $ub\n"; } |
947
|
|
|
|
|
|
|
} |
948
|
0
|
0
|
0
|
|
|
|
if (!$ubInc && $value >= $ub) { |
949
|
0
|
0
|
|
|
|
|
if ($clamp) { $value = $ub-1; } |
|
0
|
|
|
|
|
|
|
950
|
0
|
|
|
|
|
|
else { die "Error: Value $value is larger or equal to the limit $ub\n"; } |
951
|
|
|
|
|
|
|
} |
952
|
|
|
|
|
|
|
} else { |
953
|
0
|
|
|
|
|
|
die "Error: Range upper bound '$ub' not * or number\n"; |
954
|
|
|
|
|
|
|
} |
955
|
|
|
|
|
|
|
} # if ub is +inf, don't care what value is |
956
|
|
|
|
|
|
|
|
957
|
|
|
|
|
|
|
} else { |
958
|
0
|
|
|
|
|
|
die "Error: Invalid range specification '$type'\n"; |
959
|
|
|
|
|
|
|
} |
960
|
|
|
|
|
|
|
} |
961
|
|
|
|
|
|
|
|
962
|
0
|
|
|
|
|
|
return $value; |
963
|
|
|
|
|
|
|
} # end of str2dim() |
964
|
|
|
|
|
|
|
|
965
|
|
|
|
|
|
|
1; |
966
|
|
|
|
|
|
|
|
967
|
|
|
|
|
|
|
__END__ |