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 | }
|
---|