--- loncom/homework/lonr.pm 2009/04/18 16:03:17 1.3
+++ loncom/homework/lonr.pm 2009/06/19 14:03:19 1.5
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# Interface routines to R CAS
#
-# $Id: lonr.pm,v 1.3 2009/04/18 16:03:17 www Exp $
+# $Id: lonr.pm,v 1.5 2009/06/19 14:03:19 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -33,6 +33,150 @@ 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
+
+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 =~ /^((?: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 'capaNNN' 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
+ }
+}
+# --- 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
+ }
+ }
+}
+# --- end Rentry ---
+
sub connect {
return IO::Socket::UNIX->new(Peer => $Apache::lonnet::perlvar{'lonSockDir'}.'/rsock',
@@ -68,6 +212,8 @@ sub blacklisted {
'dev\.list','dev\.next','dev\.prev','dev\.set',
'dev\.off','dev\.copy','dev\.print','graphics',
'library','package','source','sink','objects',
+ 'Sys\.','unlink','file\.','on\.exit','error',
+ 'q\(\)'
) {
if ($cmd=~/$forbidden/s) { return 1; }
}
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.