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