[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.724 and 1.734

version 1.724, 2006/03/29 19:56:36 version 1.734, 2006/05/01 16:00:44
Line 45  qw(%perlvar %hostname %badServerCache %i Line 45  qw(%perlvar %hostname %badServerCache %i
   
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
 use Apache::Constants qw(:common :http);  
 use HTML::LCParser;  use HTML::LCParser;
 use HTML::Parser;  use HTML::Parser;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
Line 86  delayed. Line 85  delayed.
   
   
 # --------------------------------------------------------------------- Logging  # --------------------------------------------------------------------- Logging
   {
       my $logid;
       sub instructor_log {
    my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;
    $logid++;
    my $id=time().'00000'.$$.'00000'.$logid;
    return &Apache::lonnet::put('nohist_'.$hash_name,
       { $id => {
    'exe_uname' => $env{'user.name'},
    'exe_udom'  => $env{'user.domain'},
    'exe_time'  => time(),
    'exe_ip'    => $ENV{'REMOTE_ADDR'},
    'delflag'   => $delflag,
    'logentry'  => $storehash,
    'uname'     => $uname,
    'udom'      => $udom,
       }
     },
       $env{'course.'.$env{'request.course.id'}.'.domain'},
       $env{'course.'.$env{'request.course.id'}.'.num'}
       );
       }
   }
   
 sub logtouch {  sub logtouch {
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
Line 279  sub transfer_profile_to_env { Line 301  sub transfer_profile_to_env {
     for ($envi=0;$envi<=$#profile;$envi++) {      for ($envi=0;$envi<=$#profile;$envi++) {
  chomp($profile[$envi]);   chomp($profile[$envi]);
  my ($envname,$envvalue)=split(/=/,$profile[$envi],2);   my ($envname,$envvalue)=split(/=/,$profile[$envi],2);
    $envname=&unescape($envname);
    $envvalue=&unescape($envvalue);
  $env{$envname} = $envvalue;   $env{$envname} = $envvalue;
         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {          if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
             if ($time < time-300) {              if ($time < time-300) {
Line 331  sub appenv { Line 355  sub appenv {
         chomp($oldenv[$i]);          chomp($oldenv[$i]);
         if ($oldenv[$i] ne '') {          if ($oldenv[$i] ne '') {
     my ($name,$value)=split(/=/,$oldenv[$i],2);      my ($name,$value)=split(/=/,$oldenv[$i],2);
       $name=&unescape($name);
       $value=&unescape($value);
     unless (defined($newenv{$name})) {      unless (defined($newenv{$name})) {
  $newenv{$name}=$value;   $newenv{$name}=$value;
     }      }
Line 343  sub appenv { Line 369  sub appenv {
  }   }
  my $newname;   my $newname;
  foreach $newname (keys %newenv) {   foreach $newname (keys %newenv) {
     print $fh "$newname=$newenv{$newname}\n";      print $fh &escape($newname).'='.&escape($newenv{$newname})."\n";
  }   }
  close($fh);   close($fh);
     }      }
Line 355  sub appenv { Line 381  sub appenv {
   
 sub delenv {  sub delenv {
     my $delthis=shift;      my $delthis=shift;
     my %newenv=();  
     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {      if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
         &logthis("<font color=\"blue\">WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
                 "Attempt to delete from environment ".$delthis);                  "Attempt to delete from environment ".$delthis);
Line 388  sub delenv { Line 413  sub delenv {
     return 'error: '.$!;      return 'error: '.$!;
  }   }
  foreach my $cur_key (@oldenv) {   foreach my $cur_key (@oldenv) {
     if ($cur_key=~/^$delthis/) {       my $unescaped_cur_key = &unescape($cur_key);
                 my ($key,undef) = split('=',$cur_key,2);      if ($unescaped_cur_key=~/^$delthis/) { 
                   my ($key) = split('=',$cur_key,2);
    $key = &unescape($key);
                 delete($env{$key});                  delete($env{$key});
             } else {              } else {
                 print $fh $cur_key;                   print $fh $cur_key; 
Line 847  sub getsection { Line 874  sub getsection {
 }  }
   
 sub save_cache {  sub save_cache {
     my ($r)=@_;  
     if (! $r->is_initial_req()) { return DECLINED; }  
     &purge_remembered();      &purge_remembered();
     #&Apache::loncommon::validate_page();      #&Apache::loncommon::validate_page();
     undef(%env);      undef(%env);
     return OK;  
 }  }
   
 my $to_remember=-1;  my $to_remember=-1;
Line 2576  sub restore { Line 2600  sub restore {
 # ---------------------------------------------------------- Course Description  # ---------------------------------------------------------- Course Description
   
 sub coursedescription {  sub coursedescription {
     my $courseid=shift;      my ($courseid,$args)=@_;
     $courseid=~s/^\///;      $courseid=~s/^\///;
     $courseid=~s/\_/\//g;      $courseid=~s/\_/\//g;
     my ($cdomain,$cnum)=split(/\//,$courseid);      my ($cdomain,$cnum)=split(/\//,$courseid);
Line 2586  sub coursedescription { Line 2610  sub coursedescription {
     # trying and trying and trying to get the course description.      # trying and trying and trying to get the course description.
     my %envhash=();      my %envhash=();
     my %returnhash=();      my %returnhash=();
     $envhash{'course.'.$normalid.'.last_cache'}=time;      
       my $expiretime=600;
       if ($env{'request.course.id'} eq $normalid) {
    $expiretime=120;
       }
   
       my $prefix='course.'.$cdomain.'_'.$cnum.'.';
       if (!$args->{'freshen_cache'}
    && ((time-$env{$prefix.'last_cache'}) < $expiretime) ) {
    foreach my $key (keys(%env)) {
       next if ($key !~ /^\Q$prefix\E(.*)/);
       my ($setting) = $1;
       $returnhash{$setting} = $env{$key};
    }
    return %returnhash;
       }
   
       # get the data agin
       if (!$args->{'one_time'}) {
    $envhash{'course.'.$normalid.'.last_cache'}=time;
       }
     if ($chome ne 'no_host') {      if ($chome ne 'no_host') {
        %returnhash=&dump('environment',$cdomain,$cnum);         %returnhash=&dump('environment',$cdomain,$cnum);
        if (!exists($returnhash{'con_lost'})) {         if (!exists($returnhash{'con_lost'})) {
Line 2604  sub coursedescription { Line 2648  sub coursedescription {
            $envhash{'course.'.$normalid.'.num'}=$cnum;             $envhash{'course.'.$normalid.'.num'}=$cnum;
        }         }
     }      }
     &appenv(%envhash);      if (!$args->{'one_time'}) {
    &appenv(%envhash);
       }
     return %returnhash;      return %returnhash;
 }  }
   
Line 3424  sub allowed { Line 3470  sub allowed {
        my ($cdom,$cnum,$csec)=split(/\//,$courseid);         my ($cdom,$cnum,$csec)=split(/\//,$courseid);
                my $prefix='course.'.$cdom.'_'.$cnum.'.';                 my $prefix='course.'.$cdom.'_'.$cnum.'.';
                if ((time-$env{$prefix.'last_cache'})>$expiretime) {                 if ((time-$env{$prefix.'last_cache'})>$expiretime) {
    &coursedescription($courseid);     &coursedescription($courseid,{'freshen_cache' => 1});
                }                 }
                if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)                 if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)
                 || ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {                  || ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
Line 3970  sub get_group_membership { Line 4016  sub get_group_membership {
   
 sub get_users_groups {  sub get_users_groups {
     my ($udom,$uname,$courseid) = @_;      my ($udom,$uname,$courseid) = @_;
       my @usersgroups;
     my $cachetime=1800;      my $cachetime=1800;
     $courseid=~s/\_/\//g;      $courseid=~s/\_/\//g;
     $courseid=~s/^(\w)/\/$1/;      $courseid=~s/^(\w)/\/$1/;
   
     my $hashid="$udom:$uname:$courseid";      my $hashid="$udom:$uname:$courseid";
     my ($result,$cached)=&is_cached_new('getgroups',$hashid);      my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
     if (defined($cached)) { return $result; }      if (defined($cached)) {
           @usersgroups = split(/:/,$grouplist);
     my %roleshash = &dump('roles',$udom,$uname,$courseid);      } else {  
     my ($tmp) = keys(%roleshash);          $grouplist = '';
     if ($tmp=~/^error:/) {          my %roleshash = &dump('roles',$udom,$uname,$courseid);
         &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);          my ($tmp) = keys(%roleshash);
         return '';          if ($tmp=~/^error:/) {
     } else {              &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);
         my $grouplist;          } else {
         foreach my $key (keys %roleshash) {              my $access_end = $env{'course.'.$courseid.
             if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {                                    '.default_enrollment_end_date'};
                 unless ($roleshash{$key} =~ /_1_1$/) {   # deleted membership              my $now = time;
                     $grouplist .= $1.':';              foreach my $key (keys(%roleshash)) {
                   if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
                       my $group = $1;
                       if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
                           my $start = $2;
                           my $end = $1;
                           if ($start == -1) { next; } # deleted from group
                           if (($start!=0) && ($start>$now)) { next; }
                           if (($end!=0) && ($end<$now)) {
                               if ($access_end && $access_end < $now) {
                                   if ($access_end - $end < 86400) {
                                       push(@usersgroups,$group);
                                   }
                               }
                               next;
                           }
                           push(@usersgroups,$group);
                       }
                 }                  }
             }              }
               @usersgroups = &sort_course_groups($courseid,@usersgroups);
               $grouplist = join(':',@usersgroups);
               &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
         }          }
         $grouplist =~ s/:$//;  
         return &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);  
     }      }
       return @usersgroups;
 }  }
   
 sub devalidate_getgroups_cache {  sub devalidate_getgroups_cache {
Line 5113  sub EXT { Line 5179  sub EXT {
     if (($env{'user.name'} eq $uname) &&      if (($env{'user.name'} eq $uname) &&
  ($env{'user.domain'} eq $udom)) {   ($env{'user.domain'} eq $udom)) {
  $section=$env{'request.course.sec'};   $section=$env{'request.course.sec'};
                 @groups=&sort_course_groups($env{'request.course.groups'},$courseid);                   @groups = split(/:/,$env{'request.course.groups'});  
                 if (@groups > 0) {                  @groups=&sort_course_groups($courseid,@groups); 
                     @groups = sort(@groups);  
                 }  
     } else {      } else {
  if (! defined($usection)) {   if (! defined($usection)) {
     $section=&getsection($udom,$uname,$courseid);      $section=&getsection($udom,$uname,$courseid);
  } else {   } else {
     $section = $usection;      $section = $usection;
  }   }
                 my $grouplist = &get_users_groups($udom,$uname,$courseid);                  @groups = &get_users_groups($udom,$uname,$courseid);
                 if ($grouplist) {  
                     @groups=&sort_course_groups($grouplist,$courseid);  
                 }  
     }      }
   
     my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;      my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
Line 5250  sub check_group_parms { Line 5311  sub check_group_parms {
 }  }
   
 sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().  sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
     my ($grouplist,$courseid) = @_;      my ($courseid,@groups) = @_;
     my @groups = sort(split(/:/,$grouplist));      @groups = sort(@groups);
     return @groups;      return @groups;
 }  }
   
Line 6523  sub goodbye { Line 6584  sub goodbye {
    &logthis(sprintf("%-20s is %s",'hits',$hits));     &logthis(sprintf("%-20s is %s",'hits',$hits));
    &flushcourselogs();     &flushcourselogs();
    &logthis("Shutting down");     &logthis("Shutting down");
    return DONE;  
 }  }
   
 BEGIN {  BEGIN {
Removed from v.1.724  
changed lines
  Added in v.1.734

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