File Coverage

blib/lib/Video/Info/ASF.pm

Criterion	Covered	Total	%
statement	209	216	96.7
branch	53	74	71.6
condition	8	13	61.5
subroutine	33	33	100.0
pod	0	3	0.0
total	303	339	89.3

package Video::Info::ASF;

use strict;
use constant DEBUG => 0;
our $VERSION = '1.01';

use Video::Info;

use base qw(Video::Info);

#########################################################
# ASF GUID signatures
#
#base ASF object guids
use constant Header                        => 0x75b22630;
use constant data                          => 0x75b22636;
use constant simple_index                  => 0x33000890;

#header object guids
use constant file_properties               => 0x8cabdca1;
use constant stream_properties             => 0xb7dc0791;
use constant stream_bitrate_properties     => 0x7bf875ce;
use constant content_description           => 0x75b22633;
use constant extended_content_encryption   => 0x298ae614;
use constant script_command                => 0x1efb1a30;
use constant marker                        => 0xf487cd01;
use constant header_extension              => 0x5fbf03b5;
use constant bitrate_mutual_exclusion      => 0xd6e229dc;
use constant codec_list                    => 0x86d15240;
use constant extended_content_description  => 0xd2d0a440;
use constant error_correction              => 0x75b22635;
use constant stream_bitrate_porperties     => 0x7bf875ce;
use constant padding                       => 0x1806d474;

#stream properties object stream type guids
use constant audio_media                   => 0xf8699e40;
use constant video_media                   => 0xbc19efc0;
use constant command_media                 => 0x59dacfc0;

#stream properties object error correction type guids
use constant no_error_correction           => 0x20fb5700;
use constant audio_spread                  => 0xbfc3cd50;

#mutual exclusion object exclusion type guids
use constant mutex_bitrate                 => 0xd6e22a01;
use constant mutex_unknown                 => 0xd6e22a02;

#from mplayer
use constant audio_conceal_none            => 0x49f1a440;
use constant header_2_0                    => 0xD6E229D1;
#########################################################

sub header {
  my $self = shift;
  my $val  = shift;
  return undef unless ref $self;
  return $self->{header} unless $val;
  $self->{header} = $val;
  return $val;
}

##------------------------------------------------------------------------
## probe()
##
## Obtain the filehandle from Video::Info and extract the properties from
## the ASF structure.
##------------------------------------------------------------------------
sub init {
  my $self = shift;

  $self->init_attributes(@_);
  return $self;
}

sub probe {
  my $self = shift;
  my $fh = $self->handle; ## inherited from Video::Info
  my $header;

  sysread($fh,$header,24);# or die "died probe(): $!";

  die "not an ASF" unless unpack("V",substr($header,0,4)) == Header;
  $self->type('ASF');
  my($h1,$h2) = unpack("VV",substr($header,16,8));
  my $headersize = ($h2 * 0xffffffff) + $h1;
  my $bytes = sysread($fh,$header,$headersize,24);
  die "probe() sysread: $!" unless $bytes = $headersize;
  #warn length($header);
  #exit;
  $self->header($header);

	my %guid = ();

	for(0..$headersize-5){
		my $window = substr($header,$_,4);

		$guid{codec_list}         = $_ if(unpack("V",$window)) == codec_list;
		$guid{header}             = $_ if(unpack("V",$window)) == Header;
		$guid{audio_media}        = $_ if(unpack("V",$window)) == audio_media;
		$guid{video_media}        = $_ if(unpack("V",$window)) == video_media;
		$guid{audio_conceal_none} = $_ if(unpack("V",$window)) == audio_conceal_none;
		$guid{audio_spread}       = $_ if(unpack("V",$window)) == audio_spread;
		$guid{content_description}= $_ if(unpack("V",$window)) == content_description;
		$guid{data}               = $_ if(unpack("V",$window)) == data;
		$guid{simple_index}       = $_ if(unpack("V",$window)) == simple_index;
		$guid{stream_properties}  = $_ if(unpack("V",$window)) == stream_properties;
		$guid{header_2_0}         = $_ if(unpack("V",$window)) == header_2_0;
		$guid{file_properties}    = $_ if(unpack("V",$window)) == file_properties;
	}

	my @guids = map {$_->[0]}	sort {$a->[1] <=> $b->[1]} map {[$_,$guid{$_}]} keys %guid;

	for(my $i=0;$i
		my $thisguid = $guids[$i];
		my $nextguid = $guids[$i+1];
		#print $thisguid,"\t",$nextguid,"\n";

		my $thisguidpos = $guid{$thisguid};
		my $nextguidpos = $nextguid ? $guid{$nextguid} : length($header);

		my $head = substr($header,$thisguidpos,$nextguidpos - $thisguidpos - 1);

		my $guid   = unpack("V",substr($head,0,4));

		#warn "guid $thisguid: ".$thisguidpos."-".$nextguidpos;

		if($guid == Header){
			warn "Header" if DEBUG;
		  #noop yet.  we should switch modes depending on whether or not we have a 1.0 or 2.0 header
		} elsif($guid == header_2_0){
			warn "Header 2.0" if DEBUG;
			#no exmple yet
			die "header_2_0. Please email allenday\@ucla.edu";
		}

		elsif($guid == codec_list){
			warn "codec_list" if DEBUG;
			next unless length($head) >= 40; #prevent substr() errors on bad headers
			my($codecs) = unpack("V",substr($head,40,4));

			#print $head, "\n";

			#print "\ttotal codecs: $codecs\n";

			my $offset = 44;
			my $i = 0;
			while($i < $codecs){
				my($type,$namelen) = unpack("vv",substr($head,$offset,4)); $offset += 4;

				#print "\tcodec type: $type ";
				#print $type == 0x0000 ? "video\n"   :  #this is not standard by ASF 1.0
				#      $type == 0x0001 ? "video\n"   :
				#	  $type == 0x0002 ? "audio\n"   :
				#	  $type == 0xffff ? "unknown\n" : "huh?\n";

				$namelen *= 2; #because it is a unicode string
				my $name = substr($head,$offset,$namelen); $offset += $namelen;

				#print "\t\tname $namelen: $name\n";
				if($type == 0x0000 || $type == 0x0001){
				  $self->vcodec($self->vcodec || $name);
				  $self->vstreams( ($self->vstreams || 0) + 1);
				}

				if($type == 0x0002){
				  $self->acodec($name) unless $self->acodec;
				  $self->astreams( ($self->astreams || 0) + 1);
				}

				#we don't worry about these (for now)
				my($desclen) = unpack("v",substr($head,$offset,2));
				$desclen *= 2;
				my $desc = substr($head,$offset,$desclen); $offset += $desclen;
				#print "\t\tdesc: $desc\n";

				my($infolen) = unpack("v",substr($head,$offset,2));
				$infolen *= 2;
				my $info = substr($head,$offset,$infolen); $offset += $infolen;
				#print "\t\tinfo: $info\n";

				$i++;
			}
		}

		elsif($guid == file_properties){
			warn "file_properties" if DEBUG;
			next unless length($head) >= 32; #prevent substr() errors on bad headers

			my($size1,$size2,$date1,$date2,$count1,$count2,$dur1,$dur2) = unpack("VVVVVVVV",substr($head,40,32));
			my($maxbitrate) = unpack("V",substr($head,100,4));

			#these are 64bit values, so we have to put them together manually.
			#some systems (like mine) don't support q and Q unpacking.
			my $size  = ($size2 * 0xffffffff) + $size1;              #filesize in bytes
			my $date  = (($date2 * 0xffffffff) + $date1) / 1_000;    #creation time.  i have no idea what format --aday
			my $count = ($count2 * 0xffffffff)+ $count1;             #number of data packets in the data object
			my $dur   = (($dur2 * 0xffffffff) + $dur1) / 10_000_000; #was in 100 nanosecond units, zheesh

			#print "\tsize: $size\n";
			$self->date($date);
			#print "\tdate: ".$self->date."\n";
			$self->packets($count);
			#print "\tcount: ".$self->count."\n";
			$self->duration($dur);
			#print "\tduration: ".$self->duration."\n";
			$self->vrate($maxbitrate);
			#print "\tmax bitrate: ".$self->vrate."\n";
		}

		elsif($guid == content_description){
			warn "content_description" if DEBUG;
			next unless length($head) >= 34; #prevent substr() errors on bad headers
			my $offset = 34;
			my($titlelen,$authlen,$copylen,$desclen,$ratlen) = unpack("vvvvv",substr($head,24,10));
			my $title       = substr($head,$offset,$titlelen); $offset += $titlelen;
			my $author      = substr($head,$offset,$authlen);  $offset += $authlen;
			my $copyright   = substr($head,$offset,$copylen);  $offset += $copylen;
			my $description = substr($head,$offset,$desclen);  $offset += $desclen;
			my $rating      = substr($head,$offset,$ratlen);

			$self->title($title);
			$self->author($author);
			$self->copyright($copyright);
			$self->description($description);
			$self->rating($rating);
		}

		elsif($guid == video_media){
			warn "video_media" if DEBUG;
			next unless length($head) >= 16; #prevent substr() errors on bad headers

			my $codec = substr($head,81,4); #hack.  is it really at 81?  should be at 16 from 1.0 spec.
			$self->vcodec($codec);

			my($width,$height,$bpp,$colors) = unpack("VVxxvxxxxxxxxxxxxxxxxV",substr($head,54,32));

			$self->width($width);
			$self->height($height);

			#print "\tbpp: $bpp\n";
			#print "\tcompression ID: $codec\n";
			#print "\tcolors used: $colors\n";
		}

		elsif($guid == audio_spread || $guid == audio_media){
			warn "audio" if DEBUG;
			next unless length($head) >= 18; #prevent substr() errors on bad headers
			my($codecID,$achan,$samp,$bpsec,$blk,$bpsamp,$format) = unpack("vvVVvvv",substr($head,38,18));

			#print "\tcodec ID: $codecID\n";
			#$self->acodec($codecID) unless $self->acodec; #???
			#print "\tcodec   : ".$self->acodec."\n";
			#print "\taudio channels: $achan\n";
			$self->achans($achan);
			#print "\tsample rate: $samp\n";
			#print "\tbytes/second: $bpsec\n";
			$self->arate($bpsec * 8);
			#print "\tblock alignment: $blk\n";
			#print "\tbits/sample: $bpsamp\n";
			#print "\tformat: $format\n";
			$self->acodec($format);
		}

		elsif($guid == script_command) {
			warn "script_command" if DEBUG;
		  #hmm, interesting
		  warn "*********************script_command";
#		  my($rawsize1,$rawsize2) = unpack("VV",substr($head,16,8));
#		  my $objsize = (($rawsize2 * 0xffffffff) + $rawsize1);
#		  my $obj =
		}

		elsif($guid == stream_properties){
			warn "stream_properties" if DEBUG;
			#noop
		}

		elsif($guid == data){
			warn "data" if DEBUG;
			#noop, this is the movie itself
		}

		elsif($guid == simple_index){
			warn "simple_index" if DEBUG;
			#no example yet
			#warn "******************simple_index";
		}

		elsif($guid == audio_conceal_none){
			warn "audio_conceal_none" if DEBUG;
			#no example yet
			#warn "******************audio_conceal_none";
		}
	}

  return 1;
}

1;

__END__