Apache-Album
view release on metacpan or search on metacpan
. '<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'} =
$r->dir_config('EditMode') || 0;
$settings{'AllowFinalResize'} =
$r->dir_config('AllowFinalResize') || 0;
$settings{'ReverseDirs'} =
$r->dir_config('ReverseDirs') || 0;
$settings{'ReversePics'} =
$r->dir_config('ReversePics') || 0;
# Set up $album_uri and $album_dir, _uri for web access, _dir
# for physical access to the files...
my $album_uri = $settings{'AlbumDir'};
$album_uri .= "/" unless substr($album_uri,-1,1) eq '/';
my $album_dir = $r->lookup_uri($album_uri)->filename;
chop $album_uri; # Won't need that '/' any more
# Set up $thumb_uri and $thumb_dir, _uri for web access, _dir
# for physical access to the files...
my $thumb_uri = $settings{'ThumbDir'};
$thumb_uri .= "/" unless substr($thumb_uri,-1,1) eq '/';
my $thumb_dir = $r->lookup_uri($thumb_uri)->filename;
chop $thumb_uri; # Won't need that '/' any more
# Check and see if there was a post
my %params = ();
%params = parseArgs($r, $r->method eq 'POST' ? $r->content : $r->args);
# foreach (keys %params) {
# $r->server->warn("$_ -> $params{$_}");
# }
if ($settings{'EditMode'}) {
if (defined $params{'AlbumName'}) {
my $directory = $params{AlbumName};
$directory =~ s,[^\w\d()],,g;
# Since the only things that can get through are letters,
# numbers or parenthesis $directory should be safe
if ($directory =~ /([\w\d()]+)/) {
$directory = $1;
}
my $local_path_info = $r->path_info;
if ($directory eq "") {
$r->log_error("Directory empty (or only consists of bad characters)");
}
else {
my $new_dir = "$album_dir$local_path_info$directory";
$new_dir =~ s!/{2,},!/!g;
$r->server->warn("Creating New Album: $new_dir");
mkdir($new_dir, 0755);
}
}
else {
unless ($params{'New Album'}) {
if (my $handle = $r->upload('filename')) {
my $filename = $handle->filename;
my ($type,$ext) = split(/\//,$handle->info("Content-type"));
if ($type eq 'image') {
# on NT $filename has \'s which we don't want!
$filename =~ s,.*\\,,;
$r->server->warn("Uploading: $filename");
my $local_path_info = $r->path_info;
my $fh = $handle->fh;
if(open(OUT,">$album_dir$local_path_info$filename")) {
while(<$fh>) {
print OUT;
}
close OUT;
}
else {
$r->log_error("Problem opening $album_dir$local_path_info$filename for write: $!");
}
}
else {
$r->log_error("Will not allow upload of: $filename $type/$ext");
}
}
}
}
}
my $path_info = $r->path_info;
$path_info =~ s!^/+!!;
$path_info =~ s!/+$!!;
update_settings($r, \%settings, $album_dir, $path_info);
# path_info will be the sub directory/possible file_name
# get rid of any slashes so we can make sure that paths
# look like paths
$path_info || return &show_albums($r, $album_dir, $path_info, \%settings);
# do we have a directory or a filename, if it's a filename
# simply load it up
if ( -f "$album_dir/$path_info" ) {
return &show_picture($r, $album_uri, $thumb_uri, $path_info, \%settings);
}
# if AllowFinalResize is set, it is possible that the filename
# exists, only with a size prefixing it. So pull out that information
# and see if the file still exists
if ($settings{'AllowFinalResize'}) {
my $check_path = $path_info;
my ($check_dir, $check_filename) = $check_path =~ m,(.*)/(.*),;
if ($check_filename =~ s,^(\d+)x(\d+)_,,) {
my ($max_width, $max_height) = ($1, $2);
if (-f "$album_dir/$check_dir/$check_filename") {
# $r->log_error("\$album_uri: $album_uri \$thumb_uri: $thumb_uri");
return &show_picture($r, $album_uri, $thumb_uri,
"$check_dir/$check_filename",
\%settings, $max_width, $max_height);
}
}
}
# 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 =~
if $resize_strings;
}
if (exists $params{'all_full_images'}) {
my $picture = $_;
for ($params{'all_full_images'}) {
/full/ || !$settings{'AllowFinalResize'} and do {
$r->print(qq!<CENTER><IMG SRC="$album_uri/$path_info/$picture" ALT="$picture"></CENTER>!);
last; };
/sm/ and do {
$r->print(qq!<CENTER><IMG SRC="!
. (-f "$thumb_dir/$path_info/640x480_$picture"
? "$thumb_uri/$path_info/640x480_$picture"
: "$album_uri/$path_info/$picture")
. qq!" ALT="$picture"></CENTER>!);
last; };
/med/ and do {
$r->print(qq!<CENTER><IMG SRC="!
. (-f "$thumb_dir/$path_info/800x600_$picture"
? "$thumb_uri/$path_info/800x600_$picture"
: "$album_uri/$path_info/$picture")
. qq!" ALT="$picture"></CENTER>!);
last; };
/lg/ and do {
$r->print(qq!<CENTER><IMG SRC="!
. (-f "$thumb_dir/$path_info/1024x768_$picture"
? "$thumb_uri/$path_info/1024x768_$picture"
: "$album_uri/$path_info/$picture")
. qq!" ALT="$picture"></CENTER>!);
last; };
/xlg/ and do {
$r->print(qq!<CENTER><IMG SRC="!
. (-f "$thumb_dir/$path_info/1600x1200_$picture"
? "$thumb_uri/$path_info/1600x1200_$picture"
: "$album_uri/$path_info/$picture")
. qq!" ALT="$picture"></CENTER>!);
last; };
$r->print(qq!<CENTER><IMG SRC="$album_uri/$path_info/$picture" ALT="$picture"></CENTER>!);
}
$r->print(qq!<HR><CENTER>$message</CENTER><HR>!);
}
else {
$r->print(qq!<TD ALIGN="center"><TABLE BORDER=$settings{'InsideTablesBorder'}><TR><TD ALIGN="center"><A HREF="$_">! .
qq!<IMG SRC="$thumb_uri/$path_info/tn__$_" ALT="$_"></A>$resize_urls</TD></TR>!,
qq!<TR><TD ALIGN="center">$message</TD></TR></TABLE></TD>\n!);
$pixels_so_far += $settings{'ThumbNailWidth'};
$columns_so_far++;
if ($settings{'NumberOfColumns'} > 0
? ($columns_so_far >= $settings{'NumberOfColumns'} )
: ($pixels_so_far > $settings{'DefaultBrowserWidth'})) {
$r->print(qq!</TR><TR>!);
$pixels_so_far = $settings{'ThumbNailWidth'};
$columns_so_far = 0;
}
}
}
$r->print("</TR></TABLE></CENTER>\n");
if ($settings{'EditMode'}) {
$r->print(&file_upload());
}
$r->print("<hr>\n$settings{'Footer'}\n<hr>") if $settings{'Footer'};
$r->print(<<EOF);
</BODY>
</HTML>
EOF
return Apache2::Const::OK;
}
# show_albums simply shows the albums under the directory
# it should probably not be called, a "real" web page with
# links to the albums would probably be better, but this
# helps when debugging, or if someone decides to go to this
# directory directly
sub show_albums {
my ($r, $album_dir, $path_info, $settings) = @_;
unless ($r->uri =~ m|/$|) {
$r->log_error("Redirecting -> " . $r->uri . "/");
$r->headers_out->{Location} = $r->uri . "/";
return Apache2::Const::REDIRECT;
}
unless (opendir(IN,$album_dir)) {
$r->log_error("Could not open $album_dir: $!");
return Apache2::Const::SERVER_ERROR;
}
my @dirs = grep { -d "$album_dir/$_" && ! /^\./ } readdir(IN);
closedir(IN);
$r->content_type('text/html');
#$r->send_http_header();
return Apache2::Const::OK if $r->header_only;
$r->print(<<EOF);
<HTML><HEADER><TITLE>$$settings{AlbumTitle}</TITLE></HEADER>
<BODY $$settings{'BodyArgs'}>
<H3>$$settings{AlbumTitle}</H3>
EOF
$r->print($path_info)
if $path_info;
@dirs = sort @dirs;
@dirs = reverse @dirs
if $settings->{'ReverseDirs'};
foreach (@dirs) {
$r->print("\n<dl>\n");
&list_dirs($r, $album_dir, $_, "", $settings );
$r->print("\n</dl>\n");
}
if ($settings->{'EditMode'}) {
$r->print(qq!<FORM METHOD="POST">New Album:<INPUT TYPE="text" NAME="AlbumName"><INPUT TYPE="submit" NAME="New Album" VALUE="New Album"></FORM>!);
unless (@dirs) {
$r->print(&file_upload());
}
}
$r->print(<<EOF);
<HR>
<address>Apache::Album</address>
</BODY>
</HTML>
EOF
return Apache2::Const::OK;
}
# parseArgs is used to turn the array of arguments
# into a nice hash. This is fairly lame as I'm not
# expecting to get any duplicate values
sub parseArgs {
my $r = shift;
my @args = @_;
my %params = ();
foreach (@args) {
/(.*)=(.*)/;
my ($key,$val) = ($1, $2);
$params{$key} = $val;
}
return %params;
}
# Show picture shows the actual full sized picture,
# I might add some cool things like filters and
# such since we use ImageMagick for the thumbnails
# For now, just show the picture and a caption
sub show_picture {
my ($r, $album_uri, $thumb_uri, $path_info, $settings) = @_[0..4];
my $album_dir = $r->lookup_uri($album_uri)->filename;
my $thumb_dir = $r->lookup_uri($thumb_uri)->filename;
my $caption = $path_info;
my $modified_path_info = "$album_uri/$path_info";
my $start_link = "";
my $end_link = "";
my @slideShow;
my($prevSeven, $nextSeven);
$caption =~ s!.*/!!;
$caption =~ s!\.[^.]*$!!;
$caption =~ tr[-_][ ];
my $title = $caption;
$caption = qq!<H3>$caption</H3>!;
my ($path_dir,$path_file) = $path_info =~ m!(.*)/(.*)!;
if ($settings->{'AllowFinalResize'}) {
my ($max_width, $max_height) = @_[5,6];
my %params = split /=+/, $r->args;
my ($r, $album_dir, $directory, $old_directory, $settings) = @_;
my $text = $directory;
$text =~ tr[-_][ ];
$text =~ s,\d+\((.*)\),$1,;
$r->print(qq!\t<dt><A HREF="$old_directory$directory/">$text</A></dt>\n!);
my @dirs = ();
if (opendir(IN, "$album_dir/$directory")) {
@dirs = grep { -d "$album_dir/$directory/$_"
&& ! /^\./
} readdir(IN);
closedir(IN);
}
else {
$r->log_error("Could not open $album_dir/$directory: $!");
}
@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");
directory, the next time the page is loaded all the thumbnails will be
regenerated. (Naturally image names that start with tn__ should be
renamed before placing them in the album directory.)
=item ThumbDir
URI which points to where the thumbnail hierarchy will live. Note
that in previous versions a thumbs subdirectory would be created.
This made traversal a bit more difficult and always made permission
creating a challenge. By putting all images created by the server in
one place we can easily track diskspace usage and make sure the server
sets up all permissions.
=item DefaultBrowserWidth
A general number of how wide you want the final table to be, not an
absolute number. If the next image would take it past this "invisible
line", a new row is started.
=item NumberOfColumns
Instead of using DefaultBrowserWidth and a guess at the number of
pixels, NumberOfColumns can be set to the maximum number of columns in
a table. The default is 0 (which causes DefaultBrowserWidth to be
used instead).
=item BodyArgs
This entire string is passed in the <BODY> tag. Useful for setting
background images, background color, link colors, etc. If set in the
httpd.conf file, you must put quotes around the value, and escape any
quotes in the value. If this value is set in the .htaccess file, this
is not necessary:
In httpd.conf: PerlSetVar BodyArgs "BACKGROUND=gray.gif text=\"#FFFFFF\""
In .htaccess : PerlSetVar BodyArgs BACKGROUND=gray.gif text="#FFFFFF"
=item OutsideTableBorder
This variable's value is passed to the outer table's BORDER attribute.
=item InsideTablesBorder
This variables's value is passed to all the inner table's BORDER
attributes. Note that the name of the C<InnerTablesBorder> has an 's'
in it, as it modifes all the inner tables.
=item SlideShowDelay
The number of seconds to spend on each picture when viewing a slide
show.
=item Footer
This text/html will placed at the bottom of the page after all the
thumbnails, but before the end of the page. Useful for links back to
a home page, mailto: tag, etc.
=item EditMode
Allows the user to create new albums and upload pictures. Obviously
there are security implications here, so if EditMode is turned on that
location should probably have some kind of security. Albums can share
the same AlbumDir, so you can have something like:
/albums - ReadOnly version, no security
/albums_edit - Allow new album creation and picture uploads,
require authentication
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
( run in 0.984 second using v1.01-cache-2.11-cpan-b16cb0d3907 )