version 1.2, 2009/04/18 13:18:58
|
version 1.12, 2024/06/21 23:42:49
|
Line 33 use IO::Socket;
|
Line 33 use IO::Socket;
|
use Apache::lonnet; |
use Apache::lonnet; |
use Apache::response(); |
use Apache::response(); |
use LONCAPA; |
use LONCAPA; |
|
use Tie::IxHash::Easy; # autoties all subhashes to keep index order |
|
use Data::Dumper; # used to output hash contents |
|
|
|
my $errormsg=''; |
|
|
|
# |
|
# Rcroak: for use with R-error messages |
|
# |
|
sub Rcroak { |
|
$errormsg=$_[0]; |
|
} |
|
|
|
# |
|
# |
|
# Rpeel takes a string containing serialized values from R, |
|
# peels off the first syntactically complete unit (number, string or array), |
|
# and returns a list (first unit, remainder). |
|
# |
|
sub Rpeel { |
|
my $x = $_[0]; # the string containing the serialized R object(s) |
|
if ($x =~ /^N\;(.*)$/) { |
|
return ('',$1); |
|
} elsif ($x =~ /^((?:i|d):(.+?);)(.*)$/) { |
|
return ($1, $+); # x starts with a number |
|
} elsif ($x =~ /^s:(\d+):/) { |
|
my $n = $1; # x starts with a string of length n |
|
if ($x =~ /^(s:\d+:\"(.{$n})\";)(.*)$/) { |
|
return ($1, $+); # x starts with a valid string |
|
} else { |
|
&Rcroak('invalid string detected'); |
|
} |
|
} elsif ($x =~ /^a:/) { |
|
# x starts with an array -- need to find the closing brace |
|
my $i = index $x, '{', 0; # position of first opening brace |
|
if ($i < 0) { |
|
&Rcroak('array with no opening brace'); |
|
} |
|
my $open = 1; # counts open braces |
|
my $j = index $x, '}', $i; # position of first closing brace |
|
$i = index $x, '{', $i + 1; # position of next opening brace (if any) |
|
my $pos = -1; # position of final closing brace |
|
do { |
|
if (($i < $j) && ($i > 0)) { |
|
# encounter another opening brace before next closing brace |
|
$open++; |
|
$i = index $x, '{', $i + 1; # find the next opening brace |
|
} elsif ($j > 0) { |
|
# next brace encountered is a closing brace |
|
$open--; |
|
$pos = $j; |
|
$j = index $x, '}', $j + 1; |
|
} else { |
|
&Rcroak('unmatched left brace'); |
|
} |
|
} until ($open eq 0); |
|
# array runs from start to $pos |
|
my $a = substr $x, 0, $pos + 1; # array |
|
my $b = substr $x, $pos + 1; # remainder |
|
return ($a, $b); |
|
} else { |
|
&Rcroak('unrecognized R value'); |
|
} |
|
} |
|
# --- end Rpeel --- |
|
|
|
# |
|
# Rreturn accepts a string containing a serialized R object |
|
# and returns either the object's value (if it is scalar) or a reference |
|
# to a hash containing the contents of the object. Any null keys in the hash |
|
# are replaced by 'resultNNN' where NNN is the index of the entry in the original |
|
# R array. |
|
# |
|
sub Rreturn { |
|
my $x = $_[0]; # the string containing the serialized R object(s) |
|
$x=~s/^\"//; |
|
$x=~s/\"$//; |
|
$x=~s/\\\"/\"/g; |
|
$errormsg=''; |
|
if ($x =~ /^(?:i|d):(.+?);$/) { |
|
return $1; # return the value of the number |
|
} elsif ($x =~ /^s:(\d+):\"(.*)\";$/) { |
|
# string -- verify the length |
|
if (length($2) eq $1) { |
|
return $2; # return the string |
|
} else { |
|
return 'mismatch in string length'; |
|
} |
|
} elsif ($x =~ /^a:(\d+):\{(.*)\}$/) { |
|
# array |
|
my $dim = $1; # array size |
|
$x = $2; # array contents |
|
tie(my %h,'Tie::IxHash::Easy'); # start a hash |
|
keys(%h) = $dim; # allocate space for the hash |
|
my $key; |
|
my $y; |
|
for (my $i = 0; $i < $dim; $i++) { |
|
($y, $x) = &Rpeel($x); # strip off the entry for the key |
|
if ($y eq '') { |
|
&Rcroak('ran out of keys'); |
|
} |
|
$key = &Rreturn($y); |
|
if ($key eq '') { |
|
$key = "result$i"; # correct null key |
|
} |
|
($y, $x) = &Rpeel($x); # strip off the value |
|
if ($y eq '') { |
|
&Rcroak('ran out of values'); |
|
} |
|
if ($y =~ /^a:/) { |
|
$h{$key} = \&Rreturn($y); # array value: store as reference |
|
} else { |
|
$h{$key} = &Rreturn($y); # scalar value: store the entry in the hash |
|
} |
|
} |
|
if ($errormsg) { return $errormsg; } |
|
return \%h; # return a reference to the hash |
|
} elsif ($x eq '') { |
|
return ''; |
|
} else { |
|
return 'Unrecognized output'; |
|
} |
|
} |
|
# --- end Rreturn --- |
|
|
|
sub Rentry { |
|
my $hash = shift; # pointer to tied hash |
|
my $i; |
|
if (ref($hash) ne 'HASH') { |
|
return 'Argument to cas_hashref_entry is not a hash!'; |
|
} |
|
while ($i = shift) { |
|
if (exists($hash->{$i})) { |
|
$hash = $hash->{$i}; |
|
} else { |
|
return undef; |
|
} |
|
if (ref($hash) eq 'REF') { |
|
$hash = $$hash; # dereference one layer |
|
} elsif (ref($hash) ne 'HASH') { |
|
return $hash; # drilled down to a scalar |
|
} |
|
} |
|
} |
|
|
|
sub Rarray { |
|
my $hash = shift; # pointer to tied hash |
|
my $i; |
|
if (ref($hash) ne 'HASH') { |
|
return 'Argument to cas_hashref_array is not a hash!'; |
|
} |
|
while ($i = shift) { |
|
if (exists($hash->{$i})) { |
|
$hash = $hash->{$i}; |
|
} else { |
|
return undef; |
|
} |
|
if (ref($hash) eq 'REF') { |
|
$hash = $$hash; # dereference one layer |
|
} |
|
} |
|
my @returnarray=(); |
|
foreach my $key (keys(%{$hash})) { |
|
$returnarray[$key-1]=$$hash{$key}; |
|
} |
|
return @returnarray; |
|
} |
|
|
sub connect { |
sub connect { |
return IO::Socket::UNIX->new(Peer => $Apache::lonnet::perlvar{'lonSockDir'}.'/rsock', |
return IO::Socket::UNIX->new(Peer => $Apache::lonnet::perlvar{'lonSockDir'}.'/rsock', |
Line 61 sub rreply {
|
Line 227 sub rreply {
|
sub blacklisted { |
sub blacklisted { |
my ($cmd)=@_; |
my ($cmd)=@_; |
foreach my $forbidden ( |
foreach my $forbidden ( |
'read\.table','scan','plot','X11','windows','quartz', |
'read','write','scan','save','socket','connections', |
|
'open','close', |
|
'plot','X11','windows','quartz', |
'postscript','pdf','png','jpeg', |
'postscript','pdf','png','jpeg', |
'dev\.list','dev\.next','dev\.prev','dev\.set', |
'dev\.list','dev\.next','dev\.prev','dev\.set', |
'dev\.off','dev\.copy','dev\.print','graphics\.off', |
'dev\.off','dev\.copy','dev\.print','graphics', |
'library','package','source','sink','objects' |
'library','package','source','sink','objects', |
|
'Sys\.','unlink','file\.','on\.exit','error', |
|
'q\(\)' |
) { |
) { |
if ($cmd=~/$forbidden/s) { return 1; } |
if ($cmd=~/$forbidden/s) { return 1; } |
} |
} |
Line 73 sub blacklisted {
|
Line 243 sub blacklisted {
|
} |
} |
|
|
sub r_allowed_libraries { |
sub r_allowed_libraries { |
return ('boot','class','cluster','datasets','KernSmooth','MASS', |
return ('alr3','boot','car','class','cluster','datasets','FactoMineR','Hmisc','KernSmooth','leaps', |
'methods','mgcv','nlme','nnet','rpart','spatial', |
'lmtest','MASS','mdatools','methods','mgcv','nlme','nnet','qAnalyst','quadprog','rpart', |
'splines','stats','stats4','survival'); |
'SuppDists','spatial','splines','stats','stats4','survival','tseries','zoo'); |
} |
} |
|
|
sub r_is_allowed_library { |
sub r_is_allowed_library { |
Line 89 sub r_is_allowed_library {
|
Line 259 sub r_is_allowed_library {
|
sub runscript { |
sub runscript { |
my ($socket,$fullscript,$libraries)=@_; |
my ($socket,$fullscript,$libraries)=@_; |
if (&blacklisted($fullscript)) { return 'Error: blacklisted'; } |
if (&blacklisted($fullscript)) { return 'Error: blacklisted'; } |
my $reply; |
my $reply=''; |
$fullscript=~s/[\n\r\l]//gs; |
$fullscript=~s/[\n\r\l]//gs; |
if ($libraries) { |
if ($libraries) { |
foreach my $library (split(/\s*\,\s*/,$libraries)) { |
foreach my $library (split(/\s*\,\s*/,$libraries)) { |
unless ($library=~/\w/) { next; } |
unless ($library=~/\w/) { next; } |
if (&r_is_allowed_library($library)) { |
if (&r_is_allowed_library($library)) { |
$reply=&rreply($socket,'library('.$library.');'."\n"); |
$reply=&rreply($socket,'library('.$library.');'); |
if ($reply=~/^Error\:/) { return $reply; } |
if ($reply=~/^Error\:/) { return $reply; } |
} else { |
} else { |
return 'Error: blacklisted'; |
return 'Error: blacklisted'; |
} |
} |
} |
} |
} |
} |
foreach my $line (split(/\;/s,$fullscript)) { |
$fullscript=~s/\;+\s*$//s; |
if ($line=~/\w/) { $reply=&rreply($socket,$line.";\n"); } |
if ($fullscript=~/\w/) { $reply=&rreply($socket,$fullscript.';'); } |
if ($reply=~/^Error\:/) { return $reply; } |
if ($reply=~/^Error\:/) { return $reply; } |
} |
|
$reply=~s/^\s*//gs; |
$reply=~s/^\s*//gs; |
$reply=~s/\s*$//gs; |
$reply=~s/\s*$//gs; |
&Apache::lonxml::debug("r $fullscript \n reply $reply"); |
&Apache::lonxml::debug("r $fullscript \n reply $reply"); |
return $reply; |
return $reply; |
} |
} |
|
|
|
sub runserializedscript { |
|
my ($socket,$fullscript,$libraries)=@_; |
|
if (&blacklisted($fullscript)) { return 'Error: blacklisted'; } |
|
my $reply; |
|
$fullscript=~s/[\n\r\l]//gs; |
|
if ($libraries) { |
|
foreach my $library (split(/\s*\,\s*/,$libraries)) { |
|
unless ($library=~/\w/) { next; } |
|
if (&r_is_allowed_library($library)) { |
|
$reply=&rreply($socket,'library('.$library.');'); |
|
if ($reply=~/^Error\:/) { return($reply,$reply); } |
|
} else { |
|
return 'Error: blacklisted'; |
|
} |
|
} |
|
} |
|
$fullscript=~s/\;+\s*$//s; |
|
my $lastline=''; |
|
my $firstpart=''; |
|
if ($fullscript=~/\;/) { |
|
($firstpart,$lastline)=($fullscript=~/^(.*\;)([^\;]+)$/); |
|
} else { |
|
$lastline=$fullscript; |
|
} |
|
if ($firstpart) { |
|
$firstpart=~s/\;+\s*$//s; |
|
$reply=&rreply($socket,$firstpart.';'); |
|
if ($reply=~/^Error\:/) { return($reply,$reply); } |
|
} |
|
# The last line needs to be serialized |
|
$reply=&Rreturn(&rreply($socket,"phpSerialize($lastline);")); |
|
return($reply,&Dumper($reply)); |
|
} |
|
|
sub r_cas_formula_fix { |
sub r_cas_formula_fix { |
my ($expression)=@_; |
my ($expression)=@_; |
return &Apache::response::implicit_multiplication($expression); |
return &Apache::response::implicit_multiplication($expression); |
Line 140 sub r_run {
|
Line 343 sub r_run {
|
} |
} |
|
|
sub r_eval { |
sub r_eval { |
my ($script,$libraries) = @_; |
my ($script,$libraries,$hashflag) = @_; |
my $socket=&connect(); |
my $socket=&connect(); |
my $reply=&runscript($socket,$script,$libraries); |
my $reply; |
|
my $dump=''; |
|
if ($hashflag) { |
|
($reply,$dump)=&runserializedscript($socket,$script,$libraries); |
|
} else { |
|
$reply=&runscript($socket,$script,$libraries); |
|
} |
&disconnect($socket); |
&disconnect($socket); |
return $reply; |
return ($reply,$dump); |
} |
} |
|
|
|
|