--- loncom/homework/lonr.pm 2009/06/19 14:03:19 1.5
+++ loncom/homework/lonr.pm 2009/06/23 03:01:15 1.6
@@ -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.6 2009/06/23 03:01:15 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',
@@ -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);
}