version 1.289, 2002/10/01 19:09:27
|
version 1.304, 2002/12/04 15:23:39
|
Line 77 use Apache::File;
|
Line 77 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); |
use IO::Socket; |
use IO::Socket; |
Line 86 use GDBM_File;
|
Line 86 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 591 sub idput {
|
Line 593 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 699 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 { |
Line 652 sub subscribe {
|
Line 731 sub subscribe {
|
$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); |
my $home=homeserver($uname,$udom); |
my $home=homeserver($uname,$udom); |
if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) { |
if ($home eq 'no_host') { |
return 'not_found'; |
return 'not_found'; |
} |
} |
my $answer=reply("sub:$fname",$home); |
my $answer=reply("sub:$fname",$home); |
Line 683 sub repcopy {
|
Line 762 sub repcopy {
|
} elsif ($remoteurl eq 'directory') { |
} elsif ($remoteurl eq 'directory') { |
return OK; |
return OK; |
} else { |
} else { |
|
my $author=$filename; |
|
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
|
my ($udom,$uname)=split(/\//,$author); |
|
my $home=homeserver($uname,$udom); |
|
unless ($home eq $perlvar{'lonHostID'}) { |
my @parts=split(/\//,$filename); |
my @parts=split(/\//,$filename); |
my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; |
my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; |
if ($path ne "$perlvar{'lonDocRoot'}/res") { |
if ($path ne "$perlvar{'lonDocRoot'}/res") { |
Line 718 sub repcopy {
|
Line 802 sub repcopy {
|
rename($transname,$filename); |
rename($transname,$filename); |
return OK; |
return OK; |
} |
} |
|
} |
} |
} |
} |
} |
|
|
Line 755 sub tokenwrapper {
|
Line 840 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 808 sub finishuserfileupload {
|
Line 894 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 1015 sub devalidate {
|
Line 1104 sub devalidate {
|
if ($cid) { |
if ($cid) { |
my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':'; |
my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':'; |
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 1454 sub coursedescription {
|
Line 1543 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 1468 sub coursedescription {
|
Line 1561 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 1714 sub allowed {
|
Line 1805 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 2285 sub modifystudent {
|
Line 2378 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 2593 sub courseresdata {
|
Line 2725 sub courseresdata {
|
return $courseresdatacache{$hashid}->{$item}; |
return $courseresdatacache{$hashid}->{$item}; |
} |
} |
} |
} |
return ''; |
return undef; |
} |
} |
|
|
# --------------------------------------------------------- Value of a Variable |
# --------------------------------------------------------- Value of a Variable |
Line 2808 sub metadata {
|
Line 2940 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 2969 sub metadata_generate_part0 {
|
Line 3101 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 3315 BEGIN {
|
Line 3474 BEGIN {
|
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; |
|
$iphost{$ip}=$id; |
if ($domdescr) { $domaindescription{$domain}=$domdescr; } |
if ($domdescr) { $domaindescription{$domain}=$domdescr; } |
if ($role eq 'library') { $libserv{$id}=$name; } |
if ($role eq 'library') { $libserv{$id}=$name; } |
} else { |
} else { |
Line 3608 The course id is resolved based on the c
|
Line 3769 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 3646 Inputs:
|
Line 3808 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 |