--- loncom/lonnet/perl/lonnet.pm 2004/08/25 16:03:17 1.532
+++ loncom/lonnet/perl/lonnet.pm 2004/11/08 23:08:46 1.565
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.532 2004/08/25 16:03:17 albertel Exp $
+# $Id: lonnet.pm,v 1.565 2004/11/08 23:08:46 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -39,19 +39,19 @@ qw(%perlvar %hostname %homecache %badSer
%libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
%courselogs %accesshash %userrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache
- %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def
- %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);
+ %userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def
+ %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit);
use IO::Socket;
use GDBM_File;
use Apache::Constants qw(:common :http);
use HTML::LCParser;
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 Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
+use Time::HiRes qw( gettimeofday tv_interval );
my $readit;
+my $max_connection_retries = 10; # Or some such value.
=pod
@@ -116,14 +116,40 @@ sub logperm {
sub subreply {
my ($cmd,$server)=@_;
my $peerfile="$perlvar{'lonSockDir'}/$server";
- my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
- Type => SOCK_STREAM,
- Timeout => 10)
- or return "con_lost";
- print $client "$cmd\n";
- my $answer=<$client>;
- if (!$answer) { $answer="con_lost"; }
- chomp($answer);
+ #
+ # 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
+ # socket. In that time interval, a lock file will exist:
+
+ my $lockfile=$peerfile.".lock";
+ while (-e $lockfile) { # Need to wait for the lockfile to disappear.
+ sleep(1);
+ }
+ # At this point, either a loncnew parent is listening or an old lonc
+ # or loncnew child is listening so we can connect or everything's dead.
+ #
+ # We'll give the connection a few tries before abandoning it. If
+ # connection is not possible, we'll con_lost back to the client.
+ #
+ my $client;
+ for (my $retries = 0; $retries < $max_connection_retries; $retries++) {
+ $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
+ Type => SOCK_STREAM,
+ Timeout => 10);
+ if($client) {
+ last; # Connected!
+ }
+ sleep(1); # Try again later if failed connection.
+ }
+ my $answer;
+ if ($client) {
+ print $client "$cmd\n";
+ $answer=<$client>;
+ if (!$answer) { $answer="con_lost"; }
+ chomp($answer);
+ } else {
+ $answer = 'con_lost'; # Failed connection.
+ }
return $answer;
}
@@ -434,7 +460,7 @@ sub overloaderror {
if ($overload>0) {
$r->err_headers_out->{'Retry-After'}=$overload;
$r->log_error('Overload of '.$overload.' on '.$checkserver);
- return 409;
+ return 413;
}
return '';
}
@@ -771,6 +797,11 @@ sub getsection {
my ($udom,$unam,$courseid)=@_;
$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;
+
+ my $hashid="$udom:$unam:$courseid";
+ my ($result,$cached)=&is_cached(\%getsectioncache,$hashid,'getsection');
+ if (defined($cached)) { return $result; }
+
my %Pending;
my %Expired;
#
@@ -795,29 +826,29 @@ sub getsection {
if ($key eq $courseid.'_st') { $section=''; }
my ($dummy,$end,$start)=split(/\_/,&unescape($value));
my $now=time;
- if (defined($end) && ($now > $end)) {
+ if (defined($end) && $end && ($now > $end)) {
$Expired{$end}=$section;
next;
}
- if (defined($start) && ($now < $start)) {
+ if (defined($start) && $start && ($now < $start)) {
$Pending{$start}=$section;
next;
}
- return $section;
+ return &do_cache(\%getsectioncache,$hashid,$section,'getsection');
}
#
# Presumedly there will be few matching roles from the above
# loop and the sorting time will be negligible.
if (scalar(keys(%Pending))) {
my ($time) = sort {$a <=> $b} keys(%Pending);
- return $Pending{$time};
+ return &do_cache(\%getsectioncache,$hashid,$Pending{$time},'getsection');
}
if (scalar(keys(%Expired))) {
my @sorted = sort {$a <=> $b} keys(%Expired);
my $time = pop(@sorted);
- return $Expired{$time};
+ return &do_cache(\%getsectioncache,$hashid,$Expired{$time},'getsection');
}
- return '-1';
+ return &do_cache(\%getsectioncache,$hashid,'-1','getsection');
}
@@ -826,10 +857,12 @@ my $disk_caching_disabled=1;
sub devalidate_cache {
my ($cache,$id,$name) = @_;
delete $$cache{$id.'.time'};
+ delete $$cache{$id.'.file'};
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)) {
@@ -856,16 +889,32 @@ sub is_cached {
my ($cache,$id,$name,$time) = @_;
if (!$time) { $time=300; }
if (!exists($$cache{$id.'.time'})) {
- &load_cache_item($cache,$name,$id);
+ &load_cache_item($cache,$name,$id,$time);
}
if (!exists($$cache{$id.'.time'})) {
# &logthis("Didn't find $id");
return (undef,undef);
} else {
if (time-($$cache{$id.'.time'})>$time) {
-# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));
- &devalidate_cache($cache,$id,$name);
- return (undef,undef);
+ if (exists($$cache{$id.'.file'})) {
+ foreach my $filename (@{ $$cache{$id.'.file'} }) {
+ my $mtime=(stat($filename))[9];
+ #+1 is to take care of edge effects
+ if ($mtime && (($mtime+1) < ($$cache{$id.'.time'}))) {
+# &logthis("Upping $mtime - ".$$cache{$id.'.time'}.
+# "$id because of $filename");
+ } else {
+ &logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'})));
+ &devalidate_cache($cache,$id,$name);
+ return (undef,undef);
+ }
+ }
+ $$cache{$id.'.time'}=time;
+ } else {
+# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));
+ &devalidate_cache($cache,$id,$name);
+ return (undef,undef);
+ }
}
}
return ($$cache{$id},1);
@@ -881,44 +930,69 @@ 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}});
+ if (exists($$cache{$id.'.file'})) {
+ $hash{$id.'.file'}=freeze({'item'=>$$cache{$id.'.file'}});
+ }
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 {
- my ($cache,$name,$id)=@_;
+ my ($cache,$name,$id,$time)=@_;
if ($disk_caching_disabled) { return; }
my $starttime=&Time::HiRes::time();
# &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';
@@ -935,9 +1009,17 @@ sub load_cache_item {
}
# &logthis("Initial load: $count");
} else {
- my $hashref=thaw($hash{$id});
- $$cache{$id}=$hashref->{'item'};
- $$cache{$id.'.time'}=$hash{$id.'.time'};
+ if (($$cache{$id.'.time'}+$time) < time) {
+ $$cache{$id.'.time'}=$hash{$id.'.time'};
+ {
+ my $hashref=thaw($hash{$id});
+ $$cache{$id}=$hashref->{'item'};
+ }
+ if (exists($hash{$id.'.file'})) {
+ my $hashref=thaw($hash{$id.'.file'});
+ $$cache{$id.'.file'}=$hashref->{'item'};
+ }
+ }
}
EVALBLOCK
if ($@) {
@@ -957,38 +1039,6 @@ EVALBLOCK
# &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));
}
-sub usection {
- my ($udom,$unam,$courseid)=@_;
- my $hashid="$udom:$unam:$courseid";
-
- my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection');
- if (defined($cached)) { return $result; }
- $courseid=~s/\_/\//g;
- $courseid=~s/^(\w)/\/$1/;
- foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
- &homeserver($unam,$udom)))) {
- my ($key,$value)=split(/\=/,$_);
- $key=&unescape($key);
- if ($key=~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/) {
- my $section=$1;
- if ($key eq $courseid.'_st') { $section=''; }
- my ($dummy,$end,$start)=split(/\_/,&unescape($value));
- my $now=time;
- my $notactive=0;
- if ($start) {
- if ($now<$start) { $notactive=1; }
- }
- if ($end) {
- if ($now>$end) { $notactive=1; }
- }
- unless ($notactive) {
- return &do_cache(\%usectioncache,$hashid,$section,'usection');
- }
- }
- }
- return &do_cache(\%usectioncache,$hashid,'-1','usection');
-}
-
# ------------------------------------- Read an entry from a user's environment
sub userenvironment {
@@ -1067,7 +1117,12 @@ sub subscribe {
sub repcopy {
my $filename=shift;
$filename=~s/\/+/\//g;
- if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; }
+ if ($filename=~m|^/home/httpd/html/adm/|) { return OK; }
+ if ($filename=~m|^/home/httpd/html/lonUsers/|) { return OK; }
+ if ($filename=~m|^/home/httpd/html/userfiles/| or
+ $filename=~m|^/*uploaded/|) {
+ return &repcopy_userfile($filename);
+ }
$filename=~s/[\n\r]//g;
my $transname="$filename.in.transfer";
if ((-e $filename) || (-e $transname)) { return OK; }
@@ -1133,8 +1188,7 @@ sub ssi_body {
my ($filelink,%form)=@_;
my $output=($filelink=~/^http\:/?&externalssi($filelink):
&ssi($filelink,%form));
- $output=~
- s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
+ $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s*(-->)?\s||gs;
$output=~s/^.*?\<body[^\>]*\>//si;
$output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
return $output;
@@ -1279,6 +1333,9 @@ sub clean_filename {
$fname=~s/\s+/\_/g;
# Replace all other weird characters by nothing
$fname=~s/[^\w\.\-]//g;
+# Replace all .\d. sequences with _\d. so they no longer look like version
+# numbers
+ $fname=~s/\.(\d+)(?=\.)/_$1/g;
return $fname;
}
@@ -1814,6 +1871,7 @@ sub devalidate {
# - the student level sheet of this user in course's homespace
# - the assessment level sheet for this resource
# for this user in user's homespace
+ # - current conditional state info
my $key=$uname.':'.$udom.':';
my $status=
&del('nohist_calculatedsheets',
@@ -1828,6 +1886,7 @@ sub devalidate {
$uname.' at '.$udom.' for '.
$symb.': '.$status);
}
+ &delenv('user.state.'.$cid);
}
}
@@ -2409,7 +2468,6 @@ sub rolesinit {
my $author=0;
foreach (keys %allroles) {
%thesepriv=();
- if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
foreach (split(/:/,$allroles{$_})) {
if ($_ ne '') {
@@ -2421,6 +2479,7 @@ sub rolesinit {
$thesepriv{$privilege}.=$restrictions;
}
}
+ if ($thesepriv{'adv'} eq 'F') { $adv=1; }
}
}
$thesestr='';
@@ -2455,7 +2514,7 @@ sub get {
my %returnhash=();
my $i=0;
foreach (@$storearr) {
- $returnhash{$_}=unescape($pairs[$i]);
+ $returnhash{$_}=&thaw_unescape($pairs[$i]);
$i++;
}
return %returnhash;
@@ -2494,7 +2553,7 @@ sub dump {
my %returnhash=();
foreach (@pairs) {
my ($key,$value)=split(/=/,$_);
- $returnhash{unescape($key)}=unescape($value);
+ $returnhash{unescape($key)}=&thaw_unescape($value);
}
return %returnhash;
}
@@ -2540,7 +2599,7 @@ sub currentdump {
my ($key,$value)=split(/=/,$_);
my ($symb,$param) = split(/:/,$key);
$returnhash{&unescape($symb)}->{&unescape($param)} =
- &unescape($value);
+ &thaw_unescape($value);
}
}
return %returnhash;
@@ -2606,7 +2665,7 @@ sub put {
my $uhome=&homeserver($uname,$udomain);
my $items='';
foreach (keys %$storehash) {
- $items.=&escape($_).'='.&escape($$storehash{$_}).'&';
+ $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
}
$items=~s/\&$//;
return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
@@ -2645,7 +2704,7 @@ sub cput {
my $uhome=&homeserver($uname,$udomain);
my $items='';
foreach (keys %$storehash) {
- $items.=escape($_).'='.escape($$storehash{$_}).'&';
+ $items.=escape($_).'='.&freeze_escape($$storehash{$_}).'&';
}
$items=~s/\&$//;
return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
@@ -2668,7 +2727,7 @@ sub eget {
my %returnhash=();
my $i=0;
foreach (@$storearr) {
- $returnhash{$_}=unescape($pairs[$i]);
+ $returnhash{$_}=&thaw_unescape($pairs[$i]);
$i++;
}
return %returnhash;
@@ -2715,7 +2774,9 @@ sub allowed {
$uri=&deversion($uri);
my $orguri=$uri;
$uri=&declutter($uri);
-
+
+
+
if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; }
# Free bre access to adm and meta resources
if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|))
@@ -2723,6 +2784,13 @@ sub allowed {
return 'F';
}
+# Free bre access to user's own portfolio contents
+ my ($space,$domain,$name,$dir)=split('/',$uri);
+ if (('uploaded' eq $space) && ($ENV{'user.name'} eq $name) &&
+ ($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {
+ return 'F';
+ }
+
# Free bre to public access
if ($priv eq 'bre') {
@@ -3124,8 +3192,10 @@ sub log_query {
sub fetch_enrollment_query {
my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
my $homeserver;
+ my $maxtries = 1;
if ($context eq 'automated') {
$homeserver = $perlvar{'lonHostID'};
+ $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
} else {
$homeserver = &homeserver($cnum,$dom);
}
@@ -3143,8 +3213,13 @@ sub fetch_enrollment_query {
return 'error: '.$queryid;
}
my $reply = &get_query_reply($queryid);
+ my $tries = 1;
+ while (($reply=~/^timeout/) && ($tries < $maxtries)) {
+ $reply = &get_query_reply($queryid);
+ $tries ++;
+ }
if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
- &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum);
+ &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
} else {
my @responses = split/:/,$reply;
if ($homeserver eq $perlvar{'lonHostID'}) {
@@ -3551,8 +3626,7 @@ sub modify_student_enrollment {
$gene = $tmp{'generation'} if (!defined($gene) || $gene eq '');
$uid = $tmp{'id'} if (!defined($uid) || $uid eq '');
}
- my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,
- $first,$middle);
+ my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
my $reply=cput('classlist',
{"$uname:$udom" =>
join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
@@ -3569,6 +3643,25 @@ sub modify_student_enrollment {
return &assignrole($udom,$uname,$uurl,'st',$end,$start);
}
+sub format_name {
+ my ($firstname,$middlename,$lastname,$generation,$first)=@_;
+ my $name;
+ if ($first ne 'lastname') {
+ $name=$firstname.' '.$middlename.' '.$lastname.' '.$generation;
+ } else {
+ if ($lastname=~/\S/) {
+ $name.= $lastname.' '.$generation.', '.$firstname.' '.$middlename;
+ $name=~s/\s+,/,/;
+ } else {
+ $name.= $firstname.' '.$middlename.' '.$generation;
+ }
+ }
+ $name=~s/^\s+//;
+ $name=~s/\s+$//;
+ $name=~s/\s+/ /g;
+ return $name;
+}
+
# ------------------------------------------------- Write to course preferences
sub writecoursepref {
@@ -3679,41 +3772,80 @@ sub revokecustomrole {
$deleteflag);
}
-
-# ------------------------------------------------------------ Portfolio Director Lister
-# returns listing of contents of user's /userfiles/portfolio/ directory
-#
-
-sub portfoliolist {
- my ($currentPath, $currentFile) = @_;
- my ($udom, $uname, $portfolioRoot);
- $uname=$ENV{'user.name'};
- $udom=$ENV{'user.domain'};
- # 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));
+# ------------------------------------------------------------ Disk usage
+sub diskusage {
+ my ($udom,$uname,$directoryRoot)=@_;
+ $directoryRoot =~ s/\/$//;
+ my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));
return $listing;
}
-sub portfoliomanage {
+# ------------------------------------------------------------- Mark as Read Only
-#FIXME please user the existing remove userfile function instead and
-#add a userfilerename functions.
-#FIXME uhome should never be an argument to any lonnet functions
-
- # handles deleting and renaming files in user's userfiles/portfolio/ directory
- #
- my ($filename, $fileaction, $filenewname) = @_;
- my ($udom, $uname, $uhome);
- $uname=$ENV{'user.name'};
- $udom=$ENV{'user.domain'};
- $uhome=$ENV{'user.home'};
- my $listing = reply('portfoliomanage:'.$uname.':'.$udom.':'.$filename.':'.$fileaction.':'.$filenewname, $uhome);
- return $listing;
+sub mark_as_readonly {
+ my ($domain,$user,$files,$what) = @_;
+ my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
+ foreach my $file (@{$files}) {
+ push(@{$current_permissions{$file}},$what);
+ }
+ &Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user);
+ return;
+}
+
+#--------------------------------------------------------------Get Marked as Read Only
+
+sub get_marked_as_readonly {
+ my ($domain,$user,$what) = @_;
+ my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
+ my @readonly_files;
+ while (my ($file_name,$value) = each(%current_permissions)) {
+ &logthis("found $file_name");
+ if (ref($value) eq "ARRAY"){
+ &logthis("found array");
+ foreach my $stored_what (@{$value}) {
+ if ($stored_what eq $what) {
+ push(@readonly_files, $file_name);
+ &logthis("defined pushed $file_name");
+ } elsif (!defined($what)) {
+ push(@readonly_files, $file_name);
+ &logthis("undef pushed $file_name");
+ }
+ }
+ }
+ }
+ return @readonly_files;
}
+# ------------------------------------------------------------ Unmark as Read Only
+
+sub unmark_as_readonly {
+ # unmarks all files locked by $what
+ # for portfolio submissions, $what contains $crsid and $symb
+ my ($domain,$user,$what) = @_;
+ my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
+ my @readonly_files = &Apache::lonnet::get_marked_as_readonly($domain,$user,$what);
+ foreach my $file(@readonly_files){
+ my $current_locks = $current_permissions{$file};
+ my @new_locks;
+ my @del_keys;
+ if (ref($current_locks) eq "ARRAY"){
+ foreach my $locker (@{$current_locks}) {
+ unless ($locker eq $what) {
+ push(@new_locks, $what);
+ }
+ }
+ if (@new_locks > 0) {
+ $current_permissions{$file} = \@new_locks;
+ } else {
+ push(@del_keys, $file);
+ &Apache::lonnet::del('file_permissions',\@del_keys, $domain, $user);
+ delete $current_permissions{$file};
+ }
+ }
+ }
+ &Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user);
+ return;
+}
# ------------------------------------------------------------ Directory lister
@@ -3823,6 +3955,9 @@ sub GetFileTimestamp {
sub directcondval {
my $number=shift;
+ if (!defined($ENV{'user.state.'.$ENV{'request.course.id'}})) {
+ &Apache::lonuserstate::evalstate();
+ }
if ($ENV{'user.state.'.$ENV{'request.course.id'}}) {
return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1);
} else {
@@ -4048,11 +4183,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];
@@ -4063,11 +4201,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=&getsection($udom,$uname,$courseid);
+ } else {
+ $section = $usection;
+ }
}
my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
@@ -4105,7 +4243,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;
}
@@ -4115,10 +4253,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
@@ -4253,7 +4391,9 @@ sub metadata {
unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring;
if ($uri !~ m|^uploaded/|) {
- $metastring=&getfile(&filelocation('',&clutter($filename)));
+ my $file=&filelocation('',&clutter($filename));
+ push(@{$metacache{$uri.'.file'}},$file);
+ $metastring=&getfile($file);
}
my $parser=HTML::LCParser->new(\$metastring);
my $token;
@@ -4466,27 +4606,27 @@ sub metadata_generate_part0 {
sub gettitle {
my $urlsymb=shift;
my $symb=&symbread($urlsymb);
- unless ($symb) {
- unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }
- return &metadata($urlsymb,'title');
- }
- my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
- if (defined($cached)) { return $result; }
- my ($map,$resid,$url)=&decode_symb($symb);
- my $title='';
- my %bighash;
- if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
- &GDBM_READER(),0640)) {
- my $mapid=$bighash{'map_pc_'.&clutter($map)};
- $title=$bighash{'title_'.$mapid.'.'.$resid};
- untie %bighash;
- }
- $title=~s/\&colon\;/\:/gs;
- if ($title) {
- return &do_cache(\%titlecache,$symb,$title,'title');
- } else {
- return &metadata($urlsymb,'title');
- }
+ if ($symb) {
+ my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
+ if (defined($cached)) { return $result; }
+ my ($map,$resid,$url)=&decode_symb($symb);
+ my $title='';
+ my %bighash;
+ if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
+ &GDBM_READER(),0640)) {
+ my $mapid=$bighash{'map_pc_'.&clutter($map)};
+ $title=$bighash{'title_'.$mapid.'.'.$resid};
+ untie %bighash;
+ }
+ $title=~s/\&colon\;/\:/gs;
+ if ($title) {
+ return &do_cache(\%titlecache,$symb,$title,'title');
+ }
+ $urlsymb=$url;
+ }
+ my $title=&metadata($urlsymb,'title');
+ if (!$title) { $title=(split('/',$urlsymb))[-1]; }
+ return $title;
}
# ------------------------------------------------- Update symbolic store links
@@ -4618,14 +4758,20 @@ sub deversion {
sub symbread {
my ($thisfn,$donotrecurse)=@_;
+ my $cache_str='request.symbread.cached.'.$thisfn;
+ if (defined($ENV{$cache_str})) { return $ENV{$cache_str}; }
# no filename provided? try from environment
unless ($thisfn) {
- if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }
+ if ($ENV{'request.symb'}) {
+ return $ENV{$cache_str}=&symbclean($ENV{'request.symb'});
+ }
$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)) {
+ return $ENV{$cache_str}=&symbclean($thisfn);
+ }
}
$thisfn=declutter($thisfn);
my %hash;
@@ -4646,7 +4792,7 @@ sub symbread {
unless ($syval=~/\_\d+$/) {
unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
&appenv('request.ambiguous' => $thisfn);
- return '';
+ return $ENV{$cache_str}='';
}
$syval.=$1;
}
@@ -4693,11 +4839,11 @@ sub symbread {
}
}
if ($syval) {
- return &symbclean($syval.'___'.$thisfn);
+ return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn);
}
}
&appenv('request.ambiguous' => $thisfn);
- return '';
+ return $ENV{$cache_str}='';
}
# ---------------------------------------------------------- Return random seed
@@ -4711,6 +4857,7 @@ sub numval {
$txt=~tr/U-Z/0-5/;
$txt=~tr/u-z/0-5/;
$txt=~s/\D//g;
+ if ($_64bit) { if ($txt > 2**32) { return -1; } }
return int($txt);
}
@@ -4726,6 +4873,7 @@ sub numval2 {
my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
my $total;
foreach my $val (@txts) { $total+=$val; }
+ if ($_64bit) { if ($total > 2**32) { return -1; } }
return int($total);
}
@@ -4742,10 +4890,16 @@ sub get_rand_alg {
return &latest_rnd_algorithm_id();
}
+sub validCODE {
+ my ($CODE)=@_;
+ if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; }
+ return 0;
+}
+
sub getCODE {
- if (defined($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; }
+ if (&validCODE($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; }
if (defined($Apache::lonhomework::parsing_a_problem) &&
- defined($Apache::lonhomework::history{'resource.CODE'})) {
+ &validCODE($Apache::lonhomework::history{'resource.CODE'})) {
return $Apache::lonhomework::history{'resource.CODE'};
}
return undef;
@@ -4787,6 +4941,7 @@ sub rndseed_32bit {
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
#&Apache::lonxml::debug("rndseed :$num:$symb");
+ if ($_64bit) { $num=(($num<<32)>>32); }
return $num;
}
}
@@ -4807,6 +4962,8 @@ sub rndseed_64bit {
my $num2=$nameseed+$domainseed+$courseseed;
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
#&Apache::lonxml::debug("rndseed :$num:$symb");
+ if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
+ if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
return "$num1,$num2";
}
}
@@ -4850,7 +5007,9 @@ sub rndseed_64bit3 {
my $num1=$symbchck+$symbseed+$namechck;
my $num2=$nameseed+$domainseed+$courseseed;
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
- #&Apache::lonxml::debug("rndseed :$num:$symb");
+ #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit");
+ if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
+
return "$num1:$num2";
}
}
@@ -4868,6 +5027,8 @@ sub rndseed_CODE_64bit {
my $num2=$CODEseed+$courseseed+$symbchck;
#&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
+ if ($_64bit) { $num1=(($num1<<32)>>32); }
+ if ($_64bit) { $num2=(($num2<<32)>>32); }
return "$num1:$num2";
}
}
@@ -4958,30 +5119,32 @@ sub receipt {
# the local server.
sub getfile {
- my ($file,$caller) = @_;
+ my ($file) = @_;
- if ($file !~ m|^/*uploaded/(\w+)/(\w+)/(.+)$|) {
- # normal file from res space
- &repcopy($file);
- return &readfile($file);
- }
-
- my $info;
- my $cdom = $1;
- my $cnum = $2;
- my $filename = $3;
- my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles';
- my ($lwpresp,$rtncode);
- my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename;
- if (-e "$localfile") {
- my @fileinfo = stat($localfile);
- $lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode);
+ if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); }
+ &repcopy($file);
+ return &readfile($file);
+}
+
+sub repcopy_userfile {
+ my ($file)=@_;
+
+ if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); }
+ if ($file =~ m|^/home/httpd/html/lonUsers/|) { return OK; }
+
+ my ($cdom,$cnum,$filename) =
+ ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|);
+ my ($info,$rtncode);
+ my $uri="/uploaded/$cdom/$cnum/$filename";
+ if (-e "$file") {
+ my @fileinfo = stat($file);
+ my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
if ($lwpresp ne 'ok') {
if ($rtncode eq '404') {
- unlink($localfile);
+ unlink($file);
}
#my $ua=new LWP::UserAgent;
- #my $request=new HTTP::Request('GET',&tokenwrapper($file));
+ #my $request=new HTTP::Request('GET',&tokenwrapper($uri));
#my $response=$ua->request($request);
#if ($response->is_success()) {
# return $response->content;
@@ -4991,21 +5154,21 @@ sub getfile {
return -1;
}
if ($info < $fileinfo[9]) {
- return &readfile($localfile);
+ return OK;
}
$info = '';
- $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);
+ $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
if ($lwpresp ne 'ok') {
return -1;
}
} else {
- $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);
+ my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
if ($lwpresp ne 'ok') {
my $ua=new LWP::UserAgent;
- my $request=new HTTP::Request('GET',&tokenwrapper($file));
+ my $request=new HTTP::Request('GET',&tokenwrapper($uri));
my $response=$ua->request($request);
if ($response->is_success()) {
- return $response->content;
+ $info=$response->content;
} else {
return -1;
}
@@ -5014,6 +5177,7 @@ sub getfile {
if ($filename =~ m|^(.+)/[^/]+$|) {
push @parts, split(/\//,$1);
}
+ my $path = $perlvar{'lonDocRoot'}.'/userfiles';
foreach my $part (@parts) {
$path .= '/'.$part;
if (!-e $path) {
@@ -5021,24 +5185,23 @@ sub getfile {
}
}
}
- open (FILE,">$localfile");
+ open(FILE,">$file");
print FILE $info;
close(FILE);
- if ($caller eq 'uploadrep') {
- return 'ok';
- }
- return $info;
+ return OK;
}
sub tokenwrapper {
my $uri=shift;
- $uri=~s/^http\:\/\/([^\/]+)//;
- $uri=~s/^\///;
+ $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.
+ my (undef,$udom,$uname,$file)=split('/',$uri,4);
+ if ($udom && $uname && $file) {
+ $file=~s|(\?\.*)*$||;
+ &appenv("userfile.$udom/$uname/$file" => $ENV{'request.course.id'});
+ return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};
} else {
@@ -5083,20 +5246,18 @@ sub filelocation {
$location = $file;
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
} elsif ($file=~/^\/*uploaded/) { # is an uploaded 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;
- }
+ my ($udom,$uname,$filename)=
+ ($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|);
+ my $home=&homeserver($uname,$udom);
+ my $is_me=0;
+ my @ids=¤t_machine_ids();
+ foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
+ if ($is_me) {
+ $location=&Apache::loncommon::propath($udom,$uname).
+ '/userfiles/'.$filename;
} else {
- $location=$file;
+ $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
+ $udom.'/'.$uname.'/'.$filename;
}
} else {
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
@@ -5173,6 +5334,15 @@ sub clutter {
return $thisfn;
}
+sub freeze_escape {
+ my ($value)=@_;
+ if (ref($value)) {
+ $value=&nfreeze($value);
+ return '__FROZEN__'.&escape($value);
+ }
+ return &escape($value);
+}
+
# -------------------------------------------------------- Escape Special Chars
sub escape {
@@ -5189,6 +5359,16 @@ sub unescape {
return $str;
}
+sub thaw_unescape {
+ my ($value)=@_;
+ if ($value =~ /^__FROZEN__/) {
+ substr($value,0,10,undef);
+ $value=&unescape($value);
+ return &thaw($value);
+ }
+ return &unescape($value);
+}
+
sub mod_perl_version {
if (defined($perlvar{'MODPERL2'})) {
return 2;
@@ -5214,7 +5394,7 @@ sub goodbye {
&logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));
#1.1 only
&logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));
- &logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache)));
+ &logthis(sprintf("%-20s is %s",'%getsectioncache',scalar(%getsectioncache)));
&logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));
&logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache)));
&flushcourselogs();
@@ -5293,10 +5473,6 @@ BEGIN {
$hostip{$id}=$ip;
$iphost{$ip}=$id;
if ($role eq 'library') { $libserv{$id}=$name; }
- } else {
- if ($configline) {
- &logthis("Skipping hosts.tab line -$configline-");
- }
}
}
close($config);
@@ -5373,6 +5549,12 @@ $dumpcount=0;
&logtouch();
&logthis('<font color=yellow>INFO: Read configuration</font>');
$readit=1;
+ {
+ use integer;
+ my $test=(2**32)+1;
+ if ($test != 0) { $_64bit=1; }
+ &logthis(" Detected 64bit platform ($_64bit)");
+ }
}
}
@@ -5600,8 +5782,8 @@ X<rolesinit()>
B<rolesinit($udom,$username,$authhost)>: get user privileges
=item *
-X<usection()>
-B<usection($udom,$uname,$cname)>: finds the section of student in the
+X<getsection()>
+B<getsection($udom,$uname,$cname)>: finds the section of student in the
course $cname, return section name/number or '' for "not in course"
and '-1' for "no section"