File Coverage

blib/lib/Apache2/Archive.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Apache2::Archive;


use strict;
use Archive::Tar;
use Apache2::Log;
use Apache2::Const;
use Apache2::Util ();
use Apache2::Status;
use Apache2::SubRequest ();

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

require Exporter;

@ISA = qw(Exporter AutoLoader);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw(

);
$VERSION = '0.2';


sub handler{
	my $r = shift;
	my $t;
	#$t->{Files};			# Contains info on all the files in the archive
	#$t->{FileInfo};		# contains info on archive file itself
	#$t->{filename};		# Canonical name of the archive file itself
	#$t->{template};		# The template file (one line per array entry)
	#$t->{Tar};				# The Archive::Tar object for the archive
	#$t->{SizeLimit};	# The Maximum tar file size allowed. After opening a file larger
						# that this, the processes will terminate to free memory.
	$t->{Tar} = new Archive::Tar;
	$t->{SizeLimit} = $r->dir_config('SizeLimit');

	##
	# Get the template file for later use
	##

	&getTemplateFile($t,$r->dir_config('Template'));

	##
	# Create the Tar object;
	##


	$t->{filename} = $r->filename;
	unless (-e $t->{filename} && -r $t->{filename}) {
		return Apache2::Const::NOT_FOUND;
	}
	my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks)=stat($t->{filename});

	($t->{FileInfo}->{'name'}) = $t->{filename} =~ m!(([^/\\]|\\\/)+)$!;
	$t->{FileInfo}->{'date'} = &getDatestring($mtime, $r->dir_config('Months'));
	$t->{FileInfo}->{'rawsize'} = -s $t->{filename};
	$t->{FileInfo}->{'size'} = &getSizestring($t->{FileInfo}->{'rawsize'});
	$t->{FileInfo}->{'view_location'} = $r->uri . "/display/" . $t->{FileInfo}->{'name'};
	$t->{FileInfo}->{'compressed'} = 1 if $t->{FileInfo}->{'name'} =~ /\.gz$/;
	if (! $t->{Tar}->read($t->{filename}, $t->{FileInfo}->{'compressed'})){
		&error_response($t,$r);
		return Apache2::Const::SERVER_ERROR;
	}



	@{$t->{Files}} = $t->{Tar}->list_files(['name','mtime','size']);

	&response($t,$r);

	# We check to see if we need to kill ourselves

	if ($t->{SizeLimit} >0 && $t->{FileInfo}->{'rawsize'} > ($t->{SizeLimit} * 1024))
	{
	#	my $log = $r->log();
		if (getppid() > 1) # check we aren't the parent process.
		{
	#		$log->warn("Apache2::Archive is ending this process because SizeLimit reached. Just letting you know.");
			$r->child_terminate;
    	}
    }
	return Apache2::Const::OK;
}

sub response{
	my $t = shift;
	my $r = shift;

	if ($r->path_info =~ m!^/display/!){
		&display($t,$r);
	}
	else{
		&draw_menu($t,$r);
	}
}
##
# This extracts the file specified in the path info and dumps it
# to stdout.
##

sub display {
	my $t = shift;
	my $r = shift;
	my $filename;

	##
	# We need to get both the actual file ($file) and the name without
	# any path ($filename). We use $filename to find out the mime type.
	##

	my $file = $r->path_info;
	($filename) = $file =~ m!/([^/]+)$!;
	$file =~ s!^/display/!!;
	$file =~ s!\*\*!\./!g; # hack because tar components with ./ at the front get mangled in path_info handling

	##
	# This returns the content type. You need to set up a subrequest
	# And then run the (hypothetical) lookup against it.
	##

	my $subr = $r->lookup_uri("/$filename");
	my $ct = $subr->content_type;

	if(! defined $ct){
		$ct = 'text/plain';
	}

	##
	# Create and send the response
	##

	$r->content_type($ct);

	#$r->print("file was $file\n path was", $r->path_info);
	$r->print($t->{Tar}->get_content($file));
}


sub draw_menu {
	my $t = shift;
	my $r = shift;
	my $i = 0;
	my $dataline;
	$r->content_type("text/html");

	###
	## This loops through each line of the template file. When it sees
	## The StartData tag it captures the $dataline out and generates
	## the table. Otherwise, it just prints the line of the template file
	###

	while ($i < @{$t->{template}}){
		if ($t->{template}->[$i] =~ /##\s*StartData/){
			$i++;
			while ($t->{template}->[$i] !~ /##\s*EndData/){
				chomp($t->{template}->[$i]);
				$dataline .= $t->{template}->[$i];
				$i++;
			}
			&draw_data_table($t,$r,$dataline);
		}
		else{
			if ($t->{template}->[$i] =~ /##\w+/){
				$t->{template}->[$i] = do_value_subs($t,$t->{template}->[$i]);
			}
			$r->print($t->{template}->[$i]);
		}
		$i++;
	}


}




##
# This takes a time in seconds (since 1970 ala unix 'time()' cmd), and an
# optional string containing comma seperated month names. It returns
# a more useful indication of time and date. If no month names are specified,
# it defaults to english three letter abbreviations.
##
sub getDatestring{
	my $Seconds = shift;
	my $Months = shift;
	my @Months;
	if ($Months){
		@Months = split(/,/, $Months);
		unless(@Months == 12){	## Make sure they specified 12 months
			@Months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
		}
	}
	else{
		@Months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
	}
	my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($Seconds);

	return("$mday-$Months[$mon]-$year $hour:$min");

}
sub getSizestring{
	my $Bytes = shift;
	my $Kb = int($Bytes/1024) || 1;
	if ($Kb > 1023){
		my $Mb = $Kb/1024;
		## Nasty hack to round to two dp
		$Mb = int($Mb*100)/100;
		return("$Mb Mb");
	}
	else{
		return("$Kb Kb");
	}
}

##
# This gets the template file, or uses its internal one, if there
# is none specified.
##
sub getTemplateFile{

	## TODO options to cache this file (i.e. not re-read each time).
	###
	my $t = shift;

	if (my $file = shift){
		open(IN, "$file") or die $!;
		while(){
			push @{$t->{template}}, $_;
		}
		close IN;
	}
	else{
		@{$t->{template}} = split(/\n/, qq(\n
\n
\n
##ArchiveName\n
\n
##ArchiveDate\n
##ArchiveSize\n
This is the contents of the archive:\n
\n
\n \n \n \n \n \n \n 




245




 





 





 





 





 





 



 




246




 





 





 





 





 





 



 View itemNameDateSize




247




 





 





 





 





 





 



 




248




 





 





 





 





 





 



 ##StartData\n 




249




 





 





 





 





 





 



 




250




 





 





 





 





 





 



 View File##FileName##FileDate##FileSize




251




 





 





 





 





 





 



 




252




 





 





 





 





 





 



 ##EndData\n 




253




 





 





 





 





 





 



 \n 




254




 





 





 





 





 





 



 \n



##StartData\n



##EndData\n
\n

\n
\n
));
	}
	return 1;
}

sub draw_data_table{
	my $t = shift;
	my $r = shift;
	my $dataline = shift;
	my $moddataline;
	my $date_string;
	my $size_string;
	my $name_string;
	my $view_string;
	my $uri = $r->uri;
	foreach (@{$t->{Files}}){
			$moddataline = $dataline;
			$date_string = getDatestring($_->{'mtime'}, $r->dir_config('Months'));
			$size_string = getSizestring($_->{'size'});
			$name_string = $_->{'name'};
			$view_string = $name_string;
			$view_string =~ s!\./!\*\*!g;# prevent path_info mangling if ./
			$view_string = $uri . "/display/" . $view_string;

			if($_->{'name'} =~ /\/$/) {
				$moddataline =~ s/##FileLink/#/gi;
			} else {
				$moddataline =~ s/##FileLink/$view_string/gi;
			}
			$moddataline =~ s/##FileName/$name_string/gi;
			$moddataline =~ s/##FileDate/$date_string/gi;
			$moddataline =~ s/##FileSize/$size_string/gi;

			$moddataline =~ s/##ArchiveDate/$t->{FileInfo}->{'date'}/gi;
			$moddataline =~ s/##ArchiveSize/$t->{FileInfo}->{'size'}/gi;
			$moddataline =~ s/##ArchiveName/$t->{FileInfo}->{'name'}/gi;
			$r->print($moddataline);
	}
}

sub do_value_subs{
	my $t = shift;
	my $line = shift;
	$line =~ s/##ArchiveDate/$t->{FileInfo}->{'date'}/gi;
	$line =~ s/##ArchiveSize/$t->{FileInfo}->{'size'}/gi;
	$line =~ s/##ArchiveName/$t->{FileInfo}->{'name'}/gi;
	$line =~ s/##ArchiveLink/$t->{FileInfo}->{'view_location'}/gi;
	return $line;
}


sub error_response{
	my $t = shift;
	my $r = shift;
	my $Err = shift;
	$r->content_type("text/html");

	$r->print("500 Internal Server Error
				Internal Server ErrorThe archive file requested
				was not a valid file, or was corrupt.");
	Apache2->warn("Requested file ", $t->{filename}, "is unreadable by Apache2::Archive");
	return;

}


1;
__END__