CUFP
GrandFather
<p>This is an update to the code presented in [id://530009] that adds considerable new atom knowledge, removes the dependence on Video::info, generates the output as a string, and presents the output in a tree using Tk</p>
<p>Update: fixed a bug handling various strings</p>
<readmore title="the code">
<c>
package DumpQuicktime;
use strict;
use Video::Info;
use base qw(Video::Info);
#use diagnostics;
our $VERSION = '0.07';
use constant DEBUG => 0;
use Class::MakeMethods::Emulator::MethodMaker
get_set => [qw(acodec tracks indent indentStr lastErr result)],
list => [qw(atomStack)],
;
sub init {
my $self = shift;
my %param = @_;
$self->init_attributes(@_);
$self->indentStr ('. ');
$self->indent ('');
$self->result ('');
return $self;
}
sub read
{
my $self = shift;
my ($len, $offset) = @_;
my $buf;
seek $self->handle, $offset, 0 if defined $offset;
my $n = read $self->handle, $buf, $len;
$self->lastErr ('read failed') unless defined $n;
$self->lastErr ("short read ($len/$n)") unless $n == $len;
return $buf;
}
sub dump { # Find top level atoms
my $self = shift;
my $pos = 0;
$pos = $self->describeAtom ($pos) while ! eof ($self->handle);
return $self->result;
}
sub pr {
my $self = shift;
$self->result ($self->result . $self->indent . join '', @_);
}
sub describeAtom {
my $self = shift;
my $pos = shift;
my ($len, $key) = unpack ("Na4", $self->read (8, $pos));
if ($len == 0) {
$self->pr ("End entry\n");
return $pos + 4;
}
$key = 'x' . unpack ('H8', $key) if $key =~ /[\x00-\x1f]/;
$key =~ tr/ /_/;
$key =~ s/([^\w \d_])/sprintf "%02X", ord ($1)/ge;
if (! length $key) {
return $pos;
}
my $member = "dump_$key";
my $header = sprintf "%s @ %d (0x%08x) for %d (0x%08x):",
$key, $pos, $pos, $len, $len;
$self->pr ("$header\n");
$self->indent ($self->indent . $self->indentStr);
if ($self->can($member)) {
$self->atomStack_push ([$key, {}]);
$self->$member ($pos, $len);
$self->atomStack_pop ();
} else {
$self->pr (" Unhandled: length = $len\n");
$self->dumpBlock ($pos + 8, $len > 24 ? 16 : $len - 8) if $len > 8;
}
$self->indent (substr $self->indent, length ($self->indentStr));
return $pos + $len;
}
sub describeAtoms {
my $self = shift;
my ($pos, $count) = @_;
$pos = $self->describeAtom ($pos) while $count--;
return $pos;
}
sub describeAtomsIn {
my $self = shift;
my ($pos, $end) = @_;
$pos = $self->describeAtom ($pos) while $pos < $end;
}
sub unwrapAtoms {
my $self = shift;
my ($pos, $len) = @_;
$self->describeAtomsIn ($pos + 8, $pos + $len);
}
sub atomList {
my $self = shift;
my ($pos, $len) = @_;
$self->pr ('Version: ', unpack ('C', $self->read (1)), "\n");
$self->pr ('Flags: ', unpack ('B24', $self->read (3)), "\n");
$self->pr ('Entries: ', NToSigned ($self->read (4)), "\n");
$self->describeAtomsIn ($pos + 16, $pos + $len);
}
sub construct_hash {
my ( $input ) = @_;
my %hash;
while (length($input) > 0) {
my($len) = NToSigned (substr( $input, 0, 4, ''));
my($cntnt) = substr( $input, 0, $len-4, '');
my($type) = substr( $cntnt, 0, 4, '');
if ( exists $hash{$type} ) {
my @a = grep($type,keys %hash);
$hash{$type.length(@a)} = $cntnt;
} else {
$hash{$type} = $cntnt;
}
}
%hash;
}
sub dump_A9nam {
my $self = shift;
$self->showStr (@_);
}
sub dump_A9cpy {
my $self = shift;
$self->showStr (@_);
}
sub dump_A9cmt {
my $self = shift;
$self->showStr (@_);
}
sub dump_A9des {
my $self = shift;
$self->showStr (@_);
}
sub dump_A9inf {
my $self = shift;
$self->showStr (@_);
}
sub dump_alis {
my $self = shift;
$self->dump_code (@_);
}
sub dump_cmov {
my $self = shift;
$self->unwrapAtoms (@_);
}
sub dump_code {
my $self = shift;
my ($pos, $len) = @_;
$len -= 8;
if ($len > 16) {
$self->pr ("First 16 bytes of $len\n");
$len = 16;
}
$self->dumpBlock ($pos, $len);
}
sub dump_dflt {
my $self = shift;
$self->atomList (@_);
}
sub dump_dinf {
my $self = shift;
$self->unwrapAtoms (@_);
}
sub dump_dref {
my $self = shift;
$self->atomList (@_);
}
sub dump_evnt {
my $self = shift;
my ($pos, $len) = @_;
$self->pr ('Event type: ', $self->get4Char (), "\n");
$self->pr ('Actions: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Reserved: ', NToSigned ($self->read (4)), "\n");
$self->unwrapAtoms ($pos + 12, $len - 12);
}
sub dump_list {
my $self = shift;
my ($pos, $len) = @_;
$self->pr ('Id: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Items: ', NToSigned ($self->read (4)), "\n");
$self->unwrapAtoms ($pos + 8, $len - 8);
}
sub dump_oper {
my $self = shift;
my ($pos, $len) = @_;
$self->pr ('Operation: ', $self->get4Char (), "\n");
$self->pr ('Operands: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Reserved: ', NToSigned ($self->read (4)), "\n");
$self->unwrapAtoms ($pos + 12, $len - 12);
}
sub dump_oprn {
my $self = shift;
my ($pos, $len) = @_;
$self->pr ('Unknown 1: ', NToSigned ($self->read (4)), "\n");
$self->pr ('ID: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Unknown 3: ', NToSigned ($self->read (4)), "\n");
$self->unwrapAtoms ($pos + 12, $len - 12);
}
sub dump_actn {
my $self = shift;
my ($pos, $len) = @_;
$self->pr ('Action type: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Actions: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Reserved: ', NToSigned ($self->read (4)), "\n");
$self->unwrapAtoms ($pos + 12, $len - 12);
}
sub dump_whic {
my $self = shift;
my ($pos, $len) = @_;
my %actions =
(
1024 => 'kActionMovieSetVolume',
1025 => 'kActionMovieSetRate',
1026 => 'kActionMovieSetLoopingFlags',
1027 => 'kActionMovieGoToTime',
1028 => 'kActionMovieGoToTimeByName',
1029 => 'kActionMovieGoToBeginning',
1030 => 'kActionMovieGoToEnd',
1031 => 'kActionMovieStepForward',
1032 => 'kActionMovieStepBackward',
1033 => 'kActionMovieSetSelection',
1034 => 'kActionMovieSetSelectionByName',
1035 => 'kActionMoviePlaySelection',
1036 => 'kActionMovieSetLanguage',
1037 => 'kActionMovieChanged',
1038 => 'kActionMovieRestartAtTime',
2048 => 'kActionTrackSetVolume',
2049 => 'kActionTrackSetBalance',
2050 => 'kActionTrackSetEnabled',
2051 => 'kActionTrackSetMatrix',
2052 => 'kActionTrackSetLayer',
2053 => 'kActionTrackSetClip',
2054 => 'kActionTrackSetCursor',
2055 => 'kActionTrackSetGraphicsMode',
3072 => 'kActionSpriteSetMatrix',
3073 => 'kActionSpriteSetImageIndex',
3074 => 'kActionSpriteSetVisible',
3075 => 'kActionSpriteSetLayer',
3076 => 'kActionSpriteSetGraphicsMode',
3078 => 'kActionSpritePassMouseToCodec',
3079 => 'kActionSpriteClickOnCodec',
3080 => 'kActionSpriteTranslate',
3081 => 'kActionSpriteScale',
3082 => 'kActionSpriteRotate',
3083 => 'kActionSpriteStretch',
4096 => 'kActionQTVRSetPanAngle',
4097 => 'kActionQTVRSetTiltAngle',
4098 => 'kActionQTVRSetFieldOfView',
4099 => 'kActionQTVRShowDefaultView',
4100 => 'kActionQTVRGoToNodeID',
5120 => 'kActionMusicPlayNote',
5121 => 'kActionMusicSetController',
6144 => 'kActionCase',
6145 => 'kActionWhile',
6146 => 'kActionGoToURL',
6147 => 'kActionSendQTEventToSprite',
6148 => 'kActionDebugStr',
6149 => 'kActionPushCurrentTime',
6150 => 'kActionPushCurrentTimeWithLabel',
6151 => 'kActionPopAndGotoTopTime',
6152 => 'kActionPopAndGotoLabeledTime',
6153 => 'kActionStatusString',
6154 => 'kActionSendQTEventToTrackObject',
6155 => 'kActionAddChannelSubscription',
6156 => 'kActionRemoveChannelSubscription',
6157 => 'kActionOpenCustomActionHandler',
6158 => 'kActionDoScript',
7168 => 'kActionSpriteTrackSetVariable',
7169 => 'kActionSpriteTrackNewSprite',
7170 => 'kActionSpriteTrackDisposeSprite',
7171 => 'kActionSpriteTrackSetVariableToString',
7172 => 'kActionSpriteTrackConcatVariables',
7173 => 'kActionSpriteTrackSetVariableToMovieURL',
7174 => 'kActionSpriteTrackSetVariableToMovieBaseURL',
8192 => 'kActionApplicationNumberAndString',
9216 => 'kActionQD3DNamedObjectTranslateTo',
9217 => 'kActionQD3DNamedObjectScaleTo',
9218 => 'kActionQD3DNamedObjectRotateTo',
10240 => 'kActionFlashTrackSetPan',
10241 => 'kActionFlashTrackSetZoom',
10242 => 'kActionFlashTrackSetZoomRect',
10243 => 'kActionFlashTrackGotoFrameNumber',
10244 => 'kActionFlashTrackGotoFrameLabel',
11264 => 'kActionMovieTrackAddChildMovie',
11265 => 'kActionMovieTrackLoadChildMovie',
);
$self->pr ('Unknown 1: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Unknown 2: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Unknown 3: ', NToSigned ($self->read (4)), "\n");
my $action = NToSigned ($self->read (4));
my $actionStr = $actions{$action};
$actionStr = "Unknown - $action" if ! defined $actionStr;
$self->pr ("Type: $actionStr\n");
}
sub dump_parm {
my $self = shift;
my ($pos, $len) = @_;
$self->pr ('Unknown 1: ', NToSigned ($self->read (4)), "\n");
$self->pr ('ID: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Unknown 3: ', NToSigned ($self->read (4)), "\n");
$self->unwrapAtoms ($pos + 12, $len - 12);
}
sub dump_test {
my $self = shift;
my ($pos, $len) = @_;
$self->pr ('Unknown 1: ', NToSigned ($self->read (4)), "\n");
$self->pr ('ID: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Unknown 3: ', NToSigned ($self->read (4)), "\n");
$self->unwrapAtoms ($pos + 12, $len - 12);
}
sub dump_expr {
my $self = shift;
my ($pos, $len) = @_;
$self->pr ('Unknown 1: ', NToSigned ($self->read (4)), "\n");
$self->pr ('ID: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Unknown 3: ', NToSigned ($self->read (4)), "\n");
$self->unwrapAtoms ($pos + 12, $len - 12);
}
sub dump_ftyp {
my $self = shift;
$self->pr (unpack ("a4", $self->read (4)), "\n");
}
sub dump_gmhd {
my $self = shift;
$self->unwrapAtoms (@_);
}
sub dump_gmin {
my $self = shift;
$self->pr ('Version: ', unpack ('C', $self->read (1)), "\n");
$self->pr ('Flags: ', unpack ('B24', $self->read (3)), "\n");
$self->showGMode ();
$self->showRGB ();
$self->pr ('Balance: ', nToSigned ($self->read (2)), "\n");
$self->pr ('Reserved: ', nToSigned ($self->read (2)), "\n");
}
sub dump_moov {
my $self = shift;
$self->unwrapAtoms (@_);
}
sub dump_mvhd {
my $self = shift;
my ($pos, $len) = @_;
my $buffer = $self->read ($len - 8);
$self->pr ('Version: ', unpack( 'C', substr($buffer,0,1,'') ) . "\n");
$self->pr ('Flags: ', unpack ('B24', substr($buffer,0,3,'')) . "\n");
$self->pr ('Created: ', $self->showDate (substr($buffer,0,4,'')) . "\n");
$self->pr ('Modified: ', $self->showDate (substr($buffer,0,4,'')) . "\n");
$self->pr ('Timescale: ', unpack( "N", substr($buffer,0,4,'')) . "\n");
$self->pr ('Duration: ', unpack( "N", substr($buffer,0,4,'')) . "\n");
$self->pr ('Pref rate: ', NToFixed (substr($buffer,0,4,'')) . "\n");
$self->pr ('Pref vol: ', unpack( "n", substr($buffer,0,2,'')) . "\n");
$self->pr ('reserved: ', unpack( "H20", substr($buffer,0,10,'')) . "\n");
$self->pr ('Matrix: ', $self->showMatrix (substr($buffer,0,36,'')) . "\n");
$self->pr ('Preview start: ', unpack( "N", substr($buffer,0,4,'')) . "\n");
$self->pr ('Preview time: ', unpack( "N", substr($buffer,0,4,'')) . "\n");
$self->pr ('Poster loc: ', unpack( "N", substr($buffer,0,4,'')) . "\n");
$self->pr ('Sel start: ', unpack( "N", substr($buffer,0,4,'')) . "\n");
$self->pr ('Sel time: ', unpack( "N", substr($buffer,0,4,'')) . "\n");
$self->pr ('Time now: ', unpack( "N", substr($buffer,0,4,'')) . "\n");
my $nextTrackId = unpack( "N", substr($buffer,0,4,''));
$self->pr ("Next track: $nextTrackId\n");
$self->tracks ($nextTrackId - 1);
}
sub dump_udta {
my $self = shift;
$self->unwrapAtoms (@_);
}
sub dump_mdia {
my $self = shift;
$self->unwrapAtoms (@_);
}
sub dump_minf {
my $self = shift;
$self->unwrapAtoms (@_);
}
sub dump_free {
my $self = shift;
my ($pos, $len) = @_;
$self->pr ("Padding = $len bytes\n");
}
sub dump_wide {
my $self = shift;
my ($pos, $len) = @_;
$self->pr ("64 bit expansion place holder\n");
}
sub dump_trak {
my $self = shift;
$self->unwrapAtoms (@_);
}
sub dump_stbl {
my $self = shift;
$self->unwrapAtoms (@_);
}
sub dump_stco {
my $self = shift;
my ($pos, $len) = @_;
my $dataRef;
my $index = -1;
my $limit = $self->atomStack_count ();
while (-$index < $limit) {
$dataRef = \%{$self->atomStack_index ($index--)->[1]};
next if ! exists $dataRef->{'HdlrSubCmpt'};
last if $dataRef->{'HdlrSubCmpt'} ne 'alis';
}
$self->pr ('Version: ', unpack ('C', $self->read (1)), "\n");
$self->pr ('Flags: ', unpack ('B24', $self->read (3)), "\n");
my $entries = NToSigned ($self->read (4));
my $type = (defined $dataRef && $dataRef->{'HdlrSubCmpt'}) || '';
$self->pr ('Entries: ', $entries, " ($type)\n");
while ($entries--) {
my $off = NToSigned ($self->read (4));
$self->pr (' Offset: ', sprintf "%d (0x%04x)\n", $off, $off);
next if $type ne 'sprt';
$self->describeAtom ($off + 12);
}
}
sub dump_sean {
my $self = shift;
my ($pos, $len) = @_;
my $end = $pos + $len;
$pos += 20;
$self->describeAtomsIn ($pos, $end);
}
sub dump_sprt {
my $self = shift;
$self->atomList (@_);
}
sub dump_stsh {
my $self = shift;
$self->dump_stsz (@_);
}
sub dump_stsc {
my $self = shift;
$self->dump_stts (@_);
}
sub dump_stsd {
my $self = shift;
$self->atomList (@_);
}
sub dump_stst {
my $self = shift;
$self->dump_dref (@_);
}
sub dump_stsz {
my $self = shift;
$self->pr ('Version: ', unpack ('C', $self->read (1)), "\n");
$self->pr ('Flags: ', unpack ('B24', $self->read (3)), "\n");
$self->pr ('Samp size: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Entries: ', NToSigned ($self->read (4)), "\n");
}
sub dump_stts {
my $self = shift;
$self->atomList (@_);
}
sub dump_stss {
my $self = shift;
$self->dump_stts (@_);
}
sub dump_edts {
my $self = shift;
$self->unwrapAtoms (@_);
}
sub dump_tkhd {
my $self = shift;
$self->pr ('Version: ', unpack ('C', $self->read (1)), "\n");
$self->pr ('Flags: ', unpack ('B24', $self->read (3)), "\n");
$self->pr ('Creation time: ', $self->showDate (), "\n");
$self->pr ('Modification time: ', $self->showDate (), "\n");
$self->pr ('Track ID: ', unpack( "N", $self->read (4)), "\n");
$self->pr ('Reserved: ', unpack( "N", $self->read (4)), "\n");
$self->pr ('Duration: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Reserved: ', unpack( "NN", $self->read (8)), "\n");
$self->pr ('Layer: ', nToSigned ($self->read (2)), "\n");
$self->pr ('Alternate group: ', nToSigned ($self->read (2)), "\n");
$self->pr ('Volume: ', nToUnsigned($self->read (2)), "\n");
$self->pr ('Reserved: ', unpack( "n", $self->read (2)), "\n");
$self->pr ('Matrix structure: ', $self->showMatrix (), "\n");
$self->pr ('Track width: ', NToFixed ($self->read (4)), "\n");
$self->pr ('Track height: ', NToFixed ($self->read (4)), "\n");
}
sub dump_mdhd {
my $self = shift;
$self->pr ('Version: ', unpack ('C', $self->read (1)), "\n");
$self->pr ('Flags: ', unpack ('B24', $self->read (3)), "\n");
$self->pr ('Creation time: ', $self->showDate (), "\n");
$self->pr ('Modification time: ', $self->showDate (), "\n");
$self->pr ('Time scale: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Duration: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Locale: ', nToSigned ($self->read (2)), "\n");
$self->pr ('Quality: ', unpack ('B16', $self->read (2)), "\n");
}
sub dump_hdlr {
my $self = shift;
my $dataRef = \%{$self->atomStack_index (-2)->[1]};
$self->pr ('Version: ', unpack ('C', $self->read (1)), "\n");
$self->pr ('Flags: ', unpack ('B24', $self->read (3)), "\n");
my $cmpt = $self->get4Char ();
$self->pr ('Component type: ', $cmpt, "\n");
my $subCmpt = $self->get4Char ();
$self->pr ('Component sub type: ', $subCmpt, "\n");
$dataRef->{'HdlrCmpt'} = $cmpt;
$dataRef->{'HdlrSubCmpt'} = $subCmpt;
$self->pr ('Manufacturer: ', $self->get4Char (), "\n");
$self->pr ('Flags: ', unpack ('B32', $self->read (4)), "\n");
$self->pr ('Mask: ', unpack ('B32', $self->read (4)), "\n");
my $strLen = ord ($self->read (1));
$self->pr ('Name: ', unpack ("a$strLen", $self->read ($strLen)), "\n");
}
sub dump_elst {
my $self = shift;
$self->pr ('Version: ', unpack ('C', $self->read (1)), "\n");
$self->pr ('Flags: ', unpack ('B24', $self->read (3)), "\n");
my $items = NToSigned ($self->read (4));
$self->pr ("Items: $items\n");
for (1..$items) {
$self->pr (" Item $_\n");
$self->pr (' Duration: ', NToSigned ($self->read (4)), "\n");
$self->pr (' Start: ', NToSigned ($self->read (4)), "\n");
$self->pr (' Rate: ', NToFixed ($self->read (4)), "\n");
}
}
sub dump_dcom {
my $self = shift;
my ($pos, $len) = @_;
my $buffer = $self->read ($len - 8);
}
sub dump_clip {
my $self = shift;
$self->unwrapAtoms (@_);
}
sub dump_MCPS {
my $self = shift;
$self->dumpText (@_);
}
sub dump_name {
my $self = shift;
$self->dumpText (@_);
}
sub dump_vmhd {
my $self = shift;
my $parent = $self->atomStack_index (-2)->[0];
if ($parent eq 'minf') {
$self->pr ('Version: ', unpack ('C', $self->read (1)), "\n");
$self->pr ('Flags: ', unpack ('B24', $self->read (3)), "\n");
$self->showGraphicsXferMode ();
$self->showRGB ();
} else {
$self->pr ("Unhandled context ($parent) for VideoMediaInfo atom\n");
}
}
sub dump_WLOC {
my $self = shift;
my ($pos, $len) = @_;
$len = 2 * $len - 16;
$self->pr (unpack ("H$len\n", $self->read ($len)), "\n");
}
sub dump_x00000001 {
my $self = shift;
my $parentType = $self->atomStack_index (-2)->[0];
if ($parentType eq 'oprn') {
my ($pos, $len) = @_;
$self->pr ('Unknown 1: ', NToSigned ($self->read (4)), "\n");
$self->pr ('ID: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Unknown 3: ', NToSigned ($self->read (4)), "\n");
$self->unwrapAtoms ($pos + 12, $len - 12);
} else {
$self->showBogus ();
$self->pr ('Matrix structure: ', $self->showMatrix (), "\n");
}
}
sub dump_x00000002 {
my $self = shift;
$self->pr ("Constant\n");
$self->pr ('Unknown 1: ', NToSigned ($self->read (4)), "\n");
$self->pr ('ID: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Unknown 3: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Value: ', nToSigned ($self->read (2)), "\n");
}
sub dump_x00000004 {
my $self = shift;
$self->showBogus ();
$self->pr ('Visible: ', nToSigned ($self->read (2)), "\n");
}
sub dump_x00000005 {
my $self = shift;
$self->showBogus ();
$self->pr ('Layer: ', nToSigned ($self->read (2)), "\n");
}
sub dump_x00000006 {
my $self = shift;
$self->showPlayMode ();
$self->showBogus ();
$self->showRGB ();
}
sub dump_x00000015 {
my $self = shift;
$self->pr ("Quicktime version\n");
}
sub dump_x00000064 {
my $self = shift;
$self->showBogus ();
$self->pr ('Image index: ', nToSigned ($self->read (2)), "\n");
}
sub dump_x00000065 {
my $self = shift;
$self->pr ("Background colour:\n");
$self->showBogus ();
$self->showRGB ();
}
sub dump_x00000066 {
my $self = shift;
$self->showBogus ();
$self->pr ('Offscreen bit depth: ', nToSigned ($self->read (2)), "\n");
}
sub dump_x00000067 {
my $self = shift;
$self->showBogus ();
$self->pr ('Sample format: ', nToSigned ($self->read (2)), "\n");
}
sub dump_x00000c00 {
my $self = shift;
$self->pr ("Sprite bounds left\n");
}
sub dump_x00000c01 {
my $self = shift;
$self->pr ("Sprite bounds top\n");
}
sub dump_x00000c03 {
my $self = shift;
$self->pr ("Sprite bounds bottom\n");
}
sub dump_x00000c04 {
my $self = shift;
$self->pr ("Sprite bounds right\n");
}
sub dump_x00000c05 {
my $self = shift;
$self->pr ("Sprite is visible\n");
}
sub dump_x00000c06 {
my $self = shift;
$self->pr ("Sprite layer\n");
}
sub dump_x00000c07 {
my $self = shift;
$self->pr ("Sprite track variable\n");
}
sub dump_x00001400 {
my $self = shift;
$self->pr ("Mouse local h loc\n");
}
sub dump_x00001401 {
my $self = shift;
$self->pr ("Mouse local v loc\n");
}
sub dump_x00001402 {
my $self = shift;
$self->pr ("Key is down\n");
}
sub dumpBlock {
my $self = shift;
my ($pos, $len) = @_;
while ($len) {
my $chunk = $len > 16 ? 16 : $len;
my $str = $self->read ($chunk);
$str =~ s/([\x00-\x1f\x80-\xff])/sprintf "\\x%02x", ord ($1)/ge;
$self->pr ("$str\n");
$len -= $chunk;
}
}
sub dumpText {
my $self = shift;
my ($pos, $len) = @_;
$len -= 8;
$self->pr (unpack ("a$len", $self->read ($len)), "\n");
}
sub show {
local $_;
my $thing = shift;
if ($thing =~ /^([^\x00]*)\x00\Z/) {
return $1;
} elsif ($thing =~ /[\x00-\x1f]/) {
my $sum = 0;
my @chars = split '', $thing;
$sum = $sum * 256 + ord ($_) for @chars;
return sprintf "0x%0x", $sum;
}
return $thing;
}
sub showBogus {
my $self = shift;
$self->pr ('Version: ', unpack ('C', $self->read (1)), "\n");
$self->pr ('Flags: ', unpack ('B24', $self->read (3)), "\n");
$self->pr ('Reserved: ', NToSigned ($self->read (4)), "\n");
$self->pr ('Reserved: ', NToSigned ($self->read (4)), "\n");
}
sub showPlayMode {
my $self = shift;
my $flagBits = shift;
my $flags = '';
$flagBits = $self->read (4) if ! defined $flagBits;
$flagBits = NToSigned ($flagBits);
$flags .= 'fullScreenHideCursor ' if $flags & 1;
$flags .= 'fullScreenAllowEvents ' if $flags & 2;
$flags .= 'fullScreenDontChangeMenuBar ' if $flags & 4;
$flags .= 'fullScreenPreflightSize ' if $flags & 8;
$self->pr ("Play mode flags: $flags\n")
}
sub showGMode {
my $self = shift;
my $gMode = shift;
$gMode = $self->read (2) if ! defined $gMode;
$gMode = NToSigned ($gMode);
my %modes =
(
0x0000 => 'Copy',
0x0040 => 'Dither copy',
0x0020 => 'Blend',
0x0024 => 'Transparent',
0x0100 => 'Straight alpha',
0x0101 => 'Premul white alpha',
0x0102 => 'Premul black alpha',
0x0104 => 'Straight alpha blend',
0x0103 => 'Composition (dither copy)',
);
$self->pr ("Graphics mode: $modes{$gMode}\n")
}
sub showRGB {
my $self = shift;
my ($red, $green, $blue) = @_;
$red = $self->read (2) if ! defined $red;
$green = $self->read (2) if ! defined $green;
$blue = $self->read (2) if ! defined $blue;
$red = nToUnsigned ($red);
$green = nToUnsigned ($green);
$blue = nToUnsigned ($blue);
$self->pr ("Red: $red\n");
$self->pr ("Green: $green\n");
$self->pr ("Blue: $blue\n");
}
sub showGraphicsXferMode {
my $self = shift;
my $gMode = shift;
$gMode = $self->read (2) if ! defined $gMode;
$gMode = nToSigned ($gMode);
my %modes =
(
0 => 'srcCopy',
1 => 'srcOr',
2 => 'srcXor',
3 => 'srcBic',
4 => 'notSrcCopy',
5 => 'notSrcOr',
6 => 'notSrcXor',
7 => 'notSrcBic',
8 => 'patCopy',
9 => 'patOr',
10 => 'patXor',
11 => 'patBic',
12 => 'notPatCopy',
13 => 'notPatOr',
14 => 'notPatXor',
15 => 'notPatBic',
49 => 'grayishTextOr',
50 => 'hilite',
50 => 'hilitetransfermode',
32 => 'blend',
33 => 'addPin',
34 => 'addOver',
35 => 'subPin',
37 => 'addMax',
37 => 'adMax',
38 => 'subOver',
39 => 'adMin',
64 => 'ditherCopy',
36 => 'transparent',
);
if (exists $modes{$gMode}) {
$self->pr ('Mode: ', $modes{$gMode}, "\n");
} else {
$self->pr ('Mode: unknown - ', $gMode, "\n");
}
}
sub showDate {
my $self = shift;
my $stamp = shift;
$stamp = $self->read (4) if ! defined $stamp;
$stamp = NToUnsigned ($stamp);
# seconds difference between Mac epoch and Unix/Windows.
my $mod = ($^O =~ /MSWin32/) ? (2063824538 - 12530100 + 31536000) : (2063824538 - 12530100);
my $date = ($^O =~ /Mac/) ? localtime($stamp) : localtime($stamp-$mod);
return $date;
}
sub showMatrix {
my $self = shift;
my $matrix = shift;
$matrix = $self->read (36) if ! defined $matrix;
my $str = '';
for (1..3) {
my $sub = substr $matrix, 0, 12, '';
$str .= NToFixed (substr $sub, 0, 4, '') . ' ';
$str .= NToFixed (substr $sub, 0, 4, '') . ' ';
$str .= NToFrac (substr $sub, 0, 4, '') . ' ';
$str .= ' / ' if $_ != 3;
}
return $str;
}
sub showStr {
my $self = shift;
my $pos = shift;
my ($len, $key) = unpack ("Na4", $self->read (8, $pos));
$len -= 12;
$self->pr (unpack ("a$len", $self->read ($len, $pos + 12)), "\n");
}
sub get4Char {
my $self = shift;
return unpack ("a4", $self->read (4));
}
sub NToFixed {
my $str = shift;
return unpack ('l', pack ('l', unpack( "N", $str))) / 0x10000;
}
sub NToFrac {
my $str = shift;
my $fract = unpack ('l', pack ('l', unpack( "N", $str)));
return $fract / 0x40000000;
}
sub NToSigned {
my $str = shift;
return unpack ('l', pack ('l', unpack( "N", $str)));
}
sub NToUnsigned {
my $str = shift;
return unpack ('L', pack ('L', unpack( "N", $str)));
}
sub nToSigned {
my $str = shift;
return unpack ('s', pack ('s', unpack( "n", $str)));
}
sub nToUnsigned {
my $str = shift;
return unpack ('S', pack ('S', unpack( "n", $str)));
}
#1;
package main;
use Tk;
use Tk::Tree;
local $| = 1;
my $file = shift;
if (defined $file) {
$file = DumpQuicktime->new(-file=>$file);
my $str = $file->dump;
my $main = MainWindow->new (-title => "Quicktime dump of $file->{'filename'}");
my $tree = $main->ScrlTree
(
-font => 'FixedSys 8',
-itemtype => 'text', -separator => '/',
-scrollbars => "osoe"
);
my @pathStack;
my $lastLine = 0;
my $savedTail;
my $catchIndented;
my $maxLineLenght = 0;
my $maxNesting = 0;
my $totalLines = 0;
my $currIndent = '';
my $indentStr = $file->indentStr;
push @pathStack, 0;
for my $line (split "\n", $str) {
chomp $line;
next if length ($line) == 0; # Skip blank lines
my ($newIndent, $nodeText) = $line =~ /^((?:\Q$indentStr\E)*)(.*)/;
while (length ($newIndent) > length ($currIndent)) {# new project
push @pathStack, 0;
$currIndent .= $indentStr;
}
while (length ($newIndent) < length ($currIndent)) {# new project
pop @pathStack;
substr $currIndent, 0, length $indentStr, '';
}
$pathStack[-1]++;
$maxNesting = @pathStack if $maxNesting < @pathStack;
my $currPath = join "/", @pathStack;
$tree->add ($currPath, -text => $nodeText);
++$totalLines;
$maxLineLenght = length ($nodeText) if length ($nodeText) > $maxLineLenght;
}
$totalLines = 40 if $totalLines > 40;
$main->geometry (($maxLineLenght + $maxNesting * 4) * 5 . 'x' . (40 + $totalLines * 20));
closeTree ($tree, '');
$tree->pack(-fill=>'both',-expand => 1);
MainLoop;
} else {
print <<HELP;
DumpQuicktime parses a QuickTime movie file and dumps a report of the file's
structure to STDOUT.
Run DumpQuicktime as:
DumpQuicktime filename
HELP
}
sub closeTree {
my $tree = shift;
my ($entryPath, $hideChildren) = @_;
my @children = $tree->info (children => $entryPath);
return if ! @children;
for (@children) {
closeTree ($tree, $_, 1);
$tree->hide ('entry' => $_) if $hideChildren;
}
$tree->setmode ($entryPath, 'open') if length $entryPath;
}
</c>
</readmore>
<div class="pmsig"><div class="pmsig-461912">
<hr>DWIM is Perl's answer to Gödel
</div></div>