[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.549 and 1.552

version 1.549, 2004/10/05 11:24:34 version 1.552, 2004/10/26 15:03:08
Line 39  qw(%perlvar %hostname %homecache %badSer Line 39  qw(%perlvar %hostname %homecache %badSer
    %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache     %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
    %courselogs %accesshash %userrolehash $processmarker $dumpcount      %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache      %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache 
    %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def      %userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def 
    %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);     %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);
   
 use IO::Socket;  use IO::Socket;
Line 52  use Apache::lonlocal; Line 52  use Apache::lonlocal;
 use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);  use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
 use Time::HiRes qw( gettimeofday tv_interval );  use Time::HiRes qw( gettimeofday tv_interval );
 my $readit;  my $readit;
   my $max_connection_retries = 10;     # Or some such value.
   
 =pod  =pod
   
Line 126  sub subreply { Line 127  sub subreply {
  sleep(1);   sleep(1);
     }      }
     # At this point, either a loncnew parent is listening or an old lonc      # At this point, either a loncnew parent is listening or an old lonc
     # or loncnew child is listening so we can connect.      # or loncnew child is listening so we can connect or everything's dead.
     #      #
     my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",      #   We'll give the connection a few tries before abandoning it.  If
                                      Type    => SOCK_STREAM,      #   connection is not possible, we'll con_lost back to the client.
                                      Timeout => 10)      #   
        or return "con_lost";      my $client;
     print $client "$cmd\n";      for (my $retries = 0; $retries < $max_connection_retries; $retries++) {
     my $answer=<$client>;   $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
     if (!$answer) { $answer="con_lost"; }        Type    => SOCK_STREAM,
     chomp($answer);        Timeout => 10);
    if($client) {
       last; # Connected!
    }
    sleep(1); # Try again later if failed connection.
       }
       my $answer;
       if ($client) {
    print $client "$cmd\n";
    $answer=<$client>;
    if (!$answer) { $answer="con_lost"; }
    chomp($answer);
       } else {
    $answer = 'con_lost'; # Failed connection.
       }
     return $answer;      return $answer;
 }  }
   
Line 783  sub getsection { Line 798  sub getsection {
     my ($udom,$unam,$courseid)=@_;      my ($udom,$unam,$courseid)=@_;
     $courseid=~s/\_/\//g;      $courseid=~s/\_/\//g;
     $courseid=~s/^(\w)/\/$1/;      $courseid=~s/^(\w)/\/$1/;
   
       my $hashid="$udom:$unam:$courseid";
       my ($result,$cached)=&is_cached(\%getsectioncache,$hashid,'getsection');
       if (defined($cached)) { return $result; }
   
     my %Pending;       my %Pending; 
     my %Expired;      my %Expired;
     #      #
Line 815  sub getsection { Line 835  sub getsection {
             $Pending{$start}=$section;              $Pending{$start}=$section;
             next;              next;
         }          }
         return $section;          return &do_cache(\%getsectioncache,$hashid,$section,'getsection');
     }      }
     #      #
     # Presumedly there will be few matching roles from the above      # Presumedly there will be few matching roles from the above
     # loop and the sorting time will be negligible.      # loop and the sorting time will be negligible.
     if (scalar(keys(%Pending))) {      if (scalar(keys(%Pending))) {
         my ($time) = sort {$a <=> $b} keys(%Pending);          my ($time) = sort {$a <=> $b} keys(%Pending);
         return $Pending{$time};          return &do_cache(\%getsectioncache,$hashid,$Pending{$time},'getsection');
     }       } 
     if (scalar(keys(%Expired))) {      if (scalar(keys(%Expired))) {
         my @sorted = sort {$a <=> $b} keys(%Expired);          my @sorted = sort {$a <=> $b} keys(%Expired);
         my $time = pop(@sorted);          my $time = pop(@sorted);
         return $Expired{$time};          return &do_cache(\%getsectioncache,$hashid,$Expired{$time},'getsection');
     }      }
     return '-1';      return &do_cache(\%getsectioncache,$hashid,'-1','getsection');
 }  }
   
   
 my $disk_caching_disabled=0;  my $disk_caching_disabled=1;
   
 sub devalidate_cache {  sub devalidate_cache {
     my ($cache,$id,$name) = @_;      my ($cache,$id,$name) = @_;
Line 1020  EVALBLOCK Line 1040  EVALBLOCK
 #    &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));  #    &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));
 }  }
   
 sub usection {  
     my ($udom,$unam,$courseid)=@_;  
     my $hashid="$udom:$unam:$courseid";  
       
     my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection');  
     if (defined($cached)) { return $result; }  
     $courseid=~s/\_/\//g;  
     $courseid=~s/^(\w)/\/$1/;  
     foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',  
                         &homeserver($unam,$udom)))) {  
         my ($key,$value)=split(/\=/,$_);  
         $key=&unescape($key);  
         if ($key=~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/) {  
             my $section=$1;  
             if ($key eq $courseid.'_st') { $section=''; }  
     my ($dummy,$end,$start)=split(/\_/,&unescape($value));  
             my $now=time;  
             my $notactive=0;  
             if ($start) {  
  if ($now<$start) { $notactive=1; }  
             }  
             if ($end) {  
                 if ($now>$end) { $notactive=1; }  
             }   
             unless ($notactive) {  
  return &do_cache(\%usectioncache,$hashid,$section,'usection');  
     }  
         }  
     }  
     return &do_cache(\%usectioncache,$hashid,'-1','usection');  
 }  
   
 # ------------------------------------- Read an entry from a user's environment  # ------------------------------------- Read an entry from a user's environment
   
 sub userenvironment {  sub userenvironment {
Line 4127  sub EXT { Line 4115  sub EXT {
  $section=$ENV{'request.course.sec'};   $section=$ENV{'request.course.sec'};
     } else {      } else {
  if (! defined($usection)) {   if (! defined($usection)) {
     $section=&usection($udom,$uname,$courseid);      $section=&getsection($udom,$uname,$courseid);
  } else {   } else {
     $section = $usection;      $section = $usection;
  }   }
Line 5103  sub repcopy_userfile { Line 5091  sub repcopy_userfile {
   
 sub tokenwrapper {  sub tokenwrapper {
     my $uri=shift;      my $uri=shift;
     $uri=~s/^http\:\/\/([^\/]+)//;      $uri=~s|^http\://([^/]+)||;
     $uri=~s/^\///;      $uri=~s|^/||;
     $ENV{'user.environment'}=~/\/([^\/]+)\.id/;      $ENV{'user.environment'}=~/\/([^\/]+)\.id/;
     my $token=$1;      my $token=$1;
     if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {      my (undef,$udom,$uname,$file)=split('/',$uri,4);
         &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});      if ($udom && $uname && $file) {
         return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.   $file=~s|(\?\.*)*$||;
           &appenv("userfile.$udom/$uname/$file" => $ENV{'request.course.id'});
           return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri.
                (($uri=~/\?/)?'&':'?').'token='.$token.                 (($uri=~/\?/)?'&':'?').'token='.$token.
                                '&tokenissued='.$perlvar{'lonHostID'};                                 '&tokenissued='.$perlvar{'lonHostID'};
     } else {      } else {
Line 5283  sub goodbye { Line 5273  sub goodbye {
    &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));     &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));
 #1.1 only  #1.1 only
    &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));     &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));
    &logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache)));     &logthis(sprintf("%-20s is %s",'%getsectioncache',scalar(%getsectioncache)));
    &logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));     &logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));
    &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache)));     &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache)));
    &flushcourselogs();     &flushcourselogs();
Line 5665  X<rolesinit()> Line 5655  X<rolesinit()>
 B<rolesinit($udom,$username,$authhost)>: get user privileges  B<rolesinit($udom,$username,$authhost)>: get user privileges
   
 =item *  =item *
 X<usection()>  X<getsection()>
 B<usection($udom,$uname,$cname)>: finds the section of student in the  B<getsection($udom,$uname,$cname)>: finds the section of student in the
 course $cname, return section name/number or '' for "not in course"  course $cname, return section name/number or '' for "not in course"
 and '-1' for "no section"  and '-1' for "no section"
   
Removed from v.1.549  
changed lines
  Added in v.1.552

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