File Coverage

blib/lib/Image/DeAnim.pm

Criterion	Covered	Total	%
statement	6	77	7.7
branch	0	26	0.0
condition	0	2	0.0
subroutine	2	7	28.5
pod	0	5	0.0
total	8	117	6.8

package Image::DeAnim;

use strict;
use vars qw($VERSION @ISA @EXPORT_OK $gif_in $gif_out);

require Exporter;

@ISA = qw(Exporter);
@EXPORT_OK = qw(gif);

$VERSION = '0.02';

sub gif {
    my $nullstr     = "";
    my $nullstr_ref = \$nullstr;

    my $gif_in_ref = shift || return \$nullstr_ref;

    $gif_out = "";
    $gif_in = $$gif_in_ref;

    # header
    my $header = &safe_read(6);
    unless ($header =~ /^GIF\d\d[a-z]/) {
        warn "not a GIF header: $header";
        return $nullstr_ref;
    }
    $gif_out .= "GIF89a";

# logical screen description
    my $ls_desc = &safe_read(7);
    my ($ls_size, $ls_flag, $ls_misc) = unpack("A4 C A2", $ls_desc);
    $gif_out .= $ls_desc;

    if ($ls_flag & 0x80) { # check for global color table
        $gif_out .= &get_colormap($ls_flag & 0x07);
    }

    my $data_block;

    while (1) {
        my $ext_label;
        my $block_label = &safe_read(1);

        # if we detect end of file marker, $gif_out .= last block and return
        if ($block_label eq "\x3b") {
            $gif_out .= $data_block . "\x3b";
            return \$gif_out;
        }

        if ($block_label eq "\x2c") { # found image descriptor
            $data_block = "\x2c" . &get_image;
            next;
        }

        unless ($block_label eq "\x21") {
            warn "Illegal block label found: " . ord($block_label);
            return $nullstr_ref;
        }

        $ext_label = &safe_read(1);
        if ($ext_label eq "\xf9") { # graphic control; keep and then get image
            $data_block = "\x21\xf9" . &safe_read(6);
            unless (&safe_read(1) eq "\x2c") {
                warn "graphic control extension not followed by image";
                return $nullstr_ref;
            }
            $data_block .= "\x2c" . &get_image;
            next;
        }

        if ($ext_label eq "\xff") { # application extension; skip
            &safe_read(12);
            &get_data_block;
        } elsif ($ext_label eq "\xfe") { # comment extension; skip
            &get_data_block;
        } elsif ($ext_label eq "\x01") { # plain text extension; skip
            &safe_read(13);
            &get_data_block;
        } else {
            warn "Illegal extension label found: " . ord($ext_label);
            return $nullstr_ref;
        }
    }

    warn "exit abnormally";
    return $nullstr_ref;
}
##########################################################################

sub safe_read {
    # read from $fh_in with error checking.
    my $len = shift;
    my $buf;

    unless (length($gif_in) >= $len) {
        die "read error: unsafe read";
    }

    ($buf, $gif_in) = unpack("a$len a*", $gif_in);

    return $buf;
}

sub get_data_block {
    my ($byte, $size);
    my $block = "";

    do {
        $byte = &safe_read(1);
        $size = ord($byte);

        if ($size) {
            $block .= $byte . &safe_read($size);
        }
    } while ($size);

    return $block . "\x00";
}

sub get_colormap {
    my $size = shift;

    my $bytes = 3 * 2**($size+1);
    return &safe_read($bytes);
}

sub get_image {
    my $id_bytes = &safe_read(9);
    my $block = $id_bytes;

    my ($id_info, $id_flag) = unpack("A8 C", $id_bytes);
    if ($id_flag & 0x80) {
        $block .= &get_colormap($id_flag & 0x07);
    }

    $block .= &safe_read(1); # LZW minimum code size
    $block .= &get_data_block;

    return $block;
}

1;
__END__