--- loncom/lonnet/perl/lonnet.pm 2006/05/15 23:42:52 1.683.2.21
+++ loncom/lonnet/perl/lonnet.pm 2006/05/16 15:42:15 1.736
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.683.2.21 2006/05/15 23:42:52 albertel Exp $
+# $Id: lonnet.pm,v 1.736 2006/05/16 15:42:15 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'};
@@ -124,7 +146,7 @@ sub logperm {
# -------------------------------------------------- Non-critical communication
sub subreply {
my ($cmd,$server)=@_;
- my $peerfile="$perlvar{'lonSockDir'}/$server";
+ my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
#
# With loncnew process trimming, there's a timing hole between lonc server
# process exit and the master server picking up the listen on the AF_UNIX
@@ -152,7 +174,7 @@ sub subreply {
}
my $answer;
if ($client) {
- print $client "$cmd\n";
+ print $client "sethost:$server:$cmd\n";
$answer=<$client>;
if (!$answer) { $answer="con_lost"; }
chomp($answer);
@@ -260,6 +282,13 @@ sub critical {
sub transfer_profile_to_env {
my ($lonidsdir,$handle)=@_;
+ if (!defined($lonidsdir)) {
+ $lonidsdir = $perlvar{'lonIDsDir'};
+ }
+ if (!defined($handle)) {
+ ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
+ }
+
my @profile;
{
open(my $idf,"$lonidsdir/$handle.id");
@@ -291,14 +320,14 @@ sub transfer_profile_to_env {
sub appenv {
my %newenv=@_;
- foreach (keys %newenv) {
- if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
+ foreach my $key (keys(%newenv)) {
+ if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) {
&logthis("<font color=\"blue\">WARNING: ".
- "Attempt to modify environment ".$_." to ".$newenv{$_}
+ "Attempt to modify environment ".$key." to ".$newenv{$key}
.'</font>');
- delete($newenv{$_});
+ delete($newenv{$key});
} else {
- $env{$_}=$newenv{$_};
+ $env{$key}=$newenv{$key};
}
}
@@ -845,11 +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;
@@ -1001,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
@@ -1150,7 +1177,9 @@ sub ssi {
my $ua=new LWP::UserAgent;
my $request;
-
+
+ $form{'no_update_last_known'}=1;
+
if (%form) {
$request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);
$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
@@ -1322,12 +1351,19 @@ sub clean_filename {
}
# --------------- Take an uploaded file and put it into the userfiles directory
-# input: name of form element, coursedoc=1 means this is for the course
-# output: url of file in userspace
+# input: $formname - the contents of the file are in $env{"form.$formname"}
+# the desired filenam is in $env{"form.$formname.filename"}
+# $coursedoc - if true up to the current course
+# if false
+# $subdir - directory in userfile to store the file into
+# $parser, $allfiles, $codebase - unknown
+#
+# output: url of file in userspace, or error: <message>
+# or /adm/notfound.html if failure to upload occurse
sub userfileupload {
- my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase)=@_;
+ my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_;
if (!defined($subdir)) { $subdir='unknown'; }
my $fname=$env{'form.'.$formname.'.filename'};
$fname=&clean_filename($fname);
@@ -1350,6 +1386,7 @@ sub userfileupload {
close($fh);
return $fullpath.'/'.$fname;
}
+
# Create the directory if not present
$fname="$subdir/$fname";
if ($coursedoc) {
@@ -1365,9 +1402,19 @@ sub userfileupload {
$fname,$formname,$parser,
$allfiles,$codebase);
}
+ } elsif (defined($destuname)) {
+ my $docuname=$destuname;
+ my $docudom=$destudom;
+ return &finishuserfileupload($docuname,$docudom,$formname,
+ $fname,$parser,$allfiles,$codebase);
+
} else {
my $docuname=$env{'user.name'};
my $docudom=$env{'user.domain'};
+ if (exists($env{'form.group'})) {
+ $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
+ $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
+ }
return &finishuserfileupload($docuname,$docudom,$formname,
$fname,$parser,$allfiles,$codebase);
}
@@ -1393,8 +1440,16 @@ sub finishuserfileupload {
}
# Save the file
{
- open(FH,'>'.$filepath.'/'.$file);
- print FH $env{'form.'.$formname};
+ if (!open(FH,'>'.$filepath.'/'.$file)) {
+ &logthis('Failed to create '.$filepath.'/'.$file);
+ print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
+ return '/adm/notfound.html';
+ }
+ if (!print FH ($env{'form.'.$formname})) {
+ &logthis('Failed to write to '.$filepath.'/'.$file);
+ print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
+ return '/adm/notfound.html';
+ }
close(FH);
}
if ($parser eq 'parse') {
@@ -2545,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);
@@ -2555,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'})) {
@@ -2573,7 +2648,9 @@ sub coursedescription {
$envhash{'course.'.$normalid.'.num'}=$cnum;
}
}
- &appenv(%envhash);
+ if (!$args->{'one_time'}) {
+ &appenv(%envhash);
+ }
return %returnhash;
}
@@ -2820,7 +2897,7 @@ sub del {
# -------------------------------------------------------------- dump interface
sub dump {
- my ($namespace,$udomain,$uname,$regexp)=@_;
+ my ($namespace,$udomain,$uname,$regexp,$range)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
@@ -2829,16 +2906,23 @@ sub dump {
} else {
$regexp='.';
}
- my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome);
+ my $rep=reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
my @pairs=split(/\&/,$rep);
my %returnhash=();
foreach (@pairs) {
- my ($key,$value)=split(/=/,$_);
+ my ($key,$value)=split(/=/,$_,2);
$returnhash{unescape($key)}=&thaw_unescape($value);
}
return %returnhash;
}
+# --------------------------------------------------------- dumpstore interface
+
+sub dumpstore {
+ my ($namespace,$udomain,$uname,$regexp,$range)=@_;
+ return &dump($namespace,$udomain,$uname,$regexp,$range);
+}
+
# -------------------------------------------------------------- keys interface
sub getkeys {
@@ -2980,25 +3064,53 @@ sub newput {
# --------------------------------------------------------- putstore interface
sub putstore {
- my ($namespace,$storehash,$udomain,$uname)=@_;
+ my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
my $items='';
- my %allitems = ();
- foreach (keys %$storehash) {
- if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
- my $key = $1.':keys:'.$2;
- $allitems{$key} .= $3.':';
- }
- $items.=$_.'='.&freeze_escape($$storehash{$_}).'&';
- }
- foreach (keys %allitems) {
- $allitems{$_} =~ s/\:$//;
- $items.= $_.'='.$allitems{$_}.'&';
+ foreach my $key (keys(%$storehash)) {
+ $items.= &escape($key).'='.&freeze_escape($storehash->{$key}).'&';
}
$items=~s/\&$//;
- return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
+ my $esc_symb=&escape($symb);
+ my $esc_v=&escape($version);
+ my $reply =
+ &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
+ $uhome);
+ if ($reply eq 'unknown_cmd') {
+ # gfall back to way things use to be done
+ return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
+ $uname);
+ }
+ return $reply;
+}
+
+sub old_putstore {
+ my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
+ if (!$udomain) { $udomain=$env{'user.domain'}; }
+ if (!$uname) { $uname=$env{'user.name'}; }
+ my $uhome=&homeserver($uname,$udomain);
+ my %newstorehash;
+ foreach (keys %$storehash) {
+ my $key = $version.':'.&escape($symb).':'.$_;
+ $newstorehash{$key} = $storehash->{$_};
+ }
+ my $items='';
+ my %allitems = ();
+ foreach (keys %newstorehash) {
+ if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
+ my $key = $1.':keys:'.$2;
+ $allitems{$key} .= $3.':';
+ }
+ $items.=$_.'='.&freeze_escape($newstorehash{$_}).'&';
+ }
+ foreach (keys %allitems) {
+ $allitems{$_} =~ s/\:$//;
+ $items.= $_.'='.$allitems{$_}.'&';
+ }
+ $items=~s/\&$//;
+ return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
}
# ------------------------------------------------------ critical put interface
@@ -3010,7 +3122,7 @@ sub cput {
my $uhome=&homeserver($uname,$udomain);
my $items='';
foreach (keys %$storehash) {
- $items.=escape($_).'='.&freeze_escape($$storehash{$_}).'&';
+ $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
}
$items=~s/\&$//;
return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
@@ -3121,12 +3233,29 @@ sub allowed {
}
# Free bre access to user's own portfolio contents
- my ($space,$domain,$name,$dir)=split('/',$uri);
+ my ($space,$domain,$name,@dir)=split('/',$uri);
if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&
- ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {
+ ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
return 'F';
}
+# bre access to group if user has rgf priv for this group and course.
+ if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups')
+ && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {
+ if (exists($env{'request.course.id'})) {
+ my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+ my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+ if (($domain eq $cdom) && ($name eq $cnum)) {
+ my $courseprivid=$env{'request.course.id'};
+ $courseprivid=~s/\_/\//;
+ if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid
+ .'/'.$dir[1]} =~/rgf\&([^\:]*)/) {
+ return $1;
+ }
+ }
+ }
+ }
+
# Free bre to public access
if ($priv eq 'bre') {
@@ -3341,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')) {
@@ -3850,6 +3979,10 @@ sub modify_group_roles {
my $role = 'gr/'.&escape($userprivs);
my ($uname,$udom) = split(/:/,$user);
my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
+ if ($result eq 'ok') {
+ &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
+ }
+
return $result;
}
@@ -3883,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 {
@@ -4651,6 +4804,43 @@ sub GetFileTimestamp {
}
}
+sub stat_file {
+ my ($uri) = @_;
+ $uri = &clutter($uri);
+
+ # we want just the url part without the unneeded accessor url bits
+ 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) =
+ ($uri =~ m-/(?:uploaded|editupload)/?([^/]*)/?([^/]*)/?(.*)-);
+ $file = 'userfiles/'.$file;
+ $dir = &Apache::loncommon::propath($udom,$uname);
+ }
+ if ($uri =~ m-^/res/-) {
+ ($udom,$uname) =
+ ($uri =~ m-/(?:res)/?([^/]*)/?([^/]*)/-);
+ $file = $uri;
+ }
+
+ if (!$udom || !$uname || !$file) {
+ # unable to handle the uri
+ return ();
+ }
+
+ my ($result) = &dirlist($file,$udom,$uname,$dir);
+ my @stats = split('&', $result);
+
+ if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
+ shift(@stats); #filename is first
+ return @stats;
+ }
+ return ();
+}
+
# -------------------------------------------------------- Value of a Condition
# gets the value of a specific preevaluated condition
@@ -4843,8 +5033,8 @@ sub EXT_cache_set {
# --------------------------------------------------------- Value of a Variable
sub EXT {
- my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;
+ my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;
unless ($varname) { return ''; }
#get real user name/domain, courseid and symb
my $courseid;
@@ -4958,10 +5148,21 @@ sub EXT {
return $env{'course.'.$courseid.'.'.$spacequalifierrest};
} elsif ($realm eq 'resource') {
- my $section;
if (defined($courseid) && $courseid eq $env{'request.course.id'}) {
if (!$symbparm) { $symbparm=&symbread(); }
}
+
+ if ($space eq 'title') {
+ if (!$symbparm) { $symbparm = $env{'request.filename'}; }
+ return &gettitle($symbparm);
+ }
+
+ if ($space eq 'map') {
+ my ($map) = &decode_symb($symbparm);
+ return &symbread($map);
+ }
+
+ my ($section, $group, @groups);
my ($courselevelm,$courselevel);
if ($symbparm && defined($courseid) &&
$courseid eq $env{'request.course.id'}) {
@@ -4978,12 +5179,15 @@ sub EXT {
if (($env{'user.name'} eq $uname) &&
($env{'user.domain'} eq $udom)) {
$section=$env{'request.course.sec'};
+ @groups = split(/:/,$env{'request.course.groups'});
+ @groups=&sort_course_groups($courseid,@groups);
} else {
if (! defined($usection)) {
$section=&getsection($udom,$uname,$courseid);
} else {
$section = $usection;
}
+ @groups = &get_users_groups($udom,$uname,$courseid);
}
my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
@@ -4999,12 +5203,17 @@ sub EXT {
my $userreply=&resdata($uname,$udom,'user',
($courselevelr,$courselevelm,
$courselevel));
-
if (defined($userreply)) { return $userreply; }
# ------------------------------------------------ second, check some of course
+ my $coursereply;
+ if (@groups > 0) {
+ $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
+ $mapparm,$spacequalifierrest);
+ if (defined($coursereply)) { return $coursereply; }
+ }
- my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
+ $coursereply=&resdata($env{'course.'.$courseid.'.num'},
$env{'course.'.$courseid.'.domain'},
'course',
($seclevelr,$seclevelm,$seclevel,
@@ -5084,6 +5293,29 @@ sub EXT {
return '';
}
+sub check_group_parms {
+ my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
+ my @groupitems = ();
+ my $resultitem;
+ my @levels = ($symbparm,$mapparm,$what);
+ foreach my $group (@{$groups}) {
+ foreach my $level (@levels) {
+ my $item = $courseid.'.['.$group.'].'.$level;
+ push(@groupitems,$item);
+ }
+ }
+ my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
+ $env{'course.'.$courseid.'.domain'},
+ 'course',@groupitems);
+ return $coursereply;
+}
+
+sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
+ my ($courseid,@groups) = @_;
+ @groups = sort(@groups);
+ return @groups;
+}
+
sub packages_tab_default {
my ($uri,$varname)=@_;
my (undef,$part,$name)=split(/\./,$varname);
@@ -5183,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;
@@ -5240,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 {
@@ -5253,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'};
@@ -5300,11 +5534,12 @@ 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;
}
}
}
@@ -5432,9 +5667,12 @@ sub symblist {
if (($env{'request.course.fn'}) && (%newhash)) {
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
&GDBM_WRCREAT(),0640)) {
- foreach (keys %newhash) {
- $hash{declutter($_)}=&encode_symb($mapname,$newhash{$_}->[1],
- $newhash{$_}->[0]);
+ foreach my $url (keys %newhash) {
+ next if ($url eq 'last_known'
+ && $env{'form.no_update_last_known'});
+ $hash{declutter($url)}=&encode_symb($mapname,
+ $newhash{$url}->[1],
+ $newhash{$url}->[0]);
}
if (untie(%hash)) {
return 'ok';
@@ -6281,7 +6519,7 @@ sub clutter {
&& $thisfn!~/\.(sequence|page)$/) {
$thisfn='/adm/coursedocs/showdoc'.$thisfn;
} else {
- #&logthis("Got a blank emb style");
+# &logthis("Got a blank emb style");
}
}
}
@@ -6349,7 +6587,6 @@ sub goodbye {
&logthis(sprintf("%-20s is %s",'hits',$hits));
&flushcourselogs();
&logthis("Shutting down");
- return DONE;
}
BEGIN {
@@ -6428,7 +6665,7 @@ BEGIN {
}
close($config);
# FIXME: dev server don't want this, production servers _do_ want this
- &get_iphost();
+ #&get_iphost();
}
sub get_iphost {
@@ -7102,6 +7339,27 @@ all args are optional
=item *
+dumpstore($namespace,$udom,$uname,$regexp,$range) :
+dumps the complete (or key matching regexp) namespace into a hash
+($udom, $uname, $regexp, $range are optional) for a namespace that is
+normally &store()ed into
+
+$range should be either an integer '100' (give me the first 100
+ matching records)
+ or be two integers sperated by a - with no spaces
+ '30-50' (give me the 30th through the 50th matching
+ records)
+
+
+=item *
+
+putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :
+replaces a &store() version of data with a replacement set of data
+for a particular resource in a namespace passed in the $storehash hash
+reference
+
+=item *
+
tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that
works very similar to store/cstore, but all data is stored in a
temporary location and can be reset using tmpreset, $storehash should
@@ -7131,10 +7389,15 @@ namesp ($udom and $uname are optional)
=item *
-dump($namespace,$udom,$uname,$regexp) :
+dump($namespace,$udom,$uname,$regexp,$range) :
dumps the complete (or key matching regexp) namespace into a hash
-($udom, $uname and $regexp are optional)
+($udom, $uname, $regexp, $range are optional)
+$range should be either an integer '100' (give me the first 100
+ matching records)
+ or be two integers sperated by a - with no spaces
+ '30-50' (give me the 30th through the 50th matching
+ records)
=item *
inc($namespace,$store,$udom,$uname) : increments $store in $namespace.
@@ -7150,17 +7413,6 @@ put($namespace,$storehash,$udom,$uname)
=item *
-putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp
-keys used in storehash include version information (e.g., 1:$symb:message etc.) as
-used in records written by &store and retrieved by &restore. This function
-was created for use in editing discussion posts, without incrementing the
-version number included in the key for a particular post. The colon
-separated list of attribute names (e.g., the value associated with the key
-1:keys:$symb) is also generated and passed in the ampersand separated
-items sent to lonnet::reply().
-
-=item *
-
cput($namespace,$storehash,$udom,$uname) : critical put
($udom and $uname are optional)
@@ -7290,6 +7542,16 @@ getfile($file,$caller) : two cases - req
- returns the entire contents of a file or -1;
it properly subscribes to and replicates the file if neccessary.
+
+=item *
+
+stat_file($url) : $url is expected to be a /res/ or /uploaded/ style file
+ reference
+
+returns either a stat() list of data about the file or an empty list
+if the file doesn't exist or couldn't find out about it (connection
+problems or user unknown)
+
=item *
filelocation($dir,$file) : returns file system location of a file