Return to lonr.pm CVS log

Up to [LON-CAPA] / loncom / homework

Paul Rubin's code to unserialize R objects
- use tie::ixhash::easy commented out for now. Not sure if we actually want
that => code will be defunct
- needs better error handling, original code had 'die'

    1: # The LearningOnline Network with CAPA
    2: # Interface routines to R CAS
    3: #
    4: # $Id: lonr.pm,v 1.5 2009/06/19 14:03:19 www Exp $
    5: #
    6: # Copyright Michigan State University Board of Trustees
    7: #
    8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
    9: #
   10: # LON-CAPA is free software; you can redistribute it and/or modify
   11: # it under the terms of the GNU General Public License as published by
   12: # the Free Software Foundation; either version 2 of the License, or
   13: # (at your option) any later version.
   14: #
   15: # LON-CAPA is distributed in the hope that it will be useful,
   16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
   17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   18: # GNU General Public License for more details.
   19: #
   20: # You should have received a copy of the GNU General Public License
   21: # along with LON-CAPA; if not, write to the Free Software
   22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   23: #
   24: # /home/httpd/html/adm/gpl.txt
   25: #
   26: # http://www.lon-capa.org/
   27: #
   28:  
   29: package Apache::lonr;
   30:  
   31: use strict;
   32: use IO::Socket;
   33: use Apache::lonnet;
   34: use Apache::response();
   35: use LONCAPA;
   36: ### Commented out for now: use Tie::IxHash::Easy; # autoties all subhashes to keep index order
   37: 
   38: my $errormsg='';
   39: 
   40: #
   41: # Rcroak: for use with R-error messages
   42: #
   43: sub Rcroak {
   44:    $errormsg=$_[0];
   45: }
   46: 
   47: #
   48: #
   49: # Rpeel takes a string containing serialized values from R, 
   50: # peels off the first syntactically complete unit (number, string or array),
   51: # and returns a list (first unit, remainder).
   52: #
   53: sub Rpeel {
   54:         my $x = $_[0];  # the string containing the serialized R object(s)
   55:         if ($x =~ /^((?:i|d):(.+?);)(.*)$/) {
   56:                 return ($1, $+);  # x starts with a number
   57:         }
   58:         elsif ($x =~ /^s:(\d+):/) {
   59:                 my $n = $1;  # x starts with a string of length n
   60:                 if ($x =~ /^(s:\d+:\"(.{$n})\";)(.*)$/) {
   61:                         return ($1, $+);  # x starts with a valid string
   62:                 } else {
   63:                         &Rcroak('invalid string detected');
   64:                 }
   65:         }
   66:         elsif ($x =~ /^a:/) {
   67:                 # x starts with an array -- need to find the closing brace
   68:                 my $i = index $x, '{', 0;  # position of first opening brace
   69:                 if ($i < 0) {
   70:                         &Rcroak('array with no opening brace');
   71:                 }
   72:                 my $open = 1;  # counts open braces
   73:                 my $j = index $x, '}', $i; # position of first closing brace
   74:                 $i = index $x, '{', $i + 1; # position of next opening brace (if any)
   75:                 my $pos = -1;  # position of final closing brace
   76:                 do {
   77:                         if (($i < $j) && ($i > 0)) {
   78:                                 # encounter another opening brace before next closing brace
   79:                                 $open++;
   80:                                 $i = index $x, '{', $i + 1;  # find the next opening brace
   81:                         } elsif ($j > 0) {
   82:                                 # next brace encountered is a closing brace
   83:                                 $open--;
   84:                                 $pos = $j;
   85:                                 $j = index $x, '}', $j + 1;
   86:                         } else {
   87:                                 &Rcroak('unmatched left brace');
   88:                         }
   89:                 } until ($open eq 0);
   90:                 # array runs from start to $pos
   91:                 my $a = substr $x, 0, $pos + 1;  # array
   92:                 my $b = substr $x, $pos + 1;     # remainder
   93:                 return ($a, $b);
   94:         } else {
   95:                 &Rcroak('unrecognized R value');
   96:         }
   97: }
   98: # --- end Rpeel ---
   99: 
  100: #
  101: # Rreturn accepts a string containing a serialized R object
  102: # and returns either the object's value (if it is scalar) or a reference
  103: # to a hash containing the contents of the object.  Any null keys in the hash
  104: # are replaced by 'capaNNN' where NNN is the index of the entry in the original
  105: # R array.
  106: #
  107: sub Rreturn {
  108:         my $x = $_[0];  # the string containing the serialized R object(s)
  109:         $errormsg='';
  110:         if ($x =~ /^(?:i|d):(.+?);$/) {
  111:                 return $1;  # return the value of the number
  112:         } elsif ($x =~ /^s:(\d+):\"(.*)\";$/) {
  113:                 # string -- verify the length
  114:                 if (length($2) eq $1) {
  115:                         return $2;  # return the string
  116:                 } else {
  117:                         return 'mismatch in string length';
  118:                 }
  119:         } elsif ($x =~ /^a:(\d+):\{(.*)\}$/) {
  120:                 # array
  121:                 my $dim = $1;  # array size
  122:                 $x = $2;  # array contents
  123:                 tie(my %h,'Tie::IxHash::Easy'); # start a hash
  124:                 keys(%h) = $dim; # allocate space for the hash
  125:                 my $key;
  126:                 my $y;
  127:                 for (my $i = 0; $i < $dim; $i++) {
  128:                         ($y, $x) = &Rpeel($x);  # strip off the entry for the key
  129:                         if ($y eq '') {
  130:                                 &Rcroak('ran out of keys');
  131:                         }
  132:                         $key = &Rreturn($y);
  133:                         if ($key eq '') {
  134:                                 $key = "capa$i";  # correct null key
  135:                         }
  136:                         ($y, $x) = &Rpeel($x);  # strip off the value
  137:                         if ($y eq '') {
  138:                                 &Rcroak('ran out of values');
  139:                         }
  140:                         if ($y =~ /^a:/) {
  141:                                 $h{$key} = \&Rreturn($y);  # array value: store as reference
  142:                         } else {
  143:                         $h{$key} = &Rreturn($y);  # scalar value: store the entry in the hash
  144:                         }
  145:                 }
  146:                 if ($errormsg) { return $errormsg; }
  147:                 return \%h;  # return a reference to the hash
  148:         }
  149: }
  150: # --- end Rreturn ---
  151: 
  152: #
  153: # Rentry takes a list of indices and gets the entry in a hash generated by Rreturn.
  154: # Call: Rentry(Rvalue, index1, index2, ...) where Rvalue is a hash returned by Rreturn.
  155: # Rentry will return the first scalar value it encounters (ignoring excess indices).
  156: # If an invalid key is given, Rentry returns undef.
  157: #
  158: sub Rentry {
  159:         my $hash = shift;  # pointer to hash
  160:         my $x;
  161:         my $i;
  162:         if (ref($hash) ne 'HASH') {
  163:                 &Rcroak('argument to Rentry is not a hash');
  164:         }
  165:         while ($i = shift) {
  166:                 if (exists $hash->{$i}) {
  167:                    $hash = $hash->{$i};
  168:                 } else {
  169:                    return undef;
  170:                 }
  171:                 if (ref($hash) eq 'REF') {
  172:                    $hash = $$hash;  # dereference one layer
  173:                 } elsif (ref($hash) ne 'HASH') {
  174:                    return $hash;  # drilled down to a scalar
  175:                 }
  176:         }
  177: }
  178: # --- end Rentry ---
  179: 
  180: 
  181: sub connect {
  182:    return IO::Socket::UNIX->new(Peer    => $Apache::lonnet::perlvar{'lonSockDir'}.'/rsock',
  183: 				Type    => SOCK_STREAM,
  184: 				Timeout => 10);
  185: }
  186: 
  187: sub disconnect {
  188:     my ($socket)=@_;
  189:     if ($socket) { close($socket); }
  190: }
  191: 
  192: sub rreply {
  193:     my ($socket,$cmd)=@_;
  194:     if ($socket) {
  195: 	print $socket &escape($cmd)."\n";
  196:         my $reply=<$socket>;
  197:         chomp($reply);
  198:         if ($reply=~/^Incorrect/) { $reply='Error: '.$reply; }
  199:         return &unescape($reply);
  200:     } else {
  201:         return 'Error: no connection.';
  202:     }
  203: }
  204: 
  205: sub blacklisted {
  206:     my ($cmd)=@_;
  207:     foreach my $forbidden (
  208:         'read','write','scan','save','socket','connections',
  209:         'open','close',
  210:         'plot','X11','windows','quartz',
  211:         'postscript','pdf','png','jpeg',
  212:         'dev\.list','dev\.next','dev\.prev','dev\.set',
  213:         'dev\.off','dev\.copy','dev\.print','graphics',
  214:         'library','package','source','sink','objects',
  215:         'Sys\.','unlink','file\.','on\.exit','error',
  216:         'q\(\)'
  217:      ) {
  218: 	if ($cmd=~/$forbidden/s) { return 1; }
  219:     } 
  220:     return 0;
  221: }
  222: 
  223: sub r_allowed_libraries {
  224:    return ('boot','class','cluster','datasets','KernSmooth','MASS',
  225:            'methods','mgcv','nlme','nnet','rpart','spatial',
  226:            'splines','stats','stats4','survival');
  227: }
  228: 
  229: sub r_is_allowed_library {
  230:     my ($library)=@_;
  231:     foreach my $allowed_library (&r_allowed_libraries()) {
  232:        if ($library eq $allowed_library) { return 1; }
  233:     }
  234:     return 0;
  235: }
  236: 
  237: sub runscript {
  238:     my ($socket,$fullscript,$libraries)=@_;
  239:     if (&blacklisted($fullscript)) { return 'Error: blacklisted'; }
  240:     my $reply;
  241:     $fullscript=~s/[\n\r\l]//gs;
  242:     if ($libraries) {
  243:        foreach my $library (split(/\s*\,\s*/,$libraries)) {
  244:           unless ($library=~/\w/) { next; }
  245:           if (&r_is_allowed_library($library)) {
  246:               $reply=&rreply($socket,'library('.$library.');'."\n");
  247:               if ($reply=~/^Error\:/) { return $reply; }
  248:           } else { 
  249:              return 'Error: blacklisted'; 
  250:           }
  251:        }
  252:     }
  253:     foreach my $line (split(/\;/s,$fullscript)) {
  254: 	if ($line=~/\w/) { $reply=&rreply($socket,$line.";\n"); }
  255: 	if ($reply=~/^Error\:/) { return $reply; }
  256:     }
  257:     $reply=~s/^\s*//gs;
  258:     $reply=~s/\s*$//gs;
  259:     &Apache::lonxml::debug("r $fullscript \n reply $reply");
  260:     return $reply;
  261: }
  262: 
  263: sub r_cas_formula_fix {
  264:    my ($expression)=@_;
  265:    return &Apache::response::implicit_multiplication($expression);
  266: }
  267: 
  268: sub r_run {
  269:     my ($script,$submission,$argument,$libraries) = @_;
  270:     my $socket=&connect();
  271:     my @submissionarray=split(/\s*\,\s*/,$submission);
  272:     for (my $i=0;$i<=$#submissionarray;$i++) {
  273:         my $n=$i+1;
  274:         my $fixedsubmission=&r_cas_formula_fix($submissionarray[$i]);
  275:         $script=~s/RESPONSE\[$n\]/$fixedsubmission/gs;
  276:     }
  277:     my @argumentarray=@{$argument};
  278:     for (my $i=0;$i<=$#argumentarray;$i++) {
  279:         my $n=$i+1;
  280:         my $fixedargument=&r_cas_formula_fix($argumentarray[$i]);
  281:         $script=~s/LONCAPALIST\[$n\]/$fixedargument/gs;
  282:     }
  283:     my $reply=&runscript($socket,$script,$libraries);
  284:     &disconnect($socket);
  285:     if ($reply=~/^\s*true\s*$/i) { return 'EXACT_ANS'; }
  286:     if ($reply=~/^\s*false\s*$/i) { return 'INCORRECT'; } 
  287:     return 'BAD_FORMULA';
  288: }
  289: 
  290: sub r_eval {
  291:     my ($script,$libraries) = @_;
  292:     my $socket=&connect();
  293:     my $reply=&runscript($socket,$script,$libraries);
  294:     &disconnect($socket);
  295:     return $reply;
  296: }
  297: 
  298: 
  299: sub compareterms {
  300:     my ($socket,$terma,$termb)=@_;
  301:     my $difference=$terma.'-('.$termb.')';
  302:     if (&blacklisted($difference)) { return 'Error: blacklisted'; }
  303:     my $reply=&rreply($socket,$difference.';');
  304:     if ($reply=~/^\s*0\s*$/) { return 'true'; }
  305:     if ($reply=~/^Error\:/) { return $reply; }
  306:     return 'false';
  307: }
  308: 
  309: sub r_check {
  310:     my ($response,$answer,$reterror) = @_;
  311:     my $socket=&connect();
  312:     my $reply=&compareterms($socket,$response,$answer);
  313:     &disconnect($socket);
  314:     # integer to string mappings come from capaParser.h
  315:     # 1 maps to 'EXACT_ANS'
  316:     if ($reply eq 'true') { return 1; }
  317:     # 11 maps to 'BAD_FORMULA'
  318:     if ($reply=~/^Error\:/) { return 11; }
  319:     # 7 maps to 'INCORRECT'
  320:     return 7;
  321: }
  322:  
  323: 1;
  324: __END__;