|
version 1.525, 2004/08/05 16:59:29
|
version 1.567, 2004/11/10 19:03:04
|
|
Line 39 qw(%perlvar %hostname %homecache %badSer
|
Line 39 qw(%perlvar %hostname %homecache %badSer
|
| %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache |
%libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache |
| %courselogs %accesshash %userrolehash $processmarker $dumpcount |
%courselogs %accesshash %userrolehash $processmarker $dumpcount |
| %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache |
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache |
| %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def |
%userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def |
| %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir); |
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit); |
| |
|
| use IO::Socket; |
use IO::Socket; |
| use GDBM_File; |
use GDBM_File; |
| use Apache::Constants qw(:common :http); |
use Apache::Constants qw(:common :http); |
| use HTML::LCParser; |
use HTML::LCParser; |
| use Fcntl qw(:flock); |
use Fcntl qw(:flock); |
| use Apache::loncoursedata; |
|
| use Apache::lonlocal; |
use Apache::lonlocal; |
| use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw); |
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); |
| use Time::HiRes(); |
use Time::HiRes qw( gettimeofday tv_interval ); |
| my $readit; |
my $readit; |
| |
my $max_connection_retries = 10; # Or some such value. |
| |
|
| =pod |
=pod |
| |
|
|
Line 116 sub logperm {
|
Line 116 sub logperm {
|
| sub subreply { |
sub subreply { |
| my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
| my $peerfile="$perlvar{'lonSockDir'}/$server"; |
my $peerfile="$perlvar{'lonSockDir'}/$server"; |
| my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", |
# |
| Type => SOCK_STREAM, |
# With loncnew process trimming, there's a timing hole between lonc server |
| Timeout => 10) |
# process exit and the master server picking up the listen on the AF_UNIX |
| or return "con_lost"; |
# socket. In that time interval, a lock file will exist: |
| print $client "$cmd\n"; |
|
| my $answer=<$client>; |
my $lockfile=$peerfile.".lock"; |
| if (!$answer) { $answer="con_lost"; } |
while (-e $lockfile) { # Need to wait for the lockfile to disappear. |
| chomp($answer); |
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; |
return $answer; |
| } |
} |
| |
|
|
Line 434 sub overloaderror {
|
Line 460 sub overloaderror {
|
| if ($overload>0) { |
if ($overload>0) { |
| $r->err_headers_out->{'Retry-After'}=$overload; |
$r->err_headers_out->{'Retry-After'}=$overload; |
| $r->log_error('Overload of '.$overload.' on '.$checkserver); |
$r->log_error('Overload of '.$overload.' on '.$checkserver); |
| return 409; |
return 413; |
| } |
} |
| return ''; |
return ''; |
| } |
} |
|
Line 771 sub getsection {
|
Line 797 sub getsection {
|
| my ($udom,$unam,$courseid)=@_; |
my ($udom,$unam,$courseid)=@_; |
| $courseid=~s/\_/\//g; |
$courseid=~s/\_/\//g; |
| $courseid=~s/^(\w)/\/$1/; |
$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 %Pending; |
| my %Expired; |
my %Expired; |
| # |
# |
|
Line 795 sub getsection {
|
Line 826 sub getsection {
|
| if ($key eq $courseid.'_st') { $section=''; } |
if ($key eq $courseid.'_st') { $section=''; } |
| my ($dummy,$end,$start)=split(/\_/,&unescape($value)); |
my ($dummy,$end,$start)=split(/\_/,&unescape($value)); |
| my $now=time; |
my $now=time; |
| if (defined($end) && ($now > $end)) { |
if (defined($end) && $end && ($now > $end)) { |
| $Expired{$end}=$section; |
$Expired{$end}=$section; |
| next; |
next; |
| } |
} |
| if (defined($start) && ($now < $start)) { |
if (defined($start) && $start && ($now < $start)) { |
| $Pending{$start}=$section; |
$Pending{$start}=$section; |
| next; |
next; |
| } |
} |
| return $section; |
return &do_cache(\%getsectioncache,$hashid,$section,'getsection'); |
| } |
} |
| # |
# |
| # Presumedly there will be few matching roles from the above |
# Presumedly there will be few matching roles from the above |
| # loop and the sorting time will be negligible. |
# loop and the sorting time will be negligible. |
| if (scalar(keys(%Pending))) { |
if (scalar(keys(%Pending))) { |
| my ($time) = sort {$a <=> $b} keys(%Pending); |
my ($time) = sort {$a <=> $b} keys(%Pending); |
| return $Pending{$time}; |
return &do_cache(\%getsectioncache,$hashid,$Pending{$time},'getsection'); |
| } |
} |
| if (scalar(keys(%Expired))) { |
if (scalar(keys(%Expired))) { |
| my @sorted = sort {$a <=> $b} keys(%Expired); |
my @sorted = sort {$a <=> $b} keys(%Expired); |
| my $time = pop(@sorted); |
my $time = pop(@sorted); |
| return $Expired{$time}; |
return &do_cache(\%getsectioncache,$hashid,$Expired{$time},'getsection'); |
| } |
} |
| return '-1'; |
return &do_cache(\%getsectioncache,$hashid,'-1','getsection'); |
| } |
} |
| |
|
| |
|
|
Line 826 my $disk_caching_disabled=1;
|
Line 857 my $disk_caching_disabled=1;
|
| sub devalidate_cache { |
sub devalidate_cache { |
| my ($cache,$id,$name) = @_; |
my ($cache,$id,$name) = @_; |
| delete $$cache{$id.'.time'}; |
delete $$cache{$id.'.time'}; |
| |
delete $$cache{$id.'.file'}; |
| delete $$cache{$id}; |
delete $$cache{$id}; |
| if ($disk_caching_disabled) { return; } |
if (1 || $disk_caching_disabled) { return; } |
| my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; |
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); |
flock(DB,LOCK_EX); |
| my %hash; |
my %hash; |
| if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { |
if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { |
|
Line 856 sub is_cached {
|
Line 889 sub is_cached {
|
| my ($cache,$id,$name,$time) = @_; |
my ($cache,$id,$name,$time) = @_; |
| if (!$time) { $time=300; } |
if (!$time) { $time=300; } |
| if (!exists($$cache{$id.'.time'})) { |
if (!exists($$cache{$id.'.time'})) { |
| &load_cache_item($cache,$name,$id); |
&load_cache_item($cache,$name,$id,$time); |
| } |
} |
| if (!exists($$cache{$id.'.time'})) { |
if (!exists($$cache{$id.'.time'})) { |
| # &logthis("Didn't find $id"); |
# &logthis("Didn't find $id"); |
| return (undef,undef); |
return (undef,undef); |
| } else { |
} else { |
| if (time-($$cache{$id.'.time'})>$time) { |
if (time-($$cache{$id.'.time'})>$time) { |
| # &logthis("Devalidating $id - ".time-($$cache{$id.'.time'})); |
if (exists($$cache{$id.'.file'})) { |
| &devalidate_cache($cache,$id,$name); |
foreach my $filename (@{ $$cache{$id.'.file'} }) { |
| return (undef,undef); |
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); |
return ($$cache{$id},1); |
|
Line 881 sub do_cache {
|
Line 930 sub do_cache {
|
| $$cache{$id}; |
$$cache{$id}; |
| } |
} |
| |
|
| |
my %do_save_item; |
| |
my %do_save; |
| sub save_cache_item { |
sub save_cache_item { |
| my ($cache,$name,$id)=@_; |
my ($cache,$name,$id)=@_; |
| if ($disk_caching_disabled) { return; } |
if ($disk_caching_disabled) { return; } |
| my $starttime=&Time::HiRes::time(); |
$do_save{$name}=$cache; |
| # &logthis("Saving :$name:$id"); |
if (!exists($do_save_item{$name})) { $do_save_item{$name}={} } |
| my %hash; |
$do_save_item{$name}->{$id}=1; |
| my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; |
return; |
| open(DB,"$filename.lock"); |
} |
| flock(DB,LOCK_EX); |
|
| if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { |
sub save_cache { |
| eval <<'EVALBLOCK'; |
if ($disk_caching_disabled) { return; } |
| $hash{$id.'.time'}=$$cache{$id.'.time'}; |
my ($cache,$name,$id); |
| $hash{$id}=freeze({'item'=>$$cache{$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 |
EVALBLOCK |
| if ($@) { |
if ($@) { |
| &logthis("<font color='red'>save_cache blew up :$@:$name</font>"); |
&logthis("<font color='red'>save_cache blew up :$@:$name</font>"); |
| unlink($filename); |
unlink($filename); |
| } |
last; |
| } else { |
} |
| if (-e $filename) { |
} |
| &logthis("Unable to tie hash (save cache item): $name ($!)"); |
} else { |
| unlink($filename); |
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); |
undef(%do_save); |
| flock(DB,LOCK_UN); |
undef(%do_save_item); |
| close(DB); |
|
| # &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime)); |
|
| } |
} |
| |
|
| sub load_cache_item { |
sub load_cache_item { |
| my ($cache,$name,$id)=@_; |
my ($cache,$name,$id,$time)=@_; |
| if ($disk_caching_disabled) { return; } |
if ($disk_caching_disabled) { return; } |
| my $starttime=&Time::HiRes::time(); |
my $starttime=&Time::HiRes::time(); |
| # &logthis("Before Loading $name for $id size is ".scalar(%$cache)); |
# &logthis("Before Loading $name for $id size is ".scalar(%$cache)); |
| my %hash; |
my %hash; |
| my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; |
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); |
flock(DB,LOCK_SH); |
| if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) { |
if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) { |
| eval <<'EVALBLOCK'; |
eval <<'EVALBLOCK'; |
|
Line 935 sub load_cache_item {
|
Line 1009 sub load_cache_item {
|
| } |
} |
| # &logthis("Initial load: $count"); |
# &logthis("Initial load: $count"); |
| } else { |
} else { |
| my $hashref=thaw($hash{$id}); |
if (($$cache{$id.'.time'}+$time) < time) { |
| $$cache{$id}=$hashref->{'item'}; |
$$cache{$id.'.time'}=$hash{$id.'.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 |
EVALBLOCK |
| if ($@) { |
if ($@) { |
|
Line 957 EVALBLOCK
|
Line 1039 EVALBLOCK
|
| # &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime)); |
# &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 |
# ------------------------------------- Read an entry from a user's environment |
| |
|
| sub userenvironment { |
sub userenvironment { |
|
Line 1047 sub currentversion {
|
Line 1097 sub currentversion {
|
| sub subscribe { |
sub subscribe { |
| my $fname=shift; |
my $fname=shift; |
| if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; } |
if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; } |
| |
$fname=~s/[\n\r]//g; |
| my $author=$fname; |
my $author=$fname; |
| $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
| my ($udom,$uname)=split(/\//,$author); |
my ($udom,$uname)=split(/\//,$author); |
|
Line 1066 sub subscribe {
|
Line 1117 sub subscribe {
|
| sub repcopy { |
sub repcopy { |
| my $filename=shift; |
my $filename=shift; |
| $filename=~s/\/+/\//g; |
$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"; |
my $transname="$filename.in.transfer"; |
| if ((-e $filename) || (-e $transname)) { return OK; } |
if ((-e $filename) || (-e $transname)) { return OK; } |
| my $remoteurl=subscribe($filename); |
my $remoteurl=subscribe($filename); |
|
Line 1131 sub ssi_body {
|
Line 1188 sub ssi_body {
|
| my ($filelink,%form)=@_; |
my ($filelink,%form)=@_; |
| my $output=($filelink=~/^http\:/?&externalssi($filelink): |
my $output=($filelink=~/^http\:/?&externalssi($filelink): |
| &ssi($filelink,%form)); |
&ssi($filelink,%form)); |
| $output=~ |
$output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s*(-->)?\s||gs; |
| s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs; |
|
| $output=~s/^.*?\<body[^\>]*\>//si; |
$output=~s/^.*?\<body[^\>]*\>//si; |
| $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; |
$output=~s/(.*)\<\/body\s*\>.*?$/$1/si; |
| return $output; |
return $output; |
|
Line 1267 sub process_coursefile {
|
Line 1323 sub process_coursefile {
|
| # input: name of form element, coursedoc=1 means this is for the course |
# input: name of form element, coursedoc=1 means this is for the course |
| # output: url of file in userspace |
# output: url of file in userspace |
| |
|
| sub userfileupload { |
sub clean_filename { |
| my ($formname,$coursedoc,$subdir)=@_; |
my ($fname)=@_; |
| if (!defined($subdir)) { $subdir='unknown'; } |
|
| my $fname=$ENV{'form.'.$formname.'.filename'}; |
|
| # Replace Windows backslashes by forward slashes |
# Replace Windows backslashes by forward slashes |
| $fname=~s/\\/\//g; |
$fname=~s/\\/\//g; |
| # Get rid of everything but the actual filename |
# Get rid of everything but the actual filename |
|
Line 1279 sub userfileupload {
|
Line 1333 sub userfileupload {
|
| $fname=~s/\s+/\_/g; |
$fname=~s/\s+/\_/g; |
| # Replace all other weird characters by nothing |
# Replace all other weird characters by nothing |
| $fname=~s/[^\w\.\-]//g; |
$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; |
| |
} |
| |
|
| |
sub userfileupload { |
| |
my ($formname,$coursedoc,$subdir)=@_; |
| |
if (!defined($subdir)) { $subdir='unknown'; } |
| |
my $fname=$ENV{'form.'.$formname.'.filename'}; |
| |
$fname=&clean_filename($fname); |
| # See if there is anything left |
# See if there is anything left |
| unless ($fname) { return 'error: no uploaded file'; } |
unless ($fname) { return 'error: no uploaded file'; } |
| chop($ENV{'form.'.$formname}); |
chop($ENV{'form.'.$formname}); |
|
Line 1372 sub removeuserfile {
|
Line 1437 sub removeuserfile {
|
| return &reply("removeuserfile:$docudom/$docuname/$fname",$home); |
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); |
| |
} |
| |
|
| |
sub renameuserfile { |
| |
my ($docuname,$docudom,$old,$new)=@_; |
| |
my $home=&homeserver($docuname,$docudom); |
| |
return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'. |
| |
&escape("$new"),$home); |
| |
} |
| |
|
| # ------------------------------------------------------------------------- Log |
# ------------------------------------------------------------------------- Log |
| |
|
| sub log { |
sub log { |
|
Line 1793 sub devalidate {
|
Line 1871 sub devalidate {
|
| # - the student level sheet of this user in course's homespace |
# - the student level sheet of this user in course's homespace |
| # - the assessment level sheet for this resource |
# - the assessment level sheet for this resource |
| # for this user in user's homespace |
# for this user in user's homespace |
| |
# - current conditional state info |
| my $key=$uname.':'.$udom.':'; |
my $key=$uname.':'.$udom.':'; |
| my $status= |
my $status= |
| &del('nohist_calculatedsheets', |
&del('nohist_calculatedsheets', |
|
Line 1807 sub devalidate {
|
Line 1886 sub devalidate {
|
| $uname.' at '.$udom.' for '. |
$uname.' at '.$udom.' for '. |
| $symb.': '.$status); |
$symb.': '.$status); |
| } |
} |
| |
&delenv('user.state.'.$cid); |
| } |
} |
| } |
} |
| |
|
|
Line 2307 sub rolesinit {
|
Line 2387 sub rolesinit {
|
| my $rolesdump=reply("dump:$domain:$username:roles",$authhost); |
my $rolesdump=reply("dump:$domain:$username:roles",$authhost); |
| if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; } |
if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; } |
| my %allroles=(); |
my %allroles=(); |
| my %thesepriv=(); |
|
| my $now=time; |
my $now=time; |
| my $userroles="user.login.time=$now\n"; |
my $userroles="user.login.time=$now\n"; |
| my $thesestr; |
|
| |
|
| if ($rolesdump ne '') { |
if ($rolesdump ne '') { |
| foreach (split(/&/,$rolesdump)) { |
foreach (split(/&/,$rolesdump)) { |
|
Line 2318 sub rolesinit {
|
Line 2396 sub rolesinit {
|
| my ($area,$role)=split(/=/,$_); |
my ($area,$role)=split(/=/,$_); |
| $area=~s/\_\w\w$//; |
$area=~s/\_\w\w$//; |
| my ($trole,$tend,$tstart)=split(/_/,$role); |
my ($trole,$tend,$tstart)=split(/_/,$role); |
| $userroles.='user.role.'.$trole.'.'.$area.'='. |
$userroles.=&set_arearole($trole,$area,$tstart,$tend); |
| $tstart.'.'.$tend."\n"; |
if (($tend!=0) && ($tend<$now)) { $trole=''; } |
| # log the associated role with the area |
if (($tstart!=0) && ($tstart>$now)) { $trole=''; } |
| &userrolelog($trole,$username,$domain,$area,$tstart,$tend); |
|
| if ($tend!=0) { |
|
| if ($tend<$now) { |
|
| $trole=''; |
|
| } |
|
| } |
|
| if ($tstart!=0) { |
|
| if ($tstart>$now) { |
|
| $trole=''; |
|
| } |
|
| } |
|
| if (($area ne '') && ($trole ne '')) { |
if (($area ne '') && ($trole ne '')) { |
| my $spec=$trole.'.'.$area; |
my $spec=$trole.'.'.$area; |
| my ($tdummy,$tdomain,$trest)=split(/\//,$area); |
my ($tdummy,$tdomain,$trest)=split(/\//,$area); |
| if ($trole =~ /^cr\//) { |
if ($trole =~ /^cr\//) { |
| my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); |
&custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area); |
| my $homsvr=homeserver($rauthor,$rdomain); |
|
| if ($hostname{$homsvr} ne '') { |
|
| my ($rdummy,$roledef)= |
|
| &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); |
|
| |
|
| if (($rdummy ne 'con_lost') && ($roledef ne '')) { |
|
| my ($syspriv,$dompriv,$coursepriv)= |
|
| split(/\_/,$roledef); |
|
| if (defined($syspriv)) { |
|
| $allroles{'cm./'}.=':'.$syspriv; |
|
| $allroles{$spec.'./'}.=':'.$syspriv; |
|
| } |
|
| if ($tdomain ne '') { |
|
| if (defined($dompriv)) { |
|
| $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv; |
|
| $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; |
|
| } |
|
| if ($trest ne '') { |
|
| if (defined($coursepriv)) { |
|
| $allroles{'cm.'.$area}.=':'.$coursepriv; |
|
| $allroles{$spec.'.'.$area}.=':'.$coursepriv; |
|
| } |
|
| } |
|
| } |
|
| } |
|
| } |
|
| } else { |
} else { |
| if (defined($pr{$trole.':s'})) { |
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); |
| $allroles{'cm./'}.=':'.$pr{$trole.':s'}; |
|
| $allroles{$spec.'./'}.=':'.$pr{$trole.':s'}; |
|
| } |
|
| if ($tdomain ne '') { |
|
| if (defined($pr{$trole.':d'})) { |
|
| $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; |
|
| $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; |
|
| } |
|
| if ($trest ne '') { |
|
| if (defined($pr{$trole.':c'})) { |
|
| $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'}; |
|
| $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'}; |
|
| } |
|
| } |
|
| } |
|
| } |
} |
| } |
} |
| } |
} |
| } |
} |
| my $adv=0; |
my ($author,$adv) = &set_userprivs(\$userroles,\%allroles); |
| my $author=0; |
|
| foreach (keys %allroles) { |
|
| %thesepriv=(); |
|
| if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; } |
|
| if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } |
|
| foreach (split(/:/,$allroles{$_})) { |
|
| if ($_ ne '') { |
|
| my ($privilege,$restrictions)=split(/&/,$_); |
|
| if ($restrictions eq '') { |
|
| $thesepriv{$privilege}='F'; |
|
| } else { |
|
| if ($thesepriv{$privilege} ne 'F') { |
|
| $thesepriv{$privilege}.=$restrictions; |
|
| } |
|
| } |
|
| } |
|
| } |
|
| $thesestr=''; |
|
| foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } |
|
| $userroles.='user.priv.'.$_.'='.$thesestr."\n"; |
|
| } |
|
| $userroles.='user.adv='.$adv."\n". |
$userroles.='user.adv='.$adv."\n". |
| 'user.author='.$author."\n"; |
'user.author='.$author."\n"; |
| $ENV{'user.adv'}=$adv; |
$ENV{'user.adv'}=$adv; |
|
Line 2413 sub rolesinit {
|
Line 2418 sub rolesinit {
|
| return $userroles; |
return $userroles; |
| } |
} |
| |
|
| |
sub set_arearole { |
| |
my ($trole,$area,$tstart,$tend,$domain,$username) = @_; |
| |
# log the associated role with the area |
| |
&userrolelog($trole,$username,$domain,$area,$tstart,$tend); |
| |
return 'user.role.'.$trole.'.'.$area.'='.$tstart.'.'.$tend."\n"; |
| |
} |
| |
|
| |
sub custom_roleprivs { |
| |
my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_; |
| |
my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); |
| |
my $homsvr=homeserver($rauthor,$rdomain); |
| |
if ($hostname{$homsvr} ne '') { |
| |
my ($rdummy,$roledef)= |
| |
&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); |
| |
if (($rdummy ne 'con_lost') && ($roledef ne '')) { |
| |
my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef); |
| |
if (defined($syspriv)) { |
| |
$$allroles{'cm./'}.=':'.$syspriv; |
| |
$$allroles{$spec.'./'}.=':'.$syspriv; |
| |
} |
| |
if ($tdomain ne '') { |
| |
if (defined($dompriv)) { |
| |
$$allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv; |
| |
$$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; |
| |
} |
| |
if (($trest ne '') && (defined($coursepriv))) { |
| |
$$allroles{'cm.'.$area}.=':'.$coursepriv; |
| |
$$allroles{$spec.'.'.$area}.=':'.$coursepriv; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
|
| |
|
| |
sub standard_roleprivs { |
| |
my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_; |
| |
if (defined($pr{$trole.':s'})) { |
| |
$$allroles{'cm./'}.=':'.$pr{$trole.':s'}; |
| |
$$allroles{$spec.'./'}.=':'.$pr{$trole.':s'}; |
| |
} |
| |
if ($tdomain ne '') { |
| |
if (defined($pr{$trole.':d'})) { |
| |
$$allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; |
| |
$$allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; |
| |
} |
| |
if (($trest ne '') && (defined($pr{$trole.':c'}))) { |
| |
$$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'}; |
| |
$$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'}; |
| |
} |
| |
} |
| |
} |
| |
|
| |
sub set_userprivs { |
| |
my ($userroles,$allroles) = @_; |
| |
my $author=0; |
| |
my $adv=0; |
| |
foreach (keys %{$allroles}) { |
| |
my %thesepriv=(); |
| |
if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } |
| |
foreach (split(/:/,$$allroles{$_})) { |
| |
if ($_ ne '') { |
| |
my ($privilege,$restrictions)=split(/&/,$_); |
| |
if ($restrictions eq '') { |
| |
$thesepriv{$privilege}='F'; |
| |
} elsif ($thesepriv{$privilege} ne 'F') { |
| |
$thesepriv{$privilege}.=$restrictions; |
| |
} |
| |
if ($thesepriv{'adv'} eq 'F') { $adv=1; } |
| |
} |
| |
} |
| |
my $thesestr=''; |
| |
foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } |
| |
$$userroles.='user.priv.'.$_.'='.$thesestr."\n"; |
| |
} |
| |
return ($author,$adv); |
| |
} |
| |
|
| # --------------------------------------------------------------- get interface |
# --------------------------------------------------------------- get interface |
| |
|
| sub get { |
sub get { |
|
Line 2434 sub get {
|
Line 2517 sub get {
|
| my %returnhash=(); |
my %returnhash=(); |
| my $i=0; |
my $i=0; |
| foreach (@$storearr) { |
foreach (@$storearr) { |
| $returnhash{$_}=unescape($pairs[$i]); |
$returnhash{$_}=&thaw_unescape($pairs[$i]); |
| $i++; |
$i++; |
| } |
} |
| return %returnhash; |
return %returnhash; |
|
Line 2473 sub dump {
|
Line 2556 sub dump {
|
| my %returnhash=(); |
my %returnhash=(); |
| foreach (@pairs) { |
foreach (@pairs) { |
| my ($key,$value)=split(/=/,$_); |
my ($key,$value)=split(/=/,$_); |
| $returnhash{unescape($key)}=unescape($value); |
$returnhash{unescape($key)}=&thaw_unescape($value); |
| } |
} |
| return %returnhash; |
return %returnhash; |
| } |
} |
|
Line 2519 sub currentdump {
|
Line 2602 sub currentdump {
|
| my ($key,$value)=split(/=/,$_); |
my ($key,$value)=split(/=/,$_); |
| my ($symb,$param) = split(/:/,$key); |
my ($symb,$param) = split(/:/,$key); |
| $returnhash{&unescape($symb)}->{&unescape($param)} = |
$returnhash{&unescape($symb)}->{&unescape($param)} = |
| &unescape($value); |
&thaw_unescape($value); |
| } |
} |
| } |
} |
| return %returnhash; |
return %returnhash; |
|
Line 2585 sub put {
|
Line 2668 sub put {
|
| my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
| my $items=''; |
my $items=''; |
| foreach (keys %$storehash) { |
foreach (keys %$storehash) { |
| $items.=&escape($_).'='.&escape($$storehash{$_}).'&'; |
$items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; |
| } |
} |
| $items=~s/\&$//; |
$items=~s/\&$//; |
| return &reply("put:$udomain:$uname:$namespace:$items",$uhome); |
return &reply("put:$udomain:$uname:$namespace:$items",$uhome); |
|
Line 2624 sub cput {
|
Line 2707 sub cput {
|
| my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
| my $items=''; |
my $items=''; |
| foreach (keys %$storehash) { |
foreach (keys %$storehash) { |
| $items.=escape($_).'='.escape($$storehash{$_}).'&'; |
$items.=escape($_).'='.&freeze_escape($$storehash{$_}).'&'; |
| } |
} |
| $items=~s/\&$//; |
$items=~s/\&$//; |
| return &critical("put:$udomain:$uname:$namespace:$items",$uhome); |
return &critical("put:$udomain:$uname:$namespace:$items",$uhome); |
|
Line 2647 sub eget {
|
Line 2730 sub eget {
|
| my %returnhash=(); |
my %returnhash=(); |
| my $i=0; |
my $i=0; |
| foreach (@$storearr) { |
foreach (@$storearr) { |
| $returnhash{$_}=unescape($pairs[$i]); |
$returnhash{$_}=&thaw_unescape($pairs[$i]); |
| $i++; |
$i++; |
| } |
} |
| return %returnhash; |
return %returnhash; |
|
Line 2694 sub allowed {
|
Line 2777 sub allowed {
|
| $uri=&deversion($uri); |
$uri=&deversion($uri); |
| my $orguri=$uri; |
my $orguri=$uri; |
| $uri=&declutter($uri); |
$uri=&declutter($uri); |
| |
|
| |
|
| |
|
| if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } |
if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } |
| # Free bre access to adm and meta resources |
# Free bre access to adm and meta resources |
| |
if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) |
| if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { |
|| ($uri=~/\.meta$/)) && ($priv eq 'bre')) { |
| return 'F'; |
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 |
# Free bre to public access |
| |
|
| if ($priv eq 'bre') { |
if ($priv eq 'bre') { |
|
Line 3103 sub log_query {
|
Line 3195 sub log_query {
|
| sub fetch_enrollment_query { |
sub fetch_enrollment_query { |
| my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_; |
my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_; |
| my $homeserver; |
my $homeserver; |
| |
my $maxtries = 1; |
| if ($context eq 'automated') { |
if ($context eq 'automated') { |
| $homeserver = $perlvar{'lonHostID'}; |
$homeserver = $perlvar{'lonHostID'}; |
| |
$maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout |
| } else { |
} else { |
| $homeserver = &homeserver($cnum,$dom); |
$homeserver = &homeserver($cnum,$dom); |
| } |
} |
|
Line 3117 sub fetch_enrollment_query {
|
Line 3211 sub fetch_enrollment_query {
|
| $cmd = &escape($cmd); |
$cmd = &escape($cmd); |
| my $query = 'fetchenrollment'; |
my $query = 'fetchenrollment'; |
| my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver); |
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); |
my $reply = &get_query_reply($queryid); |
| unless ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { |
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.' maxtries: '.$maxtries.' tries: '.$tries); |
| |
} else { |
| my @responses = split/:/,$reply; |
my @responses = split/:/,$reply; |
| if ($homeserver eq $perlvar{'lonHostID'}) { |
if ($homeserver eq $perlvar{'lonHostID'}) { |
| foreach (@responses) { |
foreach (@responses) { |
|
Line 3136 sub fetch_enrollment_query {
|
Line 3240 sub fetch_enrollment_query {
|
| my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml'; |
my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml'; |
| my $destname = $pathname.'/'.$filename; |
my $destname = $pathname.'/'.$filename; |
| my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver); |
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") ) { |
if ( open(FILE,">$destname") ) { |
| print FILE &unescape($xml_classlist); |
print FILE &unescape($xml_classlist); |
| close(FILE); |
close(FILE); |
| |
} else { |
| |
&logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum); |
| } |
} |
| } |
} |
| } |
} |
|
Line 3521 sub modify_student_enrollment {
|
Line 3629 sub modify_student_enrollment {
|
| $gene = $tmp{'generation'} if (!defined($gene) || $gene eq ''); |
$gene = $tmp{'generation'} if (!defined($gene) || $gene eq ''); |
| $uid = $tmp{'id'} if (!defined($uid) || $uid eq ''); |
$uid = $tmp{'id'} if (!defined($uid) || $uid eq ''); |
| } |
} |
| my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene, |
my $fullname = &format_name($first,$middle,$last,$gene,'lastname'); |
| $first,$middle); |
|
| my $reply=cput('classlist', |
my $reply=cput('classlist', |
| {"$uname:$udom" => |
{"$uname:$udom" => |
| join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) }, |
join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) }, |
|
Line 3539 sub modify_student_enrollment {
|
Line 3646 sub modify_student_enrollment {
|
| return &assignrole($udom,$uname,$uurl,'st',$end,$start); |
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 |
# ------------------------------------------------- Write to course preferences |
| |
|
| sub writecoursepref { |
sub writecoursepref { |
|
Line 3649 sub revokecustomrole {
|
Line 3775 sub revokecustomrole {
|
| $deleteflag); |
$deleteflag); |
| } |
} |
| |
|
| |
# ------------------------------------------------------------ Disk usage |
| # ------------------------------------------------------------ Portfolio Director Lister |
sub diskusage { |
| # returns listing of contents of user's /userfiles/portfolio/ directory |
my ($udom,$uname,$directoryRoot)=@_; |
| # |
$directoryRoot =~ s/\/$//; |
| |
my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom)); |
| 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)); |
|
| return $listing; |
return $listing; |
| } |
} |
| |
|
| sub portfoliomanage { |
sub is_locked { |
| |
my ($file_name, $domain, $user) = @_; |
| |
my @check; |
| |
my $is_locked; |
| |
push @check, $file_name; |
| |
my %locked = &Apache::lonnet::get('file_permissions',\@check, |
| |
$ENV{'user.domain'},$ENV{'user.name'}); |
| |
if (ref($locked{$file_name}) eq 'ARRAY') { |
| |
$is_locked = 'true'; |
| |
} else { |
| |
$is_locked = 'false'; |
| |
} |
| |
} |
| |
|
| #FIXME please user the existing remove userfile function instead and |
# ------------------------------------------------------------- Mark as Read Only |
| #add a userfilerename functions. |
|
| #FIXME uhome should never be an argument to any lonnet functions |
sub mark_as_readonly { |
| |
my ($domain,$user,$files,$what) = @_; |
| # handles deleting and renaming files in user's userfiles/portfolio/ directory |
my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); |
| # |
foreach my $file (@{$files}) { |
| my ($filename, $fileaction, $filenewname) = @_; |
push(@{$current_permissions{$file}},$what); |
| my ($udom, $uname, $uhome); |
} |
| $uname=$ENV{'user.name'}; |
&Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user); |
| $udom=$ENV{'user.domain'}; |
return; |
| $uhome=$ENV{'user.home'}; |
} |
| my $listing = reply('portfoliomanage:'.$uname.':'.$udom.':'.$filename.':'.$fileaction.':'.$filenewname, $uhome); |
|
| return $listing; |
#--------------------------------------------------------------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)) { |
| |
if (ref($value) eq "ARRAY"){ |
| |
foreach my $stored_what (@{$value}) { |
| |
if ($stored_what eq $what) { |
| |
push(@readonly_files, $file_name); |
| |
} elsif (!defined($what)) { |
| |
push(@readonly_files, $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 |
# ------------------------------------------------------------ Directory lister |
| |
|
|
Line 3793 sub GetFileTimestamp {
|
Line 3968 sub GetFileTimestamp {
|
| |
|
| sub directcondval { |
sub directcondval { |
| my $number=shift; |
my $number=shift; |
| |
if (!defined($ENV{'user.state.'.$ENV{'request.course.id'}})) { |
| |
&Apache::lonuserstate::evalstate(); |
| |
} |
| if ($ENV{'user.state.'.$ENV{'request.course.id'}}) { |
if ($ENV{'user.state.'.$ENV{'request.course.id'}}) { |
| return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1); |
return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1); |
| } else { |
} else { |
|
Line 4018 sub EXT {
|
Line 4196 sub EXT {
|
| |
|
| my $section; |
my $section; |
| if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { |
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; |
#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest; |
| |
|
| # ----------------------------------------------------- Cascading lookup scheme |
# ----------------------------------------------------- Cascading lookup scheme |
| if (!$symbparm) { $symbparm=&symbread(); } |
|
| my $symbp=$symbparm; |
my $symbp=$symbparm; |
| my $mapp=(&decode_symb($symbp))[0]; |
my $mapp=(&decode_symb($symbp))[0]; |
| |
|
|
Line 4033 sub EXT {
|
Line 4214 sub EXT {
|
| ($ENV{'user.domain'} eq $udom)) { |
($ENV{'user.domain'} eq $udom)) { |
| $section=$ENV{'request.course.sec'}; |
$section=$ENV{'request.course.sec'}; |
| } else { |
} else { |
| if (! defined($usection)) { |
if (! defined($usection)) { |
| $section=&usection($udom,$uname,$courseid); |
$section=&getsection($udom,$uname,$courseid); |
| } else { |
} else { |
| $section = $usection; |
$section = $usection; |
| } |
} |
| } |
} |
| |
|
| my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; |
my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; |
|
Line 4075 sub EXT {
|
Line 4256 sub EXT {
|
| $uname." at ".$udom.": ". |
$uname." at ".$udom.": ". |
| $tmp."</font>"); |
$tmp."</font>"); |
| } elsif ($tmp=~/error: 2 /) { |
} elsif ($tmp=~/error: 2 /) { |
| &EXT_cache_set($udom,$uname); |
&EXT_cache_set($udom,$uname); |
| } elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
} elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
| return $tmp; |
return $tmp; |
| } |
} |
|
Line 4085 sub EXT {
|
Line 4266 sub EXT {
|
| # -------------------------------------------------------- second, check course |
# -------------------------------------------------------- second, check course |
| |
|
| my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, |
my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, |
| $ENV{'course.'.$courseid.'.domain'}, |
$ENV{'course.'.$courseid.'.domain'}, |
| ($seclevelr,$seclevelm,$seclevel, |
($seclevelr,$seclevelm,$seclevel, |
| $courselevelr,$courselevelm, |
$courselevelr,$courselevelm, |
| $courselevel)); |
$courselevel)); |
| if (defined($coursereply)) { return $coursereply; } |
if (defined($coursereply)) { return $coursereply; } |
| |
|
| # ------------------------------------------------------ third, check map parms |
# ------------------------------------------------------ third, check map parms |
|
Line 4188 sub metadata {
|
Line 4369 sub metadata {
|
| my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
| $uri=&declutter($uri); |
$uri=&declutter($uri); |
| # if it is a non metadata possible uri return quickly |
# 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|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || |
| ($uri =~ m|home/[^/]+/public_html/|)) { |
($uri =~ m|home/[^/]+/public_html/|)) { |
| return undef; |
return undef; |
|
Line 4221 sub metadata {
|
Line 4404 sub metadata {
|
| unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
| my $metastring; |
my $metastring; |
| if ($uri !~ m|^uploaded/|) { |
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 $parser=HTML::LCParser->new(\$metastring); |
| my $token; |
my $token; |
|
Line 4434 sub metadata_generate_part0 {
|
Line 4619 sub metadata_generate_part0 {
|
| sub gettitle { |
sub gettitle { |
| my $urlsymb=shift; |
my $urlsymb=shift; |
| my $symb=&symbread($urlsymb); |
my $symb=&symbread($urlsymb); |
| unless ($symb) { |
if ($symb) { |
| unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; } |
my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600); |
| return &metadata($urlsymb,'title'); |
if (defined($cached)) { return $result; } |
| } |
my ($map,$resid,$url)=&decode_symb($symb); |
| my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600); |
my $title=''; |
| if (defined($cached)) { return $result; } |
my %bighash; |
| my ($map,$resid,$url)=&decode_symb($symb); |
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
| my $title=''; |
&GDBM_READER(),0640)) { |
| my %bighash; |
my $mapid=$bighash{'map_pc_'.&clutter($map)}; |
| if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
$title=$bighash{'title_'.$mapid.'.'.$resid}; |
| &GDBM_READER(),0640)) { |
untie %bighash; |
| my $mapid=$bighash{'map_pc_'.&clutter($map)}; |
} |
| $title=$bighash{'title_'.$mapid.'.'.$resid}; |
$title=~s/\&colon\;/\:/gs; |
| untie %bighash; |
if ($title) { |
| } |
return &do_cache(\%titlecache,$symb,$title,'title'); |
| $title=~s/\&colon\;/\:/gs; |
} |
| if ($title) { |
$urlsymb=$url; |
| return &do_cache(\%titlecache,$symb,$title,'title'); |
} |
| } else { |
my $title=&metadata($urlsymb,'title'); |
| return &metadata($urlsymb,'title'); |
if (!$title) { $title=(split('/',$urlsymb))[-1]; } |
| } |
return $title; |
| } |
} |
| |
|
| # ------------------------------------------------- Update symbolic store links |
# ------------------------------------------------- Update symbolic store links |
|
Line 4586 sub deversion {
|
Line 4771 sub deversion {
|
| |
|
| sub symbread { |
sub symbread { |
| my ($thisfn,$donotrecurse)=@_; |
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 |
# no filename provided? try from environment |
| unless ($thisfn) { |
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'}; |
$thisfn=$ENV{'request.filename'}; |
| } |
} |
| # is that filename actually a symb? Verify, clean, and return |
# is that filename actually a symb? Verify, clean, and return |
| if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { |
if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { |
| if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); } |
if (&symbverify($thisfn,$1)) { |
| |
return $ENV{$cache_str}=&symbclean($thisfn); |
| |
} |
| } |
} |
| $thisfn=declutter($thisfn); |
$thisfn=declutter($thisfn); |
| my %hash; |
my %hash; |
|
Line 4614 sub symbread {
|
Line 4805 sub symbread {
|
| unless ($syval=~/\_\d+$/) { |
unless ($syval=~/\_\d+$/) { |
| unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { |
unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { |
| &appenv('request.ambiguous' => $thisfn); |
&appenv('request.ambiguous' => $thisfn); |
| return ''; |
return $ENV{$cache_str}=''; |
| } |
} |
| $syval.=$1; |
$syval.=$1; |
| } |
} |
|
Line 4661 sub symbread {
|
Line 4852 sub symbread {
|
| } |
} |
| } |
} |
| if ($syval) { |
if ($syval) { |
| return &symbclean($syval.'___'.$thisfn); |
return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn); |
| } |
} |
| } |
} |
| &appenv('request.ambiguous' => $thisfn); |
&appenv('request.ambiguous' => $thisfn); |
| return ''; |
return $ENV{$cache_str}=''; |
| } |
} |
| |
|
| # ---------------------------------------------------------- Return random seed |
# ---------------------------------------------------------- Return random seed |
|
Line 4679 sub numval {
|
Line 4870 sub numval {
|
| $txt=~tr/U-Z/0-5/; |
$txt=~tr/U-Z/0-5/; |
| $txt=~tr/u-z/0-5/; |
$txt=~tr/u-z/0-5/; |
| $txt=~s/\D//g; |
$txt=~s/\D//g; |
| |
if ($_64bit) { if ($txt > 2**32) { return -1; } } |
| return int($txt); |
return int($txt); |
| } |
} |
| |
|
|
Line 4694 sub numval2 {
|
Line 4886 sub numval2 {
|
| my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt); |
my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt); |
| my $total; |
my $total; |
| foreach my $val (@txts) { $total+=$val; } |
foreach my $val (@txts) { $total+=$val; } |
| |
if ($_64bit) { if ($total > 2**32) { return -1; } } |
| return int($total); |
return int($total); |
| } |
} |
| |
|
|
Line 4710 sub get_rand_alg {
|
Line 4903 sub get_rand_alg {
|
| return &latest_rnd_algorithm_id(); |
return &latest_rnd_algorithm_id(); |
| } |
} |
| |
|
| |
sub validCODE { |
| |
my ($CODE)=@_; |
| |
if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; } |
| |
return 0; |
| |
} |
| |
|
| sub getCODE { |
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) && |
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 $Apache::lonhomework::history{'resource.CODE'}; |
| } |
} |
| return undef; |
return undef; |
|
Line 4755 sub rndseed_32bit {
|
Line 4954 sub rndseed_32bit {
|
| my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; |
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; |
| #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
| #&Apache::lonxml::debug("rndseed :$num:$symb"); |
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
| |
if ($_64bit) { $num=(($num<<32)>>32); } |
| return $num; |
return $num; |
| } |
} |
| } |
} |
|
Line 4775 sub rndseed_64bit {
|
Line 4975 sub rndseed_64bit {
|
| my $num2=$nameseed+$domainseed+$courseseed; |
my $num2=$nameseed+$domainseed+$courseseed; |
| #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
| #&Apache::lonxml::debug("rndseed :$num:$symb"); |
#&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"; |
return "$num1,$num2"; |
| } |
} |
| } |
} |
|
Line 4818 sub rndseed_64bit3 {
|
Line 5020 sub rndseed_64bit3 {
|
| my $num1=$symbchck+$symbseed+$namechck; |
my $num1=$symbchck+$symbseed+$namechck; |
| my $num2=$nameseed+$domainseed+$courseseed; |
my $num2=$nameseed+$domainseed+$courseseed; |
| #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&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"; |
return "$num1:$num2"; |
| } |
} |
| } |
} |
|
Line 4836 sub rndseed_CODE_64bit {
|
Line 5040 sub rndseed_CODE_64bit {
|
| my $num2=$CODEseed+$courseseed+$symbchck; |
my $num2=$CODEseed+$courseseed+$symbchck; |
| #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); |
#&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); |
| #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); |
#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); |
| |
if ($_64bit) { $num1=(($num1<<32)>>32); } |
| |
if ($_64bit) { $num2=(($num2<<32)>>32); } |
| return "$num1:$num2"; |
return "$num1:$num2"; |
| } |
} |
| } |
} |
|
Line 4926 sub receipt {
|
Line 5132 sub receipt {
|
| # the local server. |
# the local server. |
| |
|
| sub getfile { |
sub getfile { |
| my ($file,$caller) = @_; |
my ($file) = @_; |
| |
|
| if ($file !~ m|^/*uploaded/(\w+)/(\w+)/(.+)$|) { |
if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); } |
| # normal file from res space |
&repcopy($file); |
| &repcopy($file); |
return &readfile($file); |
| return &readfile($file); |
} |
| } |
|
| |
sub repcopy_userfile { |
| my $info; |
my ($file)=@_; |
| my $cdom = $1; |
|
| my $cnum = $2; |
if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); } |
| my $filename = $3; |
if ($file =~ m|^/home/httpd/html/lonUsers/|) { return OK; } |
| my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles'; |
|
| my ($lwpresp,$rtncode); |
my ($cdom,$cnum,$filename) = |
| my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename; |
($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|); |
| if (-e "$localfile") { |
my ($info,$rtncode); |
| my @fileinfo = stat($localfile); |
my $uri="/uploaded/$cdom/$cnum/$filename"; |
| $lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode); |
if (-e "$file") { |
| |
my @fileinfo = stat($file); |
| |
my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode); |
| if ($lwpresp ne 'ok') { |
if ($lwpresp ne 'ok') { |
| if ($rtncode eq '404') { |
if ($rtncode eq '404') { |
| unlink($localfile); |
unlink($file); |
| } |
} |
| #my $ua=new LWP::UserAgent; |
#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); |
#my $response=$ua->request($request); |
| #if ($response->is_success()) { |
#if ($response->is_success()) { |
| # return $response->content; |
# return $response->content; |
|
Line 4959 sub getfile {
|
Line 5167 sub getfile {
|
| return -1; |
return -1; |
| } |
} |
| if ($info < $fileinfo[9]) { |
if ($info < $fileinfo[9]) { |
| return &readfile($localfile); |
return OK; |
| } |
} |
| $info = ''; |
$info = ''; |
| $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); |
$lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); |
| if ($lwpresp ne 'ok') { |
if ($lwpresp ne 'ok') { |
| return -1; |
return -1; |
| } |
} |
| } else { |
} else { |
| $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); |
my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); |
| if ($lwpresp ne 'ok') { |
if ($lwpresp ne 'ok') { |
| my $ua=new LWP::UserAgent; |
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); |
my $response=$ua->request($request); |
| if ($response->is_success()) { |
if ($response->is_success()) { |
| return $response->content; |
$info=$response->content; |
| } else { |
} else { |
| return -1; |
return -1; |
| } |
} |
|
Line 4982 sub getfile {
|
Line 5190 sub getfile {
|
| if ($filename =~ m|^(.+)/[^/]+$|) { |
if ($filename =~ m|^(.+)/[^/]+$|) { |
| push @parts, split(/\//,$1); |
push @parts, split(/\//,$1); |
| } |
} |
| |
my $path = $perlvar{'lonDocRoot'}.'/userfiles'; |
| foreach my $part (@parts) { |
foreach my $part (@parts) { |
| $path .= '/'.$part; |
$path .= '/'.$part; |
| if (!-e $path) { |
if (!-e $path) { |
|
Line 4989 sub getfile {
|
Line 5198 sub getfile {
|
| } |
} |
| } |
} |
| } |
} |
| open (FILE,">$localfile"); |
open(FILE,">$file"); |
| print FILE $info; |
print FILE $info; |
| close(FILE); |
close(FILE); |
| if ($caller eq 'uploadrep') { |
return OK; |
| return 'ok'; |
|
| } |
|
| return $info; |
|
| } |
} |
| |
|
| sub tokenwrapper { |
sub tokenwrapper { |
| my $uri=shift; |
my $uri=shift; |
| $uri=~s/^http\:\/\/([^\/]+)//; |
$uri=~s|^http\://([^/]+)||; |
| $uri=~s/^\///; |
$uri=~s|^/||; |
| $ENV{'user.environment'}=~/\/([^\/]+)\.id/; |
$ENV{'user.environment'}=~/\/([^\/]+)\.id/; |
| my $token=$1; |
my $token=$1; |
| if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) { |
my (undef,$udom,$uname,$file)=split('/',$uri,4); |
| &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'}); |
if ($udom && $uname && $file) { |
| return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri. |
$file=~s|(\?\.*)*$||; |
| |
&appenv("userfile.$udom/$uname/$file" => $ENV{'request.course.id'}); |
| |
return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri. |
| (($uri=~/\?/)?'&':'?').'token='.$token. |
(($uri=~/\?/)?'&':'?').'token='.$token. |
| '&tokenissued='.$perlvar{'lonHostID'}; |
'&tokenissued='.$perlvar{'lonHostID'}; |
| } else { |
} else { |
|
Line 5051 sub filelocation {
|
Line 5259 sub filelocation {
|
| $location = $file; |
$location = $file; |
| $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; |
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; |
| } elsif ($file=~/^\/*uploaded/) { # is an uploaded file |
} elsif ($file=~/^\/*uploaded/) { # is an uploaded file |
| $location=$file; |
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=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. |
| |
$udom.'/'.$uname.'/'.$filename; |
| |
} |
| } else { |
} else { |
| $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
| $file=~s:^/res/:/:; |
$file=~s:^/res/:/:; |
|
Line 5127 sub clutter {
|
Line 5347 sub clutter {
|
| return $thisfn; |
return $thisfn; |
| } |
} |
| |
|
| |
sub freeze_escape { |
| |
my ($value)=@_; |
| |
if (ref($value)) { |
| |
$value=&nfreeze($value); |
| |
return '__FROZEN__'.&escape($value); |
| |
} |
| |
return &escape($value); |
| |
} |
| |
|
| # -------------------------------------------------------- Escape Special Chars |
# -------------------------------------------------------- Escape Special Chars |
| |
|
| sub escape { |
sub escape { |
|
Line 5143 sub unescape {
|
Line 5372 sub unescape {
|
| return $str; |
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 { |
sub mod_perl_version { |
| if (defined($perlvar{'MODPERL2'})) { |
if (defined($perlvar{'MODPERL2'})) { |
| return 2; |
return 2; |
|
Line 5168 sub goodbye {
|
Line 5407 sub goodbye {
|
| &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache))); |
&logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache))); |
| #1.1 only |
#1.1 only |
| &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache))); |
&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",'%courseresversioncache',scalar(%courseresversioncache))); |
| &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache))); |
&logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache))); |
| &flushcourselogs(); |
&flushcourselogs(); |
|
Line 5247 BEGIN {
|
Line 5486 BEGIN {
|
| $hostip{$id}=$ip; |
$hostip{$id}=$ip; |
| $iphost{$ip}=$id; |
$iphost{$ip}=$id; |
| if ($role eq 'library') { $libserv{$id}=$name; } |
if ($role eq 'library') { $libserv{$id}=$name; } |
| } else { |
|
| if ($configline) { |
|
| &logthis("Skipping hosts.tab line -$configline-"); |
|
| } |
|
| } |
} |
| } |
} |
| close($config); |
close($config); |
|
Line 5327 $dumpcount=0;
|
Line 5562 $dumpcount=0;
|
| &logtouch(); |
&logtouch(); |
| &logthis('<font color=yellow>INFO: Read configuration</font>'); |
&logthis('<font color=yellow>INFO: Read configuration</font>'); |
| $readit=1; |
$readit=1; |
| |
{ |
| |
use integer; |
| |
my $test=(2**32)+1; |
| |
if ($test != 0) { $_64bit=1; } |
| |
&logthis(" Detected 64bit platform ($_64bit)"); |
| |
} |
| } |
} |
| } |
} |
| |
|
|
Line 5554 X<rolesinit()>
|
Line 5795 X<rolesinit()>
|
| B<rolesinit($udom,$username,$authhost)>: get user privileges |
B<rolesinit($udom,$username,$authhost)>: get user privileges |
| |
|
| =item * |
=item * |
| X<usection()> |
X<getsection()> |
| B<usection($udom,$uname,$cname)>: finds the section of student in the |
B<getsection($udom,$uname,$cname)>: finds the section of student in the |
| course $cname, return section name/number or '' for "not in course" |
course $cname, return section name/number or '' for "not in course" |
| and '-1' for "no section" |
and '-1' for "no section" |
| |
|
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl