--- loncom/lonnet/perl/lonnet.pm 2004/08/25 16:05:10 1.523.2.1
+++ loncom/lonnet/perl/lonnet.pm 2004/08/24 06:43:21 1.530
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.523.2.1 2004/08/25 16:05:10 albertel Exp $
+# $Id: lonnet.pm,v 1.530 2004/08/24 06:43:21 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -1047,7 +1047,6 @@ sub currentversion {
sub subscribe {
my $fname=shift;
if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }
- $fname=~s/[\n\r]//g;
my $author=$fname;
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
my ($udom,$uname)=split(/\//,$author);
@@ -1068,7 +1067,6 @@ sub repcopy {
my $filename=shift;
$filename=~s/\/+/\//g;
if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; }
- $filename=~s/[\n\r]//g;
my $transname="$filename.in.transfer";
if ((-e $filename) || (-e $transname)) { return OK; }
my $remoteurl=subscribe($filename);
@@ -1133,10 +1131,10 @@ sub ssi_body {
my ($filelink,%form)=@_;
my $output=($filelink=~/^http\:/?&externalssi($filelink):
&ssi($filelink,%form));
- $output=~s/^.*?\<body[^\>]*\>//si;
- $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
$output=~
s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
+ $output=~s/^.*?\<body[^\>]*\>//si;
+ $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
return $output;
}
@@ -1374,6 +1372,12 @@ sub removeuserfile {
return &reply("removeuserfile:$docudom/$docuname/$fname",$home);
}
+sub mkdiruserfile {
+ my ($docuname,$docudom,$dir)=@_;
+ my $home=&homeserver($docuname,$docudom);
+ return &reply("mkdiruserfile:".&escape("$docudom/$docuname/$dir"),$home);
+}
+
# ------------------------------------------------------------------------- Log
sub log {
@@ -2593,6 +2597,30 @@ sub put {
return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
}
+# ---------------------------------------------------------- putstore interface
+
+sub putstore {
+ my ($namespace,$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.=$_.'='.&escape($$storehash{$_}).'&';
+ }
+ foreach (keys %allitems) {
+ $allitems{$_} =~ s/\:$//;
+ $items.= $_.'='.$allitems{$_}.'&';
+ }
+ $items=~s/\&$//;
+ return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
+}
+
# ------------------------------------------------------ critical put interface
sub cput {
@@ -2675,8 +2703,8 @@ sub allowed {
if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; }
# Free bre access to adm and meta resources
-
- if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
+ if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|))
+ || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
return 'F';
}
@@ -3095,9 +3123,14 @@ sub fetch_enrollment_query {
$cmd = &escape($cmd);
my $query = 'fetchenrollment';
my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver);
- unless ($queryid=~/^\Q$host\E\_/) { return 'error: '.$queryid; }
+ unless ($queryid=~/^\Q$host\E\_/) {
+ &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum);
+ return 'error: '.$queryid;
+ }
my $reply = &get_query_reply($queryid);
- unless ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
+ if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
+ &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum);
+ } else {
my @responses = split/:/,$reply;
if ($homeserver eq $perlvar{'lonHostID'}) {
foreach (@responses) {
@@ -3114,10 +3147,14 @@ sub fetch_enrollment_query {
my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml';
my $destname = $pathname.'/'.$filename;
my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
- unless ($xml_classlist =~ /^error/) {
+ if ($xml_classlist =~ /^error/) {
+ &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
+ } else {
if ( open(FILE,">$destname") ) {
print FILE &unescape($xml_classlist);
close(FILE);
+ } else {
+ &logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum);
}
}
}
@@ -4166,7 +4203,9 @@ sub metadata {
my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
$uri=&declutter($uri);
# if it is a non metadata possible uri return quickly
- if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||
+ if (($uri eq '') ||
+ (($uri =~ m|^/*adm/|) &&
+ ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
($uri =~ m|home/[^/]+/public_html/|)) {
return undef;
@@ -5029,7 +5068,21 @@ sub filelocation {
$location = $file;
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
} elsif ($file=~/^\/*uploaded/) { # is an uploaded file
- $location=$file;
+ if ($file=~/^\/uploaded\/([^\/]+)\/([^\/]+)\/(\/)?simplepage\/([^\/]+)$/) {
+ $location=&Apache::loncommon::propath($1,$2).'/userfiles/simplepage/'.$4;
+ if (not -e $location) {
+ $file=~/^\/uploaded\/(.*)$/;
+ $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.$1;
+ }
+ } elsif ($file=~/^\/uploaded\/([^\/]+)\/([^\/]+)\/aboutme\/([^\/]+)$/) {
+ $location=&Apache::loncommon::propath($1,$2).'/userfiles/aboutme/'.$3;
+ if (not -e $location) {
+ $file=~/^\/uploaded\/(.*)$/;
+ $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.$1;
+ }
+ } else {
+ $location=$file;
+ }
} else {
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
$file=~s:^/res/:/:;
@@ -5920,6 +5973,17 @@ 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)