/usr/local/CPAN/perl-pdf/PDF/Image/GIFImage.pm
# -*- mode: Perl -*-
# PDF::Image::GIFImage - GIF image support
# Author: Michael Gross <mdgrosse@sbox.tugraz.at>
# Version: 0.06
# Copyright 2001 Michael Gross <mdgrosse@sbox.tugraz.at>
#
# 10.9.2001 - Bugfix for Perl 5.6
# 27.11.2001 - Bugfix, now also works on Windows (binmode)
package PDF::Image::GIFImage;
use strict;
use vars qw(@ISA @EXPORT $VERSION $DEBUG);
use Exporter;
use FileHandle;
@ISA = qw(Exporter);
@EXPORT = qw();
$VERSION = 0.06;
$DEBUG = 0;
sub new {
my $self = {};
$self->{private} = {};
$self->{colorspace} = 0;
$self->{width} = 0;
$self->{height} = 0;
$self->{colorspace} = "DeviceRGB";
$self->{colorspacedata} = "";
$self->{colorspacesize} = 0;
$self->{filename} = "";
$self->{error} = "";
$self->{imagesize} = 0;
$self->{transparent} = 0;
$self->{filter} = ["LZWDecode"];
$self->{decodeparms} = {'EarlyChange' => 0};
$self->{private}->{interlaced} = 0;
bless($self);
return $self;
}
sub LZW {
my $self = shift;
my $data = shift;
my $result = "";
my $prefix = "";
my $c;
my %hash;
my $num;
my $codesize = 9;
#init hash-table
for ($num=0; $num<256; $num++) {
$hash{chr($num)} = $num;
}
#start with a clear
$num = 258;
my $currentvalue = 256;
my $bits = 9;
my $pos = 0;
while ($pos < length($data)) {
$c = substr($data, $pos, 1);
if (exists($hash{$prefix . $c})) {
$prefix.=$c;
} else {
#save $hash{$prefix}
$currentvalue<<=$codesize;
$currentvalue|=$hash{$prefix};
$bits+=$codesize;
while ($bits >= 8) {
$result.=chr(($currentvalue >> ($bits-8)) & 255);
$bits-=8;
$currentvalue&=(1 << $bits) - 1;
}
$hash{$prefix . $c} = $num;
$prefix = $c;
$num++;
#increase code size?
if ($num==513 || $num==1025 || $num==2049) {
$codesize++;
}
#hash table overflow?
if ($num==4097) {
#save clear
$currentvalue<<=$codesize;
$currentvalue|=256;
$bits+=$codesize;
while ($bits >= 8) {
$result.=chr(($currentvalue >> ($bits-8)) & 255);
$bits-=8;
$currentvalue&=(1 << $bits) - 1;
}
#reset hash table
$codesize = 9;
%hash = ();
for ($num=0; $num<256; $num++) {
$hash{chr($num)} = $num;
}
$num=258;
}
}
$pos++;
}
#save value for prefix
$currentvalue<<=$codesize;
$currentvalue|=$hash{$prefix};
$bits+=$codesize;
while ($bits >= 8) {
$result.=chr(($currentvalue >> ($bits-8)) & 255);
$bits-=8;
$currentvalue&=(1 << $bits) - 1;
}
#save eoi
$currentvalue<<=$codesize;
$currentvalue|=257;
$bits+=$codesize;
while ($bits >= 8) {
$result.=chr(($currentvalue >> ($bits-8)) & 255);
$bits-=8;
$currentvalue&=(1 << $bits) - 1;
}
#save remainder in $currentvalue
if ($bits > 0) {
$currentvalue = $currentvalue << (8-$bits);
$result.=chr($currentvalue & 255);
}
$result;
}
sub UnLZW {
my $self = shift;
my $data = shift;
my $result = "";
my $bits = 0;
my $currentvalue = 0;
my $codesize = 9;
my $pos = 0;
my $prefix = "";
my $suffix;
my @table;
#initialize lookup-table
my $num;
for ($num=0; $num<256; $num++) {
$table[$num] = chr($num);
}
$table[256] = "";
$num = 257;
my $c1;
#get first word
while ($bits < $codesize) {
my $d = ord(substr($data, $pos, 1));
$currentvalue = ($currentvalue<<8) + $d;
$bits+=8;
$pos++;
}
my $c2 = $currentvalue >> ($bits - $codesize);
$bits-=$codesize;
my $mask = (1 << $bits) - 1;
$currentvalue = $currentvalue & $mask;
DECOMPRESS: while ($pos < length($data)) {
$c1 = $c2;
#get next word
while ($bits < $codesize) {
my $d = ord(substr($data, $pos, 1));
$currentvalue = ($currentvalue<<8) + $d;
$bits+=8;
$pos++;
}
$c2 = $currentvalue >> ($bits - $codesize);
$bits-=$codesize;
$mask = (1 << $bits) - 1;
$currentvalue = $currentvalue & $mask;
#clear code?
if ($c2 == 256) {
$result.=$table[$c1];
$#table = 256;
$codesize = 9;
$num = 257;
next DECOMPRESS;
}
#End Of Image?
if ($c2 == 257) {
last DECOMPRESS;
}
#get prefix
if ($c1 < $num) {
$prefix = $table[$c1];
} else {
print "Compression Error ($c1>=$num)\n";
}
#write prefix
$result.=$prefix;
#get suffix
if ($c2 < $num) {
$suffix = substr($table[$c2], 0, 1);
} elsif ($c2 == $num) {
$suffix = substr($prefix, 0, 1);
} else {
print "Compression Error ($c2>$num)\n";
}
#new table entry is prefix.suffix
$table[$num] = $prefix . $suffix;
#next table entry
$num++;
#increase code size?
if ($num==512 || $num==1024 || $num==2048) {
$codesize++;
}
}
$result.=$table[$c1];
$result;
}
sub UnInterlace {
my $self = shift;
my $data = shift;
my $row;
my @result;
my $width = $self->{width};
my $height = $self->{height};
my $idx = 0;
#Pass 1 - every 8th row, starting with row 0
$row = 0;
while ($row < $height) {
$result[$row] = substr($data, $idx*$width, $width);
$row+=8;
$idx++;
}
#Pass 2 - every 8th row, starting with row 4
$row = 4;
while ($row < $height) {
$result[$row] = substr($data, $idx*$width, $width);
$row+=8;
$idx++;
}
#Pass 3 - every 4th row, starting with row 2
$row = 2;
while ($row < $height) {
$result[$row] = substr($data, $idx*$width, $width);
$row+=4;
$idx++;
}
#Pass 4 - every 2th row, starting with row 1
$row = 1;
while ($row < $height) {
$result[$row] = substr($data, $idx*$width, $width);
$row+=2;
$idx++;
}
join('', @result);
}
sub GetDataBlock {
my $self = shift;
my $fh = shift;
my $s;
my $count;
my $buf;
read $fh, $s, 1;
$count = unpack("C", $s);
if ($count) {
read $fh, $buf, $count;
}
($count, $buf);
}
sub ReadColorMap {
my $self = shift;
my $fh = shift;
read $fh, $self->{'colorspacedata'}, 3 * $self->{'colormapsize'};
1;
}
sub DoExtension {
my $self = shift;
my $label = shift;
my $fh = shift;
my $res;
my $buf;
my $c;
my $c2;
my $c3;
if ($label eq "\001") { #Plain Text Extension
} elsif (ord($label)==0xFF) { #Application Extension
} elsif (ord($label)==0xFE) { #Comment Extension
} elsif (ord($label)==0xF9) { #Grapgic Control Extension
($res, $buf) = $self->GetDataBlock($fh); #(p, image, (unsigned char*) buf);
($c, $c2, $c2, $c3) = unpack("CCCC", $buf);
if ($c && 0x1 != 0) {
$self->{transparent}=1;
$self->{mask}=$c3;
}
}
BLOCK: while (1) {
($res, $buf) = $self->GetDataBlock($fh);
if ($res == 0) {
last BLOCK;
}
}
1;
}
sub Open {
my $self = shift;
my $filename = shift;
my $PDF_STRING_GIF = "\107\111\106";
my $PDF_STRING_87a = "\070\067\141";
my $PDF_STRING_89a = "\070\071\141";
my $LOCALCOLORMAP = 0x80;
my $INTERLACE = 0x40;
my $s;
my $c;
my $ar;
my $flags;
$self->{filename} = $filename;
my $fh = new FileHandle "$filename";
binmode $fh;
read $fh, $s, 3;
if ($s ne $PDF_STRING_GIF) {
close $fh;
$self->{error} = "Not a gif file.";
return 0;
}
read $fh, $s, 3;
if ($s ne $PDF_STRING_87a && $s ne $PDF_STRING_89a) {
close $fh;
$self->{error} = "GIF version $s not supported.";
return 0;
}
read $fh, $s, 7;
($self->{width}, $self->{height}, $flags, $self->{private}->{background}, $ar) = unpack("SSCCC", $s);
$self->{colormapsize} = 2 << ($flags & 0x07);
$self->{colorspacesize} = 3 * $self->{colormapsize};
if ($flags & $LOCALCOLORMAP) {
if (!$self->ReadColorMap($fh)) {
close $fh;
$self->{error} = "Cant read color map.";
return 0;
}
}
if ($ar != 0) {
$self->{private}->{dpi_x} = -($ar + 15.0) / 64.0;
$self->{private}->{dpi_y} = -1.0;
}
my $imageCount = 0;
IMAGES: while (1) {
read $fh, $c, 1;
if ($c eq ";") { #GIF file terminator
close $fh;
$self->{error} = "Cant find image in gif file.";
return 0;
}
if ($c eq "!") { #Extension
read $fh, $c, 1;
$self->DoExtension($c, $fh);
next;
}
if ($c ne ",") { #must be comma
next; #ignore
}
$imageCount++;
read $fh, $s, 9;
my $x;
($x, $c, $self->{width}, $self->{height}, $flags) = unpack("SSSSC", $s);
if ($flags && $INTERLACE) {
$self->{private}->{interlaced} = 1;
}
if ($flags & $LOCALCOLORMAP) {
if (!$self->ReadColorMap($fh)) {
close $fh;
$self->{error} = "Cant read color map.";
return 0;
}
}
read $fh, $s, 1; #read "LZW initial code size"
$self->{bpc} = unpack("C", $s);
if ($self->{bpc} != 8) {
close $fh;
$self->{error} = "LZW minimum code size other than 8 not supported.";
return 0;
}
if ($imageCount == 1) {
last IMAGES;
}
}
$self->{private}->{datapos} = tell($fh);
close $fh;
1;
}
sub ReadData {
my $self = shift;
# init the LZW transformation vars
my $c_size = 9; # initial code size
my $t_size = 257; # initial "table" size
my $i_buff = 0; # input buffer
my $i_bits = 0; # input buffer empty
my $o_bits = 0; # output buffer empty
my $o_buff = 0;
my $c_mask;
my $bytes_available = 0;
my $n_bytes;
my $s;
my $c;
my $flag13;
my $code;
my $w_bits;
my $result = "";
my $fh = new FileHandle $self->{filename};
binmode $fh;
seek($fh, $self->{private}->{datapos}, 0);
my $pos = 0;
my $data;
read $fh, $data, (-s $self->{filename});
use integer;
$self->{imagesize} = 0;
BLOCKS: while (1) {
$s = substr($data, $pos, 1); $pos++;
$n_bytes = unpack("C", $s);
if (!$n_bytes) {
last BLOCKS;
}
$c_mask = (1 << $c_size) - 1;
$flag13 = 0;
BLOCK: while (1) {
$w_bits = $c_size; # number of bits to write
$code = 0;
#get at least c_size bits into i_buff
while ($i_bits < $c_size) {
if ($n_bytes == 0) {
last BLOCK;
}
$n_bytes--;
$s = substr($data, $pos, 1); $pos++;
$c = unpack("C", $s);
$i_buff |= $c << $i_bits; #EOF will be caught later
$i_bits += 8;
}
$code = $i_buff & $c_mask;
$i_bits -= $c_size;
$i_buff >>= $c_size;
if ($flag13 && $code!=256 && $code!=257) {
$self->{error} = "LZW code size overflow.";
return 0;
}
if ($o_bits > 0) {
$o_buff |= $code >> ($c_size - 8 + $o_bits);
$w_bits -= 8 - $o_bits;
$result.=chr($o_buff & 255);
}
if ($w_bits >= 8) {
$w_bits -= 8;
$result.=chr(($code >> $w_bits) & 255);
}
$o_bits = $w_bits;
if ($o_bits > 0) {
$o_buff = $code << (8 - $o_bits);
}
$t_size++;
if ($code == 256) { #clear code
$c_size = 9;
$c_mask = (1 << $c_size) - 1;
$t_size = 257;
$flag13 = 0;
}
if ($code == 257) { #end code
last BLOCK;
}
if ($t_size == (1 << $c_size)) {
if (++$c_size > 12) {
$c_size--;
$flag13 = 1;
} else {
$c_mask = (1 << $c_size) - 1;
}
}
} # while () for block
} # while () for all blocks
#interlaced?
if ($self->{private}->{interlaced}) {
#when interlaced first uncompress image
$result = $self->UnLZW($result);
#remove interlacing
$result = $self->UnInterlace($result);
#compress image again
$result = $self->LZW($result);
}
$self->{imagesize} = length($result);
$result;
}
1;