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