| 1 | ###############################################################################
|
|---|
| 2 | #
|
|---|
| 3 | # This file copyright (c) 2000 by Randy J. Ray, all rights reserved
|
|---|
| 4 | #
|
|---|
| 5 | # Copying and distribution are permitted under the terms of the Artistic
|
|---|
| 6 | # License as distributed with Perl versions 5.005 and later.
|
|---|
| 7 | #
|
|---|
| 8 | ###############################################################################
|
|---|
| 9 | #
|
|---|
| 10 | # Once upon a time, this code was lifted almost verbatim from wwwis by Alex
|
|---|
| 11 | # Knowles, [email protected]. Since then, even I barely recognize it. It has
|
|---|
| 12 | # contributions, fixes, additions and enhancements from all over the world.
|
|---|
| 13 | #
|
|---|
| 14 | # See the file README for change history.
|
|---|
| 15 | #
|
|---|
| 16 | ###############################################################################
|
|---|
| 17 |
|
|---|
| 18 | package Image::Size;
|
|---|
| 19 |
|
|---|
| 20 | # require 5.6.0;
|
|---|
| 21 | require 5.006_000;
|
|---|
| 22 |
|
|---|
| 23 | use strict;
|
|---|
| 24 | use bytes;
|
|---|
| 25 | use Cwd ();
|
|---|
| 26 | use File::Spec ();
|
|---|
| 27 | use Symbol ();
|
|---|
| 28 | use AutoLoader 'AUTOLOAD';
|
|---|
| 29 | require Exporter;
|
|---|
| 30 |
|
|---|
| 31 | our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $revision, $VERSION, $NO_CACHE,
|
|---|
| 32 | $GIF_BEHAVIOR, %PCD_MAP, $PCD_SCALE, $read_in, $last_pos);
|
|---|
| 33 |
|
|---|
| 34 | BEGIN
|
|---|
| 35 | {
|
|---|
| 36 |
|
|---|
| 37 | @ISA = qw(Exporter);
|
|---|
| 38 | @EXPORT = qw(imgsize);
|
|---|
| 39 | @EXPORT_OK = qw(imgsize html_imgsize attr_imgsize $NO_CACHE $PCD_SCALE
|
|---|
| 40 | $GIF_BEHAVIOR);
|
|---|
| 41 | %EXPORT_TAGS = ('all' => [ @EXPORT_OK ]);
|
|---|
| 42 |
|
|---|
| 43 | $VERSION = "3.01";
|
|---|
| 44 |
|
|---|
| 45 | # Default behavior for GIFs is to return the "screen" size
|
|---|
| 46 | $GIF_BEHAVIOR = 0;
|
|---|
| 47 |
|
|---|
| 48 | }
|
|---|
| 49 |
|
|---|
| 50 | # This allows people to specifically request that the cache not be used
|
|---|
| 51 | $NO_CACHE = 0;
|
|---|
| 52 |
|
|---|
| 53 | # Package lexicals - invisible to outside world, used only in imgsize
|
|---|
| 54 | #
|
|---|
| 55 | # Cache of files seen, and mapping of patterns to the sizing routine
|
|---|
| 56 | my %cache = ();
|
|---|
| 57 | my %type_map = ( '^GIF8[7,9]a' => \&gifsize,
|
|---|
| 58 | "^\xFF\xD8" => \&jpegsize,
|
|---|
| 59 | "^\x89PNG\x0d\x0a\x1a\x0a" => \&pngsize,
|
|---|
| 60 | "^P[1-7]" => \&ppmsize, # also XVpics
|
|---|
| 61 | '\#define\s+\S+\s+\d+' => \&xbmsize,
|
|---|
| 62 | '\/\* XPM \*\/' => \&xpmsize,
|
|---|
| 63 | '^MM\x00\x2a' => \&tiffsize,
|
|---|
| 64 | '^II\x2a\x00' => \&tiffsize,
|
|---|
| 65 | '^BM' => \&bmpsize,
|
|---|
| 66 | '^8BPS' => \&psdsize,
|
|---|
| 67 | '^PCD_OPA' => \&pcdsize,
|
|---|
| 68 | '^FWS' => \&swfsize,
|
|---|
| 69 | '^CWS' => \&swfmxsize,
|
|---|
| 70 | "^\x8aMNG\x0d\x0a\x1a\x0a" => \&mngsize);
|
|---|
| 71 | # Kodak photo-CDs are weird. Don't ask me why, you really don't want details.
|
|---|
| 72 | %PCD_MAP = ( 'base/16' => [ 192, 128 ],
|
|---|
| 73 | 'base/4' => [ 384, 256 ],
|
|---|
| 74 | 'base' => [ 768, 512 ],
|
|---|
| 75 | 'base4' => [ 1536, 1024 ],
|
|---|
| 76 | 'base16' => [ 3072, 2048 ],
|
|---|
| 77 | 'base64' => [ 6144, 4096 ] );
|
|---|
| 78 | # Default scale for PCD images
|
|---|
| 79 | $PCD_SCALE = 'base';
|
|---|
| 80 |
|
|---|
| 81 | #
|
|---|
| 82 | # These are lexically-scoped anonymous subroutines for reading the three
|
|---|
| 83 | # types of input streams. When the input to imgsize() is typed, then the
|
|---|
| 84 | # lexical "read_in" is assigned one of these, thus allowing the individual
|
|---|
| 85 | # routines to operate on these streams abstractly.
|
|---|
| 86 | #
|
|---|
| 87 |
|
|---|
| 88 | my $read_io = sub {
|
|---|
| 89 | my $handle = shift;
|
|---|
| 90 | my ($length, $offset) = @_;
|
|---|
| 91 |
|
|---|
| 92 | if (defined($offset) && ($offset != $last_pos))
|
|---|
| 93 | {
|
|---|
| 94 | $last_pos = $offset;
|
|---|
| 95 | return '' if (! seek($handle, $offset, 0));
|
|---|
| 96 | }
|
|---|
| 97 |
|
|---|
| 98 | my ($data, $rtn) = ('', 0);
|
|---|
| 99 | $rtn = read $handle, $data, $length;
|
|---|
| 100 | $data = '' unless ($rtn);
|
|---|
| 101 | $last_pos = tell $handle;
|
|---|
| 102 |
|
|---|
| 103 | $data;
|
|---|
| 104 | };
|
|---|
| 105 |
|
|---|
| 106 | my $read_buf = sub {
|
|---|
| 107 | my $buf = shift;
|
|---|
| 108 | my ($length, $offset) = @_;
|
|---|
| 109 |
|
|---|
| 110 | if (defined($offset) && ($offset != $last_pos))
|
|---|
| 111 | {
|
|---|
| 112 | $last_pos = $offset;
|
|---|
| 113 | return '' if ($last_pos > length($$buf));
|
|---|
| 114 | }
|
|---|
| 115 |
|
|---|
| 116 | my $data = substr($$buf, $last_pos, $length);
|
|---|
| 117 | $last_pos += length($data);
|
|---|
| 118 |
|
|---|
| 119 | $data;
|
|---|
| 120 | };
|
|---|
| 121 |
|
|---|
| 122 | sub imgsize
|
|---|
| 123 | {
|
|---|
| 124 | my $stream = shift;
|
|---|
| 125 |
|
|---|
| 126 | my ($handle, $header);
|
|---|
| 127 | my ($x, $y, $id, $mtime, @list);
|
|---|
| 128 | # These only used if $stream is an existant open FH
|
|---|
| 129 | my ($save_pos, $need_restore) = (0, 0);
|
|---|
| 130 | # This is for when $stream is a locally-opened file
|
|---|
| 131 | my $need_close = 0;
|
|---|
| 132 | # This will contain the file name, if we got one
|
|---|
| 133 | my $file_name = undef;
|
|---|
| 134 |
|
|---|
| 135 | $header = '';
|
|---|
| 136 |
|
|---|
| 137 | if (ref($stream) eq "SCALAR")
|
|---|
| 138 | {
|
|---|
| 139 | $handle = $stream;
|
|---|
| 140 | $read_in = $read_buf;
|
|---|
| 141 | $header = substr(($$handle || ''), 0, 256);
|
|---|
| 142 | }
|
|---|
| 143 | elsif (ref $stream)
|
|---|
| 144 | {
|
|---|
| 145 | #
|
|---|
| 146 | # I no longer require $stream to be in the IO::* space. So I'm assuming
|
|---|
| 147 | # you don't hose yourself by passing a ref that can't do fileops. If
|
|---|
| 148 | # you do, you fix it.
|
|---|
| 149 | #
|
|---|
| 150 | $handle = $stream;
|
|---|
| 151 | $read_in = $read_io;
|
|---|
| 152 | $save_pos = tell $handle;
|
|---|
| 153 | $need_restore = 1;
|
|---|
| 154 |
|
|---|
| 155 | #
|
|---|
| 156 | # First alteration (didn't wait long, did I?) to the existant handle:
|
|---|
| 157 | #
|
|---|
| 158 | # assist dain-bramaged operating systems -- SWD
|
|---|
| 159 | # SWD: I'm a bit uncomfortable with changing the mode on a file
|
|---|
| 160 | # that something else "owns" ... the change is global, and there
|
|---|
| 161 | # is no way to reverse it.
|
|---|
| 162 | # But image files ought to be handled as binary anyway.
|
|---|
| 163 | #
|
|---|
| 164 | binmode($handle);
|
|---|
| 165 | seek($handle, 0, 0);
|
|---|
| 166 | read $handle, $header, 256;
|
|---|
| 167 | seek($handle, 0, 0);
|
|---|
| 168 | }
|
|---|
| 169 | else
|
|---|
| 170 | {
|
|---|
| 171 | unless ($NO_CACHE)
|
|---|
| 172 | {
|
|---|
| 173 | $stream = File::Spec->catfile(Cwd::cwd(),$stream)
|
|---|
| 174 | unless File::Spec->file_name_is_absolute($stream);
|
|---|
| 175 | $mtime = (stat $stream)[9];
|
|---|
| 176 | if (-e "$stream" and exists $cache{$stream})
|
|---|
| 177 | {
|
|---|
| 178 | @list = split(/,/, $cache{$stream}, 4);
|
|---|
| 179 |
|
|---|
| 180 | # Don't return the cache if the file is newer.
|
|---|
| 181 | return @list[1 .. 3] unless ($list[0] < $mtime);
|
|---|
| 182 | # In fact, clear it
|
|---|
| 183 | delete $cache{$stream};
|
|---|
| 184 | }
|
|---|
| 185 | }
|
|---|
| 186 |
|
|---|
| 187 | #first try to open the stream
|
|---|
| 188 | $handle = Symbol::gensym();
|
|---|
| 189 | open($handle, "< $stream") or
|
|---|
| 190 | return (undef, undef, "Can't open image file $stream: $!");
|
|---|
| 191 |
|
|---|
| 192 | $need_close = 1;
|
|---|
| 193 | # assist dain-bramaged operating systems -- SWD
|
|---|
| 194 | binmode($handle);
|
|---|
| 195 | read $handle, $header, 256;
|
|---|
| 196 | seek($handle, 0, 0);
|
|---|
| 197 | $read_in = $read_io;
|
|---|
| 198 | $file_name = $stream;
|
|---|
| 199 | }
|
|---|
| 200 | $last_pos = 0;
|
|---|
| 201 |
|
|---|
| 202 | #
|
|---|
| 203 | # Oh pessimism... set the values of $x and $y to the error condition. If
|
|---|
| 204 | # the grep() below matches the data to one of the known types, then the
|
|---|
| 205 | # called subroutine will override these...
|
|---|
| 206 | #
|
|---|
| 207 | $id = "Data stream is not a known image file format";
|
|---|
| 208 | $x = undef;
|
|---|
| 209 | $y = undef;
|
|---|
| 210 |
|
|---|
| 211 | grep($header =~ /$_/ && (($x, $y, $id) = &{$type_map{$_}}($handle)),
|
|---|
| 212 | keys %type_map);
|
|---|
| 213 |
|
|---|
| 214 | #
|
|---|
| 215 | # Added as an afterthought: I'm probably not the only one who uses the
|
|---|
| 216 | # same shaded-sphere image for several items on a bulleted list:
|
|---|
| 217 | #
|
|---|
| 218 | $cache{$stream} = join(',', $mtime, $x, $y, $id)
|
|---|
| 219 | unless ($NO_CACHE or (ref $stream) or (! defined $x));
|
|---|
| 220 |
|
|---|
| 221 | #
|
|---|
| 222 | # If we were passed an existant file handle, we need to restore the
|
|---|
| 223 | # old filepos:
|
|---|
| 224 | #
|
|---|
| 225 | seek($handle, $save_pos, 0) if $need_restore;
|
|---|
| 226 | # ...and if we opened the file ourselves, we need to close it
|
|---|
| 227 | close($handle) if $need_close;
|
|---|
| 228 |
|
|---|
| 229 | #
|
|---|
| 230 | # Image::Magick operates on file names.
|
|---|
| 231 | #
|
|---|
| 232 | if ($file_name && ! defined($x) && ! defined($y)) {
|
|---|
| 233 | ($x, $y, $id) = imagemagick_size($file_name);
|
|---|
| 234 | }
|
|---|
| 235 |
|
|---|
| 236 |
|
|---|
| 237 | # results:
|
|---|
| 238 | return (wantarray) ? ($x, $y, $id) : ();
|
|---|
| 239 | }
|
|---|
| 240 |
|
|---|
| 241 | sub imagemagick_size {
|
|---|
| 242 | my $module_name;
|
|---|
| 243 | # First see if we have already loaded Graphics::Magick or Image::Magick
|
|---|
| 244 | # If so, just use whichever one is already loaded.
|
|---|
| 245 | if (exists $INC{'Graphics/Magick.pm'}) {
|
|---|
| 246 | $module_name = 'Graphics::Magick';
|
|---|
| 247 | }
|
|---|
| 248 | elsif (exists $INC{'Image/Magick.pm'}) {
|
|---|
| 249 | $module_name = 'Image::Magick';
|
|---|
| 250 | }
|
|---|
| 251 |
|
|---|
| 252 | # If neither are already loaded, try loading either one.
|
|---|
| 253 | elsif ( _load_magick_module('Graphics::Magick') ) {
|
|---|
| 254 | $module_name = 'Graphics::Magick';
|
|---|
| 255 | }
|
|---|
| 256 | elsif ( _load_magick_module('Image::Magick') ) {
|
|---|
| 257 | $module_name = 'Image::Magick';
|
|---|
| 258 | }
|
|---|
| 259 |
|
|---|
| 260 | if ($module_name) {
|
|---|
| 261 | my ($file_name) = @_;
|
|---|
| 262 | my $img = $module_name->new();
|
|---|
| 263 | my $x = $img->Read($file_name);
|
|---|
| 264 | # Image::Magick error handling is a bit weird, see
|
|---|
| 265 | # <http://www.simplesystems.org/ImageMagick/www/perl.html#erro>
|
|---|
| 266 | if("$x") {
|
|---|
| 267 | return (undef, undef, "$x");
|
|---|
| 268 | } else {
|
|---|
| 269 | return ($img->Get('width', 'height', 'format'));
|
|---|
| 270 | }
|
|---|
| 271 |
|
|---|
| 272 | }
|
|---|
| 273 | else {
|
|---|
| 274 | return (undef, undef, "Data stream is not a known image file format");
|
|---|
| 275 | }
|
|---|
| 276 | }
|
|---|
| 277 |
|
|---|
| 278 | # load Graphics::Magick or Image::Magick if one is not already loaded.
|
|---|
| 279 | sub _load_magick_module {
|
|---|
| 280 | my $module_name = shift;
|
|---|
| 281 | eval {
|
|---|
| 282 | local $SIG{__DIE__};
|
|---|
| 283 | require $module_name;
|
|---|
| 284 | };
|
|---|
| 285 | return !$@;
|
|---|
| 286 | }
|
|---|
| 287 |
|
|---|
| 288 |
|
|---|
| 289 | sub html_imgsize
|
|---|
| 290 | {
|
|---|
| 291 | my @args = imgsize(@_);
|
|---|
| 292 |
|
|---|
| 293 | # Use lowercase and quotes so that it works with xhtml.
|
|---|
| 294 | return ((defined $args[0]) ?
|
|---|
| 295 | sprintf('width="%d" height="%d"', @args) :
|
|---|
| 296 | undef);
|
|---|
| 297 | }
|
|---|
| 298 |
|
|---|
| 299 | sub attr_imgsize
|
|---|
| 300 | {
|
|---|
| 301 | my @args = imgsize(@_);
|
|---|
| 302 |
|
|---|
| 303 | return ((defined $args[0]) ?
|
|---|
| 304 | (('-width', '-height', @args)[0, 2, 1, 3]) :
|
|---|
| 305 | undef);
|
|---|
| 306 | }
|
|---|
| 307 |
|
|---|
| 308 | # This used only in gifsize:
|
|---|
| 309 | sub img_eof
|
|---|
| 310 | {
|
|---|
| 311 | my $stream = shift;
|
|---|
| 312 |
|
|---|
| 313 | return ($last_pos >= length($$stream)) if (ref($stream) eq "SCALAR");
|
|---|
| 314 |
|
|---|
| 315 | eof $stream;
|
|---|
| 316 | }
|
|---|
| 317 |
|
|---|
| 318 | # Simple converter-routine used by SWF and CWS code
|
|---|
| 319 | sub _bin2int { unpack("N", pack("B32", substr("0" x 32 . shift, -32))); }
|
|---|
| 320 |
|
|---|
| 321 | =head1 NAME
|
|---|
| 322 |
|
|---|
| 323 | Image::Size - read the dimensions of an image in several popular formats
|
|---|
| 324 |
|
|---|
| 325 | =head1 SYNOPSIS
|
|---|
| 326 |
|
|---|
| 327 | use Image::Size;
|
|---|
| 328 | # Get the size of globe.gif
|
|---|
| 329 | ($globe_x, $globe_y) = imgsize("globe.gif");
|
|---|
| 330 | # Assume X=60 and Y=40 for remaining examples
|
|---|
| 331 |
|
|---|
| 332 | use Image::Size 'html_imgsize';
|
|---|
| 333 | # Get the size as 'width="X" height="Y"' for HTML generation
|
|---|
| 334 | $size = html_imgsize("globe.gif");
|
|---|
| 335 | # $size == 'width="60" height="40"'
|
|---|
| 336 |
|
|---|
| 337 | use Image::Size 'attr_imgsize';
|
|---|
| 338 | # Get the size as a list passable to routines in CGI.pm
|
|---|
| 339 | @attrs = attr_imgsize("globe.gif");
|
|---|
| 340 | # @attrs == ('-width', 60, '-height', 40)
|
|---|
| 341 |
|
|---|
| 342 | use Image::Size;
|
|---|
| 343 | # Get the size of an in-memory buffer
|
|---|
| 344 | ($buf_x, $buf_y) = imgsize(\$buf);
|
|---|
| 345 | # Assuming that $buf was the data, imgsize() needed a reference to a scalar
|
|---|
| 346 |
|
|---|
| 347 | =head1 DESCRIPTION
|
|---|
| 348 |
|
|---|
| 349 | The B<Image::Size> library is based upon the C<wwwis> script written by
|
|---|
| 350 | Alex Knowles I<([email protected])>, a tool to examine HTML and add 'width' and
|
|---|
| 351 | 'height' parameters to image tags. The sizes are cached internally based on
|
|---|
| 352 | file name, so multiple calls on the same file name (such as images used
|
|---|
| 353 | in bulleted lists, for example) do not result in repeated computations.
|
|---|
| 354 |
|
|---|
| 355 | B<Image::Size> provides three interfaces for possible import:
|
|---|
| 356 |
|
|---|
| 357 | =over
|
|---|
| 358 |
|
|---|
| 359 | =item imgsize(I<stream>)
|
|---|
| 360 |
|
|---|
| 361 | Returns a three-item list of the X and Y dimensions (width and height, in
|
|---|
| 362 | that order) and image type of I<stream>. Errors are noted by undefined
|
|---|
| 363 | (B<undef>) values for the first two elements, and an error string in the third.
|
|---|
| 364 | The third element can be (and usually is) ignored, but is useful when
|
|---|
| 365 | sizing data whose type is unknown.
|
|---|
| 366 |
|
|---|
| 367 | =item html_imgsize(I<stream>)
|
|---|
| 368 |
|
|---|
| 369 | Returns the width and height (X and Y) of I<stream> pre-formatted as a single
|
|---|
| 370 | string C<'width="X" height="Y"'> suitable for addition into generated HTML IMG
|
|---|
| 371 | tags. If the underlying call to C<imgsize> fails, B<undef> is returned. The
|
|---|
| 372 | format returned is dually suited to both HTML and XHTML.
|
|---|
| 373 |
|
|---|
| 374 | =item attr_imgsize(I<stream>)
|
|---|
| 375 |
|
|---|
| 376 | Returns the width and height of I<stream> as part of a 4-element list useful
|
|---|
| 377 | for routines that use hash tables for the manipulation of named parameters,
|
|---|
| 378 | such as the Tk or CGI libraries. A typical return value looks like
|
|---|
| 379 | C<("-width", X, "-height", Y)>. If the underlying call to C<imgsize> fails,
|
|---|
| 380 | B<undef> is returned.
|
|---|
| 381 |
|
|---|
| 382 | =back
|
|---|
| 383 |
|
|---|
| 384 | By default, only C<imgsize()> is exported. Any one or combination of the three
|
|---|
| 385 | may be explicitly imported, or all three may be with the tag B<:all>.
|
|---|
| 386 |
|
|---|
| 387 | =head2 Input Types
|
|---|
| 388 |
|
|---|
| 389 | The sort of data passed as I<stream> can be one of three forms:
|
|---|
| 390 |
|
|---|
| 391 | =over
|
|---|
| 392 |
|
|---|
| 393 | =item string
|
|---|
| 394 |
|
|---|
| 395 | If an ordinary scalar (string) is passed, it is assumed to be a file name
|
|---|
| 396 | (either absolute or relative to the current working directory of the
|
|---|
| 397 | process) and is searched for and opened (if found) as the source of data.
|
|---|
| 398 | Possible error messages (see DIAGNOSTICS below) may include file-access
|
|---|
| 399 | problems.
|
|---|
| 400 |
|
|---|
| 401 | =item scalar reference
|
|---|
| 402 |
|
|---|
| 403 | If the passed-in stream is a scalar reference, it is interpreted as pointing
|
|---|
| 404 | to an in-memory buffer containing the image data.
|
|---|
| 405 |
|
|---|
| 406 | # Assume that &read_data gets data somewhere (WWW, etc.)
|
|---|
| 407 | $img = &read_data;
|
|---|
| 408 | ($x, $y, $id) = imgsize(\$img);
|
|---|
| 409 | # $x and $y are dimensions, $id is the type of the image
|
|---|
| 410 |
|
|---|
| 411 | =item Open file handle
|
|---|
| 412 |
|
|---|
| 413 | The third option is to pass in an open filehandle (such as an object of
|
|---|
| 414 | the C<IO::File> class, for example) that has already been associated with
|
|---|
| 415 | the target image file. The file pointer will necessarily move, but will be
|
|---|
| 416 | restored to its original position before subroutine end.
|
|---|
| 417 |
|
|---|
| 418 | # $fh was passed in, is IO::File reference:
|
|---|
| 419 | ($x, $y, $id) = imgsize($fh);
|
|---|
| 420 | # Same as calling with filename, but more abstract.
|
|---|
| 421 |
|
|---|
| 422 | =back
|
|---|
| 423 |
|
|---|
| 424 | =head2 Recognized Formats
|
|---|
| 425 |
|
|---|
| 426 | Image::Size natively understands and sizes data in the following formats:
|
|---|
| 427 |
|
|---|
| 428 | =over 4
|
|---|
| 429 |
|
|---|
| 430 | =item GIF
|
|---|
| 431 |
|
|---|
| 432 | =item JPG
|
|---|
| 433 |
|
|---|
| 434 | =item XBM
|
|---|
| 435 |
|
|---|
| 436 | =item XPM
|
|---|
| 437 |
|
|---|
| 438 | =item PPM family (PPM/PGM/PBM)
|
|---|
| 439 |
|
|---|
| 440 | =item XV thumbnails
|
|---|
| 441 |
|
|---|
| 442 | =item PNG
|
|---|
| 443 |
|
|---|
| 444 | =item MNG
|
|---|
| 445 |
|
|---|
| 446 | =item TIF
|
|---|
| 447 |
|
|---|
| 448 | =item BMP
|
|---|
| 449 |
|
|---|
| 450 | =item PSD (Adobe PhotoShop)
|
|---|
| 451 |
|
|---|
| 452 | =item SWF (ShockWave/Flash)
|
|---|
| 453 |
|
|---|
| 454 | =item CWS (FlashMX, compressed SWF, Flash 6)
|
|---|
| 455 |
|
|---|
| 456 | =item PCD (Kodak PhotoCD, see notes below)
|
|---|
| 457 |
|
|---|
| 458 | =back
|
|---|
| 459 |
|
|---|
| 460 | Additionally, if the B<Image::Magick> module is present, the file types
|
|---|
| 461 | supported by it are also supported by Image::Size. See also L<"CAVEATS">.
|
|---|
| 462 |
|
|---|
| 463 | When using the C<imgsize> interface, there is a third, unused value returned
|
|---|
| 464 | if the programmer wishes to save and examine it. This value is the identity of
|
|---|
| 465 | the data type, expressed as a 2-3 letter abbreviation as listed above. This is
|
|---|
| 466 | useful when operating on open file handles or in-memory data, where the type
|
|---|
| 467 | is as unknown as the size. The two support routines ignore this third return
|
|---|
| 468 | value, so those wishing to use it must use the base C<imgsize> routine.
|
|---|
| 469 |
|
|---|
| 470 | Note that when the B<Image::Magick> fallback is used (for all non-natively
|
|---|
| 471 | supported files), the data type identity comes directly from the 'format'
|
|---|
| 472 | parameter reported by B<Image::Magick>, so it may not meet the 2-3 letter
|
|---|
| 473 | abbreviation format. For example, a WBMP file might be reported as
|
|---|
| 474 | 'Wireless Bitmap (level 0) image' in this case.
|
|---|
| 475 |
|
|---|
| 476 | =head2 Information Cacheing and C<$NO_CACHE>
|
|---|
| 477 |
|
|---|
| 478 | When a filename is passed to any of the sizing routines, the default behavior
|
|---|
| 479 | of the library is to cache the resulting information. The modification-time of
|
|---|
| 480 | the file is also recorded, to determine whether the cache should be purged and
|
|---|
| 481 | updated. This was originally added due to the fact that a number of CGI
|
|---|
| 482 | applications were using this library to generate attributes for pages that
|
|---|
| 483 | often used the same graphical element many times over.
|
|---|
| 484 |
|
|---|
| 485 | However, the cacheing can lead to problems when the files are generated
|
|---|
| 486 | dynamically, at a rate that exceeds the resolution of the modification-time
|
|---|
| 487 | value on the filesystem. Thus, the optionally-importable control variable
|
|---|
| 488 | C<$NO_CACHE> has been introduced. If this value is anything that evaluates to a
|
|---|
| 489 | non-false value (be that the value 1, any non-null string, etc.) then the
|
|---|
| 490 | cacheing is disabled until such time as the program re-enables it by setting
|
|---|
| 491 | the value to false.
|
|---|
| 492 |
|
|---|
| 493 | The parameter C<$NO_CACHE> may be imported as with the B<imgsize> routine, and
|
|---|
| 494 | is also imported when using the import tag B<C<:all>>. If the programmer
|
|---|
| 495 | chooses not to import it, it is still accessible by the fully-qualified package
|
|---|
| 496 | name, B<$Image::Size::NO_CACHE>.
|
|---|
| 497 |
|
|---|
| 498 | =head2 Sizing PhotoCD Images
|
|---|
| 499 |
|
|---|
| 500 | With version 2.95, support for the Kodak PhotoCD image format is
|
|---|
| 501 | included. However, these image files are not quite like the others. One file
|
|---|
| 502 | is the source of the image in any of a range of pre-set resolutions (all with
|
|---|
| 503 | the same aspect ratio). Supporting this here is tricky, since there is nothing
|
|---|
| 504 | inherent in the file to limit it to a specific resolution.
|
|---|
| 505 |
|
|---|
| 506 | The library addresses this by using a scale mapping, and requiring the user
|
|---|
| 507 | (you) to specify which scale is preferred for return. Like the C<$NO_CACHE>
|
|---|
| 508 | setting described earlier, this is an importable scalar variable that may be
|
|---|
| 509 | used within the application that uses B<Image::Size>. This parameter is called
|
|---|
| 510 | C<$PCD_SCALE>, and is imported by the same name. It, too, is also imported
|
|---|
| 511 | when using the tag B<C<:all>> or may be referenced as
|
|---|
| 512 | B<$Image::Size::PCD_SCALE>.
|
|---|
| 513 |
|
|---|
| 514 | The parameter should be set to one of the following values:
|
|---|
| 515 |
|
|---|
| 516 | base/16
|
|---|
| 517 | base/4
|
|---|
| 518 | base
|
|---|
| 519 | base4
|
|---|
| 520 | base16
|
|---|
| 521 | base64
|
|---|
| 522 |
|
|---|
| 523 | Note that not all PhotoCD disks will have included the C<base64>
|
|---|
| 524 | resolution. The actual resolutions are not listed here, as they are constant
|
|---|
| 525 | and can be found in any documentation on the PCD format. The value of
|
|---|
| 526 | C<$PCD_SCALE> is treated in a case-insensitive manner, so C<base> is the same
|
|---|
| 527 | as C<Base> or C<BaSe>. The default scale is set to C<base>.
|
|---|
| 528 |
|
|---|
| 529 | Also note that the library makes no effort to read enough of the PCD file to
|
|---|
| 530 | verify that the requested resolution is available. The point of this library
|
|---|
| 531 | is to read as little as necessary so as to operate efficiently. Thus, the only
|
|---|
| 532 | real difference to be found is in whether the orientation of the image is
|
|---|
| 533 | portrait or landscape. That is in fact all that the library extracts from the
|
|---|
| 534 | image file.
|
|---|
| 535 |
|
|---|
| 536 | =head2 Controlling Behavior with GIF Images
|
|---|
| 537 |
|
|---|
| 538 | GIF images present a sort of unusual situation when it comes to reading size.
|
|---|
| 539 | Because GIFs can be a series of sub-images to be isplayed as an animated
|
|---|
| 540 | sequence, what part does the user want to get the size for?
|
|---|
| 541 |
|
|---|
| 542 | When dealing with GIF files, the user may control the behavior by setting the
|
|---|
| 543 | global value B<$Image::Size::GIF_BEHAVIOR>. Like the PCD setting, this may
|
|---|
| 544 | be imported when loading the library. Three values are recognized by the
|
|---|
| 545 | GIF-handling code:
|
|---|
| 546 |
|
|---|
| 547 | =over 4
|
|---|
| 548 |
|
|---|
| 549 | =item 0
|
|---|
| 550 |
|
|---|
| 551 | This is the default value. When this value is chosen, the returned dimensions
|
|---|
| 552 | are those of the "screen". The "screen" is the display area that the GIF
|
|---|
| 553 | declares in the first data block of the file. No sub-images will be greater
|
|---|
| 554 | than this in size; if they are, the specification dictates that they be
|
|---|
| 555 | cropped to fit within the box.
|
|---|
| 556 |
|
|---|
| 557 | This is also the fastest method for sizing the GIF, as it reads the least
|
|---|
| 558 | amount of data from the image stream.
|
|---|
| 559 |
|
|---|
| 560 | =item 1
|
|---|
| 561 |
|
|---|
| 562 | If this value is set, then the size of the first sub-image within the GIF is
|
|---|
| 563 | returned. For plain (non-animated) GIF files, this would be the same as the
|
|---|
| 564 | screen (though it doesn't have to be, strictly-speaking).
|
|---|
| 565 |
|
|---|
| 566 | When the first image descriptor block is read, the code immediately returns,
|
|---|
| 567 | making this only slightly-less efficient than the previous setting.
|
|---|
| 568 |
|
|---|
| 569 | =item 2
|
|---|
| 570 |
|
|---|
| 571 | If this value is chosen, then the code loops through all the sub-images of the
|
|---|
| 572 | animated GIF, and returns the dimensions of the largest of them.
|
|---|
| 573 |
|
|---|
| 574 | This option requires that the full GIF image be read, in order to ensure that
|
|---|
| 575 | the largest is found.
|
|---|
| 576 |
|
|---|
| 577 | =back
|
|---|
| 578 |
|
|---|
| 579 | Any value outside this range will produce an error in the GIF code before any
|
|---|
| 580 | image data is read.
|
|---|
| 581 |
|
|---|
| 582 | The value of dimensions other than the view-port ("screen") is dubious.
|
|---|
| 583 | However, some users have asked for that functionality.
|
|---|
| 584 |
|
|---|
| 585 | =head1 DIAGNOSTICS
|
|---|
| 586 |
|
|---|
| 587 | The base routine, C<imgsize>, returns B<undef> as the first value in its list
|
|---|
| 588 | when an error has occured. The third element contains a descriptive
|
|---|
| 589 | error message.
|
|---|
| 590 |
|
|---|
| 591 | The other two routines simply return B<undef> in the case of error.
|
|---|
| 592 |
|
|---|
| 593 | =head1 MORE EXAMPLES
|
|---|
| 594 |
|
|---|
| 595 | The B<attr_imgsize> interface is also well-suited to use with the Tk
|
|---|
| 596 | extension:
|
|---|
| 597 |
|
|---|
| 598 | $image = $widget->Photo(-file => $img_path, attr_imgsize($img_path));
|
|---|
| 599 |
|
|---|
| 600 | Since the C<Tk::Image> classes use dashed option names as C<CGI> does, no
|
|---|
| 601 | further translation is needed.
|
|---|
| 602 |
|
|---|
| 603 | This package is also well-suited for use within an Apache web server context.
|
|---|
| 604 | File sizes are cached upon read (with a check against the modified time of
|
|---|
| 605 | the file, in case of changes), a useful feature for a B<mod_perl> environment
|
|---|
| 606 | in which a child process endures beyond the lifetime of a single request.
|
|---|
| 607 | Other aspects of the B<mod_perl> environment cooperate nicely with this
|
|---|
| 608 | module, such as the ability to use a sub-request to fetch the full pathname
|
|---|
| 609 | for a file within the server space. This complements the HTML generation
|
|---|
| 610 | capabilities of the B<CGI> module, in which C<CGI::img> wants a URL but
|
|---|
| 611 | C<attr_imgsize> needs a file path:
|
|---|
| 612 |
|
|---|
| 613 | # Assume $Q is an object of class CGI, $r is an Apache request object.
|
|---|
| 614 | # $imgpath is a URL for something like "/img/redball.gif".
|
|---|
| 615 | $r->print($Q->img({ -src => $imgpath,
|
|---|
| 616 | attr_imgsize($r->lookup_uri($imgpath)->filename) }));
|
|---|
| 617 |
|
|---|
| 618 | The advantage here, besides not having to hard-code the server document root,
|
|---|
| 619 | is that Apache passes the sub-request through the usual request lifecycle,
|
|---|
| 620 | including any stages that would re-write the URL or otherwise modify it.
|
|---|
| 621 |
|
|---|
| 622 | =head1 CAVEATS
|
|---|
| 623 |
|
|---|
| 624 | Caching of size data can only be done on inputs that are file names. Open
|
|---|
| 625 | file handles and scalar references cannot be reliably transformed into a
|
|---|
| 626 | unique key for the table of cache data. Buffers could be cached using the
|
|---|
| 627 | MD5 module, and perhaps in the future I will make that an option. I do not,
|
|---|
| 628 | however, wish to lengthen the dependancy list by another item at this time.
|
|---|
| 629 |
|
|---|
| 630 | As B<Image::Magick> operates on file names, not handles, the use of it is
|
|---|
| 631 | restricted to cases where the input to C<imgsize> is provided as file name.
|
|---|
| 632 |
|
|---|
| 633 | =head1 SEE ALSO
|
|---|
| 634 |
|
|---|
| 635 | The B<Image::Magick> and B<Image::Info> Perl modules at CPAN.
|
|---|
| 636 |
|
|---|
| 637 | =head1 AUTHORS
|
|---|
| 638 |
|
|---|
| 639 | Perl module interface by Randy J. Ray I<([email protected])>, original
|
|---|
| 640 | image-sizing code by Alex Knowles I<([email protected])> and Andrew Tong
|
|---|
| 641 | I<([email protected])>, used with their joint permission.
|
|---|
| 642 |
|
|---|
| 643 | Some bug fixes submitted by Bernd Leibing I<([email protected])>.
|
|---|
| 644 | PPM/PGM/PBM sizing code contributed by Carsten Dominik
|
|---|
| 645 | I<([email protected])>. Tom Metro I<([email protected])> re-wrote the JPG
|
|---|
| 646 | and PNG code, and also provided a PNG image for the test suite. Dan Klein
|
|---|
| 647 | I<([email protected])> contributed a re-write of the GIF code. Cloyce Spradling
|
|---|
| 648 | I<([email protected])> contributed TIFF sizing code and test images. Aldo
|
|---|
| 649 | Calpini I<([email protected])> suggested support of BMP images (which
|
|---|
| 650 | I I<really> should have already thought of :-) and provided code to work
|
|---|
| 651 | with. A patch to allow html_imgsize to produce valid output for XHTML, as
|
|---|
| 652 | well as some documentation fixes was provided by Charles Levert
|
|---|
| 653 | I<([email protected])>. The ShockWave/Flash support was provided by
|
|---|
| 654 | Dmitry Dorofeev I<([email protected])>. Though I neglected to take note of who
|
|---|
| 655 | supplied the PSD (PhotoShop) code, a bug was identified by Alex Weslowski
|
|---|
| 656 | <[email protected]>, who also provided a test image. PCD support
|
|---|
| 657 | was adapted from a script made available by Phil Greenspun, as guided to my
|
|---|
| 658 | attention by Matt Mueller I<[email protected]>. A thorough read of the
|
|---|
| 659 | documentation and source by Philip Newton I<[email protected]>
|
|---|
| 660 | found several typos and a small buglet. Ville Skyttä I<([email protected])>
|
|---|
| 661 | provided the MNG and the Image::Magick fallback code.
|
|---|
| 662 |
|
|---|
| 663 | =cut
|
|---|
| 664 |
|
|---|
| 665 | 1;
|
|---|
| 666 |
|
|---|
| 667 | __END__
|
|---|
| 668 |
|
|---|
| 669 | ###########################################################################
|
|---|
| 670 | # Subroutine gets the size of the specified GIF
|
|---|
| 671 | ###########################################################################
|
|---|
| 672 | sub gifsize
|
|---|
| 673 | {
|
|---|
| 674 | my $stream = shift;
|
|---|
| 675 |
|
|---|
| 676 | my ($cmapsize, $buf, $sh, $sw, $h, $w, $x, $y, $type);
|
|---|
| 677 |
|
|---|
| 678 | my $gif_blockskip = sub {
|
|---|
| 679 | my ($skip, $type) = @_;
|
|---|
| 680 | my ($lbuf);
|
|---|
| 681 |
|
|---|
| 682 | &$read_in($stream, $skip); # Skip header (if any)
|
|---|
| 683 | while (1)
|
|---|
| 684 | {
|
|---|
| 685 | if (&img_eof($stream))
|
|---|
| 686 | {
|
|---|
| 687 | return (undef, undef,
|
|---|
| 688 | "Invalid/Corrupted GIF (at EOF in GIF $type)");
|
|---|
| 689 | }
|
|---|
| 690 | $lbuf = &$read_in($stream, 1); # Block size
|
|---|
| 691 | last if ord($lbuf) == 0; # Block terminator
|
|---|
| 692 | &$read_in($stream, ord($lbuf)); # Skip data
|
|---|
| 693 | }
|
|---|
| 694 | };
|
|---|
| 695 |
|
|---|
| 696 | return (undef, undef,
|
|---|
| 697 | 'Out-of-range value for $Image::Size::GIF_BEHAVIOR: ' .
|
|---|
| 698 | $Image::Size::GIF_BEHAVIOR)
|
|---|
| 699 | if ($Image::Size::GIF_BEHAVIOR > 2);
|
|---|
| 700 |
|
|---|
| 701 | # Skip over the identifying string, since we already know this is a GIF
|
|---|
| 702 | $type = &$read_in($stream, 6);
|
|---|
| 703 | if (length($buf = &$read_in($stream, 7)) != 7 )
|
|---|
| 704 | {
|
|---|
| 705 | return (undef, undef, "Invalid/Corrupted GIF (bad header)");
|
|---|
| 706 | }
|
|---|
| 707 | ($sw, $sh, $x) = unpack("vv C", $buf);
|
|---|
| 708 | if ($Image::Size::GIF_BEHAVIOR == 0)
|
|---|
| 709 | {
|
|---|
| 710 | return ($sw, $sh, 'GIF');
|
|---|
| 711 | }
|
|---|
| 712 |
|
|---|
| 713 | if ($x & 0x80)
|
|---|
| 714 | {
|
|---|
| 715 | $cmapsize = 3 * (2**(($x & 0x07) + 1));
|
|---|
| 716 | if (! &$read_in($stream, $cmapsize))
|
|---|
| 717 | {
|
|---|
| 718 | return (undef, undef,
|
|---|
| 719 | "Invalid/Corrupted GIF (global color map too small?)");
|
|---|
| 720 | }
|
|---|
| 721 | }
|
|---|
| 722 |
|
|---|
| 723 | # Before we start this loop, set $sw and $sh to 0s and use them to track
|
|---|
| 724 | # the largest sub-image in the overall GIF.
|
|---|
| 725 | $sw = $sh = 0;
|
|---|
| 726 |
|
|---|
| 727 | FINDIMAGE:
|
|---|
| 728 | while (1)
|
|---|
| 729 | {
|
|---|
| 730 | if (&img_eof($stream))
|
|---|
| 731 | {
|
|---|
| 732 | # At this point, if we haven't returned then the user wants the
|
|---|
| 733 | # largest of the sub-images. So, if $sh and $sw are still 0s, then
|
|---|
| 734 | # we didn't see even one Image Descriptor block. Otherwise, return
|
|---|
| 735 | # those two values.
|
|---|
| 736 | if ($sw and $sh)
|
|---|
| 737 | {
|
|---|
| 738 | return ($sw, $sh, 'GIF');
|
|---|
| 739 | }
|
|---|
| 740 | else
|
|---|
| 741 | {
|
|---|
| 742 | return (undef, undef,
|
|---|
| 743 | "Invalid/Corrupted GIF (no Image Descriptors)");
|
|---|
| 744 | }
|
|---|
| 745 | }
|
|---|
| 746 | $buf = &$read_in($stream, 1);
|
|---|
| 747 | ($x) = unpack("C", $buf);
|
|---|
| 748 | if ($x == 0x2c)
|
|---|
| 749 | {
|
|---|
| 750 | # Image Descriptor (GIF87a, GIF89a 20.c.i)
|
|---|
| 751 | if (length($buf = &$read_in($stream, 8)) != 8)
|
|---|
| 752 | {
|
|---|
| 753 | return (undef, undef,
|
|---|
| 754 | "Invalid/Corrupted GIF (missing image header?)");
|
|---|
| 755 | }
|
|---|
| 756 | ($x, $y) = unpack("x4 vv", $buf);
|
|---|
| 757 | return ($x, $y, 'GIF') if ($Image::Size::GIF_BEHAVIOR == 1);
|
|---|
| 758 | if ($x > $sw and $y > $sh)
|
|---|
| 759 | {
|
|---|
| 760 | $sw = $x;
|
|---|
| 761 | $sh = $y;
|
|---|
| 762 | }
|
|---|
| 763 | }
|
|---|
| 764 | if ($x == 0x21)
|
|---|
| 765 | {
|
|---|
| 766 | # Extension Introducer (GIF89a 23.c.i, could also be in GIF87a)
|
|---|
| 767 | $buf = &$read_in($stream, 1);
|
|---|
| 768 | ($x) = unpack("C", $buf);
|
|---|
| 769 | if ($x == 0xF9)
|
|---|
| 770 | {
|
|---|
| 771 | # Graphic Control Extension (GIF89a 23.c.ii)
|
|---|
| 772 | &$read_in($stream, 6); # Skip it
|
|---|
| 773 | next FINDIMAGE; # Look again for Image Descriptor
|
|---|
| 774 | }
|
|---|
| 775 | elsif ($x == 0xFE)
|
|---|
| 776 | {
|
|---|
| 777 | # Comment Extension (GIF89a 24.c.ii)
|
|---|
| 778 | &$gif_blockskip(0, "Comment");
|
|---|
| 779 | next FINDIMAGE; # Look again for Image Descriptor
|
|---|
| 780 | }
|
|---|
| 781 | elsif ($x == 0x01)
|
|---|
| 782 | {
|
|---|
| 783 | # Plain Text Label (GIF89a 25.c.ii)
|
|---|
| 784 | &$gif_blockskip(13, "text data");
|
|---|
| 785 | next FINDIMAGE; # Look again for Image Descriptor
|
|---|
| 786 | }
|
|---|
| 787 | elsif ($x == 0xFF)
|
|---|
| 788 | {
|
|---|
| 789 | # Application Extension Label (GIF89a 26.c.ii)
|
|---|
| 790 | &$gif_blockskip(12, "application data");
|
|---|
| 791 | next FINDIMAGE; # Look again for Image Descriptor
|
|---|
| 792 | }
|
|---|
| 793 | else
|
|---|
| 794 | {
|
|---|
| 795 | return (undef, undef,
|
|---|
| 796 | sprintf("Invalid/Corrupted GIF (Unknown " .
|
|---|
| 797 | "extension %#x)", $x));
|
|---|
| 798 | }
|
|---|
| 799 | }
|
|---|
| 800 | else
|
|---|
| 801 | {
|
|---|
| 802 | return (undef, undef,
|
|---|
| 803 | sprintf("Invalid/Corrupted GIF (Unknown code %#x)",
|
|---|
| 804 | $x));
|
|---|
| 805 | }
|
|---|
| 806 | }
|
|---|
| 807 | }
|
|---|
| 808 |
|
|---|
| 809 | sub xbmsize
|
|---|
| 810 | {
|
|---|
| 811 | my $stream = shift;
|
|---|
| 812 |
|
|---|
| 813 | my $input;
|
|---|
| 814 | my ($x, $y, $id) = (undef, undef, "Could not determine XBM size");
|
|---|
| 815 |
|
|---|
| 816 | $input = &$read_in($stream, 1024);
|
|---|
| 817 | if ($input =~ /^\#define\s*\S*\s*(\d+)\s*\n\#define\s*\S*\s*(\d+)/si)
|
|---|
| 818 | {
|
|---|
| 819 | ($x, $y) = ($1, $2);
|
|---|
| 820 | $id = 'XBM';
|
|---|
| 821 | }
|
|---|
| 822 |
|
|---|
| 823 | ($x, $y, $id);
|
|---|
| 824 | }
|
|---|
| 825 |
|
|---|
| 826 | # Added by Randy J. Ray, 30 Jul 1996
|
|---|
| 827 | # Size an XPM file by looking for the "X Y N W" line, where X and Y are
|
|---|
| 828 | # dimensions, N is the total number of colors defined, and W is the width of
|
|---|
| 829 | # a color in the ASCII representation, in characters. We only care about X & Y.
|
|---|
| 830 | sub xpmsize
|
|---|
| 831 | {
|
|---|
| 832 | my $stream = shift;
|
|---|
| 833 |
|
|---|
| 834 | my $line;
|
|---|
| 835 | my ($x, $y, $id) = (undef, undef, "Could not determine XPM size");
|
|---|
| 836 |
|
|---|
| 837 | while ($line = &$read_in($stream, 1024))
|
|---|
| 838 | {
|
|---|
| 839 | next unless ($line =~ /"\s*(\d+)\s+(\d+)(\s+\d+\s+\d+){1,2}\s*"/s);
|
|---|
| 840 | ($x, $y) = ($1, $2);
|
|---|
| 841 | $id = 'XPM';
|
|---|
| 842 | last;
|
|---|
| 843 | }
|
|---|
| 844 |
|
|---|
| 845 | ($x, $y, $id);
|
|---|
| 846 | }
|
|---|
| 847 |
|
|---|
| 848 |
|
|---|
| 849 | # pngsize : gets the width & height (in pixels) of a png file
|
|---|
| 850 | # cor this program is on the cutting edge of technology! (pity it's blunt!)
|
|---|
| 851 | #
|
|---|
| 852 | # Re-written and tested by [email protected]
|
|---|
| 853 | sub pngsize
|
|---|
| 854 | {
|
|---|
| 855 | my $stream = shift;
|
|---|
| 856 |
|
|---|
| 857 | my ($x, $y, $id) = (undef, undef, "could not determine PNG size");
|
|---|
| 858 | my ($offset, $length);
|
|---|
| 859 |
|
|---|
| 860 | # Offset to first Chunk Type code = 8-byte ident + 4-byte chunk length + 1
|
|---|
| 861 | $offset = 12; $length = 4;
|
|---|
| 862 | if (&$read_in($stream, $length, $offset) eq 'IHDR')
|
|---|
| 863 | {
|
|---|
| 864 | # IHDR = Image Header
|
|---|
| 865 | $length = 8;
|
|---|
| 866 | ($x, $y) = unpack("NN", &$read_in($stream, $length));
|
|---|
| 867 | $id = 'PNG';
|
|---|
| 868 | }
|
|---|
| 869 |
|
|---|
| 870 | ($x, $y, $id);
|
|---|
| 871 | }
|
|---|
| 872 |
|
|---|
| 873 | # mngsize: gets the width and height (in pixels) of an MNG file.
|
|---|
| 874 | # See <URL:http://www.libpng.org/pub/mng/spec/> for the specification.
|
|---|
| 875 | #
|
|---|
| 876 | # Basically a copy of pngsize.
|
|---|
| 877 | sub mngsize
|
|---|
| 878 | {
|
|---|
| 879 | my $stream = shift;
|
|---|
| 880 |
|
|---|
| 881 | my ($x, $y, $id) = (undef, undef, "could not determine MNG size");
|
|---|
| 882 | my ($offset, $length);
|
|---|
| 883 |
|
|---|
| 884 | # Offset to first Chunk Type code = 8-byte ident + 4-byte chunk length + 1
|
|---|
| 885 | $offset = 12; $length = 4;
|
|---|
| 886 | if (&$read_in($stream, $length, $offset) eq 'MHDR')
|
|---|
| 887 | {
|
|---|
| 888 | # MHDR = Image Header
|
|---|
| 889 | $length = 8;
|
|---|
| 890 | ($x, $y) = unpack("NN", &$read_in($stream, $length));
|
|---|
| 891 | $id = 'MNG';
|
|---|
| 892 | }
|
|---|
| 893 |
|
|---|
| 894 | ($x, $y, $id);
|
|---|
| 895 | }
|
|---|
| 896 |
|
|---|
| 897 | # jpegsize: gets the width and height (in pixels) of a jpeg file
|
|---|
| 898 | # Andrew Tong, [email protected] February 14, 1995
|
|---|
| 899 | # modified slightly by [email protected]
|
|---|
| 900 | # and further still by [email protected]
|
|---|
| 901 | # optimization and general re-write from [email protected]
|
|---|
| 902 | sub jpegsize
|
|---|
| 903 | {
|
|---|
| 904 | my $stream = shift;
|
|---|
| 905 |
|
|---|
| 906 | my $MARKER = "\xFF"; # Section marker.
|
|---|
| 907 |
|
|---|
| 908 | my $SIZE_FIRST = 0xC0; # Range of segment identifier codes
|
|---|
| 909 | my $SIZE_LAST = 0xC3; # that hold size info.
|
|---|
| 910 |
|
|---|
| 911 | my ($x, $y, $id) = (undef, undef, "could not determine JPEG size");
|
|---|
| 912 |
|
|---|
| 913 | my ($marker, $code, $length);
|
|---|
| 914 | my $segheader;
|
|---|
| 915 |
|
|---|
| 916 | # Dummy read to skip header ID
|
|---|
| 917 | &$read_in($stream, 2);
|
|---|
| 918 | while (1)
|
|---|
| 919 | {
|
|---|
| 920 | $length = 4;
|
|---|
| 921 | $segheader = &$read_in($stream, $length);
|
|---|
| 922 |
|
|---|
| 923 | # Extract the segment header.
|
|---|
| 924 | ($marker, $code, $length) = unpack("a a n", $segheader);
|
|---|
| 925 |
|
|---|
| 926 | # Verify that it's a valid segment.
|
|---|
| 927 | if ($marker ne $MARKER)
|
|---|
| 928 | {
|
|---|
| 929 | # Was it there?
|
|---|
| 930 | $id = "JPEG marker not found";
|
|---|
| 931 | last;
|
|---|
| 932 | }
|
|---|
| 933 | elsif ((ord($code) >= $SIZE_FIRST) && (ord($code) <= $SIZE_LAST))
|
|---|
| 934 | {
|
|---|
| 935 | # Segments that contain size info
|
|---|
| 936 | $length = 5;
|
|---|
| 937 | ($y, $x) = unpack("xnn", &$read_in($stream, $length));
|
|---|
| 938 | $id = 'JPG';
|
|---|
| 939 | last;
|
|---|
| 940 | }
|
|---|
| 941 | else
|
|---|
| 942 | {
|
|---|
| 943 | # Dummy read to skip over data
|
|---|
| 944 | &$read_in($stream, ($length - 2));
|
|---|
| 945 | }
|
|---|
| 946 | }
|
|---|
| 947 |
|
|---|
| 948 | ($x, $y, $id);
|
|---|
| 949 | }
|
|---|
| 950 |
|
|---|
| 951 | # ppmsize: gets data on the PPM/PGM/PBM family.
|
|---|
| 952 | #
|
|---|
| 953 | # Contributed by Carsten Dominik <[email protected]>
|
|---|
| 954 | sub ppmsize
|
|---|
| 955 | {
|
|---|
| 956 | my $stream = shift;
|
|---|
| 957 |
|
|---|
| 958 | my ($x, $y, $id) = (undef, undef,
|
|---|
| 959 | "Unable to determine size of PPM/PGM/PBM data");
|
|---|
| 960 | my $n;
|
|---|
| 961 |
|
|---|
| 962 | my $header = &$read_in($stream, 1024);
|
|---|
| 963 |
|
|---|
| 964 | # PPM file of some sort
|
|---|
| 965 | $header =~ s/^\#.*//mg;
|
|---|
| 966 | ($n, $x, $y) = ($header =~ /^(P[1-6])\s+(\d+)\s+(\d+)/s);
|
|---|
| 967 | $id = "PBM" if $n eq "P1" || $n eq "P4";
|
|---|
| 968 | $id = "PGM" if $n eq "P2" || $n eq "P5";
|
|---|
| 969 | $id = "PPM" if $n eq "P3" || $n eq "P6";
|
|---|
| 970 | if ($n eq 'P7')
|
|---|
| 971 | {
|
|---|
| 972 | # John Bradley's XV thumbnail pics (thanks to [email protected])
|
|---|
| 973 | $id = 'XV';
|
|---|
| 974 | ($x, $y) = ($header =~ /IMGINFO:(\d+)x(\d+)/s);
|
|---|
| 975 | }
|
|---|
| 976 |
|
|---|
| 977 | ($x, $y, $id);
|
|---|
| 978 | }
|
|---|
| 979 |
|
|---|
| 980 | # tiffsize: size a TIFF image
|
|---|
| 981 | #
|
|---|
| 982 | # Contributed by Cloyce Spradling <[email protected]>
|
|---|
| 983 | sub tiffsize {
|
|---|
| 984 | my $stream = shift;
|
|---|
| 985 |
|
|---|
| 986 | my ($x, $y, $id) = (undef, undef, "Unable to determine size of TIFF data");
|
|---|
| 987 |
|
|---|
| 988 | my $endian = 'n'; # Default to big-endian; I like it better
|
|---|
| 989 | my $header = &$read_in($stream, 4);
|
|---|
| 990 | $endian = 'v' if ($header =~ /II\x2a\x00/o); # little-endian
|
|---|
| 991 |
|
|---|
| 992 | # Set up an association between data types and their corresponding
|
|---|
| 993 | # pack/unpack specification. Don't take any special pains to deal with
|
|---|
| 994 | # signed numbers; treat them as unsigned because none of the image
|
|---|
| 995 | # dimensions should ever be negative. (I hope.)
|
|---|
| 996 | my @packspec = ( undef, # nothing (shouldn't happen)
|
|---|
| 997 | 'C', # BYTE (8-bit unsigned integer)
|
|---|
| 998 | undef, # ASCII
|
|---|
| 999 | $endian, # SHORT (16-bit unsigned integer)
|
|---|
| 1000 | uc($endian), # LONG (32-bit unsigned integer)
|
|---|
| 1001 | undef, # RATIONAL
|
|---|
| 1002 | 'c', # SBYTE (8-bit signed integer)
|
|---|
| 1003 | undef, # UNDEFINED
|
|---|
| 1004 | $endian, # SSHORT (16-bit unsigned integer)
|
|---|
| 1005 | uc($endian), # SLONG (32-bit unsigned integer)
|
|---|
| 1006 | );
|
|---|
| 1007 |
|
|---|
| 1008 | my $offset = &$read_in($stream, 4, 4); # Get offset to IFD
|
|---|
| 1009 | $offset = unpack(uc($endian), $offset); # Fix it so we can use it
|
|---|
| 1010 |
|
|---|
| 1011 | my $ifd = &$read_in($stream, 2, $offset); # Get number of directory entries
|
|---|
| 1012 | my $num_dirent = unpack($endian, $ifd); # Make it useful
|
|---|
| 1013 | $offset += 2;
|
|---|
| 1014 | $num_dirent = $offset + ($num_dirent * 12); # Calc. maximum offset of IFD
|
|---|
| 1015 |
|
|---|
| 1016 | # Do all the work
|
|---|
| 1017 | $ifd = '';
|
|---|
| 1018 | my $tag = 0;
|
|---|
| 1019 | my $type = 0;
|
|---|
| 1020 | while (!defined($x) || !defined($y)) {
|
|---|
| 1021 | $ifd = &$read_in($stream, 12, $offset); # Get first directory entry
|
|---|
| 1022 | last if (($ifd eq '') || ($offset > $num_dirent));
|
|---|
| 1023 | $offset += 12;
|
|---|
| 1024 | $tag = unpack($endian, $ifd); # ...and decode its tag
|
|---|
| 1025 | $type = unpack($endian, substr($ifd, 2, 2)); # ...and the data type
|
|---|
| 1026 | # Check the type for sanity.
|
|---|
| 1027 | next if (($type > @packspec+0) || (!defined($packspec[$type])));
|
|---|
| 1028 | if ($tag == 0x0100) { # ImageWidth (x)
|
|---|
| 1029 | # Decode the value
|
|---|
| 1030 | $x = unpack($packspec[$type], substr($ifd, 8, 4));
|
|---|
| 1031 | } elsif ($tag == 0x0101) { # ImageLength (y)
|
|---|
| 1032 | # Decode the value
|
|---|
| 1033 | $y = unpack($packspec[$type], substr($ifd, 8, 4));
|
|---|
| 1034 | }
|
|---|
| 1035 | }
|
|---|
| 1036 |
|
|---|
| 1037 | # Decide if we were successful or not
|
|---|
| 1038 | if (defined($x) && defined($y)) {
|
|---|
| 1039 | $id = 'TIF';
|
|---|
| 1040 | } else {
|
|---|
| 1041 | $id = '';
|
|---|
| 1042 | $id = 'ImageWidth ' if (!defined($x));
|
|---|
| 1043 | if (!defined ($y)) {
|
|---|
| 1044 | $id .= 'and ' if ($id ne '');
|
|---|
| 1045 | $id .= 'ImageLength ';
|
|---|
| 1046 | }
|
|---|
| 1047 | $id .= 'tag(s) could not be found';
|
|---|
| 1048 | }
|
|---|
| 1049 |
|
|---|
| 1050 | ($x, $y, $id);
|
|---|
| 1051 | }
|
|---|
| 1052 |
|
|---|
| 1053 | # bmpsize: size a Windows-ish BitMaP image
|
|---|
| 1054 | #
|
|---|
| 1055 | # Adapted from code contributed by Aldo Calpini <[email protected]>
|
|---|
| 1056 | sub bmpsize
|
|---|
| 1057 | {
|
|---|
| 1058 | my $stream = shift;
|
|---|
| 1059 |
|
|---|
| 1060 | my ($x, $y, $id) = (undef, undef, "Unable to determine size of BMP data");
|
|---|
| 1061 | my ($buffer);
|
|---|
| 1062 |
|
|---|
| 1063 | $buffer = &$read_in($stream, 26);
|
|---|
| 1064 | ($x, $y) = unpack("x18VV", $buffer);
|
|---|
| 1065 | $id = 'BMP' if (defined $x and defined $y);
|
|---|
| 1066 |
|
|---|
| 1067 | ($x, $y, $id);
|
|---|
| 1068 | }
|
|---|
| 1069 |
|
|---|
| 1070 | # psdsize: determine the size of a PhotoShop save-file (*.PSD)
|
|---|
| 1071 | sub psdsize
|
|---|
| 1072 | {
|
|---|
| 1073 | my $stream = shift;
|
|---|
| 1074 |
|
|---|
| 1075 | my ($x, $y, $id) = (undef, undef, "Unable to determine size of PSD data");
|
|---|
| 1076 | my ($buffer);
|
|---|
| 1077 |
|
|---|
| 1078 | $buffer = &$read_in($stream, 26);
|
|---|
| 1079 | ($y, $x) = unpack("x14NN", $buffer);
|
|---|
| 1080 | $id = 'PSD' if (defined $x and defined $y);
|
|---|
| 1081 |
|
|---|
| 1082 | ($x, $y, $id);
|
|---|
| 1083 | }
|
|---|
| 1084 |
|
|---|
| 1085 | # swfsize: determine size of ShockWave/Flash files. Adapted from code sent by
|
|---|
| 1086 | # Dmitry Dorofeev <[email protected]>
|
|---|
| 1087 | sub swfsize
|
|---|
| 1088 | {
|
|---|
| 1089 | my $image = shift;
|
|---|
| 1090 | my $header = &$read_in($image, 33);
|
|---|
| 1091 |
|
|---|
| 1092 | my $ver = _bin2int(unpack 'B8', substr($header, 3, 1));
|
|---|
| 1093 | my $bs = unpack 'B133', substr($header, 8, 17);
|
|---|
| 1094 | my $bits = _bin2int(substr($bs, 0, 5));
|
|---|
| 1095 | my $x = int(_bin2int(substr($bs, 5+$bits, $bits))/20);
|
|---|
| 1096 | my $y = int(_bin2int(substr($bs, 5+$bits*3, $bits))/20);
|
|---|
| 1097 |
|
|---|
| 1098 | return ($x, $y, 'SWF');
|
|---|
| 1099 | }
|
|---|
| 1100 |
|
|---|
| 1101 | # Suggested by Matt Mueller <[email protected]>, and based on a piece of
|
|---|
| 1102 | # sample Perl code by a currently-unknown author. Credit will be placed here
|
|---|
| 1103 | # once the name is determined.
|
|---|
| 1104 | sub pcdsize
|
|---|
| 1105 | {
|
|---|
| 1106 | my $stream = shift;
|
|---|
| 1107 |
|
|---|
| 1108 | my ($x, $y, $id) = (undef, undef, "Unable to determine size of PCD data");
|
|---|
| 1109 | my $buffer = &$read_in($stream, 0xf00);
|
|---|
| 1110 |
|
|---|
| 1111 | # Second-tier sanity check
|
|---|
| 1112 | return ($x, $y, $id) unless (substr($buffer, 0x800, 3) eq 'PCD');
|
|---|
| 1113 |
|
|---|
| 1114 | my $orient = ord(substr($buffer, 0x0e02, 1)) & 1; # Clear down to one bit
|
|---|
| 1115 | ($x, $y) = @{$Image::Size::PCD_MAP{lc $Image::Size::PCD_SCALE}}
|
|---|
| 1116 | [($orient ? (0, 1) : (1, 0))];
|
|---|
| 1117 |
|
|---|
| 1118 | return ($x, $y, 'PCD');
|
|---|
| 1119 | }
|
|---|
| 1120 |
|
|---|
| 1121 | # swfmxsize: determine size of compressed ShockWave/Flash MX files. Adapted
|
|---|
| 1122 | # from code sent by Victor Kuriashkin <[email protected]>
|
|---|
| 1123 | sub swfmxsize
|
|---|
| 1124 | {
|
|---|
| 1125 | require Compress::Zlib;
|
|---|
| 1126 |
|
|---|
| 1127 | my ($image) = @_;
|
|---|
| 1128 | my $header = &$read_in($image, 1058);
|
|---|
| 1129 | my $ver = _bin2int(unpack 'B8', substr($header, 3, 1));
|
|---|
| 1130 |
|
|---|
| 1131 | my ($d, $status) = Compress::Zlib::inflateInit();
|
|---|
| 1132 | $header = $d->inflate(substr($header, 8, 1024));
|
|---|
| 1133 |
|
|---|
| 1134 | my $bs = unpack 'B133', substr($header, 0, 9);
|
|---|
| 1135 | my $bits = _bin2int(substr($bs, 0, 5));
|
|---|
| 1136 | my $x = int(_bin2int(substr($bs, 5+$bits, $bits))/20);
|
|---|
| 1137 | my $y = int(_bin2int(substr($bs, 5+$bits*3, $bits))/20);
|
|---|
| 1138 |
|
|---|
| 1139 | return ($x, $y, 'CWS');
|
|---|
| 1140 | }
|
|---|
