|
version 1.292, 2002/10/07 13:50:36
|
version 1.345, 2003/03/22 21:23:35
|
|
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 589 sub idput {
|
Line 588 sub idput {
|
| } |
} |
| } |
} |
| |
|
| |
# --------------------------------------------------- Assign a key to a student |
| |
|
| |
sub assign_access_key { |
| |
my ($ckey,$cdom,$cnum,$udom,$uname)=@_; |
| |
$cdom= |
| |
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); |
| |
$cnum= |
| |
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); |
| |
$udom=$ENV{'user.name'} unless (defined($udom)); |
| |
$uname=$ENV{'user.domain'} unless (defined($uname)); |
| |
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); |
| |
if (($existing{$ckey}=~/^\d+$/) || # has time - new key |
| |
($existing{$ckey} eq $udom.':'.$uname)) { # this should not happen, |
| |
# unless something went wrong |
| |
# the first time around |
| |
# ready to assign |
| |
} elsif (!$existing{$ckey}) { |
| |
if (&put('accesskey',{$ckey=>$udom.':'.$uname},$cdom,$cnum) eq 'ok') { |
| |
# key now belongs to user |
| |
my $envkey='key.'.$cdom.'.'.$cnum; |
| |
if (&put('environment',{$envkey => $ckey}) eq 'ok') { |
| |
&appenv('environment.'.$envkey => $ckey); |
| |
return 'ok'; |
| |
} else { |
| |
return |
| |
'error: Count not permanently assign key, will need to be re-entered later.'; |
| |
} |
| |
} else { |
| |
return 'error: Could not assign key, try again later.'; |
| |
} |
| |
# the key does not exist |
| |
return 'error: The key does not exist'; |
| |
} else { |
| |
# the key is somebody else's |
| |
return 'error: The key is already in use'; |
| |
} |
| |
} |
| |
|
| |
# ------------------------------------------------------ Generate a set of keys |
| |
|
| |
sub generate_access_keys { |
| |
my ($number,$cdom,$cnum)=@_; |
| |
$cdom= |
| |
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); |
| |
$cnum= |
| |
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); |
| |
unless (&allowed('ccc',$cdom)) { return 0; } |
| |
unless (($cdom) && ($cnum)) { return 0; } |
| |
if ($number>10000) { return 0; } |
| |
sleep(2); # make sure don't get same seed twice |
| |
srand(time()^($$+($$<<15))); # from "Programming Perl" |
| |
my $total=0; |
| |
for (my $i=1;$i<=$number;$i++) { |
| |
my $newkey=sprintf("%lx",int(100000*rand)).'-'. |
| |
sprintf("%lx",int(100000*rand)).'-'. |
| |
sprintf("%lx",int(100000*rand)); |
| |
$newkey=~s/1/g/g; # folks mix up 1 and l |
| |
$newkey=~s/0/h/g; # and also 0 and O |
| |
my %existing=&get('accesskeys',[$newkey],$cdom,$cnum); |
| |
if ($existing{$newkey}) { |
| |
$i--; |
| |
} else { |
| |
if (&put('accesskeys',{ $newkey => time() },$cdom,$cnum) eq 'ok') { |
| |
$total++; |
| |
} |
| |
} |
| |
} |
| |
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, |
| |
'Generated '.$total.' keys for '.$cnum.' at '.$cdom); |
| |
return $total; |
| |
} |
| |
|
| |
# ------------------------------------------------------- Validate an accesskey |
| |
|
| |
sub validate_access_key { |
| |
my ($ckey,$cdom,$cnum,$udom,$uname)=@_; |
| |
$cdom= |
| |
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); |
| |
$cnum= |
| |
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); |
| |
$udom=$ENV{'user.name'} unless (defined($udom)); |
| |
$uname=$ENV{'user.domain'} unless (defined($uname)); |
| |
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); |
| |
return ($existing{$ckey} eq $udom.':'.$uname); |
| |
} |
| |
|
| # ------------------------------------- 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 672 sub currentversion {
|
Line 810 sub currentversion {
|
| |
|
| 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); |
| my $home=homeserver($uname,$udom); |
my $home=homeserver($uname,$udom); |
| if ($home eq 'no_host') { |
if ($home eq 'no_host') { |
| return 'not_found'; |
return 'not_found'; |
| } |
} |
| my $answer=reply("sub:$fname",$home); |
my $answer=reply("sub:$fname",$home); |
| if (($answer eq 'con_lost') || ($answer eq 'rejected')) { |
if (($answer eq 'con_lost') || ($answer eq 'rejected')) { |
|
Line 751 sub repcopy {
|
Line 890 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 774 sub ssi {
|
Line 925 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 785 sub tokenwrapper {
|
Line 944 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 798 sub tokenwrapper {
|
Line 958 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 838 sub finishuserfileupload {
|
Line 1005 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 1040 sub expirespread {
|
Line 1210 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 1054 sub devalidate {
|
Line 1228 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 1386 sub store {
|
Line 1560 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 1394 sub store {
|
Line 1571 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 1417 sub cstore {
|
Line 1592 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 1425 sub cstore {
|
Line 1603 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 1484 sub coursedescription {
|
Line 1660 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 1498 sub coursedescription {
|
Line 1678 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 1673 sub dump {
|
Line 1851 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 1726 sub eget {
|
Line 1956 sub eget {
|
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| |
# ---------------------------------------------- Custom access rule evaluation |
| |
|
| |
sub customaccess { |
| |
my ($priv,$uri)=@_; |
| |
my ($urole,$urealm)=split(/\./,$ENV{'request.role'}); |
| |
$urealm=~s/^\W//; |
| |
my ($udom,$ucrs,$usec)=split(/\//,$urealm); |
| |
my $access=0; |
| |
foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { |
| |
my ($effect,$realm,$role)=split(/\:/,$_); |
| |
if ($role) { |
| |
if ($role ne $urole) { next; } |
| |
} |
| |
foreach (split(/\s*\,\s*/,$realm)) { |
| |
my ($tdom,$tcrs,$tsec)=split(/\_/,$_); |
| |
if ($tdom) { |
| |
if ($tdom ne $udom) { next; } |
| |
} |
| |
if ($tcrs) { |
| |
if ($tcrs ne $ucrs) { next; } |
| |
} |
| |
if ($tsec) { |
| |
if ($tsec ne $usec) { next; } |
| |
} |
| |
$access=($effect eq 'allow'); |
| |
last; |
| |
} |
| |
} |
| |
return $access; |
| |
} |
| |
|
| # ------------------------------------------------- Check for a user privilege |
# ------------------------------------------------- Check for a user privilege |
| |
|
| sub allowed { |
sub allowed { |
|
Line 1744 sub allowed {
|
Line 2005 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 1762 sub allowed {
|
Line 2025 sub allowed {
|
| # Library role, so allow browsing of resources in this domain. |
# Library role, so allow browsing of resources in this domain. |
| return 'F'; |
return 'F'; |
| } |
} |
| |
if ($copyright eq 'custom') { |
| |
unless (&customaccess($priv,$uri)) { return ''; } |
| |
} |
| } |
} |
| # Domain coordinator is trying to create a course |
# Domain coordinator is trying to create a course |
| if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) { |
if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) { |
|
Line 1798 sub allowed {
|
Line 2064 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 1973 sub allowed {
|
Line 2245 sub allowed {
|
| |
|
| if ($thisallowed=~/R/) { |
if ($thisallowed=~/R/) { |
| my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; |
my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; |
| my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta'; |
if (&metadata($uri,'roledeny')=~/$rolecode/) { |
| if (-e $filename) { |
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, |
| my @content; |
|
| { |
|
| my $fh=Apache::File->new($filename); |
|
| @content=<$fh>; |
|
| } |
|
| if (join('',@content)=~ |
|
| /\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) { |
|
| &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 2017 sub is_on_map {
|
Line 2279 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 2284 sub modifyuser {
|
Line 2547 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 2315 sub modifystudent {
|
Line 2583 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 2616 sub courseresdata {
|
Line 2923 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 2632 sub EXT {
|
Line 2941 sub EXT {
|
| my ($varname,$symbparm,$udom,$uname,)=@_; |
my ($varname,$symbparm,$udom,$uname,)=@_; |
| |
|
| unless ($varname) { return ''; } |
unless ($varname) { return ''; } |
| |
|
| #get real user name/domain, courseid and symb |
#get real user name/domain, courseid and symb |
| my $courseid; |
my $courseid; |
| if (!($uname && $udom)) { |
if (!($uname && $udom)) { |
|
Line 2641 sub EXT {
|
Line 2949 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 2656 sub EXT {
|
Line 2964 sub EXT {
|
| if ($realm eq 'user') { |
if ($realm eq 'user') { |
| # --------------------------------------------------------------- user.resource |
# --------------------------------------------------------------- user.resource |
| if ($space eq 'resource') { |
if ($space eq 'resource') { |
| my %restored=&restore(undef,undef,$udom,$uname); |
if (defined($Apache::lonhomework::parsing_a_problem)) { |
| return $restored{$qualifierrest}; |
return $Apache::lonhomework::history{$qualifierrest}; |
| |
} else { |
| |
my %restored=&restore($symbparm,$courseid,$udom,$uname); |
| |
return $restored{$qualifierrest}; |
| |
} |
| # ----------------------------------------------------------------- user.access |
# ----------------------------------------------------------------- user.access |
| } elsif ($space eq 'access') { |
} elsif ($space eq 'access') { |
| # FIXME - not supporting calls for a specific user |
# FIXME - not supporting calls for a specific user |
|
Line 2692 sub EXT {
|
Line 3004 sub EXT {
|
| return $uname; |
return $uname; |
| # ---------------------------------------------------- Any other user namespace |
# ---------------------------------------------------- Any other user namespace |
| } else { |
} else { |
| my $item=($rest)?$qualifier.'.'.$rest:$qualifier; |
my %reply=&get($space,[$qualifierrest],$udom,$uname); |
| my %reply=&get($space,[$item]); |
return $reply{$qualifierrest}; |
| return $reply{$item}; |
|
| } |
} |
| } elsif ($realm eq 'query') { |
} elsif ($realm eq 'query') { |
| # ---------------------------------------------- pull stuff out of query string |
# ---------------------------------------------- pull stuff out of query string |
|
Line 2742 sub EXT {
|
Line 3053 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 2800 sub EXT {
|
Line 3122 sub EXT {
|
| |
|
| # ------------------------------------------------------------------ Cascade up |
# ------------------------------------------------------------------ Cascade up |
| unless ($space eq '0') { |
unless ($space eq '0') { |
| my ($part,$id)=split(/\_/,$space); |
my @parts=split(/_/,$space); |
| if ($id) { |
my $id=pop(@parts); |
| my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, |
my $part=join('_',@parts); |
| $symbparm,$udom,$uname); |
if ($part eq '') { $part='0'; } |
| if (defined($partgeneral)) { return $partgeneral; } |
my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, |
| } else { |
$symbparm,$udom,$uname); |
| my $resourcegeneral=&EXT('resource.0.'.$qualifierrest, |
if (defined($partgeneral)) { return $partgeneral; } |
| $symbparm,$udom,$uname); |
|
| if (defined($resourcegeneral)) { return $resourcegeneral; } |
|
| } |
|
| } |
} |
| |
|
| # ---------------------------------------------------- Any other user namespace |
# ---------------------------------------------------- Any other user namespace |
|
Line 2831 sub EXT {
|
Line 3150 sub EXT {
|
| return ''; |
return ''; |
| } |
} |
| |
|
| |
sub add_prefix_and_part { |
| |
my ($prefix,$part)=@_; |
| |
my $keyroot; |
| |
if (defined($prefix) && $prefix !~ /^__/) { |
| |
# prefix that has a part already |
| |
$keyroot=$prefix; |
| |
} elsif (defined($prefix)) { |
| |
# prefix that is missing a part |
| |
if (defined($part)) { $keyroot='_'.$part.substr($prefix,1); } |
| |
} else { |
| |
# no prefix at all |
| |
if (defined($part)) { $keyroot='_'.$part; } |
| |
} |
| |
return $keyroot; |
| |
} |
| |
|
| # ---------------------------------------------------------------- Get metadata |
# ---------------------------------------------------------------- Get metadata |
| |
|
| sub metadata { |
sub metadata { |
|
Line 2838 sub metadata {
|
Line 3173 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 2859 sub metadata {
|
Line 3194 sub metadata {
|
| } |
} |
| my %metathesekeys=(); |
my %metathesekeys=(); |
| unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
| my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename); |
my $metastring=&getfile(&filelocation('',&clutter($filename))); |
| my $parser=HTML::LCParser->new(\$metastring); |
my $parser=HTML::LCParser->new(\$metastring); |
| my $token; |
my $token; |
| undef %metathesekeys; |
undef %metathesekeys; |
| while ($token=$parser->get_token) { |
while ($token=$parser->get_token) { |
| if ($token->[0] eq 'S') { |
if ($token->[0] eq 'S') { |
| if (defined($token->[2]->{'package'})) { |
if (defined($token->[2]->{'package'})) { |
| # |
# |
| # This is a package - get package info |
# This is a package - get package info |
| # |
# |
| my $package=$token->[2]->{'package'}; |
my $package=$token->[2]->{'package'}; |
| my $keyroot=''; |
my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
| if ($prefix) { |
if (defined($token->[2]->{'id'})) { |
| $keyroot.=$prefix; |
$keyroot.='_'.$token->[2]->{'id'}; |
| } else { |
} |
| if (defined($token->[2]->{'part'})) { |
if ($metacache{$uri.':packages'}) { |
| $keyroot.='_'.$token->[2]->{'part'}; |
$metacache{$uri.':packages'}.=','.$package.$keyroot; |
| } |
} else { |
| } |
$metacache{$uri.':packages'}=$package.$keyroot; |
| if (defined($token->[2]->{'id'})) { |
} |
| $keyroot.='_'.$token->[2]->{'id'}; |
foreach (keys %packagetab) { |
| } |
if ($_=~/^$package\&/) { |
| if ($metacache{$uri.':packages'}) { |
my ($pack,$name,$subp)=split(/\&/,$_); |
| $metacache{$uri.':packages'}.=','.$package.$keyroot; |
my $value=$packagetab{$_}; |
| } else { |
my $part=$keyroot; |
| $metacache{$uri.':packages'}=$package.$keyroot; |
$part=~s/^\_//; |
| } |
if ($subp eq 'display') { |
| foreach (keys %packagetab) { |
$value.=' [Part: '.$part.']'; |
| if ($_=~/^$package\&/) { |
} |
| my ($pack,$name,$subp)=split(/\&/,$_); |
my $unikey='parameter'.$keyroot.'_'.$name; |
| my $value=$packagetab{$_}; |
if ($subp eq 'default') { $unikey='parameter_0_'.$name; } |
| my $part=$keyroot; |
$metathesekeys{$unikey}=1; |
| $part=~s/^\_//; |
$metacache{$uri.':'.$unikey.'.part'}=$part; |
| if ($subp eq 'display') { |
unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { |
| $value.=' [Part: '.$part.']'; |
$metacache{$uri.':'.$unikey.'.'.$subp}=$value; |
| } |
} |
| my $unikey='parameter'.$keyroot.'_'.$name; |
if (defined($metacache{$uri.':'.$unikey.'.default'})) { |
| $metathesekeys{$unikey}=1; |
$metacache{$uri.':'.$unikey}= |
| $metacache{$uri.':'.$unikey.'.part'}=$part; |
$metacache{$uri.':'.$unikey.'.default'} |
| unless |
} |
| (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { |
} |
| $metacache{$uri.':'.$unikey.'.'.$subp}=$value; |
} |
| } |
} else { |
| } |
|
| } |
|
| } else { |
|
| # |
# |
| # This is not a package - some other kind of start tag |
# This is not a package - some other kind of start tag |
| # |
# |
| my $entry=$token->[1]; |
my $entry=$token->[1]; |
| my $unikey; |
my $unikey; |
| if ($entry eq 'import') { |
if ($entry eq 'import') { |
| $unikey=''; |
$unikey=''; |
| } else { |
} else { |
| $unikey=$entry; |
$unikey=$entry; |
| } |
} |
| if ($prefix) { |
$unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
| $unikey.=$prefix; |
|
| } else { |
if (defined($token->[2]->{'id'})) { |
| if (defined($token->[2]->{'part'})) { |
$unikey.='_'.$token->[2]->{'id'}; |
| $unikey.='_'.$token->[2]->{'part'}; |
} |
| } |
|
| } |
|
| if (defined($token->[2]->{'id'})) { |
|
| $unikey.='_'.$token->[2]->{'id'}; |
|
| } |
|
| |
|
| if ($entry eq 'import') { |
if ($entry eq 'import') { |
| # |
# |
| # Importing a library here |
# Importing a library here |
| # |
# |
| if ($depthcount<20) { |
if ($depthcount<20) { |
| my $location=$parser->get_text('/import'); |
my $location=$parser->get_text('/import'); |
| my $dir=$filename; |
my $dir=$filename; |
| $dir=~s|[^/]*$||; |
$dir=~s|[^/]*$||; |
| $location=&filelocation($dir,$location); |
$location=&filelocation($dir,$location); |
| foreach (sort(split(/\,/,&metadata($uri,'keys', |
foreach (sort(split(/\,/,&metadata($uri,'keys', |
| $location,$unikey, |
$location,$unikey, |
| $depthcount+1)))) { |
$depthcount+1)))) { |
| $metathesekeys{$_}=1; |
$metathesekeys{$_}=1; |
| } |
} |
| } |
} |
| } else { |
} else { |
| |
|
| if (defined($token->[2]->{'name'})) { |
if (defined($token->[2]->{'name'})) { |
| $unikey.='_'.$token->[2]->{'name'}; |
$unikey.='_'.$token->[2]->{'name'}; |
| } |
} |
| $metathesekeys{$unikey}=1; |
$metathesekeys{$unikey}=1; |
| 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 |
| } |
} |
| # the next is the end of "start tag" |
# the next is the end of "start tag" |
| } |
} |
| } |
} |
| $metacache{$uri.':keys'}=join(',',keys %metathesekeys); |
# are there custom rights to evaluate |
| |
if ($metacache{$uri.':copyright'} eq 'custom') { |
| |
|
| |
# |
| |
# Importing a rights file here |
| |
# |
| |
unless ($depthcount) { |
| |
my $location=$metacache{$uri.':customdistributionfile'}; |
| |
my $dir=$filename; |
| |
$dir=~s|[^/]*$||; |
| |
$location=&filelocation($dir,$location); |
| |
foreach (sort(split(/\,/,&metadata($uri,'keys', |
| |
$location,'_rights', |
| |
$depthcount+1)))) { |
| |
$metathesekeys{$_}=1; |
| |
} |
| |
} |
| |
} |
| |
$metacache{$uri.':keys'}=join(',',keys %metathesekeys); |
| &metadata_generate_part0(\%metathesekeys,\%metacache,$uri); |
&metadata_generate_part0(\%metathesekeys,\%metacache,$uri); |
| $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys); |
$metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys); |
| $metacache{$uri.':cachedtimestamp'}=time; |
$metacache{$uri.':cachedtimestamp'}=time; |
| # this is the end of "was not already recently cached |
# this is the end of "was not already recently cached |
| } |
} |
| return $metacache{$uri.':'.$what}; |
return $metacache{$uri.':'.$what}; |
|
Line 2999 sub metadata_generate_part0 {
|
Line 3350 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 3340 BEGIN {
|
Line 3718 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 3413 BEGIN {
|
Line 3815 BEGIN {
|
| } |
} |
| } |
} |
| |
|
| |
# ------------- set up temporary directory |
| |
{ |
| |
$tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; |
| |
|
| |
} |
| |
|
| %metacache=(); |
%metacache=(); |
| |
|
| $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
|
Line 3638 The course id is resolved based on the c
|
Line 4046 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 3676 Inputs:
|
Line 4085 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