view release on metacpan or  search on metacpan

lib/Apache/RandomImage.pm  view on Meta::CPAN

sub handler {
    my $r = shift;
    my $uri = $r->uri();
    $uri =~ s|[^/]+$||x;

    my $dir = $r->document_root() . $uri;

    my $dh = DirHandle->new($dir);
    if (not $dh) {
        $r->log_error("Cannot open directory $dir: $!");
        return NOT_FOUND;
    }

    my @suffixes = split('\s+',$r->dir_config("Suffixes"));
    return DECLINED unless scalar @suffixes;

    my @images;
    foreach my $file ( $dh->read() ) {
        next unless grep { $file =~ /\.$_$/xi } @suffixes;
        push (@images, $file);
    }

    return NOT_FOUND unless scalar @images;

    my $image = $images[rand @images];
    $r->internal_redirect_handler("$uri/$image");

    return OK;
}

=head1 Imported constants

=head2 OK

See Apache::Constants or Apache2::Const documentation

=head2 DECLINED

See Apache::Constants or Apache2::Const documentation

=head2 NOT_FOUND

See Apache::Constants or Apache2::Const documentation

=head1 SEE ALSO

=over 4

=item L<mod_perl>

=item L<Apache::RandomLocation>

=back

=head1 AUTHOR

Michael Kroell, C<< <pepl at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-locale-maketext-extract-plugin-xsl at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Locale-Maketext-Extract-Plugin-XSL>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.


=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Apache::RandomImage


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Apache-RandomImage>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Apache-RandomImage>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Apache-RandomImage>

=item * Search CPAN

L<http://search.cpan.org/dist/Apache-RandomImage>

=back


=head1 ACKNOWLEDGEMENTS

Apache::RandomImage was inspired by L<Apache::RandomLocation>

=head1 COPYRIGHT

Copyright 2003-2009 Michael Kroell, all rights reserved.

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.


=cut

1; # End of Apache::RandomImage