[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.6

version 1.5, 2009/06/19 14:03:19 version 1.6, 2009/06/23 03:01:15
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  
   ### 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='';  my $errormsg='';
   
Line 101  sub Rpeel { Line 105  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
       } 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 260  sub runscript { Line 283  sub runscript {
     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.');'."\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 {  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 340  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.6

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