];
my $preMouse = q();
#------------------------------------------------------------------------------
# New - create new HtmlDump object
# Inputs: 0) reference to HtmlDump object or HtmlDump class name
sub new
{
local $_;
my $that = shift;
my $class = ref($that) || $that || 'Image::ExifTool::HtmlDump';
return bless { Block => {}, TipNum => 0 }, $class;
}
#------------------------------------------------------------------------------
# Add information to dump
# Inputs: 0) HTML dump hash ref, 1) absolute offset in file, 2) data size,
# 3) comment string, 4) tool tip (or SAME to use previous tip),
# 5) bit flags (see below)
# Bits: 0x01 - print at start of line
# 0x02 - print red address
# 0x04 - maker notes data ('M'-class span)
# 0x08 - limit block length
# 0x10 - allow double references
# 0x100 - (reserved)
# Notes: Block will be shown in 'unused' color if comment string begins with '['
sub Add($$$$;$)
{
my ($self, $start, $size, $msg, $tip, $flag) = @_;
my $block = $$self{Block};
$$block{$start} or $$block{$start} = [ ];
my $htip;
if ($tip and $tip eq 'SAME') {
$htip = '';
} else {
# use message as first line of tip, and make bold unless in brackets
$htip = ($msg =~ /^[[(]/) ? $msg : "$msg";
if (defined $tip) {
($tip = EscapeHTML($tip)) =~ s/\n/
/g; # HTML-ize tooltip text
$htip .= '
' . $tip;
}
# add size if not already done
$htip .= "
($size bytes)" unless $htip =~ /
Size:/;
++$self->{TipNum};
}
push @{$$block{$start}}, [ $size, $msg, $htip, $flag, $self->{TipNum} ];
}
#------------------------------------------------------------------------------
# Print dump information to HTML page
# Inputs: 0) Dump information hash reference, 1) source file RAF reference,
# 2) data pointer, 3) data position, 4) output file or scalar reference,
# 5) limit level (1-3), 6) title
# Returns: non-zero if useful output was generated,
# or -1 on error loading data and "ERROR" is set to offending data name
# Note: The "Error" member may be set externally to print a specific error
# message instead of doing the dump.
sub Print($$;$$$$$)
{
local $_;
my ($self, $raf, $dataPt, $dataPos, $outfile, $level, $title) = @_;
my ($i, $buff, $rtnVal, $limit, $err);
my $block = $$self{Block};
$dataPos = 0 unless $dataPos;
$outfile = \*STDOUT unless ref $outfile;
$title = 'HtmlDump' unless $title;
$level or $level = 0;
my $tell = $raf->Tell();
my $pos = 0;
my $dataEnd = $dataPos + ($dataPt ? length($$dataPt) : 0);
# initialize member variables
$$self{Open} = [];
$$self{Closed} = [];
$$self{TipList} = [];
$$self{MSpanList} = [];
$$self{Cols} = [ '', '', '', '' ]; # text columns
# set dump size limits (limits are 4x smaller if bit 0x08 set in flags)
if ($level <= 1) {
$limit = 1024;
} elsif ($level <= 2) {
$limit = 16384;
} else {
$limit = 256 * 1024 * 1024; # never dump bigger than 256 MB
}
$$self{Limit} = $limit;
# pre-initialize open/closed hashes for all columns
for ($i=0; $i<4; ++$i) {
$self->{Open}->[$i] = { ID => [ ], Element => { } };
$self->{Closed}->[$i] = { ID => [ ], Element => { } };
}
$bkgStart = $bkgEnd = 0;
undef @bkgSpan;
my $index = 0; # initialize tooltip index
my (@names, $wasUnused, @starts);
# only do dump if we didn't have a serious error
@starts = sort { $a <=> $b } keys %$block unless $$self{Error};
for ($i=0; $i<=@starts; ++$i) {
my $start = $starts[$i];
my $parmList;
if (defined $start) {
$parmList = $$block{$start};
} elsif ($bkgEnd and $pos < $bkgEnd and not defined $wasUnused) {
$start = $bkgEnd; # finish last bkg block
} else {
last;
}
my $len = $start - $pos;
if ($len > 0 and not $wasUnused) {
# we have a unused bytes before this data block
--$i; # dump the data block next time around
# split unused data into 2 blocks if it spans end of a bkg block
my ($nextBkgEnd, $bkg);
if (not defined $wasUnused and $bkgEnd) {
foreach $bkg (@bkgSpan) {
next if $pos >= $$bkg{End} + $dataPos or $pos + $len <= $$bkg{End} + $dataPos;
$nextBkgEnd = $$bkg{End} unless $nextBkgEnd and $nextBkgEnd < $$bkg{End};
}
}
if ($nextBkgEnd) {
$start = $pos;
$len = $nextBkgEnd + $dataPos - $pos;
$wasUnused = 0;
} else {
$start = $pos; # dump the unused bytes now
$wasUnused = 1; # avoid re-dumping unused bytes if we get a read error
}
my $str = ($len > 1) ? "unused $len bytes" : 'pad byte';
$parmList = [ [ $len, "[$str]", undef, 0x108 ] ];
} else {
undef $wasUnused;
}
my $parms;
foreach $parms (@$parmList) {
my ($len, $msg, $tip, $flag, $tipNum) = @$parms;
next unless $len > 0;
$flag = 0 unless defined $flag;
# generate same name for all blocks indexed by this tooltip
my $name;
$name = $names[$tipNum] if defined $tipNum;
my $idx = $index;
if ($name) {
# get index from existing ID
$idx = substr($name, 1);
} else {
$name = "t$index";
$names[$tipNum] = $name if defined $tipNum;
++$index;
}
if ($flag & 0x14) {
my %bkg = (
Class => $flag & 0x04 ? "$name M" : $name,
Start => $start - $dataPos,
End => $start - $dataPos + $len,
);
push @bkgSpan, \%bkg;
$bkgStart = $bkg{Start} unless $bkgStart and $bkgStart < $bkg{Start};
$bkgEnd = $bkg{End} unless $bkgEnd and $bkgEnd > $bkg{End};
push @{$self->{MSpanList}}, $name;
next;
}
# loop until we read the value properly
my ($end, $try);
for ($try=0; $try<2; ++$try) {
$end = $start + $len;
# only load as much of the block as we are going to dump
# (read 32 more bytes than necessary just in case there
# is only one skipped line that we decide to print)
my $size = ($len > $limit + 32) ? $limit / 2 + 16 : $len;
if ($start >= $dataPos and $end <= $dataEnd) {
$buff = substr($$dataPt, $start-$dataPos, $size);
if ($len != $size) {
$buff .= substr($$dataPt, $start-$dataPos+$len-$size, $size);
}
} else {
$buff = '';
if ($raf->Seek($start, 0) and $raf->Read($buff, $size) == $size) {
# read end of block
if ($len != $size) {
my $buf2 = '';
unless ($raf->Seek($start+$len-$size, 0) and
$raf->Read($buf2, $size) == $size)
{
$err = $msg;
# reset $len to the actual length of available data
$raf->Seek(0, 2);
$len = $raf->Tell() - $start;
$tip .= "
Error: Only $len bytes available!" if $tip;
next;
}
$buff .= $buf2;
undef $buf2;
}
} else {
$err = $msg;
$len = length $buff;
$tip .= "
Error: Only $len bytes available!" if $tip;
}
}
last;
}
$tip and $self->{TipList}->[$idx] = $tip;
next unless length $buff;
# set flag to continue this line if next block is contiguous
if ($i+1 < @starts and $parms eq $$parmList[-1] and
($end == $starts[$i+1] or ($end < $starts[$i+1] and $end >= $pos)))
{
my $nextFlag = $block->{$starts[$i+1]}->[0]->[3] || 0;
$flag |= 0x100 unless $flag & 0x01 or $nextFlag & 0x01;
}
$self->DumpTable($start-$dataPos, \$buff, $msg, $name,
$flag, $len, $pos-$dataPos);
undef $buff;
$pos = $end if $pos < $end;
}
}
$self->Open('',''); # close all open elements
$raf->Seek($tell,0);
# write output HTML file
Write($outfile, $htmlHeader1, $title);
if ($self->{Cols}->[0]) {
Write($outfile, $htmlHeader2);
my $mspan = \@{$$self{MSpanList}};
for ($i=0; $i<@$mspan; ++$i) {
Write($outfile, qq(mspan[$i] = "$$mspan[$i]";\n));
}
Write($outfile, $htmlHeader3, $self->{Cols}->[0]);
Write($outfile, ' | ',
$preMouse, $self->{Cols}->[1]);
Write($outfile, ' | ',
$preMouse, $self->{Cols}->[2]);
Write($outfile, ' | ',
$preMouse, $self->{Cols}->[3]);
Write($outfile, " |