#
# GIFinfo.pm
#
# $Id: GIFinfo.pm,v 1.2 2002/06/11 22:55:02 roubert Exp $
#

package Image::GIFinfo;
require 5;

use strict;
use vars qw($REVISION $VERSION @ISA @EXPORT @EXPORT_OK);
use FileHandle;
use IO::Seekable;

require Exporter;
@ISA = 'Exporter';

$REVISION = '$Revision: 1.2 $';
($VERSION = $REVISION) =~ s/^\$(?#)Revision: (.+) \$$/$1/;

@EXPORT_OK = qw
(
	gifread
	gifedit
);


use constant EGARBAGE	=> 'Garbage data found in GIF file';
use constant ENOGIF	=> 'Not a GIF file';
use constant EREAD	=> 'Read error';
use constant EWRITE	=> 'Write error';

sub gifread ($;$);
sub gifedit ($$$;$);

sub myread ($$\%);
sub mywrite ($$\%);
sub myseek ($$\%);
sub mycopy ($$$\%);
sub skipblock ($$\%);
sub copyblock ($$$\%);
sub readcomment ($\%);
sub writecomment ($$\%);


#
# %info = gifread ($fh, $readcomment);
#
sub gifread ($;$)
{
	my ($fh, $readcomment) = splice @_;
	my (%info, $tmp, @tmp);

	#
	# Header and Logical Screen Descriptor
	#
	defined ($tmp = myread $fh, 13, %info)
	or return %info;
	@tmp = unpack 'A3A3vvCCC', $tmp;

	unless ($tmp[0] eq 'GIF')
	{
		$info{'error'} = ENOGIF;
		return %info;
	}

	$info{'width'} = $tmp[2];
	$info{'height'} = $tmp[3];

	return %info unless $readcomment;

	#
	# Global Color Table
	#
	if ($tmp[4] & 0x80)
	{
		myseek $fh, 3 * 2 << ($tmp[4] & 0x07), %info
		or return %info;
	}

	#
	# GIF block structure
	#
	for (;;)
	{
		defined ($tmp = ord myread $fh, 1, %info)
		or return %info;

		#
		# Extension Introducer
		#
		if ($tmp == 0x21)
		{
			defined ($tmp = ord myread $fh, 1, %info)
			or return %info;

			#
			# Comment Extension
			#
			if ($tmp == 0xfe)
			{
				defined ($tmp = readcomment $fh, %info)
				or return %info;

				push @{$info{'comment'}}, $tmp;
				next;
			}

			#
			# Application Extension
			#
			if ($tmp == 0xff)
			{
				skipblock $fh, 12, %info
				or return %info;
				next;
			}

			#
			# Graphic Control Extension
			#
			if ($tmp == 0xf9)
			{
				myseek $fh, 6, %info
				or return %info;

				next;
			}

			#
			# Plain Text Extension
			#
			if ($tmp == 0x01)
			{
				skipblock $fh, 13, %info
				or return %info;
				next;
			}

			#
			# Corrupt GIF File
			#
			$info{'error'} = EGARBAGE;
			return %info;
		}

		#
		# Image Descriptor
		#
		if ($tmp == 0x2c)
		{
			myseek $fh, 8, %info
			or return %info;

			defined ($tmp = ord myread $fh, 1, %info)
			or return %info;

			#
			# Local Color Table
			#
			if ($tmp & 0x80)
			{
				myseek $fh, 3 * 2 << ($tmp & 0x07), %info
				or return %info;
			}

			skipblock $fh, 1, %info
			or return %info;

			next;
		}

		#
		# Trailer
		#
		if ($tmp == 0x3b)
		{
			last;
		}

		#
		# Corrupt GIF File
		#
		$info{'error'} = EGARBAGE;
		return %info;
	}

	return %info;
}


#
# %info = gifedit ($src, $dst, $com, $re);
#
sub gifedit ($$$;$)
{
	my ($src, $dst, $com, $re) = splice @_;
	my (%info, $tmp, @tmp);

	$com = undef if defined $com && $com eq '';
	$re = undef if defined $re && $re eq '';

	#
	# Header and Logical Screen Descriptor
	#
	defined ($tmp = myread $src, 13, %info)
	or return %info;
	@tmp = unpack 'A3A3vvCCC', $tmp;

	unless ($tmp[0] eq 'GIF')
	{
		$info{'error'} = ENOGIF;
		return %info;
	}

	$info{'width'} = $tmp[2];
	$info{'height'} = $tmp[3];

	$tmp[1] = '89a' if $tmp[1] =~ m/^87/;
	$tmp = pack 'A3A3vvCCC', @tmp;

	mywrite $dst, $tmp, %info
	or return %info;

	#
	# Global Color Table
	#
	if ($tmp[4] & 0x80)
	{
		mycopy $src, $dst, 3 * 2 << ($tmp[4] & 0x07), %info
		or return %info;
	}

	#
	# Comment Extension
	#
	if (defined $com)
	{
		writecomment $dst, $com, %info
		or return %info;

		push @{$info{'comment'}}, $com;
	}

	#
	# GIF block structure
	#
	for (;;)
	{
		my ($blk, $ext);

		defined ($blk = myread $src, 1, %info)
		or return %info;

		$tmp = ord $blk;

		#
		# Extension Introducer
		#
		if ($tmp == 0x21)
		{
			defined ($ext = myread $src, 1, %info)
			or return %info;

			$tmp = ord $ext;

			#
			# Comment Extension
			#
			if ($tmp == 0xfe)
			{
				defined ($tmp = readcomment $src, %info)
				or return %info;

				unless (defined $re && $tmp =~ m/$re/s)
				{
					writecomment $dst, $tmp, %info
					or return %info;

					push @{$info{'comment'}}, $tmp;
				}

				next;
			}

			mywrite $dst, $blk . $ext, %info
			or return %info;

			#
			# Application Extension
			#
			if ($tmp == 0xff)
			{
				copyblock $src, $dst, 12, %info
				or return %info;
				next;
			}

			#
			# Graphic Control Extension
			#
			if ($tmp == 0xf9)
			{
				mycopy $src, $dst, 6, %info
				or return %info;

				next;
			}

			#
			# Plain Text Extension
			#
			if ($tmp == 0x01)
			{
				copyblock $src, $dst, 13, %info
				or return %info;
				next;
			}

			#
			# Corrupt GIF File
			#
			$info{'error'} = EGARBAGE;
			return %info;
		}

		mywrite $dst, $blk, %info
		or return %info;

		#
		# Image Descriptor
		#
		if ($tmp == 0x2c)
		{
			mycopy $src, $dst, 8, %info
			or return %info;

			defined ($tmp = ord mycopy $src, $dst, 1, %info)
			or return %info;

			#
			# Local Color Table
			#
			if ($tmp & 0x80)
			{
				mycopy $src, $dst, 3 * 2 << ($tmp & 0x07), %info
				or return %info;
			}

			copyblock $src, $dst, 1, %info
			or return %info;

			next;
		}

		#
		# Trailer
		#
		if ($tmp == 0x3b)
		{
			last;
		}

		#
		# Corrupt GIF File
		#
		$info{'error'} = EGARBAGE;
		return %info;
	}

	return %info;
}


#
# $data = myread ($fh, $bytes, %info);
#
sub myread ($$\%)
{
	my $tmp;

	unless ($_[1] == read $_[0], $tmp, $_[1])
	{
		${$_[2]}{'error'} = EREAD;
		return undef;
	}

	return $tmp;
}


#
# $status = mywrite ($fh, $data, %info);
#
sub mywrite ($$\%)
{
	unless (print {$_[0]} $_[1])
	{
		${$_[2]}{'error'} = EWRITE;
		return undef;
	}

	return 1;
}


#
# $status = myseek ($fh, $bytes, %info);
#
sub myseek ($$\%)
{
	unless (seek $_[0], $_[1], SEEK_CUR)
	{
		${$_[2]}{'error'} = EREAD;
		return undef;
	}

	return $_[1];
}


#
# $data = mycopy ($src, $dst, $bytes, %info);
#
sub mycopy ($$$\%)
{
	my $tmp;

	unless ($_[2] == read $_[0], $tmp, $_[2])
	{
		${$_[3]}{'error'} = EREAD;
		return undef;
	}

	mywrite $_[1], $tmp, %{$_[3]}
	or return undef;

	return $tmp;
}


#
# $status = skipblock ($fh, $offset, %info);
#
sub skipblock ($$\%)
{
	my ($fh, $offset, $info) = splice @_;
	my ($length, $total);

	myseek $fh, $offset, %{$info}
	or return undef;

	$total = $offset;

	for (;;)
	{
		defined ($length = ord myread $fh, 1, %{$info})
		or return undef;

		last if $length == 0;

		myseek $fh, $length, %{$info}
		or return undef;

		$total += $length;
	}

	return $total;
}


#
# $status = copyblock ($src, $dst, $offset, %info);
#
sub copyblock ($$$\%)
{
	my ($src, $dst, $offset, $info) = splice @_;
	my ($length, $total);

	mycopy $src, $dst, $offset, %{$info}
	or return undef;

	$total = $offset;

	for (;;)
	{
		defined ($length = ord mycopy $src, $dst, 1, %{$info})
		or return undef;

		last if $length == 0;

		mycopy $src, $dst, $length, %{$info}
		or return undef;

		$total += $length;
	}

	return $total;
}


#
# $comment = readcomment ($fh, %info);
#
sub readcomment ($\%)
{
	my ($com, $tmp, $len);

	for ($com = '';; $com .= $tmp)
	{
		defined ($len = ord myread $_[0], 1, %{$_[1]})
		or return undef;

		last if $len == 0;

		defined ($tmp = myread $_[0], $len, %{$_[1]})
		or return undef;
	}

	return $com;
}


#
# $status = writecomment ($fh, $com, %info);
#
sub writecomment ($$\%)
{
	my ($block, $tmp);

	$block = "\041\376";
	for (my $i = 0; $i < length $_[1]; $i += length $tmp)
	{
		$tmp = substr $_[1], $i, 0xff;
		$block .= chr length $tmp;
		$block .= $tmp;
	}
	$block .= "\000";

	return mywrite $_[0], $block, %{$_[2]};
}


1;
__END__

=head1 NAME

Image::GIFinfo - read and edit GIF file meta data

=head1 SYNOPSIS

=head2 gifread

	use Image::GIFinfo qw(gifread);
	use FileHandle;

	my ($fh, %info);

	$fh = new FileHandle 'test.gif', 'r' or die;
	%info = gifread $fh;
	$fh->close;

	foreach my $key (keys %info)
	{
		print "$key => $info{$key}\n";
	}

=head2 gifedit

	use Image::GIFinfo qw(gifedit);
	use FileHandle;

	my ($src, $dst, %info);

	$src = new FileHandle 'src.gif', 'r' or die;
	$dst = new FileHandle 'dst.gif', 'w' or die;
	%info = gifedit $src, $dst, "This is a new comment.";
	$src->close;
	$dst->close;

	foreach my $key (keys %info)
	{
		print "$key => $info{$key}\n";
	}

=head1 DESCRIPTION

The gifread() function takes a FileHandle argument, and returns a hash
containing the file meta data, or error messages.

The gifedit() function takes two FileHandle arguments (source and destination
respectively), the new comment as a string, and an optional regular expression.
If an existing comment in the file matches this regular expression, this
comment will be deleted. The function returns a hash that might contain error
messages.

=head1 AUTHOR

Copyright (C) 2001 Fredrik Roubert E<lt>F<roubert@df.lth.se>E<gt>.
All rights reserved.

This package is free software and is provided "as is" without express or
implied warranty. It may be used, redistributed and/or modified under the terms
of the Perl Artistic License (see http://www.perl.com/perl/misc/Artistic.html).

=cut