[BACK]Return to lonr.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / homework

Diff for /loncom/homework/lonr.pm between versions 1.5 and 1.12

version 1.5, 2009/06/19 14:03:19 version 1.12, 2024/06/21 23:42:49
Line 33  use IO::Socket; Line 33  use IO::Socket;
 use Apache::lonnet;  use Apache::lonnet;
 use Apache::response();  use Apache::response();
 use LONCAPA;  use LONCAPA;
 ### Commented out for now: use Tie::IxHash::Easy; # autoties all subhashes to keep index order  use Tie::IxHash::Easy; # autoties all subhashes to keep index order
   use Data::Dumper;  # used to output hash contents
   
 my $errormsg='';  my $errormsg='';
   
Line 52  sub Rcroak { Line 53  sub Rcroak {
 #  #
 sub Rpeel {  sub Rpeel {
         my $x = $_[0];  # the string containing the serialized R object(s)          my $x = $_[0];  # the string containing the serialized R object(s)
         if ($x =~ /^((?:i|d):(.+?);)(.*)$/) {          if ($x =~ /^N\;(.*)$/) {
               return ('',$1);
           } elsif ($x =~ /^((?:i|d):(.+?);)(.*)$/) {
                 return ($1, $+);  # x starts with a number                  return ($1, $+);  # x starts with a number
         }          } elsif ($x =~ /^s:(\d+):/) {
         elsif ($x =~ /^s:(\d+):/) {  
                 my $n = $1;  # x starts with a string of length n                  my $n = $1;  # x starts with a string of length n
                 if ($x =~ /^(s:\d+:\"(.{$n})\";)(.*)$/) {                  if ($x =~ /^(s:\d+:\"(.{$n})\";)(.*)$/) {
                         return ($1, $+);  # x starts with a valid string                          return ($1, $+);  # x starts with a valid string
                 } else {                  } else {
                         &Rcroak('invalid string detected');                          &Rcroak('invalid string detected');
                 }                  }
         }          } elsif ($x =~ /^a:/) {
         elsif ($x =~ /^a:/) {  
                 # x starts with an array -- need to find the closing brace                  # x starts with an array -- need to find the closing brace
                 my $i = index $x, '{', 0;  # position of first opening brace                  my $i = index $x, '{', 0;  # position of first opening brace
                 if ($i < 0) {                  if ($i < 0) {
Line 101  sub Rpeel { Line 102  sub Rpeel {
 # Rreturn accepts a string containing a serialized R object  # Rreturn accepts a string containing a serialized R object
 # and returns either the object's value (if it is scalar) or a reference  # 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  # 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.  # R array.
 #  #
 sub Rreturn {  sub Rreturn {
         my $x = $_[0];  # the string containing the serialized R object(s)      my $x = $_[0];  # the string containing the serialized R object(s)
         $errormsg='';      $x=~s/^\"//;
         if ($x =~ /^(?:i|d):(.+?);$/) {      $x=~s/\"$//;
                 return $1;  # return the value of the number      $x=~s/\\\"/\"/g;
         } elsif ($x =~ /^s:(\d+):\"(.*)\";$/) {      $errormsg='';
                 # string -- verify the length      if ($x =~ /^(?:i|d):(.+?);$/) {
                 if (length($2) eq $1) {          return $1;  # return the value of the number
                         return $2;  # return the string      } elsif ($x =~ /^s:(\d+):\"(.*)\";$/) {
                 } else {          # string -- verify the length
                         return 'mismatch in string length';          if (length($2) eq $1) {
                 }             return $2;  # return the string
         } elsif ($x =~ /^a:(\d+):\{(.*)\}$/) {          } else {
                 # array             return 'mismatch in string length';
                 my $dim = $1;  # array size          }
                 $x = $2;  # array contents      } elsif ($x =~ /^a:(\d+):\{(.*)\}$/) {
                 tie(my %h,'Tie::IxHash::Easy'); # start a hash          # array
                 keys(%h) = $dim; # allocate space for the hash          my $dim = $1;  # array size
                 my $key;          $x = $2;  # array contents
                 my $y;          tie(my %h,'Tie::IxHash::Easy'); # start a hash
                 for (my $i = 0; $i < $dim; $i++) {          keys(%h) = $dim; # allocate space for the hash
                         ($y, $x) = &Rpeel($x);  # strip off the entry for the key          my $key;
                         if ($y eq '') {          my $y;
                                 &Rcroak('ran out of keys');          for (my $i = 0; $i < $dim; $i++) {
                         }             ($y, $x) = &Rpeel($x);  # strip off the entry for the key
                         $key = &Rreturn($y);             if ($y eq '') {
                         if ($key eq '') {                &Rcroak('ran out of keys');
                                 $key = "capa$i";  # correct null key             }
                         }             $key = &Rreturn($y);
                         ($y, $x) = &Rpeel($x);  # strip off the value             if ($key eq '') {
                         if ($y eq '') {                $key = "result$i";  # correct null key
                                 &Rcroak('ran out of values');             }
                         }             ($y, $x) = &Rpeel($x);  # strip off the value
                         if ($y =~ /^a:/) {             if ($y eq '') {
                                 $h{$key} = \&Rreturn($y);  # array value: store as reference                 &Rcroak('ran out of values');
                         } else {             }
                         $h{$key} = &Rreturn($y);  # scalar value: store the entry in the hash             if ($y =~ /^a:/) {
                         }                 $h{$key} = \&Rreturn($y);  # array value: store as reference
                 }             } else {
                 if ($errormsg) { return $errormsg; }                 $h{$key} = &Rreturn($y);  # scalar value: store the entry in the hash
                 return \%h;  # return a reference to the hash             }
         }          }
           if ($errormsg) { return $errormsg; }
           return \%h;  # return a reference to the hash
       } elsif ($x eq '') {
           return '';
       } else {
           return 'Unrecognized output';
       }
 }  }
 # --- end Rreturn ---  # --- 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 {  sub Rentry {
         my $hash = shift;  # pointer to hash      my $hash = shift;  # pointer to tied hash
         my $x;      my $i;
         my $i;      if (ref($hash) ne 'HASH') {
         if (ref($hash) ne 'HASH') {         return 'Argument to cas_hashref_entry is not a hash!';
                 &Rcroak('argument to Rentry is not a hash');      }
         }      while ($i = shift) {
         while ($i = shift) {         if (exists($hash->{$i})) {
                 if (exists $hash->{$i}) {            $hash = $hash->{$i};
                    $hash = $hash->{$i};         } else {
                 } else {            return undef;
                    return undef;         }
                 }         if (ref($hash) eq 'REF') {
                 if (ref($hash) eq 'REF') {            $hash = $$hash;  # dereference one layer
                    $hash = $$hash;  # dereference one layer         } elsif (ref($hash) ne 'HASH') {
                 } elsif (ref($hash) ne 'HASH') {            return $hash;  # drilled down to a scalar
                    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 {  sub connect {
    return IO::Socket::UNIX->new(Peer    => $Apache::lonnet::perlvar{'lonSockDir'}.'/rsock',     return IO::Socket::UNIX->new(Peer    => $Apache::lonnet::perlvar{'lonSockDir'}.'/rsock',
Line 221  sub blacklisted { Line 243  sub blacklisted {
 }  }
   
 sub r_allowed_libraries {  sub r_allowed_libraries {
    return ('boot','class','cluster','datasets','KernSmooth','MASS',     return ('alr3','boot','car','class','cluster','datasets','FactoMineR','Hmisc','KernSmooth','leaps',
            'methods','mgcv','nlme','nnet','rpart','spatial',             'lmtest','MASS','mdatools','methods','mgcv','nlme','nnet','qAnalyst','quadprog','rpart', 
            'splines','stats','stats4','survival');             'SuppDists','spatial','splines','stats','stats4','survival','tseries','zoo');
 }  }
   
 sub r_is_allowed_library {  sub r_is_allowed_library {
Line 237  sub r_is_allowed_library { Line 259  sub r_is_allowed_library {
 sub runscript {  sub runscript {
     my ($socket,$fullscript,$libraries)=@_;      my ($socket,$fullscript,$libraries)=@_;
     if (&blacklisted($fullscript)) { return 'Error: blacklisted'; }      if (&blacklisted($fullscript)) { return 'Error: blacklisted'; }
     my $reply;      my $reply='';
     $fullscript=~s/[\n\r\l]//gs;      $fullscript=~s/[\n\r\l]//gs;
     if ($libraries) {      if ($libraries) {
        foreach my $library (split(/\s*\,\s*/,$libraries)) {         foreach my $library (split(/\s*\,\s*/,$libraries)) {
           unless ($library=~/\w/) { next; }            unless ($library=~/\w/) { next; }
           if (&r_is_allowed_library($library)) {            if (&r_is_allowed_library($library)) {
               $reply=&rreply($socket,'library('.$library.');'."\n");                $reply=&rreply($socket,'library('.$library.');');
               if ($reply=~/^Error\:/) { return $reply; }                if ($reply=~/^Error\:/) { return $reply; }
           } else {             } else { 
              return 'Error: blacklisted';                return 'Error: blacklisted'; 
           }            }
        }         }
     }      }
     foreach my $line (split(/\;/s,$fullscript)) {      $fullscript=~s/\;+\s*$//s;
  if ($line=~/\w/) { $reply=&rreply($socket,$line.";\n"); }      if ($fullscript=~/\w/) { $reply=&rreply($socket,$fullscript.';'); }
  if ($reply=~/^Error\:/) { return $reply; }      if ($reply=~/^Error\:/) { return $reply; }
     }  
     $reply=~s/^\s*//gs;      $reply=~s/^\s*//gs;
     $reply=~s/\s*$//gs;      $reply=~s/\s*$//gs;
     &Apache::lonxml::debug("r $fullscript \n reply $reply");      &Apache::lonxml::debug("r $fullscript \n reply $reply");
     return $reply;      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.');');
                 if ($reply=~/^Error\:/) { return($reply,$reply); }
             } else {
                return 'Error: blacklisted';
             }
          }
       }
       $fullscript=~s/\;+\s*$//s;
       my $lastline='';
       my $firstpart='';
       if ($fullscript=~/\;/) {
          ($firstpart,$lastline)=($fullscript=~/^(.*\;)([^\;]+)$/);
       } else {
          $lastline=$fullscript;
       }
       if ($firstpart) {
           $firstpart=~s/\;+\s*$//s;
           $reply=&rreply($socket,$firstpart.';');
           if ($reply=~/^Error\:/) { return($reply,$reply); }
       }
   # The last line needs to be serialized
       $reply=&Rreturn(&rreply($socket,"phpSerialize($lastline);"));
       return($reply,&Dumper($reply));
   }
   
 sub r_cas_formula_fix {  sub r_cas_formula_fix {
    my ($expression)=@_;     my ($expression)=@_;
    return &Apache::response::implicit_multiplication($expression);     return &Apache::response::implicit_multiplication($expression);
Line 288  sub r_run { Line 343  sub r_run {
 }  }
   
 sub r_eval {  sub r_eval {
     my ($script,$libraries) = @_;      my ($script,$libraries,$hashflag) = @_;
     my $socket=&connect();      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);      &disconnect($socket);
     return $reply;      return ($reply,$dump);
 }  }
   
   
Removed from v.1.5  
changed lines
  Added in v.1.12

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>