#!/usr/bin/perl -w
# This is a PERL script
# Please call explicitly with /path/to/perl /path/to/interpreter arguments,
# where arguments are:
#   [ -h /path/to/homedir ]
#   [ -n /path/to/nice ]
#   [ -p /path/to/perl ]
#   [ -q /path/to/quota ]
#   [ -ql /path/to/quotaget ]  where quotaget is the binary generated
#                              from ../quota_linux/quotaget.c
#   [ -f /path/to/fstab ]

$| = 1;

$perl = "/usr/bin/perl";
$quota = "/usr/bin/quota";
$quotalinux = '';
$nice = "/usr/bin/nice";
$home = '';
$fstab = '/proc/mounts';

$tmpdir = "/tmp";
$tmpname = $tmpdir . "/" . "interpreter.tmp." . $$ . "." . $<;

while (1) {
	last if (scalar (@ARGV) == 0);
	if (scalar(@ARGV) >= 2 && $ARGV[0] eq '-p') {
		$perl = $ARGV[1];
		shift @ARGV;
		shift @ARGV;
	} elsif (scalar(@ARGV) >= 2 && $ARGV[0] eq '-q') {
		$quota = $ARGV[1];
		shift @ARGV;
		shift @ARGV;
	} elsif (scalar(@ARGV) >= 2 && $ARGV[0] eq '-ql') {
		$quotalinux = $ARGV[1];
		shift @ARGV;
		shift @ARGV;
	} elsif (scalar(@ARGV) >= 2 && $ARGV[0] eq '-h') {
		$home = $ARGV[1];
		shift @ARGV;
		shift @ARGV;
	} elsif (scalar(@ARGV) >= 2 && $ARGV[0] eq '-n') {
		$nice = $ARGV[1];
		shift @ARGV;
		shift @ARGV;
	} elsif (scalar(@ARGV) >= 2 && $ARGV[0] eq '-f') {
		$fstab = $ARGV[1];
		shift @ARGV;
		shift @ARGV;
	} else {
		die "- Interpreter usage error\r\n";
	}
}

print "+ Interpreter OK\r\n";

while (<STDIN>) {
	tr/\r\n//d;
	if (/^\s*quota\s*$/) {
		&do_quota();
	} elsif (/^\s*perlc\s+(\S+)\s*$/) {
		&do_perlc($1);
	} elsif (/^\s*cgi\s+(\S+)(\s.*)?$/) {
		my ($prog, $rest) = ($1, $2);
		$rest =~ s/^\s*//;
		$rest =~ s/\s*$//;
		&do_cgi($prog, $rest);
	} elsif (/^\s*close\s*$/) {
		print "+ OK, Closing connection\r\n";
		exit 0;
	} elsif (/^\s*mkdir\s+(\S+)\s*$/) {
		my $path = $1;
		&do_mkdir($path);
	} else {
		print "- Command error\r\n";
		exit 1;
	}
}
exit 0;

sub do_quota {
	if ($quotalinux ne '') {
		&do_quota_linux();
	} else {
		&do_quota_portab();
	}
}

sub ql {
	my ($device) = @_;
	$device =~ s/\'/\'\\\'\'/g;
	$device = "\'" . $device . "\'";
	if (open (IN, "$quotalinux $device 2>&1 |")) {
		my ($read) = <IN>;
		close (IN);
		$read =~ tr/\r\n//d;
		return (($?, $read));
	}
	return (undef);
}

sub do_quota_linux {
	my (@devices);
	if (open (IN, "< /proc/mounts")) {
		while (<IN>) {
			if (/^(\S+)\s*(\S+)\s*(\S+)\s*(\S+)/) {
				my ($dev, $mnt, $fstyp, $opt) = ($1,$2,$3,$4);
				my (@opts);
				# skip tmp FS
				next if $mnt =~ /tmp/;
				@opts = split(/,/, $opt);
				# local filesystems
				if ( (0 != (grep {/^(usrquota|usrjquota)=?.*$/} @opts)) ) { #  && ( $dev =~ "^\/\S+")
					push @devices, $dev unless grep "$dev", @devices;
				}
				# NFSv4 filesystems
				if ( ($fstyp eq "nfs4") && ($mnt =~ "homepages") ) {
				  push @devices, $mnt;
				}
			}
		}
		close (IN);
	} else {
		print "- Can\'t open fstab file\r\n";
		return;
	}
	my ($dev);
	my ($blkcur, $blklim, $filcur, $fillim);
	$blkcur = 0;
	$blklim = 0;
	$filcur = 0;
	$fillim = 0;
	for $dev (@devices) {
		my ($status, $result) = &ql($dev);
		if ( (($status&255) != 0) && (($status&255) != 1) ) { # return code 1 if over quota
			print "- quota_linux error: ", $result, "\r\n";
			return;
		}
		if ($result =~
		    /^(\d+):(\d+):(\d+):(\d+):(\d+):(\d+):-?\d+:-?\d+$/) {
			my ($bh, $bs, $bc, $ih, $is, $ic) =
			    ($1, $2, $3, $4, $5, $6);
			if ($bh != $bs || $ih != $is) {
				print "- quota_linux output error\r\n";
				return;
			}
			$blkcur += $bc;
			$blklim += $bh;
			$filcur += $ic;
			$fillim += $ih;
		} else {
			print "- quota_linux output error: $result \r\n";
			return;
		}
	}
	print "+ $blkcur:$blklim:$filcur:$fillim\r\n";
}

sub do_quota_portab {
	if (open (IN, "$quota -v 2>&1 |")) {
		my (@spl, $found);
		my ($bv, $bq, $fv, $fq);
		$found = 0;
		while (<IN>) {
			tr/\r\n//d;
			s/^\s*//;
			@spl = split(/\s+/);
			if (scalar (@spl) >= 7 && ($spl[0] =~ /^\//)) {
				shift @spl;
				$bv = 0 + (shift @spl);
				$bq = 0 + (shift @spl);
				my ($bq_tmp);
				$bq_tmp = 0 + (shift @spl);
				if ($spl[0] =~ /^[A-Za-z]+$/) {
					shift @spl;
				}
				if (scalar (@spl) < 3 || $bq != $bq_tmp) {
					close(IN);
					print "- quota output error\r\n";
					return;
				}
				$fv = 0 + (shift @spl);
				$fq = 0 + (shift @spl);
				my ($fq_tmp);
				$fq_tmp = 0 + (shift @spl);
				if ($fq_tmp != $fq) {
					close(IN);
					print "- quota output error\r\n";
					return;
				}
				$found++;
			}
		}
		close(IN);
		if ($found == 1) {
			print "+ $bv:$bq:$fv:$fq\r\n";
		} elsif ($found == 0) {
			print "- No quota records found\r\n";
		} else {
			print "- Too many quota records\r\n";
		}
		# parse output
	} else {
		print "- Executing command failed\r\n";
	}
}

sub do_mkdir {
	my ($path) = @_;
	$path = &my_unescape($path);
	$path =~ s/^\/*//;
	$path = '/' . $path;
	my ($givenpath) = $path;
	$path = $home . $path;
	if ($givenpath =~ /\/\.\.\// || $givenpath =~ /\/\.\.$/) {
		print "- mkdir: No dot-dot reference allowed\r\n";
	} elsif ($givenpath =~ /\/\.\// || $givenpath =~ /\/\.$/) {
		print "- mkdir: No dot reference allowed\r\n";
	} elsif (-e $path) {
		print "- mkdir: Exists\r\n";
	} else {
		if (mkdir ($path, 0755)) {
			print "+ mkdir: OK\r\n";
		} else {
			print "- mkdir: failed: $!\r\n";
		}
	}
}

sub correct_perl {
	my ($path) = @_;
	unless (open (TMPIN, "< $path")) {
		return 0;
	}
	my ($line);
	$line = <TMPIN>;
	my ($ok);
	$ok = 0;
	if ($line) {
		$line =~ tr/\r\n//d;
		if ($line =~ /^\#\![ \t]*([^ \t]+)[ \t]*(([^ \t].*)?)$/) {
			if ($1 eq $perl && $2 eq '') {
				$ok = 1;
			}
		}
	}
	close TMPIN;
	return ($ok);
}

sub do_perlc {
	my ($path) = @_;
	$path =~ s/^\/*//;
	$path = '/' . $path;
	my ($givenpath) = $path;
	$path = $home . $path;
	if ($givenpath =~ /\/\.\.\// || $givenpath =~ /\/\.\.$/) {
		print "- cgi: No dot-dot reference allowed\r\n";
		print "- (no output)\r\n";
	} elsif ($givenpath =~ /\/\.\// || $givenpath =~ /\/\.$/) {
		print "- cgi: No dot reference allowed\r\n";
		print "- (no output)\r\n";
	} elsif (! (-f $path && ! -u $path && ! -g $path && -r $path)) {
		print "- cgi: File not present or has invalid modes\r\n";
		print "- (no output)\r\n";
	} elsif (! -x $path) {
		print "- cgi: File not executable (use chmod +x)\r\n";
		print "- (no output)\r\n";
	} elsif (! -r $path) {
		print "- cgi: File not readable (use chmod +r)\r\n";
		print "- (no output)\r\n";
	} elsif (! &correct_perl($path)) {
		print "- cgi: File has no correct script header (should be #! $perl)\r\n";
		print "- (no output)\r\n";
	} else {
		$path =~ s/\'/\'\\\'\'/g;
		$path = "\'" . $path . "\'";
		system ("$perl -c $path >$tmpname.out 2>$tmpname.err");
		if ($? != 0) {
			print "- ", ($? >> 8) , " perl returned nonzero status\r\n";
			&out('-');
		} else {
			print "+ Check succeeded\r\n";
			&out('+');
		}
	}
}

sub do_cgi {
	my ($path, $query) = @_;
	$path =~ s/^\/*//;
	$path = '/' . $path;
	my ($givenpath) = $path;
	$path = $home . $path;
	if ($givenpath =~ /\/\.\.\// || $givenpath =~ /\/\.\.$/) {
		print "- cgi: No dot-dot reference allowed\r\n";
		print "- (no output)\r\n";
	} elsif ($givenpath =~ /\/\.\// || $givenpath =~ /\/\.$/) {
		print "- cgi: No dot reference allowed\r\n";
		print "- (no output)\r\n";
	} elsif (! (-f $path && ! -u $path && ! -g $path && -r $path)) {
		print "- cgi: File not present or has invalid modes\r\n";
		print "- (no output)\r\n";
	} else {
		$ENV{'SERVER_SOFTWARE'} = 'interpreter/4.7.1.1';
		$ENV{'SERVER_NAME'} = '127.0.0.1';
		$ENV{'GATEWAY_INTERFACE'} = 'CGI/1.1';
		$ENV{'SERVER_PROTOCOL'} = 'HTTP/1.0';
		$ENV{'SERVER_PORT'} = '80';
		$ENV{'REQUEST_METHOD'} = 'GET';
		$ENV{'QUERY_STRING'} = $query;
		$ENV{'SCRIPT_NAME'} = $path;
		$ENV{'REMOTE_ADDR'} = '127.0.0.1';
		if ($home ne '') {
			$ENV{'DOCUMENT_ROOT'} = $home;
		}
		$ENV{'SCRIPT_FILENAME'} = $home . $path;
		# XXX env?!
		# XXX $ENV{'PATH'}
		my ($dir);
		$dir = $path;
		if ($dir =~ /^(.*)\/[^\/]+$/) {
			$dir = $1;
		}
		$path =~ s/\'/\'\\\'\'/g;
		$path = "\'" . $path . "\'";
		my ($arg);
		$arg = '';
		if (($query ne '') && ($query !~ /=/)) {
			$arg = $query;
			$arg =~ s/\'/\'\\\'\'/g;
			$arg = "\'" . $arg . "\'";
		}
		system("( cd $dir && $nice -n 19 $path $arg ) > $tmpname.out 2> $tmpname.err");
		if ($? != 0) {
			print "- ", ($? >> 8) ,
			    " CGI returned nonzero status\r\n";
			&out('-');
		} else {
			print "+ CGI Check succeeded\r\n";
			&out('+');
		}
	}
}

sub out {
	my ($finalchar) = @_;
	my ($outok, $errok) = (1, 1);
	if (open(IN, "< $tmpname.out")) {
		while (<IN>) {
			tr/\r\n//d;
			print "o ", $_, "\r\n";
		}
		close (IN);
		$outok = 1;
	} else {
		$outok = 0;
	}
	if (open(IN, "< $tmpname.err")) {
		while (<IN>) {
			tr/\r\n//d;
			print "e ", $_, "\r\n";
		}
		close(IN);
		$errok = 1;
	} else {
		$errok = 0;
	}
	print $finalchar, " ";
	print ($outok ? "STDOUT OK" : "STDOUT FAILED");
	print " ";
	print ($errok ? "STDERR OK" : "STDERR FAILED");
	print "\r\n";
	unlink("$tmpname.out");
	unlink("$tmpname.err");
}

sub my_unescape {
	my $str = shift;
	return '' if ($str eq '%');
	$str =~ s/\+/\%20/g;
	$str =~ s/\%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/ge;
	return ($str);
}