File Coverage

blib/lib/PDF/Builder/Util.pm
Criterion Covered Total %
statement 214 471 45.4
branch 71 192 36.9
condition 6 42 14.2
subroutine 37 54 68.5
pod 2 40 5.0
total 330 799 41.3


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