view release on metacpan or  search on metacpan

lib/HTML/Bricks/Magick.pm  view on Meta::CPAN

package HTML::Bricks::Magick;

use strict;
use Apache::Constants qw(:common);
use Apache::File ();
use File::Basename qw(fileparse);
use DirHandle ();

our $VERSION = '0.02';

my %LegalArguments = map { $_ => 1 } 
qw (adjoin background bordercolor colormap colorspace
    colors compress density dispose delay dither
    display font format iterations interlace
    loop magick mattecolor monochrome page pointsize
    preview_type quality scene subimage subrange
    size tile texture treedepth undercolor);

my %LegalFilters = map { $_ => 1 } 
qw(AddNoise Blur Border Charcoal Chop
   Contrast Crop Colorize Comment CycleColormap
   Despeckle Draw Edge Emboss Enhance Equalize Flip Flop
   Frame Gamma Implode Label Layer Magnify Map Minify
   Modulate Negate Normalize OilPaint Opaque Quantize
   Raise ReduceNoise Resize Rotate Sample Scale Segment Shade
   Sharpen Shear Solarize Spread Swirl Texture Transparent
   Threshold Trim Wave Zoom);

sub handler {
    use Image::Magick;

    my $r = shift;

    return DECLINED unless $r->filename =~ /.*\.[jJ][pP][eE]?[gG]/;

    # get the name of the requested file
    my $file = $r->filename;

    # If the file exists and there are no transformation arguments
    # just decline the transaction.  It will be handled as usual.
    return DECLINED unless $r->args || $r->path_info || !-r $r->finfo;
    
    my $source;
    my ($base, $directory, $extension) = fileparse($file, '\.\w+');
    if (-r $r->finfo) { # file exists, so it becomes the source
  	$source = $file;
    } 
    else {              # file doesn't exist, so we search for it
  	return DECLINED unless -r $directory;
  	$source = find_image($r, $directory, $base);
    }
    
    unless ($source) {
  	$r->log_error("Couldn't find an image for $file");
  	return NOT_FOUND;
    }
  
    # Get args and construct our cached URI

    my $args = $r->args;
    my $cached = $r->document_root .  '/.magick_cache' . $r->uri . '?' . $args;

    # If the filtered image is already cached on the server, and the mtimes
    # match (indicating that the file hasn't been updated since the cached 
    # copy was created (see the bottom of this sub)) send the cached copy.

    my $mtime_source = ${@{[stat($source)]}}[9];

    #
    # but first check for clients polling to see if the file's been modified
    #

    if ($r->header_only) {