File Coverage

blib/lib/PDF/Builder/Util.pm
Criterion Covered Total %
statement 230 471 48.8
branch 73 192 38.0
condition 6 42 14.2
subroutine 37 54 68.5
pod 2 40 5.0
total 348 799 43.5


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__