version 1.6, 2009/06/23 03:01:15
|
version 1.9, 2009/08/14 01:58:52
|
Line 58 sub Rpeel {
|
Line 58 sub Rpeel {
|
my $x = $_[0]; # the string containing the serialized R object(s) |
my $x = $_[0]; # the string containing the serialized R object(s) |
if ($x =~ /^((?:i|d):(.+?);)(.*)$/) { |
if ($x =~ /^((?:i|d):(.+?);)(.*)$/) { |
return ($1, $+); # x starts with a number |
return ($1, $+); # x starts with a number |
} |
} elsif ($x =~ /^s:(\d+):/) { |
elsif ($x =~ /^s:(\d+):/) { |
|
my $n = $1; # x starts with a string of length n |
my $n = $1; # x starts with a string of length n |
if ($x =~ /^(s:\d+:\"(.{$n})\";)(.*)$/) { |
if ($x =~ /^(s:\d+:\"(.{$n})\";)(.*)$/) { |
return ($1, $+); # x starts with a valid string |
return ($1, $+); # x starts with a valid string |
} else { |
} else { |
&Rcroak('invalid string detected'); |
&Rcroak('invalid string detected'); |
} |
} |
} |
} elsif ($x =~ /^a:/) { |
elsif ($x =~ /^a:/) { |
|
# x starts with an array -- need to find the closing brace |
# x starts with an array -- need to find the closing brace |
my $i = index $x, '{', 0; # position of first opening brace |
my $i = index $x, '{', 0; # position of first opening brace |
if ($i < 0) { |
if ($i < 0) { |
Line 244 sub blacklisted {
|
Line 242 sub blacklisted {
|
} |
} |
|
|
sub r_allowed_libraries { |
sub r_allowed_libraries { |
return ('boot','class','cluster','datasets','KernSmooth','MASS', |
return ('alr3','boot','car','class','cluster','datasets','Hmisc','KernSmooth','leaps','lmtest', |
'methods','mgcv','nlme','nnet','rpart','spatial', |
'MASS','methods','mgcv','nlme','nnet','qAnalyst','quadprog','rpart','SuppDists','spatial', |
'splines','stats','stats4','survival'); |
'splines','stats','stats4','survival','tseries','zoo'); |
} |
} |
|
|
sub r_is_allowed_library { |
sub r_is_allowed_library { |
Line 260 sub r_is_allowed_library {
|
Line 258 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"); |
Line 292 sub runserializedscript {
|
Line 289 sub runserializedscript {
|
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,$reply); } |
if ($reply=~/^Error\:/) { return($reply,$reply); } |
} else { |
} else { |
return 'Error: blacklisted'; |
return 'Error: blacklisted'; |
} |
} |
} |
} |
} |
} |
my @actuallines=(); |
$fullscript=~s/\;+\s*$//s; |
foreach my $line (split(/\;/s,$fullscript)) { |
my $lastline=''; |
if ($line=~/\w/) { push (@actuallines,$line); } |
my $firstpart=''; |
|
if ($fullscript=~/\;/) { |
|
($firstpart,$lastline)=($fullscript=~/^(.*\;)([^\;]+)$/); |
|
} else { |
|
$lastline=$fullscript; |
} |
} |
for (my $i=0; $i<$#actuallines; $i++) { |
if ($firstpart) { |
$reply=&rreply($socket,$actuallines[$i].";\n"); |
$firstpart=~s/\;+\s*$//s; |
|
$reply=&rreply($socket,$firstpart.';'); |
if ($reply=~/^Error\:/) { return($reply,$reply); } |
if ($reply=~/^Error\:/) { return($reply,$reply); } |
} |
} |
# The last line needs to be serialized |
# The last line needs to be serialized |
$reply=&Rreturn(&rreply($socket,"phpSerialize($actuallines[-1]);\n")); |
$reply=&Rreturn(&rreply($socket,"phpSerialize($lastline);")); |
return($reply,&Dumper($reply)); |
return($reply,&Dumper($reply)); |
} |
} |
|
|