File Coverage

blib/lib/File/Properties/Media.pm

Criterion	Covered	Total	%
statement	21	100	21.0
branch	0	36	0.0
condition	0	9	0.0
subroutine	7	18	38.8
pod	7	7	100.0
total	35	170	20.5

# ----------------------------------------------------------------------------
#
# This module provides cached access to file SHA-2 digests and mime
# types. Additional information is available for bzip2 and gzip
# compressed files, and digital media files.
#
# Copyright © 2010,2011 Brendt Wohlberg
# See distribution LICENSE file for license details.
#
# Most recent modification: 18 December 2011
#
# ----------------------------------------------------------------------------

package File::Properties::Media;
our $VERSION = 0.02;

use File::Properties::Compressed;
use base qw(File::Properties::Compressed);

require 5.005;
use strict;
use warnings;
use Error qw(:try);
use Storable qw(freeze thaw);
use Image::ExifTool;


our $CacheTableName = 'MediaFileCache';
our $CacheTableCols = ['ContentDigest TEXT','MediaMimeType TEXT',
		      'MediaFileType TEXT','MediaType TEXT',
		      'DateModified DATE', 'ExifHash BLOB'];


# ----------------------------------------------------------------------------
# Initialiser
# ----------------------------------------------------------------------------
sub _init {
  my $self = shift;
  my $path = shift; # File path or File::Properties::Generic reference
  my $fpcr = shift; # File::Properties::Cache reference

  # Initialisation for base
  $self->SUPER::_init($path, $fpcr);
  ## Remainder of initialisation only necessary for regular files (in
  ## particular, it should not be performed for directories)
  if ($self->isreg) {
    ## Initialisation is complicated because it is only possible to
    ## reliably determine whether a file is a media file *after* using
    ## Image::ExifTool to determine its mime type (the mime type
    ## returned by Properties::Regular is less reliable for this
    ## purpose). The strategy to avoid inefficient multiple uses of
    ## Image::ExifTool (potentially resulting in uncompressing a
    ## compressed file more than once) is as follows. If the
    ## already-initialised base part of the object is marked as having
    ## been retrieved from the cache, assume that the file has been
    ## previously seen, and would therefore already have a media file
    ## cache entry if it were a media file: try to retrieve the media
    ## file details from the cache, and assume it is not a media file
    ## if the retrieval fails. If the already-initialised base part
    ## was not retrieved from the cache, assume the file has not been
    ## previously seen, and use Image::ExifTool to determine its
    ## medial file properties, which are then inserted into the media
    ## file cache.
    if ($self->_fromcache($File::Properties::Regular::CacheTableName)) {
      if (my $cent = $fpcr->cretrieve($CacheTableName,
				 {'ContentDigest' => $self->SUPER::cdigest})) {
	$self->mmimetype($cent->{'MediaMimeType'});
	$self->mfiletype($cent->{'MediaFileType'});
	$self->mediatype($cent->{'MediaType'});
	$self->datemod($cent->{'DateModified'});
	$self->exifhash(thaw $cent->{'ExifHash'});
	# Set flag indicating that this entry was obtained from the cache
	$self->_fromcache($CacheTableName, 1);
      }
    } else {
      ## Attempt to extract EXIF properties from file content
      my $exft = new Image::ExifTool;
      my $info = $exft->ImageInfo($self->cfilehandle, qw(*),
				  {PrintConv => 1,
				   DateFormat => "%Y-%m-%d %H:%M:%S",
				   CoordFormat => "%.8f"});
      my $ierr = $exft->GetValue('Error');
      ## If attempt to extract EXIF properties fails with error 'Unknown
      ## file type', then the file is not a media file and the general
      ## file properties are returned. If the attempt fails with any
      ## other error, throw an exception.
      throw File::Properties::Error("ExifTool error: ".$ierr, $exft)
	if (defined $ierr and $ierr ne 'Unknown file type');

      if (not defined $ierr) {
	## Determine media mime type, file type, and media type from EXIF data
	$self->mmimetype($exft->GetValue('MIMEType'));
	$self->mfiletype($exft->GetValue('FileType'));
	my $mtyp = $self->mmimetype;
	$mtyp =~ s+\/.*$++;
	$self->mediatype($mtyp);
	$self->datemod(_fixdatestr($info->{'ModifyDate'}));
	## Construct hash of EXIF tag data and freeze it for storage in cache
	my $exfh = {};
	my ($tag, $group, $val);
	foreach $tag ($exft->GetFoundTags('Group0')) {
	  $group = $exft->GetGroup($tag);
	  $val = $info->{$tag};
	  $exfh->{"$group:".Image::ExifTool::GetTagName($tag)} = $val
	    if (defined $val and not ref($val));
	}
	$self->exifhash($exfh);

	# Set flag indicating that this entry was not obtained from the cache
	$self->_fromcache($CacheTableName, 0);

	if (defined $fpcr) {
	  my $row = {'ContentDigest' => $self->SUPER::cdigest,
		     'MediaMimeType' => $self->mmimetype,
		     'MediaFileType' => $self->mfiletype,
		     'MediaType' => $self->mediatype,
		     'DateModified' => $self->datemod,
		     'ExifHash' => freeze \%{$self->exifhash}};
	  $fpcr->cinsert($CacheTableName, $row);
	}
      }
    }
  }
}


# ----------------------------------------------------------------------------
# Get (or set) media mime type
# ----------------------------------------------------------------------------
sub mmimetype {
  my $self = shift;

  $self->{'mmtp'} = shift if (@_);
  return (defined $self->{'mmtp'})?$self->{'mmtp'}:$self->cmimetype;
}


# ----------------------------------------------------------------------------
# Get (or set) media file type
# ----------------------------------------------------------------------------
sub mfiletype {
  my $self = shift;

  $self->{'mftp'} = shift if (@_);
  return $self->{'mftp'};
}


# ----------------------------------------------------------------------------
# Get (or set) media type (initial part of mime type, e.g. 'image')
# ----------------------------------------------------------------------------
sub mediatype {
  my $self = shift;

  $self->{'mtyp'} = shift if (@_);
  return $self->{'mtyp'};
}


# ----------------------------------------------------------------------------
# Get (or set) EXIF modification date
# ----------------------------------------------------------------------------
sub datemod {
  my $self = shift;

  $self->{'mddt'} = shift if (@_);
  return $self->{'mddt'};
}


# ----------------------------------------------------------------------------
# Get (or set) hash of EXIF tags and values
# ----------------------------------------------------------------------------
sub exifhash {
  my $self = shift;

  $self->{'exif'} = shift if (@_);
  return $self->{'exif'};
}


# ----------------------------------------------------------------------------
# Determine whether file properties represent a media file
# ----------------------------------------------------------------------------
sub ismedia {
  my $self = shift;

  return (defined $self->mediatype and ($self->mediatype eq 'image' or
					$self->mediatype eq 'video' or
					$self->mediatype eq 'audio'));
}


# ----------------------------------------------------------------------------
# Construct string representing properties hash
# ----------------------------------------------------------------------------
sub string {
  my $self = shift;
  my $levl = shift;

  $levl = 0 if (!defined $levl);
  my $lpfx = ' ' x (2*$levl);
  my $s = $self->SUPER::string($levl);
  if ($self->ismedia) {
    $s .= $lpfx . "   Media Mime Type: ".$self->mmimetype."\n";
    $s .= $lpfx . "   Media File Type: ".$self->mfiletype."\n";
    $s .= $lpfx . "   Media Type: ".$self->mediatype."\n";
    $s .= $lpfx .
      "   Date Modified: ".((defined $self->datemod)?$self->datemod:'')."\n";
  }
  return $s;
}


# ----------------------------------------------------------------------------
# Initialise cache table for File::Properties::Media data
# ----------------------------------------------------------------------------
sub _cacheinit {
  my $self = shift;
  my $fpcr = shift; # File::Properties::Cache reference
  my $opts = shift; # Options hash

  $self->SUPER::_cacheinit($fpcr, $opts);
  $fpcr->define($CacheTableName, $CacheTableCols,
	       {'TableVersion' => [__PACKAGE__.'::Version', $VERSION]});
}


# ----------------------------------------------------------------------------
# Clear invalid entries in cache table for File::Properties::Media data
# ----------------------------------------------------------------------------
sub _cacheclean {
  my $self = shift;
  my $fpcr = shift; # File::Properties::Cache reference

  my $mtbl = $CacheTableName;
  my $ctbl = $File::Properties::Compressed::CacheTableName;
  # Remove any entries in the File::Properties::Media cache table
  # for which there is not a corresponding entry with the same content
  # digest in the File::Properties::Compressed cache table
  $fpcr->remove($mtbl, {'Where' => "NOT EXISTS (SELECT * FROM $ctbl " .
		               "WHERE ContentDigest = $mtbl.ContentDigest)"});
}


# ----------------------------------------------------------------------------
# Standardise date format from EXIF data
# ----------------------------------------------------------------------------
sub _fixdatestr {
  my $dstr = shift;

  return undef if (not defined $dstr);
  if ($dstr =~ /(\d+)[^\d](\d+)[^\d](\d+)[^\d](\d+)[^\d](\d+)[^\d](\d+)/) {
    $dstr = "$1-$2-$3 $4:$5:$6";
  }

  return $dstr;
}


# ----------------------------------------------------------------------------
# End of method definitions
# ----------------------------------------------------------------------------


1;
__END__