version 1.1172.2.2, 2012/05/28 15:02:06
|
version 1.1184, 2012/08/17 22:43:58
|
Line 75 use LWP::UserAgent();
|
Line 75 use LWP::UserAgent();
|
use HTTP::Date; |
use HTTP::Date; |
use Image::Magick; |
use Image::Magick; |
|
|
|
|
use Encode; |
use Encode; |
|
|
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir |
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir |
Line 99 use File::MMagic;
|
Line 100 use File::MMagic;
|
use LONCAPA qw(:DEFAULT :match); |
use LONCAPA qw(:DEFAULT :match); |
use LONCAPA::Configuration; |
use LONCAPA::Configuration; |
use LONCAPA::lonmetadata; |
use LONCAPA::lonmetadata; |
|
use LONCAPA::Lond; |
|
|
use File::Copy; |
use File::Copy; |
|
|
Line 111 our @ISA = qw (Exporter);
|
Line 113 our @ISA = qw (Exporter);
|
our @EXPORT = qw(%env); |
our @EXPORT = qw(%env); |
|
|
|
|
# --------------------------------------------------------------------- Logging |
# ---------------------------------------------------------------- Role Logging |
{ |
{ |
my $logid; |
my $logid; |
sub instructor_log { |
sub write_rolelog { |
my ($hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_; |
my ($context,$hash_name,$storehash,$delflag,$udom,$uname,$cdom,$cnum)=@_; |
if (($cnum eq '') || ($cdom eq '')) { |
if ($context eq 'course') { |
$cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; |
if (($cnum eq '') || ($cdom eq '')) { |
$cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; |
$cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; |
|
$cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; |
|
} |
} |
} |
$logid++; |
$logid ++; |
my $now = time(); |
my $now = time(); |
my $id=$now.'00000'.$$.'00000'.$logid; |
my $id=$now.'00000'.$$.'00000'.$logid; |
return &Apache::lonnet::put('nohist_'.$hash_name, |
my $logentry = { |
{ $id => { |
$id => { |
'exe_uname' => $env{'user.name'}, |
'exe_uname' => $env{'user.name'}, |
'exe_udom' => $env{'user.domain'}, |
'exe_udom' => $env{'user.domain'}, |
'exe_time' => $now, |
'exe_time' => $now, |
'exe_ip' => $ENV{'REMOTE_ADDR'}, |
'exe_ip' => $ENV{'REMOTE_ADDR'}, |
'delflag' => $delflag, |
'delflag' => $delflag, |
'logentry' => $storehash, |
'logentry' => $storehash, |
'uname' => $uname, |
'uname' => $uname, |
'udom' => $udom, |
'udom' => $udom, |
} |
} |
},$cdom,$cnum); |
}; |
|
return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum); |
} |
} |
} |
} |
|
|
Line 1238 sub check_loadbalancing {
|
Line 1243 sub check_loadbalancing {
|
my ($is_balancer,$dom_in_use,$homeintdom,$rule_in_effect, |
my ($is_balancer,$dom_in_use,$homeintdom,$rule_in_effect, |
$offloadto,$otherserver); |
$offloadto,$otherserver); |
my $lonhost = $perlvar{'lonHostID'}; |
my $lonhost = $perlvar{'lonHostID'}; |
|
my @hosts = ¤t_machine_ids(); |
my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); |
my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); |
my $uintdom = &Apache::lonnet::internet_dom($uprimary_id); |
my $uintdom = &Apache::lonnet::internet_dom($uprimary_id); |
my $intdom = &Apache::lonnet::internet_dom($lonhost); |
my $intdom = &Apache::lonnet::internet_dom($lonhost); |
Line 1264 sub check_loadbalancing {
|
Line 1270 sub check_loadbalancing {
|
my $currtargets = $result->{'targets'}; |
my $currtargets = $result->{'targets'}; |
my $currrules = $result->{'rules'}; |
my $currrules = $result->{'rules'}; |
if ($currbalancer ne '') { |
if ($currbalancer ne '') { |
my @hosts = ¤t_machine_ids(); |
|
if (grep(/^\Q$currbalancer\E$/,@hosts)) { |
if (grep(/^\Q$currbalancer\E$/,@hosts)) { |
$is_balancer = 1; |
$is_balancer = 1; |
} |
} |
Line 1352 sub check_loadbalancing {
|
Line 1357 sub check_loadbalancing {
|
$offloadto = &this_host_spares($dom_in_use); |
$offloadto = &this_host_spares($dom_in_use); |
} |
} |
} |
} |
my $lowest_load = 30000; |
if ($is_balancer) { |
if (ref($offloadto) eq 'HASH') { |
my $lowest_load = 30000; |
if (ref($offloadto->{'primary'}) eq 'ARRAY') { |
if (ref($offloadto) eq 'HASH') { |
foreach my $try_server (@{$offloadto->{'primary'}}) { |
if (ref($offloadto->{'primary'}) eq 'ARRAY') { |
($otherserver,$lowest_load) = |
foreach my $try_server (@{$offloadto->{'primary'}}) { |
&compare_server_load($try_server,$otherserver,$lowest_load); |
($otherserver,$lowest_load) = |
|
&compare_server_load($try_server,$otherserver,$lowest_load); |
|
} |
} |
} |
} |
my $found_server = ($otherserver ne '' && $lowest_load < 100); |
my $found_server = ($otherserver ne '' && $lowest_load < 100); |
|
|
|
if (!$found_server) { |
if (!$found_server) { |
if (ref($offloadto->{'default'}) eq 'ARRAY') { |
if (ref($offloadto->{'default'}) eq 'ARRAY') { |
foreach my $try_server (@{$offloadto->{'default'}}) { |
foreach my $try_server (@{$offloadto->{'default'}}) { |
|
($otherserver,$lowest_load) = |
|
&compare_server_load($try_server,$otherserver,$lowest_load); |
|
} |
|
} |
|
} |
|
} elsif (ref($offloadto) eq 'ARRAY') { |
|
if (@{$offloadto} == 1) { |
|
$otherserver = $offloadto->[0]; |
|
} elsif (@{$offloadto} > 1) { |
|
foreach my $try_server (@{$offloadto}) { |
($otherserver,$lowest_load) = |
($otherserver,$lowest_load) = |
&compare_server_load($try_server,$otherserver,$lowest_load); |
&compare_server_load($try_server,$otherserver,$lowest_load); |
} |
} |
} |
} |
} |
} |
} elsif (ref($offloadto) eq 'ARRAY') { |
if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) { |
if (@{$offloadto} == 1) { |
$is_balancer = 0; |
$otherserver = $offloadto->[0]; |
if ($uname ne '' && $udom ne '') { |
} elsif (@{$offloadto} > 1) { |
if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { |
foreach my $try_server (@{$offloadto}) { |
|
($otherserver,$lowest_load) = |
&appenv({'user.loadbalexempt' => $lonhost, |
&compare_server_load($try_server,$otherserver,$lowest_load); |
'user.loadbalcheck.time' => time}); |
|
} |
} |
} |
} |
} |
} |
} |
Line 1386 sub check_loadbalancing {
|
Line 1403 sub check_loadbalancing {
|
sub get_loadbalancer_targets { |
sub get_loadbalancer_targets { |
my ($rule_in_effect,$currtargets,$uname,$udom) = @_; |
my ($rule_in_effect,$currtargets,$uname,$udom) = @_; |
my $offloadto; |
my $offloadto; |
if ($rule_in_effect eq '') { |
if ($rule_in_effect eq 'none') { |
|
return [$perlvar{'lonHostID'}]; |
|
} elsif ($rule_in_effect eq '') { |
$offloadto = $currtargets; |
$offloadto = $currtargets; |
} else { |
} else { |
if ($rule_in_effect eq 'homeserver') { |
if ($rule_in_effect eq 'homeserver') { |
Line 1404 sub get_loadbalancer_targets {
|
Line 1423 sub get_loadbalancer_targets {
|
} |
} |
} |
} |
} else { |
} else { |
my %servers = &dom_servers($udom); |
my %servers = &internet_dom_servers($udom); |
my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers); |
my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers); |
if (&hostname($remotebalancer) ne '') { |
if (&hostname($remotebalancer) ne '') { |
$offloadto = [$remotebalancer]; |
$offloadto = [$remotebalancer]; |
Line 1923 sub get_domain_defaults {
|
Line 1942 sub get_domain_defaults {
|
my %domconfig = |
my %domconfig = |
&Apache::lonnet::get_dom('configuration',['defaults','quotas', |
&Apache::lonnet::get_dom('configuration',['defaults','quotas', |
'requestcourses','inststatus', |
'requestcourses','inststatus', |
'coursedefaults','usersessions'],$domain); |
'coursedefaults','usersessions', |
|
'requestauthor'],$domain); |
if (ref($domconfig{'defaults'}) eq 'HASH') { |
if (ref($domconfig{'defaults'}) eq 'HASH') { |
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; |
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; |
$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; |
$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; |
Line 1942 sub get_domain_defaults {
|
Line 1962 sub get_domain_defaults {
|
} else { |
} else { |
$domdefaults{'defaultquota'} = $domconfig{'quotas'}; |
$domdefaults{'defaultquota'} = $domconfig{'quotas'}; |
} |
} |
my @usertools = ('aboutme','blog','portfolio'); |
my @usertools = ('aboutme','blog','webdav','portfolio'); |
foreach my $item (@usertools) { |
foreach my $item (@usertools) { |
if (ref($domconfig{'quotas'}{$item}) eq 'HASH') { |
if (ref($domconfig{'quotas'}{$item}) eq 'HASH') { |
$domdefaults{$item} = $domconfig{'quotas'}{$item}; |
$domdefaults{$item} = $domconfig{'quotas'}{$item}; |
Line 1954 sub get_domain_defaults {
|
Line 1974 sub get_domain_defaults {
|
$domdefaults{$item} = $domconfig{'requestcourses'}{$item}; |
$domdefaults{$item} = $domconfig{'requestcourses'}{$item}; |
} |
} |
} |
} |
|
if (ref($domconfig{'requestauthor'}) eq 'HASH') { |
|
$domdefaults{'requestauthor'} = $domconfig{'requestauthor'}; |
|
} |
if (ref($domconfig{'inststatus'}) eq 'HASH') { |
if (ref($domconfig{'inststatus'}) eq 'HASH') { |
foreach my $item ('inststatustypes','inststatusorder') { |
foreach my $item ('inststatustypes','inststatusorder') { |
$domdefaults{$item} = $domconfig{'inststatus'}{$item}; |
$domdefaults{$item} = $domconfig{'inststatus'}{$item}; |
Line 2570 sub ssi {
|
Line 2593 sub ssi {
|
|
|
$request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
$request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
my $response= $ua->request($request); |
my $response= $ua->request($request); |
my $content = Encode::decode_utf8($response->content); |
my $content = $response->content; |
|
|
|
|
if (wantarray) { |
if (wantarray) { |
return ($content, $response); |
return ($content, $response); |
} else { |
} else { |
Line 3512 sub userrolelog {
|
Line 3537 sub userrolelog {
|
|
|
sub courserolelog { |
sub courserolelog { |
my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_; |
my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_; |
if (($trole eq 'cc') || ($trole eq 'in') || |
if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) { |
($trole eq 'ep') || ($trole eq 'ad') || |
my $cdom = $1; |
($trole eq 'ta') || ($trole eq 'st') || |
my $cnum = $2; |
($trole=~/^cr/) || ($trole eq 'gr') || |
my $sec = $3; |
($trole eq 'co')) { |
my $namespace = 'rolelog'; |
if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) { |
my %storehash = ( |
my $cdom = $1; |
role => $trole, |
my $cnum = $2; |
start => $tstart, |
my $sec = $3; |
end => $tend, |
my $namespace = 'rolelog'; |
selfenroll => $selfenroll, |
my %storehash = ( |
context => $context, |
role => $trole, |
); |
start => $tstart, |
if ($trole eq 'gr') { |
end => $tend, |
$namespace = 'groupslog'; |
selfenroll => $selfenroll, |
$storehash{'group'} = $sec; |
context => $context, |
} else { |
); |
$storehash{'section'} = $sec; |
if ($trole eq 'gr') { |
} |
$namespace = 'groupslog'; |
&write_rolelog('course',$namespace,\%storehash,$delflag,$domain, |
$storehash{'group'} = $sec; |
$username,$cdom,$cnum); |
} else { |
if (($trole ne 'st') || ($sec ne '')) { |
$storehash{'section'} = $sec; |
&devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum); |
} |
|
&instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom); |
|
if (($trole ne 'st') || ($sec ne '')) { |
|
&devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum); |
|
} |
|
} |
} |
} |
} |
return; |
return; |
} |
} |
|
|
|
sub domainrolelog { |
|
my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_; |
|
if ($area =~ m{^/($match_domain)/$}) { |
|
my $cdom = $1; |
|
my $domconfiguser = &Apache::lonnet::get_domainconfiguser($cdom); |
|
my $namespace = 'rolelog'; |
|
my %storehash = ( |
|
role => $trole, |
|
start => $tstart, |
|
end => $tend, |
|
context => $context, |
|
); |
|
&write_rolelog('domain',$namespace,\%storehash,$delflag,$domain, |
|
$username,$cdom,$domconfiguser); |
|
} |
|
return; |
|
|
|
} |
|
|
|
sub coauthorrolelog { |
|
my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_; |
|
if ($area =~ m{^/($match_domain)/($match_username)$}) { |
|
my $audom = $1; |
|
my $auname = $2; |
|
my $namespace = 'rolelog'; |
|
my %storehash = ( |
|
role => $trole, |
|
start => $tstart, |
|
end => $tend, |
|
context => $context, |
|
); |
|
&write_rolelog('author',$namespace,\%storehash,$delflag,$domain, |
|
$username,$audom,$auname); |
|
} |
|
return; |
|
} |
|
|
sub get_course_adv_roles { |
sub get_course_adv_roles { |
my ($cid,$codes) = @_; |
my ($cid,$codes) = @_; |
$cid=$env{'request.course.id'} unless (defined($cid)); |
$cid=$env{'request.course.id'} unless (defined($cid)); |
Line 3807 sub courseiddump {
|
Line 3864 sub courseiddump {
|
|
|
if (($domfilter eq '') || |
if (($domfilter eq '') || |
(&host_domain($tryserver) eq $domfilter)) { |
(&host_domain($tryserver) eq $domfilter)) { |
my $rep = |
my $rep; |
&reply('courseiddump:'.&host_domain($tryserver).':'. |
if (grep { $_ eq $tryserver } current_machine_ids()) { |
$sincefilter.':'.&escape($descfilter).':'. |
$rep = LONCAPA::Lond::dump_course_id_handler( |
&escape($instcodefilter).':'.&escape($ownerfilter). |
join(":", (&host_domain($tryserver), $sincefilter, |
':'.&escape($coursefilter).':'.&escape($typefilter). |
&escape($descfilter), &escape($instcodefilter), |
':'.&escape($regexp_ok).':'.$as_hash.':'. |
&escape($ownerfilter), &escape($coursefilter), |
&escape($selfenrollonly).':'.&escape($catfilter).':'. |
&escape($typefilter), &escape($regexp_ok), |
$showhidden.':'.$caller.':'.&escape($cloner).':'. |
$as_hash, &escape($selfenrollonly), |
&escape($cc_clone).':'.$cloneonly.':'. |
&escape($catfilter), $showhidden, $caller, |
&escape($createdbefore).':'.&escape($createdafter).':'. |
&escape($cloner), &escape($cc_clone), $cloneonly, |
&escape($creationcontext).':'.$domcloner, |
&escape($createdbefore), &escape($createdafter), |
$tryserver); |
&escape($creationcontext), $domcloner))); |
|
} else { |
|
$rep = &reply('courseiddump:'.&host_domain($tryserver).':'. |
|
$sincefilter.':'.&escape($descfilter).':'. |
|
&escape($instcodefilter).':'.&escape($ownerfilter). |
|
':'.&escape($coursefilter).':'.&escape($typefilter). |
|
':'.&escape($regexp_ok).':'.$as_hash.':'. |
|
&escape($selfenrollonly).':'.&escape($catfilter).':'. |
|
$showhidden.':'.$caller.':'.&escape($cloner).':'. |
|
&escape($cc_clone).':'.$cloneonly.':'. |
|
&escape($createdbefore).':'.&escape($createdafter).':'. |
|
&escape($creationcontext).':'.$domcloner, |
|
$tryserver); |
|
} |
|
|
my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
foreach my $item (@pairs) { |
foreach my $item (@pairs) { |
my ($key,$value)=split(/\=/,$item,2); |
my ($key,$value)=split(/\=/,$item,2); |
Line 5058 sub del {
|
Line 5129 sub del {
|
|
|
# -------------------------------------------------------------- dump interface |
# -------------------------------------------------------------- dump interface |
|
|
|
sub unserialize { |
|
my ($rep, $escapedkeys) = @_; |
|
|
|
return {} if $rep =~ /^error/; |
|
|
|
my %returnhash=(); |
|
foreach my $item (split /\&/, $rep) { |
|
my ($key, $value) = split(/=/, $item, 2); |
|
$key = unescape($key) unless $escapedkeys; |
|
next if $key =~ /^error: 2 /; |
|
$returnhash{$key} = Apache::lonnet::thaw_unescape($value); |
|
} |
|
#return %returnhash; |
|
return \%returnhash; |
|
} |
|
|
|
# see Lond::dump_with_regexp |
|
# if $escapedkeys hash keys won't get unescaped. |
sub dump { |
sub dump { |
my ($namespace,$udomain,$uname,$regexp,$range)=@_; |
my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_; |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
|
|
|
my $reply; |
|
if (grep { $_ eq $uhome } current_machine_ids()) { |
|
# user is hosted on this machine |
|
$reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain, |
|
$uname, $namespace, $regexp, $range)), $loncaparevs{$uhome}); |
|
return %{unserialize($reply, $escapedkeys)}; |
|
} |
if ($regexp) { |
if ($regexp) { |
$regexp=&escape($regexp); |
$regexp=&escape($regexp); |
} else { |
} else { |
Line 5075 sub dump {
|
Line 5171 sub dump {
|
if (!($rep =~ /^error/ )) { |
if (!($rep =~ /^error/ )) { |
foreach my $item (@pairs) { |
foreach my $item (@pairs) { |
my ($key,$value)=split(/=/,$item,2); |
my ($key,$value)=split(/=/,$item,2); |
$key = &unescape($key); |
$key = unescape($key) unless $escapedkeys; |
|
#$key = &unescape($key); |
next if ($key =~ /^error: 2 /); |
next if ($key =~ /^error: 2 /); |
$returnhash{$key}=&thaw_unescape($value); |
$returnhash{$key}=&thaw_unescape($value); |
} |
} |
Line 5088 sub dump {
|
Line 5185 sub dump {
|
|
|
sub dumpstore { |
sub dumpstore { |
my ($namespace,$udomain,$uname,$regexp,$range)=@_; |
my ($namespace,$udomain,$uname,$regexp,$range)=@_; |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
# same as dump but keys must be escaped. They may contain colon separated |
if (!$uname) { $uname=$env{'user.name'}; } |
# lists of values that may themself contain colons (e.g. symbs). |
my $uhome=&homeserver($uname,$udomain); |
return &dump($namespace, $udomain, $uname, $regexp, $range, 1); |
if ($regexp) { |
|
$regexp=&escape($regexp); |
|
} else { |
|
$regexp='.'; |
|
} |
|
my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); |
|
my @pairs=split(/\&/,$rep); |
|
my %returnhash=(); |
|
foreach my $item (@pairs) { |
|
my ($key,$value)=split(/=/,$item,2); |
|
next if ($key =~ /^error: 2 /); |
|
$returnhash{$key}=&thaw_unescape($value); |
|
} |
|
return %returnhash; |
|
} |
} |
|
|
# -------------------------------------------------------------- keys interface |
# -------------------------------------------------------------- keys interface |
Line 5130 sub currentdump {
|
Line 5213 sub currentdump {
|
$sdom = $env{'user.domain'} if (! defined($sdom)); |
$sdom = $env{'user.domain'} if (! defined($sdom)); |
$sname = $env{'user.name'} if (! defined($sname)); |
$sname = $env{'user.name'} if (! defined($sname)); |
my $uhome = &homeserver($sname,$sdom); |
my $uhome = &homeserver($sname,$sdom); |
my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); |
my $rep; |
|
|
|
if (grep { $_ eq $uhome } current_machine_ids()) { |
|
$rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname, |
|
$courseid))); |
|
} else { |
|
$rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); |
|
} |
|
|
return if ($rep =~ /^(error:|no_such_host)/); |
return if ($rep =~ /^(error:|no_such_host)/); |
# |
# |
my %returnhash=(); |
my %returnhash=(); |
Line 5628 sub usertools_access {
|
Line 5719 sub usertools_access {
|
unofficial => 1, |
unofficial => 1, |
community => 1, |
community => 1, |
); |
); |
|
} elsif ($context eq 'requestauthor') { |
|
%tools = ( |
|
requestauthor => 1, |
|
); |
} else { |
} else { |
%tools = ( |
%tools = ( |
aboutme => 1, |
aboutme => 1, |
blog => 1, |
blog => 1, |
|
webdav => 1, |
portfolio => 1, |
portfolio => 1, |
); |
); |
} |
} |
Line 5646 sub usertools_access {
|
Line 5742 sub usertools_access {
|
if ($action ne 'reload') { |
if ($action ne 'reload') { |
if ($context eq 'requestcourses') { |
if ($context eq 'requestcourses') { |
return $env{'environment.canrequest.'.$tool}; |
return $env{'environment.canrequest.'.$tool}; |
|
} elsif ($context eq 'requestauthor') { |
|
return $env{'environment.canrequest.author'}; |
} else { |
} else { |
return $env{'environment.availabletools.'.$tool}; |
return $env{'environment.availabletools.'.$tool}; |
} |
} |
} |
} |
} |
} |
|
|
my ($toolstatus,$inststatus); |
my ($toolstatus,$inststatus,$envkey); |
|
if ($context eq 'requestauthor') { |
|
$envkey = $context; |
|
} else { |
|
$envkey = $context.'.'.$tool; |
|
} |
|
|
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && |
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && |
($action ne 'reload')) { |
($action ne 'reload')) { |
$toolstatus = $env{'environment.'.$context.'.'.$tool}; |
$toolstatus = $env{'environment.'.$envkey}; |
$inststatus = $env{'environment.inststatus'}; |
$inststatus = $env{'environment.inststatus'}; |
} else { |
} else { |
if (ref($userenvref) eq 'HASH') { |
if (ref($userenvref) eq 'HASH') { |
$toolstatus = $userenvref->{$context.'.'.$tool}; |
$toolstatus = $userenvref->{$envkey}; |
$inststatus = $userenvref->{'inststatus'}; |
$inststatus = $userenvref->{'inststatus'}; |
} else { |
} else { |
my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus'); |
my %userenv = &userenvironment($udom,$uname,$envkey,'inststatus'); |
$toolstatus = $userenv{$context.'.'.$tool}; |
$toolstatus = $userenv{$envkey}; |
$inststatus = $userenv{'inststatus'}; |
$inststatus = $userenv{'inststatus'}; |
} |
} |
} |
} |
Line 5730 sub usertools_access {
|
Line 5833 sub usertools_access {
|
} |
} |
} |
} |
} else { |
} else { |
if ($context eq 'tools') { |
if (($context eq 'tools') && ($tool ne 'webdav')) { |
$access = 1; |
$access = 1; |
} else { |
} else { |
$access = 0; |
$access = 0; |
Line 7451 sub assignrole {
|
Line 7554 sub assignrole {
|
} |
} |
} |
} |
} |
} |
|
} elsif ($context eq 'requestauthor') { |
|
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && |
|
($url eq '/'.$udom.'/') && ($role eq 'au')) { |
|
if ($env{'environment.requestauthor'} eq 'automatic') { |
|
$refused = ''; |
|
} else { |
|
my %domdefaults = &get_domain_defaults($udom); |
|
if (ref($domdefaults{'requestauthor'}) eq 'HASH') { |
|
my $checkbystatus; |
|
if ($env{'user.adv'}) { |
|
my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'}; |
|
if ($disposition eq 'automatic') { |
|
$refused = ''; |
|
} elsif ($disposition eq '') { |
|
$checkbystatus = 1; |
|
} |
|
} else { |
|
$checkbystatus = 1; |
|
} |
|
if ($checkbystatus) { |
|
if ($env{'environment.inststatus'}) { |
|
my @inststatuses = split(/,/,$env{'environment.inststatus'}); |
|
foreach my $type (@inststatuses) { |
|
if (($type ne '') && |
|
($domdefaults{'requestauthor'}{$type} eq 'automatic')) { |
|
$refused = ''; |
|
} |
|
} |
|
} elsif ($domdefaults{'requestauthor'}{'default'} eq 'automatic') { |
|
$refused = ''; |
|
} |
|
} |
|
} |
|
} |
|
} |
} |
} |
if ($refused) { |
if ($refused) { |
&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url. |
&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url. |
Line 7501 sub assignrole {
|
Line 7639 sub assignrole {
|
if ($answer eq 'ok') { |
if ($answer eq 'ok') { |
&userrolelog($role,$uname,$udom,$url,$start,$end); |
&userrolelog($role,$uname,$udom,$url,$start,$end); |
# for course roles, perform group memberships changes triggered by role change. |
# for course roles, perform group memberships changes triggered by role change. |
&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context); |
|
unless ($role =~ /^gr/) { |
unless ($role =~ /^gr/) { |
&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, |
&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, |
$origstart,$selfenroll,$context); |
$origstart,$selfenroll,$context); |
} |
} |
|
if (($role eq 'cc') || ($role eq 'in') || |
|
($role eq 'ep') || ($role eq 'ad') || |
|
($role eq 'ta') || ($role eq 'st') || |
|
($role=~/^cr/) || ($role eq 'gr') || |
|
($role eq 'co')) { |
|
&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
|
$selfenroll,$context); |
|
} elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') || |
|
($role eq 'au') || ($role eq 'dc')) { |
|
&domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
|
$context); |
|
} elsif (($role eq 'ca') || ($role eq 'aa')) { |
|
&coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
|
$context); |
|
} |
if ($role eq 'cc') { |
if ($role eq 'cc') { |
&autoupdate_coowners($url,$end,$start,$uname,$udom); |
&autoupdate_coowners($url,$end,$start,$uname,$udom); |
} |
} |
Line 9800 sub devalidate_slots_cache {
|
Line 9952 sub devalidate_slots_cache {
|
&devalidate_cache_new('allslots',$hashid); |
&devalidate_cache_new('allslots',$hashid); |
} |
} |
|
|
|
sub get_coursechange { |
|
my ($cdom,$cnum) = @_; |
|
if ($cdom eq '' || $cnum eq '') { |
|
return unless ($env{'request.course.id'}); |
|
$cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; |
|
$cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; |
|
} |
|
my $hashid=$cdom.'_'.$cnum; |
|
my ($change,$cached)=&is_cached_new('crschange',$hashid); |
|
if ((defined($cached)) && ($change ne '')) { |
|
return $change; |
|
} else { |
|
my %crshash; |
|
%crshash = &get('environment',['internal.contentchange'],$cdom,$cnum); |
|
if ($crshash{'internal.contentchange'} eq '') { |
|
$change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'}; |
|
if ($change eq '') { |
|
%crshash = &get('environment',['internal.created'],$cdom,$cnum); |
|
$change = $crshash{'internal.created'}; |
|
} |
|
} else { |
|
$change = $crshash{'internal.contentchange'}; |
|
} |
|
my $cachetime = 600; |
|
&do_cache_new('crschange',$hashid,$change,$cachetime); |
|
} |
|
return $change; |
|
} |
|
|
|
sub devalidate_coursechange_cache { |
|
my ($cnum,$cdom)=@_; |
|
my $hashid=$cnum.':'.$cdom; |
|
&devalidate_cache_new('crschange',$hashid); |
|
} |
|
|
# ------------------------------------------------- Update symbolic store links |
# ------------------------------------------------- Update symbolic store links |
|
|
sub symblist { |
sub symblist { |
Line 9944 sub deversion {
|
Line 10131 sub deversion {
|
sub symbread { |
sub symbread { |
my ($thisfn,$donotrecurse)=@_; |
my ($thisfn,$donotrecurse)=@_; |
my $cache_str='request.symbread.cached.'.$thisfn; |
my $cache_str='request.symbread.cached.'.$thisfn; |
if (defined($env{$cache_str})) { return $env{$cache_str}; } |
if (defined($env{$cache_str})) { |
|
if (($thisfn) || ($env{$cache_str} ne '')) { |
|
return $env{$cache_str}; |
|
} |
|
} |
# no filename provided? try from environment |
# no filename provided? try from environment |
unless ($thisfn) { |
unless ($thisfn) { |
if ($env{'request.symb'}) { |
if ($env{'request.symb'}) { |