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.997 and 1.1048

version 1.997, 2009/05/08 01:43:50	version 1.1048, 2009/12/30 18:01:17
Line 92 use Time::HiRes qw( gettimeofday tv_inte	Line 92 use Time::HiRes qw( gettimeofday tv_inte
use Cache::Memcached;	use Cache::Memcached;
use Digest::MD5;	use Digest::MD5;
use Math::Random;	use Math::Random;
	use File::MMagic;
use LONCAPA qw(:DEFAULT :match);	use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;	use LONCAPA::Configuration;

Line 718 sub spareserver {	Line 719 sub spareserver {
if ($protocol{$spare_server} eq 'https') {	if ($protocol{$spare_server} eq 'https') {
$protocol = $protocol{$spare_server};	$protocol = $protocol{$spare_server};
}	}
$spare_server = $protocol.'://'.&hostname($spare_server);	if (defined($spare_server)) {
	my $hostname = &hostname($spare_server);
	if (defined($hostname)) {
	$spare_server = $protocol.'://'.$hostname;
	}
	}
}	}
return $spare_server;	return $spare_server;
}	}
Line 779 sub changepass {	Line 785 sub changepass {
my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;	my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
$currentpass = &escape($currentpass);	$currentpass = &escape($currentpass);
$newpass = &escape($newpass);	$newpass = &escape($newpass);
my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context",	my $lonhost = $perlvar{'lonHostID'};
	my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context:$lonhost",
$server);	$server);
if (! $answer) {	if (! $answer) {
&logthis("No reply on password change request to $server ".	&logthis("No reply on password change request to $server ".
Line 804 sub changepass {	Line 811 sub changepass {
} elsif ($answer =~ "^refused") {	} elsif ($answer =~ "^refused") {
&logthis("$server refused to change $uname in $udom password because ".	&logthis("$server refused to change $uname in $udom password because ".
"it was sent an unencrypted request to change the password.");	"it was sent an unencrypted request to change the password.");
	} elsif ($answer =~ "invalid_client") {
	&logthis("$server refused to change $uname in $udom password because ".
	"it was a reset by e-mail originating from an invalid server.");
}	}
return $answer;	return $answer;
}	}
Line 953 sub idput {	Line 963 sub idput {
}	}
}	}

# ------------------------------------------- get items from domain db files	# ------------------------------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;
	}

	# ------------------------------------------ get items from domain db files

sub get_dom {	sub get_dom {
my ($namespace,$storearr,$udom,$uhome)=@_;	my ($namespace,$storearr,$udom,$uhome)=@_;
Line 1027 sub put_dom {	Line 1051 sub put_dom {
}	}
}	}

	# --------------------- newput for items in db file owned by domainconfig user
	sub newput_dom {
	my ($namespace,$storehash,$udom) = @_;
	my $result;
	if (!$udom) {
	$udom=$env{'user.domain'};
	}
	if ($udom) {
	my $uname = &get_domainconfiguser($udom);
	$result = &newput($namespace,$storehash,$udom,$uname);
	}
	return $result;
	}

	# --------------------- delete for items in db file owned by domainconfig user
	sub del_dom {
	my ($namespace,$storearr,$udom)=@_;
	if (ref($storearr) eq 'ARRAY') {
	if (!$udom) {
	$udom=$env{'user.domain'};
	}
	if ($udom) {
	my $uname = &get_domainconfiguser($udom);
	return &del($namespace,$storearr,$udom,$uname);
	}
	}
	}

	# ----------------------------------construct domainconfig user for a domain
	sub get_domainconfiguser {
	my ($udom) = @_;
	return $udom.'-domainconfig';
	}

sub retrieve_inst_usertypes {	sub retrieve_inst_usertypes {
my ($udom) = @_;	my ($udom) = @_;
my (%returnhash,@order);	my (%returnhash,@order);
Line 1295 sub get_domain_defaults {	Line 1353 sub get_domain_defaults {
my %domdefaults;	my %domdefaults;
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['defaults','quotas',	&Apache::lonnet::get_dom('configuration',['defaults','quotas',
'requestcourses','inststatus'],$domain);	'requestcourses','inststatus',
	'coursedefaults'],$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 1321 sub get_domain_defaults {	Line 1380 sub get_domain_defaults {
}	}
}	}
if (ref($domconfig{'requestcourses'}) eq 'HASH') {	if (ref($domconfig{'requestcourses'}) eq 'HASH') {
foreach my $item ('official','unofficial') {	foreach my $item ('official','unofficial','community') {
$domdefaults{$item} = $domconfig{'requestcourses'}{$item};	$domdefaults{$item} = $domconfig{'requestcourses'}{$item};
}	}
}	}
Line 1330 sub get_domain_defaults {	Line 1389 sub get_domain_defaults {
$domdefaults{$item} = $domconfig{'inststatus'}{$item};	$domdefaults{$item} = $domconfig{'inststatus'}{$item};
}	}
}	}
	if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
	foreach my $item ('canuse_pdfforms') {
	$domdefaults{$item} = $domconfig{'coursedefaults'}{$item};
	}
	}
&Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,	&Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
$cachetime);	$cachetime);
return %domdefaults;	return %domdefaults;
Line 1660 sub userenvironment {	Line 1724 sub userenvironment {
}	}
$items=~s/\&$//;	$items=~s/\&$//;
my %returnhash=();	my %returnhash=();
my @answer=split(/\&/,	my $uhome = &homeserver($unam,$udom);
&reply('get:'.$udom.':'.$unam.':environment:'.$items,	unless ($uhome eq 'no_host') {
&homeserver($unam,$udom)));	my @answer=split(/\&/,
my $i;	&reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome));
for ($i=0;$i<=$#what;$i++) {	if ($#answer==0 && $answer[0] =~ /^(con_lost\|error:\|no_such_host)/i) {
$returnhash{$what[$i]}=&unescape($answer[$i]);	return %returnhash;
	}
	my $i;
	for ($i=0;$i<=$#what;$i++) {
	$returnhash{$what[$i]}=&unescape($answer[$i]);
	}
}	}
return %returnhash;	return %returnhash;
}	}
Line 1861 sub ssi_body {	Line 1930 sub ssi_body {
if ($filelink=~/^https?\:/) {	if ($filelink=~/^https?\:/) {
($output,$response)=&externalssi($filelink);	($output,$response)=&externalssi($filelink);
} else {	} else {
	$filelink .= $filelink=~/\?/ ? '&' : '?';
	$filelink .= 'inhibitmenu=yes';
($output,$response)=&ssi($filelink,%form);	($output,$response)=&ssi($filelink,%form);
}	}
$output=~s\|//(\s<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s(-->)?\s\|\|gs;	$output=~s\|//(\s<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s(-->)?\s\|\|gs;
Line 1904 sub ssi {	Line 1975 sub ssi {
&Apache::lonenc::check_encrypt(\$fn);	&Apache::lonenc::check_encrypt(\$fn);
if (%form) {	if (%form) {
$request=new HTTP::Request('POST',&absolute_url().$fn);	$request=new HTTP::Request('POST',&absolute_url().$fn);
$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));	$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form)));
} else {	} else {
$request=new HTTP::Request('GET',&absolute_url().$fn);	$request=new HTTP::Request('GET',&absolute_url().$fn);
}	}
Line 2002 sub process_coursefile {	Line 2073 sub process_coursefile {
print $fh $env{'form.'.$source};	print $fh $env{'form.'.$source};
close($fh);	close($fh);
if ($parser eq 'parse') {	if ($parser eq 'parse') {
my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);	my $mm = new File::MMagic;
unless ($parse_result eq 'ok') {	my $mime_type = $mm->checktype_filename($filepath.'/'.$fname);
&logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);	if ($mime_type eq 'text/html') {
	my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);
	unless ($parse_result eq 'ok') {
	&logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
	}
}	}
}	}
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,	$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
Line 2246 sub finishuserfileupload {	Line 2321 sub finishuserfileupload {
}	}
}	}
if ($parser eq 'parse') {	if ($parser eq 'parse') {
my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles,	my $mm = new File::MMagic;
$codebase);	my $mime_type = $mm->checktype_filename($filepath.'/'.$file);
unless ($parse_result eq 'ok') {	if ($mime_type eq 'text/html') {
&logthis('Failed to parse '.$filepath.$file.	my $parse_result = &extract_embedded_items($filepath.'/'.$file,
' for embedded media: '.$parse_result);	$allfiles,$codebase);
	unless ($parse_result eq 'ok') {
	&logthis('Failed to parse '.$filepath.$file.
	' for embedded media: '.$parse_result);
	}
}	}
}	}
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {	if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
Line 2554 sub flushcourselogs {	Line 2633 sub flushcourselogs {
# Reverse lookup of domain roles (dc, ad, li, sc, au)	# Reverse lookup of domain roles (dc, ad, li, sc, au)
#	#
my %domrolebuffer = ();	my %domrolebuffer = ();
foreach my $entry (keys %domainrolehash) {	foreach my $entry (keys(%domainrolehash)) {
my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry);	my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry);
if ($domrolebuffer{$rudom}) {	if ($domrolebuffer{$rudom}) {
$domrolebuffer{$rudom}.='&'.&escape($entry).	$domrolebuffer{$rudom}.='&'.&escape($entry).
Line 2659 sub userrolelog {	Line 2738 sub userrolelog {
if (($trole=~/^ca/) \|\| ($trole=~/^aa/) \|\|	if (($trole=~/^ca/) \|\| ($trole=~/^aa/) \|\|
($trole=~/^in/) \|\| ($trole=~/^cc/) \|\|	($trole=~/^in/) \|\| ($trole=~/^cc/) \|\|
($trole=~/^ep/) \|\| ($trole=~/^cr/) \|\|	($trole=~/^ep/) \|\| ($trole=~/^cr/) \|\|
($trole=~/^ta/)) {	($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}
Line 2668 sub userrolelog {	Line 2747 sub userrolelog {
if (($env{'request.role'} =~ /dc\./) &&	if (($env{'request.role'} =~ /dc\./) &&
(($trole=~/^au/) \|\| ($trole=~/^in/) \|\|	(($trole=~/^au/) \|\| ($trole=~/^in/) \|\|
($trole=~/^cc/) \|\| ($trole=~/^ep/) \|\|	($trole=~/^cc/) \|\| ($trole=~/^ep/) \|\|
($trole=~/^cr/) \|\| ($trole=~/^ta/))) {	($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;
Line 2689 sub courserolelog {	Line 2769 sub courserolelog {
if (($trole eq 'cc') \|\| ($trole eq 'in') \|\|	if (($trole eq 'cc') \|\| ($trole eq 'in') \|\|
($trole eq 'ep') \|\| ($trole eq 'ad') \|\|	($trole eq 'ep') \|\| ($trole eq 'ad') \|\|
($trole eq 'ta') \|\| ($trole eq 'st') \|\|	($trole eq 'ta') \|\| ($trole eq 'st') \|\|
($trole=~/^cr/) \|\| ($trole eq 'gr')) {	($trole=~/^cr/) \|\| ($trole eq 'gr') \|\|
	($trole eq 'co')) {
if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {	if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
my $cdom = $1;	my $cdom = $1;
my $cnum = $2;	my $cnum = $2;
Line 2735 sub get_course_adv_roles {	Line 2816 sub get_course_adv_roles {
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});	&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
my $now=time;	my $now=time;
my %privileged;	my %privileged;
foreach my $entry (keys %dumphash) {	foreach my $entry (keys(%dumphash)) {
my ($tend,$tstart)=split(/\:/,$dumphash{$entry});	my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
if (($tstart) && ($tstart<0)) { next; }	if (($tstart) && ($tstart<0)) { next; }
if (($tend) && ($tend<$now)) { next; }	if (($tend) && ($tend<$now)) { next; }
Line 2744 sub get_course_adv_roles {	Line 2825 sub get_course_adv_roles {
if ($username eq '' \|\| $domain eq '') { next; }	if ($username eq '' \|\| $domain eq '') { next; }
unless (ref($privileged{$domain}) eq 'HASH') {	unless (ref($privileged{$domain}) eq 'HASH') {
my %dompersonnel =	my %dompersonnel =
&Apache::lonnet::get_domain_roles($domain,['dc'],undef,$now);	&Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
$privileged{$domain} = {};	$privileged{$domain} = {};
foreach my $server (keys(%dompersonnel)) {	foreach my $server (keys(%dompersonnel)) {
if(ref($dompersonnel{$server}) eq 'HASH') {	if (ref($dompersonnel{$server}) eq 'HASH') {
foreach my $user (keys(%{$dompersonnel{$server}})) {	foreach my $user (keys(%{$dompersonnel{$server}})) {
my ($trole,$uname,$udom) = split(/:/,$user);	my ($trole,$uname,$udom) = split(/:/,$user);
$privileged{$udom}{$uname} = 1;	$privileged{$udom}{$uname} = 1;
Line 2801 sub get_my_roles {	Line 2882 sub get_my_roles {
}	}
my %returnhash=();	my %returnhash=();
my $now=time;	my $now=time;
	my %privileged;
foreach my $entry (keys(%dumphash)) {	foreach my $entry (keys(%dumphash)) {
my ($role,$tend,$tstart);	my ($role,$tend,$tstart);
if ($context eq 'userroles') {	if ($context eq 'userroles') {
Line 2849 sub get_my_roles {	Line 2931 sub get_my_roles {
}	}
}	}
if ($hidepriv) {	if ($hidepriv) {
if ((&privileged($username,$domain)) &&	if ($context eq 'userroles') {
(!$nothide{$username.':'.$domain})) {	if ((&privileged($username,$domain)) &&
next;	(!$nothide{$username.':'.$domain})) {
	next;
	}
	} else {
	unless (ref($privileged{$domain}) eq 'HASH') {
	my %dompersonnel =
	&Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
	$privileged{$domain} = {};
	if (keys(%dompersonnel)) {
	foreach my $server (keys(%dompersonnel)) {
	if (ref($dompersonnel{$server}) eq 'HASH') {
	foreach my $user (keys(%{$dompersonnel{$server}})) {
	my ($trole,$uname,$udom) = split(/:/,$user);
	$privileged{$udom}{$uname} = $trole;
	}
	}
	}
	}
	}
	if (exists($privileged{$domain}{$username})) {
	if (!$nothide{$username.':'.$domain}) {
	next;
	}
	}
}	}
}	}
if ($withsec) {	if ($withsec) {
Line 2937 sub courseidput {	Line 3042 sub courseidput {
sub courseiddump {	sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,	my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,	$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
$selfenrollonly,$catfilter,$showhidden,$caller)=@_;	$selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
	$cloneonly,$createdbefore,$createdafter,$creationcontext)=@_;
my $as_hash = 1;	my $as_hash = 1;
my %returnhash;	my %returnhash;
if (!$domfilter) { $domfilter=''; }	if (!$domfilter) { $domfilter=''; }
Line 2956 sub courseiddump {	Line 3062 sub courseiddump {
':'.&escape($coursefilter).':'.&escape($typefilter).	':'.&escape($coursefilter).':'.&escape($typefilter).
':'.&escape($regexp_ok).':'.$as_hash.':'.	':'.&escape($regexp_ok).':'.$as_hash.':'.
&escape($selfenrollonly).':'.&escape($catfilter).':'.	&escape($selfenrollonly).':'.&escape($catfilter).':'.
$showhidden.':'.$caller,$tryserver);	$showhidden.':'.$caller.':'.&escape($cloner).':'.
	&escape($cc_clone).':'.$cloneonly.':'.
	&escape($createdbefore).':'.&escape($createdafter).':'.
	&escape($creationcontext),$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 2971 sub courseiddump {	Line 3080 sub courseiddump {
for (my $i=0; $i<@responses; $i++) {	for (my $i=0; $i<@responses; $i++) {
$returnhash{$key}{$items[$i]} = &unescape($responses[$i]);	$returnhash{$key}{$items[$i]} = &unescape($responses[$i]);
}	}
}	}
}	}
}	}
}	}
Line 3011 sub dcmaildump {	Line 3120 sub dcmaildump {

sub get_domain_roles {	sub get_domain_roles {
my ($dom,$roles,$startdate,$enddate)=@_;	my ($dom,$roles,$startdate,$enddate)=@_;
if (undef($startdate) \|\| $startdate eq '') {	if ((!defined($startdate)) \|\| ($startdate eq '')) {
$startdate = '.';	$startdate = '.';
}	}
if (undef($enddate) \|\| $enddate eq '') {	if ((!defined($enddate)) \|\| ($enddate eq '')) {
$enddate = '.';	$enddate = '.';
}	}
my $rolelist;	my $rolelist;
Line 3421 sub tmpreset {	Line 3530 sub tmpreset {
if (tie(%hash,'GDBM_File',	if (tie(%hash,'GDBM_File',
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',	$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
&GDBM_WRCREAT(),0640)) {	&GDBM_WRCREAT(),0640)) {
foreach my $key (keys %hash) {	foreach my $key (keys(%hash)) {
if ($key=~ /:$symb/) {	if ($key=~ /:$symb/) {
delete($hash{$key});	delete($hash{$key});
}	}
Line 3704 sub privileged {	Line 3813 sub privileged {
my ($username,$domain)=@_;	my ($username,$domain)=@_;
my $rolesdump=&reply("dump:$domain:$username:roles",	my $rolesdump=&reply("dump:$domain:$username:roles",
&homeserver($username,$domain));	&homeserver($username,$domain));
if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '')) { return 0; }	if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '') \|\|
	($rolesdump =~ /^error:/)) {
	return 0;
	}
my $now=time;	my $now=time;
if ($rolesdump ne '') {	if ($rolesdump ne '') {
foreach my $entry (split(/&/,$rolesdump)) {	foreach my $entry (split(/&/,$rolesdump)) {
Line 3732 sub privileged {	Line 3844 sub privileged {

sub rolesinit {	sub rolesinit {
my ($domain,$username,$authhost)=@_;	my ($domain,$username,$authhost)=@_;
my %userroles;	my $now=time;
	my %userroles = ('user.login.time' => $now);
my $rolesdump=reply("dump:$domain:$username:roles",$authhost);	my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '')) { return \%userroles; }	if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '') \|\|
	($rolesdump =~ /^error:/)) {
	return \%userroles;
	}
my %allroles=();	my %allroles=();
my %allgroups=();	my %allgroups=();
my $now=time;
%userroles = ('user.login.time' => $now);
my $group_privs;	my $group_privs;

if ($rolesdump ne '') {	if ($rolesdump ne '') {
Line 3804 sub custom_roleprivs {	Line 3918 sub custom_roleprivs {
if (($rdummy ne 'con_lost') && ($roledef ne '')) {	if (($rdummy ne 'con_lost') && ($roledef ne '')) {
my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef);	my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef);
if (defined($syspriv)) {	if (defined($syspriv)) {
	if ($trest =~ /^$match_community$/) {
	$syspriv =~ s/bre\&S//;
	}
$$allroles{'cm./'}.=':'.$syspriv;	$$allroles{'cm./'}.=':'.$syspriv;
$$allroles{$spec.'./'}.=':'.$syspriv;	$$allroles{$spec.'./'}.=':'.$syspriv;
}	}
Line 3857 sub set_userprivs {	Line 3974 sub set_userprivs {
my $adv=0;	my $adv=0;
my %grouproles = ();	my %grouproles = ();
if (keys(%{$allgroups}) > 0) {	if (keys(%{$allgroups}) > 0) {
foreach my $role (keys %{$allroles}) {	foreach my $role (keys(%{$allroles})) {
my ($trole,$area,$sec,$extendedarea);	my ($trole,$area,$sec,$extendedarea);
if ($role =~ m-^(\w+\|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {	if ($role =~ m-^(\w+\|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {
$trole = $1;	$trole = $1;
Line 3901 sub set_userprivs {	Line 4018 sub set_userprivs {
}	}

sub role_status {	sub role_status {
my ($rolekey,$then,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;	my ($rolekey,$then,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
my @pwhere = ();	my @pwhere = ();
if (exists($env{$rolekey}) && $env{$rolekey} ne '') {	if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
(undef,undef,$$role,@pwhere)=split(/\./,$rolekey);	(undef,undef,$$role,@pwhere)=split(/\./,$rolekey);
Line 3912 sub role_status {	Line 4029 sub role_status {
$$tstatus='is';	$$tstatus='is';
if ($$tstart && $$tstart>$then) {	if ($$tstart && $$tstart>$then) {
$$tstatus='future';	$$tstatus='future';
if ($$tstart<$now) { $$tstatus='will'; }	if ($$tstart<$now) {
	if ($$tstart && $$tstart>$refresh) {
	if (($$where ne '') && ($$role ne '')) {
	my (%allroles,%allgroups,$group_privs);
	my %userroles = (
	'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend
	);
	my $spec=$$role.'.'.$$where;
	my ($tdummy,$tdomain,$trest)=split(/\//,$$where);
	if ($$role eq 'gr') {
	my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},
	$env{'user.name'})=@_;
	my ($trole) = split('_',$role,1);
	(undef,my $group_privs) = split(/\//,$trole);
	$group_privs = &unescape($group_privs);
	}
	if ($$role =~ /^cr\//) {
	&custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where);
	} elsif ($$role eq 'gr') {
	my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},
	$env{'user.name'});
	my $trole = split('_',$rolehash{$$where.'_'.$$role},1);
	(undef,my $group_privs) = split(/\//,$trole);
	$group_privs = &unescape($group_privs);
	&group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);
	} else {
	&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
	}
	my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups);
	&appenv(\%userroles,[$$role,'cm']);
	&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
	}
	}
	$$tstatus = 'is';
	}
}	}
if ($$tend) {	if ($$tend) {
if ($$tend<$then) {	if ($$tend<$then) {
Line 3926 sub role_status {	Line 4077 sub role_status {
}	}

sub check_adhoc_privs {	sub check_adhoc_privs {
my ($cdom,$cnum,$then,$now,$checkrole) = @_;	my ($cdom,$cnum,$then,$refresh,$now,$checkrole) = @_;
my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;	my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
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,$then,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);	&role_status($cckey,$then,$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);	&set_adhoc_privileges($cdom,$cnum,$checkrole);
}	}
Line 4570 sub usertools_access {	Line 4721 sub usertools_access {
%tools = (	%tools = (
official => 1,	official => 1,
unofficial => 1,	unofficial => 1,
	community => 1,
);	);
} else {	} else {
%tools = (	%tools = (
Line 4602 sub usertools_access {	Line 4754 sub usertools_access {
$toolstatus = $env{'environment.'.$context.'.'.$tool};	$toolstatus = $env{'environment.'.$context.'.'.$tool};
$inststatus = $env{'environment.inststatus'};	$inststatus = $env{'environment.inststatus'};
} else {	} else {
my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool);	my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');
$toolstatus = $userenv{$context.'.'.$tool};	$toolstatus = $userenv{$context.'.'.$tool};
$inststatus = $userenv{'inststatus'};	$inststatus = $userenv{'inststatus'};
}	}
Line 4703 sub is_advanced_user {	Line 4855 sub is_advanced_user {
return $is_adv;	return $is_adv;
}	}

	sub check_can_request {
	my ($dom,$can_request,$request_domains) = @_;
	my $canreq = 0;
	my ($types,$typename) = &Apache::loncommon::course_types();
	my @options = ('approval','validate','autolimit');
	my $optregex = join('\|',@options);
	if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
	foreach my $type (@{$types}) {
	if (&usertools_access($env{'user.name'},
	$env{'user.domain'},
	$type,undef,'requestcourses')) {
	$canreq ++;
	if (ref($request_domains) eq 'HASH') {
	push(@{$request_domains->{$type}},$env{'user.domain'});
	}
	if ($dom eq $env{'user.domain'}) {
	$can_request->{$type} = 1;
	}
	}
	if ($env{'environment.reqcrsotherdom.'.$type} ne '') {
	my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});
	if (@curr > 0) {
	foreach my $item (@curr) {
	if (ref($request_domains) eq 'HASH') {
	my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);
	if ($otherdom ne '') {
	if (ref($request_domains->{$type}) eq 'ARRAY') {
	unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {
	push(@{$request_domains->{$type}},$otherdom);
	}
	} else {
	push(@{$request_domains->{$type}},$otherdom);
	}
	}
	}
	}
	unless($dom eq $env{'user.domain'}) {
	$canreq ++;
	if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {
	$can_request->{$type} = 1;
	}
	}
	}
	}
	}
	}
	return $canreq;
	}

# ---------------------------------------------- Custom access rule evaluation	# ---------------------------------------------- Custom access rule evaluation

sub customaccess {	sub customaccess {
Line 4857 sub allowed {	Line 5058 sub allowed {
my $statecond=0;	my $statecond=0;
my $courseprivid='';	my $courseprivid='';

	my $ownaccess;
	# Community Coordinator or Assistant Co-author browsing resource space.
	if (($priv eq 'bro') && ($env{'user.author'})) {
	if ($uri eq '') {
	$ownaccess = 1;
	} else {
	if (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) {
	my $udom = $env{'user.domain'};
	my $uname = $env{'user.name'};
	if ($uri =~ m{^\Q$udom\E/?$}) {
	$ownaccess = 1;
	} elsif ($uri =~ m{^\Q$udom\E/\Q$uname\E/?}) {
	unless ($uri =~ m{\.\./}) {
	$ownaccess = 1;
	}
	} elsif (($udom ne 'public') && ($uname ne 'public')) {
	my $now = time;
	if ($uri =~ m{^([^/]+)/?$}) {
	my $adom = $1;
	foreach my $key (keys(%env)) {
	if ($key =~ m{^user\.role\.(ca\|aa)/\Q$adom\E}) {
	my ($start,$end) = split('.',$env{$key});
	if (($now >= $start) && (!$end \|\| $end < $now)) {
	$ownaccess = 1;
	last;
	}
	}
	}
	} elsif ($uri =~ m{^([^/]+)/([^/]+)/?}) {
	my $adom = $1;
	my $aname = $2;
	foreach my $role ('ca','aa') {
	if ($env{"user.role.$role./$adom/$aname"}) {
	my ($start,$end) =
	split('.',$env{"user.role.$role./$adom/$aname"});
	if (($now >= $start) && (!$end \|\| $end < $now)) {
	$ownaccess = 1;
	last;
	}
	}
	}
	}
	}
	}
	}
	}

# Course	# Course

if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {	if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {
$thisallowed.=$1;	unless (($priv eq 'bro') && (!$ownaccess)) {
	$thisallowed.=$1;
	}
}	}

# Domain	# Domain

if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}	if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
=~/\Q$priv\E\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
$thisallowed.=$1;	unless (($priv eq 'bro') && (!$ownaccess)) {
	$thisallowed.=$1;
	}
}	}

# Course: uri itself is a course	# Course: uri itself is a course
Line 4877 sub allowed {	Line 5129 sub allowed {

if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}	if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}
=~/\Q$priv\E\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
$thisallowed.=$1;	unless (($priv eq 'bro') && (!$ownaccess)) {
	$thisallowed.=$1;
	}
}	}

# URI is an uploaded document for this course, default permissions don't matter	# URI is an uploaded document for this course, default permissions don't matter
Line 5017 sub allowed {	Line 5271 sub allowed {

my $envkey;	my $envkey;
if ($thisallowed=~/L/) {	if ($thisallowed=~/L/) {
foreach $envkey (keys %env) {	foreach $envkey (keys(%env)) {
if ($envkey=~/^user\.role\.(st\|ta)\.([^\.]*)/) {	if ($envkey=~/^user\.role\.(st\|ta)\.([^\.]*)/) {
my $courseid=$2;	my $courseid=$2;
my $roleid=$1.'.'.$2;	my $roleid=$1.'.'.$2;
Line 5308 sub fetch_enrollment_query {	Line 5562 sub fetch_enrollment_query {
}	}
my $host=&hostname($homeserver);	my $host=&hostname($homeserver);
my $cmd = '';	my $cmd = '';
foreach my $affiliate (keys %{$affiliatesref}) {	foreach my $affiliate (keys(%{$affiliatesref})) {
$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';	$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
}	}
$cmd =~ s/%%$//;	$cmd =~ s/%%$//;
Line 5441 sub auto_run {	Line 5695 sub auto_run {

sub auto_get_sections {	sub auto_get_sections {
my ($cnum,$cdom,$inst_coursecode) = @_;	my ($cnum,$cdom,$inst_coursecode) = @_;
my $homeserver = &homeserver($cnum,$cdom);	my $homeserver;
my @secs = ();	if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));	$homeserver = &homeserver($cnum,$cdom);
unless ($response eq 'refused') {	}
@secs = split(/:/,$response);	if (!defined($homeserver)) {
	if ($cdom =~ /^$match_domain$/) {
	$homeserver = &domain($cdom,'primary');
	}
	}
	my @secs;
	if (defined($homeserver)) {
	my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
	unless ($response eq 'refused') {
	@secs = split(/:/,$response);
	}
}	}
return @secs;	return @secs;
}	}
Line 5464 sub auto_validate_courseID {	Line 5728 sub auto_validate_courseID {
return $response;	return $response;
}	}

	sub auto_validate_instcode {
	my ($cnum,$cdom,$instcode,$owner) = @_;
	my ($homeserver,$response);
	if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
	$homeserver = &homeserver($cnum,$cdom);
	}
	if (!defined($homeserver)) {
	if ($cdom =~ /^$match_domain$/) {
	$homeserver = &domain($cdom,'primary');
	}
	}
	my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
	&escape($instcode).':'.&escape($owner),$homeserver));
	my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);
	return ($outcome,$description);
	}

sub auto_create_password {	sub auto_create_password {
my ($cnum,$cdom,$authparam,$udom) = @_;	my ($cnum,$cdom,$authparam,$udom) = @_;
my ($homeserver,$response);	my ($homeserver,$response);
Line 5578 sub auto_instcode_format {	Line 5859 sub auto_instcode_format {
push(@homeservers,$tryserver);	push(@homeservers,$tryserver);
}	}
}	}
	} elsif ($caller eq 'requests') {
	if ($codedom =~ /^$match_domain$/) {
	my $chome = &domain($codedom,'primary');
	unless ($chome eq 'no_host') {
	push(@homeservers,$chome);
	}
	}
} else {	} else {
push(@homeservers,&homeserver($caller,$codedom));	push(@homeservers,&homeserver($caller,$codedom));
}	}
Line 5635 sub auto_instcode_defaults {	Line 5923 sub auto_instcode_defaults {
}	}

return $response;	return $response;
}	}

	sub auto_possible_instcodes {
	my ($domain,$codetitles,$cat_titles,$cat_orders,$code_order) = @_;
	unless ((ref($codetitles) eq 'ARRAY') && (ref($cat_titles) eq 'HASH') &&
	(ref($cat_orders) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {
	return;
	}
	my (@homeservers,$uhome);
	if (defined(&domain($domain,'primary'))) {
	$uhome=&domain($domain,'primary');
	push(@homeservers,&domain($domain,'primary'));
	} else {
	my %servers = &get_servers($domain,'library');
	foreach my $tryserver (keys(%servers)) {
	if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
	push(@homeservers,$tryserver);
	}
	}
	}
	my $response;
	foreach my $server (@homeservers) {
	$response=&reply('autopossibleinstcodes:'.$domain,$server);
	next if ($response =~ /(con_lost\|error\|no_such_host\|refused)/);
	my ($codetitlestr,$codeorderstr,$cat_title,$cat_order) =
	split(':',$response);
	@{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr));
	@{$code_order} = map { &unescape($_); } (split('&',$codeorderstr));
	foreach my $item (split('&',$cat_title)) {
	my ($name,$value)=split('=',$item);
	$cat_titles->{&unescape($name)}=&thaw_unescape($value);
	}
	foreach my $item (split('&',$cat_order)) {
	my ($name,$value)=split('=',$item);
	$cat_orders->{&unescape($name)}=&thaw_unescape($value);
	}
	return 'ok';
	}
	return $response;
	}

	sub auto_courserequest_checks {
	my ($dom) = @_;
	my ($homeserver,%validations);
	if ($dom =~ /^$match_domain$/) {
	$homeserver = &domain($dom,'primary');
	}
	unless ($homeserver eq 'no_host') {
	my $response=&reply('autocrsreqchecks:'.$dom,$homeserver);
	unless ($response =~ /(con_lost\|error\|no_such_host\|refused)/) {
	my @items = split(/&/,$response);
	foreach my $item (@items) {
	my ($key,$value) = split('=',$item);
	$validations{&unescape($key)} = &thaw_unescape($value);
	}
	}
	}
	return %validations;
	}

	sub auto_courserequest_validation {
	my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_;
	my ($homeserver,$response);
	if ($dom =~ /^$match_domain$/) {
	$homeserver = &domain($dom,'primary');
	}
	unless ($homeserver eq 'no_host') {

	$response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).
	':'.&escape($crstype).':'.&escape($inststatuslist).
	':'.&escape($instcode).':'.&escape($instseclist),
	$homeserver));
	}
	return $response;
	}

sub auto_validate_class_sec {	sub auto_validate_class_sec {
my ($cdom,$cnum,$owners,$inst_class) = @_;	my ($cdom,$cnum,$owners,$inst_class) = @_;
Line 5789 sub devalidate_getgroups_cache {	Line 6151 sub devalidate_getgroups_cache {

sub plaintext {	sub plaintext {
my ($short,$type,$cid,$forcedefault) = @_;	my ($short,$type,$cid,$forcedefault) = @_;
if ($short =~ /^cr/) {	if ($short =~ m{^cr/}) {
return (split('/',$short))[-1];	return (split('/',$short))[-1];
}	}
if (!defined($cid)) {	if (!defined($cid)) {
$cid = $env{'request.course.id'};	$cid = $env{'request.course.id'};
}	}
if (defined($cid) && ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '')) {
unless ($forcedefault) {
my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'};
&Apache::lonlocal::mt_escape(\$roletext);
return &Apache::lonlocal::mt($roletext);
}
}
my %rolenames = (	my %rolenames = (
Course => 'std',	Course => 'std',
Group => 'alt1',	Community => 'alt1',
);	);
if (defined($type) &&	if ($cid ne '') {
defined($rolenames{$type}) &&	if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') {
defined($prp{$short}{$rolenames{$type}})) {	unless ($forcedefault) {
	my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'};
	&Apache::lonlocal::mt_escape(\$roletext);
	return &Apache::lonlocal::mt($roletext);
	}
	}
	}
	if ((defined($type)) && (defined($rolenames{$type})) &&
	(defined($rolenames{$type})) &&
	(defined($prp{$short}{$rolenames{$type}}))) {
return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});	return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});
} else {	} elsif ($cid ne '') {
return &Apache::lonlocal::mt($prp{$short}{'std'});	my $crstype = $env{'course.'.$cid.'.type'};
	if (($crstype ne '') && (defined($rolenames{$crstype})) &&
	(defined($prp{$short}{$rolenames{$crstype}}))) {
	return &Apache::lonlocal::mt($prp{$short}{$rolenames{$crstype}});
	}
}	}
	return &Apache::lonlocal::mt($prp{$short}{'std'});
}	}

# ----------------------------------------------------------------- Assign Role	# ----------------------------------------------------------------- Assign Role
Line 5825 sub assignrole {	Line 6194 sub assignrole {
my $cwosec=$url;	my $cwosec=$url;
$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;	$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
unless (&allowed('ccr',$cwosec)) {	unless (&allowed('ccr',$cwosec)) {
&logthis('Refused custom assignrole: '.	my $refused = 1;
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.	if ($context eq 'requestcourses') {
$env{'user.name'}.' at '.$env{'user.domain'});	if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
return 'refused';	if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {
	if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {
	my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
	my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
	if ($crsenv{'internal.courseowner'} eq
	$env{'user.name'}.':'.$env{'user.domain'}) {
	$refused = '';
	}
	}
	}
	}
	}
	if ($refused) {
	&logthis('Refused custom assignrole: '.
	$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.
	' by '.$env{'user.name'}.' at '.$env{'user.domain'});
	return 'refused';
	}
}	}
$mrole='cr';	$mrole='cr';
} elsif ($role =~ /^gr\//) {	} elsif ($role =~ /^gr\//) {
Line 5854 sub assignrole {	Line 6240 sub assignrole {
$refused = 1;	$refused = 1;
}	}
if ($refused) {	if ($refused) {
if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {	my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
	if (!$selfenroll && $context eq 'course') {
	my %crsenv;
	if ($role eq 'cc' \|\| $role eq 'co') {
	%crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
	if (($role eq 'cc') && ($cnum !~ /^$match_community$/)) {
	if ($env{'request.role'} eq 'cc./'.$cdom.'/'.$cnum) {
	if ($crsenv{'internal.courseowner'} eq
	$env{'user.name'}.':'.$env{'user.domain'}) {
	$refused = '';
	}
	}
	} elsif (($role eq 'co') && ($cnum =~ /^$match_community$/)) {
	if ($env{'request.role'} eq 'co./'.$cdom.'/'.$cnum) {
	if ($crsenv{'internal.courseowner'} eq
	$env{'user.name'}.':'.$env{'user.domain'}) {
	$refused = '';
	}
	}
	}
	}
	} elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
$refused = '';	$refused = '';
} else {	} elsif ($context eq 'requestcourses') {
	my @possroles = ('st','ta','ep','in','cc','co');
	if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
	my $wrongcc;
	if ($cnum =~ /^$match_community$/) {
	$wrongcc = 1 if ($role eq 'cc');
	} else {
	$wrongcc = 1 if ($role eq 'co');
	}
	unless ($wrongcc) {
	my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
	if ($crsenv{'internal.courseowner'} eq
	$env{'user.name'}.':'.$env{'user.domain'}) {
	$refused = '';
	}
	}
	}
	}
	if ($refused) {
&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.	&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
' '.$role.' '.$end.' '.$start.' by '.	' '.$role.' '.$end.' '.$start.' by '.
$env{'user.name'}.' at '.$env{'user.domain'});	$env{'user.name'}.' at '.$env{'user.domain'});
Line 6180 sub writecoursepref {	Line 6605 sub writecoursepref {

sub createcourse {	sub createcourse {
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,	my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
$course_owner,$crstype)=@_;	$course_owner,$crstype,$cnum,$context,$category)=@_;
$url=&declutter($url);	$url=&declutter($url);
my $cid='';	my $cid='';
unless (&allowed('ccc',$udom)) {	if ($context eq 'requestcourses') {
	my $can_create = 0;
	my ($ownername,$ownerdom) = split(':',$course_owner);
	if ($udom eq $ownerdom) {
	if (&usertools_access($ownername,$ownerdom,$category,undef,
	$context)) {
	$can_create = 1;
	}
	} else {
	my %userenv = &userenvironment($ownerdom,$ownername,'reqcrsotherdom.'.
	$category);
	if ($userenv{'reqcrsotherdom.'.$category} ne '') {
	my @curr = split(',',$userenv{'reqcrsotherdom.'.$category});
	if (@curr > 0) {
	my @options = qw(approval validate autolimit);
	my $optregex = join('\|',@options);
	if (grep(/^\Q$udom\E:($optregex)(=?\d*)$/,@curr)) {
	$can_create = 1;
	}
	}
	}
	}
	if ($can_create) {
	unless ($ownername eq $env{'user.name'} && $ownerdom eq $env{'user.domain'}) {
	unless (&allowed('ccc',$udom)) {
	return 'refused';
	}
	}
	} else {
	return 'refused';
	}
	} elsif (!&allowed('ccc',$udom)) {
return 'refused';	return 'refused';
}	}
# ------------------------------------------------------------------- Create ID	# --------------------------------------------------------------- Get Unique ID
my $uname=int(1+rand(9)).	my $uname;
('a'..'z','A'..'Z','0'..'9')[int(rand(62))].	if ($cnum =~ /^$match_courseid$/) {
substr($$.time,0,5).unpack("H8",pack("I32",time)).	my $chome=&homeserver($cnum,$udom,'true');
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};	if (($chome eq '') \|\| ($chome eq 'no_host')) {
# ----------------------------------------------- Make sure that does not exist	$uname = $cnum;
my $uhome=&homeserver($uname,$udom,'true');	} else {
unless (($uhome eq '') \|\| ($uhome eq 'no_host')) {	$uname = &generate_coursenum($udom,$crstype);
$uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).	}
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};	} else {
$uhome=&homeserver($uname,$udom,'true');	$uname = &generate_coursenum($udom,$crstype);
unless (($uhome eq '') \|\| ($uhome eq 'no_host')) {	}
return 'error: unable to generate unique course-ID';	return $uname if ($uname =~ /^error/);
}	# -------------------------------------------------- Check supplied server name
}
# ------------------------------------------------ Check supplied server name
$course_server = $env{'user.homeserver'} if (! defined($course_server));	$course_server = $env{'user.homeserver'} if (! defined($course_server));
if (! &is_library($course_server)) {	if (! &is_library($course_server)) {
return 'error:bad server name '.$course_server;	return 'error:bad server name '.$course_server;
Line 6210 sub createcourse {	Line 6664 sub createcourse {
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',	my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
$course_server);	$course_server);
unless ($reply eq 'ok') { return 'error: '.$reply; }	unless ($reply eq 'ok') { return 'error: '.$reply; }
$uhome=&homeserver($uname,$udom,'true');	my $uhome=&homeserver($uname,$udom,'true');
if (($uhome eq '') \|\| ($uhome eq 'no_host')) {	if (($uhome eq '') \|\| ($uhome eq 'no_host')) {
return 'error: no such course';	return 'error: no such course';
}	}
# ----------------------------------------------------------------- Course made	# ----------------------------------------------------------------- Course made
# log existence	# log existence
	my $now = time;
my $newcourse = {	my $newcourse = {
$udom.'_'.$uname => {	$udom.'_'.$uname => {
description => $description,	description => $description,
inst_code => $inst_code,	inst_code => $inst_code,
owner => $course_owner,	owner => $course_owner,
type => $crstype,	type => $crstype,
	creator => $env{'user.name'}.':'.
	$env{'user.domain'},
	created => $now,
	context => $context,
},	},
};	};
&courseidput($udom,$newcourse,$uhome,'notime');	&courseidput($udom,$newcourse,$uhome,'notime');
Line 6251 ENDINITMAP	Line 6710 ENDINITMAP
return '/'.$udom.'/'.$uname;	return '/'.$udom.'/'.$uname;
}	}

	# ------------------------------------------------------------------- Create ID
	sub generate_coursenum {
	my ($udom,$crstype) = @_;
	my $domdesc = &domain($udom);
	return 'error: invalid domain' if ($domdesc eq '');
	my $first;
	if ($crstype eq 'Community') {
	$first = '0';
	} else {
	$first = int(1+rand(9));
	}
	my $uname=$first.
	('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
	substr($$.time,0,5).unpack("H8",pack("I32",time)).
	unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
	# ----------------------------------------------- Make sure that does not exist
	my $uhome=&homeserver($uname,$udom,'true');
	unless (($uhome eq '') \|\| ($uhome eq 'no_host')) {
	if ($crstype eq 'Community') {
	$first = '0';
	} else {
	$first = int(1+rand(9));
	}
	$uname=$first.
	('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
	substr($$.time,0,5).unpack("H8",pack("I32",time)).
	unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
	$uhome=&homeserver($uname,$udom,'true');
	unless (($uhome eq '') \|\| ($uhome eq 'no_host')) {
	return 'error: unable to generate unique course-ID';
	}
	}
	return $uname;
	}

sub is_course {	sub is_course {
my ($cdom,$cnum) = @_;	my ($cdom,$cnum) = @_;
my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,	my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
Line 6261 sub is_course {	Line 6755 sub is_course {
return 0;	return 0;
}	}

	sub store_userdata {
	my ($storehash,$datakey,$namespace,$udom,$uname) = @_;
	my $result;
	if ($datakey ne '') {
	if (ref($storehash) eq 'HASH') {
	if ($udom eq '' \|\| $uname eq '') {
	$udom = $env{'user.domain'};
	$uname = $env{'user.name'};
	}
	my $uhome=&homeserver($uname,$udom);
	if (($uhome eq '') \|\| ($uhome eq 'no_host')) {
	$result = 'error: no_host';
	} else {
	$storehash->{'ip'} = $ENV{'REMOTE_ADDR'};
	$storehash->{'host'} = $perlvar{'lonHostID'};

	my $namevalue='';
	foreach my $key (keys(%{$storehash})) {
	$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
	}
	$namevalue=~s/\&$//;
	$result = &reply("store:$env{'user.domain'}:$env{'user.name'}:".
	"$namespace:$datakey:$namevalue",$uhome);
	}
	} else {
	$result = 'error: data to store was not a hash reference';
	}
	} else {
	$result= 'error: invalid requestkey';
	}
	return $result;
	}

# ---------------------------------------------------------- Assign Custom Role	# ---------------------------------------------------------- Assign Custom Role

sub assigncustomrole {	sub assigncustomrole {
Line 7750 sub devalidate_title_cache {	Line 8277 sub devalidate_title_cache {
&devalidate_cache_new('title',$key);	&devalidate_cache_new('title',$key);
}	}

	# ------------------------------------------------- Get the title of a course

	sub current_course_title {
	return $env{ 'course.' . $env{'request.course.id'} . '.description' };
	}
# ------------------------------------------------- Get the title of a resource	# ------------------------------------------------- Get the title of a resource

sub gettitle {	sub gettitle {
Line 7816 sub symblist {	Line 8348 sub symblist {
if (($env{'request.course.fn'}) && (%newhash)) {	if (($env{'request.course.fn'}) && (%newhash)) {
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',	if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
&GDBM_WRCREAT(),0640)) {	&GDBM_WRCREAT(),0640)) {
foreach my $url (keys %newhash) {	foreach my $url (keys(%newhash)) {
next if ($url eq 'last_known'	next if ($url eq 'last_known'
&& $env{'form.no_update_last_known'});	&& $env{'form.no_update_last_known'});
$hash{declutter($url)}=&encode_symb($mapname,	$hash{declutter($url)}=&encode_symb($mapname,
Line 7853 sub symbverify {	Line 8385 sub symbverify {

if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',	if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
&GDBM_READER(),0640)) {	&GDBM_READER(),0640)) {
	if (($thisurl =~ m{^/adm/wrapper/ext/}) \|\| ($thisurl =~ m{^ext/})) {
	$thisurl =~ s/\?.+$//;
	}
my $ids=$bighash{'ids_'.&clutter($thisurl)};	my $ids=$bighash{'ids_'.&clutter($thisurl)};
unless ($ids) {	unless ($ids) {
$ids=$bighash{'ids_/'.$thisurl};	$ids=$bighash{'ids_/'.$thisurl};
Line 7861 sub symbverify {	Line 8396 sub symbverify {
# ------------------------------------------------------------------- Has ID(s)	# ------------------------------------------------------------------- Has ID(s)
foreach my $id (split(/\,/,$ids)) {	foreach my $id (split(/\,/,$ids)) {
my ($mapid,$resid)=split(/\./,$id);	my ($mapid,$resid)=split(/\./,$id);
	if ($thisfn =~ m{^/adm/wrapper/ext/}) {
	$symb =~ s/\?.+$//;
	}
if (	if (
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)	&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
eq $symb) {	eq $symb) {
Line 8737 sub declutter {	Line 9275 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/\?.+$//;	unless (($thisfn =~ /^ext/) \|\| ($thisfn =~ /\.(page\|sequence)___\d+___ext/)) {
	$thisfn=~s/\?.+$//;
	}
return $thisfn;	return $thisfn;
}	}

Line 8749 sub clutter {	Line 9289 sub clutter {
\|\| $thisfn =~ m{^/adm/(includes\|pages)} ) {	\|\| $thisfn =~ m{^/adm/(includes\|pages)} ) {
$thisfn='/res'.$thisfn;	$thisfn='/res'.$thisfn;
}	}
if ($thisfn !~m\|/adm\|) {	if ($thisfn !~m\|^/adm\|) {
if ($thisfn =~ m\|/ext/\|) {	if ($thisfn =~ m\|^/ext/\|) {
$thisfn='/adm/wrapper'.$thisfn;	$thisfn='/adm/wrapper'.$thisfn;
} else {	} else {
my ($ext) = ($thisfn =~ /\.(\w+)$/);	my ($ext) = ($thisfn =~ /\.(\w+)$/);
Line 9563 and course level	Line 10103 and course level

plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash	plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash
(rolesplain.tab); plain text explanation of a user role term.	(rolesplain.tab); plain text explanation of a user role term.
$type is Course (default) or Group.	$type is Course (default) or Community.
If $forcedefault evaluates to true, text returned will be default	If $forcedefault evaluates to true, text returned will be default
text for $type. Otherwise, if this is a course, the text returned	text for $type. Otherwise, if this is a course, the text returned
will be a custom name for the role (if defined in the course's	will be a custom name for the role (if defined in the course's
Line 9773 database) for a course	Line 10313 database) for a course

=item *	=item *

createcourse($udom,$description,$url) : make/modify course	createcourse($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner,$crstype,$cnum) : make course

	=item *

	generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community).

=back	=back

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

Removed from v.1.997
changed lines
	Added in v.1.1048