--- loncom/homework/lonr.pm 2009/06/19 14:03:19 1.5
+++ loncom/homework/lonr.pm 2009/08/12 20:09:02 1.8
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# Interface routines to R CAS
#
-# $Id: lonr.pm,v 1.5 2009/06/19 14:03:19 www Exp $
+# $Id: lonr.pm,v 1.8 2009/08/12 20:09:02 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -33,7 +33,11 @@ use IO::Socket;
use Apache::lonnet;
use Apache::response();
use LONCAPA;
-### Commented out for now: use Tie::IxHash::Easy; # autoties all subhashes to keep index order
+
+### You need to install the libraries below for this to work!
+
+###use Tie::IxHash::Easy; # autoties all subhashes to keep index order
+###use Data::Dumper; # used to output hash contents
my $errormsg='';
@@ -101,82 +105,101 @@ sub 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 'capaNNN' where NNN is the index of the entry in the original
+# 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)
- $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 = "capa$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
+ 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
+ } else {
+ return 'Unrecognized output';
+ }
}
# --- end Rreturn ---
-#
-# Rentry takes a list of indices and gets the entry in a hash generated by Rreturn.
-# Call: Rentry(Rvalue, index1, index2, ...) where Rvalue is a hash returned by Rreturn.
-# Rentry will return the first scalar value it encounters (ignoring excess indices).
-# If an invalid key is given, Rentry returns undef.
-#
sub Rentry {
- my $hash = shift; # pointer to hash
- my $x;
- my $i;
- if (ref($hash) ne 'HASH') {
- &Rcroak('argument to Rentry 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
- }
- }
+ 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
+ }
+ }
}
-# --- end Rentry ---
+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 {
return IO::Socket::UNIX->new(Peer => $Apache::lonnet::perlvar{'lonSockDir'}.'/rsock',
@@ -221,9 +244,9 @@ sub blacklisted {
}
sub r_allowed_libraries {
- return ('boot','class','cluster','datasets','KernSmooth','MASS',
- 'methods','mgcv','nlme','nnet','rpart','spatial',
- 'splines','stats','stats4','survival');
+ return ('alr3','boot','car','class','cluster','datasets','Hmisc','KernSmooth','leaps','lmtest',
+ 'MASS','methods','mgcv','nlme','nnet','qAnalyst','quadprog','rpart','SuppDists','spatial',
+ 'splines','stats','stats4','survival','tseries','zoo');
}
sub r_is_allowed_library {
@@ -250,7 +273,7 @@ sub runscript {
}
}
}
- foreach my $line (split(/\;/s,$fullscript)) {
+ foreach my $line (split(/[\n\r]+/s,$fullscript)) {
if ($line=~/\w/) { $reply=&rreply($socket,$line.";\n"); }
if ($reply=~/^Error\:/) { return $reply; }
}
@@ -260,6 +283,35 @@ sub runscript {
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.');'."\n");
+ if ($reply=~/^Error\:/) { return($reply,$reply); }
+ } else {
+ return 'Error: blacklisted';
+ }
+ }
+ }
+ my @actuallines=();
+ foreach my $line (split(/\;/s,$fullscript)) {
+ if ($line=~/\w/) { push (@actuallines,$line); }
+ }
+ for (my $i=0; $i<$#actuallines; $i++) {
+ $reply=&rreply($socket,$actuallines[$i].";\n");
+ if ($reply=~/^Error\:/) { return($reply,$reply); }
+ }
+# The last line needs to be serialized
+ $reply=&Rreturn(&rreply($socket,"phpSerialize($actuallines[-1]);\n"));
+ return($reply,&Dumper($reply));
+}
+
sub r_cas_formula_fix {
my ($expression)=@_;
return &Apache::response::implicit_multiplication($expression);
@@ -288,11 +340,17 @@ sub r_run {
}
sub r_eval {
- my ($script,$libraries) = @_;
+ my ($script,$libraries,$hashflag) = @_;
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);
- return $reply;
+ return ($reply,$dump);
}
500 Internal Server Error
Internal Server Error
The server encountered an internal error or
misconfiguration and was unable to complete
your request.
Please contact the server administrator at
root@localhost to inform them of the time this error occurred,
and the actions you performed just before this error.
More information about this error may be available
in the server error log.