version 1.651.2.5, 2005/09/26 22:16:58
|
version 1.665, 2005/10/18 21:27:46
|
Line 37 use HTTP::Date;
|
Line 37 use HTTP::Date;
|
use vars |
use vars |
qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom |
qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom |
%libserv %pr %prp $memcache %packagetab |
%libserv %pr %prp $memcache %packagetab |
%courselogs %accesshash %userrolehash $processmarker $dumpcount |
%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount |
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf |
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf |
%domaindescription %domain_auth_def %domain_auth_arg_def |
%domaindescription %domain_auth_def %domain_auth_arg_def |
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit |
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit |
Line 767 sub validate_access_key {
|
Line 767 sub validate_access_key {
|
} |
} |
|
|
# ------------------------------------- Find the section of student in a course |
# ------------------------------------- Find the section of student in a course |
|
sub devalidate_getsection_cache { |
|
my ($udom,$unam,$courseid)=@_; |
|
$courseid=~s/\_/\//g; |
|
$courseid=~s/^(\w)/\/$1/; |
|
my $hashid="$udom:$unam:$courseid"; |
|
&devalidate_cache_new('getsection',$hashid); |
|
} |
|
|
sub getsection { |
sub getsection { |
my ($udom,$unam,$courseid)=@_; |
my ($udom,$unam,$courseid)=@_; |
Line 1603 sub flushcourselogs {
|
Line 1610 sub flushcourselogs {
|
delete $userrolehash{$entry}; |
delete $userrolehash{$entry}; |
} |
} |
} |
} |
|
# |
|
# Reverse lookup of domain roles (dc, ad, li, sc, au) |
|
# |
|
my %domrolebuffer = (); |
|
foreach my $entry (keys %domainrolehash) { |
|
my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry; |
|
if ($domrolebuffer{$rudom}) { |
|
$domrolebuffer{$rudom}.='&'.&escape($entry). |
|
'='.&escape($domainrolehash{$entry}); |
|
} else { |
|
$domrolebuffer{$rudom}.=&escape($entry). |
|
'='.&escape($domainrolehash{$entry}); |
|
} |
|
delete $domainrolehash{$entry}; |
|
} |
|
foreach my $dom (keys(%domrolebuffer)) { |
|
foreach my $tryserver (keys %libserv) { |
|
if ($hostdom{$tryserver} eq $dom) { |
|
unless (&reply('domroleput:'.$dom.':'. |
|
$domrolebuffer{$dom},$tryserver) eq 'ok') { |
|
&logthis('Put of domain roles failed for '.$dom.' and '.$tryserver); |
|
} |
|
} |
|
} |
|
} |
$dumpcount++; |
$dumpcount++; |
} |
} |
|
|
Line 1678 sub linklog {
|
Line 1710 sub linklog {
|
|
|
sub userrolelog { |
sub userrolelog { |
my ($trole,$username,$domain,$area,$tstart,$tend)=@_; |
my ($trole,$username,$domain,$area,$tstart,$tend)=@_; |
if (($trole=~/^ca/) || ($trole=~/^in/) || |
if (($trole=~/^ca/) || ($trole=~/^aa/) || |
($trole=~/^cc/) || ($trole=~/^ep/) || |
($trole=~/^in/) || ($trole=~/^cc/) || |
($trole=~/^cr/) || ($trole=~/^ta/)) { |
($trole=~/^ep/) || ($trole=~/^cr/) || |
|
($trole=~/^ta/)) { |
my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
$userrolehash |
$userrolehash |
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
=$tend.':'.$tstart; |
=$tend.':'.$tstart; |
} |
} |
|
if (($trole=~/^dc/) || ($trole=~/^ad/) || |
|
($trole=~/^li/) || ($trole=~/^li/) || |
|
($trole=~/^au/) || ($trole=~/^dg/) || |
|
($trole=~/^sc/)) { |
|
my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
|
$domainrolehash |
|
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
|
= $tend.':'.$tstart; |
|
} |
} |
} |
|
|
sub get_course_adv_roles { |
sub get_course_adv_roles { |
Line 1804 sub courseiddump {
|
Line 1846 sub courseiddump {
|
return %returnhash; |
return %returnhash; |
} |
} |
|
|
# |
# ---------------------------------------------------------- DC e-mail |
|
|
|
sub dcmailput { |
|
my ($domain,$msgid,$contents,$server)=@_; |
|
my $status = &Apache::lonnet::critical( |
|
'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='. |
|
&Apache::lonnet::escape($$contents{$server}),$server); |
|
return $status; |
|
} |
|
|
|
sub dcmaildump { |
|
my ($dom,$startdate,$enddate,$senders) = @_; |
|
my %returnhash=(); |
|
foreach my $tryserver (keys(%libserv)) { |
|
if ($hostdom{$tryserver} eq $dom) { |
|
%{$returnhash{$tryserver}}=(); |
|
my $cmd='dcmaildump:'.$dom.':'. |
|
&escape($startdate).':'.&escape($enddate).':'; |
|
my @esc_senders=map { &escape($_)} @$senders; |
|
$cmd.=&escape(join('&',@esc_senders)); |
|
foreach (split(/\&/,&reply($cmd,$tryserver))) { |
|
my ($key,$value) = split(/\=/,$_); |
|
if (($key) && ($value)) { |
|
$returnhash{$tryserver}{&unescape($key)} = &unescape($value); |
|
} |
|
} |
|
} |
|
} |
|
return %returnhash; |
|
} |
|
# ---------------------------------------------------------- Domain roles |
|
|
|
sub get_domain_roles { |
|
my ($dom,$roles,$startdate,$enddate)=@_; |
|
if (undef($startdate) || $startdate eq '') { |
|
$startdate = '.'; |
|
} |
|
if (undef($enddate) || $enddate eq '') { |
|
$enddate = '.'; |
|
} |
|
my $rolelist = join(':',@{$roles}); |
|
my %personnel = (); |
|
foreach my $tryserver (keys(%libserv)) { |
|
if ($hostdom{$tryserver} eq $dom) { |
|
%{$personnel{$tryserver}}=(); |
|
foreach ( |
|
split(/\&/,&reply('domrolesdump:'.$dom.':'. |
|
&escape($startdate).':'.&escape($enddate).':'. |
|
&escape($rolelist), $tryserver))) { |
|
my($key,$value) = split(/\=/,$_); |
|
if (($key) && ($value)) { |
|
$personnel{$tryserver}{&unescape($key)} = &unescape($value); |
|
} |
|
} |
|
} |
|
} |
|
return %personnel; |
|
} |
|
|
# ----------------------------------------------------------- Check out an item |
# ----------------------------------------------------------- Check out an item |
|
|
sub get_first_access { |
sub get_first_access { |
Line 2479 sub rolesinit {
|
Line 2579 sub rolesinit {
|
if ($_!~/^rolesdef_/) { |
if ($_!~/^rolesdef_/) { |
my ($area,$role)=split(/=/,$_); |
my ($area,$role)=split(/=/,$_); |
$area=~s/\_\w\w$//; |
$area=~s/\_\w\w$//; |
|
|
my ($trole,$tend,$tstart); |
my ($trole,$tend,$tstart); |
if ($role=~/^cr/) { |
if ($role=~/^cr/) { |
if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) { |
if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) { |
Line 2503 sub rolesinit {
|
Line 2602 sub rolesinit {
|
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); |
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); |
} |
} |
} |
} |
} |
} |
} |
} |
my ($author,$adv) = &set_userprivs(\$userroles,\%allroles); |
my ($author,$adv) = &set_userprivs(\$userroles,\%allroles); |
$userroles.='user.adv='.$adv."\n". |
$userroles.='user.adv='.$adv."\n". |
Line 2977 sub allowed {
|
Line 3076 sub allowed {
|
$thisallowed.=$1; |
$thisallowed.=$1; |
} |
} |
|
|
# URI is an uploaded document for this course |
# URI is an uploaded document for this course, default permissions don't matter |
# not allowing 'edit' access (editupload) to uploaded course docs |
# not allowing 'edit' access (editupload) to uploaded course docs |
if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { |
if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { |
|
$thisallowed=''; |
my $refuri=$env{'httpref.'.$orguri}; |
my $refuri=$env{'httpref.'.$orguri}; |
if ($refuri) { |
if ($refuri) { |
if ($refuri =~ m|^/adm/|) { |
if ($refuri =~ m|^/adm/|) { |
Line 3201 sub allowed {
|
Line 3301 sub allowed {
|
# --------------------------------------------------- Is a resource on the map? |
# --------------------------------------------------- Is a resource on the map? |
|
|
sub is_on_map { |
sub is_on_map { |
my $uri=&declutter(shift); |
my $uri=&deversion(&declutter(shift)); |
$uri=~s/\.\d+\.(\w+)$/\.$1/; |
|
my @uriparts=split(/\//,$uri); |
my @uriparts=split(/\//,$uri); |
my $filename=$uriparts[$#uriparts]; |
my $filename=$uriparts[$#uriparts]; |
my $pathname=$uri; |
my $pathname=$uri; |
Line 3572 sub assignrole {
|
Line 3671 sub assignrole {
|
my $answer=&reply($command,&homeserver($uname,$udom)); |
my $answer=&reply($command,&homeserver($uname,$udom)); |
# log new user role if status is ok |
# log new user role if status is ok |
if ($answer eq 'ok') { |
if ($answer eq 'ok') { |
&userrolelog($mrole,$uname,$udom,$url,$start,$end); |
&userrolelog($role,$uname,$udom,$url,$start,$end); |
} |
} |
return $answer; |
return $answer; |
} |
} |
Line 3775 sub modify_student_enrollment {
|
Line 3874 sub modify_student_enrollment {
|
$cdom,$cnum); |
$cdom,$cnum); |
unless (($reply eq 'ok') || ($reply eq 'delayed')) { |
unless (($reply eq 'ok') || ($reply eq 'delayed')) { |
return 'error: '.$reply; |
return 'error: '.$reply; |
|
} else { |
|
&devalidate_getsection_cache($udom,$uname,$cid); |
} |
} |
# Add student role to user |
# Add student role to user |
my $uurl='/'.$cid; |
my $uurl='/'.$cid; |
Line 4860 sub metadata {
|
Line 4961 sub metadata {
|
$metaentry{':keys'}=join(',',keys %metathesekeys); |
$metaentry{':keys'}=join(',',keys %metathesekeys); |
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); |
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); |
&do_cache_new('meta',$uri,\%metaentry,600); |
&do_cache_new('meta',$uri,\%metaentry,60*60*24); |
# this is the end of "was not already recently cached |
# this is the end of "was not already recently cached |
} |
} |
return $metaentry{':'.$what}; |
return $metaentry{':'.$what}; |
Line 5890 BEGIN {
|
Line 5991 BEGIN {
|
} |
} |
close($config); |
close($config); |
# FIXME: dev server don't want this, production servers _do_ want this |
# FIXME: dev server don't want this, production servers _do_ want this |
&get_iphost(); |
#&get_iphost(); |
} |
} |
|
|
sub get_iphost { |
sub get_iphost { |