--- loncom/lonnet/perl/lonnet.pm 2004/06/30 12:33:47 1.517
+++ loncom/lonnet/perl/lonnet.pm 2004/09/15 20:44:05 1.523.2.3
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.517 2004/06/30 12:33:47 albertel Exp $
+# $Id: lonnet.pm,v 1.523.2.3 2004/09/15 20:44:05 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -50,7 +50,7 @@ use Fcntl qw(:flock);
use Apache::loncoursedata;
use Apache::lonlocal;
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
-use Time::HiRes();
+use Time::HiRes qw( gettimeofday tv_interval );
my $readit;
=pod
@@ -827,9 +827,10 @@ sub devalidate_cache {
my ($cache,$id,$name) = @_;
delete $$cache{$id.'.time'};
delete $$cache{$id};
- if ($disk_caching_disabled) { return; }
+ if (1 || $disk_caching_disabled) { return; }
my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
- open(DB,"$filename.lock");
+ if (!-e $filename) { return; }
+ open(DB,">$filename.lock");
flock(DB,LOCK_EX);
my %hash;
if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
@@ -881,34 +882,55 @@ sub do_cache {
$$cache{$id};
}
+my %do_save_item;
+my %do_save;
sub save_cache_item {
my ($cache,$name,$id)=@_;
if ($disk_caching_disabled) { return; }
- my $starttime=&Time::HiRes::time();
-# &logthis("Saving :$name:$id");
- my %hash;
- my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
- open(DB,"$filename.lock");
- flock(DB,LOCK_EX);
- if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
- eval <<'EVALBLOCK';
- $hash{$id.'.time'}=$$cache{$id.'.time'};
- $hash{$id}=freeze({'item'=>$$cache{$id}});
+ $do_save{$name}=$cache;
+ if (!exists($do_save_item{$name})) { $do_save_item{$name}={} }
+ $do_save_item{$name}->{$id}=1;
+ return;
+}
+
+sub save_cache {
+ if ($disk_caching_disabled) { return; }
+ my ($cache,$name,$id);
+ foreach $name (keys(%do_save)) {
+ $cache=$do_save{$name};
+
+ my $starttime=&Time::HiRes::time();
+ &logthis("Saving :$name:");
+ my %hash;
+ my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
+ open(DB,">$filename.lock");
+ flock(DB,LOCK_EX);
+ if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
+ foreach $id (keys(%{ $do_save_item{$name} })) {
+ eval <<'EVALBLOCK';
+ $hash{$id.'.time'}=$$cache{$id.'.time'};
+ $hash{$id}=freeze({'item'=>$$cache{$id}});
EVALBLOCK
- if ($@) {
- &logthis("<font color='red'>save_cache blew up :$@:$name</font>");
- unlink($filename);
- }
- } else {
- if (-e $filename) {
- &logthis("Unable to tie hash (save cache item): $name ($!)");
- unlink($filename);
+ if ($@) {
+ &logthis("<font color='red'>save_cache blew up :$@:$name</font>");
+ unlink($filename);
+ last;
+ }
+ }
+ } else {
+ if (-e $filename) {
+ &logthis("Unable to tie hash (save cache): $name ($!)");
+ unlink($filename);
+ }
}
+ untie(%hash);
+ flock(DB,LOCK_UN);
+ close(DB);
+ &logthis("save_cache $name took ".(&Time::HiRes::time()-$starttime));
}
- untie(%hash);
- flock(DB,LOCK_UN);
- close(DB);
-# &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime));
+ undef(%do_save);
+ undef(%do_save_item);
+
}
sub load_cache_item {
@@ -918,7 +940,8 @@ sub load_cache_item {
# &logthis("Before Loading $name for $id size is ".scalar(%$cache));
my %hash;
my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
- open(DB,"$filename.lock");
+ if (!-e $filename) { return; }
+ open(DB,">$filename.lock");
flock(DB,LOCK_SH);
if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {
eval <<'EVALBLOCK';
@@ -1047,6 +1070,7 @@ 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);
@@ -1067,6 +1091,7 @@ 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);
@@ -1282,6 +1307,22 @@ sub userfileupload {
# See if there is anything left
unless ($fname) { return 'error: no uploaded file'; }
chop($ENV{'form.'.$formname});
+ if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently
+ my $now = time;
+ my $filepath = 'tmp/helprequests/'.$now;
+ my @parts=split(/\//,$filepath);
+ my $fullpath = $perlvar{'lonDaemons'};
+ for (my $i=0;$i<@parts;$i++) {
+ $fullpath .= '/'.$parts[$i];
+ if ((-e $fullpath)!=1) {
+ mkdir($fullpath,0777);
+ }
+ }
+ open(my $fh,'>'.$fullpath.'/'.$fname);
+ print $fh $ENV{'form.'.$formname};
+ close($fh);
+ return $fullpath.'/'.$fname;
+ }
# Create the directory if not present
my $docuname='';
my $docudom='';
@@ -1600,7 +1641,7 @@ sub getannounce {
if ($announcement=~/\w/) {
return
'<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
- '<tr><td bgcolor="#FFFFFF"><pre>'.$announcement.'</pre></td></tr></table>';
+ '<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>';
} else {
return '';
}
@@ -3203,6 +3244,32 @@ sub auto_create_password {
return ($authparam,$create_passwd,$authchk);
}
+sub auto_instcode_format {
+ my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;
+ my $courses = '';
+ my $homeserver;
+ if ($caller eq 'global') {
+ $homeserver = $perlvar{'lonHostID'};
+ } else {
+ $homeserver = &homeserver($caller,$codedom);
+ }
+ my $host=$hostname{$homeserver};
+ foreach (keys %{$instcodes}) {
+ $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';
+ }
+ chop($courses);
+ my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver);
+ unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
+ my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response;
+ %{$codes} = &str2hash($codes_str);
+ @{$codetitles} = &str2array($codetitles_str);
+ %{$cat_titles} = &str2hash($cat_titles_str);
+ %{$cat_order} = &str2hash($cat_order_str);
+ return 'ok';
+ }
+ return $response;
+}
+
# ------------------------------------------------------------------ Plain Text
sub plaintext {
@@ -3585,16 +3652,19 @@ sub revokecustomrole {
# ------------------------------------------------------------ Portfolio Director Lister
+# returns listing of contents of user's /userfiles/portfolio/ directory
+#
+
sub portfoliolist {
-#FIXME us the ls: command instead please
-#FIXME uhome should never be an argument to any lonnet functions
- # returns listing of contents of user's /userfiles/portfolio/ directory
- #
- my ($udom,$uname,$uhome);
+ my ($currentPath, $currentFile) = @_;
+ my ($udom, $uname, $portfolioRoot);
$uname=$ENV{'user.name'};
$udom=$ENV{'user.domain'};
- $uhome=$ENV{'user.home'};
- my $listing = &reply('portls:'.$uname.':'.$udom, $uhome);
+ # really should interrogate the system for home directory information, but . . .
+ $portfolioRoot = '/home/httpd/lonUsers/'.$udom.'/';
+ $uname =~ /^(.?)(.?)(.?)/;
+ $portfolioRoot = $portfolioRoot.$1.'/'.$2.'/'.$3.'/'.$uname.'/userfiles/portfolio';
+ my $listing = &reply('ls:'.$portfolioRoot.$currentPath, &homeserver($uname,$udom));
return $listing;
}
@@ -3949,11 +4019,14 @@ sub EXT {
my $section;
if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {
+ if (!$symbparm) { $symbparm=&symbread(); }
+ }
+ if ($symbparm && defined($courseid) &&
+ $courseid eq $ENV{'request.course.id'}) {
#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
# ----------------------------------------------------- Cascading lookup scheme
- if (!$symbparm) { $symbparm=&symbread(); }
my $symbp=$symbparm;
my $mapp=(&decode_symb($symbp))[0];
@@ -3964,11 +4037,11 @@ sub EXT {
($ENV{'user.domain'} eq $udom)) {
$section=$ENV{'request.course.sec'};
} else {
- if (! defined($usection)) {
- $section=&usection($udom,$uname,$courseid);
- } else {
- $section = $usection;
- }
+ if (! defined($usection)) {
+ $section=&usection($udom,$uname,$courseid);
+ } else {
+ $section = $usection;
+ }
}
my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
@@ -4006,7 +4079,7 @@ sub EXT {
$uname." at ".$udom.": ".
$tmp."</font>");
} elsif ($tmp=~/error: 2 /) {
- &EXT_cache_set($udom,$uname);
+ &EXT_cache_set($udom,$uname);
} elsif ($tmp =~ /^(con_lost|no_such_host)/) {
return $tmp;
}
@@ -4016,10 +4089,10 @@ sub EXT {
# -------------------------------------------------------- second, check course
my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},
- $ENV{'course.'.$courseid.'.domain'},
- ($seclevelr,$seclevelm,$seclevel,
- $courselevelr,$courselevelm,
- $courselevel));
+ $ENV{'course.'.$courseid.'.domain'},
+ ($seclevelr,$seclevelm,$seclevel,
+ $courselevelr,$courselevelm,
+ $courselevel));
if (defined($coursereply)) { return $coursereply; }
# ------------------------------------------------------ third, check map parms
@@ -4517,14 +4590,23 @@ sub deversion {
sub symbread {
my ($thisfn,$donotrecurse)=@_;
+ if (defined($ENV{'request.symbread.cached'})) {
+ return $ENV{'request.symbread.cached'};
+ }
# no filename provided? try from environment
unless ($thisfn) {
- if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }
+ if ($ENV{'request.symb'}) {
+ $ENV{'request.symbread.cached'}=&symbclean($ENV{'request.symb'});
+ return $ENV{'request.symbread.cached'};
+ }
$thisfn=$ENV{'request.filename'};
}
# is that filename actually a symb? Verify, clean, and return
if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
- if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); }
+ if (&symbverify($thisfn,$1)) {
+ $ENV{'request.symbread.cached'}=&symbclean($thisfn);
+ return $ENV{'request.symbread.cached'};
+ }
}
$thisfn=declutter($thisfn);
my %hash;
@@ -4545,6 +4627,7 @@ sub symbread {
unless ($syval=~/\_\d+$/) {
unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
&appenv('request.ambiguous' => $thisfn);
+ $ENV{'request.symbread.cached'}='';
return '';
}
$syval.=$1;
@@ -4592,10 +4675,12 @@ sub symbread {
}
}
if ($syval) {
- return &symbclean($syval.'___'.$thisfn);
+ $ENV{'request.symbread.cached'}=&symbclean($syval.'___'.$thisfn);
+ return $ENV{'request.symbread.cached'};
}
}
&appenv('request.ambiguous' => $thisfn);
+ $ENV{'request.symbread.cached'}='';
return '';
}
@@ -4899,7 +4984,6 @@ sub getfile {
}
} else {
$lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);
- &logthis("return is $lwpresp");
if ($lwpresp ne 'ok') {
my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',&tokenwrapper($file));
@@ -4913,7 +4997,7 @@ sub getfile {
my @parts = ($cdom,$cnum);
if ($filename =~ m|^(.+)/[^/]+$|) {
push @parts, split(/\//,$1);
- }
+ }
foreach my $part (@parts) {
$path .= '/'.$part;
if (!-e $path) {