#!/usr/local/bin/perl
# Change Dumpxs to Dump for Irix
# Remove: ->Purity(1)->Indent(0) for WinNT
use lib '.';
use strict;
use CGI;
use SafeCall;
use Data::Dumper;
use Data::Undumper; # Undumps using the Safe module
my($cgi) = new CGI;
if ($cgi->param('library_path') =~ 'upload:') {
upload($cgi);
} else {
perlcall($cgi);
}
exit;
sub authenticate {
my($user) = shift;
my($inpwd) = shift;
my($pwdfile) = '.rcgipwd';
my($result) = 0;
if (-e $pwdfile && -r $pwdfile &&
$user !~ /^\s*$/ && $inpwd !~ /^\s*$/) {
open(PASSWD,"$pwdfile");
while(<PASSWD>) {
chomp;
my($puser,$ppwd) = split(':');
if ($puser eq $user) {
my($salt) = substr($ppwd,0,2);
my($pwd) = crypt($inpwd,$salt);
$result = ($pwd eq $ppwd) ? 1 : 0;
}
}
close(PASSWD);
}
return $result;
}
sub upload {
my($cgi) = shift;
my($module) = $cgi->param('module');
my($arguments) = $cgi->param('arguments');
my($contents,$username,$password) = Data::Undumper::Undump($arguments);
if (defined($cgi->remote_user) ||
authenticate($username,$password)) {
$module =~ s/\:\:/\//g;
# Handle subdirectories that need creating.
mkdir_p($module);
if (open(FILE,"> $module.pm")) {
print FILE $contents;
close(FILE);
my($result) = 'OK';
print $cgi->header(-type => 'perl/call',
-status => '200 OK');
print Data::Dumper->new([ \$result ])->Purity(1)->Indent(0)->Dumpxs,
"\n";
} else {
print $cgi->header(-type => 'perl/call',
-status => "230 Unable to open: $module.pm");
}
} else {
print $cgi->header(-type => 'perl/call',
-status => '220 Unauthenticated connection');
}
}
sub mkdir_p {
my($filepath) = shift;
my(@directory) = split('/',$filepath);
pop(@directory); # pop off the filename
my($path) = shift(@directory);
if (!-e $path) {
mkdir($path,0770);
}
map {
$path .= '/' . $_;
if (!-e $path) {
mkdir($path,0770);
}
} @directory;
return $path;
}
sub perlcall {
my($cgi) = shift;
my($library_path) = $cgi->param('library_path');
my($module) = $cgi->param('module');
my($subroutine) = $cgi->param('subroutine');
my($arguments) = $cgi->param('arguments');
my($wantarray) = $cgi->param('wantarray');
my(@result); # array result
my($result); # scalar result
my($result_ref); # reference of result
my($status); # SafeCall::Execute return status
my($string);
if (defined($module) && defined($subroutine) && defined($arguments) &&
defined($wantarray)) {
if ($wantarray) {
@result = SafeCall::Execute($library_path,$module,$subroutine,\$status,
Data::Undumper::Undump($arguments));
if (!$status) {
$result_ref = \@result;
}
} else {
$result = SafeCall::Execute($library_path,$module,$subroutine,\$status,
Data::Undumper::Undump($arguments));
if (!$status) {
$result_ref = \$result;
}
}
if ($status) {
print $cgi->header(-type => 'perl/call',
-status => 200 - $status . ' SafeCall Failed');
} else {
print $cgi->header(-type => 'perl/call',
-status => '200 OK');
print Data::Dumper->new([ $result_ref ])->Purity(1)->Indent(0)->Dumpxs,
"\n";
}
} else {
map {
if (!defined($cgi->param($_))) {
$string .= ' '.$_;
}
}
( 'module', 'subroutine', 'arguments', 'wantarray' );
print $cgi->header(-type => 'perl/call',
-status => '210 Missing Arguments:'.$string);
}
}