File Coverage

blib/lib/PDF/API2/Util.pm

Criterion	Covered	Total	%
statement	174	385	45.1
branch	47	134	35.0
condition	6	9	66.6
subroutine	32	54	59.2
pod	0	39	0.0
total	259	621	41.7

package PDF::API2::Util;

use strict;
no warnings qw[ recursion uninitialized ];

our $VERSION = '2.045'; # VERSION

BEGIN {
    use Encode qw(:all);
    use Math::Trig;
    use List::Util qw(min max);
    use PDF::API2::Basic::PDF::Utils;
    use PDF::API2::Basic::PDF::Filter;
    use PDF::API2::Resource::Colors;
    use PDF::API2::Resource::Glyphs;
    use PDF::API2::Resource::PaperSizes;
    use POSIX qw( HUGE_VAL floor );

    use vars qw(
        @ISA
        @EXPORT
        @EXPORT_OK
        %colors
        $key_var
        %u2n
        %n2u
        $pua
        %PaperSizes
    );

    use Exporter;
    @ISA = qw(Exporter);
    @EXPORT = qw(
        pdfkey
        float floats floats5 intg intgs
        mMin mMax
        HSVtoRGB RGBtoHSV HSLtoRGB RGBtoHSL RGBtoLUM
        namecolor namecolor_cmyk namecolor_lab optInvColor defineColor
        dofilter unfilter
        nameByUni uniByName initNameTable defineName
        page_size
        getPaperSizes
    );
    @EXPORT_OK = qw(
        pdfkey
        digest digestx digest16 digest32
        float floats floats5 intg intgs
        mMin mMax
        cRGB cRGB8 RGBasCMYK
        HSVtoRGB RGBtoHSV HSLtoRGB RGBtoHSL RGBtoLUM
        namecolor namecolor_cmyk namecolor_lab optInvColor defineColor
        dofilter unfilter
        nameByUni uniByName initNameTable defineName
        page_size
    );

    %colors = PDF::API2::Resource::Colors->get_colors();
    %PaperSizes = PDF::API2::Resource::PaperSizes->get_paper_sizes();

    no warnings qw[ recursion uninitialized ];

    $key_var = 'CBA';

    $pua = 0xE000;

    %u2n = %{$PDF::API2::Resource::Glyphs::u2n};
    %n2u = %{$PDF::API2::Resource::Glyphs::n2u};
}

sub pdfkey {
    return $PDF::API2::Util::key_var++;
}

sub digestx {
    my $len = shift();
    my $mask = $len - 1;
    my $ddata = join('', @_);
    my $mdkey = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789gT';
    my $xdata = '0' x $len;
    my $off = 0;
    foreach my $set (0 .. (length($ddata) << 1)) {
        $off += vec($ddata, $set, 4);
        $off += vec($xdata, ($set & $mask), 8);
        vec($xdata, ($set & ($mask << 1 | 1)), 4) = vec($mdkey, ($off & 0x7f), 4);
    }

    # foreach $set (0 .. $mask) {
    #     vec($xdata, $set, 8) = (vec($xdata, $set, 8) & 0x7f) | 0x40;
    # }

    # $off = 0;
    # foreach $set (0 .. $mask) {
    #     $off += vec($xdata, $set, 8);
    #     vec($xdata, $set, 8) = vec($mdkey, ($off & 0x3f), 8);
    # }

    return $xdata;
}

sub digest {
    return digestx(32, @_);
}

sub digest16 {
    return digestx(16, @_);
}

sub digest32 {
    return digestx(32, @_);
}

sub xlog10 {
    my $n = shift();
    if ($n) {
        return log(abs($n)) / log(10);
    }
    else {
        return 0;
    }
}

sub float {
    my $f = shift();
    my $mxd = shift() || 4;
    $f = 0 if abs($f) < 0.0000000000000001;
    my $ad = floor(xlog10($f) - $mxd);
    if (abs($f - int($f)) < (10 ** (-$mxd))) {
        # just in case we have an integer
        return sprintf('%i', $f);
    }
    elsif ($ad > 0) {
        my $value = sprintf('%f', $f);
        # Remove trailing zeros
        $value =~ s/(\.\d*?)0+$/$1/;
        $value =~ s/\.$//;
        return $value;
    }
    else {
        my $value = sprintf('%.*f', abs($ad), $f);
        # Remove trailing zeros
        $value =~ s/(\.\d*?)0+$/$1/;
        $value =~ s/\.$//;
        return $value;
    }
}
sub floats { return map { float($_) } @_; }
sub floats5 { return map { float($_, 5) } @_; }

sub intg {
    my $f = shift();
    return sprintf('%i', $f);
}
sub intgs { return map { intg($_) } @_; }

sub mMin {
    my $n = HUGE_VAL();
    map { $n = ($n > $_) ? $_ : $n } @_;
    return $n;
}

sub mMax {
    my $n = -HUGE_VAL();
    map { $n = ($n < $_) ? $_ : $n } @_;
    return $n;
}

sub cRGB {
    my @cmy = (map { 1 - $_ } @_);
    my $k = mMin(@cmy);
    return (map { $_ - $k } @cmy), $k;
}

sub cRGB8 {
    return cRGB(map { $_ / 255 } @_);
}

sub RGBtoLUM {
    my ($r, $g, $b) = @_;
    return $r * 0.299 + $g * 0.587 + $b * 0.114;
}

sub RGBasCMYK {
    my @rgb = @_;
    my @cmy = map { 1 - $_ } @rgb;
    my $k = mMin(@cmy) * 0.44;
    return (map { $_ - $k } @cmy), $k;
}

sub HSVtoRGB {
    my ($h, $s, $v) = @_;
    my ($r, $g, $b, $i, $f, $p, $q, $t);

    if ($s == 0) {
        # achromatic (grey)
        return ($v, $v, $v);
    }

    $h %= 360;
    $h /= 60;       ## sector 0 to 5
    $i = POSIX::floor($h);
    $f = $h - $i;   ## factorial part of h
    $p = $v * (1 - $s);
    $q = $v * (1 - $s * $f);
    $t = $v * (1 - $s * (1 - $f));

    if ($i < 1) {
        $r = $v;
        $g = $t;
        $b = $p;
    }
    elsif ($i < 2) {
        $r = $q;
        $g = $v;
        $b = $p;
    }
    elsif ($i < 3) {
        $r = $p;
        $g = $v;
        $b = $t;
    }
    elsif ($i < 4) {
        $r = $p;
        $g = $q;
        $b = $v;
    }
    elsif ($i < 5) {
        $r = $t;
        $g = $p;
        $b = $v;
    }
    else {
        $r = $v;
        $g = $p;
        $b = $q;
    }

    return ($r, $g, $b);
}

sub RGBquant {
    my ($q1, $q2, $h) = @_;
    while ($h < 0){
        $h += 360;
    }
    $h %= 360;
    if ($h < 60) {
        return $q1 + (($q2 - $q1) * $h / 60);
    }
    elsif ($h < 180) {
        return $q2;
    }
    elsif ($h < 240) {
        return $q1 + (($q2 - $q1) * (240 - $h) / 60);
    }
    else {
        return $q1;
    }
}

sub RGBtoHSV {
    my ($r, $g, $b) = @_;
    my ($h, $s, $v, $min, $max, $delta);

    $min = mMin($r, $g, $b);
    $max = mMax($r, $g, $b);

    $v = $max;

    $delta = $max - $min;

    if ($delta > 0.000000001) {
        $s = $delta / $max;
    }
    else {
        $s = 0;
        $h = 0;
        return ($h, $s, $v);
    }

    if ($r == $max) {
        $h = ($g - $b) / $delta;
    }
    elsif ($g == $max) {
        $h = 2 + ($b - $r) / $delta;
    }
    else {
        $h = 4 + ($r - $g) / $delta;
    }
    $h *= 60;
    if ($h < 0) {
        $h += 360;
    }
    return ($h, $s, $v);
}

sub RGBtoHSL {
    my ($r, $g, $b) = @_;
    my ($h, $s, $v, $l, $min, $max, $delta);

    $min = mMin($r, $g, $b);
    $max = mMax($r, $g, $b);
    ($h, $s, $v) = RGBtoHSV($r, $g, $b);
    $l = ($max + $min) / 2.0;
    $delta = $max - $min;
    if ($delta < 0.00000000001) {
        return (0, 0, $l);
    }
    else {
        if ($l <= 0.5) {
            $s = $delta / ($max + $min);
        }
        else {
            $s = $delta / (2 - $max - $min);
        }
    }
    return ($h, $s, $l);
}

sub HSLtoRGB {
    my ($h, $s, $l, $r, $g, $b, $p1, $p2) = @_;
    if ($l <= 0.5) {
        $p2 = $l * (1 + $s);
    }
    else {
        $p2 = $l + $s - ($l * $s);
    }
    $p1 = 2 * $l - $p2;
    if ($s < 0.0000000000001) {
        $r = $g = $b = $l;
    }
    else {
        $r = RGBquant($p1, $p2, $h + 120);
        $g = RGBquant($p1, $p2, $h);
        $b = RGBquant($p1, $p2, $h - 120);
    }
    return ($r, $g, $b);
}

sub optInvColor {
    my ($r, $g, $b) = @_;

    my $ab = (0.2 * $r) + (0.7 * $g) + (0.1 * $b);

    if ($ab > 0.45) {
        return (0, 0, 0);
    }
    else {
        return (1, 1, 1);
    }
}

sub defineColor {
    my ($name, $mx, $r, $g, $b) = @_;
    $colors{$name} ||= [ map {$_ / $mx} ($r, $g, $b) ];
    return $colors{$name};
}

sub rgbHexValues {
    my $name = lc(shift());
    my ($r, $g, $b);
    if (length($name) < 5) {     # zb. #fa4,          #cf0
        $r = hex(substr($name, 1, 1)) / 0xf;
        $g = hex(substr($name, 2, 1)) / 0xf;
        $b = hex(substr($name, 3, 1)) / 0xf;
    }
    elsif (length($name) < 8) {  # zb. #ffaa44,       #ccff00
        $r = hex(substr($name, 1, 2)) / 0xff;
        $g = hex(substr($name, 3, 2)) / 0xff;
        $b = hex(substr($name, 5, 2)) / 0xff;
    }
    elsif(length($name) < 11) {  # zb. #fffaaa444,    #cccfff000
        $r = hex(substr($name, 1, 3)) / 0xfff;
        $g = hex(substr($name, 4, 3)) / 0xfff;
        $b = hex(substr($name, 7, 3)) / 0xfff;
    }
    else {                       # zb. #ffffaaaa4444, #ccccffff0000
        $r = hex(substr($name, 1, 4)) / 0xffff;
        $g = hex(substr($name, 5, 4)) / 0xffff;
        $b = hex(substr($name, 9, 4)) / 0xffff;
    }
    return ($r, $g, $b);
}

sub cmykHexValues {
    my $name = lc(shift());
    my ($c, $m, $y, $k);
    if (length($name) < 6) {     # zb. %cmyk
        $c = hex(substr($name, 1, 1)) / 0xf;
        $m = hex(substr($name, 2, 1)) / 0xf;
        $y = hex(substr($name, 3, 1)) / 0xf;
        $k = hex(substr($name, 4, 1)) / 0xf;
    }
    elsif (length($name) < 10) { # zb. %ccmmyykk
        $c = hex(substr($name, 1, 2)) / 0xff;
        $m = hex(substr($name, 3, 2)) / 0xff;
        $y = hex(substr($name, 5, 2)) / 0xff;
        $k = hex(substr($name, 7, 2)) / 0xff;
    }
    elsif (length($name) < 14) { # zb. %cccmmmyyykkk
        $c = hex(substr($name, 1, 3)) / 0xfff;
        $m = hex(substr($name, 4, 3)) / 0xfff;
        $y = hex(substr($name, 7, 3)) / 0xfff;
        $k = hex(substr($name, 10, 3)) / 0xfff;
    }
    else {                       # zb. %ccccmmmmyyyykkkk
        $c = hex(substr($name, 1, 4)) / 0xffff;
        $m = hex(substr($name, 5, 4)) / 0xffff;
        $y = hex(substr($name, 9, 4)) / 0xffff;
        $k = hex(substr($name, 13, 4)) / 0xffff;
    }
    return ($c, $m, $y, $k);
}

sub hsvHexValues {
    my $name = lc(shift());
    my ($h, $s, $v);
    if (length($name) < 5) {
        $h = 360 * hex(substr($name, 1, 1)) / 0x10;
        $s = hex(substr($name, 2, 1)) / 0xf;
        $v = hex(substr($name, 3, 1)) / 0xf;
    }
    elsif (length($name) < 8) {
        $h = 360 * hex(substr($name, 1, 2)) / 0x100;
        $s = hex(substr($name, 3, 2)) / 0xff;
        $v = hex(substr($name, 5, 2)) / 0xff;
    }
    elsif (length($name) < 11) {
        $h = 360 * hex(substr($name, 1, 3)) / 0x1000;
        $s = hex(substr($name, 4, 3)) / 0xfff;
        $v = hex(substr($name, 7, 3)) / 0xfff;
    }
    else {
        $h = 360 * hex(substr($name, 1, 4)) / 0x10000;
        $s = hex(substr($name, 5, 4)) / 0xffff;
        $v = hex(substr($name, 9, 4)) / 0xffff;
    }
    return ($h, $s, $v);
}

sub labHexValues {
    my $name = lc(shift());
    my ($l, $a, $b);
    if (length($name) < 5) {
        $l =  100 * hex(substr($name, 1, 1)) / 0xf;
        $a = (200 * hex(substr($name, 2, 1)) / 0xf) - 100;
        $b = (200 * hex(substr($name, 3, 1)) / 0xf) - 100;
    }
    elsif (length($name) < 8) {
        $l =  100 * hex(substr($name, 1, 2)) / 0xff;
        $a = (200 * hex(substr($name, 3, 2)) / 0xff) - 100;
        $b = (200 * hex(substr($name, 5, 2)) / 0xff) - 100;
    }
    elsif (length($name) < 11) {
        $l =  100 * hex(substr($name, 1, 3)) / 0xfff;
        $a = (200 * hex(substr($name, 4, 3)) / 0xfff) - 100;
        $b = (200 * hex(substr($name, 7, 3)) / 0xfff) - 100;
    }
    else {
        $l =  100 * hex(substr($name, 1, 4)) / 0xffff;
        $a = (200 * hex(substr($name, 5, 4)) / 0xffff) - 100;
        $b = (200 * hex(substr($name, 9, 4)) / 0xffff) - 100;
    }

    return ($l, $a, $b);
}

sub namecolor {
    my $name = shift();
    unless (ref($name)) {
        $name = lc($name);
        $name =~ s/[^\#!%\&\$a-z0-9]//g;
    }
    if ($name =~ /^[a-z]/) { # name spec.
        return namecolor($colors{$name});
    }
    elsif ($name =~ /^#/) { # rgb spec.
        return floats5(rgbHexValues($name));
    }
    elsif ($name =~ /^%/) { # cmyk spec.
        return floats5(cmykHexValues($name));
    }
    elsif ($name =~ /^!/) { # hsv spec.
        return floats5(HSVtoRGB(hsvHexValues($name)));
    }
    elsif ($name =~ /^&/) { # hsl spec.
        return floats5(HSLtoRGB(hsvHexValues($name)));
    }
    else { # or it is a ref ?
        return floats5(@{$name || [0.5, 0.5, 0.5]});
    }
}

sub namecolor_cmyk {
    my $name = shift();
    unless (ref($name)) {
        $name = lc($name);
        $name =~ s/[^\#!%\&\$a-z0-9]//g;
    }
    if ($name =~ /^[a-z]/) { # name spec.
        return namecolor_cmyk($colors{$name});
    }
    elsif ($name =~ /^#/) { # rgb spec.
        return floats5(RGBasCMYK(rgbHexValues($name)));
    }
    elsif ($name =~ /^%/) { # cmyk spec.
        return floats5(cmykHexValues($name));
    }
    elsif ($name =~ /^!/) { # hsv spec.
        return floats5(RGBasCMYK(HSVtoRGB(hsvHexValues($name))));
    }
    elsif ($name =~ /^&/) { # hsl spec.
        return floats5(RGBasCMYK(HSLtoRGB(hsvHexValues($name))));
    }
    else { # or it is a ref ?
        return floats5(RGBasCMYK(@{$name || [0.5, 0.5, 0.5]}));
    }
}

sub namecolor_lab {
    my $name = shift();
    unless (ref($name)) {
        $name = lc($name);
        $name =~ s/[^\#!%\&\$a-z0-9]//g;
    }
    if ($name =~ /^[a-z]/) { # name spec.
        return namecolor_lab($colors{$name});
    }
    elsif ($name =~ /^\$/) { # lab spec.
        return floats5(labHexValues($name));
    }
    elsif ($name =~ /^#/) { # rgb spec.
        my ($h, $s, $v) = RGBtoHSV(rgbHexValues($name));
        my $a = cos(deg2rad($h)) * $s * 100;
        my $b = sin(deg2rad($h)) * $s * 100;
        my $l = 100 * $v;
        return floats5($l,$a,$b);
    }
    elsif ($name =~ /^!/) { # hsv spec.
        # fake conversion
        my ($h, $s, $v) = hsvHexValues($name);
        my $a = cos(deg2rad($h)) * $s * 100;
        my $b = sin(deg2rad($h)) * $s * 100;
        my $l = 100 * $v;
        return floats5($l,$a,$b);
    }
    elsif ($name =~ /^&/) { # hsl spec.
        my ($h, $s, $v) = hsvHexValues($name);
        my $a = cos(deg2rad($h)) * $s * 100;
        my $b = sin(deg2rad($h)) * $s * 100;
        ($h, $s, $v) = RGBtoHSV(HSLtoRGB($h, $s, $v));
        my $l = 100 * $v;
        return floats5($l,$a,$b);
    }
    else { # or it is a ref ?
        my ($h, $s, $v) = RGBtoHSV(@{$name || [0.5, 0.5, 0.5]});
        my $a = cos(deg2rad($h)) * $s * 100;
        my $b = sin(deg2rad($h)) * $s * 100;
        my $l = 100 * $v;
        return floats5($l,$a,$b);
    }
}

sub unfilter {
    my ($filter, $stream) = @_;

    if (defined $filter) {
        # we need to fix filter because it MAY be
        # an array BUT IT COULD BE only a name
        if (ref($filter) !~ /Array$/) {
            $filter = PDFArray($filter);
        }
        my @filts;
        my ($hasflate) = -1;
        my ($temp, $i, $temp1);

        @filts = map { ("PDF::API2::Basic::PDF::Filter::" . $_->val())->new() } $filter->elements();

        foreach my $f (@filts) {
            $stream = $f->infilt($stream, 1);
        }
    }

    return $stream;
}

sub dofilter {
    my ($filter, $stream) = @_;

    if (defined $filter) {
        # we need to fix filter because it MAY be
        # an array BUT IT COULD BE only a name
        if (ref($filter) !~ /Array$/) {
            $filter = PDFArray($filter);
        }
        my @filts;
        my $hasflate = -1;
        my ($temp, $i, $temp1);

        @filts = map { ("PDF::API2::Basic::PDF::Filter::" . $_->val())->new() } $filter->elements();

        foreach my $f (@filts) {
            $stream = $f->outfilt($stream, 1);
        }
    }

    return $stream;
}

sub nameByUni {
    my $e = shift();
    return $u2n{$e} || sprintf('uni%04X', $e);
}

sub uniByName {
    my $e = shift();
    if ($e =~ /^uni([0-9A-F]{4})$/) {
        return hex($1);
    }
    return $n2u{$e} || undef;
}

sub initNameTable {
    %u2n = %{$PDF::API2::Resource::Glyphs::u2n};
    %n2u = %{$PDF::API2::Resource::Glyphs::n2u};
    $pua = 0xE000;
    return;
}

sub defineName {
    my $name = shift();
    return $n2u{$name} if defined $n2u{$name};

    $pua++ while defined $u2n{$pua};

    $u2n{$pua} = $name;
    $n2u{$name} = $pua;

    return $pua;
}

sub page_size {
    my ($x1, $y1, $x2, $y2) = @_;

    # full bbox
    if (defined $x2) {
        return ($x1, $y1, $x2, $y2);
    }

    # half bbox
    elsif (defined $y1) {
        return (0, 0, $x1, $y1);
    }

    # textual spec.
    elsif (defined $PaperSizes{lc $x1}) {
        return (0, 0, @{$PaperSizes{lc $x1}});
    }

    # single quadratic
    elsif ($x1 =~ /^[\d\.]+$/) {
        return(0, 0, $x1, $x1);
    }

    # pdf default.
    else {
        return (0, 0, 612, 792);
    }
}

sub getPaperSizes {
    my %sizes = ();
    foreach my $type (keys %PaperSizes) {
        $sizes{$type} = [@{$PaperSizes{$type}}];
    }
    return %sizes;
}

1;