1package Image::Info::GIF; 2 3# Copyright 1999-2000, Gisle Aas. 4# 5# This library is free software; you can redistribute it and/or 6# modify it under the same terms as Perl itself. 7 8=begin register 9 10MAGIC: /^GIF8[79]a/ 11 12Both GIF87a and GIF89a are supported and the version number is found 13as C<GIF_Version> for the first image. GIF files can contain multiple 14images, and information for all images will be returned if 15image_info() is called in list context. The Netscape-2.0 extention to 16loop animation sequences is represented by the C<GIF_Loop> key for the 17first image. The value is either "forever" or a number indicating 18loop count. 19 20=end register 21 22=cut 23 24use strict; 25 26sub my_read 27{ 28 my($source, $len) = @_; 29 my $buf; 30 my $n = read($source, $buf, $len); 31 die "read failed: $!" unless defined $n; 32 die "short read ($len/$n)" unless $n == $len; 33 $buf; 34} 35 36sub read_data_blocks 37{ 38 my $source = shift; 39 my @data; 40 while (my $len = ord(my_read($source, 1))) { 41 push(@data, my_read($source, $len)); 42 } 43 join("", @data); 44} 45 46 47sub process_file 48{ 49 my($info, $fh) = @_; 50 51 my $header = my_read($fh, 13); 52 die "Bad GIF signature" 53 unless $header =~ s/^GIF(8[79]a)//; 54 my $version = $1; 55 $info->push_info(0, "GIF_Version" => $version); 56 57 # process logical screen descriptor 58 my($sw, $sh, $packed, $bg, $aspect) = unpack("vvCCC", $header); 59 $info->push_info(0, "ScreenWidth" => $sw); 60 $info->push_info(0, "ScreenHeight" => $sh); 61 62 my $color_table_size = 1 << (($packed & 0x07) + 1); 63 $info->push_info(0, "ColorTableSize" => $color_table_size); 64 65 $info->push_info(0, "SortedColors" => ($packed & 0x08) ? 1 : 0) 66 if $version eq "89a"; 67 68 $info->push_info(0, "ColorResolution", (($packed & 0x70) >> 4) + 1); 69 70 my $global_color_table = $packed & 0x80; 71 $info->push_info(0, "GlobalColorTableFlag" => $global_color_table ? 1 : 0); 72 if ($global_color_table) { 73 $info->push_info(0, "BackgroundColor", $bg); 74 } 75 76 if ($aspect) { 77 $aspect = ($aspect + 15) / 64; 78 $info->push_info(0, "PixelAspectRatio" => $aspect); 79 80 # XXX is this correct???? 81 $info->push_info(0, "resolution", "1/$aspect"); 82 } 83 else { 84 $info->push_info(0, "resolution", "1/1"); 85 } 86 87 $info->push_info(0, "file_media_type" => "image/gif"); 88 $info->push_info(0, "file_ext" => "gif"); 89 90 # more?? 91 if ($global_color_table) { 92 my $color_table = my_read($fh, $color_table_size * 3); 93 #$info->push_info(0, "GlobalColorTable", color_table($color_table)); 94 } 95 96 my $img_no = 0; 97 my @comments; 98 my @warnings; 99 100 while (1) { 101 my $intro = ord(my_read($fh, 1)); 102 if ($intro == 0x3B) { # trailer (end of image) 103 last; 104 } 105 elsif ($intro == 0x2C) { # new image 106 107 108 if (@comments) { 109 for (@comments) { 110 $info->push_info(0, "Comment", $_); 111 } 112 @comments = (); 113 } 114 115 $info->push_info($img_no, "color_type" => "Indexed-RGB"); 116 117 my($x_pos, $y_pos, $w, $h, $packed) = 118 unpack("vvvvC", my_read($fh, 9)); 119 $info->push_info($img_no, "XPosition", $x_pos); 120 $info->push_info($img_no, "YPosition", $y_pos); 121 $info->push_info($img_no, "width", $w); 122 $info->push_info($img_no, "height", $h); 123 124 if ($packed & 0x80) { 125 # yes, we have a local color table 126 my $ct_size = 1 << (($packed & 0x07) + 1); 127 $info->push_info($img_no, "LColorTableSize" => $ct_size); 128 my $color_table = my_read($fh, $ct_size * 3); 129 } 130 131 $info->push_info($img_no, "Interlace" => "GIF") 132 if $packed & 0x40; 133 134 my $lzw_code_size = ord(my_read($fh, 1)); 135 #$info->push_info($img_no, "LZW_MininmCodeSize", $lzw_code_size); 136 read_data_blocks($fh); # skip image data 137 $img_no++; 138 } 139 elsif ($intro == 0x21) { # GIF89a extension 140 push(@warnings, "GIF 89a extensions in 87a") 141 if $version eq "87a"; 142 143 my $label = ord(my_read($fh, 1)); 144 my $data = read_data_blocks($fh); 145 if ($label == 0xF9 && length($data) == 4) { # Graphic Control 146 my($packed, $delay, $trans_color) = unpack("CvC", $data); 147 my $disposal_method = ($packed >> 2) & 0x07; 148 $info->push_info($img_no, "DisposalMethod", $disposal_method) 149 if $disposal_method; 150 $info->push_info($img_no, "UserInput", 1) 151 if $packed & 0x02; 152 $info->push_info($img_no, "Delay" => $delay/100) if $delay; 153 $info->push_info($img_no, "TransparencyIndex" => $trans_color) 154 if $packed & 0x01; 155 } 156 elsif ($label == 0xFE) { # Comment 157 $data =~ s/\0+$//; # is often NUL-terminated 158 push(@comments, $data); 159 } 160 elsif ($label == 0xFF) { # Application 161 my $app = substr($data, 0, 11, ""); 162 my $auth = substr($app, -3, 3, ""); 163 if ($app eq "NETSCAPE" && $auth eq "2.0" 164 && $data =~ /^\01/) { 165 my $loop = unpack("xv", $data); 166 $loop = "forever" unless $loop; 167 $info->push_info($img_no, "GIF_Loop" => $loop); 168 } else { 169 $info->push_info($img_no, "APP-$app-$auth" => $data); 170 } 171 } 172 else { 173 $info->push_info($img_no, "GIF_Extension-$label" => $data); 174 } 175 } 176 else { 177 die "Unknown introduced code $intro, bad GIF"; 178 } 179 } 180 181 for (@comments) { 182 $info->push_info(0, "Comment", $_); 183 } 184 185 for (@warnings) { 186 $info->push_info(0, "Warn", $_); 187 } 188} 189 190sub color_table 191{ 192 my @n = unpack("C*", shift); 193 die "Color table not a multiple of 3" if @n % 3; 194 my @table; 195 while (@n) { 196 my @triple = splice(@n, -3); 197 push(@table, sprintf("#%02x%02x%02x", @triple)); 198 } 199 [reverse @table]; 200} 201 2021; 203