--- loncom/lonnet/perl/lonnet.pm 2006/04/07 22:42:32 1.728 +++ loncom/lonnet/perl/lonnet.pm 2006/05/16 18:24:58 1.737 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.728 2006/04/07 22:42:32 albertel Exp $ +# $Id: lonnet.pm,v 1.737 2006/05/16 18:24:58 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -85,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'}; @@ -2577,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); @@ -2587,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'})) { @@ -2605,7 +2648,9 @@ sub coursedescription { $envhash{'course.'.$normalid.'.num'}=$cnum; } } - &appenv(%envhash); + if (!$args->{'one_time'}) { + &appenv(%envhash); + } return %returnhash; } @@ -3425,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')) { @@ -3971,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} =~ /_\d+_\-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 { @@ -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,17 +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); + @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; @@ -5248,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; } @@ -5352,16 +5415,16 @@ sub metadata { } else { $metaentry{':packages'}=$package.$keyroot; } - foreach (sort keys %packagetab) { + foreach my $pack_entry (keys(%packagetab)) { my $part=$keyroot; $part=~s/^\_//; - if ($_=~/^\Q$package\E\&/ || - $_=~/^\Q$package\E_0\&/) { - my ($pack,$name,$subp)=split(/\&/,$_); + if ($pack_entry=~/^\Q$package\E\&/ || + $pack_entry=~/^\Q$package\E_0\&/) { + my ($pack,$name,$subp)=split(/\&/,$pack_entry); # ignore package.tab specified default values # here &package_tab_default() will fetch those if ($subp eq 'default') { next; } - my $value=$packagetab{$_}; + my $value=$packagetab{$pack_entry}; my $unikey; if ($pack =~ /_0$/) { $unikey='parameter_0_'.$name; @@ -5409,11 +5472,12 @@ sub metadata { my $dir=$filename; $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); - foreach (sort(split(/\,/,&metadata($uri,'keys', - $location,$unikey, - $depthcount+1)))) { - $metaentry{':'.$_}=$metaentry{':'.$_}; - $metathesekeys{$_}=1; + my $metadata = + &metadata($uri,'keys', $location,$unikey, + $depthcount+1); + foreach my $meta (split(',',$metadata)) { + $metaentry{':'.$meta}=$metaentry{':'.$meta}; + $metathesekeys{$meta}=1; } } } else { @@ -5422,8 +5486,9 @@ sub metadata { $unikey.='_'.$token->[2]->{'name'}; } $metathesekeys{$unikey}=1; - foreach (@{$token->[3]}) { - $metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_}; + foreach my $param (@{$token->[3]}) { + $metaentry{':'.$unikey.'.'.$param} = + $token->[2]->{$param}; } my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); my $default=$metaentry{':'.$unikey.'.default'}; @@ -5444,14 +5509,14 @@ sub metadata { } } my ($extension) = ($uri =~ /\.(\w+)$/); - foreach my $key (sort(keys(%packagetab))) { + foreach my $key (keys(%packagetab)) { #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($metaentry{':packages'})) { - foreach my $key (sort(keys(%packagetab))) { + foreach my $key (keys(%packagetab)) { #no specific packages well let's get default then if ($key!~/^default&/) { next; } &metadata_create_package_def($uri,$key,'default', @@ -5469,15 +5534,22 @@ sub metadata { my $dir=$filename; $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); - foreach (sort(split(/\,/,&metadata($uri,'keys', - $location,'_rights', - $depthcount+1)))) { - #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_}; - $metathesekeys{$_}=1; + my $rights_metadata = + &metadata($uri,'keys',$location,'_rights', + $depthcount+1); + foreach my $rights (split(',',$rights_metadata)) { + #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights}; + $metathesekeys{$rights}=1; } } } - $metaentry{':keys'}=join(',',keys %metathesekeys); + # uniqifiy package listing + my %seen; + my @uniq_packages = + grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); + $metaentry{':packages'} = join(',',@uniq_packages); + + $metaentry{':keys'} = join(',',keys(%metathesekeys)); &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); &do_cache_new('meta',$uri,\%metaentry,60*60); @@ -5513,7 +5585,7 @@ sub metadata_create_package_def { sub metadata_generate_part0 { my ($metadata,$metacache,$uri) = @_; my %allnames; - foreach my $metakey (sort keys %$metadata) { + foreach my $metakey (keys(%$metadata)) { if ($metakey=~/^parameter\_(.*)/) { my $part=$$metacache{':'.$metakey.'.part'}; my $name=$$metacache{':'.$metakey.'.name'};