# Copyright 2002-2008 Josh Clark and Global Moxie, LLC. This code cannot be
# redistributed without permission from globalmoxie.com.  For more
# information, consult your Big Medium license.
#
# $Id: Image.pm 3275 2008-08-23 18:17:43Z josh $

package BigMed::Media::Image;
use strict;
use warnings;
use utf8;
use Carp;
use BigMed;
use BigMed::Prefs;
use BigMed::DiskUtil (
    'bm_file_path',   'bm_untaint_filepath',
    'bm_confirm_dir', 'bm_check_space',
    'bm_copy_file',   'bm_move_file',
    'bm_delete_file', 'bm_file_chmod',
);
use BigMed::Trigger;
use base qw(BigMed::Media);
my $ERR = 'BigMed::Error';

#set default image sizes and quality
$BigMed::Media::Image::QUALITY = 80;
my %FORMATS = (
    '800x800' => 'xlarge',
    '600x600' => 'large',
    '400x400' => 'medium',
    '200x200' => 'small',
    '100x100' => 'xsmall',
    '60x60'   => 'thumb',
);
my %ACTIONS = (
    '800x800' => 'squeeze',
    '600x600' => 'squeeze',
    '400x400' => 'squeeze',
    '200x200' => 'squeeze',
    '100x100' => 'squeeze-crop',
    '60x60'   => 'squeeze-crop',
);
my %LABEL_LOOKUP = reverse %FORMATS;

BigMed::Prefs->register_pref(
    'image_actions',
    {   default   => {},
        edit_type => 'key_value',
    },
);

###########################################################
# SET IMAGE DATA SCHEMA
###########################################################

my @data_schema = (
    {   name => 'formats',
        type => 'image_file',
    },
    {   name => 'sm_image',
        type => 'raw_text',
    },
);

my @editor_fields = (
    {   column   => 'title',
        required => 1,
    },
    { column => 'formats', },
    {   column       => 'shared',
        option_label => 'LIBRARY_Allow others to use this item',
        default      => 1,
    },
    {   column       => 'in_lib',
        option_label => 'LIBRARY_Display in library for reuse',
        default      => 1,
    },
);

BigMed::Media::Image->register_minicontent(
    elements      => \@data_schema,
    can_link      => 1,
    can_hotlink   => 1,
    can_embed     => 1,
    editor_fields => \@editor_fields,
    post_parse    => \&process_image,
    preview       => { html => \&preview_html },
    batch_upload  => 'formats',
);

###########################################################
# TRASH CALLBACKS
###########################################################

BigMed::Media::Image->add_callback( 'before_trash', \&_trash_image_files );
BigMed::Media::Image->add_callback( 'before_trash_all',
    \&_trash_all_image_files );

sub _trash_image_files {
    my $self   = shift;
    my @delete = $self->_non_url_image_files();
    return 1 if !@delete;
    my $sid = $self->site or return 1;

    require BigMed::Site;
    my $site = BigMed::Site->fetch( { id => $sid } );
    return ( defined $site ) if !$site;
    my $img_dir = $site->image_path;
    foreach my $file (@delete) {
        bm_delete_file( bm_file_path( $img_dir, $file ) ) or return;
    }
    return 1;
}

sub _trash_all_image_files {
    my $select = shift;
    my %dir;

    my $obj;
    $select->set_index(0);
    while ( $obj = $select->next ) {
        my @delete = $obj->_non_url_image_files();
        next if !@delete;
        my $sid = $obj->site or next;
        my $img_dir = $dir{$sid};
        if ( !$img_dir ) {
            require BigMed::Site;
            my $site = BigMed::Site->fetch( { id => $sid } );
            return if !defined $site;    #error
            next   if !$site;            #not found
            $img_dir = $dir{$sid} = $site->image_path;
        }
        foreach my $file (@delete) {
            bm_delete_file( bm_file_path( $img_dir, $file ) ) or return;
        }
    }
    return if !defined $obj;
    return 1;
}

sub _non_url_image_files {
    my %format = $_[0]->formats;
    return grep { $_ && index( $_, 'url:' ) != 0 } values %format;
}

###########################################################
# COPY CALLBACK
###########################################################

BigMed::Media::Image->add_callback( 'after_copy', \&_after_image_copy );

sub _after_image_copy {
    my ( $orig, $clone, $rparam ) = @_;
    $clone->is_unique('title');
    $clone->set_formats( {} );
    my %orig_fmt = $orig->formats or return $clone->save;

    #collect the site directories
    my $nsite = $rparam->{target_site} || $clone->site;
    if ( !ref $nsite ) {
        my $nid = $nsite;
        defined( $nsite = BigMed::Site->fetch($nid) ) or return;
        return $orig->set_error(
            head => 'BM_No such site',
            text => ['BM_TEXT_No such site', $nid],
          )
          if !$nsite;
    }
    my $osite = $rparam->{source_site} || $orig->site;
    if ( !ref $osite ) {
        my $oid = $osite;
        $osite =
          $orig->site == $clone->site ? $nsite : BigMed::Site->fetch($oid);
        return if !defined $osite;
        return $orig->set_error(
            head => 'BM_No such site',
            text => ['BM_TEXT_No such site', $oid],
          )
          if !$osite;
    }
    my $odir = $osite->image_path;
    my $ndir = $nsite->image_path;

    #get target site sizes and see if original has entries for all sizes;
    #if gaps in original, generate a fresh full set if we can
    my @sizes = map { $_->[1] } $clone->image_formats($nsite);
    unshift @sizes, 'orig';
    my $missing;
    foreach my $s (@sizes) {
        $missing = 1, last if !$orig_fmt{$s};
    }
    my %clone_fmt;
    if (   $missing
        && $clone->can_thumbnail
        && $orig_fmt{orig}
        && -e bm_file_path( $odir, $orig_fmt{orig} )
        && index( $orig_fmt{orig}, 'url:' ) < 0 )
    {
        my $fname = $clone->import_media_file(
            dir      => $ndir,
            ext_file => bm_file_path( $odir, $orig_fmt{orig} ),
            filename => $orig_fmt{orig},
          )
          or return;
        $clone_fmt{orig} = $fname;
        $clone->set_formats( \%clone_fmt );
        $clone->generate_thumbnails($nsite) or return;    #also saves
        %clone_fmt = $clone->formats();    #filled w/thumbnail info
    }

    #copy matching formats over from original (no dupes),
    #in case some are urls or custom file entries
    foreach my $s (@sizes) {
        my $ofile = $orig_fmt{$s} or next;
        if ( index( $ofile, 'url:' ) == 0 ) {    #url entry
            bm_delete_file( bm_file_path( $ndir, $clone_fmt{$s} ) )
              if $clone_fmt{$s};
            $clone_fmt{$s} = $ofile;
            next;
        }
        my $opath = bm_file_path( $odir, $ofile );
        next if !-e $opath;
        my $fname = $clone->import_media_file(
            dir      => $ndir,
            ext_file => $opath,
            filename => ( $clone_fmt{$s} || $ofile ),
            replace  => $clone_fmt{$s}
          )
          or return;
        $clone_fmt{$s} = $fname;
    }
    $clone->set_formats( \%clone_fmt );
    return $clone->save;
}

###########################################################
# IMAGE HANDLING
###########################################################

sub can_thumbnail {
    return $_[0]->driver ? 1 : 0;
}

sub exists_at_site {
    my ( $obj, $site, $rparam ) = @_;
    croak 'site object required' if !ref $site || !$site->isa('BigMed::Site');
    my $sid = $site->id;
    $rparam ||= {};

    my $title = $obj->title or return 0;
    $title = qr/\A\Q$title\E/ms;
    my %oformat = $obj->formats;
    my $ofile   = $oformat{orig} or return 0;

    my $seek = $rparam->{selection} || ref $obj;
    my $select = $seek->select( { title => $title, site => $site->id } )
      or return;
    return 0 if !$select->count;

    my ( $filesize, $tdir );
    if ( index( $ofile, 'url:' ) != 0 ) {    #orig is file, not url
        my $source = $rparam->{source_site}
          || (
            $obj->site == $sid ? $site : BigMed::Site->fetch( $obj->site ) )
          or return 0;
        $filesize = -s bm_file_path( $source->image_path, $ofile )
          || 0;
        $tdir = $site->image_path;
    }

    my $test;
    my $regex = qr/\A\Q$ofile\E/ms;
    while ( $test = $select->next ) {
        my %tformat = $test->formats;
        my $tfile = $tformat{orig} or next;
        next if $tfile !~ $regex;
        if ( defined $filesize ) {    #file
            next if index( $tfile, 'url:' ) == 0;
            my $file = bm_file_path( $tdir, $tfile );
            next         if !-e $file;
            return $test if ( -s $file == $filesize );
        }
        else {
            return $test if $tfile eq $ofile;    #url match
        }
    }
    return 0;
}

sub default_sizes {    #return array of dimensions, ascending order by width
    return map { $_->[1] }
      sort     { $a->[0] <=> $b->[0] }
      map { [( /^(\d+)x/ms ? $1 : $_ ), $_] } keys %FORMATS;
}

sub image_actions {    #return
    my ( $class, $site ) = @_;
    croak 'image_actions requires site object' if !$site->isa('BigMed::Site');
    return ( %ACTIONS, $site->get_pref_value('image_actions') );
}

sub image_formats {
    my ( $class, $site ) = @_;

    #get any non-default sizes from site actions, and merge with default
    #FORMATS hash
    my %site_actions = $site ? $site->get_pref_value('image_actions') : ();
    my %formats = (
        %FORMATS, ( map { $_ => ( $FORMATS{$_} || $_ ) } keys %site_actions )
    );

    #sort by width and return array of array refs: [size name, dimensions]
    return map { [$_->[1], $_->[2]] }
      sort { $a->[0] <=> $b->[0] }
      map { [( /^(\d+)x/ms ? $1 : $_ ), $formats{$_}, $_] } keys %formats;
}

sub lib_preview_image {
    my ( $obj, $site ) = @_;
    croak 'lib_preview_img requires site object'
      if ref $site ne 'BigMed::Site';
    if ( $obj->sm_image ) {
        return _format_image_url( $obj->sm_image, $site->image_url );
    }
    else {
        return BigMed->bigmed->env('BMADMINURL') . '/img/bmcp_lib_image.png';
    }
}

sub lib_preview_url {
    my ( $obj, $site ) = @_;
    croak 'lib_preview_img requires site object'
      if ref $site ne 'BigMed::Site';

    my %format = $obj->formats;
    my $pre_key;
    foreach my $prefab (qw(large xlarge medium orig)) {
        my $fmt = $LABEL_LOOKUP{$prefab} || $prefab;
        $pre_key = $fmt, last if $format{$fmt};
    }
    if ( !$pre_key ) {    #get largest available or give up
        no warnings;      #quiet non-numeric warnings
        $pre_key = ( sort { $b <=> $a } keys %format )[0] or return q{};
    }

    return _format_image_url( $format{$pre_key}, $site->image_url );
}

sub can_batch_upload {
    return $_[0]->can_thumbnail();
}

sub batch_upload_title {
    my $obj     = shift;
    my %formats = $obj->formats;
    return $formats{orig} || 'Untitled';
}

sub preview_html {
    my ( $app, $obj, $roptions ) = @_;

    my $preview_url = $obj->lib_preview_image( $app->current_site );
    my %fmt         = $obj->formats;
    my %fmt_label   = ( %FORMATS, orig => 'original' );
    my $preview_dir = $app->current_site->image_url;
    my @links       =
      map {
        {   size => $fmt_label{ $_->[1] }
            ? $app->language( 'IMAGE_' . $fmt_label{ $_->[1] } )
            : $_->[1],
            url => _format_image_url( $fmt{ $_->[1] }, $preview_dir ),
        }
      }
      sort { $a->[0] <=> $b->[0] || $a->[1] cmp $b->[1] }
      map { /(\d+)x/ms ? [$1, $_] : [0, $_] } keys %fmt;

    my $html = $app->html_template(
        'wi_image_preview.tmpl',
        TITLE       => $obj->title,
        PREVIEW_URL => $preview_url,
        LINKS       => \@links,
    );
    return ( PREVIEW_HTML => $html );
}

sub _format_image_url {
    my ( $url, $image_dir ) = @_;
    return index( $url, 'url:' ) == 0 ? substr( $url, 4 ) : "$image_dir/$url";

}

sub process_image {
    my ( $self, $rfields ) = @_;

    # the formats column is parsed via the image_file parser, which returns
    # a reference to an array of hash refs, with these key/value pairs:
    #
    # url        => if provided, the rest will always be empty
    # filename   => the name of the file itself (no path)
    # tempfile   => path to file in its temporary location as saved by CGI.pm
    # filehandle => filehandle for temporary file
    # dimensions => widthxheight string, e.g: 60x60 -- empty for orig
    #
    # the job here is process each item in the array and put it into
    # the formats or url column, newly reformatted into a hash reference,
    # with keys being the dimensions and values being the filename.
    # old images for each format are replaced if necessary (even if
    # they have a different name).
    #
    # if neither url nor filename is defined for a size format, clear
    # the url value, but leave any existing file intact.

    my $rallimage = $rfields->{formats}
      or return;    #there was probably an error
    my @images = @{$rallimage};

    #set field values to current formats and urls value (dereference)
    my %old_fmt = $self->formats;
    $rfields->{formats} = \%old_fmt;

    if ( !@images && !%old_fmt ) {
        $rfields->{_ERROR}->{formats} = 'PARSE_ERR_Please provide a value.';
    }
    if ( $rfields->{_ERROR} ) {    #don't do anything if there are errors
        foreach (@images) {
            close $_->{filehandle} if $_->{filehandle};
        }
        return;
    }

    #fetch the site
    my $app = BigMed->bigmed->app;
    my $site;
    if ( $app->can('current_site') ) {
        $site = $app->current_site;
    }
    else {
        my $sid = $self->site or croak 'Could not get site from image object';
        defined( $site = BigMed::Site->fetch($sid) ) or return;
        croak "Image.pm could not find site with id $sid" if !$site;
    }

    my $dir = $site->image_path;

    foreach my $rimage (@images) {
        my %image = %{$rimage};
        my $size  = $image{dimensions} || 'orig';
        my $old   = $rfields->{formats}->{$size} || q{};
        if ( $image{url} ) {
            bm_delete_file( bm_file_path( $dir, $old ) )
              if $old && index( $old, 'url:' ) != 0;
            $rfields->{formats}->{$size} = "url:$image{url}";
        }
        next if !$image{filename};

        my ( $filename, $tmpfile, $filehandle ) =
          @image{qw(filename tempfile filehandle)};
        return _set_field_error($rfields)
          if !$image{manual} && !$self->filetype_supported($filename);

        #if old value is file and we're thumbnailing, stow it somewhere
        #safe before save in case we run into trouble with the thumbnail
        $old = q{} if index( $old, 'url:' ) == 0;
        my ( $bak_path, $filepath );
        if ( $old && !$image{manual} ) {    #stow backup before copy
            $filepath = bm_file_path( $dir, $old );
            $bak_path = bm_file_path( $dir, "$old~backup" );
            if ( -e $filepath ) {
                bm_copy_file( $filepath, $bak_path, { build_path => 1 } )
                  or return;
            }
        }

        $filename = $self->import_media_file(
            dir      => $dir,
            ext_file => $tmpfile,
            filename => $filename,
            replace  => ( $old || undef ),
        );
        if ( !$filename ) {
            foreach (@images) {
                close( $_->{filehandle} ) if $_->{filehandle};
            }
            return _set_field_error($rfields);
        }

        if ( !$image{manual} ) {    #we're thumbnailing....

            #no need to worry about overwriting existing names with the
            #generated files; they contain a ~ or . character which would get
            #scrubbed out by manual uploads, and the base name is guaranteed
            #to be unique because of import_media_file.

            my $orig = bm_file_path( $dir, $filename );
            $rfields->{formats} =
              $self->_make_thumbnail_formats( $site, $orig );
            if ( !$rfields->{formats} ) { #error, revert to previous state
                bm_delete_file($orig);
                bm_delete_file($filepath) if $filepath;
                bm_move_file( $bak_path, $filepath ) if $bak_path;
                foreach (@images) {
                    close( $_->{filehandle} ) if $_->{filehandle};
                }
                return _set_field_error($rfields);
            }
            $rfields->{formats}->{orig} = $filename;
            bm_delete_file($bak_path) if $bak_path;

            last;                   #should have only a single master image
        }
        else {    #loading images manually; copying the files will suffice
            $rfields->{formats}->{$size} = $filename;
        }
    }
    foreach (@images) {
        close( $_->{filehandle} ) if $_->{filehandle};
    }

    #choose a preview image
    $self->choose_preview_image( $rfields->{formats} );
    return 1;
}

sub choose_preview_image {
    my $self = shift;
    my $rformats = shift || { $self->formats };
    my $pre_key;
    foreach my $prefab qw(thumb xsmall small medium) {
        my $fmt = $LABEL_LOOKUP{$prefab};
        $pre_key = $fmt, last if $rformats->{$fmt};
    }
    
    my $WARN = $^W;
    $^W = 0; #block non-numeric value warning for 'orig' sort
    $pre_key = ( sort { $a <=> $b } keys %{$rformats} )[0]
      if !$pre_key;
    $^W = $WARN;
    $self->set_sm_image( $pre_key ? $rformats->{$pre_key} : undef );
    return $self->sm_image();
}

sub _set_field_error {
    my $rfields = shift;
    my $msg = shift || 'IMAGE_Could not process image.';
    $rfields->{formats} = undef;
    $rfields->{_ERROR}->{formats} = $msg;
    $rfields->{_ERROR}->{_FIRST_ERR} ||= 'image';
    return;
}

sub _make_thumbnail_formats {
    my ( $self, $site, $filepath ) = @_;
    croak 'generate_images requires site object'
      if ref $site ne 'BigMed::Site';

    #have to have an original image to work with if not supplied in filepath
    my %old_fmt = $self->formats;
    my $dir = $site->image_path;
    if ( !$filepath ) {
        return \%old_fmt
          if !$old_fmt{orig} || index( $old_fmt{orig}, 'url:' ) == 0;
        $filepath = bm_file_path( $dir, $old_fmt{orig} );
    }
    if ( !-e $filepath ) {
        warn "Could not make thumbnail image, file not found: $filepath";
        return \%old_fmt;    #warn and otherwise be silent
    }

    my %image_actions = $self->image_actions($site);
    my %transform;    #key: crop/squeeze/squeeze-crop; value: dimensions
    foreach my $format ( keys %image_actions ) {
        push @{ $transform{ $image_actions{$format} } }, $format;
    }

    #make the thumbnails and get the hash ref of format=>filename
    #(not including orig)
    my $rformats = $self->save_sizes(
        filepath  => $filepath,
        dir       => $dir,
        transform => \%transform,
      )
      or return;

    #remove any files whose names have changed (original is handled
    #elsewhere)
    foreach my $size ( keys %old_fmt ) {
        next if $size eq 'orig';
        my $newfile = $rformats->{$size};
        next if index($old_fmt{$size},'url:') == 0;
        bm_delete_file( bm_file_path( $dir, $old_fmt{$size} ) )
          if !$newfile || $newfile ne $old_fmt{$size};
    }

    return $rformats;    #does not include orig, only subsidiary files
}

sub generate_thumbnails {
    my ( $self, $site ) = @_;
    return 1 if !$self->can_thumbnail;
    croak 'generate_images requires site object'
      if ref $site ne 'BigMed::Site';

    my %orig_fmt = $self->formats;
    my $orig = $orig_fmt{orig} or return 1;    #nothing to do
    my $rnew_fmt = $self->_make_thumbnail_formats($site) or return;
    $rnew_fmt->{orig} = $orig;
    $self->set_formats($rnew_fmt);
    $self->choose_preview_image();
    return $self->save;
}

my %supported = (
    'jfif' => 'jpeg',
    'jpg'  => 'jpeg',
    'jpeg' => 'jpeg',
    'png'  => 'png',
    'gif'  => 'gif',
);

sub filetype_supported {
    my ( $self, $fn ) = @_;
    my $suffix = ( $fn =~ m{.+[.]([a-zA-Z0-9]+)$}ms ? lc $1 : q{} );
    if ( !$supported{$suffix} ) {
        return $ERR->set_error(
            head => 'IMAGE_Unsupported file format',
            text => [
                'IMAGE_TEXT_Unsupported file format',
                $suffix,
                join( ', ', sort keys %supported )
            ],
        );
    }
    return $suffix;
}

sub save_sizes {
    my $self   = shift;
    my $driver = $self->driver
      or return $self->set_error(
        head => 'IMAGE_No image driver',
        text => 'IMAGE_TEXT_No image driver'
      );
    my %param  = @_;
    my $rtrans = $param{transform}
      or croak 'No transformation provided to save_sizes';
    my %trans    = %{$rtrans};
    my $filepath = bm_untaint_filepath( $param{filepath} )
      or croak "Invalid filepath '$param{filepath}' provided to save_sizes";
    my $dir = bm_untaint_filepath( $param{dir} )
      or croak "Invalid directory '$param{dir}' provided to save_sizes";
    if ( !-e $filepath ) {
        return $ERR->set_error(
            head => 'IMAGE_Could not find original image file',
            text =>
              ['IMAGE_TEXT_Could not find original image file', $filepath],
        );
    }
    return if !$self->filetype_supported($filepath);

    #massage filename
    my ( $base, $suffix );
    ( $base = $filepath ) =~ s{.*[\\/]}{}ms;
    if ( $base =~ m{(.+)[.]([a-zA-Z0-9]+)\z}ms ) {
        ( $base, $suffix ) = ( $1, lc $2 );
    }
    else {
        croak "Invalid filepath '$filepath' in save_sizes";
    }
    $self->call_trigger('before_thumbs_saved', $filepath) or return;

    my %file_map = ();
    my $dot = BigMed->bigmed->env('DOT');
    foreach my $action (qw(squeeze crop squeeze-crop)) {
        $trans{$action} ||= [];
        my @sizes =
          ref $trans{$action} eq 'ARRAY'
          ? @{ $trans{$action} }
          : ( $trans{action} );
        next if !@sizes;
        my @formats;
        foreach my $size (@sizes) {
            if ( $size =~ /^(\d+)[xX](\d+)\z/ims ) {
                my $filename = "$base${dot}s$size.$suffix";
                $file_map{$size} = $filename;
                push @formats, [$1, $2, bm_file_path( $dir, $filename )];
            }
            else {
                warn "invalid size format $size; should be WxH (100x100)";
                next;
            }
        }
        my $method =
          $action eq 'squeeze-crop' ? '_do_squeeze_crop' : "_do_$action";
        $self->$method(
            filepath => $filepath,
            type     => $supported{$suffix},
            formats  => \@formats,
            driver   => $driver,
          )
          or return;
    }
    $self->call_trigger('after_thumbs_saved', \%file_map, $dir) or return;
    return \%file_map;
}

my $driver;

sub driver {
    my $class = ref $_[0] || $_[0];

    #loads drivers in this order for preference of speed and quality:
    #Imagemagick, Imager, NetPBM (slow but ok quality), GD (fast but lossy)
    return $driver if defined $driver;
    local $SIG{'__DIE__'};    #override any custom die hooks
    eval { require Image::Magick; import Image::Magick; };
    return ( $driver = $class . '::Magick' ) if !$@;
    eval { require Imager; import Imager; };
    return ( $driver = $class . '::Imager' ) if !$@;
    $driver = BigMed::Media::Image::NetPBM->init_netpbm();
    return $driver if $driver;
    eval { require GD; import GD; };
    return ( $driver = $class . '::GD' ) if !$@;
    return ( $driver = q{} );
}

sub _do_squeeze {  #keep proportions but reduce to fit inside height and width
    my $class  = shift;
    my %param  = @_;
    my $driver = $param{driver};
    my ( $type, $orig ) = @param{qw(type filepath)};
    foreach my $fmt ( @{ $param{formats} } ) {
        my ( $mxw, $mxh, $newfile ) = @{$fmt};
        my $size = "${mxw}x${mxh}";
        my ( $img, $w, $h ) =
          $driver->get_image_and_dims( $type, $orig, $size );
        return if !$img;
        my ( $nw, $nh ) =
          BigMed::Media::Image->_squeeze_size( $w, $h, $mxw, $mxh );
        $img = $driver->resize( $img, $w, $h, $nw, $nh );
        $driver->save_file( $img, $newfile, $type ) or return;
    }
    return 1;
}

sub _do_crop {    #crop image to height and width; no reduction
    my $class  = shift;
    my %param  = @_;
    my $driver = $param{driver};
    my ( $type, $orig ) = @param{qw(type filepath)};
    foreach my $fmt ( @{ $param{formats} } ) {
        my ( $cw, $ch, $newfile ) = @{$fmt};
        my ( $img, $w, $h ) = $driver->get_image_and_dims( $type, $orig );
        return if !$img;
        my ( $rsz_w, $rsz_h ) =
          BigMed::Media::Image->_reasonable_crop_size( $w, $h, $cw, $ch );
        $img = $driver->resize( $img, $w,     $h,     $rsz_w, $rsz_h );
        $img = $driver->crop( $img,   $rsz_w, $rsz_h, $cw,    $ch );
        $driver->save_file( $img, $newfile, $type ) or return;
    }
    return 1;
}

sub _do_squeeze_crop {    #reduce image to fit but crop to exact dimensions
    my $class  = shift;
    my %param  = @_;
    my $driver = $param{driver};
    my ( $type, $orig ) = @param{qw(type filepath)};
    foreach my $fmt ( @{ $param{formats} } ) {
        my ( $mxw, $mxh, $newfile ) = @{$fmt};
        my ( $img, $w, $h ) = $driver->get_image_and_dims( $type, $orig );
        return if !$img;
        my ( $nw, $nh ) =
          BigMed::Media::Image->_squeeze_crop_size( $w, $h, $mxw, $mxh );
        $img = $driver->resize( $img, $w,  $h,  $nw,  $nh );
        $img = $driver->crop( $img,   $nw, $nh, $mxw, $mxh );
        $driver->save_file( $img, $newfile, $type ) or return;
    }
    return 1;
}

sub _squeeze_size {    #fit entire image into bounding box
    my $class = shift;
    my ( $w, $h, $mxwidth, $mxheight ) = @_;
    my ( $w_scale, $h_scale ) = ( $mxwidth / $w, $mxheight / $h );

    #fit to the scale that will result in the smaller image
    my $scale = ( $w_scale * $h <= $mxheight ) ? $w_scale : $h_scale;
    my ( $nw, $nh ) = ( int( $w * $scale ), int( $h * $scale ) );
    $nw = $mxwidth if $nw == $mxwidth - 1; #fix rounding
    $nh = $mxheight if $nh == $mxheight - 1;
    return ( $nw > $w || $nh > $h ) ? ( $w, $h ) : ( $nw, $nh ); #no enlarging
}

sub _squeeze_crop_size {    #fill bounding box and crop any overflow
    my $class = shift;
    my ( $w, $h, $mxwidth, $mxheight ) = @_;

    #fit to the scale that will result in the larger image
    my ( $w_scale, $h_scale ) = ( $mxwidth / $w, $mxheight / $h );
    my $scale = ( $w_scale * $h >= $mxheight ) ? $w_scale : $h_scale;
    my ( $nw, $nh ) = ( int( $w * $scale ), int( $h * $scale ) );
    $nw = $mxwidth if $nw == $mxwidth - 1; #fix rounding
    $nh = $mxheight if $nh == $mxheight - 1;
    return ( $nw > $w || $nh > $h ) ? ( $w, $h ) : ( $nw, $nh ); #no enlarging
}

sub _reasonable_crop_size {
    my $class = shift;
    my ( $w, $h, $cw, $ch ) = @_;
    my $hdiff       = $h / $ch;
    my $wdiff       = $w / $cw;
    my $limit_ratio = 3;
    if ( $hdiff > $limit_ratio && $wdiff > $limit_ratio ) {

        #scale it to 3x target size, using the side that's closest to the
        #ratio as the index
        my ( $rsz_h, $rsz_w );
        if ( $hdiff < $wdiff ) {
            $rsz_h = $ch * $limit_ratio;
            $rsz_w = int( $rsz_h * ( $w / $h ) );
        }
        else {
            $rsz_w = $cw * $limit_ratio;
            $rsz_h = int( $rsz_w * ( $h / $w ) );
        }
        $rsz_w = $cw if $rsz_w == $cw - 1; #fix rounding
        $rsz_h = $ch if $rsz_h == $ch - 1;
        return ( $rsz_w, $rsz_h );
    }
    return ( $w, $h );    #size is fine as-is
}

sub _crop_offset_and_size {
    my $class = shift;
    my ( $size, $crop_size ) = @_;
    my $offset = 0;
    if ( $size > $crop_size ) {
        $offset = int( $size / 2 - $crop_size / 2 );
        $offset = 0 if $offset < 0;
    }
    else {
        $crop_size = $size;
    }
    return ( $offset, $crop_size );
}

package BigMed::Media::Image::Magick;
use strict;
use warnings;
use utf8;
use Carp;
use BigMed::DiskUtil qw(bm_file_chmod);
$Carp::Verbose = 1;

sub get_image_and_dims {    # FOR IMAGE::MAGICK
    my ( $class, $type, $orig, $size ) = @_;
    my $magick = Image::Magick->new( magick => $type );
    my %param = ( quality => $BigMed::Media::Image::QUALITY );
    $param{size} = $size if $size;  #for speed, can preload size if we know it
    $magick->Set(%param);
    my $err = $magick->Read($orig);
    return $err
      ? $ERR->set_io_error( undef, 'open', $orig, "(ImageMagick read) $err" )
      : ( $magick, $magick->Get( 'width', 'height' ) );
}

sub save_file {                     # FOR IMAGE::MAGICK
    my ( $class, $magick, $file, $type ) = @_;   #magick doesn't need the type
    my $err = $magick->Write($file);
    if ($err) {
        return $ERR->set_io_error( undef, 'write', $file, $err );
    }
    my $chmod = bm_file_chmod();
    chmod $chmod, $file;
    return 1;
}

sub resize {                                     # FOR IMAGE::MAGICK
    my ( $class, $magick, $ow, $oh, $nw, $nh ) = @_;
    return $magick if ( $ow == $nw && $oh == $nh );

    #   Older versions of imagemagick do not support thumbnail,
    #   so use Resize instead and Strip instead .
    #   Thumbnailing a bit superior: samples the image down to 5 times the
    #   final height, before running an normal -resize to reduce the image to
    #   its final size. Superior speed.
    if ( $magick->can('Thumbnail') ) {
        $magick->Thumbnail( geometry => "${nw}x${nh}" );
    }
    else {
        $magick->Resize( geometry => "${nw}x${nh}" );
        $magick->Strip() if $magick->can('Strip');    #not all support it
    }
    return $magick;
}

sub crop {                                            # FOR IMAGE::MAGICK
    my ( $class, $magick, $ow, $oh, $cw, $ch ) = @_;
    return $magick if ( $ow <= $cw && $oh <= $ch );    #smaller than crop size
    my ( $offset_w, $offset_h );
    ( $offset_w, $cw ) =
      BigMed::Media::Image->_crop_offset_and_size( $ow, $cw );
    ( $offset_h, $ch ) =
      BigMed::Media::Image->_crop_offset_and_size( $oh, $ch );
    $magick->Crop( geometry => "${cw}x${ch}+$offset_w+$offset_h" );
    $magick->Set( page => '0x0+0+0' );    #trims surrounding gif space
    return $magick;
}

package BigMed::Media::Image::Imager;
use base qw(BigMed::Error);
use strict;
use warnings;
use utf8;
use Carp;
use BigMed::DiskUtil qw(bm_file_chmod);
$Carp::Verbose = 1;

sub get_image_and_dims {                  # FOR IMAGER
    my ( $class, $type, $orig, $size ) = @_;    #imager doesn't use size
    my $imager = Imager->new;
    $imager->read( file => $orig, type => $type )
      or return $ERR->set_io_error( undef, 'open', $orig,
        '(Imager read) ' . $imager->errstr );
    return ( $imager, $imager->getwidth(), $imager->getheight() );
}

sub save_file {                                 # FOR IMAGER
    my ( $class, $imager, $file, $type ) = @_;
    my %param = ( file => $file, type => $type );
    $param{jpegquality} = $BigMed::Media::Image::QUALITY if $type eq 'jpeg';
    $imager->write(%param)
      or return $ERR->set_io_error( undef, 'write', $file, $imager->errstr );
    my $chmod = bm_file_chmod();
    chmod $chmod, $file;
    return 1;
}

sub resize {                                    # FOR IMAGER
    my ( $class, $imager, $ow, $oh, $nw, $nh ) = @_;
    return $imager if ( $ow == $nw && $oh == $nh );
    return ( $ow != $nw || $oh != $nh )
      ? $imager->scale( xpixels => $nw )
      : $imager;
}

sub crop {                                      # FOR IMAGER
    my ( $class, $imager, $ow, $oh, $cw, $ch ) = @_;
    return $imager if ( $ow <= $cw && $oh <= $ch );    #smaller than crop size
    my ( $offset_w, $offset_h );
    ( $offset_w, $cw ) =
      BigMed::Media::Image->_crop_offset_and_size( $ow, $cw );
    ( $offset_h, $ch ) =
      BigMed::Media::Image->_crop_offset_and_size( $oh, $ch );
    return $imager->crop(
        left   => $offset_w,
        top    => $offset_h,
        height => $ch,
        width  => $cw,
    );
}

## GD resizing is totally crummy... this should be a last resort.

package BigMed::Media::Image::GD;
use strict;
use warnings;
use utf8;
use Carp;
$Carp::Verbose = 1;
use BigMed::DiskUtil qw(bm_write_file);

#in GD, png quality is 0-9 where 0 is highest
my $png_quality = int( ( 100 - $BigMed::Media::Image::QUALITY ) / 10 );
if ( $png_quality < 0 ) {
    $png_quality = 0;
}
elsif ( $png_quality > 9 ) {
    $png_quality = 9;
}

sub get_image_and_dims {    # FOR GD
    my ( $class, $type, $orig, $size ) = @_;    #gd doesn't use size
    my $gd = GD::Image->new($orig)
      or return $ERR->set_io_error( undef, 'open', $orig,
        "(GD could not open image) $!" );
    return ( $gd, $gd->getBounds() );
}

sub save_file {                                 # FOR GD
    my ( $class, $gd, $file, $type ) = @_;
    $type = 'jpeg' if $type eq 'jpg' || $type eq 'jfif';
    my $data;
    if ( $type eq 'jpeg' || $type eq 'jpg' || $type eq 'jfif' ) {
        $data = $gd->jpeg($BigMed::Media::Image::QUALITY);
    }
    elsif ( $type eq 'png' ) {
        $data = $gd->png($png_quality);
    }
    else {
        $data = $gd->$type;
    }
    return bm_write_file( $file, $data, { binmode => 1 } );
}

sub resize {    # FOR GD
    my ( $class, $gd, $ow, $oh, $nw, $nh ) = @_;
    return $gd if ( $ow == $nw && $oh == $nh );
    my $thumb = GD::Image->new( $nw, $nh );
    if ($thumb->can('copyResampled')) {
        $thumb->copyResampled( $gd, 0, 0, 0, 0, $nw, $nh, $ow, $oh );
    }
    else {
        $thumb->copyResized( $gd, 0, 0, 0, 0, $nw, $nh, $ow, $oh );
    }
    return $thumb;
}

sub crop {      # FOR GD
    my ( $class, $gd, $ow, $oh, $cw, $ch ) = @_;
    return $gd if ( $ow <= $cw && $oh <= $ch );    #smaller than crop size
    my ( $offset_w, $offset_h );
    ( $offset_w, $cw ) =
      BigMed::Media::Image->_crop_offset_and_size( $ow, $cw );
    ( $offset_h, $ch ) =
      BigMed::Media::Image->_crop_offset_and_size( $oh, $ch );
    my $cropped = GD::Image->new( $cw, $ch );
    $cropped->copyResized( $gd, 0, 0, $offset_w, $offset_h, $cw, $ch, $cw,
        $ch );
    return $cropped;
}

#reasonably good quality, but pretty slow -- I think I can probably
#do more to optimize this routine (right now every call to _do_netpbm_command
#is translating from target format to pbm and back; can probably reserve
#that step just for loading and saving images).

package BigMed::Media::Image::NetPBM;
use strict;
use warnings;
use utf8;
use Carp;
$Carp::Verbose = 1;
use BigMed::DiskUtil qw(bm_write_file);
use English qw( -no_match_vars );

my $netpbm_path;

sub init_netpbm {
    my $class = shift;
    return if index( $OSNAME, 'MSWin' ) >= 0;    #only do it for unix

    require Config;
    require File::Spec;
    require ExtUtils::MakeMaker;

    #see if we have the files, using pnmscale as the test
    my $command = 'pnmscale';

    #throw in /opt/local/bin too
    my @dir = (
        split( /\Q$Config::Config{path_sep}\E/ms, $ENV{PATH} ),
        '/opt/local/bin',
    );
    foreach my $dir (@dir) {
        my $abs = File::Spec->catfile( $dir, $command );
        $netpbm_path = $dir, last if MM->maybe_command($abs);
    }
    return if !$netpbm_path;
    
    #requires ipc::run but win32 sometimes can't do it
    eval { require IPC::Run; };
    return if $@;
    
    return $class;
}

sub get_image_and_dims {    # FOR NETPBM
    my ( $class, $type, $orig, $size ) = @_;   #netpbm doesn't use size string

    #load data
    my $netpbm = _do_netpbm_command( { type => $type, file => $orig } );

    #look up file dimensions
    my ( $out, $err );
    my @in = ("$netpbm_path/${type}topnm");
    my @out = ( "$netpbm_path/pnmfile", '-allimages' );
    IPC::Run::run( \@in, '<', \$netpbm->{data}, q{|}, \@out, \$out, \$err )
      or return $ERR->set_io_error( undef, 'open', $orig,
        "(NetPBM dimensions) $err" );
    my ( $w, $h ) = $out =~ /(\d+)\s+by\s+(\d+)/ms;
    return ( $netpbm, $w, $h );
}

sub save_file {    # FOR NETPBM
    my ( $class, $netpbm, $file, $type ) = @_;
    return bm_write_file( $file, $netpbm->{data}, { binmode => 1 } );
}

sub _do_netpbm_command {    #FOR NETPBM
    my ( $netpbm, @commands ) = @_;    #no commmands just loads data as-is
    push( @commands, q{|} ) if @commands;
    my @source;
    my @in = ( _choose_command( $netpbm->{type} . 'to', q{} ) );
    if ( defined $netpbm->{data} ) {    #load from pre-loaded data
        @source = ( '<', \$netpbm->{data} );
    }
    else {                              #use the filename
        push @in, $netpbm->{file};
    }
    my @out = ( _choose_command( q{}, 'to' . $netpbm->{type} ) );
    my @quant =
      $netpbm->{type} eq 'gif'
      ? ( [_choose_command( q{}, 'quant' ), 256], q{|} )
      : ();

    #pnmquant needs help with the path
    my $path = $ENV{'PATH'};
    $ENV{'PATH'} .= ":$netpbm_path";

    my ( $out, $err );
    my $success =
      IPC::Run::run( \@in, @source, q{|}, @commands, @quant, \@out, \$out,
        \$err );
    $ENV{'PATH'} = $path;    #no need for that anymore
    return $ERR->set_error(
        head => 'IMG_Image Parsing Error',
        text => ['IMG_TEXT_Image Parsing Error', $err]
      )
      if !$success;
    $netpbm->{data} = $out;
    return $netpbm;
}

sub _choose_command {        #FOR NETPBM
    my $prefix = shift || q{};
    my $suffix = shift || q{};
    my $command;
    foreach my $fmt (qw( pam pnm ppm )) {
        my $output = "$netpbm_path/$prefix$fmt$suffix";
        $command = $output, last if -x $output;
    }
    return $command;
}

sub resize {                 #FOR NETPBM
    my ( $class, $netpbm, $ow, $oh, $nw, $nh ) = @_;
    return $netpbm if ( $ow == $nw && $oh == $nh );
    my $command = _choose_command( q{}, 'scale' );
    return _do_netpbm_command( $netpbm,
        [$command, '-width', $nw, '-height', $nh] );
}

sub crop {                   # FOR NETPBM
    my ( $class, $netpbm, $ow, $oh, $cw, $ch ) = @_;
    return $netpbm if ( $ow <= $cw && $oh <= $ch );    #smaller than crop size
    my ( $offset_w, $offset_h );
    ( $offset_w, $cw ) =
      BigMed::Media::Image->_crop_offset_and_size( $ow, $cw );
    ( $offset_h, $ch ) =
      BigMed::Media::Image->_crop_offset_and_size( $oh, $ch );
    my $command = _choose_command( q{}, 'cut' );
    return _do_netpbm_command(
        $netpbm,
        [   $command,  '-left',  $offset_w, '-top',
            $offset_h, '-width', $cw,       '-height',
            $ch
        ]
    );
}

1;
__END__


=head1 NAME

BigMed::Media:Image - Big Medium image objects.

=head1 DESCRIPTION

BigMed::Media::Image objects represent images in the Big Medium system.
The class also handles resizing, publication and unpublication of images,
and other image manipulation

=head1 USAGE

BigMed::Image is a subclass of BigMed::Data. In addition to the methods 
documented below, please see the BigMed::Data documentation for details about
topics including:

=over 4

=item Creating a new data object

=item Saving a data object

=item Finding and sorting saved data objects

=item Data access methods

=item Error handling

=back

=head1 METHODS

=head2 Data Access Methods

BigMed::Media::Image objects hold the following pieces of data. They can be
accessed and set using the standard data access methods described in the
BigMed::Data documentation. See the L<"Searching and Sorting"> section below
for details on the data columns available to search and sort BigMed::Site
objects.

=over 4

=item * id

The numeric ID of the pointer object

=item * site

The numeric ID of the site to which the two objects belong

=item * owner

The numeric ID of the user who "owns" the media object.

=item * shared

Boolean value indicating whether the owner allows this media to be used by other
users with privileges at the same site. (Admins and webmasters are always
allowed to use the media objects).

= item * slug

The slug name for the media object. This may be used to generate a filename
or be used as an id string in widgets. The slug must be unique within the
BigMed::Media::Image class.

= item * title

The name of the media object.

= item * version

The version of the media object.

= item * description

A text description of the media object (this might be used as a caption for
some types of media).

= item * formats

An array of format names corresponding to the various image sizes available
for this image.

= item * filetype

The file extension for the image type.

=item * mod_time

Timestamp for when the last time the object was saved.

=item * create_time

Timestamp for when the object was first created.

=back

=head3 Searching and Sorting

You can look up and sort records by any combination of the following fields.
See the C<fetch> and C<select> documentation in BigMed::Data for more info.

=over 4

=item * id

=item * mod_time

=item * site

=item * owner

=item * shared

=item * slug

=item * title

=item * version

=back

=head3 Copying image objects

BigMed::Media::Image extends BigMed::Data's C<copy> method by copying
all of the supporting image files in addition to the data object itself.
The method returns the cloned, B<saved> image object on success, or undef
on failure. (This is different behavior than the default BigMed::Data
copy method, which returns the clone unsaved).

    $clone = $image->copy( { source_site => $site1, target_site => $site2 } );

The optional hash reference can contain two parameters. Both are optional
but offer performance gains if provided:

=over 4

=item * C<<target_site => $site_id_or_obj>>

The site to which you would like to copy the document object. This can
be a site object or id. If not provided, the document is copied to the
same site as the original.

=item * C<<source_site => $site_id_or_obj>>

The site object or id for the original document object.

=back

If copying to a new site, only those supporting image files matching
the target site's image formats are copied. If the target site has image
formats that that source site does not, those additional sizes are generated
when copied.

=head3 Checking for duplicates

BigMed::Media::Image extends BigMed::Library's C<exists_at_site> stub
method. It returns the matching object if a similar object exists at the
argument site, otherwise a false value (undef on error).

    my $test;
    $test = $image->exists_at_site($site_obj);
    $app->error_stop if !defined $test;
    if ($test) {
        print $test->id, ' has the same content as ', $image->id, "\n";
    }

    #providing optional parameters in the second argument can provide
    #a performance boost
    my $select = BigMed::Media::Image->select( { site => $site->id } )
      or $app->error_stop;
    $test = $image->exists_at_site(
        $site, { selection => $select, source_site => $site_obj } );
    $app->error_stop if !defined $test;
    if ($test) {
        print $test->id, ' has the same content as ', $image->id, "\n";
    }

The check searches for images with similar titles and original image
filenames and then compares the byte size of the original filenames.
For images with urls for original images, they must be an exact match.

The optional second argument is a hash reference of two parameters:

=over 4

=item * selection => $data_selection

A cached selection of image objects at the site to search.

=item * source_site => $site_obj

The site object for the site to which the original image object belongs

=back

=head1 CALLBACK TRIGGERS

BigMed::Media::Image has two callback triggers in its C<save_sizes> method,
which may be used to act on the original image (before resizing) or the
resulting thumbnail images (after resizing):

=over 4

=item * C<before_thumbs_saved>

The callback receives the image object and the path to the original image
as arguments:

    BigMed::Media::Image->add_callback('before_thumbs_saved', \&my_callback);
    
    sub my_callback {
        my ($img_object, $orig_image_path) = @_
        ...
        return 1;
    }

=item * C<after_thumbs_saved>

The callback receives the image object, a hash reference mapping generated sizes to filenames, and the image directory where those images were saved. B<<Note
that the hash reference does not necessarily match the hash in the image
object's C<formats> value.>> (The C<save_sizes> method does not store this
hash reference in the C<formats> value, so that value will be the same as
it was when C<save_sizes> was called.)

    BigMed::Media::Image->add_callback('after_thumbs_saved', \&my_callback);
    
    sub my_callback {
        my ($img_object, $rsizes, $image_dir) = @_
        
        # $rsizes = {
        #     '800x800' => 'file.s800x800.jpg',
        #     '600x600' => 'file.s600x600.jpg',
        #     '400x400' => 'file.s400x400.jpg',
        #     ...
        # }

        ...
        return 1;
    }

=back

For more information on trigger callbacks, see BigMed::Trigger.

=head1 SEE ALSO

=over 4

=item * BigMed::Data

=item * BigMed::Media

=back

=head1 AUTHOR & COPYRIGHTS

This module and all Big Medium modules are copyright Josh Clark
and Global Moxie. All rights reserved.

Use of this module and the Big Medium content
management system are governed by Global Moxie's software licenses
and may not be used outside of the terms and conditions outlined
there.

For more information, visit the Global Moxie website at
L<http://globalmoxie.com/>.

Big Medium and Global Moxie are service marks of Global Moxie
and Josh Clark. All rights reserved.

=cut