--- loncom/lonnet/perl/lonnet.pm 2002/08/05 21:02:07 1.261
+++ 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.261 2002/08/05 21:02:07 albertel 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 {
@@ -766,10 +778,15 @@ sub userfileupload {
}
# Notify homeserver to grep it
#
-# FIXME - this still needs to happen
+ if
+(&reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome) eq 'ok')
+ {
#
# Return the URL to it
- return '/uploaded/'.$path.$fname;
+ return '/uploaded/'.$path.$fname;
+ } else {
+ return '/adm/notfound.html';
+ }
}
# ------------------------------------------------------------------------- Log
@@ -803,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};
}
}
@@ -983,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);
}
- return (@returnarray);
+
+ $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);
+ }
+
+ $string =~ s/^__END_ARRAY_REF__//;
+
+ return (\@array, $string);
}
# -------------------------------------------------------------------Temp Store
@@ -1580,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='';
@@ -2011,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'},
@@ -2042,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)) {
@@ -2167,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
@@ -2189,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')) {
@@ -2300,6 +2430,30 @@ sub dirlist {
}
}
+# --------------------------------------------- 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
sub directcondval {
@@ -2592,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?
#
@@ -2615,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'};
@@ -2673,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;
}
}
@@ -2703,8 +2859,9 @@ sub metadata {
# the next is the end of "start tag"
}
}
- &metadata_generate_part0(\%metathesekeys,\%metacache,$uri);
$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
}