|
version 1.291, 2002/10/03 22:32:53
|
version 1.332, 2003/03/01 15:13:58
|
|
Line 47
|
Line 47
|
| # 09/01 Guy Albertelli |
# 09/01 Guy Albertelli |
| # 09/01,10/01,11/01 Gerd Kortemeyer |
# 09/01,10/01,11/01 Gerd Kortemeyer |
| # YEAR=2001 |
# YEAR=2001 |
| # 02/27/01 Scott Harrison |
|
| # 3/2 Gerd Kortemeyer |
# 3/2 Gerd Kortemeyer |
| # 3/15,3/19 Scott Harrison |
|
| # 3/19,3/20 Gerd Kortemeyer |
# 3/19,3/20 Gerd Kortemeyer |
| # 3/22,3/27,4/2,4/16,4/17 Scott Harrison |
|
| # 5/26,5/28 Gerd Kortemeyer |
# 5/26,5/28 Gerd Kortemeyer |
| # 5/30 H. K. Ng |
# 5/30 H. K. Ng |
| # 6/1 Gerd Kortemeyer |
# 6/1 Gerd Kortemeyer |
| # July Guy Albertelli |
# July Guy Albertelli |
| # 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26, |
# 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26, |
| # 10/2 Gerd Kortemeyer |
# 10/2 Gerd Kortemeyer |
| # 10/5,10/10,11/13,11/15 Scott Harrison |
|
| # 11/17,11/20,11/22,11/29 Gerd Kortemeyer |
# 11/17,11/20,11/22,11/29 Gerd Kortemeyer |
| # 12/5 Matthew Hall |
# 12/5 Matthew Hall |
| # 12/5 Guy Albertelli |
# 12/5 Guy Albertelli |
| # 12/6,12/7,12/12 Gerd Kortemeyer |
# 12/6,12/7,12/12 Gerd Kortemeyer |
| # 12/18 Scott Harrison |
|
| # 12/21,12/22,12/27,12/28 Gerd Kortemeyer |
# 12/21,12/22,12/27,12/28 Gerd Kortemeyer |
| # YEAR=2002 |
# YEAR=2002 |
| # 1/4,2/4,2/7 Gerd Kortemeyer |
# 1/4,2/4,2/7 Gerd Kortemeyer |
|
Line 77 use Apache::File;
|
Line 72 use Apache::File;
|
| use LWP::UserAgent(); |
use LWP::UserAgent(); |
| use HTTP::Headers; |
use HTTP::Headers; |
| use vars |
use vars |
| qw(%perlvar %hostname %homecache %badServerCache %hostip %spareid %hostdom |
qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom |
| %libserv %pr %prp %metacache %packagetab |
%libserv %pr %prp %metacache %packagetab %titlecache |
| %courselogs %accesshash $processmarker $dumpcount |
%courselogs %accesshash $processmarker $dumpcount |
| %coursedombuf %coursehombuf %courseresdatacache %domaindescription); |
%coursedombuf %coursehombuf %courseresdatacache |
| |
%domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir); |
| 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; |
| |
|
| my $readit; |
my $readit; |
| |
|
| # --------------------------------------------------------------------- Logging |
# --------------------------------------------------------------------- Logging |
|
Line 140 sub reply {
|
Line 138 sub reply {
|
| unless (defined($hostname{$server})) { return 'no_such_host'; } |
unless (defined($hostname{$server})) { return 'no_such_host'; } |
| my $answer=subreply($cmd,$server); |
my $answer=subreply($cmd,$server); |
| if ($answer eq 'con_lost') { |
if ($answer eq 'con_lost') { |
| #sleep 5; |
#sleep 5; |
| #$answer=subreply($cmd,$server); |
#$answer=subreply($cmd,$server); |
| #if ($answer eq 'con_lost') { |
#if ($answer eq 'con_lost') { |
| # &logthis("Second attempt con_lost on $server"); |
# &logthis("Second attempt con_lost on $server"); |
| # my $peerfile="$perlvar{'lonSockDir'}/$server"; |
# my $peerfile="$perlvar{'lonSockDir'}/$server"; |
| # my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", |
# my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", |
|
Line 213 sub critical {
|
Line 211 sub critical {
|
| $middlename=substr($middlename,0,16); |
$middlename=substr($middlename,0,16); |
| $middlename=~s/\W//g; |
$middlename=~s/\W//g; |
| my $dfilename= |
my $dfilename= |
| "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server"; |
"$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server"; |
| |
$dumpcount++; |
| { |
{ |
| my $dfh; |
my $dfh; |
| if ($dfh=Apache::File->new(">$dfilename")) { |
if ($dfh=Apache::File->new(">$dfilename")) { |
|
Line 591 sub idput {
|
Line 590 sub idput {
|
| |
|
| # ------------------------------------- Find the section of student in a course |
# ------------------------------------- Find the section of student in a course |
| |
|
| |
sub getsection { |
| |
my ($udom,$unam,$courseid)=@_; |
| |
$courseid=~s/\_/\//g; |
| |
$courseid=~s/^(\w)/\/$1/; |
| |
my %Pending; |
| |
my %Expired; |
| |
# |
| |
# Each role can either have not started yet (pending), be active, |
| |
# or have expired. |
| |
# |
| |
# If there is an active role, we are done. |
| |
# |
| |
# If there is more than one role which has not started yet, |
| |
# choose the one which will start sooner |
| |
# If there is one role which has not started yet, return it. |
| |
# |
| |
# If there is more than one expired role, choose the one which ended last. |
| |
# If there is a role which has expired, return it. |
| |
# |
| |
foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', |
| |
&homeserver($unam,$udom)))) { |
| |
my ($key,$value)=split(/\=/,$_); |
| |
$key=&unescape($key); |
| |
next if ($key !~/^$courseid(?:\/)*(\w+)*\_st$/); |
| |
my $section=$1; |
| |
if ($key eq $courseid.'_st') { $section=''; } |
| |
my ($dummy,$end,$start)=split(/\_/,&unescape($value)); |
| |
my $now=time; |
| |
if (defined($end) && ($now > $end)) { |
| |
$Expired{$end}=$section; |
| |
next; |
| |
} |
| |
if (defined($start) && ($now < $start)) { |
| |
$Pending{$start}=$section; |
| |
next; |
| |
} |
| |
return $section; |
| |
} |
| |
# |
| |
# Presumedly there will be few matching roles from the above |
| |
# loop and the sorting time will be negligible. |
| |
if (scalar(keys(%Pending))) { |
| |
my ($time) = sort {$a <=> $b} keys(%Pending); |
| |
return $Pending{$time}; |
| |
} |
| |
if (scalar(keys(%Expired))) { |
| |
my @sorted = sort {$a <=> $b} keys(%Expired); |
| |
my $time = pop(@sorted); |
| |
return $Expired{$time}; |
| |
} |
| |
return '-1'; |
| |
} |
| |
|
| sub usection { |
sub usection { |
| my ($udom,$unam,$courseid)=@_; |
my ($udom,$unam,$courseid)=@_; |
| $courseid=~s/\_/\//g; |
$courseid=~s/\_/\//g; |
|
Line 644 sub chatsend {
|
Line 696 sub chatsend {
|
| &escape($newentry)),$chome); |
&escape($newentry)),$chome); |
| } |
} |
| |
|
| |
# ------------------------------------------ Find current version of a resource |
| |
|
| |
sub getversion { |
| |
my $fname=&clutter(shift); |
| |
unless ($fname=~/^\/res\//) { return -1; } |
| |
return ¤tversion(&filelocation('',$fname)); |
| |
} |
| |
|
| |
sub currentversion { |
| |
my $fname=shift; |
| |
my $author=$fname; |
| |
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
| |
my ($udom,$uname)=split(/\//,$author); |
| |
my $home=homeserver($uname,$udom); |
| |
if ($home eq 'no_host') { |
| |
return -1; |
| |
} |
| |
my $answer=reply("currentversion:$fname",$home); |
| |
if (($answer eq 'con_lost') || ($answer eq 'rejected')) { |
| |
return -1; |
| |
} |
| |
return $answer; |
| |
} |
| |
|
| # ----------------------------- Subscribe to a resource, return URL if possible |
# ----------------------------- Subscribe to a resource, return URL if possible |
| |
|
| sub subscribe { |
sub subscribe { |
| my $fname=shift; |
my $fname=shift; |
| |
if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; } |
| 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 727 sub repcopy {
|
Line 804 sub repcopy {
|
| } |
} |
| } |
} |
| |
|
| |
# ------------------------------------------------ Get server side include body |
| |
sub ssi_body { |
| |
my $filelink=shift; |
| |
my $output=($filelink=~/^http\:/?&externalssi($filelink): |
| |
&ssi($filelink)); |
| |
$output=~s/^.*\<body[^\>]*\>//si; |
| |
$output=~s/\<\/body\s*\>.*$//si; |
| |
$output=~ |
| |
s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs; |
| |
return $output; |
| |
} |
| |
|
| # --------------------------------------------------------- Server Side Include |
# --------------------------------------------------------- Server Side Include |
| |
|
| sub ssi { |
sub ssi { |
|
Line 750 sub ssi {
|
Line 839 sub ssi {
|
| return $response->content; |
return $response->content; |
| } |
} |
| |
|
| |
sub externalssi { |
| |
my ($url)=@_; |
| |
my $ua=new LWP::UserAgent; |
| |
my $request=new HTTP::Request('GET',$url); |
| |
my $response=$ua->request($request); |
| |
return $response->content; |
| |
} |
| |
|
| # ------- Add a token to a remote URI's query string to vouch for access rights |
# ------- Add a token to a remote URI's query string to vouch for access rights |
| |
|
| sub tokenwrapper { |
sub tokenwrapper { |
|
Line 761 sub tokenwrapper {
|
Line 858 sub tokenwrapper {
|
| if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) { |
if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) { |
| &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'}); |
&appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'}); |
| return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri. |
return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri. |
| (($uri=~/\?/)?'&':'?').'token='.$token; |
(($uri=~/\?/)?'&':'?').'token='.$token. |
| |
'&tokenissued='.$perlvar{'lonHostID'}; |
| } else { |
} else { |
| return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
| } |
} |
|
Line 774 sub tokenwrapper {
|
Line 872 sub tokenwrapper {
|
| sub userfileupload { |
sub userfileupload { |
| my ($formname,$coursedoc)=@_; |
my ($formname,$coursedoc)=@_; |
| my $fname=$ENV{'form.'.$formname.'.filename'}; |
my $fname=$ENV{'form.'.$formname.'.filename'}; |
| |
# Replace Windows backslashes by forward slashes |
| $fname=~s/\\/\//g; |
$fname=~s/\\/\//g; |
| |
# Get rid of everything but the actual filename |
| $fname=~s/^.*\/([^\/]+)$/$1/; |
$fname=~s/^.*\/([^\/]+)$/$1/; |
| |
# Replace spaces by underscores |
| |
$fname=~s/\s+/\_/g; |
| |
# Replace all other weird characters by nothing |
| |
$fname=~s/[^\w\.\-]//g; |
| |
# 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}); |
| # Create the directory if not present |
# Create the directory if not present |
|
Line 814 sub finishuserfileupload {
|
Line 919 sub finishuserfileupload {
|
| } |
} |
| # Notify homeserver to grep it |
# Notify homeserver to grep it |
| # |
# |
| if |
|
| (&reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome) eq 'ok') |
my $fetchresult= |
| { |
&reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome); |
| |
if ($fetchresult eq 'ok') { |
| # |
# |
| # Return the URL to it |
# Return the URL to it |
| return '/uploaded/'.$path.$fname; |
return '/uploaded/'.$path.$fname; |
| } else { |
} else { |
| |
&logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$fname. |
| |
' to host '.$docuhome.': '.$fetchresult); |
| return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
| } |
} |
| } |
} |
|
Line 1016 sub expirespread {
|
Line 1124 sub expirespread {
|
| # ----------------------------------------------------- Devalidate Spreadsheets |
# ----------------------------------------------------- Devalidate Spreadsheets |
| |
|
| sub devalidate { |
sub devalidate { |
| my $symb=shift; |
my ($symb,$uname,$udom)=@_; |
| my $cid=$ENV{'request.course.id'}; |
my $cid=$ENV{'request.course.id'}; |
| if ($cid) { |
if ($cid) { |
| my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':'; |
# delete the stored spreadsheets for |
| |
# - the student level sheet of this user in course's homespace |
| |
# - the assessment level sheet for this resource |
| |
# for this user in user's homespace |
| |
my $key=$uname.':'.$udom.':'; |
| my $status= |
my $status= |
| &del('nohist_calculatedsheet', |
&del('nohist_calculatedsheets', |
| [$key.'studentcalc'], |
[$key.'studentcalc'], |
| $ENV{'course.'.$cid.'.domain'}, |
$ENV{'course.'.$cid.'.domain'}, |
| $ENV{'course.'.$cid.'.num'}) |
$ENV{'course.'.$cid.'.num'}) |
|
Line 1030 sub devalidate {
|
Line 1142 sub devalidate {
|
| [$key.'assesscalc:'.$symb]); |
[$key.'assesscalc:'.$symb]); |
| unless ($status eq 'ok ok') { |
unless ($status eq 'ok ok') { |
| &logthis('Could not devalidate spreadsheet '. |
&logthis('Could not devalidate spreadsheet '. |
| $ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '. |
$uname.' at '.$udom.' for '. |
| $symb.': '.$status); |
$symb.': '.$status); |
| } |
} |
| } |
} |
|
Line 1362 sub store {
|
Line 1474 sub store {
|
| $symb=&symbclean($symb); |
$symb=&symbclean($symb); |
| if (!$symb) { unless ($symb=&symbread()) { return ''; } } |
if (!$symb) { unless ($symb=&symbread()) { return ''; } } |
| |
|
| &devalidate($symb); |
if (!$domain) { $domain=$ENV{'user.domain'}; } |
| |
if (!$stuname) { $stuname=$ENV{'user.name'}; } |
| |
|
| |
&devalidate($symb,$stuname,$domain); |
| |
|
| $symb=escape($symb); |
$symb=escape($symb); |
| if (!$namespace) { |
if (!$namespace) { |
|
Line 1370 sub store {
|
Line 1485 sub store {
|
| return ''; |
return ''; |
| } |
} |
| } |
} |
| if (!$domain) { $domain=$ENV{'user.domain'}; } |
|
| if (!$stuname) { $stuname=$ENV{'user.name'}; } |
|
| if (!$home) { $home=$ENV{'user.home'}; } |
if (!$home) { $home=$ENV{'user.home'}; } |
| my $namevalue=''; |
my $namevalue=''; |
| foreach (keys %$storehash) { |
foreach (keys %$storehash) { |
|
Line 1393 sub cstore {
|
Line 1506 sub cstore {
|
| $symb=&symbclean($symb); |
$symb=&symbclean($symb); |
| if (!$symb) { unless ($symb=&symbread()) { return ''; } } |
if (!$symb) { unless ($symb=&symbread()) { return ''; } } |
| |
|
| &devalidate($symb); |
if (!$domain) { $domain=$ENV{'user.domain'}; } |
| |
if (!$stuname) { $stuname=$ENV{'user.name'}; } |
| |
|
| |
&devalidate($symb,$stuname,$domain); |
| |
|
| $symb=escape($symb); |
$symb=escape($symb); |
| if (!$namespace) { |
if (!$namespace) { |
|
Line 1401 sub cstore {
|
Line 1517 sub cstore {
|
| return ''; |
return ''; |
| } |
} |
| } |
} |
| if (!$domain) { $domain=$ENV{'user.domain'}; } |
|
| if (!$stuname) { $stuname=$ENV{'user.name'}; } |
|
| if (!$home) { $home=$ENV{'user.home'}; } |
if (!$home) { $home=$ENV{'user.home'}; } |
| |
|
| my $namevalue=''; |
my $namevalue=''; |
|
Line 1460 sub coursedescription {
|
Line 1574 sub coursedescription {
|
| $courseid=~s/\_/\//g; |
$courseid=~s/\_/\//g; |
| my ($cdomain,$cnum)=split(/\//,$courseid); |
my ($cdomain,$cnum)=split(/\//,$courseid); |
| my $chome=&homeserver($cnum,$cdomain); |
my $chome=&homeserver($cnum,$cdomain); |
| |
my $normalid=$cdomain.'_'.$cnum; |
| |
# need to always cache even if we get errors otherwise we keep |
| |
# trying and trying and trying to get the course description. |
| |
my %envhash=(); |
| |
my %returnhash=(); |
| |
$envhash{'course.'.$normalid.'.last_cache'}=time; |
| if ($chome ne 'no_host') { |
if ($chome ne 'no_host') { |
| my %returnhash=&dump('environment',$cdomain,$cnum); |
%returnhash=&dump('environment',$cdomain,$cnum); |
| if (!exists($returnhash{'con_lost'})) { |
if (!exists($returnhash{'con_lost'})) { |
| my $normalid=$cdomain.'_'.$cnum; |
|
| my %envhash=(); |
|
| $returnhash{'home'}= $chome; |
$returnhash{'home'}= $chome; |
| $returnhash{'domain'} = $cdomain; |
$returnhash{'domain'} = $cdomain; |
| $returnhash{'num'} = $cnum; |
$returnhash{'num'} = $cnum; |
|
Line 1474 sub coursedescription {
|
Line 1592 sub coursedescription {
|
| $returnhash{'url'}=&clutter($returnhash{'url'}); |
$returnhash{'url'}=&clutter($returnhash{'url'}); |
| $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. |
$returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. |
| $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; |
$ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; |
| $envhash{'course.'.$normalid.'.last_cache'}=time; |
|
| $envhash{'course.'.$normalid.'.home'}=$chome; |
$envhash{'course.'.$normalid.'.home'}=$chome; |
| $envhash{'course.'.$normalid.'.domain'}=$cdomain; |
$envhash{'course.'.$normalid.'.domain'}=$cdomain; |
| $envhash{'course.'.$normalid.'.num'}=$cnum; |
$envhash{'course.'.$normalid.'.num'}=$cnum; |
| &appenv(%envhash); |
|
| return %returnhash; |
|
| } |
} |
| } |
} |
| return (); |
&appenv(%envhash); |
| |
return %returnhash; |
| } |
} |
| |
|
| # -------------------------------------------------------- Get user privileges |
# -------------------------------------------------------- Get user privileges |
|
Line 1649 sub dump {
|
Line 1765 sub dump {
|
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| |
# --------------------------------------------------------------- currentdump |
| |
sub currentdump { |
| |
my ($courseid,$sdom,$sname)=@_; |
| |
$courseid = $ENV{'request.course.id'} if (! defined($courseid)); |
| |
$sdom = $ENV{'user.domain'} if (! defined($sdom)); |
| |
$sname = $ENV{'user.name'} if (! defined($sname)); |
| |
my $uhome = &homeserver($sname,$sdom); |
| |
my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); |
| |
return if ($rep =~ /^(error:|no_such_host)/); |
| |
# |
| |
my %returnhash=(); |
| |
# |
| |
if ($rep eq "unknown_cmd") { |
| |
# an old lond will not know currentdump |
| |
# Do a dump and make it look like a currentdump |
| |
my @tmp = &dump($courseid,$sdom,$sname,'.'); |
| |
return if ($tmp[0] =~ /^(error:|no_such_host)/); |
| |
my %hash = @tmp; |
| |
@tmp=(); |
| |
# Code ripped from lond, essentially. The only difference |
| |
# here is the unescaping done by lonnet::dump(). Conceivably |
| |
# we might run in to problems with parameter names =~ /^v\./ |
| |
while (my ($key,$value) = each(%hash)) { |
| |
my ($v,$symb,$param) = split(/:/,$key); |
| |
next if ($v eq 'version' || $symb eq 'keys'); |
| |
next if (exists($returnhash{$symb}) && |
| |
exists($returnhash{$symb}->{$param}) && |
| |
$returnhash{$symb}->{'v.'.$param} > $v); |
| |
$returnhash{$symb}->{$param}=$value; |
| |
$returnhash{$symb}->{'v.'.$param}=$v; |
| |
} |
| |
# |
| |
# Remove all of the keys in the hashes which keep track of |
| |
# the version of the parameter. |
| |
while (my ($symb,$param_hash) = each(%returnhash)) { |
| |
# use a foreach because we are going to delete from the hash. |
| |
foreach my $key (keys(%$param_hash)) { |
| |
delete($param_hash->{$key}) if ($key =~ /^v\./); |
| |
} |
| |
} |
| |
} else { |
| |
my @pairs=split(/\&/,$rep); |
| |
foreach (@pairs) { |
| |
my ($key,$value)=split(/=/,$_); |
| |
my ($symb,$param) = split(/:/,$key); |
| |
$returnhash{&unescape($symb)}->{&unescape($param)} = |
| |
&unescape($value); |
| |
} |
| |
} |
| |
return %returnhash; |
| |
} |
| |
|
| # --------------------------------------------------------------- put interface |
# --------------------------------------------------------------- put interface |
| |
|
| sub put { |
sub put { |
|
Line 1720 sub allowed {
|
Line 1888 sub allowed {
|
| |
|
| if ($priv eq 'bre') { |
if ($priv eq 'bre') { |
| my $copyright=&metadata($uri,'copyright'); |
my $copyright=&metadata($uri,'copyright'); |
| if ($copyright eq 'public') { return 'F'; } |
if (($copyright eq 'public') && (!$ENV{'request.course.id'})) { |
| |
return 'F'; |
| |
} |
| if ($copyright eq 'priv') { |
if ($copyright eq 'priv') { |
| $uri=~/([^\/]+)\/([^\/]+)\//; |
$uri=~/([^\/]+)\/([^\/]+)\//; |
| unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) { |
unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) { |
|
Line 1774 sub allowed {
|
Line 1944 sub allowed {
|
| $thisallowed.=$1; |
$thisallowed.=$1; |
| } |
} |
| |
|
| |
# URI is an uploaded document for this course |
| |
|
| |
if (($priv eq 'bre') && |
| |
($uri=~/^uploaded\/$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}\/$ENV{'course.'.$ENV{'request.course.id'}.'.num'}/)) { |
| |
return '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 1993 sub is_on_map {
|
Line 2169 sub is_on_map {
|
| my $filename=$uriparts[$#uriparts]; |
my $filename=$uriparts[$#uriparts]; |
| my $pathname=$uri; |
my $pathname=$uri; |
| $pathname=~s|/\Q$filename\E$||; |
$pathname=~s|/\Q$filename\E$||; |
| |
$pathname=~s/^adm\/wrapper\///; |
| #Trying to find the conditional for the file |
#Trying to find the conditional for the file |
| my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ |
my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ |
| /\&\Q$filename\E\:([\d\|]+)\&/); |
/\&\Q$filename\E\:([\d\|]+)\&/); |
|
Line 2260 sub modifyuser {
|
Line 2437 sub modifyuser {
|
| } |
} |
| } |
} |
| # -------------------------------------------------------------- Add names, etc |
# -------------------------------------------------------------- Add names, etc |
| my %names=&get('environment', |
my @tmp=&get('environment', |
| ['firstname','middlename','lastname','generation'], |
['firstname','middlename','lastname','generation'], |
| $udom,$uname); |
$udom,$uname); |
| if ($names{'firstname'} =~ m/^error:.*/) { %names=(); } |
my %names; |
| |
if ($tmp[0] =~ m/^error:.*/) { |
| |
%names=(); |
| |
} else { |
| |
%names = @tmp; |
| |
} |
| if ($first) { $names{'firstname'} = $first; } |
if ($first) { $names{'firstname'} = $first; } |
| if ($middle) { $names{'middlename'} = $middle; } |
if ($middle) { $names{'middlename'} = $middle; } |
| if ($last) { $names{'lastname'} = $last; } |
if ($last) { $names{'lastname'} = $last; } |
|
Line 2291 sub modifystudent {
|
Line 2473 sub modifystudent {
|
| ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, |
($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, |
| $desiredhome); |
$desiredhome); |
| unless ($reply eq 'ok') { return $reply; } |
unless ($reply eq 'ok') { return $reply; } |
| |
# This will cause &modify_student_enrollment to get the uid from the |
| |
# students environment |
| |
$uid = undef if (!$forceid); |
| |
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle, |
| |
$last,$gene,$usec,$end,$start); |
| |
return $reply; |
| |
} |
| |
|
| |
sub modify_student_enrollment { |
| |
my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start) = @_; |
| |
# Get the course id from the environment |
| |
my $cid=''; |
| |
unless ($cid=$ENV{'request.course.id'}) { |
| |
return 'not_in_class'; |
| |
} |
| |
# Make sure the user exists |
| my $uhome=&homeserver($uname,$udom); |
my $uhome=&homeserver($uname,$udom); |
| if (($uhome eq '') || ($uhome eq 'no_host')) { |
if (($uhome eq '') || ($uhome eq 'no_host')) { |
| return 'error: no such user'; |
return 'error: no such user'; |
| } |
} |
| # -------------------------------------------------- Add student to course list |
# |
| $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'. |
# Get student data if we were not given enough information |
| |
if (!defined($first) || $first eq '' || |
| |
!defined($last) || $last eq '' || |
| |
!defined($uid) || $uid eq '' || |
| |
!defined($middle) || $middle eq '' || |
| |
!defined($gene) || $gene eq '') { |
| |
# They did not supply us with enough data to enroll the student, so |
| |
# we need to pick up more information. |
| |
my %tmp = &get('environment', |
| |
['firstname','middlename','lastname', 'generation','id'] |
| |
,$udom,$uname); |
| |
|
| |
foreach (keys(%tmp)) { |
| |
&logthis("key $_ = ".$tmp{$_}); |
| |
} |
| |
$first = $tmp{'firstname'} if (!defined($first) || $first eq ''); |
| |
$middle = $tmp{'middlename'} if (!defined($middle) || $middle eq ''); |
| |
$last = $tmp{'lastname'} if (!defined($last) || $last eq ''); |
| |
$gene = $tmp{'generation'} if (!defined($gene) || $gene eq ''); |
| |
$uid = $tmp{'id'} if (!defined($uid) || $uid eq ''); |
| |
} |
| |
my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene, |
| |
$first,$middle); |
| |
my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'. |
| $ENV{'course.'.$cid.'.num'}.':classlist:'. |
$ENV{'course.'.$cid.'.num'}.':classlist:'. |
| &escape($uname.':'.$udom).'='. |
&escape($uname.':'.$udom).'='. |
| &escape($end.':'.$start), |
&escape(join(':',$end,$start,$uid,$usec,$fullname)), |
| $ENV{'course.'.$cid.'.home'}); |
$ENV{'course.'.$cid.'.home'}); |
| unless (($reply eq 'ok') || ($reply eq 'delayed')) { |
unless (($reply eq 'ok') || ($reply eq 'delayed')) { |
| return 'error: '.$reply; |
return 'error: '.$reply; |
| } |
} |
| # ---------------------------------------------------- Add student role to user |
# Add student role to user |
| my $uurl='/'.$cid; |
my $uurl='/'.$cid; |
| $uurl=~s/\_/\//g; |
$uurl=~s/\_/\//g; |
| if ($usec) { |
if ($usec) { |
|
Line 2592 sub courseresdata {
|
Line 2813 sub courseresdata {
|
| if ($tmp !~ /^(con_lost|error|no_such_host)/i) { |
if ($tmp !~ /^(con_lost|error|no_such_host)/i) { |
| $courseresdatacache{$hashid.'.time'}=time; |
$courseresdatacache{$hashid.'.time'}=time; |
| $courseresdatacache{$hashid}=\%dumpreply; |
$courseresdatacache{$hashid}=\%dumpreply; |
| |
} elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
| |
return $tmp; |
| } |
} |
| } |
} |
| foreach my $item (@which) { |
foreach my $item (@which) { |
|
Line 2617 sub EXT {
|
Line 2840 sub EXT {
|
| } else { |
} else { |
| $courseid=$ENV{'request.course.id'}; |
$courseid=$ENV{'request.course.id'}; |
| } |
} |
| |
|
| my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); |
my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); |
| my $rest; |
my $rest; |
| if ($therest[0]) { |
if (defined($therest[0])) { |
| $rest=join('.',@therest); |
$rest=join('.',@therest); |
| } else { |
} else { |
| $rest=''; |
$rest=''; |
| } |
} |
| |
|
| my $qualifierrest=$qualifier; |
my $qualifierrest=$qualifier; |
| if ($rest) { $qualifierrest.='.'.$rest; } |
if ($rest) { $qualifierrest.='.'.$rest; } |
| my $spacequalifierrest=$space; |
my $spacequalifierrest=$space; |
|
Line 2718 sub EXT {
|
Line 2941 sub EXT {
|
| my $courselevelm=$courseid.'.'.$mapparm; |
my $courselevelm=$courseid.'.'.$mapparm; |
| |
|
| # ----------------------------------------------------------- first, check user |
# ----------------------------------------------------------- first, check user |
| my %resourcedata=&get('resourcedata', |
#most student don't have any data set, check if there is some data |
| [$courselevelr,$courselevelm,$courselevel], |
#every thirty minutes |
| $udom,$uname); |
if (! |
| if (($resourcedata{$courselevelr}!~/^error\:/) && |
(exists($ENV{'cache.studentresdata'}) |
| ($resourcedata{$courselevelr}!~/^con_lost/)) { |
&& (($ENV{'cache.studentresdata'}+1800) > time))) { |
| |
my %resourcedata=&get('resourcedata', |
| if ($resourcedata{$courselevelr}) { |
[$courselevelr,$courselevelm,$courselevel], |
| return $resourcedata{$courselevelr}; } |
$udom,$uname); |
| if ($resourcedata{$courselevelm}) { |
my ($tmp)=keys(%resourcedata); |
| return $resourcedata{$courselevelm}; } |
if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { |
| if ($resourcedata{$courselevel}) { |
if ($resourcedata{$courselevelr}) { |
| return $resourcedata{$courselevel}; } |
return $resourcedata{$courselevelr}; } |
| } else { |
if ($resourcedata{$courselevelm}) { |
| if ($resourcedata{$courselevelr}!~/No such file/) { |
return $resourcedata{$courselevelm}; } |
| &logthis("<font color=blue>WARNING:". |
if ($resourcedata{$courselevel}) { |
| " Trying to get resource data for ". |
return $resourcedata{$courselevel}; } |
| $uname." at ".$udom.": ". |
} else { |
| $resourcedata{$courselevelr}."</font>"); |
if ($tmp!~/No such file/) { |
| |
&logthis("<font color=blue>WARNING:". |
| |
" Trying to get resource data for ". |
| |
$uname." at ".$udom.": ". |
| |
$tmp."</font>"); |
| |
} elsif ($tmp=~/error:No such file/) { |
| |
$ENV{'cache.studentresdata'}=time; |
| |
&appenv(('cache.studentresdata'=> |
| |
$ENV{'cache.studentresdata'})); |
| |
} elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
| |
return $tmp; |
| |
} |
| } |
} |
| } |
} |
| |
|
|
Line 2814 sub metadata {
|
Line 3048 sub metadata {
|
| |
|
| $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|/$|) || |
if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) || |
| ($uri =~ m|/.meta$|)) { |
($uri =~ m|/$|) || ($uri =~ m|/.meta$|)) { |
| return ''; |
return ''; |
| } |
} |
| my $filename=$uri; |
my $filename=$uri; |
|
Line 2874 sub metadata {
|
Line 3108 sub metadata {
|
| my $unikey='parameter'.$keyroot.'_'.$name; |
my $unikey='parameter'.$keyroot.'_'.$name; |
| $metathesekeys{$unikey}=1; |
$metathesekeys{$unikey}=1; |
| $metacache{$uri.':'.$unikey.'.part'}=$part; |
$metacache{$uri.':'.$unikey.'.part'}=$part; |
| unless |
unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { |
| (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { |
$metacache{$uri.':'.$unikey.'.'.$subp}=$value; |
| $metacache{$uri.':'.$unikey.'.'.$subp}=$value; |
} |
| |
if (defined($metacache{$uri.':'.$unikey.'.default'})) { |
| |
$metacache{$uri.':'.$unikey}= |
| |
$metacache{$uri.':'.$unikey.'.default'} |
| } |
} |
| } |
} |
| } |
} |
|
Line 2926 sub metadata {
|
Line 3163 sub metadata {
|
| foreach (@{$token->[3]}) { |
foreach (@{$token->[3]}) { |
| $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; |
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; |
| } |
} |
| unless ( |
my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); |
| $metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry)) |
my $default=$metacache{$uri.':'.$unikey.'.default'}; |
| ) { $metacache{$uri.':'.$unikey}= |
if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { |
| $metacache{$uri.':'.$unikey.'.default'}; |
# only ws inside the tag, and not in default, so use default |
| } |
# as value |
| |
$metacache{$uri.':'.$unikey}=$default; |
| |
} else { |
| |
# either something interesting inside the tag or default |
| |
# uninteresting |
| |
$metacache{$uri.':'.$unikey}=$internaltext; |
| |
} |
| # end of not-a-package not-a-library import |
# end of not-a-package not-a-library import |
| } |
} |
| # end of not-a-package start tag |
# end of not-a-package start tag |
|
Line 2975 sub metadata_generate_part0 {
|
Line 3218 sub metadata_generate_part0 {
|
| } |
} |
| } |
} |
| |
|
| |
# ------------------------------------------------- Get the title of a resource |
| |
|
| |
sub gettitle { |
| |
my $urlsymb=shift; |
| |
my $symb=&symbread($urlsymb); |
| |
unless ($symb) { |
| |
unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; } |
| |
return &metadata($urlsymb,'title'); |
| |
} |
| |
if ($titlecache{$symb}) { return $titlecache{$symb}; } |
| |
my ($map,$resid,$url)=split(/\_\_\_/,$symb); |
| |
my $title=''; |
| |
my %bighash; |
| |
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
| |
&GDBM_READER(),0640)) { |
| |
my $mapid=$bighash{'map_pc_'.&clutter($map)}; |
| |
$title=$bighash{'title_'.$mapid.'.'.$resid}; |
| |
untie %bighash; |
| |
} |
| |
if ($title) { |
| |
$titlecache{$symb}=$title; |
| |
return $title; |
| |
} else { |
| |
return &metadata($urlsymb,'title'); |
| |
} |
| |
} |
| |
|
| # ------------------------------------------------- Update symbolic store links |
# ------------------------------------------------- Update symbolic store links |
| |
|
| sub symblist { |
sub symblist { |
|
Line 3316 BEGIN {
|
Line 3586 BEGIN {
|
| } |
} |
| } |
} |
| |
|
| |
# ------------------------------------------------------------ Read domain file |
| |
{ |
| |
my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. |
| |
'/domain.tab'); |
| |
%domaindescription = (); |
| |
%domain_auth_def = (); |
| |
%domain_auth_arg_def = (); |
| |
if ($fh) { |
| |
while (<$fh>) { |
| |
next if /^\#/; |
| |
chomp; |
| |
my ($domain, $domain_description, $def_auth, $def_auth_arg) |
| |
= split(/:/,$_,4); |
| |
$domain_auth_def{$domain}=$def_auth; |
| |
$domain_auth_arg_def{$domain}=$def_auth_arg; |
| |
$domaindescription{$domain}=$domain_description; |
| |
# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); |
| |
# &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); |
| |
} |
| |
} |
| |
} |
| |
|
| |
|
| # ------------------------------------------------------------- Read hosts file |
# ------------------------------------------------------------- Read hosts file |
| { |
{ |
| my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab"); |
my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab"); |
| |
|
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
| |
next if ($configline =~ /^(\#|\s*$)/); |
| chomp($configline); |
chomp($configline); |
| my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline); |
my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline); |
| if ($id && $domain && $role && $name && $ip) { |
if ($id && $domain && $role && $name && $ip) { |
| $hostname{$id}=$name; |
$hostname{$id}=$name; |
| $hostdom{$id}=$domain; |
$hostdom{$id}=$domain; |
| $hostip{$id}=$ip; |
$hostip{$id}=$ip; |
| if ($domdescr) { $domaindescription{$domain}=$domdescr; } |
$iphost{$ip}=$id; |
| if ($role eq 'library') { $libserv{$id}=$name; } |
if ($role eq 'library') { $libserv{$id}=$name; } |
| } else { |
} else { |
| if ($configline) { |
if ($configline) { |
|
Line 3389 BEGIN {
|
Line 3683 BEGIN {
|
| } |
} |
| } |
} |
| |
|
| |
# ------------- set up temporary directory |
| |
{ |
| |
$tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; |
| |
|
| |
} |
| |
|
| %metacache=(); |
%metacache=(); |
| |
|
| $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
|
Line 3614 The course id is resolved based on the c
|
Line 3914 The course id is resolved based on the c
|
| This means the envoking user must be a course coordinator or otherwise |
This means the envoking user must be a course coordinator or otherwise |
| associated with a course. |
associated with a course. |
| |
|
| This call is essentially a wrapper for lonnet::modifyuser |
This call is essentially a wrapper for lonnet::modifyuser and |
| |
lonnet::modify_student_enrollment |
| |
|
| Inputs: |
Inputs: |
| |
|
|
Line 3652 Inputs:
|
Line 3953 Inputs:
|
| |
|
| =item * |
=item * |
| |
|
| |
modify_student_enrollment |
| |
|
| |
Change a students enrollment status in a class. The environment variable |
| |
'role.request.course' must be defined for this function to proceed. |
| |
|
| |
Inputs: |
| |
|
| |
=over 4 |
| |
|
| |
=item $udom, students domain |
| |
|
| |
=item $uname, students name |
| |
|
| |
=item $uid, students user id |
| |
|
| |
=item $first, students first name |
| |
|
| |
=item $middle |
| |
|
| |
=item $last |
| |
|
| |
=item $gene |
| |
|
| |
=item $usec |
| |
|
| |
=item $end |
| |
|
| |
=item $start |
| |
|
| |
=back |
| |
|
| |
|
| |
=item * |
| |
|
| assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign |
assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign |
| custom role; give a custom role to a user for the level given by URL. Specify |
custom role; give a custom role to a user for the level given by URL. Specify |
| name and domain of role author, and role name |
name and domain of role author, and role name |
![[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