http://www.perlmonks.org?node_id=534371

This is an update to the code presented in QuickTime format movie file dumper 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

Update: fixed a bug handling various strings

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 ato +m\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)/g +e; $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 proj +ect push @pathStack, 0; $currIndent .= $indentStr; } while (length ($newIndent) < length ($currIndent)) {# new proj +ect 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) > $m +axLineLenght; } $totalLines = 40 if $totalLines > 40; $main->geometry (($maxLineLenght + $maxNesting * 4) * 5 . 'x' . (4 +0 + $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; }

DWIM is Perl's answer to Gödel

Replies are listed 'Best First'.
Re: Updated QuickTime format movie file dumper
by baboo (Initiate) on Mar 04, 2006 at 09:28 UTC
    Need to say that previous version (without bells and whistles, output to STDOUT) was more flexible solution. I'm currently stragling with building of Tk module on Mac - it's not so easy as I got a batch of "Undefined symbols" while linking... Overal conclusion - more modules - more head aches for users. Could you please help me with previous version of the script? I have all modules installed. I'm able to run the program without parameters - it returns usage message. But if I feed any parameter it fails on this line: $file = DumpQuicktime->new(-file=>$file); with note "Can't locate object method "new" via package "DumpQuicktime" at 530009.pl line 465"

      Just replace the package main stuff with:

      package main; my $file = shift; if (defined $file) { $file = DumpQuicktime->new(-file=>$file); die $file->lastErr () if length $file->lastErr (); print $file->dump (); }

      For me the tree stuff is invaluable. Quicktime atoms are nested about 30 deep in stuff I'm looking at and the output is, I'd guess, a couple of thousand lines long!

      Returning a string rather than outputting directly to sdtout allows post processing of the output.


      DWIM is Perl's answer to Gödel
        Hmm, the line "$file = DumpQuicktime->new(-file=>$file);" is the same, the same is the error :( Never seen movies with nested more than 3-4 deep atoms. The same with "thousand lines" - an average movie header say with 3-4 tracks may have about hundred or so atoms. Anyway thank you ;-)