view release on metacpan or  search on metacpan

PAR.pm  view on Meta::CPAN

package Apache::PAR;

use constant DEBUG => 0;

use 5.005;
use strict;

require mod_perl; # For version detection

# Since we don't use exporter, only export what we need
use vars qw($VERSION %PARFILE_LIST %MTIME_LIST %UNPACK_LIST);

$VERSION = '0.30';

unless ($mod_perl::VERSION < 1.99) {
	require Apache::ServerUtil;
	require APR::Table;

}
else {
	require Apache;
	require Apache::Server;
}

use Archive::Zip qw( AZ_OK );
Archive::Zip::setErrorHandler(sub {});

my @pardir      = Apache->server->dir_config->get('PARDir');
my @parfiles    = Apache->server->dir_config->get('PARFile');
my @parloc      = Apache->server->dir_config->get('PARInclude');

sub handler {
	my $r = shift;
	foreach (keys(%MTIME_LIST)) {
		my $mtime = (stat($_))[9];
		if($mtime > $MTIME_LIST{$_}) {
			PAR::reload_libs($_);
			if($UNPACK_LIST{$_}) {
				unpack_par(undef, $_, Apache->server->dir_config->get('PARTempDir'))
			}
			$MTIME_LIST{$_} = $mtime;
		}
	}
	
	return 1;
}

sub import {
	my $class = shift;
	my @parentries = @_;
	my $parext    = Apache->server->dir_config('PARExt') || 'par';
	my $conf_file = Apache->server->dir_config('PARConf') || 'web.conf';

	my %parlist = ();
	foreach my $parentry (@parentries) {
		$parentry = Apache->server_root_relative($parentry);
		$parentry =~ s/\/$//;
		if(!(-e $parentry)) {
			print STDERR "PAR: No such file or directory: $parentry\n";
			next;
		}
		if(-f _) {
			$parlist{$parentry} = 1;
		}
		elsif(-d _) {
			opendir(DIR, $parentry);
			my @files = readdir(DIR);
			closedir(DIR);
			foreach my $file (@files) {
				next if($file !~ /\.$parext$/);
				next if(!-f "$parentry/$file");
				$parlist{"$parentry/$file"} = 1;
			}
		}
		else {
			print STDERR "PAR: Bad file type: $parentry\n";
		}
	}
	my @pars = keys(%parlist);
	eval 'require PAR; import PAR (@pars,keys(%PARFILE_LIST));';
	die "Could not load PAR, $@\n" if $@;


	foreach my $file (@pars) {
		my $zip = Archive::Zip->new;
		my $rv  = $zip->read($file);
		unless($rv == AZ_OK && defined($zip)) {
			print STDERR "$file does not seem to be a valid PAR (Zip) file. Skipping.\n";
			next;
		}
		
		my $mtime = (stat $file)[9];
		$MTIME_LIST{$file} = $mtime;
		
		my $conf_member = $zip->memberNamed($conf_file);

PAR.pm  view on Meta::CPAN

			$err = Apache->server->add_config([split /\n/, $conf]);
		} else
		{
			Apache->httpd_conf($conf);
		}
		die $err if $err;
	}

	map {$PARFILE_LIST{$_} = 1;} @pars;

}

sub unpack_par {
	my $class = shift;
	my($par, $tmpdir) = @_;

	require File::Spec;
	require File::Path;
	require Digest::MD5;

	warn "[PAR] unpacking '$par'\n" if DEBUG;
	my $zip = Archive::Zip->new;
	my $rv = $zip->read($par);
	unless($rv == AZ_OK) {
		 print STDERR "Unable to read ZIP file '$par': error code $rv";
		 return undef;
	}

	$tmpdir ||= File::Spec->tmpdir;
	unless($tmpdir) {
		 print STDERR "no temp directory specified";
		 return undef;
	}
	
	unless(-d $tmpdir) {
		 print STDERR "temp dir '$tmpdir' does not exist or is not a directory";
		 return undef;
	}

	my $tmppar = File::Spec->catdir($tmpdir, 'par', (File::Spec->splitpath($par))[1,2]);
	# Instead of using full path, this will append MD5
	# my $fh;
	# unless(open $fh, '<', $par) {
	# 	 print STDERR "unable to read '$par': $!";
	# 	 return undef;
	# }
	# binmode($fh);
	# my $md5    = Digest::MD5->new->addfile($fh)->hexdigest;
	# my $tmppar = File::Spec->catdir($tmpdir, 'par', $md5);
	# close($fh);

	warn "[PAR] unpack dir is '$tmppar'\n" if DEBUG;

    # mtime check for if MD5 approach isn't used
	if (-d $tmppar) {
		if (DEBUG) {
			warn "[PAR] archive has been unpacked previously\n";
			warn "[PAR] directory age: ", -M $tmppar, "\n";
			warn "[PAR] archive age: ", -M $par, "\n";
		}
		return $tmppar if (stat($tmppar))[9] > (stat($par))[9];
		warn "[PAR] removing old unpack dir '$tmppar'" if DEBUG;
		File::Path::rmtree $tmppar;
	}
 
	# XXX Add signature check here

	# unpack the files
	foreach my $member ($zip->members) {
		# $member->fileName is always in Unix format
		# See also Archive::Zip::_asLocalName()
		my $file = File::Spec->catfile($tmppar, split('/', $member->fileName));
		warn "[PAR] extracting '$file'\n" if DEBUG;
		my $rv = $member->extractToFileNamed($file);
		unless($rv == AZ_OK) {
			 print STDERR "Error extracting '$file' from '$par': error code: $rv";
			 return undef;
		}
		if ($member->fileAttributeFormat == 3) { # unix permissions
			my $perms = $member->unixFileAttributes & 0xFFF;
			unless(chmod $perms, $file) {
				 print STDERR "chmod $perms, $file failed: $!";
				 return undef;
			}
		}
	}

	return $tmppar;
}

import(__PACKAGE__,@pardir,@parfiles,@parloc);

1;
__END__

=head1 NAME

Apache::PAR - Perl extension for including Perl ARchive files in a mod_perl (1.x or 2.x) 
environment.

=head1 SYNOPSIS

  Inside Apache configuration:
    PerlSetVar PARInclude /path/to/par/archive/directory
    ...
    PerlAddVar PARInclude /path/to/a/par/file.par
    ...
    PerlModule Apache::PAR

  In Apache/mod_perl 1.x environments on Win32 platforms, the following 
  should be used instead:
  
    PerlSetVar PARInclude /path/to/par/archive/directory
    ...
    PerlSetVar PARInclude /path/to/a/par/file.par
    ...
    <PERL>
    use Apache::PAR;
    </PERL>