[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.481 and 1.491

version 1.481, 2004/03/31 19:25:08 version 1.491, 2004/04/29 07:57:47
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 Date::Parse;  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 616  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 626  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 1186  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 1201  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  # action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
 #         will be retrived from $ENV{form.$source} via DOCS interface to  #         will be retrived from $ENV{form.uploaddoc} (from DOCS interface) to
 #         /home/httpd/html/userfiles/$domain/1/2/3/$course/$file  #         /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  #         and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file
 #         in course's home server.  #         in course's home server.
Line 1255  sub process_coursefile { Line 1258  sub process_coursefile {
             }              }
         }          }
     }      }
     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 1280  sub userfileupload { Line 1283  sub userfileupload {
 # See if there is anything left  # See if there is anything left
     unless ($fname) { return 'error: no uploaded file'; }      unless ($fname) { return 'error: no uploaded file'; }
     chop($ENV{'form.'.$formname});      chop($ENV{'form.'.$formname});
     my $url = '';  
 # Create the directory if not present  # Create the directory if not present
     my $docuname='';      my $docuname='';
     my $docudom='';      my $docudom='';
Line 1290  sub userfileupload { Line 1292  sub userfileupload {
  $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/) {          if ($ENV{'form.folder'} =~ m/^default/) {
             $url = &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);              return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
         } else {          } else {
             $fname=$ENV{'form.folder'}.'/'.$fname;              $fname=$ENV{'form.folder'}.'/'.$fname;
             $url = &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname);              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 1337  sub finishuserfileupload { Line 1338  sub finishuserfileupload {
     }          }    
 }  }
   
   sub removeuserfile {
       my ($docuname,$docudom,$fname)=@_;
       my $home=&homeserver($docuname,$docudom);
       return &reply("removeuserfile:$docudom/$docuname/$fname",$home);
   }
   
 # ------------------------------------------------------------------------- Log  # ------------------------------------------------------------------------- Log
   
 sub log {  sub log {
Line 3306  sub modify_student_enrollment { Line 3313  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 3936  sub metadata { Line 3944  sub metadata {
     # if it is a non metadata possible uri return quickly      # if it is a non metadata possible uri return quickly
     if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||      if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
  ($uri =~ m|home/[^/]+/public_html/|) || ($uri =~ m|^uploaded/|)) {   ($uri =~ m|home/[^/]+/public_html/|)) {
  return undef;   return undef;
     }      }
     my $filename=$uri;      my $filename=$uri;
Line 3965  sub metadata { Line 3973  sub metadata {
  }   }
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring=&getfile(&filelocation('',&clutter($filename)));   my $metastring;
    if ($uri !~ m|^uploaded/|) {
       $metastring=&getfile(&filelocation('',&clutter($filename)));
    }
         my $parser=HTML::LCParser->new(\$metastring);          my $parser=HTML::LCParser->new(\$metastring);
         my $token;          my $token;
         undef %metathesekeys;          undef %metathesekeys;
Line 4076  sub metadata { Line 4087  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 4104  sub metadata { Line 4131  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 4378  sub numval { Line 4429  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';
 }  }
   
   sub getCODE {
       if (defined($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; }
       if (defined($Apache::lonhomework::parsing_a_problem) &&
    defined($Apache::lonhomework::history{'resource.CODE'})) {
    return $Apache::lonhomework::history{'resource.CODE'};
       }
       return undef;
   }
   
 sub rndseed {  sub rndseed {
     my ($symb,$courseid,$domain,$username)=@_;      my ($symb,$courseid,$domain,$username)=@_;
   
Line 4393  sub rndseed { Line 4468  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'};      if (defined(&getCODE())) {
     if (defined($CODE)) {   return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
  &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 4468  sub rndseed_CODE_64bit { Line 4542  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*",&getCODE().' ') << 16;
    my $CODEseed=numval(&getCODE());
  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 4566  sub receipt { Line 4641  sub receipt {
   
 sub getfile {  sub getfile {
     my ($file,$caller) = @_;      my ($file,$caller) = @_;
     if ($file=~ m|^/*uploaded/(\w+)/(\w+)/(.+)$|) { # user file  
         my $info;      if ($file !~ m|^/*uploaded/(\w+)/(\w+)/(.+)$|) {
         my $cdom = $1;   # normal file from res space
         my $cnum = $2;  
         my $filename = $3;  
         my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles';  
         my ($lwpresp,$rtncode);  
         my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename;  
         if (-e "$localfile") {  
             my @fileinfo = stat($localfile);  
             $lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode);  
             if ($lwpresp eq 'ok') {  
                 if ($info > $fileinfo[9]) {  
                     $info = '';  
                     $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);  
                     if ($lwpresp eq 'ok') {  
                         open (FILE,">$localfile");  
                         print FILE $info;  
                         close(FILE);  
                         if ($caller eq 'uploadrep') {  
                             return 'ok';  
                         } else {  
                             return $info;  
                         }  
                     } else {  
                         return -1;  
                     }  
         } else {  
                     return &readfile($localfile);  
                 }  
             } else {  
                 if ($rtncode eq '404') {  
                     unlink($localfile);  
                 }  
                 return -1;  
             }  
  } else {  
             $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);  
             if ($lwpresp eq 'ok') {  
                 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';  
                 } else {  
                     return $info;  
                 }  
             } else {  
                 return -1;  
             }  
         }  
     } else { # normal file from res space  
  &repcopy($file);   &repcopy($file);
         return &readfile($file);          return &readfile($file);
     }      }
   
       my $info;
       my $cdom = $1;
       my $cnum = $2;
       my $filename = $3;
       my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles';
       my ($lwpresp,$rtncode);
       my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename;
       if (-e "$localfile") {
    my @fileinfo = stat($localfile);
    $lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode);
    if ($lwpresp ne 'ok') {
       if ($rtncode eq '404') {
    unlink($localfile);
       }
       return -1;
    }
    if ($info < $fileinfo[9]) {
       return &readfile($localfile);
    }
    $info = '';
    $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);
    if ($lwpresp ne 'ok') {
       return -1;
    }
       } 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 {  sub getuploaded {
Line 4641  sub getuploaded { Line 4705  sub getuploaded {
     my $request=new HTTP::Request($reqtype,$uri);      my $request=new HTTP::Request($reqtype,$uri);
     my $response=$ua->request($request);      my $response=$ua->request($request);
     $$rtncode = $response->code;      $$rtncode = $response->code;
     if ($response->is_success()) {      if (! $response->is_success()) {
         if ($reqtype eq 'HEAD') {   return 'failed';
             $$info = &Date::Parse::str2time( $response->header('Last-modified') );      }      
         } elsif ($reqtype eq 'GET') {      if ($reqtype eq 'HEAD') {
             $$info = $response->content;   $$info = &HTTP::Date::str2time( $response->header('Last-modified') );
         }      } elsif ($reqtype eq 'GET') {
         return 'ok';   $$info = $response->content;
     } else {  
         return 'failed';  
     }      }
       return 'ok';
 }  }
   
 sub readfile {  sub readfile {
Line 4803  BEGIN { Line 4866  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 4921  BEGIN { Line 4984  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);
Removed from v.1.481  
changed lines
  Added in v.1.491

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