|
version 1.471, 2004/02/04 22:39:06
|
version 1.523.2.12, 2004/11/06 21:27:40
|
|
Line 32 package Apache::lonnet;
|
Line 32 package Apache::lonnet;
|
| use strict; |
use strict; |
| use LWP::UserAgent(); |
use LWP::UserAgent(); |
| use HTTP::Headers; |
use HTTP::Headers; |
| |
use HTTP::Date; |
| |
# use Date::Parse; |
| use vars |
use vars |
| qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom |
qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom |
| %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 %courseresdatacache |
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache |
| %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def |
%userresdatacache %usectioncache %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; |
|
Line 48 use Fcntl qw(:flock);
|
Line 50 use Fcntl qw(:flock);
|
| use Apache::loncoursedata; |
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); |
| use Time::HiRes(); |
use Time::HiRes qw( gettimeofday tv_interval ); |
| my $readit; |
my $readit; |
| |
|
| =pod |
=pod |
|
Line 377 sub delenv {
|
Line 379 sub delenv {
|
| return 'error: '.$!; |
return 'error: '.$!; |
| } |
} |
| foreach (@oldenv) { |
foreach (@oldenv) { |
| unless ($_=~/^$delthis/) { print $fh $_; } |
if ($_=~/^$delthis/) { |
| |
my ($key,undef) = split('=',$_); |
| |
delete($ENV{$key}); |
| |
} else { |
| |
print $fh $_; |
| |
} |
| } |
} |
| close($fh); |
close($fh); |
| } |
} |
|
Line 427 sub overloaderror {
|
Line 434 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 413; |
return 409; |
| } |
} |
| return ''; |
return ''; |
| } |
} |
|
Line 610 sub idput {
|
Line 617 sub idput {
|
| my ($udom,%ids)=@_; |
my ($udom,%ids)=@_; |
| my %servers=(); |
my %servers=(); |
| foreach (keys %ids) { |
foreach (keys %ids) { |
| |
&cput('environment',{'id'=>$ids{$_}},$udom,$_); |
| my $uhom=&homeserver($_,$udom); |
my $uhom=&homeserver($_,$udom); |
| if ($uhom ne 'no_host') { |
if ($uhom ne 'no_host') { |
| my $id=&escape($ids{$_}); |
my $id=&escape($ids{$_}); |
|
Line 620 sub idput {
|
Line 628 sub idput {
|
| } else { |
} else { |
| $servers{$uhom}=$id.'='.$unam; |
$servers{$uhom}=$id.'='.$unam; |
| } |
} |
| &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom); |
|
| } |
} |
| } |
} |
| foreach (keys %servers) { |
foreach (keys %servers) { |
|
Line 635 sub assign_access_key {
|
Line 642 sub assign_access_key {
|
| # a valid key looks like uname:udom#comments |
# a valid key looks like uname:udom#comments |
| # comments are being appended |
# comments are being appended |
| # |
# |
| my ($ckey,$cdom,$cnum,$udom,$uname,$logentry)=@_; |
my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_; |
| |
$kdom= |
| |
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($kdom)); |
| |
$knum= |
| |
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($knum)); |
| $cdom= |
$cdom= |
| $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); |
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); |
| $cnum= |
$cnum= |
| $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); |
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); |
| $udom=$ENV{'user.name'} unless (defined($udom)); |
$udom=$ENV{'user.name'} unless (defined($udom)); |
| $uname=$ENV{'user.domain'} unless (defined($uname)); |
$uname=$ENV{'user.domain'} unless (defined($uname)); |
| my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); |
my %existing=&get('accesskeys',[$ckey],$kdom,$knum); |
| if (($existing{$ckey}=~/^\#(.*)$/) || # - new key |
if (($existing{$ckey}=~/^\#(.*)$/) || # - new key |
| ($existing{$ckey}=~/^$uname\:$udom\#(.*)$/)) { |
($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) { |
| # assigned to this person |
# assigned to this person |
| # - this should not happen, |
# - this should not happen, |
| # unless something went wrong |
# unless something went wrong |
| # the first time around |
# the first time around |
| # ready to assign |
# ready to assign |
| $logentry=$1.'; '.$logentry; |
$logentry=$1.'; '.$logentry; |
| if (&put('accesskey',{$ckey=>$uname.':'.$udom.'#'.$logentry}, |
if (&put('accesskeys',{$ckey=>$uname.':'.$udom.'#'.$logentry}, |
| $cdom,$cnum) eq 'ok') { |
$kdom,$knum) eq 'ok') { |
| # key now belongs to user |
# key now belongs to user |
| my $envkey='key.'.$cdom.'_'.$cnum; |
my $envkey='key.'.$cdom.'_'.$cnum; |
| if (&put('environment',{$envkey => $ckey}) eq 'ok') { |
if (&put('environment',{$envkey => $ckey}) eq 'ok') { |
|
Line 748 sub validate_access_key {
|
Line 759 sub validate_access_key {
|
| $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); |
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); |
| $cnum= |
$cnum= |
| $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); |
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); |
| $udom=$ENV{'user.name'} unless (defined($udom)); |
$udom=$ENV{'user.domain'} unless (defined($udom)); |
| $uname=$ENV{'user.domain'} unless (defined($uname)); |
$uname=$ENV{'user.name'} unless (defined($uname)); |
| my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); |
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); |
| return ($existing{$ckey}=~/^$uname\:$udom\#/); |
return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/); |
| } |
} |
| |
|
| # ------------------------------------- Find the section of student in a course |
# ------------------------------------- Find the section of student in a course |
|
Line 779 sub getsection {
|
Line 790 sub getsection {
|
| &homeserver($unam,$udom)))) { |
&homeserver($unam,$udom)))) { |
| my ($key,$value)=split(/\=/,$_); |
my ($key,$value)=split(/\=/,$_); |
| $key=&unescape($key); |
$key=&unescape($key); |
| next if ($key !~/^$courseid(?:\/)*(\w+)*\_st$/); |
next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); |
| my $section=$1; |
my $section=$1; |
| 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; |
| } |
} |
|
Line 815 my $disk_caching_disabled=1;
|
Line 826 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 845 sub is_cached {
|
Line 858 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 870 sub do_cache {
|
Line 899 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 924 sub load_cache_item {
|
Line 978 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 958 sub usection {
|
Line 1020 sub usection {
|
| &homeserver($unam,$udom)))) { |
&homeserver($unam,$udom)))) { |
| my ($key,$value)=split(/\=/,$_); |
my ($key,$value)=split(/\=/,$_); |
| $key=&unescape($key); |
$key=&unescape($key); |
| if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) { |
if ($key=~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/) { |
| my $section=$1; |
my $section=$1; |
| 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)); |
|
Line 1036 sub currentversion {
|
Line 1098 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 1056 sub repcopy {
|
Line 1119 sub repcopy {
|
| my $filename=shift; |
my $filename=shift; |
| $filename=~s/\/+/\//g; |
$filename=~s/\/+/\//g; |
| if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; } |
if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; } |
| |
$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 1158 sub externalssi {
|
Line 1222 sub externalssi {
|
| return $response->content; |
return $response->content; |
| } |
} |
| |
|
| # ------- Add a token to a remote URI's query string to vouch for access rights |
# -------------------------------- Allow a /uploaded/ URI to be vouched for |
| |
|
| sub tokenwrapper { |
sub allowuploaded { |
| my $uri=shift; |
my ($srcurl,$url)=@_; |
| $uri=~s/^http\:\/\/([^\/]+)//; |
$url=&clutter(&declutter($url)); |
| $uri=~s/^\///; |
my $dir=$url; |
| $ENV{'user.environment'}=~/\/([^\/]+)\.id/; |
$dir=~s/\/[^\/]+$//; |
| my $token=$1; |
my %httpref=(); |
| if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) { |
my $httpurl=&hreflocation('',$url); |
| &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'}); |
$httpref{'httpref.'.$httpurl}=$srcurl; |
| return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri. |
&Apache::lonnet::appenv(%httpref); |
| (($uri=~/\?/)?'&':'?').'token='.$token. |
} |
| '&tokenissued='.$perlvar{'lonHostID'}; |
|
| |
# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course |
| |
# input: action, courseID, current domain, home server for course, intended |
| |
# path to file, source of file. |
| |
# output: url to file (if action was uploaddoc), |
| |
# ok if successful, or diagnostic message otherwise (if action was propagate or copy) |
| |
# |
| |
# Allows directory structure to be used within lonUsers/../userfiles/ for a |
| |
# course. |
| |
# |
| |
# action = propagate - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file |
| |
# will be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles in |
| |
# course's home server. |
| |
# |
| |
# action = copy - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will |
| |
# be copied from $source (current location) to |
| |
# /home/httpd/html/userfiles/$domain/1/2/3/$course/$file |
| |
# and will then be copied to |
| |
# /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in |
| |
# course's home server. |
| |
# |
| |
# action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file |
| |
# will be retrived from $ENV{form.uploaddoc} (from DOCS interface) to |
| |
# /home/httpd/html/userfiles/$domain/1/2/3/$course/$file |
| |
# and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file |
| |
# in course's home server. |
| |
|
| |
|
| |
sub process_coursefile { |
| |
my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_; |
| |
my $fetchresult; |
| |
if ($action eq 'propagate') { |
| |
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file |
| |
,$docuhome); |
| } else { |
} else { |
| return '/adm/notfound.html'; |
my $fetchresult = ''; |
| |
my $fpath = ''; |
| |
my $fname = $file; |
| |
($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); |
| |
$fpath=$docudom.'/'.$docuname.'/'.$fpath; |
| |
my $filepath=$perlvar{'lonDocRoot'}.'/userfiles'; |
| |
unless ($fpath eq '') { |
| |
my @parts=split('/',$fpath); |
| |
foreach my $part (@parts) { |
| |
$filepath.= '/'.$part; |
| |
if ((-e $filepath)!=1) { |
| |
mkdir($filepath,0777); |
| |
} |
| |
} |
| |
} |
| |
if ($action eq 'copy') { |
| |
if ($source eq '') { |
| |
$fetchresult = 'no source file'; |
| |
return $fetchresult; |
| |
} else { |
| |
my $destination = $filepath.'/'.$fname; |
| |
rename($source,$destination); |
| |
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, |
| |
$docuhome); |
| |
} |
| |
} elsif ($action eq 'uploaddoc') { |
| |
open(my $fh,'>'.$filepath.'/'.$fname); |
| |
print $fh $ENV{'form.'.$source}; |
| |
close($fh); |
| |
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, |
| |
$docuhome); |
| |
if ($fetchresult eq 'ok') { |
| |
return '/uploaded/'.$fpath.'/'.$fname; |
| |
} else { |
| |
&logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. |
| |
' to host '.$docuhome.': '.$fetchresult); |
| |
return '/adm/notfound.html'; |
| |
} |
| |
} |
| |
} |
| |
unless ( $fetchresult eq 'ok') { |
| |
&logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. |
| |
' to host '.$docuhome.': '.$fetchresult); |
| } |
} |
| |
return $fetchresult; |
| } |
} |
| |
|
| # --------------- Take an uploaded file and put it into the userfiles directory |
# --------------- Take an uploaded file and put it into the userfiles directory |
| # 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 userfileupload { |
| my ($formname,$coursedoc)=@_; |
my ($formname,$coursedoc,$subdir)=@_; |
| |
if (!defined($subdir)) { $subdir='unknown'; } |
| my $fname=$ENV{'form.'.$formname.'.filename'}; |
my $fname=$ENV{'form.'.$formname.'.filename'}; |
| # Replace Windows backslashes by forward slashes |
# Replace Windows backslashes by forward slashes |
| $fname=~s/\\/\//g; |
$fname=~s/\\/\//g; |
|
Line 1194 sub userfileupload {
|
Line 1335 sub userfileupload {
|
| # 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}); |
| |
if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently |
| |
my $now = time; |
| |
my $filepath = 'tmp/helprequests/'.$now; |
| |
my @parts=split(/\//,$filepath); |
| |
my $fullpath = $perlvar{'lonDaemons'}; |
| |
for (my $i=0;$i<@parts;$i++) { |
| |
$fullpath .= '/'.$parts[$i]; |
| |
if ((-e $fullpath)!=1) { |
| |
mkdir($fullpath,0777); |
| |
} |
| |
} |
| |
open(my $fh,'>'.$fullpath.'/'.$fname); |
| |
print $fh $ENV{'form.'.$formname}; |
| |
close($fh); |
| |
return $fullpath.'/'.$fname; |
| |
} |
| # Create the directory if not present |
# Create the directory if not present |
| my $docuname=''; |
my $docuname=''; |
| my $docudom=''; |
my $docudom=''; |
| my $docuhome=''; |
my $docuhome=''; |
| |
$fname="$subdir/$fname"; |
| if ($coursedoc) { |
if ($coursedoc) { |
| $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; |
$docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; |
| $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; |
$docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; |
| $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; |
$docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; |
| |
if ($ENV{'form.folder'} =~ m/^default/) { |
| |
return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); |
| |
} else { |
| |
$fname=$ENV{'form.folder'}.'/'.$fname; |
| |
return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname); |
| |
} |
| } else { |
} else { |
| $docuname=$ENV{'user.name'}; |
$docuname=$ENV{'user.name'}; |
| $docudom=$ENV{'user.domain'}; |
$docudom=$ENV{'user.domain'}; |
| $docuhome=$ENV{'user.home'}; |
$docuhome=$ENV{'user.home'}; |
| |
return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); |
| } |
} |
| return |
|
| &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); |
|
| } |
} |
| |
|
| sub finishuserfileupload { |
sub finishuserfileupload { |
| my ($docuname,$docudom,$docuhome,$formname,$fname)=@_; |
my ($docuname,$docudom,$docuhome,$formname,$fname)=@_; |
| my $path=$docudom.'/'.$docuname.'/'; |
my $path=$docudom.'/'.$docuname.'/'; |
| my $filepath=$perlvar{'lonDocRoot'}; |
my $filepath=$perlvar{'lonDocRoot'}; |
| |
my ($fnamepath,$file); |
| |
$file=$fname; |
| |
if ($fname=~m|/|) { |
| |
($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|); |
| |
$path.=$fnamepath.'/'; |
| |
} |
| my @parts=split(/\//,$filepath.'/userfiles/'.$path); |
my @parts=split(/\//,$filepath.'/userfiles/'.$path); |
| my $count; |
my $count; |
| for ($count=4;$count<=$#parts;$count++) { |
for ($count=4;$count<=$#parts;$count++) { |
|
Line 1225 sub finishuserfileupload {
|
Line 1394 sub finishuserfileupload {
|
| } |
} |
| # Save the file |
# Save the file |
| { |
{ |
| open(my $fh,'>'.$filepath.'/'.$fname); |
#&Apache::lonnet::logthis("Saving to $filepath $file"); |
| |
open(my $fh,'>'.$filepath.'/'.$file); |
| print $fh $ENV{'form.'.$formname}; |
print $fh $ENV{'form.'.$formname}; |
| close($fh); |
close($fh); |
| } |
} |
| # Notify homeserver to grep it |
# Notify homeserver to grep it |
| # |
# |
| |
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); |
| my $fetchresult= |
|
| &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome); |
|
| if ($fetchresult eq 'ok') { |
if ($fetchresult eq 'ok') { |
| # |
# |
| # Return the URL to it |
# Return the URL to it |
| return '/uploaded/'.$path.$fname; |
return '/uploaded/'.$path.$file; |
| } else { |
} else { |
| &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$fname. |
&logthis('Failed to transfer '.$path.$file.' to host '.$docuhome. |
| ' to host '.$docuhome.': '.$fetchresult); |
': '.$fetchresult); |
| return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
| } |
} |
| } |
} |
| |
|
| |
sub removeuploadedurl { |
| |
my ($url)=@_; |
| |
my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); |
| |
return &Apache::lonnet::removeuserfile($uname,$udom,$fname); |
| |
} |
| |
|
| |
sub removeuserfile { |
| |
my ($docuname,$docudom,$fname)=@_; |
| |
my $home=&homeserver($docuname,$docudom); |
| |
return &reply("removeuserfile:$docudom/$docuname/$fname",$home); |
| |
} |
| |
|
| # ------------------------------------------------------------------------- Log |
# ------------------------------------------------------------------------- Log |
| |
|
| sub log { |
sub log { |
|
Line 1284 sub flushcourselogs {
|
Line 1464 sub flushcourselogs {
|
| } |
} |
| if ($courseidbuffer{$coursehombuf{$crsid}}) { |
if ($courseidbuffer{$coursehombuf{$crsid}}) { |
| $courseidbuffer{$coursehombuf{$crsid}}.='&'. |
$courseidbuffer{$coursehombuf{$crsid}}.='&'. |
| &escape($crsid).'='.&escape($coursedescrbuf{$crsid}); |
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}). |
| |
'='.&escape($courseinstcodebuf{$crsid}); |
| } else { |
} else { |
| $courseidbuffer{$coursehombuf{$crsid}}= |
$courseidbuffer{$coursehombuf{$crsid}}= |
| &escape($crsid).'='.&escape($coursedescrbuf{$crsid}); |
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}). |
| |
'='.&escape($courseinstcodebuf{$crsid}); |
| } |
} |
| } |
} |
| # |
# |
|
Line 1361 sub courselog {
|
Line 1543 sub courselog {
|
| $ENV{'course.'.$ENV{'request.course.id'}.'.home'}; |
$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; |
| $coursedescrbuf{$ENV{'request.course.id'}}= |
$coursedescrbuf{$ENV{'request.course.id'}}= |
| $ENV{'course.'.$ENV{'request.course.id'}.'.description'}; |
$ENV{'course.'.$ENV{'request.course.id'}.'.description'}; |
| |
$courseinstcodebuf{$ENV{'request.course.id'}}= |
| |
$ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'}; |
| if (defined $courselogs{$ENV{'request.course.id'}}) { |
if (defined $courselogs{$ENV{'request.course.id'}}) { |
| $courselogs{$ENV{'request.course.id'}}.='&'.$what; |
$courselogs{$ENV{'request.course.id'}}.='&'.$what; |
| } else { |
} else { |
|
Line 1485 sub getannounce {
|
Line 1669 sub getannounce {
|
| if ($announcement=~/\w/) { |
if ($announcement=~/\w/) { |
| return |
return |
| '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'. |
'<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'. |
| '<tr><td bgcolor="#FFFFFF"><pre>'.$announcement.'</pre></td></tr></table>'; |
'<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>'; |
| } else { |
} else { |
| return ''; |
return ''; |
| } |
} |
|
Line 1504 sub courseidput {
|
Line 1688 sub courseidput {
|
| } |
} |
| |
|
| sub courseiddump { |
sub courseiddump { |
| my ($domfilter,$descfilter,$sincefilter)=@_; |
my ($domfilter,$descfilter,$sincefilter,$hostidflag,$hostidref)=@_; |
| my %returnhash=(); |
my %returnhash=(); |
| unless ($domfilter) { $domfilter=''; } |
unless ($domfilter) { $domfilter=''; } |
| foreach my $tryserver (keys %libserv) { |
foreach my $tryserver (keys %libserv) { |
| if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { |
if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) { |
| foreach ( |
if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { |
| split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. |
foreach ( |
| |
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. |
| $sincefilter.':'.&escape($descfilter), |
$sincefilter.':'.&escape($descfilter), |
| $tryserver))) { |
$tryserver))) { |
| my ($key,$value)=split(/\=/,$_); |
my ($key,$value)=split(/\=/,$_); |
| if (($key) && ($value)) { |
if (($key) && ($value)) { |
| $returnhash{&unescape($key)}=&unescape($value); |
$returnhash{&unescape($key)}=$value; |
| |
} |
| } |
} |
| } |
} |
| |
|
| } |
} |
| } |
} |
| return %returnhash; |
return %returnhash; |
|
Line 1527 sub courseiddump {
|
Line 1712 sub courseiddump {
|
| # |
# |
| # ----------------------------------------------------------- Check out an item |
# ----------------------------------------------------------- Check out an item |
| |
|
| |
sub get_first_access { |
| |
my ($type,$argsymb)=@_; |
| |
my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); |
| |
if ($argsymb) { $symb=$argsymb; } |
| |
my ($map,$id,$res)=&decode_symb($symb); |
| |
if ($type eq 'map') { $res=$map; } |
| |
my %times=&get('firstaccesstimes',[$res],$udom,$uname); |
| |
return $times{$res}; |
| |
} |
| |
|
| |
sub set_first_access { |
| |
my ($type)=@_; |
| |
my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); |
| |
my ($map,$id,$res)=&decode_symb($symb); |
| |
if ($type eq 'map') { $res=$map; } |
| |
my $firstaccess=&get_first_access($type); |
| |
if (!$firstaccess) { |
| |
return &put('firstaccesstimes',{$res=>time},$udom,$uname); |
| |
} |
| |
return 'already_set'; |
| |
} |
| |
|
| sub checkout { |
sub checkout { |
| my ($symb,$tuname,$tudom,$tcrsid)=@_; |
my ($symb,$tuname,$tudom,$tcrsid)=@_; |
| my $now=time; |
my $now=time; |
|
Line 1705 sub hash2str {
|
Line 1912 sub hash2str {
|
| sub hashref2str { |
sub hashref2str { |
| my ($hashref)=@_; |
my ($hashref)=@_; |
| my $result='__HASH_REF__'; |
my $result='__HASH_REF__'; |
| foreach (keys(%$hashref)) { |
foreach (sort(keys(%$hashref))) { |
| if (ref($_) eq 'ARRAY') { |
if (ref($_) eq 'ARRAY') { |
| $result.=&arrayref2str($_).'='; |
$result.=&arrayref2str($_).'='; |
| } elsif (ref($_) eq 'HASH') { |
} elsif (ref($_) eq 'HASH') { |
|
Line 2566 sub allowed {
|
Line 2773 sub allowed {
|
| |
|
| # Course |
# Course |
| |
|
| if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) { |
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) { |
| $thisallowed.=$1; |
$thisallowed.=$1; |
| } |
} |
| |
|
| # Domain |
# Domain |
| |
|
| if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} |
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} |
| =~/$priv\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
| $thisallowed.=$1; |
$thisallowed.=$1; |
| } |
} |
| |
|
|
Line 2583 sub allowed {
|
Line 2790 sub allowed {
|
| $courseuri=~s/^([^\/])/\/$1/; |
$courseuri=~s/^([^\/])/\/$1/; |
| |
|
| if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri} |
if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri} |
| =~/$priv\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
| $thisallowed.=$1; |
$thisallowed.=$1; |
| } |
} |
| |
|
| # URI is an uploaded document for this course |
# URI is an uploaded document for this course |
| |
|
| if (($priv eq 'bre') && |
if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { |
| ($uri=~/^uploaded\/$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}\/$ENV{'course.'.$ENV{'request.course.id'}.'.num'}/)) { |
my $refuri=$ENV{'httpref.'.$orguri}; |
| return 'F'; |
if ($refuri) { |
| |
if ($refuri =~ m|^/adm/|) { |
| |
$thisallowed='F'; |
| |
} |
| |
} |
| } |
} |
| |
|
| # Full access at system, domain or course-wide level? Exit. |
# Full access at system, domain or course-wide level? Exit. |
| |
|
| if ($thisallowed=~/F/) { |
if ($thisallowed=~/F/) { |
|
Line 2601 sub allowed {
|
Line 2813 sub allowed {
|
| |
|
| # If this is generating or modifying users, exit with special codes |
# If this is generating or modifying users, exit with special codes |
| |
|
| if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) { |
if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:\Q$priv\E\:/) { |
| return $thisallowed; |
return $thisallowed; |
| } |
} |
| # |
# |
|
Line 2622 sub allowed {
|
Line 2834 sub allowed {
|
| if ($match) { |
if ($match) { |
| $statecond=$cond; |
$statecond=$cond; |
| if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} |
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} |
| =~/$priv\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
| $thisallowed.=$1; |
$thisallowed.=$1; |
| $checkreferer=0; |
$checkreferer=0; |
| } |
} |
|
Line 2650 sub allowed {
|
Line 2862 sub allowed {
|
| if ($match) { |
if ($match) { |
| my $refstatecond=$cond; |
my $refstatecond=$cond; |
| if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} |
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} |
| =~/$priv\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
| $thisallowed.=$1; |
$thisallowed.=$1; |
| $uri=$refuri; |
$uri=$refuri; |
| $statecond=$refstatecond; |
$statecond=$refstatecond; |
|
Line 2703 sub allowed {
|
Line 2915 sub allowed {
|
| if ((time-$ENV{$prefix.'last_cache'})>$expiretime) { |
if ((time-$ENV{$prefix.'last_cache'})>$expiretime) { |
| &coursedescription($courseid); |
&coursedescription($courseid); |
| } |
} |
| if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/) |
if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/) |
| || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) { |
|| ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) { |
| if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) { |
if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) { |
| &log($ENV{'user.domain'},$ENV{'user.name'}, |
&log($ENV{'user.domain'},$ENV{'user.name'}, |
|
Line 2714 sub allowed {
|
Line 2926 sub allowed {
|
| return ''; |
return ''; |
| } |
} |
| } |
} |
| if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/) |
if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/) |
| || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { |
|| ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { |
| if ($ENV{'priv.'.$priv.'.lock.expire'}>time) { |
if ($ENV{'priv.'.$priv.'.lock.expire'}>time) { |
| &log($ENV{'user.domain'},$ENV{'user.name'}, |
&log($ENV{'user.domain'},$ENV{'user.name'}, |
|
Line 2748 sub allowed {
|
Line 2960 sub allowed {
|
| my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; |
my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; |
| my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'}; |
my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'}; |
| if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'} |
if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'} |
| =~/$rolecode/) { |
=~/\Q$rolecode\E/) { |
| &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, |
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, |
| 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. |
| $ENV{'request.course.id'}); |
$ENV{'request.course.id'}); |
|
Line 2756 sub allowed {
|
Line 2968 sub allowed {
|
| } |
} |
| |
|
| if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'} |
if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'} |
| =~/$unamedom/) { |
=~/\Q$unamedom\E/) { |
| &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, |
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, |
| 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. |
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. |
| $ENV{'request.course.id'}); |
$ENV{'request.course.id'}); |
|
Line 2768 sub allowed {
|
Line 2980 sub allowed {
|
| |
|
| if ($thisallowed=~/R/) { |
if ($thisallowed=~/R/) { |
| my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; |
my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; |
| if (&metadata($uri,'roledeny')=~/$rolecode/) { |
if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { |
| &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, |
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, |
| 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); |
| return ''; |
return ''; |
|
Line 2780 sub allowed {
|
Line 2992 sub allowed {
|
| if ($thisallowed=~/X/) { |
if ($thisallowed=~/X/) { |
| if ($ENV{'acc.randomout'}) { |
if ($ENV{'acc.randomout'}) { |
| my $symb=&symbread($uri,1); |
my $symb=&symbread($uri,1); |
| if (($symb) && ($ENV{'acc.randomout'}=~/\&$symb\&/)) { |
if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) { |
| return ''; |
return ''; |
| } |
} |
| } |
} |
|
Line 2844 sub definerole {
|
Line 3056 sub definerole {
|
| my ($rolename,$sysrole,$domrole,$courole)=@_; |
my ($rolename,$sysrole,$domrole,$courole)=@_; |
| foreach (split(':',$sysrole)) { |
foreach (split(':',$sysrole)) { |
| my ($crole,$cqual)=split(/\&/,$_); |
my ($crole,$cqual)=split(/\&/,$_); |
| if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; } |
if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; } |
| if ($pr{'cr:s'}=~/$crole\&/) { |
if ($pr{'cr:s'}=~/\Q$crole\E\&/) { |
| if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) { |
if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { |
| return "refused:s:$crole&$cqual"; |
return "refused:s:$crole&$cqual"; |
| } |
} |
| } |
} |
| } |
} |
| foreach (split(':',$domrole)) { |
foreach (split(':',$domrole)) { |
| my ($crole,$cqual)=split(/\&/,$_); |
my ($crole,$cqual)=split(/\&/,$_); |
| if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; } |
if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; } |
| if ($pr{'cr:d'}=~/$crole\&/) { |
if ($pr{'cr:d'}=~/\Q$crole\E\&/) { |
| if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) { |
if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) { |
| return "refused:d:$crole&$cqual"; |
return "refused:d:$crole&$cqual"; |
| } |
} |
| } |
} |
| } |
} |
| foreach (split(':',$courole)) { |
foreach (split(':',$courole)) { |
| my ($crole,$cqual)=split(/\&/,$_); |
my ($crole,$cqual)=split(/\&/,$_); |
| if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; } |
if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; } |
| if ($pr{'cr:c'}=~/$crole\&/) { |
if ($pr{'cr:c'}=~/\Q$crole\E\&/) { |
| if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) { |
if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { |
| return "refused:c:$crole&$cqual"; |
return "refused:c:$crole&$cqual"; |
| } |
} |
| } |
} |
|
Line 2911 sub log_query {
|
Line 3123 sub log_query {
|
| my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters)); |
my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters)); |
| my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, |
my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, |
| $uhome); |
$uhome); |
| unless ($queryid=~/^$uhost\_/) { return 'error: '.$queryid; } |
unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; } |
| return get_query_reply($queryid); |
return get_query_reply($queryid); |
| } |
} |
| |
|
| |
# ------- Request retrieval of institutional classlists for course(s) |
| |
|
| |
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); |
| |
} |
| |
my $host=$hostname{$homeserver}; |
| |
my $cmd = ''; |
| |
foreach (keys %{$affiliatesref}) { |
| |
$cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%'; |
| |
} |
| |
$cmd =~ s/%%$//; |
| |
$cmd = &escape($cmd); |
| |
my $query = 'fetchenrollment'; |
| |
my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver); |
| |
unless ($queryid=~/^\Q$host\E\_/) { return 'error: '.$queryid; } |
| |
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.' maxtries: '.$maxtries.' tries: '.$tries); |
| |
} |
| |
unless ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { |
| |
my @responses = split/:/,$reply; |
| |
if ($homeserver eq $perlvar{'lonHostID'}) { |
| |
foreach (@responses) { |
| |
my ($key,$value) = split/=/,$_; |
| |
$$replyref{$key} = $value; |
| |
} |
| |
} else { |
| |
my $pathname = $perlvar{'lonDaemons'}.'/tmp'; |
| |
foreach (@responses) { |
| |
my ($key,$value) = split/=/,$_; |
| |
$$replyref{$key} = $value; |
| |
if ($value > 0) { |
| |
foreach (@{$$affiliatesref{$key}}) { |
| |
my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml'; |
| |
my $destname = $pathname.'/'.$filename; |
| |
my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver); |
| |
unless ($xml_classlist =~ /^error/) { |
| |
if ( open(FILE,">$destname") ) { |
| |
print FILE &unescape($xml_classlist); |
| |
close(FILE); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return 'ok'; |
| |
} |
| |
return 'error'; |
| |
} |
| |
|
| sub get_query_reply { |
sub get_query_reply { |
| my $queryid=shift; |
my $queryid=shift; |
| my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid; |
my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid; |
|
Line 2959 sub userlog_query {
|
Line 3236 sub userlog_query {
|
| return &log_query($uname,$udom,'userlog',%filters); |
return &log_query($uname,$udom,'userlog',%filters); |
| } |
} |
| |
|
| |
#--------- Call auto-enrollment subs in localenroll.pm for homeserver for course |
| |
|
| |
sub auto_run { |
| |
my ($cnum,$cdom) = @_; |
| |
my $homeserver = &homeserver($cnum,$cdom); |
| |
my $response = &reply('autorun:'.$cdom,$homeserver); |
| |
return $response; |
| |
} |
| |
|
| |
sub auto_get_sections { |
| |
my ($cnum,$cdom,$inst_coursecode) = @_; |
| |
my $homeserver = &homeserver($cnum,$cdom); |
| |
my @secs = (); |
| |
my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); |
| |
unless ($response eq 'refused') { |
| |
@secs = split/:/,$response; |
| |
} |
| |
return @secs; |
| |
} |
| |
|
| |
sub auto_new_course { |
| |
my ($cnum,$cdom,$inst_course_id,$owner) = @_; |
| |
my $homeserver = &homeserver($cnum,$cdom); |
| |
my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver)); |
| |
return $response; |
| |
} |
| |
|
| |
sub auto_validate_courseID { |
| |
my ($cnum,$cdom,$inst_course_id) = @_; |
| |
my $homeserver = &homeserver($cnum,$cdom); |
| |
my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver)); |
| |
return $response; |
| |
} |
| |
|
| |
sub auto_create_password { |
| |
my ($cnum,$cdom,$authparam) = @_; |
| |
my $homeserver = &homeserver($cnum,$cdom); |
| |
my $create_passwd = 0; |
| |
my $authchk = ''; |
| |
my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver)); |
| |
if ($response eq 'refused') { |
| |
$authchk = 'refused'; |
| |
} else { |
| |
($authparam,$create_passwd,$authchk) = split/:/,$response; |
| |
} |
| |
return ($authparam,$create_passwd,$authchk); |
| |
} |
| |
|
| |
sub auto_instcode_format { |
| |
my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_; |
| |
my $courses = ''; |
| |
my $homeserver; |
| |
if ($caller eq 'global') { |
| |
$homeserver = $perlvar{'lonHostID'}; |
| |
} else { |
| |
$homeserver = &homeserver($caller,$codedom); |
| |
} |
| |
my $host=$hostname{$homeserver}; |
| |
foreach (keys %{$instcodes}) { |
| |
$courses .= &escape($_).'='.&escape($$instcodes{$_}).'&'; |
| |
} |
| |
chop($courses); |
| |
my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver); |
| |
unless ($response =~ /(con_lost|error|no_such_host|refused)/) { |
| |
my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response; |
| |
%{$codes} = &str2hash($codes_str); |
| |
@{$codetitles} = &str2array($codetitles_str); |
| |
%{$cat_titles} = &str2hash($cat_titles_str); |
| |
%{$cat_order} = &str2hash($cat_order_str); |
| |
return 'ok'; |
| |
} |
| |
return $response; |
| |
} |
| |
|
| # ------------------------------------------------------------------ Plain Text |
# ------------------------------------------------------------------ Plain Text |
| |
|
| sub plaintext { |
sub plaintext { |
|
Line 3149 sub modifyuser {
|
Line 3500 sub modifyuser {
|
| |
|
| sub modifystudent { |
sub modifystudent { |
| my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, |
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, |
| $end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_; |
$end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_; |
| if (!$cid) { |
if (!$cid) { |
| unless ($cid=$ENV{'request.course.id'}) { |
unless ($cid=$ENV{'request.course.id'}) { |
| return 'not_in_class'; |
return 'not_in_class'; |
|
Line 3164 sub modifystudent {
|
Line 3515 sub modifystudent {
|
| # students environment |
# students environment |
| $uid = undef if (!$forceid); |
$uid = undef if (!$forceid); |
| $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, |
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, |
| $gene,$usec,$end,$start,$type,$cid); |
$gene,$usec,$end,$start,$type,$locktype,$cid); |
| return $reply; |
return $reply; |
| } |
} |
| |
|
| sub modify_student_enrollment { |
sub modify_student_enrollment { |
| my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type, |
my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_; |
| $cid) = @_; |
|
| my ($cdom,$cnum,$chome); |
my ($cdom,$cnum,$chome); |
| if (!$cid) { |
if (!$cid) { |
| unless ($cid=$ENV{'request.course.id'}) { |
unless ($cid=$ENV{'request.course.id'}) { |
|
Line 3214 sub modify_student_enrollment {
|
Line 3564 sub modify_student_enrollment {
|
| } |
} |
| my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene, |
my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene, |
| $first,$middle); |
$first,$middle); |
| my $value=&escape($uname.':'.$udom).'='. |
my $reply=cput('classlist', |
| &escape(join(':',$end,$start,$uid,$usec,$fullname,$type)); |
{"$uname:$udom" => |
| my $reply=critical('put:'.$cdom.':'.$cnum.':classlist:'.$value,$chome); |
join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) }, |
| |
$cdom,$cnum); |
| unless (($reply eq 'ok') || ($reply eq 'delayed')) { |
unless (($reply eq 'ok') || ($reply eq 'delayed')) { |
| return 'error: '.$reply; |
return 'error: '.$reply; |
| } |
} |
|
Line 3251 sub writecoursepref {
|
Line 3602 sub writecoursepref {
|
| # ---------------------------------------------------------- Make/modify course |
# ---------------------------------------------------------- Make/modify course |
| |
|
| sub createcourse { |
sub createcourse { |
| my ($udom,$description,$url,$course_server,$nonstandard)=@_; |
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code)=@_; |
| $url=&declutter($url); |
$url=&declutter($url); |
| my $cid=''; |
my $cid=''; |
| unless (&allowed('ccc',$udom)) { |
unless (&allowed('ccc',$udom)) { |
|
Line 3284 sub createcourse {
|
Line 3635 sub createcourse {
|
| return 'error: no such course'; |
return 'error: no such course'; |
| } |
} |
| # ----------------------------------------------------------------- Course made |
# ----------------------------------------------------------------- Course made |
| # log existance |
# log existence |
| &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description), |
&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description). |
| $uhome); |
'='.&escape($inst_code),$uhome); |
| &flushcourselogs(); |
&flushcourselogs(); |
| # set toplevel url |
# set toplevel url |
| my $topurl=$url; |
my $topurl=$url; |
|
Line 3339 sub revokecustomrole {
|
Line 3690 sub revokecustomrole {
|
| $deleteflag); |
$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)); |
| |
return $listing; |
| |
} |
| |
|
| |
sub portfoliomanage { |
| |
|
| |
#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; |
| |
} |
| |
|
| |
|
| # ------------------------------------------------------------ Directory lister |
# ------------------------------------------------------------ Directory lister |
| |
|
| sub dirlist { |
sub dirlist { |
|
Line 3672 sub EXT {
|
Line 4059 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 3687 sub EXT {
|
Line 4077 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=&usection($udom,$uname,$courseid); |
| } else { |
} else { |
| $section = $usection; |
$section = $usection; |
| } |
} |
| } |
} |
| |
|
| my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; |
my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; |
|
Line 3729 sub EXT {
|
Line 4119 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 3739 sub EXT {
|
Line 4129 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 3873 sub metadata {
|
Line 4263 sub metadata {
|
| } |
} |
| my %metathesekeys=(); |
my %metathesekeys=(); |
| unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
| my $metastring=&getfile(&filelocation('',&clutter($filename))); |
my $metastring; |
| |
if ($uri !~ m|^uploaded/|) { |
| |
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; |
| undef %metathesekeys; |
undef %metathesekeys; |
|
Line 3984 sub metadata {
|
Line 4379 sub metadata {
|
| # the next is the end of "start tag" |
# the next is the end of "start tag" |
| } |
} |
| } |
} |
| |
my ($extension) = ($uri =~ /\.(\w+)$/); |
| |
foreach my $key (sort(keys(%packagetab))) { |
| |
#&logthis("extsion1 $extension $key !!"); |
| |
#no specific packages #how's our extension |
| |
if ($key!~/^extension_\Q$extension\E&/) { next; } |
| |
&metadata_create_package_def($uri,$key,'extension_'.$extension, |
| |
\%metathesekeys); |
| |
} |
| |
if (!exists($metacache{$uri}->{':packages'})) { |
| |
foreach my $key (sort(keys(%packagetab))) { |
| |
#no specific packages well let's get default then |
| |
if ($key!~/^default&/) { next; } |
| |
&metadata_create_package_def($uri,$key,'default', |
| |
\%metathesekeys); |
| |
} |
| |
} |
| # are there custom rights to evaluate |
# are there custom rights to evaluate |
| if ($metacache{$uri}->{':copyright'} eq 'custom') { |
if ($metacache{$uri}->{':copyright'} eq 'custom') { |
| |
|
|
Line 4012 sub metadata {
|
Line 4423 sub metadata {
|
| return $metacache{$uri}->{':'.$what}; |
return $metacache{$uri}->{':'.$what}; |
| } |
} |
| |
|
| |
sub metadata_create_package_def { |
| |
my ($uri,$key,$package,$metathesekeys)=@_; |
| |
my ($pack,$name,$subp)=split(/\&/,$key); |
| |
if ($subp eq 'default') { next; } |
| |
|
| |
if (defined($metacache{$uri}->{':packages'})) { |
| |
$metacache{$uri}->{':packages'}.=','.$package; |
| |
} else { |
| |
$metacache{$uri}->{':packages'}=$package; |
| |
} |
| |
my $value=$packagetab{$key}; |
| |
my $unikey; |
| |
$unikey='parameter_0_'.$name; |
| |
$metacache{$uri}->{':'.$unikey.'.part'}=0; |
| |
$$metathesekeys{$unikey}=1; |
| |
unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { |
| |
$metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; |
| |
} |
| |
if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { |
| |
$metacache{$uri}->{':'.$unikey}= |
| |
$metacache{$uri}->{':'.$unikey.'.default'}; |
| |
} |
| |
} |
| |
|
| sub metadata_generate_part0 { |
sub metadata_generate_part0 { |
| my ($metadata,$metacache,$uri) = @_; |
my ($metadata,$metacache,$uri) = @_; |
| my %allnames; |
my %allnames; |
|
Line 4035 sub metadata_generate_part0 {
|
Line 4470 sub metadata_generate_part0 {
|
| my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name. |
my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name. |
| '.display'}; |
'.display'}; |
| my $expr='\\[Part: '.$allnames{$name}.'\\]'; |
my $expr='\\[Part: '.$allnames{$name}.'\\]'; |
| $olddis=~s/$expr/\[Part: 0\]/; |
$olddis=~s/\Q$expr\E/\[Part: 0\]/; |
| $$metacache{"$key.display"}=$olddis; |
$$metacache{"$key.display"}=$olddis; |
| } |
} |
| } |
} |
|
Line 4091 sub symblist {
|
Line 4526 sub symblist {
|
| # --------------------------------------------------------------- Verify a symb |
# --------------------------------------------------------------- Verify a symb |
| |
|
| sub symbverify { |
sub symbverify { |
| my ($symb,$thisfn)=@_; |
my ($symb,$thisurl)=@_; |
| |
my $thisfn=$thisurl; |
| |
# wrapper not part of symbs |
| |
$thisfn=~s/^\/adm\/wrapper//; |
| $thisfn=&declutter($thisfn); |
$thisfn=&declutter($thisfn); |
| # direct jump to resource in page or to a sequence - will construct own symbs |
# direct jump to resource in page or to a sequence - will construct own symbs |
| if ($thisfn=~/\.(page|sequence)$/) { return 1; } |
if ($thisfn=~/\.(page|sequence)$/) { return 1; } |
|
Line 4101 sub symbverify {
|
Line 4539 sub symbverify {
|
| unless ($url eq $thisfn) { return 0; } |
unless ($url eq $thisfn) { return 0; } |
| |
|
| $symb=&symbclean($symb); |
$symb=&symbclean($symb); |
| |
$thisurl=&deversion($thisurl); |
| $thisfn=&deversion($thisfn); |
$thisfn=&deversion($thisfn); |
| |
|
| my %bighash; |
my %bighash; |
|
Line 4108 sub symbverify {
|
Line 4547 sub symbverify {
|
| |
|
| if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
| &GDBM_READER(),0640)) { |
&GDBM_READER(),0640)) { |
| my $ids=$bighash{'ids_'.&clutter($thisfn)}; |
my $ids=$bighash{'ids_'.&clutter($thisurl)}; |
| unless ($ids) { |
unless ($ids) { |
| $ids=$bighash{'ids_/'.$thisfn}; |
$ids=$bighash{'ids_/'.$thisurl}; |
| } |
} |
| if ($ids) { |
if ($ids) { |
| # ------------------------------------------------------------------- Has ID(s) |
# ------------------------------------------------------------------- Has ID(s) |
|
Line 4139 sub symbclean {
|
Line 4578 sub symbclean {
|
| # remove version from URL |
# remove version from URL |
| $symb=~s/\.(\d+)\.(\w+)$/\.$2/; |
$symb=~s/\.(\d+)\.(\w+)$/\.$2/; |
| |
|
| |
# remove wrapper |
| |
|
| |
$symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/; |
| return $symb; |
return $symb; |
| } |
} |
| |
|
|
Line 4190 sub deversion {
|
Line 4632 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; |
| my %bighash; |
my %bighash; |
| my $syval=''; |
my $syval=''; |
| if (($ENV{'request.course.fn'}) && ($thisfn)) { |
if (($ENV{'request.course.fn'}) && ($thisfn)) { |
| |
my $targetfn = $thisfn; |
| |
if ( ($thisfn =~ m/^uploaded\//) && ($thisfn !~ m/\.(page|sequence)$/) ) { |
| |
$targetfn = 'adm/wrapper/'.$thisfn; |
| |
} |
| if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', |
if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', |
| &GDBM_READER(),0640)) { |
&GDBM_READER(),0640)) { |
| $syval=$hash{$thisfn}; |
$syval=$hash{$targetfn}; |
| untie(%hash); |
untie(%hash); |
| } |
} |
| # ---------------------------------------------------------- There was an entry |
# ---------------------------------------------------------- There was an entry |
|
Line 4214 sub symbread {
|
Line 4666 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 4258 sub symbread {
|
Line 4710 sub symbread {
|
| } |
} |
| } |
} |
| untie(%bighash) |
untie(%bighash) |
| } |
} |
| } |
} |
| 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 4279 sub numval {
|
Line 4731 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); |
| } |
} |
| |
|
| |
sub numval2 { |
| |
my $txt=shift; |
| |
$txt=~tr/A-J/0-9/; |
| |
$txt=~tr/a-j/0-9/; |
| |
$txt=~tr/K-T/0-9/; |
| |
$txt=~tr/k-t/0-9/; |
| |
$txt=~tr/U-Z/0-5/; |
| |
$txt=~tr/u-z/0-5/; |
| |
$txt=~s/\D//g; |
| |
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); |
| |
} |
| |
|
| sub latest_rnd_algorithm_id { |
sub latest_rnd_algorithm_id { |
| return '64bit2'; |
return '64bit3'; |
| |
} |
| |
|
| |
sub get_rand_alg { |
| |
my ($courseid)=@_; |
| |
if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; } |
| |
if ($courseid) { |
| |
return $ENV{"course.$courseid.rndseed"}; |
| |
} |
| |
return &latest_rnd_algorithm_id(); |
| |
} |
| |
|
| |
sub validCODE { |
| |
my ($CODE)=@_; |
| |
if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; } |
| |
return 0; |
| |
} |
| |
|
| |
sub getCODE { |
| |
if (&validCODE($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; } |
| |
if (defined($Apache::lonhomework::parsing_a_problem) && |
| |
&validCODE($Apache::lonhomework::history{'resource.CODE'})) { |
| |
return $Apache::lonhomework::history{'resource.CODE'}; |
| |
} |
| |
return undef; |
| } |
} |
| |
|
| sub rndseed { |
sub rndseed { |
|
Line 4296 sub rndseed {
|
Line 4789 sub rndseed {
|
| if (!$courseid) { $courseid=$wcourseid; } |
if (!$courseid) { $courseid=$wcourseid; } |
| if (!$domain) { $domain=$wdomain; } |
if (!$domain) { $domain=$wdomain; } |
| if (!$username) { $username=$wusername } |
if (!$username) { $username=$wusername } |
| my $which=$ENV{"course.$courseid.rndseed"}; |
my $which=&get_rand_alg(); |
| my $CODE=$ENV{'scantron.CODE'}; |
if (defined(&getCODE())) { |
| if (defined($CODE)) { |
return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); |
| &rndseed_CODE_64bit($symb,$courseid,$domain,$username); |
} elsif ($which eq '64bit3') { |
| |
return &rndseed_64bit3($symb,$courseid,$domain,$username); |
| } elsif ($which eq '64bit2') { |
} elsif ($which eq '64bit2') { |
| return &rndseed_64bit2($symb,$courseid,$domain,$username); |
return &rndseed_64bit2($symb,$courseid,$domain,$username); |
| } elsif ($which eq '64bit') { |
} elsif ($which eq '64bit') { |
|
Line 4321 sub rndseed_32bit {
|
Line 4815 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 4341 sub rndseed_64bit {
|
Line 4836 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); } |
| return "$num1,$num2"; |
return "$num1,$num2"; |
| } |
} |
| } |
} |
|
Line 4363 sub rndseed_64bit2 {
|
Line 4859 sub rndseed_64bit2 {
|
| 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); } |
| return "$num1,$num2"; |
return "$num1,$num2"; |
| } |
} |
| } |
} |
| |
|
| |
sub rndseed_64bit3 { |
| |
my ($symb,$courseid,$domain,$username)=@_; |
| |
{ |
| |
use integer; |
| |
# strings need to be an even # of cahracters long, it it is odd the |
| |
# last characters gets thrown away |
| |
my $symbchck=unpack("%32S*",$symb.' ') << 21; |
| |
my $symbseed=numval2($symb) << 10; |
| |
my $namechck=unpack("%32S*",$username.' '); |
| |
|
| |
my $nameseed=numval2($username) << 21; |
| |
my $domainseed=unpack("%32S*",$domain.' ') << 10; |
| |
my $courseseed=unpack("%32S*",$courseid.' '); |
| |
|
| |
my $num1=$symbchck+$symbseed+$namechck; |
| |
my $num2=$nameseed+$domainseed+$courseseed; |
| |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
| |
#&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit"); |
| |
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } |
| |
|
| |
return "$num1:$num2"; |
| |
} |
| |
} |
| |
|
| sub rndseed_CODE_64bit { |
sub rndseed_CODE_64bit { |
| my ($symb,$courseid,$domain,$username)=@_; |
my ($symb,$courseid,$domain,$username)=@_; |
| { |
{ |
| use integer; |
use integer; |
| my $symbchck=unpack("%32S*",$symb.' ') << 16; |
my $symbchck=unpack("%32S*",$symb.' ') << 16; |
| my $symbseed=numval($symb); |
my $symbseed=numval2($symb); |
| my $CODEseed=numval($ENV{'scantron.CODE'}) << 16; |
my $CODEchck=unpack("%32S*",&getCODE().' ') << 16; |
| |
my $CODEseed=numval(&getCODE()); |
| my $courseseed=unpack("%32S*",$courseid.' '); |
my $courseseed=unpack("%32S*",$courseid.' '); |
| my $num1=$symbseed+$CODEseed; |
my $num1=$symbseed+$CODEchck; |
| my $num2=$courseseed+$symbchck; |
my $num2=$CODEseed+$courseseed+$symbchck; |
| #&Apache::lonxml::debug("$symbseed:$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"); |
| return "$num1,$num2"; |
if ($_64bit) { $num1=(($num1<<32)>>32); } |
| |
if ($_64bit) { $num2=(($num2<<32)>>32); } |
| |
return "$num1:$num2"; |
| } |
} |
| } |
} |
| |
|
| sub setup_random_from_rndseed { |
sub setup_random_from_rndseed { |
| my ($rndseed)=@_; |
my ($rndseed)=@_; |
| if ($rndseed =~/,/) { |
if ($rndseed =~/([,:])/) { |
| my ($num1,$num2)=split(/,/,$rndseed); |
my ($num1,$num2)=split(/[,:]/,$rndseed); |
| &Math::Random::random_set_seed(abs($num1),abs($num2)); |
&Math::Random::random_set_seed(abs($num1),abs($num2)); |
| } else { |
} else { |
| &Math::Random::random_set_seed_from_phrase($rndseed); |
&Math::Random::random_set_seed_from_phrase($rndseed); |
| } |
} |
| } |
} |
| |
|
| |
sub latest_receipt_algorithm_id { |
| |
return 'receipt2'; |
| |
} |
| |
|
| |
sub recunique { |
| |
my $fucourseid=shift; |
| |
my $unique; |
| |
if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') { |
| |
$unique=$ENV{"course.$fucourseid.internal.encseed"}; |
| |
} else { |
| |
$unique=$perlvar{'lonReceipt'}; |
| |
} |
| |
return unpack("%32C*",$unique); |
| |
} |
| |
|
| |
sub recprefix { |
| |
my $fucourseid=shift; |
| |
my $prefix; |
| |
if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') { |
| |
$prefix=$ENV{"course.$fucourseid.internal.encpref"}; |
| |
} else { |
| |
$prefix=$perlvar{'lonHostID'}; |
| |
} |
| |
return unpack("%32C*",$prefix); |
| |
} |
| |
|
| sub ireceipt { |
sub ireceipt { |
| my ($funame,$fudom,$fucourseid,$fusymb)=@_; |
my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_; |
| my $cuname=unpack("%32C*",$funame); |
my $cuname=unpack("%32C*",$funame); |
| my $cudom=unpack("%32C*",$fudom); |
my $cudom=unpack("%32C*",$fudom); |
| my $cucourseid=unpack("%32C*",$fucourseid); |
my $cucourseid=unpack("%32C*",$fucourseid); |
| my $cusymb=unpack("%32C*",$fusymb); |
my $cusymb=unpack("%32C*",$fusymb); |
| my $cunique=unpack("%32C*",$perlvar{'lonReceipt'}); |
my $cunique=&recunique($fucourseid); |
| return unpack("%32C*",$perlvar{'lonHostID'}).'-'. |
my $cpart=unpack("%32S*",$part); |
| ($cunique%$cuname+ |
my $return =&recprefix($fucourseid).'-'; |
| $cunique%$cudom+ |
if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2' || |
| $cusymb%$cuname+ |
$ENV{'request.state'} eq 'construct') { |
| $cusymb%$cudom+ |
&Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname). |
| $cucourseid%$cuname+ |
" and ".($cpart%$cudom)); |
| $cucourseid%$cudom); |
|
| |
$return.= ($cunique%$cuname+ |
| |
$cunique%$cudom+ |
| |
$cusymb%$cuname+ |
| |
$cusymb%$cudom+ |
| |
$cucourseid%$cuname+ |
| |
$cucourseid%$cudom+ |
| |
$cpart%$cuname+ |
| |
$cpart%$cudom); |
| |
} else { |
| |
$return.= ($cunique%$cuname+ |
| |
$cunique%$cudom+ |
| |
$cusymb%$cuname+ |
| |
$cusymb%$cudom+ |
| |
$cucourseid%$cuname+ |
| |
$cucourseid%$cudom); |
| |
} |
| |
return $return; |
| } |
} |
| |
|
| sub receipt { |
sub receipt { |
| my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); |
my ($part)=@_; |
| return &ireceipt($name,$domain,$courseid,$symb); |
my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); |
| |
return &ireceipt($name,$domain,$courseid,$symb,$part); |
| } |
} |
| |
|
| # ------------------------------------------------------------ Serves up a file |
# ------------------------------------------------------------ Serves up a file |
| # returns either the contents of the file or a -1 |
# returns either the contents of the file or |
| |
# -1 if the file doesn't exist |
| |
# |
| |
# if the target is a file that was uploaded via DOCS, |
| |
# a check will be made to see if a current copy exists on the local server, |
| |
# if it does this will be served, otherwise a copy will be retrieved from |
| |
# the home server for the course and stored in /home/httpd/html/userfiles on |
| |
# the local server. |
| |
|
| sub getfile { |
sub getfile { |
| my $file=shift; |
my ($file,$caller) = @_; |
| if ($file=~/^\/*uploaded\//) { # user 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 ($lwpresp ne 'ok') { |
| |
if ($rtncode eq '404') { |
| |
unlink($localfile); |
| |
} |
| |
#my $ua=new LWP::UserAgent; |
| |
#my $request=new HTTP::Request('GET',&tokenwrapper($file)); |
| |
#my $response=$ua->request($request); |
| |
#if ($response->is_success()) { |
| |
# return $response->content; |
| |
# } else { |
| |
# return -1; |
| |
# } |
| |
return -1; |
| |
} |
| |
if ($info < $fileinfo[9]) { |
| |
return &readfile($localfile); |
| |
} |
| |
$info = ''; |
| |
$lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); |
| |
if ($lwpresp ne 'ok') { |
| |
return -1; |
| |
} |
| |
} else { |
| |
$lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); |
| |
if ($lwpresp ne 'ok') { |
| |
my $ua=new LWP::UserAgent; |
| |
my $request=new HTTP::Request('GET',&tokenwrapper($file)); |
| |
my $response=$ua->request($request); |
| |
if ($response->is_success()) { |
| |
return $response->content; |
| |
} else { |
| |
return -1; |
| |
} |
| |
} |
| |
my @parts = ($cdom,$cnum); |
| |
if ($filename =~ m|^(.+)/[^/]+$|) { |
| |
push @parts, split(/\//,$1); |
| |
} |
| |
foreach my $part (@parts) { |
| |
$path .= '/'.$part; |
| |
if (!-e $path) { |
| |
mkdir($path,0770); |
| |
} |
| |
} |
| |
} |
| |
open (FILE,">$localfile"); |
| |
print FILE $info; |
| |
close(FILE); |
| |
if ($caller eq 'uploadrep') { |
| |
return 'ok'; |
| |
} |
| |
return $info; |
| |
} |
| |
|
| |
sub tokenwrapper { |
| |
my $uri=shift; |
| |
$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. |
| |
(($uri=~/\?/)?'&':'?').'token='.$token. |
| |
'&tokenissued='.$perlvar{'lonHostID'}; |
| |
} else { |
| |
return '/adm/notfound.html'; |
| |
} |
| |
} |
| |
|
| |
sub getuploaded { |
| |
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; |
| |
$uri=~s/^\///; |
| |
$uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri; |
| my $ua=new LWP::UserAgent; |
my $ua=new LWP::UserAgent; |
| my $request=new HTTP::Request('GET',&tokenwrapper($file)); |
my $request=new HTTP::Request($reqtype,$uri); |
| my $response=$ua->request($request); |
my $response=$ua->request($request); |
| if ($response->is_success()) { |
$$rtncode = $response->code; |
| return $response->content; |
if (! $response->is_success()) { |
| } else { |
return 'failed'; |
| return -1; |
} |
| } |
if ($reqtype eq 'HEAD') { |
| } else { # normal file from res space |
$$info = &HTTP::Date::str2time( $response->header('Last-modified') ); |
| &repcopy($file); |
} elsif ($reqtype eq 'GET') { |
| if (! -e $file ) { return -1; }; |
$$info = $response->content; |
| my $fh; |
} |
| open($fh,"<$file"); |
return 'ok'; |
| my $a=''; |
} |
| while (<$fh>) { $a .=$_; } |
|
| return $a; |
sub readfile { |
| } |
my $file = shift; |
| |
if ( (! -e $file ) || ($file eq '') ) { return -1; }; |
| |
my $fh; |
| |
open($fh,"<$file"); |
| |
my $a=''; |
| |
while (<$fh>) { $a .=$_; } |
| |
return $a; |
| } |
} |
| |
|
| sub filelocation { |
sub filelocation { |
|
Line 4448 sub filelocation {
|
Line 5120 sub filelocation {
|
| } elsif ($file=~/^\/*uploaded/) { # is an uploaded file |
} elsif ($file=~/^\/*uploaded/) { # is an uploaded file |
| $location=$file; |
$location=$file; |
| } else { |
} else { |
| $file=~s/^$perlvar{'lonDocRoot'}//; |
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
| $file=~s:^/res/:/:; |
$file=~s:^/res/:/:; |
| if ( !( $file =~ m:^/:) ) { |
if ( !( $file =~ m:^/:) ) { |
| $location = $dir. '/'.$file; |
$location = $dir. '/'.$file; |
|
Line 4458 sub filelocation {
|
Line 5130 sub filelocation {
|
| } |
} |
| $location=~s://+:/:g; # remove duplicate / |
$location=~s://+:/:g; # remove duplicate / |
| while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. |
while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. |
| |
while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./ |
| return $location; |
return $location; |
| } |
} |
| |
|
|
Line 4504 sub current_machine_ids {
|
Line 5177 sub current_machine_ids {
|
| |
|
| sub declutter { |
sub declutter { |
| my $thisfn=shift; |
my $thisfn=shift; |
| $thisfn=~s/^$perlvar{'lonDocRoot'}//; |
$thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
| $thisfn=~s/^\///; |
$thisfn=~s/^\///; |
| $thisfn=~s/^res\///; |
$thisfn=~s/^res\///; |
| $thisfn=~s/\?.+$//; |
$thisfn=~s/\?.+$//; |
|
Line 4515 sub declutter {
|
Line 5188 sub declutter {
|
| |
|
| sub clutter { |
sub clutter { |
| my $thisfn='/'.&declutter(shift); |
my $thisfn='/'.&declutter(shift); |
| unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) { |
unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv|public)\//) { |
| $thisfn='/res'.$thisfn; |
$thisfn='/res'.$thisfn; |
| } |
} |
| return $thisfn; |
return $thisfn; |
|
Line 4577 BEGIN {
|
Line 5250 BEGIN {
|
| open(my $config,"</etc/httpd/conf/loncapa.conf"); |
open(my $config,"</etc/httpd/conf/loncapa.conf"); |
| |
|
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
| if ($configline =~ /^[^\#]*PerlSetVar/) { |
if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) { |
| my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); |
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); |
| chomp($varvalue); |
chomp($varvalue); |
| $perlvar{$varname}=$varvalue; |
$perlvar{$varname}=$varvalue; |
|
Line 4695 BEGIN {
|
Line 5368 BEGIN {
|
| open(my $config,"<$perlvar{'lonTabDir'}/packages.tab"); |
open(my $config,"<$perlvar{'lonTabDir'}/packages.tab"); |
| |
|
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
| |
if ($configline !~ /\S/ || $configline=~/^#/) { next; } |
| chomp($configline); |
chomp($configline); |
| my ($short,$plain)=split(/:/,$configline); |
my ($short,$plain)=split(/:/,$configline); |
| my ($pack,$name)=split(/\&/,$short); |
my ($pack,$name)=split(/\&/,$short); |
|
Line 4720 $dumpcount=0;
|
Line 5394 $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 5440 messages of critical importance should g
|
Line 6120 messages of critical importance should g
|
| |
|
| =item * |
=item * |
| |
|
| getfile($file) : returns the entire contents of a file or -1; it |
getfile($file,$caller) : two cases - requests for files in /res or in /uploaded. |
| properly subscribes to and replicates the file if neccessary. |
(a) files in /uploaded |
| |
(i) If a local copy of the file exists - |
| |
compares modification date of local copy with last-modified date for |
| |
definitive version stored on home server for course. If local copy is |
| |
stale, requests a new version from the home server and stores it. |
| |
If the original has been removed from the home server, then local copy |
| |
is unlinked. |
| |
(ii) If local copy does not exist - |
| |
requests the file from the home server and stores it. |
| |
|
| |
If $caller is 'uploadrep': |
| |
This indicates a call from lonuploadrep.pm (PerlHeaderParserHandler phase) |
| |
for request for files originally uploaded via DOCS. |
| |
- returns 'ok' if fresh local copy now available, -1 otherwise. |
| |
|
| |
Otherwise: |
| |
This indicates a call from the content generation phase of the request. |
| |
- returns the entire contents of the file or -1. |
| |
|
| |
(b) files in /res |
| |
- returns the entire contents of a file or -1; |
| |
it properly subscribes to and replicates the file if neccessary. |
| |
|
| =item * |
=item * |
| |
|
![[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