Apache-Album
view release on metacpan or search on metacpan
package Apache::Album;
# For detailed information on this module, please see
# the pod data at the bottom of this file
#
# Copyright 1998-2004 James D Woodgate. All rights reserved.
# It may be used and modified freely, but I do request that this copyright
# notice remain attached to the file. You may modify this module as you
# wish, but if you redistribute a modified version, please attach a note
# listing the modifications you have made.
use Image::Magick;
use vars qw($VERSION);
use Apache2::RequestRec ();
use Apache2::RequestIO ();
use Apache2::SubRequest ();
use APR::Pool ();
use APR::URI ();
use Apache2::URI ();
use Apache2::Const -compile => qw(OK SERVER_ERROR REDIRECT);
$VERSION = '1.00';
sub handler {
my $r;
$r = shift if $ENV{MOD_PERL};
# All the configurable values will be stored in %settings
my %settings;
$settings{'AlbumTitle'} =
$r->dir_config('AlbumTitle') || "Available Albums";
$settings{'AlbumDir'} =
$r->dir_config->get('AlbumDir') || "/albums_loc";
$settings{'ThumbNailUse'} =
lc($r->dir_config('ThumbNailUse')) || "width";
$settings{'ThumbNailWidth'} =
$r->dir_config('ThumbNailWidth') || 100;
$settings{'ThumbNailAspect'} =
$r->dir_config('ThumbNailAspect') || "1/5";
$settings{'ThumbDir'} =
$r->dir_config('ThumbDir') || '/thumbs';
$settings{'DefaultBrowserWidth'} =
$r->dir_config('DefaultBrowserWidth') || 640;
$settings{'NumberOfColumns'} =
$r->dir_config('NumberOfColumns') || 0;
$settings{'BodyArgs'} =
$r->dir_config('BodyArgs');
$settings{'OutsideTableBorder'} =
$r->dir_config('OutsideTableBorder') || 0;
$settings{'InsideTablesBorder'} =
$r->dir_config('InsideTablesBorder') || 0;
$settings{'SlideShowDelay'} =
$r->dir_config('SlideShowDelay') || 60;
$settings{'Footer'} =
$r->dir_config('Footer') || '<center>Slide Show: '
. '<a href="?slide_show=sm">small</a> | '
. '<a href="?slide_show=med">medium</a> | '
. '<a href="?slide_show=lg">large</a> | '
. '<a href="?slide_show=xlg">xlarge</a> | '
. '<a href="?slide_show=full">full sized</a></center><br>'
. '<center>All Images: '
. '<a href="?all_full_images=sm">small</a> | '
. '<a href="?all_full_images=med">medium</a> | '
. '<a href="?all_full_images=lg">large</a> | '
. '<a href="?all_full_images=xlg">xlarge</a> | '
. '<a href="?all_full_images">full sized</a>'
. '</center><br><address>Apache::Album</address>';
$settings{'EditMode'} =
}
}
}
# We have a directory, but does $path_info end in a
# / like all good directories should? If not, add
# it and do a redirect, makes the pictures show up
# easier later.
unless ( $r->path_info =~ m!/$!) {
$r->server->warn("Redirecting -> " . $r->uri . "/");
$r->headers_out->{'Location'} = $r->uri . "/";
return Apache2::Const::REDIRECT;
}
# Try to open the directory, and read all the image file
# that aren't thumbnails
unless(opendir(IN,"$album_dir/$path_info")) {
$r->log_error("Couldn't open $album_dir/$path_info: $!");
return Apache2::Const::SERVER_ERROR;
}
my @files = grep { !/\.htaccess/ && !/^tn__/
&& $r->lookup_uri("$album_uri/$_")->content_type =~
m!^image/!} readdir(IN);
closedir(IN);
# If we have a directory, but slide_show is set, we need to grab the
# first file and redirect
if (defined $params{'slide_show'}) {
@files = sort(@files);
$r->server->warn("Redirecting -> " . $r->uri . $files[0] . "?slide_show="
. $params{'slide_show'});
$r->headers_out->{'Location'} = $r->uri . $files[0] . "?slide_show="
. $params{'slide_show'};
return Apache2::Const::REDIRECT;
}
# if @files is empty, need to call show_albums
return &show_albums($r, "$album_dir/$path_info", $path_info, \%settings)
unless @files;
@files = sort @files;
@files = reverse @files
if $settings{'ReversePics'};
my @cleanup_subs = ();
# Load up thumbnails
# Unless the thumbnail file exists, and
# is newer than the file it's a thumbnail for, generate the
# thumbnail
foreach (@files) {
unless ( -e "$thumb_dir/$path_info/tn__$_" &&
(stat(_))[9] > (stat("$album_dir/$path_info/$_"))[9] ) {
# Make sure the thumbnail directory exists
&mymkdir("$thumb_dir/$path_info", 0755)
unless -d "$thumb_dir/$path_info";
# Create a new thumbnail
my $q = new Image::Magick;
unless ($q) {
$r->log_error("Couldn't create a new Image::Magick object");
return Apache2::Const::SERVER_ERROR;
}
# Setting the size before reading the image is dramatically
# faster. The trade-off is that the quality of the resized
# image will be lower, which is OK for thumbnails.
# The actual resize (below) could be done with ->Sample() for
# similar reasons, but some limited testing revealed that the
# cumulative benefit of setting the size and using Sample was
# almost non-existant. Using ->Scale() instead might have a
# small quality benefit.
# Load up the current images width and height
my ($o_width, $o_height) = $q->Ping("$album_dir/$path_info/$_");
my ($ratio, $t_width, $t_height, $t_aspect);
# If we're using aspect, then multiply width and
# height by the aspect ratio
if ( $settings{'ThumbNailUse'} eq "aspect") {
$t_aspect = $settings{'ThumbNailAspect'};
# get the *real* aspect
$t_aspect =~ tr[^0-9/.][];
$t_aspect = eval($t_aspect);
$t_width = $o_width * $t_aspect;
$t_height = $o_height * $t_aspect;
}
else {
# Otherwise just make the width a constant and
# keep the same aspect ratio for the height
$t_width = $settings{'ThumbNailWidth'};
$ratio = $o_width / $o_height if $o_height;
$t_height = $t_width / $ratio if $ratio;
}
$q->Set( size => "${t_width}x${t_height}" );
$q->Read("$album_dir/$path_info/$_");
# Scale it down, and save the file
$q->Scale( width => $t_width, height => $t_height );
$q->Write("$thumb_dir/$path_info/tn__$_");
undef $q;
# Create smaller versions of the full size image if requested
if ($settings{'AllowFinalResize'}) {
my $q = new Image::Magick;
unless ($q) {
$r->log_error("Couldn't create a new Image::Magick object");
return Apache2::Const::SERVER_ERROR;
}
my $filename = $_;
push (@cleanup_subs, sub {&create_final_resize($r, \%settings, $album_dir, $thumb_dir, $path_info, $filename, $o_width, $o_height);});
}
}
}
$r->pool->cleanup_register(sub {foreach (@cleanup_subs) {&$_;}})
if @cleanup_subs;
# The title will be a hacked up path_info, only the
# last directory, transform -_ to space
my $title = $path_info;
$title =~ s|.*/||;
$title =~ tr|-_| |;
# Send the actual web page...
$r->content_type('text/html');
#$r->send_http_header();
return Apache2::Const::OK if $r->header_only;
$r->print(<<EOF);
<HTML>
<HEADER><TITLE>$title</TITLE></HEADER>
<BODY $settings{'BodyArgs'}>
EOF
# If there is a caption.txt file, include it here
# The caption file is copied directly to the page up
# to the __END__ line. At which point, the remaing
# text in the file is considered to be captions for
# individual files in the form:
#
# file.ext: Caption Here
#
# HTML tags are welcome in the entire file
my $caption_file = "$album_dir/$path_info/caption.txt";
# Account for varieties of using Alias
$caption_file =~ s!/{2,}!/!g;
my %picture_captions;
my $state = "Caption";
if ( -r $caption_file ) {
unless (open (IN,$caption_file)) {
$r->log_error("Weird, $caption_file is readable, but I can't read it: $!");
return Apache2::Const::SERVER_ERROR;
}
while (<IN>) {
$state eq "Caption" && ! /^__END__$/ and $r->print($_);
if ($state eq "Picture Captions") {
my ($key,@rest) = split (/:/,$_);
$picture_captions{$key} = (join(':',@rest));
}
/^__END__$/ and $state = "Picture Captions";
}
close IN;
@dirs = sort @dirs;
if (-f "$album_dir/$directory/.htaccess") {
my $override = 0;
# check if ReverseDirs is specified in here
if (open (IN, "$album_dir/$directory/.htaccess")) {
while (<IN>) {
if (/ReverseDirs\s+(.*)$/) {
@dirs = reverse @dirs
if $1;
$override = 1;
}
}
close IN;
unless ($override) {
@dirs = reverse @dirs
if $settings->{'ReverseDirs'};
}
}
else {
@dirs = reverse @dirs
if $settings->{'ReverseDirs'};
}
}
else {
@dirs = reverse @dirs
if $settings->{'ReverseDirs'};
}
if (@dirs) {
$r->print("\t<dd><dl>\n");
foreach (@dirs) {
&list_dirs($r, "$album_dir/$directory", $_, "$old_directory$directory/", $settings);
}
$r->print("\t</dl></dd>\n");
}
}
# file_upload is just the html for the file upload
# it's in a sub since it will be called from multiple
# places
sub file_upload {
my $ret = <<EOF
<FORM METHOD="POST" ENCTYPE="multipart/form-data">
<INPUT TYPE="submit" NAME="Upload" VALUE="Upload">
<INPUT TYPE="file" NAME="filename" SIZE=50 MAXLENGTH=200>
</FORM>
EOF
;
return $ret;
}
sub create_final_resize {
my ($r, $settings, $album_dir, $thumb_dir, $path_info, $filename, $o_width, $o_height) = @_;
my $q = new Image::Magick;
$q->Read("$album_dir/$path_info/$filename");
my $ratio = $o_width / $o_height if $o_height;
# X-Large is 1600x1200
if ($o_width > 1600) {
my $f_height = 0;
$f_height = 1600 / $ratio if $ratio;
my $q = $q->Clone();
unless ($q) {
$r->log_error("Couldn't create a new Image::Magick object");
return Apache2::Const::SERVER_ERROR;
}
$q->Scale( width => 1600, height => $f_height );
$q->Write("$thumb_dir/$path_info/"
. "/1600x1200_$filename");
}
# Large is 1024x768
if ($o_width > 1024) {
my $f_height = 0;
$f_height = 1024 / $ratio if $ratio;
my $q = $q->Clone();
unless ($q) {
$r->log_error("Couldn't create a new Image::Magick object");
return Apache2::Const::SERVER_ERROR;
}
$q->Scale( width => 1024, height => $f_height );
$q->Write("$thumb_dir/$path_info/"
. "/1024x768_$filename");
}
# Med is 800x600
if ($o_width > 800) {
my $f_height = 0;
$f_height = 800 / $ratio if $ratio;
my $q = $q->Clone();
unless ($q) {
$r->log_error("Couldn't create a new Image::Magick object");
return Apache2::Const::SERVER_ERROR;
}
$q->Scale( width => 800, height => $f_height );
$q->Write("$thumb_dir/$path_info/"
. "/800x600_$filename");
}
# Sm is 640x480
if ($o_width > 640) {
my $f_height = 0;
$f_height = 640 / $ratio if $ratio;
my $q = $q->Clone();
unless ($q) {
$r->log_error("Couldn't create a new Image::Magick object");
return Apache2::Const::SERVER_ERROR;
}
$q->Scale( width => 640, height => $f_height );
$q->Write("$thumb_dir/$path_info/"
. "/640x480_$filename");
}
}
sub update_settings {
my ($r, $settings, $album_dir, $path_info) = @_;
my $current_path = "$album_dir/";
foreach my $next_dir (split(m|/|, $path_info)) {
$current_path .= "$next_dir/";
# check to see if there is an .htaccess file there, if so
# parse it looking for PerlSetVar's that override the defaults/
# httpd.conf files
if ( -f "$current_path/.htaccess") {
if (open (IN,"$current_path/.htaccess")) {
while (<IN>) {
next if /^\s*$/;
next if /^\#/;
if (/^PerlSetVar\s+(\w+)\s+(.*)$/) {
my ($key,$value) = ($1,$2);
$settings->{$key} = $value;
}
}
close IN;
}
else {
$r->log_error("Couldn't open $current_path/.htaccess: $!");
}
}
}
}
sub mymkdir {
my ($dir, $mode) = @_;
my @dir = split('/', $dir);
my $curDir = "";
foreach (@dir) {
next unless $_;
$curDir .= "/$_";
mkdir($curDir, $mode)
unless (-d $curDir);
}
}
1;
__END__
=head1 NAME
Apache::Album - Simple mod_perl Photo Album
both using the same AlbumDir.
=item AllowFinalResize
If this is set to true, the user will have 3 additional options when
viewing the full sized picture. The thumbnail can still be selected
to view the full picture, or Sm (Small), Med (Medium), or Lg(Large)
can be selected to bring the picture down to fit better in a 640x480,
800x600, or 1024x758 screen.
=item ReverseDirs
When viewing albums, they will be sorted by name. If this is set to
true the order will be reversed. (Useful if you want to use things
like dates/months as the directory names, this will put the most
recent albums first.
=item ReversePics
When viewing pictures, they will be sorted by name. If this is set to
true, the order of the pictures will be reversed.
=back
=head1 OTHER FEATURES
For people with lots of bandwidth and memory, Apache::Album can
generate a single page with all the full sized pictures (or all the
Small(sm), Medium(med) or Large(lg) pictures if AllowFinalResize is
turned on). This is enabled by passing
?all_full_images=sm|med|lg|full to the url of an album, for example:
=over 2
C<http://your.web.server/albums/specific_album/?all_full_images=sm>
=back
Will create a page with all the picutres in an album, but none will be
larger than 640x480. The pictures will have captions as if the
pictures were being viewed one at a time.
=head1 LIMITATIONS
PerlMagick is a limiting factor. If PerlMagick can't load the image,
no thumbnail will be created.
=head1 COPYRIGHT
Copyright (c) 1998-2004 Jim Woodgate. All rights reserved. This
program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=head1 AUTHOR
Jim Woodgate woody@realtime.net
=head1 SEE ALSO
perl(1), L<Image::Magick>(3).
=cut
( run in 1.886 second using v1.01-cache-2.11-cpan-75ffa21a3d4 )