view release on metacpan or  search on metacpan

PAR/Static.pm  view on Meta::CPAN

use 5.005;
use strict;

# for version detection
require mod_perl;

# constants
use vars qw($CACHE_FILE $CACHE_MEMORY $CACHE_SHARED);
$CACHE_FILE           = 'file';
$CACHE_MEMORY = 'memory';
$CACHE_SHARED   = 'shared';

# Exporter
require Exporter;
use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK @EXPORT $VERSION);
@ISA = qw(Exporter);
%EXPORT_TAGS = ( 'all' => [ qw($CACHE_FILE $CACHE_MEMORY $CACHE_SHARED) ] );
@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
@EXPORT = qw( );

$VERSION = '0.30';

unless ($mod_perl::VERSION < 1.99) {
	require Apache::Const;
	import Apache::Const qw(OK NOT_FOUND FORBIDDEN);
	require Apache::Response;
	require Apache::RequestRec;
	require Apache::RequestIO;
	require Apache::RequestUtil;
	require APR::Table;
}
else {
	require Apache::Constants;
	import Apache::Constants qw(OK NOT_FOUND FORBIDDEN);
	require Apache::Log;
	require Apache::File;
}

use MIME::Types ();
use Archive::Zip ();

sub handler {
	my $r = shift;

	my $filename    = $r->filename;

	(my $path_info = $r->path_info) =~ s/^\///;

	my $file_path    = $r->dir_config->get('PARStaticFilesPath') || 'htdocs/';
	$file_path      .= '/' if ($file_path !~ /\/$/);
	$file_path      .= $path_info;

	$file_path =~ s/^\///;


	return NOT_FOUND() unless -r $filename;

	# Use the last modified time of the PAR archive
	# Can cause cache to reload more often than necessary
	# but much faster than opening the archive every time
	my $last_modified = (stat(_))[9];

	# Initialize the cache
	my $cache_obj = _init_cache($r);
	my $contents = _get_cache($r, $filename, $file_path, $last_modified, $cache_obj);

	unless (defined $contents) {
		Archive::Zip::setErrorHandler(sub {});
		my $zip = Archive::Zip->new($filename);
		return NOT_FOUND() unless(defined($zip));

		my $member = $zip->memberNamed($file_path) || $zip->memberNamed("$file_path/");
		return NOT_FOUND() unless(defined($member));

		if($member->isDirectory()) {
			my @index_list = $r->dir_config->get('PARStaticDirectoryIndex');
			unless (@index_list) {
				$r->log_error('Apache::PAR::Static: Cannot serve directory - set PARStaticDirectoryIndex to enable');
				return FORBIDDEN();
			}

			# save $file_path for later
			my $index_path = $file_path;
			$index_path =~ s/\/$//;
			foreach my $index_name (@index_list) {
				if(defined($member = $zip->memberNamed("$index_path/$index_name"))) {
					$index_path .= "/$index_name";
					last;
				}
			}
			if(!defined($member) || $member->isDirectory()) {
				$r->log_error('Apache::PAR::Static: Cannot serve directory - Index file does not exist.');
				return FORBIDDEN();
			}
		}

		$contents = $member->contents;
		return NOT_FOUND() unless defined($contents);

		# This uses the original file name (not index name)
		# Can cause a duplicate cache entry, but avoids
		# having to open the archive each time to see if request
		# is for a directory
		_set_cache($r, $filename, $file_path, $contents, $last_modified, $cache_obj);
	}

	$r->headers_out->set('Accept-Ranges' => 'bytes');

	$r->content_type(MIME::Types::by_suffix($file_path)->[0] || $r->dir_config->get('PARStaticDefaultMIME') || 'text/plain');
	(my $package = __PACKAGE__) =~ s/::/\//g;
	$r->update_mtime($last_modified);
	$r->update_mtime((stat $INC{"$package.pm"})[9]);
	$r->set_last_modified;

	$r->set_content_length(length($contents));


	if((my $status = $r->meets_conditions) eq OK()) {
		$r->send_http_header if ($mod_perl::VERSION < 1.99);
	}
	else {