Return to lonr.pm CVS log

Up to [LON-CAPA] / loncom / homework

- Need to handle 'N;' in serialized data from phpSerialize(), because
  phpSerialize.r adds it to the string when a null value is encountered.

    1: # The LearningOnline Network with CAPA
    2: # Interface routines to R CAS
    3: #
    4: # $Id: lonr.pm,v 1.11 2014/11/19 21:14:47 raeburn 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: use Tie::IxHash::Easy; # autoties all subhashes to keep index order
   37: use Data::Dumper;  # used to output hash contents
   38: 
   39: my $errormsg='';
   40: 
   41: #
   42: # Rcroak: for use with R-error messages
   43: #
   44: sub Rcroak {
   45:    $errormsg=$_[0];
   46: }
   47: 
   48: #
   49: #
   50: # Rpeel takes a string containing serialized values from R, 
   51: # peels off the first syntactically complete unit (number, string or array),
   52: # and returns a list (first unit, remainder).
   53: #
   54: sub Rpeel {
   55:         my $x = $_[0];  # the string containing the serialized R object(s)
   56:         if ($x =~ /^N\;(.*)$/) {
   57:             return ('',$1);
   58:         } elsif ($x =~ /^((?:i|d):(.+?);)(.*)$/) {
   59:                 return ($1, $+);  # x starts with a number
   60:         } elsif ($x =~ /^s:(\d+):/) {
   61:                 my $n = $1;  # x starts with a string of length n
   62:                 if ($x =~ /^(s:\d+:\"(.{$n})\";)(.*)$/) {
   63:                         return ($1, $+);  # x starts with a valid string
   64:                 } else {
   65:                         &Rcroak('invalid string detected');
   66:                 }
   67:         } elsif ($x =~ /^a:/) {
   68:                 # x starts with an array -- need to find the closing brace
   69:                 my $i = index $x, '{', 0;  # position of first opening brace
   70:                 if ($i < 0) {
   71:                         &Rcroak('array with no opening brace');
   72:                 }
   73:                 my $open = 1;  # counts open braces
   74:                 my $j = index $x, '}', $i; # position of first closing brace
   75:                 $i = index $x, '{', $i + 1; # position of next opening brace (if any)
   76:                 my $pos = -1;  # position of final closing brace
   77:                 do {
   78:                         if (($i < $j) && ($i > 0)) {
   79:                                 # encounter another opening brace before next closing brace
   80:                                 $open++;
   81:                                 $i = index $x, '{', $i + 1;  # find the next opening brace
   82:                         } elsif ($j > 0) {
   83:                                 # next brace encountered is a closing brace
   84:                                 $open--;
   85:                                 $pos = $j;
   86:                                 $j = index $x, '}', $j + 1;
   87:                         } else {
   88:                                 &Rcroak('unmatched left brace');
   89:                         }
   90:                 } until ($open eq 0);
   91:                 # array runs from start to $pos
   92:                 my $a = substr $x, 0, $pos + 1;  # array
   93:                 my $b = substr $x, $pos + 1;     # remainder
   94:                 return ($a, $b);
   95:         } else {
   96:                 &Rcroak('unrecognized R value');
   97:         }
   98: }
   99: # --- end Rpeel ---
  100: 
  101: #
  102: # Rreturn accepts a string containing a serialized R object
  103: # and returns either the object's value (if it is scalar) or a reference
  104: # to a hash containing the contents of the object.  Any null keys in the hash
  105: # are replaced by 'resultNNN' where NNN is the index of the entry in the original
  106: # R array.
  107: #
  108: sub Rreturn {
  109:     my $x = $_[0];  # the string containing the serialized R object(s)
  110:     $x=~s/^\"//;
  111:     $x=~s/\"$//;
  112:     $x=~s/\\\"/\"/g;
  113:     $errormsg='';
  114:     if ($x =~ /^(?:i|d):(.+?);$/) {
  115:         return $1;  # return the value of the number
  116:     } elsif ($x =~ /^s:(\d+):\"(.*)\";$/) {
  117:         # string -- verify the length
  118:         if (length($2) eq $1) {
  119:            return $2;  # return the string
  120:         } else {
  121:            return 'mismatch in string length';
  122:         }
  123:     } elsif ($x =~ /^a:(\d+):\{(.*)\}$/) {
  124:         # array
  125:         my $dim = $1;  # array size
  126:         $x = $2;  # array contents
  127:         tie(my %h,'Tie::IxHash::Easy'); # start a hash
  128:         keys(%h) = $dim; # allocate space for the hash
  129:         my $key;
  130:         my $y;
  131:         for (my $i = 0; $i < $dim; $i++) {
  132:            ($y, $x) = &Rpeel($x);  # strip off the entry for the key
  133:            if ($y eq '') {
  134:               &Rcroak('ran out of keys');
  135:            }
  136:            $key = &Rreturn($y);
  137:            if ($key eq '') {
  138:               $key = "result$i";  # correct null key
  139:            }
  140:            ($y, $x) = &Rpeel($x);  # strip off the value
  141:            if ($y eq '') {
  142:                &Rcroak('ran out of values');
  143:            }
  144:            if ($y =~ /^a:/) {
  145:                $h{$key} = \&Rreturn($y);  # array value: store as reference
  146:            } else {
  147:                $h{$key} = &Rreturn($y);  # scalar value: store the entry in the hash
  148:            }
  149:         }
  150:         if ($errormsg) { return $errormsg; }
  151:         return \%h;  # return a reference to the hash
  152:     } elsif ($x eq '') {
  153:         return '';
  154:     } else {
  155:         return 'Unrecognized output';
  156:     }
  157: }
  158: # --- end Rreturn ---
  159: 
  160: sub Rentry {
  161:     my $hash = shift;  # pointer to tied hash
  162:     my $i;
  163:     if (ref($hash) ne 'HASH') {
  164:        return 'Argument to cas_hashref_entry is not a hash!';
  165:     }
  166:     while ($i = shift) {
  167:        if (exists($hash->{$i})) {
  168:           $hash = $hash->{$i};
  169:        } else {
  170:           return undef;
  171:        }
  172:        if (ref($hash) eq 'REF') {
  173:           $hash = $$hash;  # dereference one layer
  174:        } elsif (ref($hash) ne 'HASH') {
  175:           return $hash;  # drilled down to a scalar
  176:        }
  177:     }
  178: }
  179: 
  180: sub Rarray {
  181:     my $hash = shift;  # pointer to tied hash
  182:     my $i;
  183:     if (ref($hash) ne 'HASH') {
  184:        return 'Argument to cas_hashref_array is not a hash!';
  185:     }
  186:     while ($i = shift) {
  187:        if (exists($hash->{$i})) {
  188:           $hash = $hash->{$i};
  189:        } else {
  190:           return undef;
  191:        }
  192:        if (ref($hash) eq 'REF') {
  193:           $hash = $$hash;  # dereference one layer
  194:        }
  195:     }
  196:     my @returnarray=();
  197:     foreach my $key (keys(%{$hash})) {
  198:         $returnarray[$key-1]=$$hash{$key};
  199:     }
  200:     return @returnarray;
  201: }
  202: 
  203: sub connect {
  204:    return IO::Socket::UNIX->new(Peer    => $Apache::lonnet::perlvar{'lonSockDir'}.'/rsock',
  205: 				Type    => SOCK_STREAM,
  206: 				Timeout => 10);
  207: }
  208: 
  209: sub disconnect {
  210:     my ($socket)=@_;
  211:     if ($socket) { close($socket); }
  212: }
  213: 
  214: sub rreply {
  215:     my ($socket,$cmd)=@_;
  216:     if ($socket) {
  217: 	print $socket &escape($cmd)."\n";
  218:         my $reply=<$socket>;
  219:         chomp($reply);
  220:         if ($reply=~/^Incorrect/) { $reply='Error: '.$reply; }
  221:         return &unescape($reply);
  222:     } else {
  223:         return 'Error: no connection.';
  224:     }
  225: }
  226: 
  227: sub blacklisted {
  228:     my ($cmd)=@_;
  229:     foreach my $forbidden (
  230:         'read','write','scan','save','socket','connections',
  231:         'open','close',
  232:         'plot','X11','windows','quartz',
  233:         'postscript','pdf','png','jpeg',
  234:         'dev\.list','dev\.next','dev\.prev','dev\.set',
  235:         'dev\.off','dev\.copy','dev\.print','graphics',
  236:         'library','package','source','sink','objects',
  237:         'Sys\.','unlink','file\.','on\.exit','error',
  238:         'q\(\)'
  239:      ) {
  240: 	if ($cmd=~/$forbidden/s) { return 1; }
  241:     } 
  242:     return 0;
  243: }
  244: 
  245: sub r_allowed_libraries {
  246:    return ('alr3','boot','car','class','cluster','datasets','Hmisc','KernSmooth','leaps','lmtest',
  247:            'MASS','methods','mgcv','nlme','nnet','qAnalyst','quadprog','rpart','SuppDists','spatial',
  248:            'splines','stats','stats4','survival','tseries','zoo');
  249: }
  250: 
  251: sub r_is_allowed_library {
  252:     my ($library)=@_;
  253:     foreach my $allowed_library (&r_allowed_libraries()) {
  254:        if ($library eq $allowed_library) { return 1; }
  255:     }
  256:     return 0;
  257: }
  258: 
  259: sub runscript {
  260:     my ($socket,$fullscript,$libraries)=@_;
  261:     if (&blacklisted($fullscript)) { return 'Error: blacklisted'; }
  262:     my $reply='';
  263:     $fullscript=~s/[\n\r\l]//gs;
  264:     if ($libraries) {
  265:        foreach my $library (split(/\s*\,\s*/,$libraries)) {
  266:           unless ($library=~/\w/) { next; }
  267:           if (&r_is_allowed_library($library)) {
  268:               $reply=&rreply($socket,'library('.$library.');');
  269:               if ($reply=~/^Error\:/) { return $reply; }
  270:           } else { 
  271:              return 'Error: blacklisted'; 
  272:           }
  273:        }
  274:     }
  275:     $fullscript=~s/\;+\s*$//s;
  276:     if ($fullscript=~/\w/) { $reply=&rreply($socket,$fullscript.';'); }
  277:     if ($reply=~/^Error\:/) { return $reply; }
  278:     $reply=~s/^\s*//gs;
  279:     $reply=~s/\s*$//gs;
  280:     &Apache::lonxml::debug("r $fullscript \n reply $reply");
  281:     return $reply;
  282: }
  283: 
  284: sub runserializedscript {
  285:     my ($socket,$fullscript,$libraries)=@_;
  286:     if (&blacklisted($fullscript)) { return 'Error: blacklisted'; }
  287:     my $reply;
  288:     $fullscript=~s/[\n\r\l]//gs;
  289:     if ($libraries) {
  290:        foreach my $library (split(/\s*\,\s*/,$libraries)) {
  291:           unless ($library=~/\w/) { next; }
  292:           if (&r_is_allowed_library($library)) {
  293:               $reply=&rreply($socket,'library('.$library.');');
  294:               if ($reply=~/^Error\:/) { return($reply,$reply); }
  295:           } else {
  296:              return 'Error: blacklisted';
  297:           }
  298:        }
  299:     }
  300:     $fullscript=~s/\;+\s*$//s;
  301:     my $lastline='';
  302:     my $firstpart='';
  303:     if ($fullscript=~/\;/) {
  304:        ($firstpart,$lastline)=($fullscript=~/^(.*\;)([^\;]+)$/);
  305:     } else {
  306:        $lastline=$fullscript;
  307:     }
  308:     if ($firstpart) {
  309:         $firstpart=~s/\;+\s*$//s;
  310:         $reply=&rreply($socket,$firstpart.';');
  311:         if ($reply=~/^Error\:/) { return($reply,$reply); }
  312:     }
  313: # The last line needs to be serialized
  314:     $reply=&Rreturn(&rreply($socket,"phpSerialize($lastline);"));
  315:     return($reply,&Dumper($reply));
  316: }
  317: 
  318: sub r_cas_formula_fix {
  319:    my ($expression)=@_;
  320:    return &Apache::response::implicit_multiplication($expression);
  321: }
  322: 
  323: sub r_run {
  324:     my ($script,$submission,$argument,$libraries) = @_;
  325:     my $socket=&connect();
  326:     my @submissionarray=split(/\s*\,\s*/,$submission);
  327:     for (my $i=0;$i<=$#submissionarray;$i++) {
  328:         my $n=$i+1;
  329:         my $fixedsubmission=&r_cas_formula_fix($submissionarray[$i]);
  330:         $script=~s/RESPONSE\[$n\]/$fixedsubmission/gs;
  331:     }
  332:     my @argumentarray=@{$argument};
  333:     for (my $i=0;$i<=$#argumentarray;$i++) {
  334:         my $n=$i+1;
  335:         my $fixedargument=&r_cas_formula_fix($argumentarray[$i]);
  336:         $script=~s/LONCAPALIST\[$n\]/$fixedargument/gs;
  337:     }
  338:     my $reply=&runscript($socket,$script,$libraries);
  339:     &disconnect($socket);
  340:     if ($reply=~/^\s*true\s*$/i) { return 'EXACT_ANS'; }
  341:     if ($reply=~/^\s*false\s*$/i) { return 'INCORRECT'; } 
  342:     return 'BAD_FORMULA';
  343: }
  344: 
  345: sub r_eval {
  346:     my ($script,$libraries,$hashflag) = @_;
  347:     my $socket=&connect();
  348:     my $reply;
  349:     my $dump='';
  350:     if ($hashflag) {
  351:        ($reply,$dump)=&runserializedscript($socket,$script,$libraries);
  352:     } else {
  353:        $reply=&runscript($socket,$script,$libraries);
  354:     }
  355:     &disconnect($socket);
  356:     return ($reply,$dump);
  357: }
  358: 
  359: 
  360: sub compareterms {
  361:     my ($socket,$terma,$termb)=@_;
  362:     my $difference=$terma.'-('.$termb.')';
  363:     if (&blacklisted($difference)) { return 'Error: blacklisted'; }
  364:     my $reply=&rreply($socket,$difference.';');
  365:     if ($reply=~/^\s*0\s*$/) { return 'true'; }
  366:     if ($reply=~/^Error\:/) { return $reply; }
  367:     return 'false';
  368: }
  369: 
  370: sub r_check {
  371:     my ($response,$answer,$reterror) = @_;
  372:     my $socket=&connect();
  373:     my $reply=&compareterms($socket,$response,$answer);
  374:     &disconnect($socket);
  375:     # integer to string mappings come from capaParser.h
  376:     # 1 maps to 'EXACT_ANS'
  377:     if ($reply eq 'true') { return 1; }
  378:     # 11 maps to 'BAD_FORMULA'
  379:     if ($reply=~/^Error\:/) { return 11; }
  380:     # 7 maps to 'INCORRECT'
  381:     return 7;
  382: }
  383:  
  384: 1;
  385: __END__;