#!/usr/bin/perl -w
#
# Fucking with the GIF format
# (C)2021 Pegasus Epsilon
# Educational purposes only
use strict;
use v5.10;
use POSIX;
select(((select STDOUT), $| = 1)[0]);
sub binread {
my @f = ( "C", "S", "L" );
my ($h, $l) = @_;
read $h, (my $t), $l or die "binread: end of file\n";
unpack $f[int(log($l)/log(2))], $t;
}
sub retread {
read shift, my $tmp, shift or die "retread: end of file\n";
$tmp;
}
sub match {
my $m = shift;
grep /$m/, @_;
}
die "No file specified\n" unless @ARGV;
open my $gif, "<:raw", $ARGV[0] or die "$ARGV[0]: file not found\n";
die "$ARGV[0] is not a GIF file.\n" unless "GIF" eq retread($gif, 3);
read $gif, my $dat, 3;
die "$ARGV[0] is not a GIF file.\n" unless match($dat, "87a", "89a");
say "$ARGV[0] is GIF version $dat";
say "canvas is " . binread($gif, 2) . "x" . binread($gif, 2);
my $flags = binread($gif, 1);
say "background color index: " . binread($gif, 1);
my $aspect = binread($gif, 1);
say "pixel aspect ratio is " . ($aspect
? ($aspect + 15) . "/64 (" . (($aspect + 15) / 64)
: "not specified"
);
my $tc = `tput colors` == 256;
sub fmt_color_table {
my $ct = shift;
$tc && do {
(join "\e[0m\n", map { join '', map {
"\e[48;2;" . (join ";", map { hex } unpack "a2" x 3) . "m "
} unpack "a6" x 32 } unpack "a192" x (length($ct) / 96),
join '', map { sprintf "%02X", $_ } unpack "C*", $ct) . "\e[0m";
} || do {
join ', ', map { s/(\n?)/$1#/; $_ } split /,/,
join "\n", unpack "a56" x (length($ct) / 3 / 8),
join ',', unpack "a6" x (length($ct) / 3),
join '', map { sprintf "%02X", $_ } unpack "C*", $ct;
}
}
if ($flags >> 7) {
print +($flags & 8 ? "" : "un") . "sorted global color table is ";
my $bpp = ($flags & 7) + 1;
my $ctl = 2 ** $bpp;
my $cts = 3 * $ctl;
say "$cts bytes ($ctl entries) long with " . ((($flags >> 4) & 7) + 1)
. " bits per channel:";
say fmt_color_table(retread($gif, $cts));
} else { say "global color table does not exist."; }
sub image_descriptor {
my $fh = shift;
printf "Image descriptor block at offset 0x%06X\n", tell $fh;
print "- position: " . binread($fh, 2) . "x" . binread($fh, 2);
say ", size: " . binread($fh, 2) . "x" . binread($fh, 2);
my $flags = binread($fh, 1);
if ($flags & (1 << 7)) {
print "- " . ($flags & 16 ? "" : "un") . "sorted local color table is ";
my $bpp = ($flags & 7) + 1;
my $ctl = 2 ** $bpp;
my $cts = 3 * $ctl;
say "$cts bytes long ($ctl entries):";
say fmt_color_table(retread($gif, $cts));
} else { say "- local color table is not present."; }
say "- image is " . ($flags & (1 << 6)
? "" : "not ") . "interlaced";
say "- LZW minimum code size: " . binread($fh, 1);
say "- Skipping LZW blocks...";
my $l;
while ($l = binread($fh, 1)) { retread($fh, $l); }
say "End of image descriptor.";
}
sub graphic_extension {
my $fh = shift;
printf "Graphic extension at offset 0x%06X\n", tell $fh;
for (;;) {
$_ = binread($fh, 1);
0xFF == $_ and do {
my $l = binread($fh, 1);
say '- Application extension: "' . retread($fh, $l) . '"';
$l = binread($fh, 1);
my $t = binread($fh, 1);
if (0x01 == $t) {
my $c = binread($fh, $l - 1);
say "-- Animation loops " . (!$c ? "forever" : "$c times");
} else {
seek $fh, -1, SEEK_CUR;
say "-- Unhandled sub-blocks, dumping...";
print chr $l;
print retread($fh, $l);
while ($l = binread($fh, 1)) {
print chr $l;
print retread($fh, $l);
}
say "\n-- End of unhandled sub-blocks.";
seek $fh, -1, SEEK_CUR; # rewind stream one byte
}
say "- End of application extension block.";
next;
};
0xFE == $_ and do {
say "- Comment sub-blocks, dumping...";
my $l = binread($fh, 1);
print chr $l;
print retread($fh, $l);
while ($l = binread($fh, 1)) {
print chr $l;
print retread($fh, $l);
}
say "\n- End of comment sub-blocks.";
seek $fh, -1, SEEK_CUR; # rewind stream one byte
next;
};
0xF9 == $_ and do {
my $l = binread($fh, 1);
say "- Graphic control extension block.";
my $flags = binread($fh, 1);
say "-- User can " . ($flags & 2
? "" : "not ") . "advance to next image with input";
my @disp = ( "none", "leave", "bg", "prev", "reserved" );
my $disp = ($flags >> 2) & 7;
$disp = $disp > 4 ? 4 : $disp;
say "-- Disposal method $disp($disp[$disp]) requested";
say "-- Image will be displayed for " .
binread($fh, 2) / 100 . " seconds.";
if ($flags & 1) {
say "-- Image's transparency index is " . binread($fh, 1) . ".";
} else { say "-- Image has no transparency."; binread($fh, 1); }
say "- End of graphic control extension block.";
next;
};
0x01 == $_ and do {
my $l = binread($fh, 1);
say "This plain text block is $l bytes long. Skipping...";
retread($fh, $l);
next;
};
0x00 == $_ and do {
say "End of graphic extension block.";
last;
};
my $o = tell $fh;
my $l = binread($fh, 1);
printf STDERR "UNKNOWN BLOCK 0x%02X LENGTH %d AT OFFSET 0x%06X\n", $_, $l, $o;
say join "\n", unpack "a48" x ceil($l / 16), join ' ', map { sprintf "%02X", $_ } unpack "C*", retread($gif, $l);
}
}
for (;;) {
$_ = binread($gif, 1);
0x21 == $_ and do {
graphic_extension($gif);
next;
};
0x2C == $_ and do {
image_descriptor($gif);
next;
};
0x3B == $_ and do {
printf "Found end of file marker at offset 0x%06X\n", tell($gif) - 1;
last;
};
printf "Unknown marker 0x%02X found at offset 0x%06X\n", $_, tell($gif) - 1;
}