--- loncom/lonnet/perl/lonnet.pm 2002/06/27 21:11:44 1.249
+++ loncom/lonnet/perl/lonnet.pm 2002/09/03 01:29:35 1.267.4.5
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.249 2002/06/27 21:11:44 www Exp $
+# $Id: lonnet.pm,v 1.267.4.5 2002/09/03 01:29:35 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -608,6 +608,18 @@ sub userenvironment {
return %returnhash;
}
+# -------------------------------------------------------------------- New chat
+
+sub chatsend {
+ my ($newentry,$anon)=@_;
+ 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);
+}
+
# ----------------------------- Subscribe to a resource, return URL if possible
sub subscribe {
@@ -708,6 +720,75 @@ sub ssi {
return $response->content;
}
+# ------- Add a token to a remote URI's query string to vouch for access rights
+
+sub tokenwrapper {
+ my $uri=shift;
+ $uri=~s/^http\:\/\/([^\/]+)//;
+ $uri=~s/^\///;
+ $ENV{'user.environment'}=~/\/([^\/]+)\.id/;
+ my $token=$1;
+ if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {
+ &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});
+ return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
+ (($uri=~/\?/)?'&':'?').'token='.$token;
+ } else {
+ return '/adm/notfound.html';
+ }
+}
+
+# --------------- 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
+
+sub userfileupload {
+ my ($formname,$coursedoc)=@_;
+ my $fname=$ENV{'form.'.$formname.'.filename'};
+ $fname=~s/\\/\//g;
+ $fname=~s/^.*\/([^\/]+)$/$1/;
+ unless ($fname) { return 'error: no uploaded file'; }
+ chop($ENV{'form.'.$formname});
+# Create the directory if not present
+ my $docuname='';
+ my $docudom='';
+ my $docuhome='';
+ if ($coursedoc) {
+ $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};
+ $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
+ $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
+ } else {
+ $docuname=$ENV{'user.name'};
+ $docudom=$ENV{'user.domain'};
+ $docuhome=$ENV{'user.home'};
+ }
+ my $path=$docudom.'/'.$docuname.'/';
+ my $filepath=$perlvar{'lonDocRoot'};
+ my @parts=split(/\//,$filepath.'/userfiles/'.$path);
+ my $count;
+ for ($count=4;$count<=$#parts;$count++) {
+ $filepath.="/$parts[$count]";
+ if ((-e $filepath)!=1) {
+ mkdir($filepath,0777);
+ }
+ }
+# Save the file
+ {
+ my $fh=Apache::File->new('>'.$filepath.'/'.$fname);
+ print $fh $ENV{'form.'.$formname};
+ }
+# Notify homeserver to grep it
+#
+ if
+(&reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome) eq 'ok')
+ {
+#
+# Return the URL to it
+ return '/uploaded/'.$path.$fname;
+ } else {
+ return '/adm/notfound.html';
+ }
+}
+
# ------------------------------------------------------------------------- Log
sub log {
@@ -739,7 +820,7 @@ sub flushcourselogs {
my $entry=$_;
$entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;
my %temphash=($entry => $accesshash{$entry});
- if (&Apache::lonnet::put('resevaldata',\%temphash,$1,$2) eq 'ok') {
+ if (&Apache::lonnet::put('nohist_resevaldata',\%temphash,$1,$2) eq 'ok') {
delete $accesshash{$entry};
}
}
@@ -919,97 +1000,195 @@ sub devalidate {
}
}
+sub get_scalar {
+ my ($string,$end) = @_;
+ my $value;
+ if ($$string =~ s/^([^&]*?)($end)/$2/) {
+ $value = $1;
+ } elsif ($$string =~ s/^([^&]*?)&//) {
+ $value = $1;
+ }
+ return &unescape($value);
+}
+
+sub array2str {
+ my (@array) = @_;
+ my $result=&arrayref2str(\@array);
+ $result=~s/^__ARRAY_REF__//;
+ $result=~s/__END_ARRAY_REF__$//;
+ return $result;
+}
+
sub arrayref2str {
my ($arrayref) = @_;
- my $result='_ARRAY_REF__';
+ my $result='__ARRAY_REF__';
foreach my $elem (@$arrayref) {
- if (ref($elem) eq 'ARRAY') {
- $result.=&escape(&arrayref2str($elem)).'&';
- } elsif (ref($elem) eq 'HASH') {
- $result.=&escape(&hashref2str($elem)).'&';
- } elsif (ref($elem)) {
- &logthis("Got a ref of ".(ref($elem))." skipping.");
+ if(ref($elem) eq 'ARRAY') {
+ $result.=&arrayref2str($elem).'&';
+ } elsif(ref($elem) eq 'HASH') {
+ $result.=&hashref2str($elem).'&';
+ } elsif(ref($elem)) {
+ #print("Got a ref of ".(ref($elem))." skipping.");
} else {
$result.=&escape($elem).'&';
}
}
$result=~s/\&$//;
+ $result .= '__END_ARRAY_REF__';
return $result;
}
sub hash2str {
my (%hash) = @_;
my $result=&hashref2str(\%hash);
- $result=~s/^_HASH_REF__//;
+ $result=~s/^__HASH_REF__//;
+ $result=~s/__END_HASH_REF__$//;
return $result;
}
sub hashref2str {
my ($hashref)=@_;
- my $result='_HASH_REF__';
+ my $result='__HASH_REF__';
foreach (keys(%$hashref)) {
if (ref($_) eq 'ARRAY') {
- $result.=&escape(&arrayref2str($_)).'=';
+ $result.=&arrayref2str($_).'=';
} elsif (ref($_) eq 'HASH') {
- $result.=&escape(&hashref2str($_)).'=';
+ $result.=&hashref2str($_).'=';
} elsif (ref($_)) {
- &logthis("Got a ref of ".(ref($_))." skipping.");
+ $result.='=';
+ #print("Got a ref of ".(ref($_))." skipping.");
} else {
- $result.=&escape($_).'=';
+ if ($_) {$result.=&escape($_).'=';} else { last; }
}
- if (ref($$hashref{$_}) eq 'ARRAY') {
- $result.=&escape(&arrayref2str($$hashref{$_})).'&';
- } elsif (ref($$hashref{$_}) eq 'HASH') {
- $result.=&escape(&hashref2str($$hashref{$_})).'&';
- } elsif (ref($$hashref{$_})) {
- &logthis("Got a ref of ".(ref($$hashref{$_}))." skipping.");
+ if(ref($hashref->{$_}) eq 'ARRAY') {
+ $result.=&arrayref2str($hashref->{$_}).'&';
+ } elsif(ref($hashref->{$_}) eq 'HASH') {
+ $result.=&hashref2str($hashref->{$_}).'&';
+ } elsif(ref($hashref->{$_})) {
+ $result.='&';
+ #print("Got a ref of ".(ref($hashref->{$_}))." skipping.");
} else {
- $result.=&escape($$hashref{$_}).'&';
+ $result.=&escape($hashref->{$_}).'&';
}
}
$result=~s/\&$//;
+ $result .= '__END_HASH_REF__';
return $result;
}
sub str2hash {
+ my ($string)=@_;
+ my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__');
+ return %$hash;
+}
+
+sub str2hashref {
my ($string) = @_;
- my %returnhash;
- foreach (split(/\&/,$string)) {
- my ($name,$value)=split(/\=/,$_);
- $name=&unescape($name);
- $value=&unescape($value);
- if ($value =~ /^_HASH_REF__/) {
- $value =~ s/^_HASH_REF__//;
- my %hash=&str2hash($value);
- $value=\%hash;
- } elsif ($value =~ /^_ARRAY_REF__/) {
- $value =~ s/^_ARRAY_REF__//;
- my @array=&str2array($value);
- $value=\@array;
- }
- $returnhash{$name}=$value;
+
+ my %hash;
+
+ if($string !~ /^__HASH_REF__/) {
+ if (! ($string eq '' || !defined($string))) {
+ $hash{'error'}='Not hash reference';
+ }
+ return (\%hash, $string);
}
- return (%returnhash);
+
+ $string =~ s/^__HASH_REF__//;
+
+ while($string !~ /^__END_HASH_REF__/) {
+ #key
+ my $key='';
+ if($string =~ /^__HASH_REF__/) {
+ ($key, $string)=&str2hashref($string);
+ if(defined($key->{'error'})) {
+ $hash{'error'}='Bad data';
+ return (\%hash, $string);
+ }
+ } elsif($string =~ /^__ARRAY_REF__/) {
+ ($key, $string)=&str2arrayref($string);
+ if($key->[0] eq 'Array reference error') {
+ $hash{'error'}='Bad data';
+ return (\%hash, $string);
+ }
+ } else {
+ $string =~ s/^(.*?)=//;
+ $key=&unescape($1);
+ }
+ $string =~ s/^=//;
+
+ #value
+ my $value='';
+ if($string =~ /^__HASH_REF__/) {
+ ($value, $string)=&str2hashref($string);
+ if(defined($value->{'error'})) {
+ $hash{'error'}='Bad data';
+ return (\%hash, $string);
+ }
+ } elsif($string =~ /^__ARRAY_REF__/) {
+ ($value, $string)=&str2arrayref($string);
+ if($value->[0] eq 'Array reference error') {
+ $hash{'error'}='Bad data';
+ return (\%hash, $string);
+ }
+ } else {
+ $value=&get_scalar(\$string,'__END_HASH_REF__');
+ }
+ $string =~ s/^&//;
+
+ $hash{$key}=$value;
+ }
+
+ $string =~ s/^__END_HASH_REF__//;
+
+ return (\%hash, $string);
}
sub str2array {
+ my ($string)=@_;
+ my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__');
+ return @$array;
+}
+
+sub str2arrayref {
my ($string) = @_;
- my @returnarray;
- foreach my $value (split(/\&/,$string)) {
- $value=&unescape($value);
- if ($value =~ /^_HASH_REF__/) {
- $value =~ s/^_HASH_REF__//;
- my %hash=&str2hash($value);
- $value=\%hash;
- } elsif ($value =~ /^_ARRAY_REF__/) {
- $value =~ s/^_ARRAY_REF__//;
- my @array=&str2array($value);
- $value=\@array;
- }
- push(@returnarray,$value);
+ my @array;
+
+ if($string !~ /^__ARRAY_REF__/) {
+ if (! ($string eq '' || !defined($string))) {
+ $array[0]='Array reference error';
+ }
+ return (\@array, $string);
+ }
+
+ $string =~ s/^__ARRAY_REF__//;
+
+ while($string !~ /^__END_ARRAY_REF__/) {
+ my $value='';
+ if($string =~ /^__HASH_REF__/) {
+ ($value, $string)=&str2hashref($string);
+ if(defined($value->{'error'})) {
+ $array[0] ='Array reference error';
+ return (\@array, $string);
+ }
+ } elsif($string =~ /^__ARRAY_REF__/) {
+ ($value, $string)=&str2arrayref($string);
+ if($value->[0] eq 'Array reference error') {
+ $array[0] ='Array reference error';
+ return (\@array, $string);
+ }
+ } else {
+ $value=&get_scalar(\$string,'__END_ARRAY_REF__');
+ }
+ $string =~ s/^&//;
+
+ push(@array, $value);
}
- return (@returnarray);
+
+ $string =~ s/^__END_ARRAY_REF__//;
+
+ return (\@array, $string);
}
# -------------------------------------------------------------------Temp Store
@@ -1033,7 +1212,7 @@ sub tmpreset {
my %hash;
if (tie(%hash,'GDBM_File',
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
- &GDBM_WRCREAT,0640)) {
+ &GDBM_WRCREAT(),0640)) {
foreach my $key (keys %hash) {
if ($key=~ /:$symb/) {
delete($hash{$key});
@@ -1069,7 +1248,7 @@ sub tmpstore {
my $path=$perlvar{'lonDaemons'}.'/tmp';
if (tie(%hash,'GDBM_File',
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
- &GDBM_WRCREAT,0640)) {
+ &GDBM_WRCREAT(),0640)) {
$hash{"version:$symb"}++;
my $version=$hash{"version:$symb"};
my $allkeys='';
@@ -1113,7 +1292,7 @@ sub tmprestore {
my $path=$perlvar{'lonDaemons'}.'/tmp';
if (tie(%hash,'GDBM_File',
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
- &GDBM_READER,0640)) {
+ &GDBM_READER(),0640)) {
my $version=$hash{"version:$symb"};
$returnhash{'version'}=$version;
my $scope;
@@ -1516,6 +1695,17 @@ sub allowed {
return '';
}
}
+ if ($ENV{'request.role'}=~ /li\.\//) {
+ # Library role, so allow browsing of resources in this domain.
+ return 'F';
+ }
+ }
+ # Domain coordinator is trying to create a course
+ if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) {
+ # uri is the requested domain in this case.
+ # comparison to 'request.role.domain' shows if the user has selected
+ # a role of dc for the domain in question.
+ return 'F' if ($uri eq $ENV{'request.role.domain'});
}
my $thisallowed='';
@@ -1947,7 +2137,8 @@ sub modifyuserauth {
my $uhome=&homeserver($uname,$udom);
unless (&allowed('mau',$udom)) { return 'refused'; }
&logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
- $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});
+ $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}.
+ ' in domain '.$ENV{'request.role.domain'});
my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
&escape($upass),$uhome);
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},
@@ -1978,7 +2169,8 @@ sub modifyuser {
$last.', '.$gene.'(forceid: '.$forceid.')'.
(defined($desiredhome) ? ' desiredhome = '.$desiredhome :
' desiredhome not specified').
- ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});
+ ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}.
+ ' in domain '.$ENV{'request.role.domain'});
my $uhome=&homeserver($uname,$udom,'true');
# ----------------------------------------------------------------- Create User
if (($uhome eq 'no_host') && ($umode) && ($upass)) {
@@ -2103,13 +2295,10 @@ sub writecoursepref {
# ---------------------------------------------------------- Make/modify course
sub createcourse {
- my ($udom,$description,$url)=@_;
+ my ($udom,$description,$url,$course_server)=@_;
$url=&declutter($url);
my $cid='';
- unless (&allowed('ccc',$ENV{'user.domain'})) {
- return 'refused';
- }
- unless ($udom eq $ENV{'user.domain'}) {
+ unless (&allowed('ccc',$udom)) {
return 'refused';
}
# ------------------------------------------------------------------- Create ID
@@ -2125,9 +2314,14 @@ sub createcourse {
return 'error: unable to generate unique course-ID';
}
}
+# ------------------------------------------------ Check supplied server name
+ $course_server = $ENV{'user.homeserver'} if (! defined($course_server));
+ if (! exists($libserv{$course_server})) {
+ return 'error:bad server name '.$course_server;
+ }
# ------------------------------------------------------------- Make the course
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
- $ENV{'user.home'});
+ $course_server);
unless ($reply eq 'ok') { return 'error: '.$reply; }
$uhome=&homeserver($uname,$udom,'true');
if (($uhome eq '') || ($uhome eq 'no_host')) {
@@ -2166,51 +2360,98 @@ sub revokecustomrole {
# ------------------------------------------------------------ Directory lister
sub dirlist {
- my $uri=shift;
+ my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_;
+
$uri=~s/^\///;
$uri=~s/\/$//;
- my ($res,$udom,$uname,@rest)=split(/\//,$uri);
- if ($udom) {
- if ($uname) {
- my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/'.$uri,
- homeserver($uname,$udom));
- return split(/:/,$listing);
- } else {
- my $tryserver;
- my %allusers=();
- foreach $tryserver (keys %libserv) {
- if ($hostdom{$tryserver} eq $udom) {
- my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.$udom,
- $tryserver);
- if (($listing ne 'no_such_dir') && ($listing ne 'empty')
- && ($listing ne 'con_lost')) {
- foreach (split(/:/,$listing)) {
- my ($entry,@stat)=split(/&/,$_);
- $allusers{$entry}=1;
+ my ($udom, $uname);
+ (undef,$udom,$uname)=split(/\//,$uri);
+ if(defined($userdomain)) {
+ $udom = $userdomain;
+ }
+ if(defined($username)) {
+ $uname = $username;
+ }
+
+ my $dirRoot = $perlvar{'lonDocRoot'};
+ if(defined($alternateDirectoryRoot)) {
+ $dirRoot = $alternateDirectoryRoot;
+ $dirRoot =~ s/\/$//;
+ }
+
+ if($udom) {
+ if($uname) {
+ my $listing=reply('ls:'.$dirRoot.'/'.$uri,
+ homeserver($uname,$udom));
+ return split(/:/,$listing);
+ } elsif(!defined($alternateDirectoryRoot)) {
+ my $tryserver;
+ my %allusers=();
+ foreach $tryserver (keys %libserv) {
+ if($hostdom{$tryserver} eq $udom) {
+ my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
+ $udom, $tryserver);
+ if (($listing ne 'no_such_dir') && ($listing ne 'empty')
+ && ($listing ne 'con_lost')) {
+ foreach (split(/:/,$listing)) {
+ my ($entry,@stat)=split(/&/,$_);
+ $allusers{$entry}=1;
+ }
+ }
}
- }
- }
- }
- my $alluserstr='';
- foreach (sort keys %allusers) {
- $alluserstr.=$_.'&user:';
- }
- $alluserstr=~s/:$//;
- return split(/:/,$alluserstr);
- }
- } else {
- my $tryserver;
- my %alldom=();
- foreach $tryserver (keys %libserv) {
- $alldom{$hostdom{$tryserver}}=1;
- }
- my $alldomstr='';
- foreach (sort keys %alldom) {
- $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';
- }
- $alldomstr=~s/:$//;
- return split(/:/,$alldomstr);
- }
+ }
+ my $alluserstr='';
+ foreach (sort keys %allusers) {
+ $alluserstr.=$_.'&user:';
+ }
+ $alluserstr=~s/:$//;
+ return split(/:/,$alluserstr);
+ } else {
+ my @emptyResults = ();
+ push(@emptyResults, 'missing user name');
+ return split(':',@emptyResults);
+ }
+ } elsif(!defined($alternateDirectoryRoot)) {
+ my $tryserver;
+ my %alldom=();
+ foreach $tryserver (keys %libserv) {
+ $alldom{$hostdom{$tryserver}}=1;
+ }
+ my $alldomstr='';
+ foreach (sort keys %alldom) {
+ $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';
+ }
+ $alldomstr=~s/:$//;
+ return split(/:/,$alldomstr);
+ } else {
+ my @emptyResults = ();
+ push(@emptyResults, 'missing domain');
+ return split(':',@emptyResults);
+ }
+}
+
+# --------------------------------------------- GetFileTimestamp
+# This function utilizes dirlist and returns the date stamp for
+# when it was last modified. It will also return an error of -1
+# if an error occurs
+
+sub GetFileTimestamp {
+ my ($studentDomain,$studentName,$filename,$root)=@_;
+ $studentDomain=~s/\W//g;
+ $studentName=~s/\W//g;
+ my $subdir=$studentName.'__';
+ $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
+ my $proname="$studentDomain/$subdir/$studentName";
+ $proname .= '/'.$filename;
+ my @dir = &Apache::lonnet::dirlist($proname, $studentDomain, $studentName,
+ $root);
+ my $fileStat = $dir[0];
+ my @stats = split('&', $fileStat);
+ if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
+ return $stats[9];
+ } else {
+ return -1;
+ }
}
# -------------------------------------------------------- Value of a Condition
@@ -2271,30 +2512,26 @@ sub courseresdata {
my ($coursenum,$coursedomain,@which)=@_;
my $coursehom=&homeserver($coursenum,$coursedomain);
my $hashid=$coursenum.':'.$coursedomain;
- unless (defined($courseresdatacache{$hashid.'.time'})) {
- unless (time-$courseresdatacache{$hashid.'.time'}<300) {
- my $coursehom=&homeserver($coursenum,$coursedomain);
- if ($coursehom) {
- my $dumpreply=&reply('dump:'.$coursedomain.':'.$coursenum.
- ':resourcedata:.',$coursehom);
- unless ($dumpreply=~/^error\:/) {
- $courseresdatacache{$hashid.'.time'}=time;
- $courseresdatacache{$hashid}=$dumpreply;
- }
- }
- }
+ my $dodump=0;
+ if (!defined($courseresdatacache{$hashid.'.time'})) {
+ $dodump=1;
+ } else {
+ if (time-$courseresdatacache{$hashid.'.time'}>300) { $dodump=1; }
}
- my @pairs=split(/\&/,$courseresdatacache{$hashid});
- my %returnhash=();
- foreach (@pairs) {
- my ($key,$value)=split(/=/,$_);
- $returnhash{unescape($key)}=unescape($value);
- }
- my $item;
- foreach $item (@which) {
- if ($returnhash{$item}) { return $returnhash{$item}; }
- }
- return '';
+ if ($dodump) {
+ my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
+ my ($tmp) = keys(%dumpreply);
+ if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
+ $courseresdatacache{$hashid.'.time'}=time;
+ $courseresdatacache{$hashid}=\%dumpreply;
+ }
+ }
+ foreach my $item (@which) {
+ if ($courseresdatacache{$hashid}->{$item}) {
+ return $courseresdatacache{$hashid}->{$item};
+ }
+ }
+ return '';
}
# --------------------------------------------------------- Value of a Variable
@@ -2399,7 +2636,7 @@ sub EXT {
my $section;
if (($ENV{'user.name'} eq $uname) &&
($ENV{'user.domain'} eq $udom)) {
- $section={'request.course.sec'};
+ $section=$ENV{'request.course.sec'};
} else {
$section=&usection($udom,$uname,$courseid);
}
@@ -2448,7 +2685,7 @@ sub EXT {
my $thisparm='';
if (tie(%parmhash,'GDBM_File',
$ENV{'request.course.fn'}.'_parms.db',
- &GDBM_READER,0640)) {
+ &GDBM_READER(),0640)) {
$thisparm=$parmhash{$symbparm};
untie(%parmhash);
}
@@ -2509,7 +2746,7 @@ sub metadata {
# Look at timestamp of caching
# Everything is cached by the main uri, libraries are never directly cached
#
- unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600) {
+ unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600 && !defined($liburi)) {
#
# Is this a recursive call for a library?
#
@@ -2532,7 +2769,7 @@ sub metadata {
my $package=$token->[2]->{'package'};
my $keyroot='';
if ($prefix) {
- $keyroot.='_'.$prefix;
+ $keyroot.=$prefix;
} else {
if (defined($token->[2]->{'part'})) {
$keyroot.='_'.$token->[2]->{'part'};
@@ -2590,12 +2827,14 @@ sub metadata {
#
# Importing a library here
#
- if (defined($depthcount)) { $depthcount++; } else
- { $depthcount=0; }
if ($depthcount<20) {
- foreach (split(/\,/,&metadata($uri,'keys',
- $parser->get_text('/import'),$unikey,
- $depthcount))) {
+ my $location=$parser->get_text('/import');
+ my $dir=$filename;
+ $dir=~s|[^/]*$||;
+ $location=&filelocation($dir,$location);
+ foreach (sort(split(/\,/,&metadata($uri,'keys',
+ $location,$unikey,
+ $depthcount+1)))) {
$metathesekeys{$_}=1;
}
}
@@ -2621,12 +2860,42 @@ sub metadata {
}
}
$metacache{$uri.':keys'}=join(',',keys %metathesekeys);
+ &metadata_generate_part0(\%metathesekeys,\%metacache,$uri);
+ $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys);
$metacache{$uri.':cachedtimestamp'}=time;
# this is the end of "was not already recently cached
}
return $metacache{$uri.':'.$what};
}
+sub metadata_generate_part0 {
+ my ($metadata,$metacache,$uri) = @_;
+ my %allnames;
+ foreach my $metakey (sort keys %$metadata) {
+ if ($metakey=~/^parameter\_(.*)/) {
+ my $part=$$metacache{$uri.':'.$metakey.'.part'};
+ my $name=$$metacache{$uri.':'.$metakey.'.name'};
+ if (! exists($$metadata{'parameter_0_'.$name})) {
+ $allnames{$name}=$part;
+ }
+ }
+ }
+ foreach my $name (keys(%allnames)) {
+ $$metadata{"parameter_0_$name"}=1;
+ my $key="$uri:parameter_0_$name";
+ $$metacache{"$key.part"}='0';
+ $$metacache{"$key.name"}=$name;
+ $$metacache{"$key.type"}=$$metacache{$uri.':parameter_'.
+ $allnames{$name}.'_'.$name.
+ '.type'};
+ my $olddis=$$metacache{$uri.':parameter_'.$allnames{$name}.'_'.$name.
+ '.display'};
+ my $expr='\\[Part: '.$allnames{$name}.'\\]';
+ $olddis=~s/$expr/\[Part: 0\]/;
+ $$metacache{"$key.display"}=$olddis;
+ }
+}
+
# ------------------------------------------------- Update symbolic store links
sub symblist {
@@ -2635,7 +2904,7 @@ sub symblist {
my %hash;
if (($ENV{'request.course.fn'}) && (%newhash)) {
if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
- &GDBM_WRCREAT,0640)) {
+ &GDBM_WRCREAT(),0640)) {
foreach (keys %newhash) {
$hash{declutter($_)}=$mapname.'___'.$newhash{$_};
}
@@ -2663,7 +2932,7 @@ sub symbverify {
my %bighash;
my $okay=0;
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
- &GDBM_READER,0640)) {
+ &GDBM_READER(),0640)) {
my $ids=$bighash{'ids_/res/'.$thisfn};
unless ($ids) {
$ids=$bighash{'ids_/'.$thisfn};
@@ -2717,7 +2986,7 @@ sub symbread {
my $syval='';
if (($ENV{'request.course.fn'}) && ($thisfn)) {
if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
- &GDBM_READER,0640)) {
+ &GDBM_READER(),0640)) {
$syval=$hash{$thisfn};
untie(%hash);
}
@@ -2733,7 +3002,7 @@ sub symbread {
} else {
# ------------------------------------------------------- Was not in symb table
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
- &GDBM_READER,0640)) {
+ &GDBM_READER(),0640)) {
# ---------------------------------------------- Get ID(s) for current resource
my $ids=$bighash{'ids_/res/'.$thisfn};
unless ($ids) {
@@ -2835,10 +3104,10 @@ sub ireceipt {
}
sub receipt {
- return &ireceipt($ENV{'user.name'},$ENV{'user.domain'},
- $ENV{'request.course.id'},&symbread());
+ my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();
+ return &ireceipt($name,$domain,$courseid,$symb);
}
-
+
# ------------------------------------------------------------ Serves up a file
# returns either the contents of the file or a -1
sub getfile {
@@ -2952,13 +3221,17 @@ BEGIN {
while (my $configline=<$config>) {
chomp($configline);
my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline);
- $hostname{$id}=$name;
- $hostdom{$id}=$domain;
- $hostip{$id}=$ip;
- if ($domdescr) {
- $domaindescription{$domain}=$domdescr;
+ if ($id && $domain && $role && $name && $ip) {
+ $hostname{$id}=$name;
+ $hostdom{$id}=$domain;
+ $hostip{$id}=$ip;
+ if ($domdescr) { $domaindescription{$domain}=$domdescr; }
+ if ($role eq 'library') { $libserv{$id}=$name; }
+ } else {
+ if ($configline) {
+ &logthis("Skipping hosts.tab line -$configline-");
+ }
}
- if ($role eq 'library') { $libserv{$id}=$name; }
}
}