package DumpQuicktime;

use strict;
use warnings;

our $VERSION = '0.08';
use constant DEBUG => 0;

use Class::MethodMaker
    new_with_init => 'new',
    get_set => [qw(filename handle tracks indent indentStr lastErr result)],
    list => [qw(atomStack)],
    ;

sub init {
    my $self = shift;
    my %param = @_;

    $self->init_attributes(@_);

    if (exists $param{-file}) {
        my $handle;
        
        $self->filename ($param{-file});
        if (! open $handle, '<', $param{-file}) {
            $self->lastErr ("Open $param{-file} failed: $|");
        } else {
            $self->handle ($handle);
            $self->lastErr ('');
        }
    }
    
    return $self;
}

sub init_attributes {
    my $self = shift;

    $self->indentStr ('.  ');
    $self->indent ('');
    $self->result ('');
}

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));
  
    $len ||= 0;
    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->dumpText (@_);
}

sub dump_A9cpy {
    my $self = shift;
    $self->dumpText (@_);
}

sub dump_A9cmt {
    my $self = shift;
    $self->dumpText (@_);
}

sub dump_A9des {
    my $self = shift;
    $self->dumpText (@_);
}

sub dump_A9inf {
    my $self = shift;
    $self->dumpText (@_);
}

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 dumpStr {
    my $self = shift;
    my ($pos, $len) = @_;

    $len -= 8;
    $self->pr (unpack ("a$len", $self->read ($len, $pos + 8)), "\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 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 <info (children => $entryPath);

    return if ! @children;

    for (@children) {
        closeTree ($tree, $_, 1);
        $tree->hide ('entry' => $_) if $hideChildren;
    }
    $tree->setmode ($entryPath, 'open') if length $entryPath;
}

Re: Updated QuickTime format movie file dumper

baboo

created: 2006-03-04 04:28:00

perlmonks

• reply
• node
• thread
• author

• node
• author
• thread

prlmnks

• node
• thread
• author

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"

Re^2: Updated QuickTime format movie file dumper

GrandFather

created: 2006-03-04 04:57:27

perlmonks

• reply
• node
• thread
• author

• node
• author
• thread

prlmnks

• node
• thread
• author

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

Re^3: Updated QuickTime format movie file dumper

baboo

created: 2006-03-04 07:44:18

perlmonks

• reply
• node
• thread
• author

• node
• author
• thread

prlmnks

• node
• thread
• author

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 ;-)

Re^4: Updated QuickTime format movie file dumper

GrandFather

created: 2006-03-04 08:16:07

perlmonks

• reply
• node
• thread
• author

• node
• author
• thread

prlmnks

• node
• thread
• author

The only "interesting" module this version of the code depends on is use Class::MethodMaker. What is the error that you are getting?

I wrote this code to see how a move with four sprite tracks in addition to a conventional movie track was being put together. Expressions involved in mouse hit testing get very nested! Note that this code is now looking inside the sprite media data (not just the track headers) to pull apart event handlers and such.

---

DWIM is Perl's answer to Gödel

Re^5: Updated QuickTime format movie file dumper

baboo

created: 2006-03-04 08:47:56

perlmonks

• reply
• node
• thread
• author

• node
• author
• thread

prlmnks

• node
• thread
• author

Isn't Tk and Tk::Tree are less "interesting". The problem is on Mac OS X Jaguar I need to recompile the whole Perl bundle to be able compile Tk module. Otherwice Tk returns: ld: Undefined symbols: _PL_curpad _PL_markstack_ptr _PL_op _PL_stack_base _PL_stack_sp _PL_sv_yes _Perl_croak _Perl_form _Perl_get_sv _Perl_mg_set _Perl_newXS _Perl_sv_2iv _Perl_sv_2pv_flags _Perl_sv_2pv_nolen _Perl_sv_newmortal _Perl_sv_setnv _Perl_sv_setpv