--- loncom/lonnet/perl/lonnet.pm 2012/05/30 22:01:08 1.1172.2.5
+++ loncom/lonnet/perl/lonnet.pm 2012/08/27 15:03:52 1.1172.2.9
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1172.2.5 2012/05/30 22:01:08 raeburn Exp $
+# $Id: lonnet.pm,v 1.1172.2.9 2012/08/27 15:03:52 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -108,31 +108,33 @@ require Exporter;
our @ISA = qw (Exporter);
our @EXPORT = qw(%env);
-
-# --------------------------------------------------------------------- Logging
+# ------------------------------------ Logging (parameters, docs, slots, roles)
{
my $logid;
- sub instructor_log {
- my ($hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
- if (($cnum eq '') || ($cdom eq '')) {
- $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
- $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+ sub write_log {
+ my ($context,$hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
+ if ($context eq 'course') {
+ if (($cnum eq '') || ($cdom eq '')) {
+ $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+ $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+ }
}
$logid++;
my $now = time();
my $id=$now.'00000'.$$.'00000'.$logid;
- return &Apache::lonnet::put('nohist_'.$hash_name,
- { $id => {
- 'exe_uname' => $env{'user.name'},
- 'exe_udom' => $env{'user.domain'},
- 'exe_time' => $now,
- 'exe_ip' => $ENV{'REMOTE_ADDR'},
- 'delflag' => $delflag,
- 'logentry' => $storehash,
- 'uname' => $uname,
- 'udom' => $udom,
- }
- },$cdom,$cnum);
+ my $logentry = {
+ $id => {
+ 'exe_uname' => $env{'user.name'},
+ 'exe_udom' => $env{'user.domain'},
+ 'exe_time' => $now,
+ 'exe_ip' => $ENV{'REMOTE_ADDR'},
+ 'delflag' => $delflag,
+ 'logentry' => $storehash,
+ 'uname' => $uname,
+ 'udom' => $udom,
+ }
+ };
+ return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);
}
}
@@ -1416,7 +1418,7 @@ sub get_loadbalancer_targets {
}
}
} else {
- my %servers = &dom_servers($udom);
+ my %servers = &internet_dom_servers($udom);
my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers);
if (&hostname($remotebalancer) ne '') {
$offloadto = [$remotebalancer];
@@ -1935,7 +1937,8 @@ sub get_domain_defaults {
my %domconfig =
&Apache::lonnet::get_dom('configuration',['defaults','quotas',
'requestcourses','inststatus',
- 'coursedefaults','usersessions'],$domain);
+ 'coursedefaults','usersessions',
+ 'requestauthor'],$domain);
if (ref($domconfig{'defaults'}) eq 'HASH') {
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
@@ -1954,7 +1957,7 @@ sub get_domain_defaults {
} else {
$domdefaults{'defaultquota'} = $domconfig{'quotas'};
}
- my @usertools = ('aboutme','blog','portfolio');
+ my @usertools = ('aboutme','blog','webdav','portfolio');
foreach my $item (@usertools) {
if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
$domdefaults{$item} = $domconfig{'quotas'}{$item};
@@ -1966,6 +1969,9 @@ sub get_domain_defaults {
$domdefaults{$item} = $domconfig{'requestcourses'}{$item};
}
}
+ if (ref($domconfig{'requestauthor'}) eq 'HASH') {
+ $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};
+ }
if (ref($domconfig{'inststatus'}) eq 'HASH') {
foreach my $item ('inststatustypes','inststatusorder') {
$domdefaults{$item} = $domconfig{'inststatus'}{$item};
@@ -3523,38 +3529,70 @@ sub userrolelog {
sub courserolelog {
my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;
- if (($trole eq 'cc') || ($trole eq 'in') ||
- ($trole eq 'ep') || ($trole eq 'ad') ||
- ($trole eq 'ta') || ($trole eq 'st') ||
- ($trole=~/^cr/) || ($trole eq 'gr') ||
- ($trole eq 'co')) {
- if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
- my $cdom = $1;
- my $cnum = $2;
- my $sec = $3;
- my $namespace = 'rolelog';
- my %storehash = (
- role => $trole,
- start => $tstart,
- end => $tend,
- selfenroll => $selfenroll,
- context => $context,
- );
- if ($trole eq 'gr') {
- $namespace = 'groupslog';
- $storehash{'group'} = $sec;
- } else {
- $storehash{'section'} = $sec;
- }
- &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);
- if (($trole ne 'st') || ($sec ne '')) {
- &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);
- }
+ if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
+ my $cdom = $1;
+ my $cnum = $2;
+ my $sec = $3;
+ my $namespace = 'rolelog';
+ my %storehash = (
+ role => $trole,
+ start => $tstart,
+ end => $tend,
+ selfenroll => $selfenroll,
+ context => $context,
+ );
+ if ($trole eq 'gr') {
+ $namespace = 'groupslog';
+ $storehash{'group'} = $sec;
+ } else {
+ $storehash{'section'} = $sec;
+ }
+ &write_log('course',$namespace,\%storehash,$delflag,$username,
+ $domain,$cnum,$cdom);
+ if (($trole ne 'st') || ($sec ne '')) {
+ &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);
}
}
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_log('domain',$namespace,\%storehash,$delflag,$username,
+ $domain,$domconfiguser,$cdom);
+ }
+ 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_log('author',$namespace,\%storehash,$delflag,$username,
+ $domain,$auname,$audom);
+ }
+ return;
+}
+
sub get_course_adv_roles {
my ($cid,$codes) = @_;
$cid=$env{'request.course.id'} unless (defined($cid));
@@ -3667,7 +3705,7 @@ sub get_my_roles {
}
my ($rolecode,$username,$domain,$section,$area);
if ($context eq 'userroles') {
- ($area,$rolecode) = split(/_/,$entry);
+ ($area,$rolecode) = ($entry =~ /^(.+)_([^_]+)$/);
(undef,$domain,$username,$section) = split(/\//,$area);
} else {
($role,$username,$domain,$section) = split(/\:/,$entry);
@@ -4989,15 +5027,19 @@ sub delete_env_groupprivs {
sub check_adhoc_privs {
my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;
my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
+ my $setprivs;
if ($env{$cckey}) {
my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
&role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {
&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
+ $setprivs = 1;
}
} else {
&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
+ $setprivs = 1;
}
+ return $setprivs;
}
sub set_adhoc_privileges {
@@ -5639,10 +5681,15 @@ sub usertools_access {
unofficial => 1,
community => 1,
);
+ } elsif ($context eq 'requestauthor') {
+ %tools = (
+ requestauthor => 1,
+ );
} else {
%tools = (
aboutme => 1,
blog => 1,
+ webdav => 1,
portfolio => 1,
);
}
@@ -5657,25 +5704,32 @@ sub usertools_access {
if ($action ne 'reload') {
if ($context eq 'requestcourses') {
return $env{'environment.canrequest.'.$tool};
+ } elsif ($context eq 'requestauthor') {
+ return $env{'environment.canrequest.author'};
} else {
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'}) &&
($action ne 'reload')) {
- $toolstatus = $env{'environment.'.$context.'.'.$tool};
+ $toolstatus = $env{'environment.'.$envkey};
$inststatus = $env{'environment.inststatus'};
} else {
if (ref($userenvref) eq 'HASH') {
- $toolstatus = $userenvref->{$context.'.'.$tool};
+ $toolstatus = $userenvref->{$envkey};
$inststatus = $userenvref->{'inststatus'};
} else {
- my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');
- $toolstatus = $userenv{$context.'.'.$tool};
+ my %userenv = &userenvironment($udom,$uname,$envkey,'inststatus');
+ $toolstatus = $userenv{$envkey};
$inststatus = $userenv{'inststatus'};
}
}
@@ -5741,7 +5795,7 @@ sub usertools_access {
}
}
} else {
- if ($context eq 'tools') {
+ if (($context eq 'tools') && ($tool ne 'webdav')) {
$access = 1;
} else {
$access = 0;
@@ -7462,6 +7516,41 @@ 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) {
&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
@@ -7512,11 +7601,25 @@ sub assignrole {
if ($answer eq 'ok') {
&userrolelog($role,$uname,$udom,$url,$start,$end);
# for course roles, perform group memberships changes triggered by role change.
- &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context);
unless ($role =~ /^gr/) {
&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
$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') {
&autoupdate_coowners($url,$end,$start,$uname,$udom);
}
@@ -9811,6 +9914,41 @@ sub devalidate_slots_cache {
&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
sub symblist {
@@ -9955,7 +10093,11 @@ sub deversion {
sub symbread {
my ($thisfn,$donotrecurse)=@_;
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
unless ($thisfn) {
if ($env{'request.symb'}) {