loncom/lonnet/perl/lonnet.pm - diff

Return to lonnet.pm CVS log

Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.1163 and 1.1188

version 1.1163, 2012/04/01 16:19:20	version 1.1188, 2012/08/27 14:33:24
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 vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir	use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease	$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
%managerstab);	%managerstab);
Line 97 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 109 our @ISA = qw (Exporter);	Line 113 our @ISA = qw (Exporter);
our @EXPORT = qw(%env);	our @EXPORT = qw(%env);


# --------------------------------------------------------------------- Logging	# ------------------------------------ Logging (parameters, docs, slots, roles)
{	{
my $logid;	my $logid;
sub instructor_log {	sub write_log {
my ($hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;	my ($context,$hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
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 1236 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 = &current_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 1262 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 = &current_machine_ids();
if (grep(/^\Q$currbalancer\E$/,@hosts)) {	if (grep(/^\Q$currbalancer\E$/,@hosts)) {
$is_balancer = 1;	$is_balancer = 1;
}	}
Line 1350 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 1384 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 1402 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 1535 sub idput {	Line 1556 sub idput {

# ------------------------------dump from db file owned by domainconfig user	# ------------------------------dump from db file owned by domainconfig user
sub dump_dom {	sub dump_dom {
my ($namespace,$udom,$regexp,$range)=@_;	my ($namespace, $udom, $regexp) = @_;
if (!$udom) {
$udom=$env{'user.domain'};	$udom \|\|= $env{'user.domain'};
}
my %returnhash;	return () unless $udom;
if ($udom) {
my $uname = &get_domainconfiguser($udom);	return &dump($namespace, $udom, &get_domainconfiguser($udom), $regexp);
%returnhash = &dump($namespace,$udom,$uname,$regexp,$range);
}
return %returnhash;
}	}

# ------------------------------------------ get items from domain db files	# ------------------------------------------ get items from domain db files
Line 1924 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 1943 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 1955 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 2158 sub getsection {	Line 2180 sub getsection {
# If there is a role which has expired, return it.	# If there is a role which has expired, return it.
#	#
$courseid = &courseid_to_courseurl($courseid);	$courseid = &courseid_to_courseurl($courseid);
my $extra = &freeze_escape({'skipcheck' => 1});	my %roleshash = &dump('roles',$udom,$unam,$courseid);
my %roleshash = &dump('roles',$udom,$unam,$courseid,undef,$extra);
foreach my $key (keys(%roleshash)) {	foreach my $key (keys(%roleshash)) {
next if ($key !~/^\Q$courseid\E(?:\/)(\w+)\_st$/);	next if ($key !~/^\Q$courseid\E(?:\/)(\w+)\_st$/);
my $section=$1;	my $section=$1;
Line 2443 sub repcopy {	Line 2464 sub repcopy {
$filename=~s/\/+/\//g;	$filename=~s/\/+/\//g;
my $londocroot = $perlvar{'lonDocRoot'};	my $londocroot = $perlvar{'lonDocRoot'};
if ($filename=~m{^\Q$londocroot/adm/\E}) { return 'ok'; }	if ($filename=~m{^\Q$londocroot/adm/\E}) { return 'ok'; }
if ($filename=~m{^\Q$londocroot/lonUsers/\E}) { return 'ok'; }	if ($filename=~m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
if ($filename=~m{^\Q$londocroot/userfiles/\E} or	if ($filename=~m{^\Q$londocroot/userfiles/\E} or
$filename=~m{^/*(uploaded\|editupload)/}) {	$filename=~m{^/*(uploaded\|editupload)/}) {
return &repcopy_userfile($filename);	return &repcopy_userfile($filename);
Line 2571 sub ssi {	Line 2592 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 = $response->content;


if (wantarray) {	if (wantarray) {
return ($response->content, $response);	return ($content, $response);
} else {	} else {
return $response->content;	return $content;
}	}
}	}

Line 3033 sub finishuserfileupload {	Line 3056 sub finishuserfileupload {
sub extract_embedded_items {	sub extract_embedded_items {
my ($fullpath,$allfiles,$codebase,$content) = @_;	my ($fullpath,$allfiles,$codebase,$content) = @_;
my @state = ();	my @state = ();
	my (%lastids,%related,%shockwave,%flashvars);
my %javafiles = (	my %javafiles = (
codebase => '',	codebase => '',
code => '',	code => '',
Line 3062 sub extract_embedded_items {	Line 3086 sub extract_embedded_items {
&add_filetype($allfiles,$attr->{'href'},'href');	&add_filetype($allfiles,$attr->{'href'},'href');
}	}
if (lc($tagname) eq 'script') {	if (lc($tagname) eq 'script') {
	my $src;
if ($attr->{'archive'} =~ /\.jar$/i) {	if ($attr->{'archive'} =~ /\.jar$/i) {
&add_filetype($allfiles,$attr->{'archive'},'archive');	&add_filetype($allfiles,$attr->{'archive'},'archive');
} else {	} else {
&add_filetype($allfiles,$attr->{'src'},'src');	if ($attr->{'src'} ne '') {
	$src = $attr->{'src'};
	&add_filetype($allfiles,$src,'src');
	}
	}
	my $text = $p->get_trimmed_text();
	if ($text =~ /\Qswfobject.registerObject(\E([^\)]+)\)/) {
	my @swfargs = split(/,/,$1);
	foreach my $item (@swfargs) {
	$item =~ s/["']//g;
	$item =~ s/^\s+//;
	$item =~ s/\s+$//;
	}
	if (($swfargs[0] ne'') && ($swfargs[2] ne '')) {
	if (ref($related{$swfargs[0]}) eq 'ARRAY') {
	push(@{$related{$swfargs[0]}},$swfargs[2]);
	} else {
	$related{$swfargs[0]} = [$swfargs[2]];
	}
	}
}	}
}	}
if (lc($tagname) eq 'link') {	if (lc($tagname) eq 'link') {
Line 3078 sub extract_embedded_items {	Line 3122 sub extract_embedded_items {
foreach my $item (keys(%javafiles)) {	foreach my $item (keys(%javafiles)) {
$javafiles{$item} = '';	$javafiles{$item} = '';
}	}
	if ((lc($tagname) eq 'object') && (lc($state[-2]) ne 'object')) {
	$lastids{lc($tagname)} = $attr->{'id'};
	}
}	}
if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {	if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {
my $name = lc($attr->{'name'});	my $name = lc($attr->{'name'});
Line 3087 sub extract_embedded_items {	Line 3134 sub extract_embedded_items {
last;	last;
}	}
}	}
	my $pathfrom;
foreach my $item (keys(%mediafiles)) {	foreach my $item (keys(%mediafiles)) {
if ($name eq $item) {	if ($name eq $item) {
&add_filetype($allfiles, $attr->{'value'}, 'value');	$pathfrom = $attr->{'value'};
	$shockwave{$lastids{lc($state[-2])}} = $pathfrom;
	&add_filetype($allfiles,$pathfrom,$name);
last;	last;
}	}
}	}
	if ($name eq 'flashvars') {
	$flashvars{$lastids{lc($state[-2])}} = $attr->{'value'};
	}
	if ($pathfrom ne '') {
	&embedded_dependency($allfiles,\%related,$lastids{lc($state[-2])},
	$pathfrom);
	}
}	}
if (lc($tagname) eq 'embed' \|\| lc($tagname) eq 'applet') {	if (lc($tagname) eq 'embed' \|\| lc($tagname) eq 'applet') {
foreach my $item (keys(%javafiles)) {	foreach my $item (keys(%javafiles)) {
Line 3107 sub extract_embedded_items {	Line 3164 sub extract_embedded_items {
last;	last;
}	}
}	}
	if (lc($tagname) eq 'embed') {
	if (($attr->{'name'} ne '') && ($attr->{'src'} ne '')) {
	&embedded_dependency($allfiles,\%related,$attr->{'name'},
	$attr->{'src'});
	}
	}
}	}
	if ($t->[4] =~ m{/>$}) {
	pop(@state);
	}
} elsif ($t->[0] eq 'E') {	} elsif ($t->[0] eq 'E') {
my ($tagname) = ($t->[1]);	my ($tagname) = ($t->[1]);
if ($javafiles{'codebase'} ne '') {	if ($javafiles{'codebase'} ne '') {
Line 3127 sub extract_embedded_items {	Line 3193 sub extract_embedded_items {
pop @state;	pop @state;
}	}
}	}
	foreach my $id (sort(keys(%flashvars))) {
	if ($shockwave{$id} ne '') {
	my @pairs = split(/\&/,$flashvars{$id});
	foreach my $pair (@pairs) {
	my ($key,$value) = split(/\=/,$pair);
	if ($key eq 'thumb') {
	&add_filetype($allfiles,$value,$key);
	} elsif ($key eq 'content') {
	my ($path) = ($shockwave{$id} =~ m{^(.+/)[^/]+$});
	my ($ext) = ($value =~ /\.([^.]+)$/);
	if ($ext ne '') {
	&add_filetype($allfiles,$path.$value,$ext);
	}
	}
	}
	}
	}
return 'ok';	return 'ok';
}	}

Line 3141 sub add_filetype {	Line 3224 sub add_filetype {
}	}
}	}

	sub embedded_dependency {
	my ($allfiles,$related,$identifier,$pathfrom) = @_;
	if ((ref($allfiles) eq 'HASH') && (ref($related) eq 'HASH')) {
	if (($identifier ne '') &&
	(ref($related->{$identifier}) eq 'ARRAY') &&
	($pathfrom ne '')) {
	my ($path) = ($pathfrom =~ m{^(.+/)[^/]+$});
	foreach my $dep (@{$related->{$identifier}}) {
	&add_filetype($allfiles,$path.$dep,'object');
	}
	}
	}
	return;
	}

sub removeuploadedurl {	sub removeuploadedurl {
my ($url)=@_;	my ($url)=@_;
my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);	my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
Line 3418 sub statslog {	Line 3516 sub statslog {

sub userrolelog {	sub userrolelog {
my ($trole,$username,$domain,$area,$tstart,$tend)=@_;	my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
if (($trole=~/^ca/) \|\| ($trole=~/^aa/) \|\|	if ( $trole =~ /^(ca\|aa\|in\|cc\|ep\|cr\|ta\|co)/ ) {
($trole=~/^in/) \|\| ($trole=~/^cc/) \|\|
($trole=~/^ep/) \|\| ($trole=~/^cr/) \|\|
($trole=~/^ta/) \|\| ($trole=~/^co/)) {
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 (($env{'request.role'} =~ /dc\./) &&	if ($env{'request.role'} =~ /dc\./ && $trole =~ /^(au\|in\|cc\|ep\|cr\|ta\|co)/) {
(($trole=~/^au/) \|\| ($trole=~/^in/) \|\|
($trole=~/^cc/) \|\| ($trole=~/^ep/) \|\|
($trole=~/^cr/) \|\| ($trole=~/^ta/) \|\|
($trole=~/^co/))) {
$userrolehash	$userrolehash
{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}	{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
=$tend.':'.$tstart;	=$tend.':'.$tstart;
}	}
if (($trole=~/^dc/) \|\| ($trole=~/^ad/) \|\|	if ($trole =~ /^(dc\|ad\|li\|au\|dg\|sc)/ ) {
($trole=~/^li/) \|\| ($trole=~/^li/) \|\|
($trole=~/^au/) \|\| ($trole=~/^dg/) \|\|
($trole=~/^sc/)) {
my (undef,$rudom,$runame,$rsec)=split(/\//,$area);	my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
$domainrolehash	$domainrolehash
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}	{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
Line 3449 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_log('course',$namespace,\%storehash,$delflag,$username,
$storehash{'group'} = $sec;	$domain,$cnum,$cdom);
} 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_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 {	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 3548 sub get_my_roles {	Line 3668 sub get_my_roles {
unless (defined($udom)) { $udom=$env{'user.domain'}; }	unless (defined($udom)) { $udom=$env{'user.domain'}; }
my (%dumphash,%nothide);	my (%dumphash,%nothide);
if ($context eq 'userroles') {	if ($context eq 'userroles') {
my $extra = &freeze_escape({'skipcheck' => 1});	%dumphash = &dump('roles',$udom,$uname);
%dumphash = &dump('roles',$udom,$uname,'.',undef,$extra);
} else {	} else {
%dumphash=	%dumphash=
&dump('nohist_userroles',$udom,$uname);	&dump('nohist_userroles',$udom,$uname);
Line 3594 sub get_my_roles {	Line 3713 sub get_my_roles {
}	}
my ($rolecode,$username,$domain,$section,$area);	my ($rolecode,$username,$domain,$section,$area);
if ($context eq 'userroles') {	if ($context eq 'userroles') {
($area,$rolecode) = split(/_/,$entry);	($area,$rolecode) = ($entry =~ /^(.+)_([^_]+)$/);
(undef,$domain,$username,$section) = split(/\//,$area);	(undef,$domain,$username,$section) = split(/\//,$area);
} else {	} else {
($role,$username,$domain,$section) = split(/\:/,$entry);	($role,$username,$domain,$section) = split(/\:/,$entry);
Line 3745 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 3898 my $cachedtime=();	Line 4031 my $cachedtime=();
sub load_all_first_access {	sub load_all_first_access {
my ($uname,$udom)=@_;	my ($uname,$udom)=@_;
if (($cachedkey eq $uname.':'.$udom) &&	if (($cachedkey eq $uname.':'.$udom) &&
(abs($cachedtime-time)<5)) {	(abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) {
return;	return;
}	}
$cachedtime=time;	$cachedtime=time;
Line 4542 sub update_released_required {	Line 4675 sub update_released_required {

sub privileged {	sub privileged {
my ($username,$domain)=@_;	my ($username,$domain)=@_;
my $rolesdump=&reply("dump:$domain:$username:roles",
&homeserver($username,$domain));	my %rolesdump = &dump("roles", $domain, $username) or return 0;
if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '') \|\|	my $now = time;
($rolesdump =~ /^error:/)) {
return 0;	for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {
}	my ($trole, $tend, $tstart) = split(/_/, $role);
my $now=time;	if (($trole eq 'dc') \|\| ($trole eq 'su')) {
if ($rolesdump ne '') {	return 1 unless ($tend && $tend < $now)
foreach my $entry (split(/&/,$rolesdump)) {	or ($tstart && $tstart > $now);
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; }
}
}
}	}
}
return 0;	return 0;
}	}

# -------------------------------------------------------- Get user privileges	# -------------------------------------------------------- Get user privileges

sub rolesinit {	sub rolesinit {
my ($domain,$username,$authhost)=@_;	my ($domain, $username) = @_;
my $now=time;	my %userroles = ('user.login.time' => time);
my %userroles = ('user.login.time' => $now);	my %rolesdump = &dump("roles", $domain, $username) or return \%userroles;
my $extra = &freeze_escape({'skipcheck' => 1});
my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost);	# firstaccess and timerinterval are related to timed maps/resources.
if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '') \|\|	# also, blocking can be triggered by an activating timer
($rolesdump =~ /^error:/)) {	# it's saved in the user's %env.
return \%userroles;	my %firstaccess = &dump('firstaccesstimes', $domain, $username);
}	my %timerinterval = &dump('timerinterval', $domain, $username);
my %firstaccess = &dump('firstaccesstimes',$domain,$username);	my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,
my %timerinterval = &dump('timerinterval',$domain,$username);	%timerintchk, %timerintenv);
my (%coursetimerstarts,%firstaccchk,%firstaccenv,
%coursetimerintervals,%timerintchk,%timerintenv);
foreach my $key (keys(%firstaccess)) {	foreach my $key (keys(%firstaccess)) {
my ($cid,$rest) = split(/\0/,$key);	my ($cid, $rest) = split(/\0/, $key);
$coursetimerstarts{$cid}{$rest} = $firstaccess{$key};	$coursetimerstarts{$cid}{$rest} = $firstaccess{$key};
}	}

foreach my $key (keys(%timerinterval)) {	foreach my $key (keys(%timerinterval)) {
my ($cid,$rest) = split(/\0/,$key);	my ($cid,$rest) = split(/\0/,$key);
$coursetimerintervals{$cid}{$rest} = $timerinterval{$key};	$coursetimerintervals{$cid}{$rest} = $timerinterval{$key};
}	}

my %allroles=();	my %allroles=();
my %allgroups=();	my %allgroups=();

if ($rolesdump ne '') {	for my $area (grep { ! /^rolesdef_/ } keys %rolesdump) {
foreach my $entry (split(/&/,$rolesdump)) {	my $role = $rolesdump{$area};
if ($entry!~/^rolesdef_/) {	$area =~ s/\_\w\w$//;
my ($area,$role)=split(/=/,$entry);
$area=~s/\_\w\w$//;	my ($trole, $tend, $tstart, $group_privs);
my ($trole,$tend,$tstart,$group_privs);
if ($role=~/^cr/) {	if ($role =~ /^cr/) {
if ($role=~m\|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$\|) {	# Custom role, defined by a user
($trole,my $trest)=($role=~m\|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$\|);	# e.g., user.role.cr/msu/smith/mynewrole
($tend,$tstart)=split('_',$trest);	if ($role =~ m\|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$\|) {
} else {	$trole = $1;
$trole=$role;	($tend, $tstart) = split('_', $2);
}	} else {
} elsif ($role =~ m\|^gr/\|) {	$trole = $role;
($trole,$tend,$tstart) = split(/_/,$role);	}
next if ($tstart eq '-1');	} elsif ($role =~ m\|^gr/\|) {
($trole,$group_privs) = split(/\//,$trole);	# Role of member in a group, defined within a course/community
$group_privs = &unescape($group_privs);	# e.g., user.role.gr/msu/04935610a19ee4a5fmsul1/leopards
} else {	($trole, $tend, $tstart) = split(/_/, $role);
($trole,$tend,$tstart)=split(/_/,$role);	next if $tstart eq '-1';
}	($trole, $group_privs) = split(/\//, $trole);
my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,	$group_privs = &unescape($group_privs);
$username);	} else {
@userroles{keys(%new_role)} = @new_role{keys(%new_role)};	# Just a normal role, defined in roles.tab
if (($tend!=0) && ($tend<$now)) { $trole=''; }	($trole, $tend, $tstart) = split(/_/,$role);
if (($tstart!=0) && ($tstart>$now)) { $trole=''; }	}
if (($area ne '') && ($trole ne '')) {
my $spec=$trole.'.'.$area;	my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
my ($tdummy,$tdomain,$trest)=split(/\//,$area);	$username);
if ($trole =~ /^cr\//) {	@userroles{keys(%new_role)} = @new_role{keys(%new_role)};
&custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
} elsif ($trole eq 'gr') {	# role expired or not available yet?
&group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);	$trole = '' if ($tend != 0 && $tend < $userroles{'user.login.time'}) or
} else {	($tstart != 0 && $tstart > $userroles{'user.login.time'});
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
}	next if $area eq '' or $trole eq '';
if ($trole ne 'gr') {
my $cid = $tdomain.'_'.$trest;	my $spec = "$trole.$area";
unless ($firstaccchk{$cid}) {	my ($tdummy, $tdomain, $trest) = split(/\//, $area);
if (ref($coursetimerstarts{$cid}) eq 'HASH') {
foreach my $item (keys(%{$coursetimerstarts{$cid}})) {	if ($trole =~ /^cr\//) {
$firstaccenv{'course.'.$cid.'.firstaccess.'.$item} =	# Custom role, defined by a user
$coursetimerstarts{$cid}{$item};	&custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
}	} elsif ($trole eq 'gr') {
}	# Role of a member in a group, defined within a course/community
$firstaccchk{$cid} = 1;	&group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
}	next;
unless ($timerintchk{$cid}) {	} else {
if (ref($coursetimerintervals{$cid}) eq 'HASH') {	# Normal role, defined in roles.tab
foreach my $item (keys(%{$coursetimerintervals{$cid}})) {	&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
$timerintenv{'course.'.$cid.'.timerinterval.'.$item} =	}
$coursetimerintervals{$cid}{$item};
}	my $cid = $tdomain.'_'.$trest;
}	unless ($firstaccchk{$cid}) {
$timerintchk{$cid} = 1;	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);	return (\%userroles,\%firstaccenv,\%timerintenv);
}	}

Line 4917 sub delete_env_groupprivs {	Line 5049 sub delete_env_groupprivs {
sub check_adhoc_privs {	sub check_adhoc_privs {
my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;	my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;
my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;	my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
	my $setprivs;
if ($env{$cckey}) {	if ($env{$cckey}) {
my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);	my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
&role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);	&role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
unless (($tstatus eq 'is') \|\| ($tstatus eq 'will_not')) {	unless (($tstatus eq 'is') \|\| ($tstatus eq 'will_not')) {
&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);	&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
	$setprivs = 1;
}	}
} else {	} else {
&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);	&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
	$setprivs = 1;
}	}
	return $setprivs;
}	}

sub set_adhoc_privileges {	sub set_adhoc_privileges {
Line 4997 sub del {	Line 5133 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,$extra)=@_;	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 {
$regexp='.';	$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 @pairs=split(/\&/,$rep);
my %returnhash=();	my %returnhash=();
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 5026 sub dump {	Line 5189 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 5068 sub currentdump {	Line 5217 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 5566 sub usertools_access {	Line 5723 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 5584 sub usertools_access {	Line 5746 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 5668 sub usertools_access {	Line 5837 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 7217 sub get_users_groups {	Line 7386 sub get_users_groups {
} else {	} else {
$grouplist = '';	$grouplist = '';
my $courseurl = &courseid_to_courseurl($courseid);	my $courseurl = &courseid_to_courseurl($courseid);
my $extra = &freeze_escape({'skipcheck' => 1});	my %roleshash = &dump('roles',$udom,$uname,$courseurl);
my %roleshash = &dump('roles',$udom,$uname,$courseurl,undef,$extra);
my $access_end = $env{'course.'.$courseid.	my $access_end = $env{'course.'.$courseid.
'.default_enrollment_end_date'};	'.default_enrollment_end_date'};
my $now = time;	my $now = time;
Line 7390 sub assignrole {	Line 7558 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 7440 sub assignrole {	Line 7643 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 8031 sub generate_coursenum {	Line 8248 sub generate_coursenum {
}	}

sub is_course {	sub is_course {
my ($cdom,$cnum) = @_;	my ($cdom, $cnum) = scalar(@_) == 1 ?
my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,	($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_;
undef,'.');
if (exists($courses{$cdom.'_'.$cnum})) {	return unless $cdom and $cnum;
return 1;
}	my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,
return 0;	'.');

	return unless exists($courses{$cdom.'_'.$cnum});
	return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
}	}

sub store_userdata {	sub store_userdata {
Line 9736 sub devalidate_slots_cache {	Line 9956 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 9880 sub deversion {	Line 10135 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'}) {
Line 10440 sub repcopy_userfile {	Line 10699 sub repcopy_userfile {
my ($file)=@_;	my ($file)=@_;
my $londocroot = $perlvar{'lonDocRoot'};	my $londocroot = $perlvar{'lonDocRoot'};
if ($file =~ m{^/*(uploaded\|editupload)/}) { $file=&filelocation("",$file); }	if ($file =~ m{^/*(uploaded\|editupload)/}) { $file=&filelocation("",$file); }
if ($file =~ m{^\Q$londocroot/lonUsers/\E}) { return 'ok'; }	if ($file =~ m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
my ($cdom,$cnum,$filename) =	my ($cdom,$cnum,$filename) =
($file=~m\|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)\|);	($file=~m\|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)\|);
my $uri="/uploaded/$cdom/$cnum/$filename";	my $uri="/uploaded/$cdom/$cnum/$filename";
Line 10697 sub declutter {	Line 10956 sub declutter {
$thisfn=~s\|^adm/wrapper/\|\|;	$thisfn=~s\|^adm/wrapper/\|\|;
$thisfn=~s\|^adm/coursedocs/showdoc/\|\|;	$thisfn=~s\|^adm/coursedocs/showdoc/\|\|;
$thisfn=~s/^res\///;	$thisfn=~s/^res\///;
	$thisfn=~s/^priv\///;
unless (($thisfn =~ /^ext/) \|\| ($thisfn =~ /\.(page\|sequence)___\d+___ext/)) {	unless (($thisfn =~ /^ext/) \|\| ($thisfn =~ /\.(page\|sequence)___\d+___ext/)) {
$thisfn=~s/\?.+$//;	$thisfn=~s/\?.+$//;
}	}
Line 11615 B<idput($udom,%ids)>: store away a list	Line 11875 B<idput($udom,%ids)>: store away a list

=item *	=item *
X<rolesinit()>	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 *	=item *
X<getsection()>	X<getsection()>
Line 11908 createcourse($udom,$description,$url,$co	Line 12174 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).	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	=back

=head2 Resource Subroutines	=head2 Resource Subroutines

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

Removed from v.1.1163
changed lines
	Added in v.1.1188