File Coverage

blib/lib/Perlbal/Plugin/Palimg.pm

Criterion	Covered	Total	%
statement	11	154	7.1
branch	0	66	0.0
condition	0	9	0.0
subroutine	5	17	29.4
pod	0	4	0.0
total	16	250	6.4

###########################################################################
# Palimg plugin that allows Perlbal to serve palette altered images
###########################################################################

package Perlbal::Plugin::Palimg;

use strict;
use warnings;
no  warnings qw(deprecated);

# called when we're being added to a service
sub register {
    my ($class, $svc) = @_;

    # verify that an incoming request is a palimg request
    $svc->register_hook('Palimg', 'start_serve_request', sub {
        my Perlbal::ClientHTTPBase $obj = $_[0];
        return 0 unless $obj;
        my Perlbal::HTTPHeaders $hd = $obj->{req_headers};
        my $uriref = $_[1];
        return 0 unless $uriref;

        # if this is palimg, peel off the requested modifications and put in headers
        return 0 unless $$uriref =~ m!^/palimg/(.+)\.(\w+)(.*)$!;
        my ($fn, $ext, $extra) = ($1, $2, $3);
        return 0 unless $extra;
        my ($palspec) = $extra =~ m!^/p(.+)$!;
        return 0 unless $fn && $palspec;

        # must be ok, setup for it
        $$uriref = "/palimg/$fn.$ext";
        $obj->{scratch}->{palimg} = [ $ext, $palspec ];
        return 0;
    });

    # actually serve a palimg
    $svc->register_hook('Palimg', 'start_send_file', sub {
        my Perlbal::ClientHTTPBase $obj = $_[0];
        return 0 unless $obj &&
                        (my $palimginfo = $obj->{scratch}->{palimg});

        # turn off writes
        $obj->watch_write(0);

        # create filehandle for reading
        my $data = '';
        Perlbal::AIO::aio_read($obj->reproxy_fh, 0, 2048, $data, sub {
            # got data? undef is error
            return $obj->_simple_response(500) unless $_[0] > 0;

            # pass down to handler
            my Perlbal::HTTPHeaders $hd = $obj->{req_headers};
            my $res = PalImg::modify_file(\$data, $palimginfo->[0], $palimginfo->[1]);
            return $obj->_simple_response(500) unless defined $res;
            return $obj->_simple_response($res) if $res;

            # seek into the file now so sendfile starts further in
            my $ld = length $data;
            sysseek($obj->{reproxy_fh}, $ld, &POSIX::SEEK_SET);
            $obj->{reproxy_file_offset} = $ld;

            # re-enable writes after we get data
            $obj->tcp_cork(1); # by setting reproxy_file_offset above, it won't cork, so we cork it
            $obj->write($data);
            $obj->watch_write(1);
        });

        return 1;
    });

    return 1;
}

# called when we're no longer active on a service
sub unregister {
    my ($class, $svc) = @_;

    # clean up time
    $svc->unregister_hooks('Palimg');
    return 1;
}

# called when we are loaded/unloaded ... someday add some stats viewing
# commands here?
sub load { return 1; }
sub unload { return 1; }

####### PALIMG START ###########################################################################
package PalImg;

sub parse_hex_color
{
    my $color = shift;
    return [ map { hex(substr($color, $_, 2)) } (0,2,4) ];
}

sub modify_file
{
    my ($data, $type, $palspec) = @_;

    # palette altering
    my %pal_colors;
    if (my $pals = $palspec) {
        my $hx = "[0-9a-f]";
        if ($pals =~ /^g($hx{2,2})($hx{6,6})($hx{2,2})($hx{6,6})$/) {
            # gradient from index $1, color $2, to index $3, color $4
            my $from = hex($1);
            my $to = hex($3);
            return 404 if $from == $to;
            my $fcolor = parse_hex_color($2);
            my $tcolor = parse_hex_color($4);
            if ($to < $from) {
                ($from, $to, $fcolor, $tcolor) =
                    ($to, $from, $tcolor, $fcolor);
            }
            for (my $i=$from; $i<=$to; $i++) {
                $pal_colors{$i} = [ map {
                    int($fcolor->[$_] +
                        ($tcolor->[$_] - $fcolor->[$_]) *
                        ($i-$from) / ($to-$from))
                    } (0..2)  ];
            }
        } elsif ($pals =~ /^t($hx{6,6})($hx{6,6})?$/) {
            # tint everything towards color
            my ($t, $td) = ($1, $2);
            $pal_colors{'tint'} = parse_hex_color($t);
            $pal_colors{'tint_dark'} = $td ? parse_hex_color($td) : [0,0,0];
        } elsif (length($pals) > 42 || $pals =~ /[^0-9a-f]/) {
            return 404;
        } else {
            my $len = length($pals);
            return 404 if $len % 7;  # must be multiple of 7 chars
            for (my $i = 0; $i < $len/7; $i++) {
                my $palindex = hex(substr($pals, $i*7, 1));
                $pal_colors{$palindex} = [
                                          hex(substr($pals, $i*7+1, 2)),
                                          hex(substr($pals, $i*7+3, 2)),
                                          hex(substr($pals, $i*7+5, 2)),
                                          substr($pals, $i*7+1, 6),
                                          ];
            }
        }
    }

    if (%pal_colors) {
        if ($type eq 'gif') {
            return 404 unless PaletteModify::new_gif_palette($data, \%pal_colors);
        } elsif ($type eq 'png') {
            return 404 unless PaletteModify::new_png_palette($data, \%pal_colors);
        }
    }

    # success
    return 0;
}
####### PALIMG END #############################################################################

####### PALETTEMODIFY START ####################################################################
package PaletteModify;

BEGIN {
    $PaletteModify::HAVE_CRC = eval "use String::CRC32 (); 1;";
}

sub common_alter
{
    my ($palref, $table) = @_;
    my $length = length $table;

    my $pal_size = $length / 3;

    # tinting image?  if so, we're remaking the whole palette
    if (my $tint = $palref->{'tint'}) {
        my $dark = $palref->{'tint_dark'};
        my $diff = [ map { $tint->[$_] - $dark->[$_] } (0..2) ];
        $palref = {};
        for (my $idx=0; $idx<$pal_size; $idx++) {
            for my $c (0..2) {
                my $curr = ord(substr($table, $idx*3+$c));
                my $p = \$palref->{$idx}->[$c];
                $$p = int($dark->[$c] + $diff->[$c] * $curr / 255);
            }
        }
    }

    while (my ($idx, $c) = each %$palref) {
        next if $idx >= $pal_size;
        substr($table, $idx*3+$_, 1) = chr($c->[$_]) for (0..2);
    }

    return $table;
}

sub new_gif_palette
{
    my ($data, $palref) = @_;

    # make sure we have data to operate on, or the substrs below die
    return unless $$data;

    # 13 bytes for magic + image info (size, color depth, etc)
    # and then the global palette table (3*256)
    my $header = substr($$data, 0, 13+3*256);

    # figure out how big global color table is (don't want to overwrite it)
    my $pf = ord substr($header, 10, 1);
    my $gct = 2 ** (($pf & 7) + 1);  # last 3 bits of packaged fields

    # final sanity check for size so the substr below doesn't die
    return unless length $header >= 13 + 3 * $gct;

    substr($header, 13, 3*$gct) = common_alter($palref, substr($header, 13, 3*$gct));
    $$data = $header;
    return 1;
}

sub new_png_palette
{
    my ($data, $palref) = @_;

    # subroutine for reading data
    my ($curidx, $maxlen) = (0, length $$data);
    my $read = sub {
        # put $_[1] data into scalar reference $_[0]
        return undef if $_[1] + $curidx > $maxlen;
        ${$_[0]} = substr($$data, $curidx, $_[1]);
        $curidx += $_[1];
        return length ${$_[0]};
    };

    # without this module, we can't proceed.
    return 0 unless $PaletteModify::HAVE_CRC;

    my $imgdata;

    # Validate PNG signature
    my $png_sig = pack("H16", "89504E470D0A1A0A");
    my $sig;
    $read->(\$sig, 8);
    return 0 unless $sig eq $png_sig;
    $imgdata .= $sig;

    # Start reading in chunks
    my ($length, $type) = (0, '');
    while ($read->(\$length, 4)) {

        $imgdata .= $length;
        $length = unpack("N", $length);
        return 0 unless $read->(\$type, 4) == 4;
        $imgdata .= $type;

        if ($type eq 'IHDR') {
            my $header;
            $read->(\$header, $length+4);
            my ($width,$height,$depth,$color,$compression,
                $filter,$interlace, $CRC)
                = unpack("NNCCCCCN", $header);
            return 0 unless $color == 3; # unpaletted image
            $imgdata .= $header;
        } elsif ($type eq 'PLTE') {
            # Finally, we can go to work
            my $palettedata;
            $read->(\$palettedata, $length);
            $palettedata = common_alter($palref, $palettedata);
            $imgdata .= $palettedata;

            # Skip old CRC
            my $skip;
            $read->(\$skip, 4);

            # Generate new CRC
            my $crc = String::CRC32::crc32($type . $palettedata);
            $crc = pack("N", $crc);

            $imgdata .= $crc;
            $$data = $imgdata;
            return 1;
        } else {
            my $skip;
            # Skip rest of chunk and add to imgdata
            # Number of bytes is +4 because of CRC
            #
            for (my $count=0; $count < $length + 4; $count++) {
                $read->(\$skip, 1);
                $imgdata .= $skip;
            }
        }
    }

    return 0;
}
####### PALETTEMODIFY END ######################################################################

1;

__END__