--- loncom/lonnet/perl/lonnet.pm 2012/04/14 00:52:16 1.1164
+++ loncom/lonnet/perl/lonnet.pm 2012/09/25 19:54:38 1.1191
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1164 2012/04/14 00:52:16 raeburn Exp $
+# $Id: lonnet.pm,v 1.1191 2012/09/25 19:54:38 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -75,6 +75,9 @@ use LWP::UserAgent();
use HTTP::Date;
use Image::Magick;
+
+use Encode;
+
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
%managerstab);
@@ -97,6 +100,7 @@ use File::MMagic;
use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;
use LONCAPA::lonmetadata;
+use LONCAPA::Lond;
use File::Copy;
@@ -109,30 +113,33 @@ 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++;
+ $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);
}
}
@@ -1233,9 +1240,10 @@ sub get_lonbalancer_config {
sub check_loadbalancing {
my ($uname,$udom) = @_;
- my ($is_balancer,$dom_in_use,$homeintdom,$rule_in_effect,
- $offloadto,$otherserver);
+ my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,
+ $rule_in_effect,$offloadto,$otherserver);
my $lonhost = $perlvar{'lonHostID'};
+ my @hosts = ¤t_machine_ids();
my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);
my $intdom = &Apache::lonnet::internet_dom($lonhost);
@@ -1258,15 +1266,8 @@ sub check_loadbalancing {
}
}
if (ref($result) eq 'HASH') {
- my $currbalancer = $result->{'lonhost'};
- my $currtargets = $result->{'targets'};
- my $currrules = $result->{'rules'};
- if ($currbalancer ne '') {
- my @hosts = ¤t_machine_ids();
- if (grep(/^\Q$currbalancer\E$/,@hosts)) {
- $is_balancer = 1;
- }
- }
+ ($is_balancer,$currtargets,$currrules) =
+ &check_balancer_result($result,@hosts);
if ($is_balancer) {
if (ref($currrules) eq 'HASH') {
if ($homeintdom) {
@@ -1324,12 +1325,9 @@ sub check_loadbalancing {
}
}
if (ref($result) eq 'HASH') {
- my $currbalancer = $result->{'lonhost'};
- my $currtargets = $result->{'targets'};
- my $currrules = $result->{'rules'};
-
- if ($currbalancer eq $lonhost) {
- $is_balancer = 1;
+ ($is_balancer,$currtargets,$currrules) =
+ &check_balancer_result($result,@hosts);
+ if ($is_balancer) {
if (ref($currrules) eq 'HASH') {
if ($currrules->{'_LC_internetdom'} ne '') {
$rule_in_effect = $currrules->{'_LC_internetdom'};
@@ -1350,41 +1348,81 @@ sub check_loadbalancing {
$offloadto = &this_host_spares($dom_in_use);
}
}
- my $lowest_load = 30000;
- if (ref($offloadto) eq 'HASH') {
- if (ref($offloadto->{'primary'}) eq 'ARRAY') {
- foreach my $try_server (@{$offloadto->{'primary'}}) {
- ($otherserver,$lowest_load) =
- &compare_server_load($try_server,$otherserver,$lowest_load);
+ if ($is_balancer) {
+ my $lowest_load = 30000;
+ if (ref($offloadto) eq 'HASH') {
+ if (ref($offloadto->{'primary'}) eq 'ARRAY') {
+ foreach my $try_server (@{$offloadto->{'primary'}}) {
+ ($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 (ref($offloadto->{'default'}) eq 'ARRAY') {
- foreach my $try_server (@{$offloadto->{'default'}}) {
+ if (!$found_server) {
+ if (ref($offloadto->{'default'}) eq 'ARRAY') {
+ 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) =
&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) =
- &compare_server_load($try_server,$otherserver,$lowest_load);
+ if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {
+ $is_balancer = 0;
+ if ($uname ne '' && $udom ne '') {
+ if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
+
+ &appenv({'user.loadbalexempt' => $lonhost,
+ 'user.loadbalcheck.time' => time});
+ }
}
}
}
return ($is_balancer,$otherserver);
}
+sub check_balancer_result {
+ my ($result,@hosts) = @_;
+ my ($is_balancer,$currtargets,$currrules);
+ if (ref($result) eq 'HASH') {
+ if ($result->{'lonhost'} ne '') {
+ my $currbalancer = $result->{'lonhost'};
+ if (grep(/^\Q$currbalancer\E$/,@hosts)) {
+ $is_balancer = 1;
+ $currtargets = $result->{'targets'};
+ $currrules = $result->{'rules'};
+ }
+ } else {
+ foreach my $key (keys(%{$result})) {
+ if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&
+ (ref($result->{$key}) eq 'HASH')) {
+ $is_balancer = 1;
+ $currrules = $result->{$key}{'rules'};
+ $currtargets = $result->{$key}{'targets'};
+ last;
+ }
+ }
+ }
+ }
+ return ($is_balancer,$currtargets,$currrules);
+}
+
sub get_loadbalancer_targets {
my ($rule_in_effect,$currtargets,$uname,$udom) = @_;
my $offloadto;
- if ($rule_in_effect eq '') {
+ if ($rule_in_effect eq 'none') {
+ return [$perlvar{'lonHostID'}];
+ } elsif ($rule_in_effect eq '') {
$offloadto = $currtargets;
} else {
if ($rule_in_effect eq 'homeserver') {
@@ -1402,7 +1440,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];
@@ -1535,16 +1573,13 @@ sub idput {
# ------------------------------dump from db file owned by domainconfig user
sub dump_dom {
- my ($namespace,$udom,$regexp,$range)=@_;
- if (!$udom) {
- $udom=$env{'user.domain'};
- }
- my %returnhash;
- if ($udom) {
- my $uname = &get_domainconfiguser($udom);
- %returnhash = &dump($namespace,$udom,$uname,$regexp,$range);
- }
- return %returnhash;
+ my ($namespace, $udom, $regexp) = @_;
+
+ $udom ||= $env{'user.domain'};
+
+ return () unless $udom;
+
+ return &dump($namespace, $udom, &get_domainconfiguser($udom), $regexp);
}
# ------------------------------------------ get items from domain db files
@@ -1924,7 +1959,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'};
@@ -1943,7 +1979,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};
@@ -1955,6 +1991,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};
@@ -2158,8 +2197,7 @@ sub getsection {
# If there is a role which has expired, return it.
#
$courseid = &courseid_to_courseurl($courseid);
- my $extra = &freeze_escape({'skipcheck' => 1});
- my %roleshash = &dump('roles',$udom,$unam,$courseid,undef,$extra);
+ my %roleshash = &dump('roles',$udom,$unam,$courseid);
foreach my $key (keys(%roleshash)) {
next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
my $section=$1;
@@ -2385,7 +2423,7 @@ sub chatsend {
sub getversion {
my $fname=&clutter(shift);
- unless ($fname=~/^\/res\//) { return -1; }
+ unless ($fname=~m{^(/adm/wrapper|)/res/}) { return -1; }
return ¤tversion(&filelocation('',$fname));
}
@@ -2571,12 +2609,14 @@ sub ssi {
}
$request->header(Cookie => $ENV{'HTTP_COOKIE'});
- my $response=$ua->request($request);
+ my $response= $ua->request($request);
+ my $content = $response->content;
+
if (wantarray) {
- return ($response->content, $response);
+ return ($content, $response);
} else {
- return $response->content;
+ return $content;
}
}
@@ -3493,28 +3533,18 @@ sub statslog {
sub userrolelog {
my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
- if (($trole=~/^ca/) || ($trole=~/^aa/) ||
- ($trole=~/^in/) || ($trole=~/^cc/) ||
- ($trole=~/^ep/) || ($trole=~/^cr/) ||
- ($trole=~/^ta/) || ($trole=~/^co/)) {
+ if ( $trole =~ /^(ca|aa|in|cc|ep|cr|ta|co)/ ) {
my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
$userrolehash
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
=$tend.':'.$tstart;
}
- if (($env{'request.role'} =~ /dc\./) &&
- (($trole=~/^au/) || ($trole=~/^in/) ||
- ($trole=~/^cc/) || ($trole=~/^ep/) ||
- ($trole=~/^cr/) || ($trole=~/^ta/) ||
- ($trole=~/^co/))) {
+ if ($env{'request.role'} =~ /dc\./ && $trole =~ /^(au|in|cc|ep|cr|ta|co)/) {
$userrolehash
{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
=$tend.':'.$tstart;
}
- if (($trole=~/^dc/) || ($trole=~/^ad/) ||
- ($trole=~/^li/) || ($trole=~/^li/) ||
- ($trole=~/^au/) || ($trole=~/^dg/) ||
- ($trole=~/^sc/)) {
+ if ($trole =~ /^(dc|ad|li|au|dg|sc)/ ) {
my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
$domainrolehash
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
@@ -3524,38 +3554,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));
@@ -3623,8 +3685,7 @@ sub get_my_roles {
unless (defined($udom)) { $udom=$env{'user.domain'}; }
my (%dumphash,%nothide);
if ($context eq 'userroles') {
- my $extra = &freeze_escape({'skipcheck' => 1});
- %dumphash = &dump('roles',$udom,$uname,'.',undef,$extra);
+ %dumphash = &dump('roles',$udom,$uname);
} else {
%dumphash=
&dump('nohist_userroles',$udom,$uname);
@@ -3669,7 +3730,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);
@@ -3820,18 +3881,32 @@ sub courseiddump {
if (($domfilter eq '') ||
(&host_domain($tryserver) eq $domfilter)) {
- my $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 $rep;
+ if (grep { $_ eq $tryserver } current_machine_ids()) {
+ $rep = LONCAPA::Lond::dump_course_id_handler(
+ join(":", (&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)));
+ } 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);
foreach my $item (@pairs) {
my ($key,$value)=split(/\=/,$item,2);
@@ -3973,7 +4048,7 @@ my $cachedtime=();
sub load_all_first_access {
my ($uname,$udom)=@_;
if (($cachedkey eq $uname.':'.$udom) &&
- (abs($cachedtime-time)<5)) {
+ (abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) {
return;
}
$cachedtime=time;
@@ -4617,127 +4692,126 @@ sub update_released_required {
sub privileged {
my ($username,$domain)=@_;
- my $rolesdump=&reply("dump:$domain:$username:roles",
- &homeserver($username,$domain));
- if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||
- ($rolesdump =~ /^error:/)) {
- return 0;
- }
- my $now=time;
- if ($rolesdump ne '') {
- foreach my $entry (split(/&/,$rolesdump)) {
- if ($entry!~/^rolesdef_/) {
- my ($area,$role)=split(/=/,$entry);
- $area=~s/\_\w\w$//;
- my ($trole,$tend,$tstart)=split(/_/,$role);
- if (($trole eq 'dc') || ($trole eq 'su')) {
- my $active=1;
- if ($tend) {
- if ($tend<$now) { $active=0; }
- }
- if ($tstart) {
- if ($tstart>$now) { $active=0; }
- }
- if ($active) { return 1; }
- }
- }
+
+ my %rolesdump = &dump("roles", $domain, $username) or return 0;
+ my $now = time;
+
+ for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {
+ my ($trole, $tend, $tstart) = split(/_/, $role);
+ if (($trole eq 'dc') || ($trole eq 'su')) {
+ return 1 unless ($tend && $tend < $now)
+ or ($tstart && $tstart > $now);
+ }
}
- }
+
return 0;
}
# -------------------------------------------------------- Get user privileges
sub rolesinit {
- my ($domain,$username,$authhost)=@_;
- my $now=time;
- my %userroles = ('user.login.time' => $now);
- my $extra = &freeze_escape({'skipcheck' => 1});
- my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost);
- if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||
- ($rolesdump =~ /^error:/)) {
- return \%userroles;
- }
- my %firstaccess = &dump('firstaccesstimes',$domain,$username);
- my %timerinterval = &dump('timerinterval',$domain,$username);
- my (%coursetimerstarts,%firstaccchk,%firstaccenv,
- %coursetimerintervals,%timerintchk,%timerintenv);
+ my ($domain, $username) = @_;
+ my %userroles = ('user.login.time' => time);
+ my %rolesdump = &dump("roles", $domain, $username) or return \%userroles;
+
+ # firstaccess and timerinterval are related to timed maps/resources.
+ # also, blocking can be triggered by an activating timer
+ # it's saved in the user's %env.
+ my %firstaccess = &dump('firstaccesstimes', $domain, $username);
+ my %timerinterval = &dump('timerinterval', $domain, $username);
+ my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,
+ %timerintchk, %timerintenv);
+
foreach my $key (keys(%firstaccess)) {
- my ($cid,$rest) = split(/\0/,$key);
+ my ($cid, $rest) = split(/\0/, $key);
$coursetimerstarts{$cid}{$rest} = $firstaccess{$key};
}
+
foreach my $key (keys(%timerinterval)) {
my ($cid,$rest) = split(/\0/,$key);
$coursetimerintervals{$cid}{$rest} = $timerinterval{$key};
}
+
my %allroles=();
my %allgroups=();
- if ($rolesdump ne '') {
- foreach my $entry (split(/&/,$rolesdump)) {
- if ($entry!~/^rolesdef_/) {
- my ($area,$role)=split(/=/,$entry);
- $area=~s/\_\w\w$//;
- my ($trole,$tend,$tstart,$group_privs);
- if ($role=~/^cr/) {
- if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
- ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|);
- ($tend,$tstart)=split('_',$trest);
- } else {
- $trole=$role;
- }
- } elsif ($role =~ m|^gr/|) {
- ($trole,$tend,$tstart) = split(/_/,$role);
- next if ($tstart eq '-1');
- ($trole,$group_privs) = split(/\//,$trole);
- $group_privs = &unescape($group_privs);
- } else {
- ($trole,$tend,$tstart)=split(/_/,$role);
- }
- my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
- $username);
- @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
- if (($tend!=0) && ($tend<$now)) { $trole=''; }
- if (($tstart!=0) && ($tstart>$now)) { $trole=''; }
- if (($area ne '') && ($trole ne '')) {
- my $spec=$trole.'.'.$area;
- my ($tdummy,$tdomain,$trest)=split(/\//,$area);
- if ($trole =~ /^cr\//) {
- &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
- } elsif ($trole eq 'gr') {
- &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
- } else {
- &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
- }
- if ($trole ne 'gr') {
- my $cid = $tdomain.'_'.$trest;
- unless ($firstaccchk{$cid}) {
- if (ref($coursetimerstarts{$cid}) eq 'HASH') {
- foreach my $item (keys(%{$coursetimerstarts{$cid}})) {
- $firstaccenv{'course.'.$cid.'.firstaccess.'.$item} =
- $coursetimerstarts{$cid}{$item};
- }
- }
- $firstaccchk{$cid} = 1;
- }
- unless ($timerintchk{$cid}) {
- if (ref($coursetimerintervals{$cid}) eq 'HASH') {
- foreach my $item (keys(%{$coursetimerintervals{$cid}})) {
- $timerintenv{'course.'.$cid.'.timerinterval.'.$item} =
- $coursetimerintervals{$cid}{$item};
- }
- }
- $timerintchk{$cid} = 1;
- }
+ for my $area (grep { ! /^rolesdef_/ } keys %rolesdump) {
+ my $role = $rolesdump{$area};
+ $area =~ s/\_\w\w$//;
+
+ my ($trole, $tend, $tstart, $group_privs);
+
+ if ($role =~ /^cr/) {
+ # Custom role, defined by a user
+ # e.g., user.role.cr/msu/smith/mynewrole
+ if ($role =~ m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
+ $trole = $1;
+ ($tend, $tstart) = split('_', $2);
+ } else {
+ $trole = $role;
+ }
+ } elsif ($role =~ m|^gr/|) {
+ # Role of member in a group, defined within a course/community
+ # e.g., user.role.gr/msu/04935610a19ee4a5fmsul1/leopards
+ ($trole, $tend, $tstart) = split(/_/, $role);
+ next if $tstart eq '-1';
+ ($trole, $group_privs) = split(/\//, $trole);
+ $group_privs = &unescape($group_privs);
+ } else {
+ # Just a normal role, defined in roles.tab
+ ($trole, $tend, $tstart) = split(/_/,$role);
+ }
+
+ my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
+ $username);
+ @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
+
+ # role expired or not available yet?
+ $trole = '' if ($tend != 0 && $tend < $userroles{'user.login.time'}) or
+ ($tstart != 0 && $tstart > $userroles{'user.login.time'});
+
+ next if $area eq '' or $trole eq '';
+
+ my $spec = "$trole.$area";
+ my ($tdummy, $tdomain, $trest) = split(/\//, $area);
+
+ if ($trole =~ /^cr\//) {
+ # Custom role, defined by a user
+ &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
+ } elsif ($trole eq 'gr') {
+ # Role of a member in a group, defined within a course/community
+ &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
+ next;
+ } else {
+ # Normal role, defined in roles.tab
+ &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
+ }
+
+ my $cid = $tdomain.'_'.$trest;
+ unless ($firstaccchk{$cid}) {
+ if (ref($coursetimerstarts{$cid}) eq 'HASH') {
+ foreach my $item (keys(%{$coursetimerstarts{$cid}})) {
+ $firstaccenv{'course.'.$cid.'.firstaccess.'.$item} =
+ $coursetimerstarts{$cid}{$item};
}
}
- }
+ $firstaccchk{$cid} = 1;
+ }
+ unless ($timerintchk{$cid}) {
+ if (ref($coursetimerintervals{$cid}) eq 'HASH') {
+ foreach my $item (keys(%{$coursetimerintervals{$cid}})) {
+ $timerintenv{'course.'.$cid.'.timerinterval.'.$item} =
+ $coursetimerintervals{$cid}{$item};
+ }
+ }
+ $timerintchk{$cid} = 1;
}
- my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups);
- $userroles{'user.adv'} = $adv;
- $userroles{'user.author'} = $author;
- $env{'user.adv'}=$adv;
}
+
+ @userroles{'user.author', 'user.adv'} = &set_userprivs(\%userroles,
+ \%allroles, \%allgroups);
+ $env{'user.adv'} = $userroles{'user.adv'};
+
return (\%userroles,\%firstaccenv,\%timerintenv);
}
@@ -4992,15 +5066,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 {
@@ -5072,23 +5150,50 @@ sub del {
# -------------------------------------------------------------- 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 {
- my ($namespace,$udomain,$uname,$regexp,$range,$extra)=@_;
+ my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }
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) {
$regexp=&escape($regexp);
} else {
$regexp='.';
}
- my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range:$extra",$uhome);
+ my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
my @pairs=split(/\&/,$rep);
my %returnhash=();
if (!($rep =~ /^error/ )) {
foreach my $item (@pairs) {
my ($key,$value)=split(/=/,$item,2);
- $key = &unescape($key);
+ $key = unescape($key) unless $escapedkeys;
+ #$key = &unescape($key);
next if ($key =~ /^error: 2 /);
$returnhash{$key}=&thaw_unescape($value);
}
@@ -5101,23 +5206,9 @@ sub dump {
sub dumpstore {
my ($namespace,$udomain,$uname,$regexp,$range)=@_;
- if (!$udomain) { $udomain=$env{'user.domain'}; }
- if (!$uname) { $uname=$env{'user.name'}; }
- my $uhome=&homeserver($uname,$udomain);
- 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;
+ # same as dump but keys must be escaped. They may contain colon separated
+ # lists of values that may themself contain colons (e.g. symbs).
+ return &dump($namespace, $udomain, $uname, $regexp, $range, 1);
}
# -------------------------------------------------------------- keys interface
@@ -5143,7 +5234,15 @@ sub currentdump {
$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);
+ 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)/);
#
my %returnhash=();
@@ -5641,10 +5740,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,
);
}
@@ -5659,25 +5763,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'};
}
}
@@ -5743,7 +5854,7 @@ sub usertools_access {
}
}
} else {
- if ($context eq 'tools') {
+ if (($context eq 'tools') && ($tool ne 'webdav')) {
$access = 1;
} else {
$access = 0;
@@ -7292,8 +7403,7 @@ sub get_users_groups {
} else {
$grouplist = '';
my $courseurl = &courseid_to_courseurl($courseid);
- my $extra = &freeze_escape({'skipcheck' => 1});
- my %roleshash = &dump('roles',$udom,$uname,$courseurl,undef,$extra);
+ my %roleshash = &dump('roles',$udom,$uname,$courseurl);
my $access_end = $env{'course.'.$courseid.
'.default_enrollment_end_date'};
my $now = time;
@@ -7465,6 +7575,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.
@@ -7515,11 +7660,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);
}
@@ -8106,13 +8265,16 @@ sub generate_coursenum {
}
sub is_course {
- my ($cdom,$cnum) = @_;
- my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
- undef,'.');
- if (exists($courses{$cdom.'_'.$cnum})) {
- return 1;
- }
- return 0;
+ my ($cdom, $cnum) = scalar(@_) == 1 ?
+ ($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_;
+
+ return unless $cdom and $cnum;
+
+ my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,
+ '.');
+
+ return unless exists($courses{$cdom.'_'.$cnum});
+ return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
}
sub store_userdata {
@@ -9811,6 +9973,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 {
@@ -9838,7 +10035,7 @@ sub symblist {
# --------------------------------------------------------------- Verify a symb
sub symbverify {
- my ($symb,$thisurl)=@_;
+ my ($symb,$thisurl,$encstate)=@_;
my $thisfn=$thisurl;
$thisfn=&declutter($thisfn);
# direct jump to resource in page or to a sequence - will construct own symbs
@@ -9874,11 +10071,14 @@ sub symbverify {
}
if (
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
- eq $symb) {
+ eq $symb) {
+ if (ref($encstate)) {
+ $$encstate = $bighash{'encrypted_'.$id};
+ }
if (($env{'request.role.adv'}) ||
($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
($thisurl eq '/adm/navmaps')) {
- $okay=1;
+ $okay=1;
}
}
}
@@ -9955,7 +10155,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'}) {
@@ -10772,6 +10976,7 @@ sub declutter {
$thisfn=~s|^adm/wrapper/||;
$thisfn=~s|^adm/coursedocs/showdoc/||;
$thisfn=~s/^res\///;
+ $thisfn=~s/^priv\///;
unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) {
$thisfn=~s/\?.+$//;
}
@@ -11690,7 +11895,13 @@ B<idput($udom,%ids)>: store away a list
=item *
X<rolesinit()>
-B<rolesinit($udom,$username,$authhost)>: get user privileges
+B<rolesinit($udom,$username)>: get user privileges.
+returns user role, first access and timer interval hashes
+
+=item *
+X<privileged()>
+B<privileged($username,$domain)>: returns a true if user has a
+privileged and active role (i.e. su or dc), false otherwise.
=item *
X<getsection()>
@@ -11983,6 +12194,19 @@ createcourse($udom,$description,$url,$co
generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community).
+=item *
+
+is_course($courseid), is_course($cdom, $cnum)
+
+Accepts either a combined $courseid (in the form of domain_courseid) or the
+two component version $cdom, $cnum. It checks if the specified course exists.
+
+Returns:
+ undef if the course doesn't exist, otherwise
+ in scalar context the combined courseid.
+ in list context the two components of the course identifier, domain and
+ courseid.
+
=back
=head2 Resource Subroutines
@@ -12051,12 +12275,14 @@ returns the data handle
=item *
-symbverify($symb,$thisfn) : verifies that $symb actually exists and is
-a possible symb for the URL in $thisfn, and if is an encryypted
+symbverify($symb,$thisfn,$encstate) : verifies that $symb actually exists
+and is a possible symb for the URL in $thisfn, and if is an encrypted
resource that the user accessed using /enc/ returns a 1 on success, 0
-on failure, user must be in a course, as it assumes the existance of
-the course initial hash, and uses $env('request.course.id'}
-
+on failure, user must be in a course, as it assumes the existence of
+the course initial hash, and uses $env('request.course.id'}. The third
+arg is an optional reference to a scalar. If this arg is passed in the
+call to symbverify, it will be set to 1 if the symb has been set to be
+encrypted; otherwise it will be null.
=item *