source: gs2-extensions/parallel-building/trunk/src/perllib/cpan/Image/ExifTool/HtmlDump.pm@ 24626

Last change on this file since 24626 was 24626, checked in by jmt12, 13 years ago

An (almost) complete copy of the perllib directory from a (circa SEP2011) head checkout from Greenstone 2 trunk - in order to try and make merging in this extension a little easier later on (as there have been some major changes to buildcol.pl commited in the main trunk but not in the x64 branch)
File size: 31.4 KB
Line 
1#------------------------------------------------------------------------------
2# File: HtmlDump.pm
3#
4# Description: Dump information in hex to HTML page
5#
6# Revisions: 12/05/2005 - P. Harvey Created
7#------------------------------------------------------------------------------
8
9package Image::ExifTool::HtmlDump;
10
11use strict;
12use vars qw($VERSION);
13use Image::ExifTool; # only for FinishTiffDump()
14use Image::ExifTool::HTML qw(EscapeHTML);
15
16$VERSION = '1.30';
17
18sub DumpTable($$$;$$$$$);
19sub Open($$$;@);
20sub Write($@);
21
22my ($bkgStart, $bkgEnd, @bkgSpan);
23
24my $htmlHeader1 = <<_END_PART_1_;
25<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"
26 "http://www.w3.org/TR/1998/REC-html40-19980424/loose.dtd">
27<html>
28<head>
29<title>
30_END_PART_1_
31
32# Note: Don't change font-weight style because it can affect line height
33my $htmlHeader2 = <<_END_PART_2_;
34</title>
35<style type="text/css">
36<!--
37/* character style ID's */
38.D { color: #000000 } /* default color */
39.V { color: #ff0000 } /* duplicate block 1 */
40.W { color: #004400 } /* normal block 1 */
41.X { color: #ff4488 } /* duplicate block 2 */
42.Y { color: #448844 } /* normal block 2 */
43.U { color: #cc8844 } /* unused data block */
44.H { color: #0000ff } /* highlighted tag name */
45.F { color: #aa00dd } /* actual offset differs */
46.M { text-decoration: underline } /* maker notes data */
47.tt { /* tooltip text */
48 visibility: hidden;
49 position: absolute;
50 white-space: nowrap;
51 top: 0;
52 left: 0;
53 font-family: Verdana, sans-serif;
54 font-size: .7em;
55 padding: 2px 4px;
56 border: 1px solid gray;
57 z-index: 3;
58}
59.tb { /* tooltip background */
60 visibility: hidden;
61 position: absolute;
62 background: #ffffdd;
63 opacity: 0.8;
64 -moz-opacity: 0.8;
65 filter: alpha(opacity=80);
66 -ms-filter: 'progid:DXImageTransform.Microsoft.Alpha(Opacity=80)';
67 z-index: 2;
68}
69/* table styles */
70table.dump {
71 border-top: 1px solid gray;
72 border-bottom: 1px solid gray;
73}
74table.dump td { padding: .2em .3em }
75td.c2 {
76 border-left: 1px solid gray;
77 border-right: 1px solid gray;
78}
79pre { margin: 0 }
80table { font-size: .9em }
81body { color: black; background: white }
82-->
83</style>
84<script language="JavaScript" type="text/JavaScript">
85<!-- Begin
86// tooltip positioning constants
87var TMAR = 4; // top/left margins
88var BMAR = 16; // bottom/right margins (scrollbars may overhang inner dimensions)
89var XOFF = 10; // x offset from cursor
90var YOFF = 40; // y offset
91var YMIN = 10; // minimum y offset
92var YTOP = 20; // y offset when above cursor
93// common variables
94var safari1 = navigator.userAgent.indexOf("Safari/312.6") >= 0;
95var ie6 = navigator.userAgent.toLowerCase().indexOf('msie 6') >= 0;
96var mspan = new Array;
97var hlist, tt, tb;
98
99function GetElementsByClass(classname, tagname) {
100 var found = new Array();
101 var list = document.getElementsByTagName(tagname);
102 var len = list.length;
103 for (var i=0, j=0; i<len; ++i) {
104 var classes = list[i].className.split(' ');
105 for (var k=0; k<classes.length; ++k) {
106 if (classes[k] == classname) {
107 found[j++] = list[i];
108 break;
109 }
110 }
111 }
112 delete list;
113 return found;
114}
115
116// move tooltip
117function move(e)
118{
119 if (!tt) return;
120 if (ie6 && (tt.style.top == '' || tt.style.top == 0) &&
121 (tt.style.left == '' || tt.style.left == 0))
122 {
123 tt.style.width = tt.offsetWidth + 'px';
124 tt.style.height = tt.offsetHeight + 'px';
125 }
126 var w, h;
127 // browser inconsistencies make getting window size more complex than it should be,
128 // and even then we don't know if it is smaller due to scrollbar width
129 if (typeof(window.innerWidth) == 'number') {
130 w = window.innerWidth;
131 h = window.innerHeight;
132 } else if (document.documentElement && document.documentElement.clientWidth) {
133 w = document.documentElement.clientWidth;
134 h = document.documentElement.clientHeight;
135 } else {
136 w = document.body.clientWidth;
137 h = document.body.clientHeight;
138 }
139 var x = e.clientX + XOFF;
140 var y = e.clientY + YOFF;
141 if (safari1) { // patch for people still using OS X 10.3.9
142 x -= document.body.scrollLeft + document.documentElement.scrollLeft;
143 y -= document.body.scrollTop + document.documentElement.scrollTop;
144 }
145 var mx = w - BMAR - tt.offsetWidth;
146 var my = h - BMAR - tt.offsetHeight;
147 if (y > my + YOFF - YMIN) y = e.clientY - YTOP - tt.offsetHeight;
148 if (x > mx) x = mx;
149 if (y > my) y = my;
150 if (x < TMAR) x = TMAR;
151 if (y < TMAR) y = TMAR;
152 x += document.body.scrollLeft + document.documentElement.scrollLeft;
153 y += document.body.scrollTop + document.documentElement.scrollTop;
154 tb.style.width = tt.offsetWidth + 'px';
155 tb.style.height = tt.offsetHeight + 'px';
156 tt.style.top = tb.style.top = y + 'px';
157 tt.style.left = tb.style.left = x + 'px';
158 tt.style.visibility = tb.style.visibility = 'visible';
159}
160
161// highlight/unhighlight text
162function high(e,on) {
163 var targ;
164 if (e.target) targ = e.target;
165 else if (e.srcElement) targ = e.srcElement;
166 if (targ.nodeType == 3) targ = targ.parentNode; // defeat Safari bug
167 if (!targ.name) targ = targ.parentNode; // go up another level if necessary
168 if (targ.name && document.getElementsByName) {
169 // un-highlight current objects
170 if (hlist) {
171 for (var i=0; i<hlist.length; ++i) {
172 hlist[i].style.background = 'transparent';
173 }
174 hlist = null;
175 }
176 if (tt) {
177 // hide old tooltip
178 tt.style.visibility = tb.style.visibility = 'hidden';
179 tt = null;
180 }
181 if (on) {
182 if (targ.name.substring(0,1) == 't') {
183 // show our tooltip (ID is different than name to avoid confusing IE)
184 tt = document.getElementById('p' + targ.name.substring(1));
185 if (tt) {
186 tb = document.getElementById('tb');
187 move(e);
188 }
189 }
190 // highlight anchor elements with the same name
191 hlist = document.getElementsByName(targ.name);
192 // use class name to highlight span elements if necessary
193 for (var i=0; i<mspan.length; ++i) {
194 if (mspan[i] != targ.name) continue;
195 var slist = GetElementsByClass(targ.name, 'span');
196 // add elements from hlist collection to our array
197 for (var j=0; j<hlist.length; ++j) {
198 slist[slist.length] = hlist[j];
199 }
200 hlist = slist;
201 break;
202 }
203 for (var j=0; j<hlist.length; ++j) {
204 hlist[j].style.background = '#ffcc99';
205 }
206 }
207 }
208}
209_END_PART_2_
210
211my $htmlHeader3 = q[
212// End --->
213</script></head>
214<body><noscript><b class=V>--&gt;
215Enable JavaScript for active highlighting and information tool tips!
216</b></noscript>
217<table class=dump cellspacing=0 cellpadding=2>
218<tr><td valign='top'><pre>];
219
220my $preMouse = q(<pre onmouseover="high(event,1)" onmouseout="high(event,0)" onmousemove="move(event)">);
221
222#------------------------------------------------------------------------------
223# New - create new HtmlDump object
224# Inputs: 0) reference to HtmlDump object or HtmlDump class name
225sub new
226{
227 local $_;
228 my $that = shift;
229 my $class = ref($that) || $that || 'Image::ExifTool::HtmlDump';
230 return bless { Block => {}, TipNum => 0 }, $class;
231}
232
233#------------------------------------------------------------------------------
234# Add information to dump
235# Inputs: 0) HTML dump hash ref, 1) absolute offset in file, 2) data size,
236# 3) comment string, 4) tool tip (or SAME to use previous tip),
237# 5) bit flags (see below)
238# Bits: 0x01 - print at start of line
239# 0x02 - print red address
240# 0x04 - maker notes data ('M'-class span)
241# 0x08 - limit block length
242# 0x10 - allow double references
243# 0x100 - (reserved)
244# Notes: Block will be shown in 'unused' color if comment string begins with '['
245sub Add($$$$;$)
246{
247 my ($self, $start, $size, $msg, $tip, $flag) = @_;
248 my $block = $$self{Block};
249 $$block{$start} or $$block{$start} = [ ];
250 my $htip;
251 if ($tip and $tip eq 'SAME') {
252 $htip = '';
253 } else {
254 # use message as first line of tip, and make bold unless in brackets
255 $htip = ($msg =~ /^[[(]/) ? $msg : "<b>$msg</b>";
256 if (defined $tip) {
257 ($tip = EscapeHTML($tip)) =~ s/\n/<br>/g; # HTML-ize tooltip text
258 $htip .= '<br>' . $tip;
259 }
260 # add size if not already done
261 $htip .= "<br>($size bytes)" unless $htip =~ /<br>Size:/;
262 ++$self->{TipNum};
263 }
264 push @{$$block{$start}}, [ $size, $msg, $htip, $flag, $self->{TipNum} ];
265}
266
267#------------------------------------------------------------------------------
268# Print dump information to HTML page
269# Inputs: 0) Dump information hash reference, 1) source file RAF reference,
270# 2) data pointer, 3) data position, 4) output file or scalar reference,
271# 5) limit level (1-3), 6) title
272# Returns: non-zero if useful output was generated,
273# or -1 on error loading data and "ERROR" is set to offending data name
274# Note: The "Error" member may be set externally to print a specific error
275# message instead of doing the dump.
276sub Print($$;$$$$$)
277{
278 local $_;
279 my ($self, $raf, $dataPt, $dataPos, $outfile, $level, $title) = @_;
280 my ($i, $buff, $rtnVal, $limit, $err);
281 my $block = $$self{Block};
282 $dataPos = 0 unless $dataPos;
283 $outfile = \*STDOUT unless ref $outfile;
284 $title = 'HtmlDump' unless $title;
285 $level or $level = 0;
286 my $tell = $raf->Tell();
287 my $pos = 0;
288 my $dataEnd = $dataPos + ($dataPt ? length($$dataPt) : 0);
289 # initialize member variables
290 $$self{Open} = [];
291 $$self{Closed} = [];
292 $$self{TipList} = [];
293 $$self{MSpanList} = [];
294 $$self{Cols} = [ '', '', '', '' ]; # text columns
295 # set dump size limits (limits are 4x smaller if bit 0x08 set in flags)
296 if ($level <= 1) {
297 $limit = 1024;
298 } elsif ($level <= 2) {
299 $limit = 16384;
300 } else {
301 $limit = 256 * 1024 * 1024; # never dump bigger than 256 MB
302 }
303 $$self{Limit} = $limit;
304 # pre-initialize open/closed hashes for all columns
305 for ($i=0; $i<4; ++$i) {
306 $self->{Open}->[$i] = { ID => [ ], Element => { } };
307 $self->{Closed}->[$i] = { ID => [ ], Element => { } };
308 }
309 $bkgStart = $bkgEnd = 0;
310 undef @bkgSpan;
311 my $index = 0; # initialize tooltip index
312 my (@names, $wasUnused, @starts);
313 # only do dump if we didn't have a serious error
314 @starts = sort { $a <=> $b } keys %$block unless $$self{Error};
315 for ($i=0; $i<@starts; ++$i) {
316 my $start = $starts[$i];
317 my $parmList = $$block{$start};
318 my $len = $start - $pos;
319 if ($len > 0 and not $wasUnused) {
320 # we have an unused bytes before this data block
321 --$i; # dump the data block next time around
322 # split unused data into 2 blocks if it spans end of a bkg block
323 my ($nextBkgEnd, $bkg);
324 if (not defined $wasUnused and $bkgEnd) {
325 foreach $bkg (@bkgSpan) {
326 next if $pos >= $$bkg{End} + $dataPos or $pos + $len <= $$bkg{End} + $dataPos;
327 $nextBkgEnd = $$bkg{End} unless $nextBkgEnd and $nextBkgEnd < $$bkg{End};
328 }
329 }
330 if ($nextBkgEnd) {
331 $start = $pos;
332 $len = $nextBkgEnd + $dataPos - $pos;
333 $wasUnused = 0;
334 } else {
335 $start = $pos; # dump the unused bytes now
336 $wasUnused = 1; # avoid re-dumping unused bytes if we get a read error
337 }
338 my $str = ($len > 1) ? "unused $len bytes" : 'pad byte';
339 $parmList = [ [ $len, "[$str]", undef, 0x108 ] ];
340 } else {
341 undef $wasUnused;
342 }
343 my $parms;
344 foreach $parms (@$parmList) {
345 my ($len, $msg, $tip, $flag, $tipNum) = @$parms;
346 next unless $len > 0;
347 $flag = 0 unless defined $flag;
348 # generate same name for all blocks indexed by this tooltip
349 my $name;
350 $name = $names[$tipNum] if defined $tipNum;
351 my $idx = $index;
352 if ($name) {
353 # get index from existing ID
354 $idx = substr($name, 1);
355 } else {
356 $name = "t$index";
357 $names[$tipNum] = $name if defined $tipNum;
358 ++$index;
359 }
360 if ($flag & 0x14) {
361 my %bkg = (
362 Class => $flag & 0x04 ? "$name M" : $name,
363 Start => $start - $dataPos,
364 End => $start - $dataPos + $len,
365 );
366 push @bkgSpan, \%bkg;
367 $bkgStart = $bkg{Start} unless $bkgStart and $bkgStart < $bkg{Start};
368 $bkgEnd = $bkg{End} unless $bkgEnd and $bkgEnd > $bkg{End};
369 push @{$self->{MSpanList}}, $name;
370 next;
371 }
372 # loop until we read the value properly
373 my ($end, $try);
374 for ($try=0; $try<2; ++$try) {
375 $end = $start + $len;
376 # only load as much of the block as we are going to dump
377 my $size = ($len > $limit) ? $limit / 2 : $len;
378 if ($start >= $dataPos and $end <= $dataEnd) {
379 $buff = substr($$dataPt, $start-$dataPos, $size);
380 if ($len != $size) {
381 $buff .= substr($$dataPt, $start-$dataPos+$len-$size, $size);
382 }
383 } else {
384 $buff = '';
385 if ($raf->Seek($start, 0) and $raf->Read($buff, $size) == $size) {
386 # read end of block
387 if ($len != $size) {
388 my $buf2 = '';
389 unless ($raf->Seek($start+$len-$size, 0) and
390 $raf->Read($buf2, $size) == $size)
391 {
392 $err = $msg;
393 # reset $len to the actual length of available data
394 $raf->Seek(0, 2);
395 $len = $raf->Tell() - $start;
396 $tip .= "<br>Error: Only $len bytes available!" if $tip;
397 next;
398 }
399 $buff .= $buf2;
400 undef $buf2;
401 }
402 } else {
403 $err = $msg;
404 $len = length $buff;
405 $tip .= "<br>Error: Only $len bytes available!" if $tip;
406 }
407 }
408 last;
409 }
410 $tip and $self->{TipList}->[$idx] = $tip;
411 next unless length $buff;
412 # set flag to continue this line if next block is contiguous
413 if ($i+1 < @starts and $parms eq $$parmList[-1] and
414 ($end == $starts[$i+1] or ($end < $starts[$i+1] and $end >= $pos)))
415 {
416 my $nextFlag = $block->{$starts[$i+1]}->[0]->[3] || 0;
417 $flag |= 0x100 unless $flag & 0x01 or $nextFlag & 0x01;
418 }
419 $self->DumpTable($start-$dataPos, \$buff, $msg, $name,
420 $flag, $len, $pos-$dataPos);
421 undef $buff;
422 $pos = $end if $pos < $end;
423 }
424 }
425 $self->Open('',''); # close all open elements
426 $raf->Seek($tell,0);
427
428 # write output HTML file
429 Write($outfile, $htmlHeader1, $title);
430 if ($self->{Cols}->[0]) {
431 Write($outfile, $htmlHeader2);
432 my $mspan = \@{$$self{MSpanList}};
433 for ($i=0; $i<@$mspan; ++$i) {
434 Write($outfile, qq(mspan[$i] = "$$mspan[$i]";\n));
435 }
436 Write($outfile, $htmlHeader3, $self->{Cols}->[0]);
437 Write($outfile, '</pre></td><td valign="top">',
438 $preMouse, $self->{Cols}->[1]);
439 Write($outfile, '</pre></td><td class=c2 valign="top">',
440 $preMouse, $self->{Cols}->[2]);
441 Write($outfile, '</pre></td><td valign="top">',
442 $preMouse, $self->{Cols}->[3]);
443 Write($outfile, "</pre></td></tr></table>\n<div id=tb class=tb> </div>\n");
444 my $tips = \@{$$self{TipList}};
445 for ($i=0; $i<@$tips; ++$i) {
446 my $tip = $$tips[$i];
447 Write($outfile, "<div id=p$i class=tt>$tip</div>\n") if defined $tip;
448 }
449 delete $$self{TipList};
450 $rtnVal = 1;
451 } else {
452 my $err = $$self{Error} || 'No EXIF or TIFF information found in image';
453 Write($outfile, "$title</title></head><body>\n$err\n");
454 $rtnVal = 0;
455 }
456 Write($outfile, "</body></html>\n");
457 for ($i=0; $i<4; ++$i) {
458 $self->{Cols}->[$i] = ''; # free memory
459 }
460 if ($err) {
461 $err =~ tr/()//d;
462 $$self{ERROR} = $err;
463 return -1;
464 }
465 return $rtnVal;
466}
467
468#------------------------------------------------------------------------------
469# Open or close a specified html element
470# Inputs: 0) HtmlDump object ref, 1) element id, 2) element string,
471# 3-N) list of column numbers (empty for all columns)
472# - element id may be '' to close all elements
473# - element string may be '' to close element by ID (or 0 to close without reopening)
474# - element id and string may both be 1 to reopen temporarily closed elements
475sub Open($$$;@)
476{
477 my ($self, $id, $element, @colNums) = @_;
478
479 # loop through specified columns
480 @colNums or @colNums = (0 .. $#{$self->{Open}});
481 my $col;
482 foreach $col (@colNums) {
483 # get information about open elements in this column
484 my $opHash = $self->{Open}->[$col];
485 my $opElem = $$opHash{Element};
486 if ($element) {
487 # next if already open
488 next if $$opElem{$id} and $$opElem{$id} eq $element;
489 } elsif ($id and not $$opElem{$id}) {
490 # next if already closed and nothing to reopen
491 next unless $element eq '' and @{$self->{Closed}->[$col]->{ID}};
492 }
493 my $opID = $$opHash{ID};
494 my $clHash = $self->{Closed}->[$col];
495 my $clID = $$clHash{ID};
496 my $clElem = $$clHash{Element};
497 # get reference to output column list (use temp list if available)
498 my $cols = $$self{TmpCols} || $$self{Cols};
499 # close everything down to this element if necessary
500 if ($$opElem{$id} or not $id) {
501 while (@$opID) {
502 my $tid = pop @$opID;
503 my $e = $$opElem{$tid};
504 $e =~ s/^<(\S+).*/<\/$1>/s;
505 $$cols[$col] .= $e;
506 if ($id eq $tid or not $id) {
507 delete $$opElem{$tid};
508 last if $id;
509 next;
510 }
511 # add this to the temporarily closed list
512 # (because we really didn't want to close it)
513 push @$clID, $tid;
514 $$clElem{$tid} = $$opElem{$tid};
515 delete $$opElem{$tid};
516 }
517 unless ($id) {
518 # forget all temporarily closed elements
519 $clID = $$clHash{ID} = [ ];
520 $clElem = $$clHash{Element} = { };
521 }
522 } elsif ($$clElem{$id}) {
523 # delete from the list of temporarily closed elements
524 delete $$clElem{$id};
525 @$clID = grep !/^$id$/, @$clID;
526 }
527 next if $element eq '0'; # 0 = don't reopen temporarily closed elements
528
529 # re-open temporarily closed elements
530 while (@$clID) {
531 my $tid = pop @$clID;
532 $$cols[$col] .= $$clElem{$tid};
533 push @$opID, $tid;
534 $$opElem{$tid} = $$clElem{$tid};
535 delete $$clElem{$tid};
536 }
537 # open specified element
538 if ($element and $element ne '1') {
539 $$cols[$col] .= $element;
540 push @$opID, $id;
541 $$opElem{$id} = $element;
542 }
543 }
544}
545
546#------------------------------------------------------------------------------
547# Dump a block of data in HTML table form
548# Inputs: 0) HtmlDump object ref, 1) data position, 2) block pointer,
549# 3) message, 4) object name, 5) flag, 6) full block length (actual
550# data may be shorter), 7) data end position
551sub DumpTable($$$;$$$$$)
552{
553 my ($self, $pos, $blockPt, $msg, $name, $flag, $len, $endPos) = @_;
554 $len = length $$blockPt unless defined $len;
555 $endPos = 0 unless $endPos;
556 my ($f0, $dblRef, $id);
557 my $skipped = 0;
558 if (($endPos and $pos < $endPos) or $flag & 0x02) {
559 # display double-reference addresses in red
560 $f0 = "<span class=V>";
561 $dblRef = 1 if $endPos and $pos < $endPos;
562 } else {
563 $f0 = '';
564 }
565 my @c = ('','','','');
566 $$self{TmpCols} = \@c;
567 if ($name) {
568 if ($msg and $msg =~ /^\[/) {
569 $id = 'U';
570 } else {
571 if ($$self{A}) {
572 $id = 'X';
573 $$self{A} = 0;
574 } else {
575 $id = 'V';
576 $$self{A} = 1;
577 }
578 ++$id unless $dblRef;
579 }
580 $name = "<a name=$name class=$id>";
581 $msg and $msg = "$name$msg</a>";
582 } else {
583 $name = '';
584 }
585 # use base-relative offsets from now on
586 my $cols = 0;
587 my $p = $pos;
588 if ($$self{Cont}) {
589 $cols = $pos & 0x0f;
590 $c[1] .= ($cols == 8) ? ' ' : ' ';
591 } else {
592 my $addr = $pos < 0 ? sprintf("-%.4x",-$pos) : sprintf("%5.4x",$pos);
593 $self->Open('fgd', $f0, 0);
594 $self->Open('fgd', '', 3);
595 $c[0] .= "$addr";
596 $p -= $pos & 0x0f unless $flag & 0x01;
597 if ($p < $pos) {
598 $self->Open('bkg', '', 1, 2); # don't underline white space
599 $cols = $pos - $p;
600 my $n = 3 * $cols;
601 ++$n if $cols > 7;
602 $c[1] .= ' ' x $n;
603 $c[2] .= ' ' x $cols;
604 $p = $pos;
605 }
606 }
607 # loop through each column of hex numbers
608 for (;;) {
609 my (@spanClass, @spanCont, $spanClose, $bkg);
610 if ($p >= $bkgStart and $p < $bkgEnd) {
611 foreach $bkg (@bkgSpan) {
612 next unless $p >= $$bkg{Start} and $p < $$bkg{End};
613 push @spanClass, $$bkg{Class};
614 if ($p + 1 == $$bkg{End}) {
615 $spanClose = 1;
616 } else {
617 push @spanCont, $$bkg{Class}; # this span continues
618 }
619 }
620 $self->Open('bkg', @spanClass ? "<span class='@spanClass'>" : '', 1, 2);
621 } else {
622 $self->Open('bkg', '', 1, 2);
623 }
624 $self->Open('a', $name, 1, 2);
625 my $ch = substr($$blockPt,$p-$pos-$skipped,1);
626 $c[1] .= sprintf("%.2x", ord($ch));
627 # make the character HTML-friendly
628 $ch =~ tr/\x00-\x1f\x7f-\xff/./;
629 $ch =~ s/&/&amp;/g;
630 $ch =~ s/>/&gt;/g;
631 $ch =~ s/</&lt;/g;
632 $c[2] .= $ch;
633 ++$p;
634 ++$cols;
635 # close necessary elements
636 if ($spanClose) {
637 my $spanCont = @spanCont ? "<span class='@spanCont'>" : '';
638 # close without reopening if closing anchor later
639 my $arg = ($p - $pos >= $len) ? 0 : $spanCont;
640 $self->Open('bkg', $arg, 1, 2);
641 }
642 if ($dblRef and $p >= $endPos) {
643 $dblRef = 0;
644 ++$id;
645 $name =~ s/class=\w\b/class=$id/;
646 $f0 = '';
647 $self->Open('fgd', $f0, 0);
648 }
649 if ($p - $pos >= $len) {
650 $self->Open('a', '', 1, 2); # close our anchor
651 last;
652 }
653 if ($cols < 16) {
654 $c[1] .= ($cols == 8 ? ' ' : ' ');
655 next;
656 } elsif ($flag & 0x01 and $cols < $len) {
657 $c[1] .= ' ';
658 next; # put it all on one line
659 }
660 unless ($$self{Msg}) {
661 $c[3] .= $msg;
662 $msg = '';
663 }
664 $_ .= "\n" foreach @c; # add CR to all lines
665 $$self{Msg} = 0;
666 # limit data length if specified
667 if ($$self{Limit}) {
668 my $div = ($flag & 0x08) ? 4 : 1;
669 my $lim = $$self{Limit} / (2 * $div) - 16;
670 if ($p - $pos > $lim and $len - $p + $pos > $lim) {
671 my $n = ($len - $p + $pos - $lim) & ~0x0f;
672 if ($n > 16) { # (no use just cutting out one line)
673 $self->Open('bkg', '', 1, 2); # no underline
674 my $note = sprintf "[snip %d lines]", $n / 16;
675 $note = (' ' x (24-length($note)/2)) . $note;
676 $c[0] .= " ...\n";
677 $c[1] .= $note . (' ' x (48-length($note))) . "\n";
678 $c[2] .= " [snip] \n";
679 $c[3] .= "\n";
680 $p += $n;
681 $skipped += $len - length $$blockPt;
682 }
683 }
684 }
685 $c[0] .= ($p < 0 ? sprintf("-%.4x",-$p) : sprintf("%5.4x",$p));
686 $cols = 0;
687 }
688 if ($msg) {
689 $msg = " $msg" if $$self{Msg};
690 $c[3] .= $msg;
691 }
692 if ($flag & 0x100 and $cols < 16) { # continue on same line?
693 $$self{Cont} = 1;
694 $$self{Msg} = 1 if $msg;
695 } else {
696 $_ .= "\n" foreach @c;
697 $$self{Msg} = 0;
698 $$self{Cont} = 0;
699 }
700 # add temporary column data to our real columns
701 my $i;
702 for ($i=0; $i<4; ++$i) {
703 $self->{Cols}->[$i] .= $c[$i];
704 }
705 delete $$self{TmpCols};
706}
707
708#------------------------------------------------------------------------------
709# Finish dumping of TIFF image data
710# Inputs: 0) HtmlDump object ref, 1) ExifTool object ref, 2) length of file
711# (this really belongs in Image::ExifTool::Exif, but is placed here so it
712# is only compiled when needed)
713sub FinishTiffDump($$$)
714{
715 my ($self, $exifTool, $size) = @_;
716 my ($tag, $key, $start, $blockInfo, $i);
717
718 # list of all indirectly referenced TIFF data tags
719 my %offsetPair = (
720 StripOffsets => 'StripByteCounts',
721 TileOffsets => 'TileByteCounts',
722 FreeOffsets => 'FreeByteCounts',
723 ThumbnailOffset => 'ThumbnailLength',
724 PreviewImageStart => 'PreviewImageLength',
725 JpgFromRawStart => 'JpgFromRawLength',
726 OtherImageStart => 'OtherImageLength',
727 ImageOffset => 'ImageByteCount',
728 AlphaOffset => 'AlphaByteCount',
729 MPImageStart => 'MPImageLength',
730 IDCPreviewStart => 'IDCPreviewLength',
731 );
732
733 # add TIFF data to html dump
734 foreach $tag (keys %offsetPair) {
735 my $info = $exifTool->GetInfo($tag);
736 next unless %$info;
737 # Panasonic hack: StripOffsets is not valid for Panasonic RW2 files,
738 # and StripRowBytes is not valid for some RAW images
739 if ($tag eq 'StripOffsets' and $exifTool->{TAG_INFO}{$tag}{PanasonicHack}) {
740 # use RawDataOffset instead if available since it is valid in RW2
741 my $info2 = $exifTool->GetInfo('RawDataOffset');
742 $info2 = $info unless %$info2;
743 my @keys = keys %$info2;
744 my $offset = $$info2{$keys[0]};
745 my $raf = $$exifTool{RAF};
746 # ignore StripByteCounts and assume raw data runs to the end of file
747 if (@keys == 1 and $offset =~ /^\d+$/ and $raf) {
748 my $pos = $raf->Tell();
749 $raf->Seek(0, 2); # seek to end
750 my $len = $raf->Tell() - $offset;
751 $raf->Seek($pos, 0);
752 if ($len > 0) {
753 $self->Add($offset, $len, "(Panasonic raw data)", "Size: $len bytes", 0x08);
754 next;
755 }
756 }
757 }
758 # loop through all offsets tags
759 foreach $key (keys %$info) {
760 my $name = Image::ExifTool::GetTagName($key);
761 my $grp1 = $exifTool->GetGroup($key, 1);
762 my $info2 = $exifTool->GetInfo($offsetPair{$tag}, { Group1 => $grp1 });
763 my $key2 = $offsetPair{$tag};
764 $key2 .= $1 if $key =~ /( .*)/; # use same instance number as $tag
765 next unless $$info2{$key2};
766 my $offsets = $$info{$key};
767 my $byteCounts = $$info2{$key2};
768 # ignore primary MPImage (this is the whole JPEG)
769 next if $tag eq 'MPImageStart' and $offsets eq '0';
770 # (long lists may be SCALAR references)
771 my @offsets = split ' ', (ref $offsets ? $$offsets : $offsets);
772 my @byteCounts = split ' ', (ref $byteCounts ? $$byteCounts : $byteCounts);
773 my $num = scalar @offsets;
774 my $li = 0;
775 my $padBytes = 0;
776 for ($i=0; @offsets and @byteCounts; ++$i) {
777 my $offset = shift @offsets;
778 my $byteCount = shift @byteCounts;
779 my $end = $offset + $byteCount;
780 if (@offsets and @byteCounts) {
781 # show data as contiguous if only normal pad bytes between blocks
782 if ($end & 0x01 and $end + 1 == $offsets[0]) {
783 $end += 1;
784 ++$padBytes; # count them
785 }
786 if ($end == $offsets[0]) {
787 # combine these two blocks
788 $byteCounts[0] += $offsets[0] - $offset;
789 $offsets[0] = $offset;
790 next;
791 }
792 }
793 my $msg = $exifTool->GetGroup($key, 1) . ':' . $tag;
794 $msg =~ s/(Offsets?|Start)$/ /;
795 if ($num > 1) {
796 $msg .= "$li-" if $li != $i;
797 $msg .= "$i ";
798 $li = $i + 1;
799 }
800 $msg .= "data";
801 my $tip = "Size: $byteCount bytes";
802 $tip .= ", incl. $padBytes pad bytes" if $padBytes;
803 $self->Add($offset, $byteCount, "($msg)", $tip, 0x08);
804 }
805 }
806 }
807 # find offset of last dumped information, and dump any unknown trailer
808 my $last = 0;
809 my $block = $$self{Block};
810 foreach $start (keys %$block) {
811 foreach $blockInfo (@{$$block{$start}}) {
812 my $end = $start + $$blockInfo[0];
813 $last = $end if $last < $end;
814 }
815 }
816 my $diff = $size - $last;
817 if ($diff > 0 and ($last or $exifTool->Options('Unknown'))) {
818 if ($diff > 1 or $size & 0x01) {
819 $self->Add($last, $diff, "[unknown data]", "Size: $diff bytes", 0x08);
820 } else {
821 $self->Add($last, $diff, "[trailing pad byte]", undef, 0x08);
822 }
823 }
824}
825
826#------------------------------------------------------------------------------
827# utility routine to write to file or memory
828# Inputs: 0) file or scalar reference, 1-N) list of stuff to write
829# Returns: true on success
830sub Write($@)
831{
832 my $outfile = shift;
833 if (UNIVERSAL::isa($outfile,'GLOB')) {
834 return print $outfile @_;
835 } elsif (ref $outfile eq 'SCALAR') {
836 $$outfile .= join('', @_);
837 return 1;
838 }
839 return 0;
840}
841
8421; # end
843
844__END__
845
846=head1 NAME
847
848Image::ExifTool::HtmlDump - Dump information in hex to HTML page
849
850=head1 SYNOPSIS
851
852 use Image::ExifTool::HtmlDump;
853 my $dump = new Image::ExifTool::HtmlDump;
854 $dump->Add($start, $size, $comment);
855 $dump->Print($dumpInfo, $raf, $dataPt, $dataPos, $outfile);
856
857=head1 DESCRIPTION
858
859This module contains code used to generate an HTML-based hex dump of
860information for debugging purposes. This is code is called when the
861ExifTool 'HtmlDump' option is used.
862
863Currently, only EXIF/TIFF and JPEG information is dumped.
864
865=head1 BUGS
866
867Due to a memory allocation bug in ActivePerl 5.8.x for Windows, this code
868may run extremely slowly when processing large files with this version of
869Perl.
870
871An HTML 4 compliant browser is needed to properly display the generated HTML
872page.
873
874=head1 AUTHOR
875
876Copyright 2003-2011, Phil Harvey (phil at owl.phy.queensu.ca)
877
878This library is free software; you can redistribute it and/or modify it
879under the same terms as Perl itself.
880
881=head1 SEE ALSO
882
883L<Image::ExifTool(3pm)|Image::ExifTool>
884
885=cut
886
Note: See TracBrowser for help on using the repository browser.