1# 2# PDF::Image::GIF - GIF image support for PDF::Create 3# 4# Author: Michael Gross <info@mdgrosse.net> 5# 6# Copyright 1999-2001 Fabien Tassin 7# Copyright 2007 Markus Baertschi <markus@markus.org> 8# 9# Please see the CHANGES and Changes file for the detailed change log 10# 11# Please do not use any of the methods here directly. You will be 12# punished with your application no longer working after an upgrade ! 13# 14 15package PDF::Image::GIF; 16 17use 5.006; 18use strict; 19use warnings; 20use FileHandle; 21 22our $VERSION = '1.46'; 23our $DEBUG = 0; 24 25sub new 26{ 27 my $self = {}; 28 29 $self->{private} = {}; 30 $self->{colorspace} = 0; 31 $self->{width} = 0; 32 $self->{height} = 0; 33 $self->{colorspace} = "DeviceRGB"; 34 $self->{colorspacedata} = ""; 35 $self->{colorspacesize} = 0; 36 $self->{filename} = ""; 37 $self->{error} = ""; 38 $self->{imagesize} = 0; 39 $self->{transparent} = 0; 40 $self->{filter} = ["LZWDecode"]; 41 $self->{decodeparms} = { 'EarlyChange' => 0 }; 42 $self->{private}->{interlaced} = 0; 43 44 bless($self); 45 return $self; 46} 47 48sub LZW 49{ 50 my $self = shift; 51 my $data = shift; 52 my $result = ""; 53 my $prefix = ""; 54 my $c; 55 my %hash; 56 my $num; 57 my $codesize = 9; 58 59 #init hash-table 60 for ( $num = 0 ; $num < 256 ; $num++ ) { 61 $hash{ chr($num) } = $num; 62 } 63 64 #start with a clear 65 $num = 258; 66 my $currentvalue = 256; 67 my $bits = 9; 68 69 my $pos = 0; 70 while ( $pos < length($data) ) { 71 $c = substr( $data, $pos, 1 ); 72 73 if ( exists( $hash{ $prefix . $c } ) ) { 74 $prefix .= $c; 75 } else { 76 77 #save $hash{$prefix} 78 $currentvalue <<= $codesize; 79 $currentvalue |= $hash{$prefix}; 80 $bits += $codesize; 81 while ( $bits >= 8 ) { 82 $result .= chr( ( $currentvalue >> ( $bits - 8 ) ) & 255 ); 83 $bits -= 8; 84 $currentvalue &= ( 1 << $bits ) - 1; 85 } 86 87 $hash{ $prefix . $c } = $num; 88 $prefix = $c; 89 $num++; 90 91 #increase code size? 92 if ( $num == 513 || $num == 1025 || $num == 2049 ) { 93 $codesize++; 94 } 95 96 #hash table overflow? 97 if ( $num == 4097 ) { 98 99 #save clear 100 $currentvalue <<= $codesize; 101 $currentvalue |= 256; 102 $bits += $codesize; 103 while ( $bits >= 8 ) { 104 $result .= chr( ( $currentvalue >> ( $bits - 8 ) ) & 255 ); 105 $bits -= 8; 106 $currentvalue &= ( 1 << $bits ) - 1; 107 } 108 109 #reset hash table 110 $codesize = 9; 111 %hash = (); 112 for ( $num = 0 ; $num < 256 ; $num++ ) { 113 $hash{ chr($num) } = $num; 114 } 115 $num = 258; 116 } 117 } 118 $pos++; 119 } 120 121 #save value for prefix 122 $currentvalue <<= $codesize; 123 $currentvalue |= $hash{$prefix}; 124 $bits += $codesize; 125 while ( $bits >= 8 ) { 126 $result .= chr( ( $currentvalue >> ( $bits - 8 ) ) & 255 ); 127 $bits -= 8; 128 $currentvalue &= ( 1 << $bits ) - 1; 129 } 130 131 #save eoi 132 $currentvalue <<= $codesize; 133 $currentvalue |= 257; 134 $bits += $codesize; 135 while ( $bits >= 8 ) { 136 $result .= chr( ( $currentvalue >> ( $bits - 8 ) ) & 255 ); 137 $bits -= 8; 138 $currentvalue &= ( 1 << $bits ) - 1; 139 } 140 141 #save remainder in $currentvalue 142 if ( $bits > 0 ) { 143 $currentvalue = $currentvalue << ( 8 - $bits ); 144 $result .= chr( $currentvalue & 255 ); 145 } 146 147 $result; 148} 149 150sub UnLZW 151{ 152 my $self = shift; 153 my $data = shift; 154 my $result = ""; 155 156 my $bits = 0; 157 my $currentvalue = 0; 158 my $codesize = 9; 159 my $pos = 0; 160 161 my $prefix = ""; 162 my $suffix; 163 my @table; 164 165 #initialize lookup-table 166 my $num; 167 for ( $num = 0 ; $num < 256 ; $num++ ) { 168 $table[$num] = chr($num); 169 } 170 $table[256] = ""; 171 172 $num = 257; 173 174 my $c1; 175 176 #get first word 177 while ( $bits < $codesize ) { 178 my $d = ord( substr( $data, $pos, 1 ) ); 179 $currentvalue = ( $currentvalue << 8 ) + $d; 180 $bits += 8; 181 $pos++; 182 } 183 my $c2 = $currentvalue >> ( $bits - $codesize ); 184 $bits -= $codesize; 185 my $mask = ( 1 << $bits ) - 1; 186 $currentvalue = $currentvalue & $mask; 187 188 DECOMPRESS: while ( $pos < length($data) ) { 189 $c1 = $c2; 190 191 #get next word 192 while ( $bits < $codesize ) { 193 my $d = ord( substr( $data, $pos, 1 ) ); 194 $currentvalue = ( $currentvalue << 8 ) + $d; 195 $bits += 8; 196 $pos++; 197 } 198 $c2 = $currentvalue >> ( $bits - $codesize ); 199 $bits -= $codesize; 200 $mask = ( 1 << $bits ) - 1; 201 $currentvalue = $currentvalue & $mask; 202 203 #clear code? 204 if ( $c2 == 256 ) { 205 $result .= $table[$c1]; 206 $#table = 256; 207 $codesize = 9; 208 $num = 257; 209 next DECOMPRESS; 210 } 211 212 #End Of Image? 213 if ( $c2 == 257 ) { 214 last DECOMPRESS; 215 } 216 217 #get prefix 218 if ( $c1 < $num ) { 219 $prefix = $table[$c1]; 220 } else { 221 print "Compression Error ($c1>=$num)\n"; 222 } 223 224 #write prefix 225 $result .= $prefix; 226 227 #get suffix 228 if ( $c2 < $num ) { 229 $suffix = substr( $table[$c2], 0, 1 ); 230 } elsif ( $c2 == $num ) { 231 $suffix = substr( $prefix, 0, 1 ); 232 } else { 233 print "Compression Error ($c2>$num)\n"; 234 } 235 236 #new table entry is prefix.suffix 237 $table[$num] = $prefix . $suffix; 238 239 #next table entry 240 $num++; 241 242 #increase code size? 243 if ( $num == 512 || $num == 1024 || $num == 2048 ) { 244 $codesize++; 245 } 246 } 247 248 $result .= $table[$c1] if defined $table[$c1]; 249 250 $result; 251} 252 253sub UnInterlace 254{ 255 my $self = shift; 256 my $data = shift; 257 my $row; 258 my @result; 259 my $width = $self->{width}; 260 my $height = $self->{height}; 261 my $idx = 0; 262 263 #Pass 1 - every 8th row, starting with row 0 264 $row = 0; 265 while ( $row < $height ) { 266 $result[$row] = substr( $data, $idx * $width, $width ); 267 $row += 8; 268 $idx++; 269 } 270 271 #Pass 2 - every 8th row, starting with row 4 272 $row = 4; 273 while ( $row < $height ) { 274 $result[$row] = substr( $data, $idx * $width, $width ); 275 $row += 8; 276 $idx++; 277 } 278 279 #Pass 3 - every 4th row, starting with row 2 280 $row = 2; 281 while ( $row < $height ) { 282 $result[$row] = substr( $data, $idx * $width, $width ); 283 $row += 4; 284 $idx++; 285 } 286 287 #Pass 4 - every 2th row, starting with row 1 288 $row = 1; 289 while ( $row < $height ) { 290 $result[$row] = substr( $data, $idx * $width, $width ); 291 $row += 2; 292 $idx++; 293 } 294 295 join( '', @result ); 296} 297 298sub GetDataBlock 299{ 300 my $self = shift; 301 my $fh = shift; 302 my $s; 303 my $count; 304 my $buf; 305 read $fh, $s, 1; 306 $count = unpack( "C", $s ); 307 308 if ($count) { 309 read $fh, $buf, $count; 310 } 311 312 ( $count, $buf ); 313} 314 315sub ReadColorMap 316{ 317 my $self = shift; 318 my $fh = shift; 319 read $fh, $self->{'colorspacedata'}, 3 * $self->{'colormapsize'}; 320 1; 321} 322 323sub DoExtension 324{ 325 my $self = shift; 326 my $label = shift; 327 my $fh = shift; 328 my $res; 329 my $buf; 330 my $c; 331 my $c2; 332 my $c3; 333 334 if ( $label eq "\001" ) { #Plain Text Extension 335 } elsif ( ord($label) == 0xFF ) { #Application Extension 336 } elsif ( ord($label) == 0xFE ) { #Comment Extension 337 } elsif ( ord($label) == 0xF9 ) { #Grapgic Control Extension 338 ( $res, $buf ) = $self->GetDataBlock($fh); #(p, image, (unsigned char*) buf); 339 ( $c, $c2, $c2, $c3 ) = unpack( "CCCC", $buf ); 340 if ( $c && 0x1 != 0 ) { 341 $self->{transparent} = 1; 342 $self->{mask} = $c3; 343 } 344 } 345 346 BLOCK: while (1) { 347 ( $res, $buf ) = $self->GetDataBlock($fh); 348 if ( $res == 0 ) { 349 last BLOCK; 350 } 351 } 352 353 1; 354} 355 356sub Open 357{ 358 my $self = shift; 359 my $filename = shift; 360 361 my $PDF_STRING_GIF = "\107\111\106"; 362 my $PDF_STRING_87a = "\070\067\141"; 363 my $PDF_STRING_89a = "\070\071\141"; 364 my $LOCALCOLORMAP = 0x80; 365 my $INTERLACE = 0x40; 366 367 my $s; 368 my $c; 369 my $ar; 370 my $flags; 371 372 $self->{filename} = $filename; 373 my $fh = FileHandle->new("$filename"); 374 if ( !defined $fh ) { $self->{error} = "PDF::Image::GIF.pm: $filename: $!"; return 0 } 375 binmode $fh; 376 read $fh, $s, 3; 377 if ( $s ne $PDF_STRING_GIF ) { 378 close $fh; 379 $self->{error} = "PDF::Image::GIF.pm: Not a gif file."; 380 return 0; 381 } 382 383 read $fh, $s, 3; 384 if ( $s ne $PDF_STRING_87a && $s ne $PDF_STRING_89a ) { 385 close $fh; 386 $self->{error} = "PDF::Image::GIF.pm: GIF version $s not supported."; 387 return 0; 388 } 389 390 read $fh, $s, 7; 391 ( $self->{width}, $self->{height}, $flags, $self->{private}->{background}, $ar ) = unpack( "vvCCC", $s ); 392 393 $self->{colormapsize} = 2 << ( $flags & 0x07 ); 394 $self->{colorspacesize} = 3 * $self->{colormapsize}; 395 if ( $flags & $LOCALCOLORMAP ) { 396 if ( !$self->ReadColorMap($fh) ) { 397 close $fh; 398 $self->{error} = "PDF::Image::GIF.pm: Cant read color map."; 399 return 0; 400 } 401 } 402 403 if ( $ar != 0 ) { 404 $self->{private}->{dpi_x} = -( $ar + 15.0 ) / 64.0; 405 $self->{private}->{dpi_y} = -1.0; 406 } 407 408 my $imageCount = 0; 409 IMAGES: while (1) { 410 read $fh, $c, 1; 411 if ( $c eq ";" ) { #GIF file terminator 412 close $fh; 413 $self->{error} = "PDF::Image::GIF.pm: Cant find image in gif file."; 414 return 0; 415 } 416 417 if ( $c eq "!" ) { #Extension 418 read $fh, $c, 1; 419 $self->DoExtension( $c, $fh ); 420 next; 421 } 422 423 if ( $c ne "," ) { #must be comma 424 next; #ignore 425 } 426 427 $imageCount++; 428 429 read $fh, $s, 9; 430 my $x; 431 ( $x, $c, $self->{width}, $self->{height}, $flags ) = unpack( "vvvvC", $s ); 432 433 if ( $flags && $INTERLACE ) { 434 $self->{private}->{interlaced} = 1; 435 } 436 437 if ( $flags & $LOCALCOLORMAP ) { 438 if ( !$self->ReadColorMap($fh) ) { 439 close $fh; 440 $self->{error} = "PDF::Image::GIF.pm: Cant read color map."; 441 return 0; 442 } 443 } 444 445 read $fh, $s, 1; #read "LZW initial code size" 446 $self->{bpc} = unpack( "C", $s ); 447 if ( $self->{bpc} != 8 ) { 448 close $fh; 449 $self->{error} = "PDF::Image::GIF.pm: LZW minimum code size is " . $self->{bpc} . ", must be 8 to be supported."; 450 return 0; 451 } 452 453 if ( $imageCount == 1 ) { 454 last IMAGES; 455 } 456 457 } 458 459 $self->{private}->{datapos} = tell($fh); 460 close $fh; 461 462 1; 463} 464 465sub ReadData 466{ 467 my $self = shift; 468 469 # init the LZW transformation vars 470 my $c_size = 9; # initial code size 471 my $t_size = 257; # initial "table" size 472 my $i_buff = 0; # input buffer 473 my $i_bits = 0; # input buffer empty 474 my $o_bits = 0; # output buffer empty 475 my $o_buff = 0; 476 my $c_mask; 477 my $bytes_available = 0; 478 my $n_bytes; 479 my $s; 480 my $c; 481 my $flag13; 482 my $code; 483 my $w_bits; 484 485 my $result = ""; 486 487 my $fh = FileHandle->new($self->{filename}); 488 if ( !defined $fh ) { $self->{error} = "PDF::Image::GIF.pm: $self->{filename}: $!"; return 0 } 489 binmode $fh; 490 seek( $fh, $self->{private}->{datapos}, 0 ); 491 my $pos = 0; 492 my $data; 493 read $fh, $data, ( -s $self->{filename} ); 494 495 use integer; 496 497 $self->{imagesize} = 0; 498 BLOCKS: while (1) { 499 $s = substr( $data, $pos, 1 ); 500 $pos++; 501 $n_bytes = unpack( "C", $s ); 502 if ( !$n_bytes ) { 503 last BLOCKS; 504 } 505 506 $c_mask = ( 1 << $c_size ) - 1; 507 $flag13 = 0; 508 509 BLOCK: while (1) { 510 $w_bits = $c_size; # number of bits to write 511 $code = 0; 512 513 #get at least c_size bits into i_buff 514 while ( $i_bits < $c_size ) { 515 if ( $n_bytes == 0 ) { 516 last BLOCK; 517 } 518 $n_bytes--; 519 $s = substr( $data, $pos, 1 ); 520 $pos++; 521 $c = unpack( "C", $s ); 522 $i_buff |= $c << $i_bits; #EOF will be caught later 523 $i_bits += 8; 524 } 525 526 $code = $i_buff & $c_mask; 527 528 $i_bits -= $c_size; 529 $i_buff >>= $c_size; 530 531 if ( $flag13 && $code != 256 && $code != 257 ) { 532 $self->{error} = "PDF::Image::GIF.pm: LZW code size overflow."; 533 return 0; 534 } 535 536 if ( $o_bits > 0 ) { 537 $o_buff |= $code >> ( $c_size - 8 + $o_bits ); 538 $w_bits -= 8 - $o_bits; 539 $result .= chr( $o_buff & 255 ); 540 } 541 542 if ( $w_bits >= 8 ) { 543 $w_bits -= 8; 544 $result .= chr( ( $code >> $w_bits ) & 255 ); 545 } 546 $o_bits = $w_bits; 547 if ( $o_bits > 0 ) { 548 $o_buff = $code << ( 8 - $o_bits ); 549 } 550 551 $t_size++; 552 if ( $code == 256 ) { #clear code 553 $c_size = 9; 554 $c_mask = ( 1 << $c_size ) - 1; 555 $t_size = 257; 556 $flag13 = 0; 557 } 558 559 if ( $code == 257 ) { #end code 560 last BLOCK; 561 } 562 563 if ( $t_size == ( 1 << $c_size ) ) { 564 if ( ++$c_size > 12 ) { 565 $c_size--; 566 $flag13 = 1; 567 } else { 568 $c_mask = ( 1 << $c_size ) - 1; 569 } 570 } 571 } # while () for block 572 } # while () for all blocks 573 574 #interlaced? 575 if ( $self->{private}->{interlaced} ) { 576 577 #when interlaced first uncompress image 578 $result = $self->UnLZW($result); 579 580 #remove interlacing 581 $result = $self->UnInterlace($result); 582 583 #compress image again 584 $result = $self->LZW($result); 585 } 586 587 $self->{imagesize} = length($result); 588 $result; 589} 590 5911; 592