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

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.479 and 1.488

version 1.479, 2004/03/19 16:45:25 version 1.488, 2004/04/23 19:36:46
Line 32  package Apache::lonnet; Line 32  package Apache::lonnet;
 use strict;  use strict;
 use LWP::UserAgent();  use LWP::UserAgent();
 use HTTP::Headers;  use HTTP::Headers;
   use HTTP::Date;
   # use Date::Parse;
 use vars   use vars 
 qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom   qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
    %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache     %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
Line 615  sub idput { Line 617  sub idput {
     my ($udom,%ids)=@_;      my ($udom,%ids)=@_;
     my %servers=();      my %servers=();
     foreach (keys %ids) {      foreach (keys %ids) {
    &cput('environment',{'id'=>$ids{$_}},$udom,$_);
         my $uhom=&homeserver($_,$udom);          my $uhom=&homeserver($_,$udom);
         if ($uhom ne 'no_host') {          if ($uhom ne 'no_host') {
             my $id=&escape($ids{$_});              my $id=&escape($ids{$_});
Line 625  sub idput { Line 628  sub idput {
             } else {              } else {
                 $servers{$uhom}=$id.'='.$unam;                  $servers{$uhom}=$id.'='.$unam;
             }              }
             &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom);  
         }          }
     }      }
     foreach (keys %servers) {      foreach (keys %servers) {
Line 1185  sub tokenwrapper { Line 1187  sub tokenwrapper {
 # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course  # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
 # input: action, courseID, current domain, home server for course, intended  # input: action, courseID, current domain, home server for course, intended
 #        path to file, source of file.  #        path to file, source of file.
 # output: ok if successful, diagnostic message otherwise  # output: url to file (if action was uploaddoc), 
   #         ok if successful, or diagnostic message otherwise (if action was propagate or copy)
 #  #
 # Allows directory structure to be used within lonUsers/../userfiles/ for a   # Allows directory structure to be used within lonUsers/../userfiles/ for a 
 # course.  # course.
Line 1200  sub tokenwrapper { Line 1203  sub tokenwrapper {
 #         and will then be copied to  #         and will then be copied to
 #          /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in  #          /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in
 #         course's home server.  #         course's home server.
   #
   # action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
   #         will be retrived from $ENV{form.uploaddoc} (from DOCS interface) to
   #         /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
   #         and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file
   #         in course's home server.
   
   
 sub process_coursefile {  sub process_coursefile {
     my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_;      my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_;
Line 1207  sub process_coursefile { Line 1217  sub process_coursefile {
     if ($action eq 'propagate') {      if ($action eq 'propagate') {
         $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file          $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file
                             ,$docuhome);                              ,$docuhome);
     } elsif ($action eq 'copy') {      } else {
         my $fetchresult = '';          my $fetchresult = '';
         my $fpath = '';          my $fpath = '';
         my $fname = $file;          my $fname = $file;
Line 1223  sub process_coursefile { Line 1233  sub process_coursefile {
                 }                  }
             }              }
         }          }
         if ($source eq '') {          if ($action eq 'copy') {
             $fetchresult = 'no source file';              if ($source eq '') {
         } else {                  $fetchresult = 'no source file';
             my $destination = $filepath.'/'.$fname;                  return $fetchresult;
             print STDERR "Getting ready to rename $source to $destination\n";              } else {
             rename($source,$destination);                  my $destination = $filepath.'/'.$fname;
                   rename($source,$destination);
                   $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
                                    $docuhome);
               }
           } elsif ($action eq 'uploaddoc') {
               open(my $fh,'>'.$filepath.'/'.$fname);
               print $fh $ENV{'form.'.$source};
               close($fh);
             $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,              $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
                                  $docuhome);                                   $docuhome);
               if ($fetchresult eq 'ok') {
                   return '/uploaded/'.$fpath.'/'.$fname;
               } else {
                   &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
                           ' to host '.$docuhome.': '.$fetchresult);
                   return '/adm/notfound.html';
               }
         }          }
     }      }
     unless ( ($fetchresult eq 'ok') || ($fetchresult eq 'no source file') ) {      unless ( $fetchresult eq 'ok') {
         &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.          &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
              ' to host '.$docuhome.': '.$fetchresult);               ' to host '.$docuhome.': '.$fetchresult);
     }      }
Line 1266  sub userfileupload { Line 1291  sub userfileupload {
  $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};   $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};
  $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};   $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
  $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};   $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
           if ($ENV{'form.folder'} =~ m/^default/) {
               return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
           } else {
               $fname=$ENV{'form.folder'}.'/'.$fname;
               return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname);
           }
     } else {      } else {
         $docuname=$ENV{'user.name'};          $docuname=$ENV{'user.name'};
         $docudom=$ENV{'user.domain'};          $docudom=$ENV{'user.domain'};
         $docuhome=$ENV{'user.home'};          $docuhome=$ENV{'user.home'};
           return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
     }      }
     return   
         &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);  
 }  }
   
 sub finishuserfileupload {  sub finishuserfileupload {
Line 3277  sub modify_student_enrollment { Line 3307  sub modify_student_enrollment {
     }      }
     my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,      my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,
                                                            $first,$middle);                                                             $first,$middle);
     my $value=&escape($uname.':'.$udom).'='.      my $reply=cput('classlist',
  &escape(join(':',$end,$start,$uid,$usec,$fullname,$type));     {"$uname:$udom" => 
     my $reply=critical('put:'.$cdom.':'.$cnum.':classlist:'.$value,$chome);   join(':',$end,$start,$uid,$usec,$fullname,$type) },
      $cdom,$cnum);
     unless (($reply eq 'ok') || ($reply eq 'delayed')) {      unless (($reply eq 'ok') || ($reply eq 'delayed')) {
  return 'error: '.$reply;   return 'error: '.$reply;
     }      }
Line 4047  sub metadata { Line 4078  sub metadata {
 # the next is the end of "start tag"  # the next is the end of "start tag"
     }      }
  }   }
    my ($extension) = ($uri =~ /\.(\w+)$/);
    foreach my $key (sort(keys(%packagetab))) {
       #&logthis("extsion1 $extension $key !!");
       #no specific packages #how's our extension
       if ($key!~/^extension_\Q$extension\E&/) { next; }
       &metadata_create_package_def($uri,$key,'extension_'.$extension,
    \%metathesekeys);
    }
    if (!exists($metacache{$uri}->{':packages'})) {
       foreach my $key (sort(keys(%packagetab))) {
    #no specific packages well let's get default then
    if ($key!~/^default&/) { next; }
    &metadata_create_package_def($uri,$key,'default',
        \%metathesekeys);
       }
    }
 # are there custom rights to evaluate  # are there custom rights to evaluate
  if ($metacache{$uri}->{':copyright'} eq 'custom') {   if ($metacache{$uri}->{':copyright'} eq 'custom') {
   
Line 4075  sub metadata { Line 4122  sub metadata {
     return $metacache{$uri}->{':'.$what};      return $metacache{$uri}->{':'.$what};
 }  }
   
   sub metadata_create_package_def {
       my ($uri,$key,$package,$metathesekeys)=@_;
       my ($pack,$name,$subp)=split(/\&/,$key);
       if ($subp eq 'default') { next; }
       
       if (defined($metacache{$uri}->{':packages'})) {
    $metacache{$uri}->{':packages'}.=','.$package;
       } else {
    $metacache{$uri}->{':packages'}=$package;
       }
       my $value=$packagetab{$key};
       my $unikey;
       $unikey='parameter_0_'.$name;
       $metacache{$uri}->{':'.$unikey.'.part'}=0;
       $$metathesekeys{$unikey}=1;
       unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
    $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
       }
       if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
    $metacache{$uri}->{':'.$unikey}=
       $metacache{$uri}->{':'.$unikey.'.default'};
       }
   }
   
 sub metadata_generate_part0 {  sub metadata_generate_part0 {
     my ($metadata,$metacache,$uri) = @_;      my ($metadata,$metacache,$uri) = @_;
     my %allnames;      my %allnames;
Line 4267  sub symbread { Line 4338  sub symbread {
     my %bighash;      my %bighash;
     my $syval='';      my $syval='';
     if (($ENV{'request.course.fn'}) && ($thisfn)) {      if (($ENV{'request.course.fn'}) && ($thisfn)) {
           my $targetfn = $thisfn;
           if ( ($thisfn =~ m/^uploaded\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {
               $targetfn = 'adm/wrapper/'.$thisfn;
           }
         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',          if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
                       &GDBM_READER(),0640)) {                        &GDBM_READER(),0640)) {
     $syval=$hash{$thisfn};      $syval=$hash{$targetfn};
             untie(%hash);              untie(%hash);
         }          }
 # ---------------------------------------------------------- There was an entry  # ---------------------------------------------------------- There was an entry
Line 4321  sub symbread { Line 4396  sub symbread {
                  }                   }
       }        }
               untie(%bighash)                untie(%bighash)
            }              }
         }          }
         if ($syval) {          if ($syval) {
            return &symbclean($syval.'___'.$thisfn);              return &symbclean($syval.'___'.$thisfn); 
Line 4345  sub numval { Line 4420  sub numval {
     return int($txt);      return int($txt);
 }  }
   
   sub numval2 {
       my $txt=shift;
       $txt=~tr/A-J/0-9/;
       $txt=~tr/a-j/0-9/;
       $txt=~tr/K-T/0-9/;
       $txt=~tr/k-t/0-9/;
       $txt=~tr/U-Z/0-5/;
       $txt=~tr/u-z/0-5/;
       $txt=~s/\D//g;
       my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
       my $total;
       foreach my $val (@txts) { $total+=$val; }
       return int($total);
   }
   
 sub latest_rnd_algorithm_id {  sub latest_rnd_algorithm_id {
     return '64bit2';      return '64bit2';
 }  }
Line 4360  sub rndseed { Line 4450  sub rndseed {
     if (!$domain) { $domain=$wdomain; }      if (!$domain) { $domain=$wdomain; }
     if (!$username) { $username=$wusername }      if (!$username) { $username=$wusername }
     my $which=$ENV{"course.$courseid.rndseed"};      my $which=$ENV{"course.$courseid.rndseed"};
     my $CODE=$ENV{'scantron.CODE'};      my $CODE=$ENV{'form.CODE'};
     if (defined($CODE)) {      if (defined($CODE)) {
  &rndseed_CODE_64bit($symb,$courseid,$domain,$username);   return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
     } elsif ($which eq '64bit2') {      } elsif ($which eq '64bit2') {
  return &rndseed_64bit2($symb,$courseid,$domain,$username);   return &rndseed_64bit2($symb,$courseid,$domain,$username);
     } elsif ($which eq '64bit') {      } elsif ($which eq '64bit') {
Line 4435  sub rndseed_CODE_64bit { Line 4525  sub rndseed_CODE_64bit {
     {      {
  use integer;   use integer;
  my $symbchck=unpack("%32S*",$symb.' ') << 16;   my $symbchck=unpack("%32S*",$symb.' ') << 16;
  my $symbseed=numval($symb);   my $symbseed=numval2($symb);
  my $CODEseed=numval($ENV{'scantron.CODE'}) << 16;   my $CODEchck=unpack("%32S*",$ENV{'form.CODE'}.' ') << 16;
    my $CODEseed=numval($ENV{'form.CODE'});
  my $courseseed=unpack("%32S*",$courseid.' ');   my $courseseed=unpack("%32S*",$courseid.' ');
  my $num1=$symbseed+$CODEseed;   my $num1=$symbseed+$CODEchck;
  my $num2=$courseseed+$symbchck;   my $num2=$CODEseed+$courseseed+$symbchck;
  #&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck");   #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
  #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");   #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
  return "$num1,$num2";   return "$num1,$num2";
     }      }
Line 4460  sub latest_receipt_algorithm_id { Line 4551  sub latest_receipt_algorithm_id {
     return 'receipt2';      return 'receipt2';
 }  }
   
   sub recunique {
       my $fucourseid=shift;
       my $unique;
       if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') {
    $unique=$ENV{"course.$fucourseid.internal.encseed"};
       } else {
    $unique=$perlvar{'lonReceipt'};
       }
       return unpack("%32C*",$unique);
   }
   
   sub recprefix {
       my $fucourseid=shift;
       my $prefix;
       if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') {
    $prefix=$ENV{"course.$fucourseid.internal.encpref"};
       } else {
    $prefix=$perlvar{'lonHostID'};
       }
       return unpack("%32C*",$prefix);
   }
   
 sub ireceipt {  sub ireceipt {
     my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;      my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;
     my $cuname=unpack("%32C*",$funame);      my $cuname=unpack("%32C*",$funame);
     my $cudom=unpack("%32C*",$fudom);      my $cudom=unpack("%32C*",$fudom);
     my $cucourseid=unpack("%32C*",$fucourseid);      my $cucourseid=unpack("%32C*",$fucourseid);
     my $cusymb=unpack("%32C*",$fusymb);      my $cusymb=unpack("%32C*",$fusymb);
     my $cunique=unpack("%32C*",$perlvar{'lonReceipt'});      my $cunique=&recunique($fucourseid);
     my $cpart=unpack("%32S*",$part);      my $cpart=unpack("%32S*",$part);
     my $return =unpack("%32C*",$perlvar{'lonHostID'}).'-';      my $return =&recprefix($fucourseid).'-';
     if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2' ||      if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
  $ENV{'request.state'} eq 'construct') {   $ENV{'request.state'} eq 'construct') {
  &Apache::lonxml::debug("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname).   &Apache::lonxml::debug("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname).
Line 4502  sub receipt { Line 4615  sub receipt {
 # ------------------------------------------------------------ Serves up a file  # ------------------------------------------------------------ Serves up a file
 # returns either the contents of the file or   # returns either the contents of the file or 
 # -1 if the file doesn't exist  # -1 if the file doesn't exist
 # -2 if an error occured when trying to aqcuire the file  #
   # if the target is a file that was uploaded via DOCS, 
   # a check will be made to see if a current copy exists on the local server,
   # if it does this will be served, otherwise a copy will be retrieved from
   # the home server for the course and stored in /home/httpd/html/userfiles on
   # the local server.   
   
 sub getfile {  sub getfile {
     my $file=shift;      my ($file,$caller) = @_;
     if ($file=~/^\/*uploaded\//) { # user file  
  my $ua=new LWP::UserAgent;      if ($file !~ m|^/*uploaded/(\w+)/(\w+)/(.+)$|) {
  my $request=new HTTP::Request('GET',&tokenwrapper($file));   # normal file from res space
  my $response=$ua->request($request);   &repcopy($file);
  if ($response->is_success()) {          return &readfile($file);
     return $response->content;      }
  } else {   
     #&logthis("Return Code is ".$response->code." for $file ".      my $info;
     #         &tokenwrapper($file));      my $cdom = $1;
     # 500 for ISE when tokenwrapper can't figure out what server to      my $cnum = $2;
             #  contact      my $filename = $3;
             # 503 when lonuploadacc can't contact the requested server      my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles';
     if ($response->code eq 503 || $response->code eq 500) {      my ($lwpresp,$rtncode);
  return -2;      my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename;
     } else {      if (-e "$localfile") {
  return -1;   my @fileinfo = stat($localfile);
    $lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode);
    if ($lwpresp ne 'ok') {
       if ($rtncode eq '404') {
    unlink($localfile);
     }      }
       return -1;
  }   }
     } else { # normal file from res space   if ($info < $fileinfo[9]) {
  &repcopy($file);      return &readfile($localfile);
  if (! -e $file ) { return -1; };   }
  my $fh;   $info = '';
  open($fh,"<$file");   $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);
  my $a='';   if ($lwpresp ne 'ok') {
  while (<$fh>) { $a .=$_; }      return -1;
  return $a;   }
       } else {
    $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);
    if ($lwpresp ne 'ok') {
       return -1;
    }
    my @parts = ($cdom,$cnum); 
    if ($filename =~ m|^(.+)/[^/]+$|) {
       push @parts, split(/\//,$1);
       }
    foreach my $part (@parts) {
       $path .= '/'.$part;
       if (!-e $path) {
    mkdir($path,0770);
       }
    }
       }
       open (FILE,">$localfile");
       print FILE $info;
       close(FILE);
       if ($caller eq 'uploadrep') {
    return 'ok';
       }
       return $info;
   }
   
   sub getuploaded {
       my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
       $uri=~s/^\///;
       $uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri;
       my $ua=new LWP::UserAgent;
       my $request=new HTTP::Request($reqtype,$uri);
       my $response=$ua->request($request);
       $$rtncode = $response->code;
       if (! $response->is_success()) {
    return 'failed';
       }      
       if ($reqtype eq 'HEAD') {
    $$info = &HTTP::Date::str2time( $response->header('Last-modified') );
       } elsif ($reqtype eq 'GET') {
    $$info = $response->content;
     }      }
       return 'ok';
   }
   
   sub readfile {
       my $file = shift;
       if ( (! -e $file ) || ($file eq '') ) { return -1; };
       my $fh;
       open($fh,"<$file");
       my $a='';
       while (<$fh>) { $a .=$_; }
       return $a;
 }  }
   
 sub filelocation {  sub filelocation {
Line 4675  BEGIN { Line 4849  BEGIN {
     open(my $config,"</etc/httpd/conf/loncapa.conf");      open(my $config,"</etc/httpd/conf/loncapa.conf");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
         if ($configline =~ /^[^\#]*PerlSetVar/) {          if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) {
    my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);     my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
            chomp($varvalue);             chomp($varvalue);
            $perlvar{$varname}=$varvalue;             $perlvar{$varname}=$varvalue;
Line 4793  BEGIN { Line 4967  BEGIN {
     open(my $config,"<$perlvar{'lonTabDir'}/packages.tab");      open(my $config,"<$perlvar{'lonTabDir'}/packages.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
    if ($configline !~ /\S/ || $configline=~/^#/) { next; }
  chomp($configline);   chomp($configline);
  my ($short,$plain)=split(/:/,$configline);   my ($short,$plain)=split(/:/,$configline);
  my ($pack,$name)=split(/\&/,$short);   my ($pack,$name)=split(/\&/,$short);
Line 5538  messages of critical importance should g Line 5713  messages of critical importance should g
   
 =item *  =item *
   
 getfile($file) : returns the entire contents of a file or -1; it  getfile($file,$caller) : two cases - requests for files in /res or in /uploaded.
 properly subscribes to and replicates the file if neccessary.  (a) files in /uploaded
     (i) If a local copy of the file exists - 
         compares modification date of local copy with last-modified date for 
         definitive version stored on home server for course. If local copy is 
         stale, requests a new version from the home server and stores it. 
         If the original has been removed from the home server, then local copy 
         is unlinked.
     (ii) If local copy does not exist -
         requests the file from the home server and stores it. 
     
     If $caller is 'uploadrep':  
       This indicates a call from lonuploadrep.pm (PerlHeaderParserHandler phase)
       for request for files originally uploaded via DOCS. 
        - returns 'ok' if fresh local copy now available, -1 otherwise.
     
     Otherwise:
        This indicates a call from the content generation phase of the request.
        -  returns the entire contents of the file or -1.
        
   (b) files in /res
      - returns the entire contents of a file or -1; 
      it properly subscribes to and replicates the file if neccessary.
   
 =item *  =item *
   
Removed from v.1.479  
changed lines
  Added in v.1.488

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