cgi-bin/PaletteModify.pm

   1 #!/usr/bin/perl
   2 #
   3
   4 use strict;
   5 BEGIN {
   6     $PaletteModify::HAVE_CRC = eval "use String::CRC32 (); 1;";
   7 }
   8
   9 package PaletteModify;
  10
  11 sub common_alter
  12 {
  13     my ($palref, $table) = @_;
  14     my $length = length $table;
  15
  16     my $pal_size = $length / 3;
  17
  18     # tinting image?  if so, we're remaking the whole palette
  19     if (my $tint = $palref->{'tint'}) {
  20         my $dark = $palref->{'tint_dark'};
  21         my $diff = [ map { $tint->[$_] - $dark->[$_] } (0..2) ];
  22         $palref = {};
  23         for (my $idx=0; $idx<$pal_size; $idx++) {
  24             for my $c (0..2) {
  25                 my $curr = ord(substr($table, $idx*3+$c));
  26                 my $p = \$palref->{$idx}->[$c];
  27                 $$p = int($dark->[$c] + $diff->[$c] * $curr / 255);
  28             }
  29         }
  30     }
  31
  32     while (my ($idx, $c) = each %$palref) {
  33         next if $idx >= $pal_size;
  34         substr($table, $idx*3+$_, 1) = chr($c->[$_]) for (0..2);
  35     }
  36
  37     return $table;
  38 }
  39
  40 sub new_gif_palette
  41 {
  42     my ($fh, $palref) = @_;
  43     my $header;
  44
  45     # 13 bytes for magic + image info (size, color depth, etc)
  46     # and then the global palette table (3*256)
  47     read($fh, $header, 13+3*256);
  48
  49     # figure out how big global color table is (don't want to overwrite it)
  50     my $pf = ord substr($header, 10, 1);
  51     my $gct = 2 ** (($pf & 7) + 1);  # last 3 bits of packaged fields
  52
  53     substr($header, 13, 3*$gct) = common_alter($palref, substr($header, 13, 3*$gct));
  54     return $header;
  55 }
  56
  57 sub new_png_palette
  58 {
  59     my ($fh, $palref) = @_;
  60
  61     # without this module, we can't proceed.
  62     return undef unless $PaletteModify::HAVE_CRC;
  63
  64     my $imgdata;
  65
  66     # Validate PNG signature
  67     my $png_sig = pack("H16", "89504E470D0A1A0A");
  68     my $sig;
  69     read($fh, $sig, 8);
  70     return undef unless $sig eq $png_sig;
  71     $imgdata .= $sig;
  72
  73     # Start reading in chunks
  74     my ($length, $type) = (0, '');
  75     while (read($fh, $length, 4)) {
  76
  77         $imgdata .= $length;
  78         $length = unpack("N", $length);
  79         return undef unless read($fh, $type, 4) == 4;
  80         $imgdata .= $type;
  81
  82         if ($type eq 'IHDR') {
  83             my $header;
  84             read($fh, $header, $length+4);
  85             my ($width,$height,$depth,$color,$compression,
  86                 $filter,$interlace, $CRC)
  87                 = unpack("NNCCCCCN", $header);
  88             return undef unless $color == 3; # unpaletted image
  89             $imgdata .= $header;
  90         } elsif ($type eq 'PLTE') {
  91             # Finally, we can go to work
  92             my $palettedata;
  93             read($fh, $palettedata, $length);
  94             $palettedata = common_alter($palref, $palettedata);
  95             $imgdata .= $palettedata;
  96
  97             # Skip old CRC
  98             my $skip;
  99             read($fh, $skip, 4);
 100
 101             # Generate new CRC
 102             my $crc = String::CRC32::crc32($type . $palettedata);
 103             $crc = pack("N", $crc);
 104
 105             $imgdata .= $crc;
 106             return $imgdata;
 107         } else {
 108             my $skip;
 109             # Skip rest of chunk and add to imgdata
 110             # Number of bytes is +4 becauses of CRC
 111             #
 112             for (my $count=0; $count < $length + 4; $count++) {
 113                 read($fh, $skip, 1);
 114                 $imgdata .= $skip;
 115             }
 116         }
 117     }
 118
 119     return undef;
 120 }
 121
 122 1;