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