--- loncom/lonnet/perl/lonnet.pm 2006/03/27 23:00:18 1.722 +++ loncom/lonnet/perl/lonnet.pm 2006/05/15 23:40:36 1.735 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.722 2006/03/27 23:00:18 albertel Exp $ +# $Id: lonnet.pm,v 1.735 2006/05/15 23:40:36 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -45,7 +45,6 @@ qw(%perlvar %hostname %badServerCache %i use IO::Socket; use GDBM_File; -use Apache::Constants qw(:common :http); use HTML::LCParser; use HTML::Parser; use Fcntl qw(:flock); @@ -86,6 +85,29 @@ delayed. # --------------------------------------------------------------------- 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 { my $execdir=$perlvar{'lonDaemons'}; @@ -279,6 +301,8 @@ sub transfer_profile_to_env { for ($envi=0;$envi<=$#profile;$envi++) { chomp($profile[$envi]); my ($envname,$envvalue)=split(/=/,$profile[$envi],2); + $envname=&unescape($envname); + $envvalue=&unescape($envvalue); $env{$envname} = $envvalue; if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { if ($time < time-300) { @@ -331,6 +355,8 @@ sub appenv { chomp($oldenv[$i]); if ($oldenv[$i] ne '') { my ($name,$value)=split(/=/,$oldenv[$i],2); + $name=&unescape($name); + $value=&unescape($value); unless (defined($newenv{$name})) { $newenv{$name}=$value; } @@ -343,7 +369,7 @@ sub appenv { } my $newname; foreach $newname (keys %newenv) { - print $fh "$newname=$newenv{$newname}\n"; + print $fh &escape($newname).'='.&escape($newenv{$newname})."\n"; } close($fh); } @@ -355,7 +381,6 @@ sub appenv { sub delenv { my $delthis=shift; - my %newenv=(); if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { &logthis("WARNING: ". "Attempt to delete from environment ".$delthis); @@ -388,8 +413,10 @@ sub delenv { return 'error: '.$!; } foreach my $cur_key (@oldenv) { - if ($cur_key=~/^$delthis/) { - my ($key,undef) = split('=',$cur_key,2); + my $unescaped_cur_key = &unescape($cur_key); + if ($unescaped_cur_key=~/^$delthis/) { + my ($key) = split('=',$cur_key,2); + $key = &unescape($key); delete($env{$key}); } else { print $fh $cur_key; @@ -847,12 +874,9 @@ sub getsection { } sub save_cache { - my ($r)=@_; - if (! $r->is_initial_req()) { return DECLINED; } &purge_remembered(); #&Apache::loncommon::validate_page(); undef(%env); - return OK; } my $to_remember=-1; @@ -1004,13 +1028,13 @@ sub retrievestudentphoto { # -------------------------------------------------------------------- New chat sub chatsend { - my ($newentry,$anon)=@_; + my ($newentry,$anon,$group)=@_; my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'}; my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'}; my $chome=$env{'course.'.$env{'request.course.id'}.'.home'}; &reply('chatsend:'.$cdom.':'.$cnum.':'. &escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'. - &escape($newentry)),$chome); + &escape($newentry)).':'.$group,$chome); } # ------------------------------------------ Find current version of a resource @@ -2576,7 +2600,7 @@ sub restore { # ---------------------------------------------------------- Course Description sub coursedescription { - my $courseid=shift; + my ($courseid,$args)=@_; $courseid=~s/^\///; $courseid=~s/\_/\//g; my ($cdomain,$cnum)=split(/\//,$courseid); @@ -2586,7 +2610,27 @@ sub coursedescription { # trying and trying and trying to get the course description. my %envhash=(); 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') { %returnhash=&dump('environment',$cdomain,$cnum); if (!exists($returnhash{'con_lost'})) { @@ -2604,7 +2648,9 @@ sub coursedescription { $envhash{'course.'.$normalid.'.num'}=$cnum; } } - &appenv(%envhash); + if (!$args->{'one_time'}) { + &appenv(%envhash); + } return %returnhash; } @@ -3424,7 +3470,7 @@ sub allowed { my ($cdom,$cnum,$csec)=split(/\//,$courseid); my $prefix='course.'.$cdom.'_'.$cnum.'.'; if ((time-$env{$prefix.'last_cache'})>$expiretime) { - &coursedescription($courseid); + &coursedescription($courseid,{'freshen_cache' => 1}); } if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/) || ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) { @@ -3970,31 +4016,51 @@ sub get_group_membership { sub get_users_groups { my ($udom,$uname,$courseid) = @_; + my @usersgroups; my $cachetime=1800; $courseid=~s/\_/\//g; $courseid=~s/^(\w)/\/$1/; my $hashid="$udom:$uname:$courseid"; - my ($result,$cached)=&is_cached_new('getgroups',$hashid); - if (defined($cached)) { return $result; } - - my %roleshash = &dump('roles',$udom,$uname,$courseid); - my ($tmp) = keys(%roleshash); - if ($tmp=~/^error:/) { - &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom); - return ''; - } else { - my $grouplist; - foreach my $key (keys %roleshash) { - if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) { - unless ($roleshash{$key} =~ /_1_1$/) { # deleted membership - $grouplist .= $1.':'; + my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid); + if (defined($cached)) { + @usersgroups = split(/:/,$grouplist); + } else { + $grouplist = ''; + my %roleshash = &dump('roles',$udom,$uname,$courseid); + my ($tmp) = keys(%roleshash); + if ($tmp=~/^error:/) { + &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom); + } else { + my $access_end = $env{'course.'.$courseid. + '.default_enrollment_end_date'}; + my $now = time; + 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 { @@ -4743,11 +4809,10 @@ sub stat_file { $uri = &clutter($uri); # we want just the url part without the unneeded accessor url bits - if ($file =~ m-^/adm/-) { - $file=~s-^/adm/wrapper/-/-; - $file=~s-^/adm/coursedocs/showdoc/-/-; + if ($uri =~ m-^/adm/-) { + $uri=~s-^/adm/wrapper/-/-; + $uri=~s-^/adm/coursedocs/showdoc/-/-; } - my ($udom,$uname,$file,$dir); if ($uri =~ m-^/(uploaded|editupload)/-) { ($udom,$uname,$file) = @@ -5106,7 +5171,7 @@ sub EXT { # ----------------------------------------------------- Cascading lookup scheme my $symbp=$symbparm; - my $mapp=(&decode_symb($symbp))[0]; + my $mapp=&deversion((&decode_symb($symbp))[0]); my $symbparm=$symbp.'.'.$spacequalifierrest; my $mapparm=$mapp.'___(all).'.$spacequalifierrest; @@ -5114,20 +5179,15 @@ sub EXT { if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { $section=$env{'request.course.sec'}; - @groups=&sort_course_groups($env{'request.course.groups'},$courseid); - if (@groups > 0) { - @groups = sort(@groups); - } + @groups = split(/:/,$env{'request.course.groups'}); + @groups=&sort_course_groups($courseid,@groups); } else { if (! defined($usection)) { $section=&getsection($udom,$uname,$courseid); } else { $section = $usection; } - my $grouplist = &get_users_groups($udom,$uname,$courseid); - if ($grouplist) { - @groups=&sort_course_groups($grouplist,$courseid); - } + @groups = &get_users_groups($udom,$uname,$courseid); } my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; @@ -5251,8 +5311,8 @@ sub check_group_parms { } sub sort_course_groups { # Sort groups based on defined rankings. Default is sort(). - my ($grouplist,$courseid) = @_; - my @groups = sort(split(/:/,$grouplist)); + my ($courseid,@groups) = @_; + @groups = sort(@groups); return @groups; } @@ -6524,7 +6584,6 @@ sub goodbye { &logthis(sprintf("%-20s is %s",'hits',$hits)); &flushcourselogs(); &logthis("Shutting down"); - return DONE; } BEGIN {