view release on metacpan or  search on metacpan

PrettyPerl.pm  view on Meta::CPAN

package Apache::PrettyPerl;

use strict;
use warnings;
use vars qw/$VERSION/;

use Apache::Const qw/:common/;
use Apache::RequestRec;
use Apache::RequestIO;
use Apache::RequestUtil;
use Apache::Response;
use File::Basename qw/basename/;

$VERSION = '2.10';

# You can set colors here. Use HTML color names or codes
# (like #ff0000 being red).
our %Colors =
(
	foreground	=> 'silver',
	background	=> 'black',
	links		=> 'white',
	
	comment	=> 'navy',
	escaped	=> 'purple',
	keyword	=> 'yellow',
	number	=> 'red',
	pod	=> 'navy',
	regex	=> 'red',
	string	=> 'red',
	variable=> 'aqua'
);

our @KeyWords =
qw(
	while until for foreach unless if elsif else do
	package use no require import and or eq ne cmp
	abs accept alarm atan2 bind binmode bless
	caller chdir chmod chomp chop chown chr
	chroot close closedir connect continue cos
	crypt dbmclose dbmopen defined delete die
	dump each endgrent endhostent endnetent
	endprotoent endpwent endservent eof eval 
	exec exists exit exp fcntl fileno flock
	fork format formline getc getgrent getgrgid
	getgrnam gethostbyaddr gethostbyname gethostent
	getlogin getnetbyaddr getnetbyname getnetent
	getpeername getpgrp getppid getpriority
	getprotobyname getprotobynumber getprotoent
	getpwent getpwnam getpwuid getservbyname
	getservbyport getservent getsockname
	getsockopt glob gmtime goto grep hex index
	int ioctl join keys kill last lc lcfirst
	length link listen local localtime log
	lstat map map mkdir msgctl msgget msgrcv
	msgsnd my next oct open opendir ord our pack
	pipe pop pos print printf prototype push
	quotemeta rand read readdir readline
	readlink readpipe recv redo ref rename
	reset return reverse rewinddir rindex
	rmdir scalar seek seekdir select semctl
	semget semop send setgrent sethostent
	setnetent setpgrp setpriority setprotoent
	setpwent setservent setsockopt shift shmctl 
	shmget shmread shmwrite shutdown sin sleep
	socket socketpair sort splice split sprintf
	sqrt srand stat study sub substr symlink
	syscall sysopen sysread sysread sysseek
	system syswrite tell telldir tie tied
	time times truncate uc ucfirst umask undef
	unlink unpack unshift untie utime values
	vec wait waitpid wantarray warn write
);

our @Buffer = ();
our $BufferFill = 0;
our $alrm = chr (7);
our $Tabsize = 8;

sub handler
{
	my $req = shift;
	my $filename = $req->filename ();
	my $dl = 0;
	my $dl_ok = 0;
	my $data;
	my $mtime;

	if (!-e $filename)
	{
		return (NOT_FOUND);
	}

	if (!-r $filename)
	{
		return (FORBIDDEN);
	}

	$mtime = (stat ($filename))[9] or return (SERVER_ERROR);

	if ($req->dir_config ('AllowDownload'))
	{
		my $conf = lc ($req->dir_config ('AllowDownload'));

		if (($conf eq 'on') or ($conf eq 'true')
				or ($conf eq 'yes'))
		{
			$dl_ok = 1;
		}
	}

	if ($req->args ())
	{
		my %args = $req->args ();

		if (exists ($args{'download'})
				and ($dl_ok))
		{
			$req->content_type ("text/perl-script");