[Date Prev][Date Next][Thread Prev][Thread Next]
[Search]
[Date Index]
[Thread Index]
Re: [MacPerl] GIF image size
>Bart Lateur writes:
>|Anybody interested in TIFF files ? :-)
>
I use the following from Marcus E. Hennecke to sort out various
image file sizes all the time. Works OK on UNIX although I have really
only used it for jpg and gif files. I had to tweak something
for use with NT so Im not sure how well it will work on the Mac.
The fix involved changing an unpack to use NETWORK byte order rather
than INTEL. This is the untweaked version... sorry.
## Copyright (C) 1995-96 by Marcus E. Hennecke
## This program is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation; either version 2 of the License, or
## (at your option) any later version.
## More precisely, you can use this program free of charge for
## commercial or non-commercial uses and you may even use fragments of
## the code in your own programs, provided that proper credit is
## given.
## This program is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU General Public License for more details.
## For a copy of the GNU General Public License write to the Free
## Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
# -------------------------------------------------------------------
# Define marker types
$M_SOF0 = "\xC0"; $M_SOF3 = "\xC3";
$M_SOF5 = "\xC5"; $M_SOF7 = "\xC3";
$M_SOF9 = "\xC9"; $M_SOF11 = "\xCB";
$M_SOF13 = "\xCD"; $M_SOF15 = "\xCF";
$M_SOI = "\xD8"; $M_EOI = "\xD9";
$M_SOS = "\xDA"; $FF = "\xFF";
sub image_size {
local($fname) = @_;
open(IN,"<$fname") || die "Couldn't open file $fname !\n";
# Check the first two bytes to see if this is a JPEG file
local($magic) = '';
eval { $magic = &read_n_bytes(2); };
$@ = '';
if ( $magic eq "$FF$M_SOI" ) {
# Appears to be a JPEG file
# Go through the markers in the header. Stop when height
# and width are determined or when end of header is
# reached.
while ( 1==1 ) {
# Get the next marker
$db = 0; $ch = &read_1_byte;
while ( $ch ne $FF ) {
$db++; $ch = &read_1_byte;
}
$ch = &read_1_byte while ( $ch eq $FF );
$db && die "Garbage data found in JPEG file\n";
# What type marker are we looking at?
# Do we have width and height yet?
if ( $ch ge $M_SOF0 && $ch le $M_SOF3 ||
$ch ge $M_SOF5 && $ch le $M_SOF7 ||
$ch ge $M_SOF9 && $ch le $M_SOF11 ||
$ch ge $M_SOF13 && $ch le $M_SOF15 ) {
($l,$d,$height,$width) =
unpack("SCSS",&read_n_bytes(7));
return($width, $height);
}
# Or have we reached the end of the header?
elsif ( $ch eq $M_SOS || $ch eq $M_EOI ) {
die "Found no width or height!\n";
}
# Otherwise, skip this variable
else {
$l = unpack("S",&read_n_bytes(2)) - 2;
($l < 0 ) && die "Erroneous JPEG marker length!\n";
&read_n_bytes($l);
};
}; # while ( 1==1 )
}
if ( $magic =~ /P[1-6]/ ) {
local($buffer) = '';
# Appears to be a PNM file
$width = 0+&read_string($buffer);
$height = 0+&read_string($buffer);
return($width, $height);
}
# Could it be a Sun raster file? Read a few more characters
$magic .= &read_n_bytes(2);
if ( $magic eq "\x59\xa6\x6a\x95" ) {
($width,$height) = unpack('NN',&read_n_bytes(8));
return($width, $height);
}
if ( $magic eq "MM\x00\x2a" || $magic eq "II\x2a\x00" ) {
# Appears to be a TIFF file
local($order, $ifd, $len);
local($tag, $type, $count);
local($width, $height, $flag);
$order = ($magic eq "MM\x00\x2a");
$ifd = ($order ? unpack('N', &read_n_bytes(4))
: unpack('V', &read_n_bytes(4)));
$flag = 0;
while ( $ifd ) {
seek(IN, $ifd, 0);
$len = ($order ? unpack('n', &read_n_bytes(2))
: unpack('v', &read_n_bytes(2)));
for ( ; $len > 0; $len-- ) {
($tag, $type, $count, $offset) = ( $order
? unpack('nnNN', &read_n_bytes(12))
: unpack('vvVV', &read_n_bytes(12)));
if ( $count == 1 && $type == 1 ) {
$offset >>= 24;
} elsif ( $count == 1 && $type == 3 ) {
$offset >>= 16;
}
if ( $tag == 256 ) {
$width = $offset;
return($width, $height) if ( $flag );
$flag = 1;
}
if ( $tag == 257 ) {
$height = $offset;
return($width, $height) if ( $flag );
$flag = 1;
}
}
$ifd = ($order ? unpack('N', &read_n_bytes(4))
: unpack('V', &read_n_bytes(4)));
}
die "TIFF file corrupt (no width or height found).\n";
}
# Could it be a GIF file? Read a few more characters
$magic .= &read_n_bytes(2);
if ( $magic eq "GIF87a" || $magic eq "GIF89a" ) {
($width,$height) = unpack('vv',&read_n_bytes(4));
return($width, $height);
}
# Could it be a XBM file? Read a few more characters
$magic .= &read_n_bytes(2);
if ( $magic =~ /#define\s/ ) {
# This might in fact be one, read next two lines
$magic .= <IN> . <IN>;
if ( $magic =~
/^#define\s+\S+_width\s+(\d+)\s*\n#define\s+\S+_height\s+(\d+)\s*\n/ ) {
return ($1, $2);
} else {
die "Not a known image format.\n";
};
}
# Could it be a PNG file?
if ( $magic eq "\x89PNG\x0d\x0a\x1a\x0a" ) {
&read_n_bytes(4); # Skip chunk length
if ( &read_n_bytes(4) ne "IHDR" ) {
die "PNG file seems corrupted.\n";
}
($width,$height) = unpack('NN',&read_n_bytes(8));
return($width, $height);
}
print "Not a known image format.\n";
}
# Reads one byte. If EOF is reached, terminates with an error message.
sub read_1_byte {
local($ch);
($ch = getc(IN)) || die "Premature EOF in image file!\n";
$ch;
}
# Reads N bytes. If EOF is reached, terminates with an error message.
sub read_n_bytes {
local($n) = @_;
local($ch);
read(IN,$ch,$n) == $n || die "Premature EOF in image file!\n";
$ch;
}
sub read_string {
local($str) = '';
local($buf);
local($*) = 1;
do {
if ($_[0] =~ s/^\s*(\S+)(\s+)/$2/) {
$str = $1;
if (substr($str,0,1) eq '#') {
$str = '';
$_[0] =~ s/^[^\n\r]*//;
until ($_[0]) {
read(IN, $_[0], 256);
$_[0] =~ s/^[^\n\r]*//;
}
}
} else {
read(IN, $buf, 256);
$_[0] .= $buf;
}
} until ($str);
$str;
}
======================================================================
Fergus McMenemie Email:fergus@twig.demon.co.uk.
Technical Basis Phone:0421 376 021
Unix/Mac/Intranets Analyst Programmer
======================================================================
***** Want to unsubscribe from this list?
***** Send mail with body "unsubscribe" to mac-perl-request@iis.ee.ethz.ch