Filename | /var/www/foswiki11/lib/Foswiki/Attach.pm |
Statements | Executed 21 statements in 2.22ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 32µs | 44µs | BEGIN@15 | Foswiki::Attach::
1 | 1 | 1 | 16µs | 30µs | BEGIN@13 | Foswiki::Attach::
1 | 1 | 1 | 14µs | 14µs | new | Foswiki::Attach::
1 | 1 | 1 | 12µs | 17µs | BEGIN@14 | Foswiki::Attach::
1 | 1 | 1 | 10µs | 23µs | renderMetaData | Foswiki::Attach::
1 | 1 | 1 | 5µs | 5µs | finish | Foswiki::Attach::
0 | 0 | 0 | 0s | 0s | _NEWgifsize | Foswiki::Attach::
0 | 0 | 0 | 0s | 0s | _OLDgifsize | Foswiki::Attach::
0 | 0 | 0 | 0s | 0s | _expandAttrs | Foswiki::Attach::
0 | 0 | 0 | 0s | 0s | _formatRow | Foswiki::Attach::
0 | 0 | 0 | 0s | 0s | _gif_blockskip | Foswiki::Attach::
0 | 0 | 0 | 0s | 0s | _gifsize | Foswiki::Attach::
0 | 0 | 0 | 0s | 0s | _imgsize | Foswiki::Attach::
0 | 0 | 0 | 0s | 0s | _jpegsize | Foswiki::Attach::
0 | 0 | 0 | 0s | 0s | _pngsize | Foswiki::Attach::
0 | 0 | 0 | 0s | 0s | formatVersions | Foswiki::Attach::
0 | 0 | 0 | 0s | 0s | getAttachmentLink | Foswiki::Attach::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | # See bottom of file for license and copyright information | ||||
2 | |||||
3 | =begin TML | ||||
4 | |||||
5 | ---+ package Foswiki::Attach | ||||
6 | |||||
7 | A singleton object of this class is used to deal with attachments to topics. | ||||
8 | |||||
9 | =cut | ||||
10 | |||||
11 | package Foswiki::Attach; | ||||
12 | |||||
13 | 2 | 30µs | 2 | 43µs | # spent 30µs (16+13) within Foswiki::Attach::BEGIN@13 which was called:
# once (16µs+13µs) by Foswiki::attach at line 13 # spent 30µs making 1 call to Foswiki::Attach::BEGIN@13
# spent 13µs making 1 call to strict::import |
14 | 2 | 25µs | 2 | 23µs | # spent 17µs (12+5) within Foswiki::Attach::BEGIN@14 which was called:
# once (12µs+5µs) by Foswiki::attach at line 14 # spent 17µs making 1 call to Foswiki::Attach::BEGIN@14
# spent 5µs making 1 call to warnings::import |
15 | 2 | 2.13ms | 2 | 57µs | # spent 44µs (32+12) within Foswiki::Attach::BEGIN@15 which was called:
# once (32µs+12µs) by Foswiki::attach at line 15 # spent 44µs making 1 call to Foswiki::Attach::BEGIN@15
# spent 12µs making 1 call to Assert::import |
16 | |||||
17 | 1 | 700ns | our $MARKER = "\0"; | ||
18 | |||||
19 | =begin TML | ||||
20 | |||||
21 | ---++ ClassMethod new($session) | ||||
22 | |||||
23 | Constructor. | ||||
24 | |||||
25 | =cut | ||||
26 | |||||
27 | # spent 14µs within Foswiki::Attach::new which was called:
# once (14µs+0s) by Foswiki::attach at line 2014 of /var/www/foswiki11/lib/Foswiki.pm | ||||
28 | 1 | 1µs | my ( $class, $session ) = @_; | ||
29 | 1 | 10µs | my $this = bless( { session => $session }, $class ); | ||
30 | |||||
31 | 1 | 6µs | return $this; | ||
32 | } | ||||
33 | |||||
34 | =begin TML | ||||
35 | |||||
36 | ---++ ObjectMethod finish() | ||||
37 | Break circular references. | ||||
38 | |||||
39 | =cut | ||||
40 | |||||
41 | # Note to developers; please undef *all* fields in the object explicitly, | ||||
42 | # whether they are references or not. That way this method is "golden | ||||
43 | # documentation" of the live fields in the object. | ||||
44 | # spent 5µs within Foswiki::Attach::finish which was called:
# once (5µs+0s) by Foswiki::finish at line 2163 of /var/www/foswiki11/lib/Foswiki.pm | ||||
45 | 1 | 1µs | my $this = shift; | ||
46 | 1 | 5µs | undef $this->{session}; | ||
47 | } | ||||
48 | |||||
49 | =begin TML | ||||
50 | |||||
51 | ---++ ObjectMethod renderMetaData( $topicObject, $args ) -> $text | ||||
52 | |||||
53 | Generate a table of attachments suitable for the bottom of a topic | ||||
54 | view, using templates for the header, footer and each row. | ||||
55 | * =$topicObject= the topic | ||||
56 | * =$args= hash of attachment arguments | ||||
57 | |||||
58 | =cut | ||||
59 | |||||
60 | # spent 23µs (10+13) within Foswiki::Attach::renderMetaData which was called:
# once (10µs+13µs) by Foswiki::META at line 19 of /var/www/foswiki11/lib/Foswiki/Macros/META.pm | ||||
61 | 1 | 600ns | my ( $this, $topicObject, $attrs ) = @_; | ||
62 | |||||
63 | 1 | 700ns | my $showAll = $attrs->{all} || ''; | ||
64 | 1 | 400ns | my $showAttr = $showAll ? 'h' : ''; | ||
65 | 1 | 200ns | my $A = ($showAttr) ? ':A' : ''; | ||
66 | 1 | 400ns | my $title = $attrs->{title} || ''; | ||
67 | 1 | 400ns | my $tmplname = $attrs->{template} || 'attachtables'; | ||
68 | |||||
69 | 1 | 5µs | 1 | 13µs | my @attachments = $topicObject->find('FILEATTACHMENT'); # spent 13µs making 1 call to Foswiki::Meta::find |
70 | 1 | 4µs | return '' unless @attachments; | ||
71 | |||||
72 | my $templates = $this->{session}->templates; | ||||
73 | $templates->readTemplate($tmplname); | ||||
74 | |||||
75 | my $rows = ''; | ||||
76 | my $row = $templates->expandTemplate( 'ATTACH:files:row' . $A ); | ||||
77 | foreach | ||||
78 | my $attachment ( sort { ( $a->{name} || '' ) cmp( $b->{name} || '' ) } | ||||
79 | @attachments ) | ||||
80 | { | ||||
81 | my $attrAttr = $attachment->{attr}; | ||||
82 | |||||
83 | if ( !$attrAttr || ( $showAttr && $attrAttr =~ /^[$showAttr]*$/ ) ) { | ||||
84 | $rows .= _formatRow( $this, $topicObject, $attachment, $row ); | ||||
85 | } | ||||
86 | } | ||||
87 | |||||
88 | my $text = ''; | ||||
89 | |||||
90 | if ( $showAll || $rows ne '' ) { | ||||
91 | my $header = $templates->expandTemplate( 'ATTACH:files:header' . $A ); | ||||
92 | my $footer = $templates->expandTemplate( 'ATTACH:files:footer' . $A ); | ||||
93 | |||||
94 | $text = $header . $rows . $footer; | ||||
95 | } | ||||
96 | return $title . $text; | ||||
97 | } | ||||
98 | |||||
99 | =begin TML | ||||
100 | |||||
101 | ---++ ObjectMethod formatVersions ( $topicObject, $attrs ) -> $text | ||||
102 | |||||
103 | Generate a version history table for a single attachment | ||||
104 | * =$topicObject= - the topic | ||||
105 | * =$attrs= - Hash of meta-data attributes | ||||
106 | |||||
107 | =cut | ||||
108 | |||||
109 | sub formatVersions { | ||||
110 | my ( $this, $topicObject, %attrs ) = @_; | ||||
111 | |||||
112 | my $users = $this->{session}->{users}; | ||||
113 | |||||
114 | $attrs{name} = | ||||
115 | Foswiki::Sandbox::untaint( $attrs{name}, | ||||
116 | \&Foswiki::Sandbox::validateAttachmentName ); | ||||
117 | |||||
118 | my $revIt = $topicObject->getRevisionHistory( $attrs{name} ); | ||||
119 | |||||
120 | my $templates = $this->{session}->templates; | ||||
121 | $templates->readTemplate('attachtables'); | ||||
122 | |||||
123 | my $header = $templates->expandTemplate('ATTACH:versions:header'); | ||||
124 | my $footer = $templates->expandTemplate('ATTACH:versions:footer'); | ||||
125 | my $row = $templates->expandTemplate('ATTACH:versions:row'); | ||||
126 | |||||
127 | my @rows; | ||||
128 | |||||
129 | while ( $revIt->hasNext() ) { | ||||
130 | my $rev = $revIt->next(); | ||||
131 | my $info = | ||||
132 | $topicObject->getAttachmentRevisionInfo( $attrs{name}, $rev ); | ||||
133 | $info->{name} = $attrs{name}; | ||||
134 | $info->{attr} = $attrs{attr}; | ||||
135 | $info->{size} = $attrs{size}; | ||||
136 | |||||
137 | push( @rows, _formatRow( $this, $topicObject, $info, $row ) ); | ||||
138 | } | ||||
139 | |||||
140 | return $header . join( '', @rows ) . $footer; | ||||
141 | } | ||||
142 | |||||
143 | #Format a single row in an attachment table by expanding a template. | ||||
144 | #| =$web= | the web | | ||||
145 | #| =$topic= | the topic | | ||||
146 | #| =$info= | hash containing fields name, user (user (not wikiname) who uploaded this revision), date (date of _this revision_ of the attachment), command and version (the required revision; required to be a full (major.minor) revision number) | | ||||
147 | #| =$tmpl= | The template of a row | | ||||
148 | sub _formatRow { | ||||
149 | my ( $this, $topicObject, $info, $tmpl ) = @_; | ||||
150 | |||||
151 | my $row = $tmpl; | ||||
152 | |||||
153 | $row =~ s/%A_(\w+)%/_expandAttrs( $this, $1, $topicObject, $info)/ge; | ||||
154 | $row =~ s/$MARKER/%/go; | ||||
155 | |||||
156 | return $row; | ||||
157 | } | ||||
158 | |||||
159 | sub _expandAttrs { | ||||
160 | my ( $this, $attr, $topicObject, $info ) = @_; | ||||
161 | my $file = $info->{name} || ''; | ||||
162 | my $users = $this->{session}->{users}; | ||||
163 | |||||
164 | require Foswiki::Time; | ||||
165 | |||||
166 | if ( $attr eq 'REV' ) { | ||||
167 | return $info->{version}; | ||||
168 | } | ||||
169 | elsif ( $attr eq 'ICON' ) { | ||||
170 | return '%ICON{"' . $file . '" default="else"}%'; | ||||
171 | } | ||||
172 | elsif ( $attr eq 'EXT' ) { | ||||
173 | |||||
174 | # $fileExtension is used to map the attachment to its MIME type | ||||
175 | # only grab the last extension in case of multiple extensions | ||||
176 | $file =~ m/\.([^.]*)$/; | ||||
177 | return $1; | ||||
178 | } | ||||
179 | elsif ( $attr eq 'URL' ) { | ||||
180 | return $this->{session}->getScriptUrl( | ||||
181 | 0, 'viewfile', $topicObject->web, $topicObject->topic, | ||||
182 | rev => $info->{version} || undef, | ||||
183 | filename => $file | ||||
184 | ); | ||||
185 | } | ||||
186 | elsif ( $attr eq 'SIZE' ) { | ||||
187 | my $attrSize = $info->{size}; | ||||
188 | $attrSize = 100 if ( !$attrSize || $attrSize < 100 ); | ||||
189 | return sprintf( "%1.1f K", $attrSize / 1024 ); | ||||
190 | } | ||||
191 | elsif ( $attr eq 'COMMENT' ) { | ||||
192 | my $comment = $info->{comment}; | ||||
193 | if ($comment) { | ||||
194 | $comment =~ s/\|/|/g; | ||||
195 | } | ||||
196 | else { | ||||
197 | $comment = " "; | ||||
198 | } | ||||
199 | return $comment; | ||||
200 | } | ||||
201 | elsif ( $attr eq 'ATTRS' ) { | ||||
202 | if ( $info->{attr} ) { | ||||
203 | return $info->{attr}; | ||||
204 | } | ||||
205 | else { | ||||
206 | return " "; | ||||
207 | } | ||||
208 | } | ||||
209 | elsif ( $attr eq 'FILE' ) { | ||||
210 | return $file; | ||||
211 | } | ||||
212 | elsif ( $attr eq 'EFILE' ) { | ||||
213 | |||||
214 | # Really aggressive URL encoding, required to protect wikiwords | ||||
215 | # See Bugs:Item3289, Bugs:Item3623 | ||||
216 | $file =~ s/([^A-Za-z0-9])/'%'.sprintf('%02x',ord($1))/ge; | ||||
217 | return $file; | ||||
218 | } | ||||
219 | elsif ( $attr eq 'DATE' ) { | ||||
220 | return Foswiki::Time::formatTime( $info->{date} || 0 ); | ||||
221 | } | ||||
222 | elsif ( $attr eq 'USER' ) { | ||||
223 | |||||
224 | # Must be able to expand either user or author, depending on whether | ||||
225 | # info came from attachment meta-data (user), or | ||||
226 | # revision info (author) | ||||
227 | my $user = $info->{author} || $info->{user} || 'UnknownUser'; | ||||
228 | my $cUID; | ||||
229 | if ($user) { | ||||
230 | $cUID = $users->getCanonicalUserID($user); | ||||
231 | if ( !$cUID ) { | ||||
232 | |||||
233 | # Not a login name or a wiki name. Is it a valid cUID? | ||||
234 | my $ln = $users->getLoginName($user); | ||||
235 | $cUID = $user if defined $ln && $ln ne 'unknown'; | ||||
236 | } | ||||
237 | } | ||||
238 | |||||
239 | return $users->webDotWikiName($cUID); | ||||
240 | } | ||||
241 | else { | ||||
242 | return $MARKER . 'A_' . $attr . $MARKER; | ||||
243 | } | ||||
244 | } | ||||
245 | |||||
246 | =begin TML | ||||
247 | |||||
248 | ---++ ObjectMethod getAttachmentLink( $topicObject, $name ) -> $html | ||||
249 | |||||
250 | * =$topicObject= - The topic | ||||
251 | * =$name= - Name of the attachment | ||||
252 | |||||
253 | Build a link to the attachment, suitable for insertion in the topic. | ||||
254 | |||||
255 | =cut | ||||
256 | |||||
257 | sub getAttachmentLink { | ||||
258 | my ( $this, $topicObject, $attName ) = @_; | ||||
259 | |||||
260 | my $att = $topicObject->get( 'FILEATTACHMENT', $attName ); | ||||
261 | my $fileComment = $att->{comment}; | ||||
262 | $fileComment = $attName unless ($fileComment); | ||||
263 | |||||
264 | my $fileLink = ''; | ||||
265 | my $imgSize = ''; | ||||
266 | my $prefs = $this->{session}->{prefs}; | ||||
267 | |||||
268 | # I18N: URL-encode the attachment filename | ||||
269 | my $fileURL = Foswiki::urlEncodeAttachment($attName); | ||||
270 | |||||
271 | if ( $attName =~ /\.(gif|jpg|jpeg|png|svg)$/i ) { | ||||
272 | |||||
273 | # inline image | ||||
274 | |||||
275 | # The pixel size calculation is done for performance reasons | ||||
276 | # Some browsers wait with rendering a page until the size of | ||||
277 | # embedded images is known, e.g. after all images of a page are | ||||
278 | # downloaded. When you upload an image to Foswiki and checkmark | ||||
279 | # the link checkbox, Foswiki will generate the width and height | ||||
280 | # img parameters, speeding up the page rendering. | ||||
281 | my $stream = $topicObject->openAttachment( $attName, '<' ); | ||||
282 | my ( $nx, $ny ) = _imgsize( $stream, $attName ); | ||||
283 | $stream->close(); | ||||
284 | my %attrs; | ||||
285 | |||||
286 | if ( $nx > 0 && $ny > 0 ) { | ||||
287 | $attrs{width} = $nx; | ||||
288 | $attrs{height} = $ny; | ||||
289 | $imgSize = "width='$nx' height='$ny'"; | ||||
290 | } | ||||
291 | |||||
292 | $fileLink = $prefs->getPreference('ATTACHEDIMAGEFORMAT'); | ||||
293 | unless ($fileLink) { | ||||
294 | $attrs{src} = "%ATTACHURLPATH%/$fileURL"; | ||||
295 | $attrs{alt} = $attName; | ||||
296 | return " * $fileComment: " . CGI::br() . CGI::img( \%attrs ); | ||||
297 | } | ||||
298 | } | ||||
299 | else { | ||||
300 | |||||
301 | # normal attached file | ||||
302 | $fileLink = $prefs->getPreference('ATTACHEDFILELINKFORMAT'); | ||||
303 | unless ($fileLink) { | ||||
304 | return " * [[%ATTACHURL%/$fileURL][$attName]]: $fileComment"; | ||||
305 | } | ||||
306 | } | ||||
307 | |||||
308 | # I18N: Site specified %ATTACHEDIMAGEFORMAT% or %ATTACHEDFILELINKFORMAT%, | ||||
309 | # ensure that filename is URL encoded - first $name must be URL. | ||||
310 | $fileLink =~ s/\$name/$fileURL/; # deprecated | ||||
311 | $fileLink =~ s/\$name/$attName/; # deprecated, see Item1814 | ||||
312 | $fileLink =~ s/\$filename/$attName/g; | ||||
313 | $fileLink =~ s/\$fileurl/$fileURL/g; | ||||
314 | |||||
315 | # Expand \t and \n early (only in the format, not | ||||
316 | # in the comment) - TWikibug:Item4581 | ||||
317 | $fileLink =~ s/\\t/\t/go; | ||||
318 | $fileLink =~ s/\\n/\n/go; | ||||
319 | $fileLink =~ s/\$comment/$fileComment/g; | ||||
320 | $fileLink =~ s/\$size/$imgSize/g; | ||||
321 | $fileLink =~ s/([^\n])$/$1\n/; | ||||
322 | |||||
323 | return $fileLink; | ||||
324 | } | ||||
325 | |||||
326 | # code fragment to extract pixel size from images | ||||
327 | # taken from http://www.tardis.ed.ac.uk/~ark/wwwis/ | ||||
328 | # subroutines: _imgsize, _gifsize, _OLDgifsize, _gif_blockskip, | ||||
329 | # _NEWgifsize, _jpegsize | ||||
330 | # | ||||
331 | sub _imgsize { | ||||
332 | my ( $file, $att ) = @_; | ||||
333 | my ( $x, $y ) = ( 0, 0 ); | ||||
334 | |||||
335 | if ( defined($file) ) { | ||||
336 | binmode($file); # For Windows | ||||
337 | my $s; | ||||
338 | return ( 0, 0 ) unless ( read( $file, $s, 4 ) == 4 ); | ||||
339 | seek( $file, 0, 0 ); | ||||
340 | if ( $s eq 'GIF8' ) { | ||||
341 | |||||
342 | # GIF 47 49 46 38 | ||||
343 | ( $x, $y ) = _gifsize($file); | ||||
344 | } | ||||
345 | else { | ||||
346 | my ( $a, $b, $c, $d ) = unpack( 'C4', $s ); | ||||
347 | if ( $a == 0x89 | ||||
348 | && $b == 0x50 | ||||
349 | && $c == 0x4E | ||||
350 | && $d == 0x47 ) | ||||
351 | { | ||||
352 | |||||
353 | # PNG 89 50 4e 47 | ||||
354 | ( $x, $y ) = _pngsize($file); | ||||
355 | } | ||||
356 | elsif ($a == 0xFF | ||||
357 | && $b == 0xD8 | ||||
358 | && $c == 0xFF | ||||
359 | && ( $d == 0xE0 || $d == 0xE1 ) ) | ||||
360 | { | ||||
361 | |||||
362 | # JPG ff d8 ff e0/e1 | ||||
363 | ( $x, $y ) = _jpegsize($file); | ||||
364 | } | ||||
365 | } | ||||
366 | close($file); | ||||
367 | } | ||||
368 | return ( $x, $y ); | ||||
369 | } | ||||
370 | |||||
371 | sub _gifsize { | ||||
372 | my ($GIF) = @_; | ||||
373 | if (0) { | ||||
374 | return &_NEWgifsize($GIF); | ||||
375 | } | ||||
376 | else { | ||||
377 | return &_OLDgifsize($GIF); | ||||
378 | } | ||||
379 | } | ||||
380 | |||||
381 | sub _OLDgifsize { | ||||
382 | my ($GIF) = @_; | ||||
383 | my ( $type, $a, $b, $c, $d, $s ) = ( 0, 0, 0, 0, 0, 0 ); | ||||
384 | |||||
385 | if ( defined($GIF) | ||||
386 | && read( $GIF, $type, 6 ) | ||||
387 | && $type =~ /GIF8[7,9]a/ | ||||
388 | && read( $GIF, $s, 4 ) == 4 ) | ||||
389 | { | ||||
390 | ( $a, $b, $c, $d ) = unpack( 'C' x 4, $s ); | ||||
391 | return ( $b << 8 | $a, $d << 8 | $c ); | ||||
392 | } | ||||
393 | return ( 0, 0 ); | ||||
394 | } | ||||
395 | |||||
396 | # part of _NEWgifsize | ||||
397 | sub _gif_blockskip { | ||||
398 | my ( $GIF, $skip, $type ) = @_; | ||||
399 | my ($s) = 0; | ||||
400 | my ($dummy) = ''; | ||||
401 | |||||
402 | read( $GIF, $dummy, $skip ); # Skip header (if any) | ||||
403 | while (1) { | ||||
404 | if ( eof($GIF) ) { | ||||
405 | |||||
406 | #warn "Invalid/Corrupted GIF (at EOF in GIF $type)\n"; | ||||
407 | return ''; | ||||
408 | } | ||||
409 | read( $GIF, $s, 1 ); # Block size | ||||
410 | last if ord($s) == 0; # Block terminator | ||||
411 | read( $GIF, $dummy, ord($s) ); # Skip data | ||||
412 | } | ||||
413 | } | ||||
414 | |||||
415 | # this code by "Daniel V. Klein" <dvk@lonewolf.com> | ||||
416 | sub _NEWgifsize { | ||||
417 | my ($GIF) = @_; | ||||
418 | my ( $cmapsize, $a, $b, $c, $d, $e ) = 0; | ||||
419 | my ( $type, $s ) = ( 0, 0 ); | ||||
420 | my ( $x, $y ) = ( 0, 0 ); | ||||
421 | my ($dummy) = ''; | ||||
422 | |||||
423 | return ( $x, $y ) if ( !defined $GIF ); | ||||
424 | |||||
425 | read( $GIF, $type, 6 ); | ||||
426 | if ( $type !~ /GIF8[7,9]a/ || read( $GIF, $s, 7 ) != 7 ) { | ||||
427 | |||||
428 | #warn "Invalid/Corrupted GIF (bad header)\n"; | ||||
429 | return ( $x, $y ); | ||||
430 | } | ||||
431 | ($e) = unpack( "x4 C", $s ); | ||||
432 | if ( $e & 0x80 ) { | ||||
433 | $cmapsize = 3 * 2**( ( $e & 0x07 ) + 1 ); | ||||
434 | if ( !read( $GIF, $dummy, $cmapsize ) ) { | ||||
435 | |||||
436 | #warn "Invalid/Corrupted GIF (global color map too small?)\n"; | ||||
437 | return ( $x, $y ); | ||||
438 | } | ||||
439 | } | ||||
440 | FINDIMAGE: | ||||
441 | while (1) { | ||||
442 | if ( eof($GIF) ) { | ||||
443 | |||||
444 | #warn "Invalid/Corrupted GIF (at EOF w/o Image Descriptors)\n"; | ||||
445 | return ( $x, $y ); | ||||
446 | } | ||||
447 | read( $GIF, $s, 1 ); | ||||
448 | ($e) = unpack( 'C', $s ); | ||||
449 | if ( $e == 0x2c ) { # Image Descriptor (GIF87a, GIF89a 20.c.i) | ||||
450 | if ( read( $GIF, $s, 8 ) != 8 ) { | ||||
451 | |||||
452 | #warn "Invalid/Corrupted GIF (missing image header?)\n"; | ||||
453 | return ( $x, $y ); | ||||
454 | } | ||||
455 | ( $a, $b, $c, $d ) = unpack( "x4 C4", $s ); | ||||
456 | $x = $b << 8 | $a; | ||||
457 | $y = $d << 8 | $c; | ||||
458 | return ( $x, $y ); | ||||
459 | } | ||||
460 | if ( $type eq 'GIF89a' ) { | ||||
461 | if ( $e == 0x21 ) { # Extension Introducer (GIF89a 23.c.i) | ||||
462 | read( $GIF, $s, 1 ); | ||||
463 | ($e) = unpack( 'C', $s ); | ||||
464 | if ( $e == 0xF9 ) { # Graphic Control Extension (GIF89a 23.c.ii) | ||||
465 | read( $GIF, $dummy, 6 ); # Skip it | ||||
466 | next FINDIMAGE; # Look again for Image Descriptor | ||||
467 | } | ||||
468 | elsif ( $e == 0xFE ) { # Comment Extension (GIF89a 24.c.ii) | ||||
469 | &_gif_blockskip( $GIF, 0, 'Comment' ); | ||||
470 | next FINDIMAGE; # Look again for Image Descriptor | ||||
471 | } | ||||
472 | elsif ( $e == 0x01 ) { # Plain Text Label (GIF89a 25.c.ii) | ||||
473 | &_gif_blockskip( $GIF, 12, 'text data' ); | ||||
474 | next FINDIMAGE; # Look again for Image Descriptor | ||||
475 | } | ||||
476 | elsif ( $e == 0xFF ) | ||||
477 | { # Application Extension Label (GIF89a 26.c.ii) | ||||
478 | &_gif_blockskip( $GIF, 11, 'application data' ); | ||||
479 | next FINDIMAGE; # Look again for Image Descriptor | ||||
480 | } | ||||
481 | else { | ||||
482 | |||||
483 | #printf STDERR "Invalid/Corrupted GIF (Unknown extension %#x)\n", $e; | ||||
484 | return ( $x, $y ); | ||||
485 | } | ||||
486 | } | ||||
487 | else { | ||||
488 | |||||
489 | #printf STDERR "Invalid/Corrupted GIF (Unknown code %#x)\n", $e; | ||||
490 | return ( $x, $y ); | ||||
491 | } | ||||
492 | } | ||||
493 | else { | ||||
494 | |||||
495 | #warn "Invalid/Corrupted GIF (missing GIF87a Image Descriptor)\n"; | ||||
496 | return ( $x, $y ); | ||||
497 | } | ||||
498 | } | ||||
499 | } | ||||
500 | |||||
501 | # _jpegsize : gets the width and height (in pixels) of a jpeg file | ||||
502 | # Andrew Tong, werdna@ugcs.caltech.edu February 14, 1995 | ||||
503 | # modified slightly by alex@ed.ac.uk | ||||
504 | sub _jpegsize { | ||||
505 | my ($JPEG) = @_; | ||||
506 | my ($done) = 0; | ||||
507 | my ( $c1, $c2, $ch, $s, $length, $dummy ) = ( 0, 0, 0, 0, 0, 0 ); | ||||
508 | my ( $a, $b, $c, $d ); | ||||
509 | |||||
510 | if ( defined($JPEG) | ||||
511 | && read( $JPEG, $c1, 1 ) | ||||
512 | && read( $JPEG, $c2, 1 ) | ||||
513 | && ord($c1) == 0xFF | ||||
514 | && ord($c2) == 0xD8 ) | ||||
515 | { | ||||
516 | while ( ord($ch) != 0xDA && !$done ) { | ||||
517 | |||||
518 | # Find next marker (JPEG markers begin with 0xFF) | ||||
519 | # This can hang the program!! | ||||
520 | while ( ord($ch) != 0xFF ) { | ||||
521 | return ( 0, 0 ) unless read( $JPEG, $ch, 1 ); | ||||
522 | } | ||||
523 | |||||
524 | # JPEG markers can be padded with unlimited 0xFF's | ||||
525 | while ( ord($ch) == 0xFF ) { | ||||
526 | return ( 0, 0 ) unless read( $JPEG, $ch, 1 ); | ||||
527 | } | ||||
528 | |||||
529 | # Now, $ch contains the value of the marker. | ||||
530 | if ( ( ord($ch) >= 0xC0 ) && ( ord($ch) <= 0xC3 ) ) { | ||||
531 | return ( 0, 0 ) unless read( $JPEG, $dummy, 3 ); | ||||
532 | return ( 0, 0 ) unless read( $JPEG, $s, 4 ); | ||||
533 | ( $a, $b, $c, $d ) = unpack( 'C' x 4, $s ); | ||||
534 | return ( $c << 8 | $d, $a << 8 | $b ); | ||||
535 | } | ||||
536 | else { | ||||
537 | |||||
538 | # We **MUST** skip variables, since FF's within variable | ||||
539 | # names are NOT valid JPEG markers | ||||
540 | return ( 0, 0 ) unless read( $JPEG, $s, 2 ); | ||||
541 | ( $c1, $c2 ) = unpack( 'C' x 2, $s ); | ||||
542 | $length = $c1 << 8 | $c2; | ||||
543 | last if ( !defined($length) || $length < 2 ); | ||||
544 | read( $JPEG, $dummy, $length - 2 ); | ||||
545 | } | ||||
546 | } | ||||
547 | } | ||||
548 | return ( 0, 0 ); | ||||
549 | } | ||||
550 | |||||
551 | # _pngsize : gets the width & height (in pixels) of a png file | ||||
552 | # source: http://www.la-grange.net/2000/05/04-png.html | ||||
553 | sub _pngsize { | ||||
554 | my ($PNG) = @_; | ||||
555 | my ($head) = ''; | ||||
556 | my ( $a, $b, $c, $d, $e, $f, $g, $h ) = 0; | ||||
557 | if ( defined($PNG) | ||||
558 | && read( $PNG, $head, 8 ) == 8 | ||||
559 | && $head eq "\x89\x50\x4e\x47\x0d\x0a\x1a\x0a" | ||||
560 | && read( $PNG, $head, 4 ) == 4 | ||||
561 | && read( $PNG, $head, 4 ) == 4 | ||||
562 | && $head eq 'IHDR' | ||||
563 | && read( $PNG, $head, 8 ) == 8 ) | ||||
564 | { | ||||
565 | ( $a, $b, $c, $d, $e, $f, $g, $h ) = unpack( 'C' x 8, $head ); | ||||
566 | return ( | ||||
567 | $a << 24 | $b << 16 | $c << 8 | $d, | ||||
568 | $e << 24 | $f << 16 | $g << 8 | $h | ||||
569 | ); | ||||
570 | } | ||||
571 | return ( 0, 0 ); | ||||
572 | } | ||||
573 | |||||
574 | 1 | 3µs | 1; | ||
575 | __END__ |