File Coverage

blib/lib/Labyrinth/Media.pm

Criterion	Covered	Total	%
statement	43	45	95.5
branch			n/a
condition			n/a
subroutine	15	15	100.0
pod			n/a
total	58	60	96.6

package Labyrinth::Media;

use warnings;
use strict;

use vars qw($VERSION @ISA %EXPORT_TAGS @EXPORT @EXPORT_OK);
$VERSION = '5.32';

=head1 NAME

Labyrinth::Media - Media File Management for Labyrinth

=head1 DESCRIPTION

This module collates many media and image file handling functionality used
within Labyrinth.

It should be noted that internally images and media files are stored in the
same, although images also record dimensions. When retrieving the required
files, it is recommend you call the appropriate method to ensure you are
getting the correct format of data for the file format. For example, GetImage
and GetMedia, both return file information, but GetImage adds deminsion data.

Also note that Images and Photos differ in the directory structure storage, so
saving and copying need to reference different functions. See below for a more
detailed explanation.

=cut

# -------------------------------------
# Export Details

require Exporter;
@ISA = qw(Exporter);

%EXPORT_TAGS = (
    'all' => [ qw(
        CGIFile
        StockSelect StockName StockPath StockType PathMove
        GetImage SaveImageFile MirrorImageFile
        CopyPhotoFile SavePhotoFile
        GetMedia SaveMediaFile SaveFile DeleteFile UnZipFile
        GetImageSize ResizeDimensions GetGravatar
    ) ]
);

@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
@EXPORT    = ( @{ $EXPORT_TAGS{'all'} } );

# -------------------------------------
# Library Modules

use Archive::Extract;
use Data::Dumper;
use Digest::MD5 qw(md5_hex);
use File::Basename;
use File::Copy;
use File::Path;
use File::Slurp;
use Image::Size;
use URI::Escape qw(uri_escape);
use WWW::Mechanize;

use Labyrinth::Audit;
use Labyrinth::Globals;
use Labyrinth::DBUtils;
use Labyrinth::DIUtils;
use Labyrinth::Metadata;
use Labyrinth::MLUtils;
use Labyrinth::Plugins;
use Labyrinth::Support;
use Labyrinth::Users;
use Labyrinth::Variables;

# -------------------------------------
# Constants

use constant    MaxDefaultImageWidth     => 800;
use constant    MaxDefaultImageHeight    => 600;
use constant    MaxDefaultThumbWidth     => 200;
use constant    MaxDefaultThumbHeight    => 200;

# -------------------------------------
# Variables

{ # START Stock Control

my @CHARS = (
    qw/A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
       a b c d e f g h i j k l m n o p q r s t u v w x y z
       0 1 2 3 4 5 6 7 8 9 _
      /);

my %stock;

# -------------------------------------
# The Functions

=head1 PUBLIC INTERFACE FUNCTIONS

=head2 Stock Control Functions

=over

=item CGIFile

When uploading a file via a web form, this function will save the file to the
local filesystem.

=back

=cut

my %image_store;

sub CGIFile {
    my $param = shift;
    my $stock = shift || 1;

    _init_stock()   unless(%stock);
    $stock = 1  unless($stock{$stock});
    my $path = "$settings{webdir}/$stock{$stock}->{path}";
    mkpath($path);

    # have we already saved the file
    if($image_store{$param}) {
        # move file if different stock type requested
        if($image_store{$param}[3] != $stock) {
            my $source = "$settings{webdir}/$image_store{$param}[1]";
            my $target = "$path/$image_store{$param}[0].$image_store{$param}[2]";
            copy($source,$target);
            #unlink($source);

            $target =~ s!^$settings{webdir}/!!;
            $image_store{$param}[1] = $target;
            $image_store{$param}[3] = $stock;
        }

        #LogDebug("CGIFile: return previous $param image_store=".Dumper($image_store{$param}));
        return @{$image_store{$param}};
    }

    my $fn = $cgi->param($param);
    LogDebug("CGIFile: $param fn=$fn");
    return unless($fn);

    my ($bytes,$filename,$dir,$name,$suffix);

    eval {
        my $f = $cgi->upload($param) || die "Cannot access filehandle\n";
        ($name, $dir, $suffix) = fileparse($fn,qr/\.[^.]*/);
        #LogDebug("CGIFile: fileparse dir=$dir, name=$name, suffix=$suffix");

        my $tries = 0;
        while(1) {
            last    if($tries++ > 10);
            $filename = "$path/" . _randname('imgXXXXXX') . lc($suffix);
            next    if(-f $filename);
            last;
        }

        my $buffer = read_file($f, binmode => ':raw');
        $bytes = length($buffer);
        write_file($filename, { binmode => ':raw' }, $buffer);
    };

    die $@ if $@;

    if($bytes == 0) {
        LogError("CGIFile: no bytes read for input file [$param]");
        return;
    }

    $filename =~ s!^$settings{webdir}/!!;
    $image_store{$param} = [$name,$filename,$suffix,$stock];
    #LogDebug("CGIFile: returning $param image_store=".Dumper($image_store{$param}));
    return ($name,$filename,$suffix);
}

=head2 Stock Control Functions

The stock list relates to the directory paths where uploaded files should be
saved on the local filesystem.

=over

=item StockName

Return the name for the given stock id.

=item StockPath

Return the path for the given stock id.

=item StockType

Return the stock id for the given stock code.

=item StockSelect

Returns an XHTML snippet for a dropdown selection box of stock entries.

=item PathMove

=back

=cut

sub StockName {
    my $stock = shift || 1;
    _init_stock()   unless(%stock);
    return $stock{$stock}->{title};
}

sub StockPath {
    my $stock = shift || 1;
    _init_stock()   unless(%stock);
    return $stock{$stock}->{path};
}

sub StockType {
    my $stock = shift || 'DRAFT';
    _init_stock()   unless(%stock);
    for(keys %stock) {
        return $_   if($stock{$_}->{title} eq $stock);
    }
    return 1;   # default
}

sub StockSelect {
    my $opt   = shift || 0;
    my $blank = shift || 1;
    _init_stock()   unless(%stock);

    my $html = "";
    $html .= "Select"    if(defined $blank && $blank == 1);

    foreach (sort {$a <=> $b} keys %stock) {
        $html .= "
        $html .= ' selected="selected"' if($opt == $_);
        $html .= ">$stock{$_}->{title}";
    }
    $html .= "";

    return $html;
}

sub PathMove {
    my ($stockid,$link) = @_;
    my ($path,$name) = ($link =~ m!(.+)/([^/]+)!);
    return $link    if($stock{$stockid}->{path} eq $path);

    my $old = "$settings{webdir}/$link";
    my $new = "$settings{webdir}/$stock{$stockid}->{path}/$name";

    rename $old, $new;
    return "$stock{$stockid}->{path}/$name";
}

# -------------------------------------
# Private Functions

sub _init_stock {
    my @rows = $dbi->GetQuery('hash','AllImageStock');
    $stock{$_->{stockid}} = $_  for(@rows);
}

sub _randname {
    my $path = shift;
    $path =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge;
    return $path;
}

} # END Stock Control

# -------------------------------------
# Public Image Functions

=head2 Image Functions

=over 4

=item GetImage($imageid)

Retrieves the image data for a given imageid.

=item SaveImageFile(%hash)

Saves an uploaded image file into the specified directory structure. If not
save directory is specified, the draft folder is used. The hash can contain
the following:

  param     - the CGI parameter used to reference the upload file
  width     - maximum saved width (default = 120px)
  height    - maximum saved height (default = 120px)
  imageid   - if overwriting already existing file
  stock     - file category (used to define the save directory)

=item MirrorImageFile($source,$stock [,$xmax,$ymax] )

Mirrors a file from a URL to the local file system. If a max width and height
are given, will resize the image.

=item GetImageSize($link,$size,$width,$height,$maxwidth,$maxheight)

For a given file, returns the true width and height that will be rendered
within the browser, given the current and default settings.

=item ResizeDimensions($dimensions,$file,$maxwidth,$maxheight)

Given the current dimensions, file and intended max height and width, will
return the width and height values to use in a image tag to scale the
dimensions to the require box size.

=item GetGravatar

Returns a Gravatar link.

=back

=cut

sub GetImage {
    my $imageid = shift;
    my @rows = $dbi->GetQuery('hash','GetImageByID',$imageid);
    return()    unless(@rows);

    my ($x,$y);
    if($rows[0]->{dimensions}) {
        ($x,$y) = split("x",$rows[0]->{dimensions});
    } else {
        ($x,$y) = imgsize($settings{webdir}.'/'.$rows[0]->{link});
    }
    return($rows[0]->{tag},$rows[0]->{link},$rows[0]->{href},$x,$y);
}


# stock type DRAFT should always be id 1
# DRAFT images are removed during reaping

sub MirrorImageFile {
    my ($source,$stock,$xmax,$ymax) = @_;
    my $stockid = StockType($stock);

    my $name = basename($source);
    my $file = StockPath($stockid) . '/' . $name;
    my $target = $settings{'webdir'} . '/' . $file;

    my $mechanize = WWW::Mechanize->new();
    $mechanize->mirror( $source, $target );

    if($xmax && $ymax) {
        my $i = Labyrinth::DIUtils->new($target);
        $i->reduce($xmax,$ymax);
    }

    my ($size_x,$size_y) = imgsize($target);

    my $imageid = SaveImage(
        undef,
        $name,          # tag (maybe keywords)
        $file,          # filename
        $stockid,       # stock type
        undef,
        $size_x . 'x' . $size_y
    );

    return ($imageid,$file);
}

sub SaveImageFile {
    my %hash = @_;

    my $param   = $hash{param};
    my $xmax    = $hash{width}  || $settings{maxdefaultimagewidth}  || MaxDefaultImageWidth;
    my $ymax    = $hash{height} || $settings{maxdefaultimageheight} || MaxDefaultImageHeight;
    my $imageid = $hash{imageid};
    my $stock   = StockType($hash{stock});

    return  unless($param && $cgiparams{$param});

    my ($name,$filename) = CGIFile($param,$stock);
    return 1    unless($name);  # blank if anything goes wrong

    eval {
        LogDebug("reducing '$settings{webdir}/$filename' to $xmax x $ymax");
        my $i = Labyrinth::DIUtils->new("$settings{webdir}/$filename");
        $i->reduce($xmax,$ymax);
    };

    LogDebug("error reducing '$settings{webdir}/$filename': $@")    if($@);

    my ($size_x,$size_y) = imgsize("$settings{webdir}/$filename");

    $imageid = SaveImage(
        $imageid,
        $name,          # tag (maybe keywords)
        $filename,      # filename
        $stock,         # stock type
        $hash{href},
        $size_x . 'x' . $size_y
    );

    return ($imageid,$filename);
}

sub GetImageSize {
    my ($link,$size,$width,$height,$maxwidth,$maxheight) = @_;
    $maxwidth  ||= $settings{maxdefaultimagewidth}  || MaxDefaultImageWidth;
    $maxheight ||= $settings{maxdefaultimageheight} || MaxDefaultImageHeight;

    my ($w,$h) = $size ? split('x',$size) : (0,0);
    ($w,$h) = imgsize("$settings{webdir}/$link") unless($w || $h);

    ($width,$height) = ($w,$h)  unless($width || $height);

    # long winded to avoid uninitialised variable errors
    if(defined $width && defined $height && $width > $height && $width > $maxwidth) {
        $width  = $maxwidth;
        $height = 0;
    } elsif(defined $width && defined $height && $width < $height && $height > $maxheight) {
        $height = $maxheight;
        $width  = 0;
    } elsif(defined $width && $width > $maxwidth) {
        $width  = $maxwidth;
        $height = 0;
    } elsif(defined $height && $height > $maxheight) {
        $height = $maxheight;
        $width  = 0;
    }

    if($width && $height) {
        # nothing
    } elsif( $width && !$height) {
        $height = int($h * ($width  / $w));
    } elsif(!$width &&  $height) {
        $width  = int($w * ($height / $h));
    }

    #LogDebug("dimensions: x.($w,$h) / ($width,$height) / ($settings{webdir}/$link)");

    return ($width,$height);
}

sub ResizeDimensions {
    my ($dimensions,$file,$maxwidth,$maxheight) = @_;
    my $toobig = 0;
    my ($x,$y);

    if($tvars{data}->{dimensions}) {
        ($x,$y) = split("x",$tvars{data}->{dimensions});
    } else {
        ($x,$y) = imgsize($file)  if(-f $file);
    }

    return                  unless($x && $y);
    return ($x,$y,$toobig)  unless($maxwidth && $maxheight);
    return ($x,$y,$toobig)  if($x <= $maxwidth && $y <= $maxheight);

    $toobig = 1;
    my $xr = $maxwidth  ? $maxwidth  / $x : 0;
    my $yr = $maxheight ? $maxheight / $y : 0;

    if($xr <= $yr) {
        $x *= $xr;
        $y *= $xr;
    } else {
        $x *= $yr;
        $y *= $yr;
    }

    return (int($x),int($y),$toobig);
}

sub GetGravatar {
    my ($id,$email) = @_;
    my $nophoto = uri_escape($settings{nophoto});

    return $nophoto     unless($id);
    my $user = GetUser($id);
    return $nophoto     unless($user);

    return
        'http://www.gravatar.com/avatar.php?'
        .'gravatar_id='.md5_hex($email)
        .'&default='.$nophoto
        .'&size=80';
}

=head2 Image Functions

=over 4

=item CopyPhotoFile()

Copy an existing stored image, both on the filesystem and in the database.

=item SavePhotoFile()

Save a photo uploaded via a web form to the local filesystem and to the photo
gallery database table.

=back

=cut

sub CopyPhotoFile {
    my %hash = @_;

    my $photo = $hash{photo};
    my $xmax  = $hash{width}  || $settings{maxdefaultimagewidth}  || MaxDefaultImageWidth;
    my $ymax  = $hash{height} || $settings{maxdefaultimageheight} || MaxDefaultImageHeight;
    my $stock = StockType($hash{stock});

    return  unless($photo);

    my @rs = $dbi->GetQuery('hash','GetPhotoDetail',$photo);
    my $name = basename($rs[0]->{image});
    return 1    unless($name);  # blank if anything goes wrong

    my $source = "$settings{webdir}/photos/$rs[0]->{image}";
    my $target = "$settings{webdir}/images/draft/$name";
    copy($source,$target);

    my $i = Labyrinth::DIUtils->new($target);
    $i->reduce($xmax,$ymax);

    my ($size_x,$size_y) = imgsize($target);

    $target =~ s!$settings{webdir}/!!;

    my $imageid = SaveImage(
        undef,
        $name,          # tag (maybe keywords)
        $target,        # filename
        $stock,         # stock type
        $hash{href},
        $size_x . 'x' . $size_y
    );

    return ($imageid,$target);
}

sub SavePhotoFile {
    my %hash = @_;

    my $param   = $hash{param}   || return;
    my $path    = $hash{path}    || return;
    my $page    = $hash{page}    || return;
    my $iwidth  = $hash{iwidth}  || $settings{maxdefaultimagewidth}  || MaxDefaultImageWidth;
    my $iheight = $hash{iheight} || $settings{maxdefaultimageheight} || MaxDefaultImageHeight;
    my $twidth  = $hash{twidth}  || $settings{maxdefaultthumbwidth}  || MaxDefaultThumbWidth;
    my $theight = $hash{theight} || $settings{maxdefaultthumbheight} || MaxDefaultThumbHeight;
    my $order   = $hash{order}   || 1;
    my $tag     = $hash{tag};
    my $stock   = StockType($hash{stock});

    return  unless($cgiparams{$param});

    my ($name,$filename,$extn) = CGIFile($param,$stock);
    return 1    unless($name);  # blank if anything goes wrong
    $tag = $name    unless(defined $tag);

    my $file = lc($name);
    $file =~ s/\s+//g;

    my $source = "$settings{webdir}/$filename";
    my $target = "$settings{webdir}/$path/$file$extn";
    copy($source,$target);

    $source = "$settings{webdir}/$path/$file$extn";
    $target = "$settings{webdir}/$path/$file-thumb$extn";
    copy($source,$target);

    eval {
        LogDebug("reducing '$source' to $iwidth x $iheight");
        my $i = Labyrinth::DIUtils->new($source);
        $i->reduce($iwidth,$iheight);
    };
    eval {
        LogDebug("reducing '$target' to $twidth x $theight");
        my $t = Labyrinth::DIUtils->new($target);
        $t->reduce($twidth,$theight);
    };

    my ($size_x,$size_y) = imgsize($source);

    $source =~ s!$settings{webdir}/(photos/)?!!;
    $target =~ s!$settings{webdir}/(photos/)?!!;
    my $photoid = $dbi->IDQuery('SavePhoto',$page,$target,$source,$size_x.'x'.$size_y,$tag,$order);

    MetaSave($photoid,['Photo'],split(/[ ,]+/,$name));

    return ($photoid,$name);
}

=head2 Media Functions

=over 4

=item GetMedia($imageid)

Retrieves the media data for a given imageid.

=item SaveMediaFile(%hash)

Saves an uploaded media file into the specified directory structure. If no
save directory is specified, the draft folder is used. The hash can contain
the following:

  param     - the CGI parameter used to reference the upload file
  imageid   - if overwriting already existing file
  stock     - file category (used to define the save directory)

=back

=cut

sub GetMedia {
    my $imageid = shift;
    my @rows = $dbi->GetQuery('hash','GetImageByID',$imageid);
    return()    unless(@rows);
    return($rows[0]->{tag},$rows[0]->{link},$rows[0]->{href});
}


# stock type DRAFT should always be id 1
# DRAFT images are removed during reaping

sub SaveMediaFile {
    my %hash = @_;

    my $param   = $hash{param};
    my $imageid = $hash{imageid};
    my $stock   = StockType($hash{stock});

    return  unless($param && $cgiparams{$param});

    my ($name,$filename) = CGIFile($param,$stock);
    return 1    unless($name);  # blank if anything goes wrong

    $imageid = SaveImage(
        $imageid,
        $name,          # tag (maybe keywords)
        $filename,      # filename
        $stock,         # stock type
        $hash{href},
        ''
    );

    return ($imageid,$filename);
}

=over

=item SaveFile(%hash)

Saves an uploaded media file into the specified directory structure. If no
save directory is specified, the draft folder is used. The hash can contain
the following:

  param     - the CGI parameter used to reference the upload file
  stock     - file category (used to define the save directory)

Note that this upload function assumes that the file is to be stored in the
appropriate directory with a link being return. No imageid or further reference
is held within the database.

=cut

sub SaveFile {
    my %hash = @_;

    my $param   = $hash{param};
    my $stock   = StockType($hash{stock});

    return  unless($param && $cgiparams{$param});

    my ($name,$filename) = CGIFile($param,$stock,1);
    return  unless($name);  # undef if anything goes wrong

    return $filename;
}

=item DeleteFile(%hash)

Deletes a previously uploaded media file from disk. No attempt is made to check
whether file is used within the database, other checks should be used prior to
calling this function if this is required. The hash can contain the following:

  file      - file to be deleted

=back

=cut

sub DeleteFile {
    my %hash = @_;

    my $file = $hash{file};
    unlink $file;
}

=head1 ADMIN INTERFACE FUNCTIONS

=over 4

=item ImageCheck

Used by Images::Delete to verify whether a particular module uses a particular
image referenced in the database.

=back

=cut

sub ImageCheck {
    my $imageid = shift;

    foreach my $plugin (get_plugins) {
        return 1    if( $plugin->ImageCheck($imageid) );
    }

    return 0;
}

=head1 LOCAL INTERNAL FUNCTIONS

=over 4

=item SaveImage

Writes image data to the database.

=cut

sub SaveImage {
    my ($imageid,@fields) = @_;

    if($imageid)    { $dbi->DoQuery('SaveImage',@fields,$imageid); }
    else            { $imageid = $dbi->IDQuery('AddImage',@fields); }

    return $imageid;
}

=item UnZipFile

Un wraps an archive file and stores it in an appropriate directory. For a
single file archive, the path to the file is returned. For collecions of
files, an 'index.html' is searched for and the path to it returned if
found. In all other instances the either the path to the first HTML file or
first other file is returned.

=cut

sub UnZipFile {
    my $file = shift;
    return  unless($file =~ /(.*)\.(zip|tar|tar\.gz|tgz)$/);

    my $path = $1;
    return  unless($path);

    # extract in to path directory
    # note ONLY ONE extraction allowed, in case zip of death uploaded

    my $ae = Archive::Extract->new( archive => "$settings{webdir}/$file" );
    my $ok = $ae->extract( to => "$settings{webdir}/$path" );
    unless($ok) {
        LogError("UnZip failure: file=[$file], path=[$path], error: ".$ae->error);
        rmtree("$settings{webdir}/$path");
        unlink("$settings{webdir}/$file");
        return;
    }

    my @files = map {my $x = $_; $x =~ s!$settings{webdir}/!!; $x} File::Find::Rule->file()->name('*')->in("$settings{webdir}/$path");
    unless(@files > 0) {
        LogError("UnZip failure: file=[$file], path=[$path], error: No files in archive.");
        rmtree("$settings{webdir}/$path");
        unlink("$settings{webdir}/$file");
        return;
    }

    # return file if count == 1
    return $files[0]    if(@files == 1);

    # return index.html if found
    my @html = grep {/^index.html?$/} @files;
    return $html[0]     if(@html);

    # return first html file if found
    @html = grep {/\.html?$/} @files;
    return $html[0]     if(@html);

    # return first file found
    return $files[0];
}

1;

__END__