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.1172.2.146.2.1 and 1.1172.2.146.2.29

version 1.1172.2.146.2.1, 2022/01/03 14:40:28	version 1.1172.2.146.2.29, 2025/06/06 21:18:46
Line 221 sub get_server_distarch {	Line 221 sub get_server_distarch {
}	}
}	}
my $rep = &reply('serverdistarch',$lonhost);	my $rep = &reply('serverdistarch',$lonhost);
unless ($rep eq 'unknown_command' \|\| $rep eq 'no_such_host' \|\|	unless ($rep eq 'unknown_cmd' \|\| $rep eq 'no_such_host' \|\|
$rep eq 'con_lost' \|\| $rep eq 'rejected' \|\| $rep eq 'refused' \|\|	$rep eq 'con_lost' \|\| $rep eq 'rejected' \|\| $rep eq 'refused' \|\|
$rep eq '') {	$rep eq '') {
return &do_cache_new('serverdistarch',$lonhost,$rep,$cachetime);	return &do_cache_new('serverdistarch',$lonhost,$rep,$cachetime);
Line 365 sub remote_devalidate_cache {	Line 365 sub remote_devalidate_cache {
return &reply('devalidatecache:'.&escape($cachestr),$lonhost);	return &reply('devalidatecache:'.&escape($cachestr),$lonhost);
}	}

	sub sign_lti {
	my ($cdom,$cnum,$crsdef,$type,$context,$url,$ltinum,$keynum,$paramsref,$inforef) = @_;
	my $chome;
	if (&domain($cdom) ne '') {
	if ($crsdef) {
	$chome = &homeserver($cnum,$cdom);
	} else {
	$chome = &domain($cdom,'primary');
	}
	}
	if ($cdom && $chome && ($chome ne 'no_host')) {
	if ((ref($paramsref) eq 'HASH') &&
	(ref($inforef) eq 'HASH')) {
	my $rep;
	if (grep { $_ eq $chome } &current_machine_ids()) {
	# domain information is hosted on this machine
	$rep =
	&LONCAPA::Lond::sign_lti_payload($cdom,$cnum,$crsdef,$type,
	$context,$url,$ltinum,$keynum,
	$perlvar{'lonVersion'},
	$paramsref,$inforef);
	if (ref($rep) eq 'HASH') {
	return ('ok',$rep);
	}
	} else {
	my ($escurl,$params,$info);
	$escurl = &escape($url);
	if (ref($paramsref) eq 'HASH') {
	$params = &freeze_escape($paramsref);
	}
	if (ref($inforef) eq 'HASH') {
	$info = &freeze_escape($inforef);
	}
	$rep=&reply("encrypt:signlti:$cdom:$cnum:$crsdef:$type:$context:$escurl:$ltinum:$keynum:$params:$info",$chome);
	}
	if (($rep eq '') \|\| ($rep =~ /^con_lost\|error\|no_such_host\|unknown_cmd/i)) {
	return ();
	} elsif (($inforef->{'respfmt'} eq 'to_post_body') \|\|
	($inforef->{'respfmt'} eq 'to_authorization_header')) {
	return ('ok',$rep);
	} else {
	my %returnhash;
	foreach my $item (split(/\&/,$rep)) {
	my ($name,$value)=split(/\=/,$item);
	$returnhash{&unescape($name)}=&thaw_unescape($value);
	}
	return('ok',\%returnhash);
	}
	} else {
	return ();
	}
	} else {
	return ();
	&logthis("sign_lti failed - no homeserver and/or domain ($cdom) ($chome)");
	}
	}

# -------------------------------------------------- Non-critical communication	# -------------------------------------------------- Non-critical communication
sub subreply {	sub subreply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
Line 418 sub reply {	Line 475 sub reply {
my $subcmd = $1;	my $subcmd = $1;
if (($subcmd eq 'auth') \|\| ($subcmd eq 'passwd') \|\|	if (($subcmd eq 'auth') \|\| ($subcmd eq 'passwd') \|\|
($subcmd eq 'changeuserauth') \|\| ($subcmd eq 'makeuser') \|\|	($subcmd eq 'changeuserauth') \|\| ($subcmd eq 'makeuser') \|\|
($subcmd eq 'putdom') \|\| ($subcmd eq 'autoexportgrades')) {	($subcmd eq 'putdom') \|\| ($subcmd eq 'autoexportgrades') \|\|
	($subcmd eq 'put')) {
(undef,undef,my @rest) = split(/:/,$cmd);	(undef,undef,my @rest) = split(/:/,$cmd);
if (($subcmd eq 'auth') \|\| ($subcmd eq 'putdom')) {	if (($subcmd eq 'auth') \|\| ($subcmd eq 'putdom')) {
splice(@rest,2,1,'Hidden');	splice(@rest,2,1,'Hidden');
} elsif ($subcmd eq 'passwd') {	} elsif ($subcmd eq 'passwd') {
splice(@rest,2,2,('Hidden','Hidden'));	splice(@rest,2,2,('Hidden','Hidden'));
} elsif (($subcmd eq 'changeuserauth') \|\| ($subcmd eq 'makeuser') \|\|	} elsif (($subcmd eq 'changeuserauth') \|\| ($subcmd eq 'makeuser') \|\|
($subcmd eq 'autoexportgrades')) {	($subcmd eq 'autoexportgrades') \|\| ($subcmd eq 'put')) {
splice(@rest,3,1,'Hidden');	splice(@rest,3,1,'Hidden');
}	}
$logged = join(':',('encrypt:'.$subcmd,@rest));	$logged = join(':',('encrypt:'.$subcmd,@rest));
Line 694 sub check_for_valid_session {	Line 752 sub check_for_valid_session {
if ($disk_env{'request.role'}) {	if ($disk_env{'request.role'}) {
$userhashref->{'role'} = $disk_env{'request.role'};	$userhashref->{'role'} = $disk_env{'request.role'};
}	}
	$userhashref->{'lti'} = $disk_env{'request.lti.login'};
	if ($userhashref->{'lti'}) {
	$userhashref->{'ltitarget'} = $disk_env{'request.lti.target'};
	$userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'};
	}
}	}
untie(%disk_env);	untie(%disk_env);

Line 1035 sub find_existing_session {	Line 1098 sub find_existing_session {
return;	return;
}	}

	sub delusersession {
	my ($lonid,$udom,$uname) = @_;
	my $uprimary_id = &domain($udom,'primary');
	my $uintdom = &internet_dom($uprimary_id);
	my $intdom = &internet_dom($lonid);
	my $serverhomedom = &host_domain($lonid);
	if (($uintdom ne '') && ($uintdom eq $intdom)) {
	return &reply(join(':','delusersession',
	map {&escape($_)} ($udom,$uname)),$lonid);
	}
	return;
	}


# check if user's browser sent load balancer cookie and server still has session	# check if user's browser sent load balancer cookie and server still has session
# and is not overloaded.	# and is not overloaded.
sub check_for_balancer_cookie {	sub check_for_balancer_cookie {
Line 1254 sub changepass {	Line 1331 sub changepass {
sub queryauthenticate {	sub queryauthenticate {
my ($uname,$udom)=@_;	my ($uname,$udom)=@_;
my $uhome=&homeserver($uname,$udom);	my $uhome=&homeserver($uname,$udom);
if (!$uhome) {	if ((!$uhome) \|\| ($uhome eq 'no_host')) {
&logthis("User $uname at $udom is unknown when looking for authentication mechanism");	&logthis("User $uname at $udom is unknown when looking for authentication mechanism");
return 'no_host';	return 'no_host';
}	}
Line 1303 sub authenticate {	Line 1380 sub authenticate {
}	}
if ($answer eq 'non_authorized') {	if ($answer eq 'non_authorized') {
&logthis("User $uname at $udom rejected by $uhome");	&logthis("User $uname at $udom rejected by $uhome");
return 'no_host';	return 'no_host';
}	}
&logthis("User $uname at $udom threw error $answer when checking authentication mechanism");	&logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
return 'no_host';	return 'no_host';
}	}

	sub can_switchserver {
	my ($udom,$home) = @_;
	my ($canswitch,@intdoms);
	my $internet_names = &get_internet_names($home);
	if (ref($internet_names) eq 'ARRAY') {
	@intdoms = @{$internet_names};
	}
	my $uint_dom = &internet_dom(&domain($udom,'primary'));
	if ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) {
	$canswitch = 1;
	} else {
	my $serverhomeID = &get_server_homeID(&hostname($home));
	my $serverhomedom = &host_domain($serverhomeID);
	my %defdomdefaults = &get_domain_defaults($serverhomedom);
	my %udomdefaults = &get_domain_defaults($udom);
	my $remoterev = &get_server_loncaparev('',$home);
	$canswitch = &can_host_session($udom,$home,$remoterev,
	$udomdefaults{'remotesessions'},
	$defdomdefaults{'hostedsessions'});
	}
	return $canswitch;
	}

sub can_host_session {	sub can_host_session {
my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_;	my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_;
my $canhost = 1;	my $canhost = 1;
Line 1997 sub del_dom {	Line 2097 sub del_dom {
}	}
}	}

	sub store_dom {
	my ($storehash,$id,$namespace,$dom,$home,$encrypt) = @_;
	$$storehash{'ip'}=&get_requestor_ip();
	$$storehash{'host'}=$perlvar{'lonHostID'};
	my $namevalue='';
	foreach my $key (keys(%{$storehash})) {
	$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
	}
	$namevalue=~s/\&$//;
	if (grep { $_ eq $home } current_machine_ids()) {
	return LONCAPA::Lond::store_dom("storedom:$dom:$namespace:$id:$namevalue");
	} else {
	if ($namespace eq 'private') {
	return 'refused';
	} elsif ($encrypt) {
	return reply("encrypt:storedom:$dom:$namespace:$id:$namevalue",$home);
	} else {
	return reply("storedom:$dom:$namespace:$id:$namevalue",$home);
	}
	}
	}

	sub restore_dom {
	my ($id,$namespace,$dom,$home,$encrypt) = @_;
	my $answer;
	if (grep { $_ eq $home } current_machine_ids()) {
	$answer = LONCAPA::Lond::restore_dom("restoredom:$dom:$namespace:$id");
	} elsif ($namespace ne 'private') {
	if ($encrypt) {
	$answer=&reply("encrypt:restoredom:$dom:$namespace:$id",$home);
	} else {
	$answer=&reply("restoredom:$dom:$namespace:$id",$home);
	}
	}
	my %returnhash=();
	unless (($answer eq '') \|\| ($answer eq 'con_lost') \|\| ($answer eq 'refused') \|\|
	($answer eq 'unknown_cmd') \|\| ($answer eq 'rejected')) {
	foreach my $line (split(/\&/,$answer)) {
	my ($name,$value)=split(/\=/,$line);
	$returnhash{&unescape($name)}=&thaw_unescape($value);
	}
	my $version;
	for ($version=1;$version<=$returnhash{'version'};$version++) {
	foreach my $item (split(/\:/,$returnhash{$version.':keys'})) {
	$returnhash{$item}=$returnhash{$version.':'.$item};
	}
	}
	}
	return %returnhash;
	}

# ----------------------------------construct domainconfig user for a domain	# ----------------------------------construct domainconfig user for a domain
sub get_domainconfiguser {	sub get_domainconfiguser {
my ($udom) = @_;	my ($udom) = @_;
Line 2275 sub inst_rulecheck {	Line 2426 sub inst_rulecheck {
$response=&unescape(&reply('instidrulecheck:'.&escape($udom).	$response=&unescape(&reply('instidrulecheck:'.&escape($udom).
':'.&escape($id).':'.$rulestr,	':'.&escape($id).':'.$rulestr,
$homeserver));	$homeserver));
	} elsif ($item eq 'unamemap') {
	$response=&unescape(&reply('instunamemapcheck:'.
	&escape($udom).':'.&escape($uname).
	':'.$rulestr,$homeserver));
} elsif ($item eq 'selfcreate') {	} elsif ($item eq 'selfcreate') {
$response=&unescape(&reply('instselfcreatecheck:'.	$response=&unescape(&reply('instselfcreatecheck:'.
&escape($udom).':'.&escape($uname).	&escape($udom).':'.&escape($uname).
Line 2308 sub inst_userrules {	Line 2463 sub inst_userrules {
} elsif ($check eq 'email') {	} elsif ($check eq 'email') {
$response=&reply('instemailrules:'.&escape($udom),	$response=&reply('instemailrules:'.&escape($udom),
$homeserver);	$homeserver);
	} elsif ($check eq 'unamemap') {
	$response=&reply('unamemaprules:'.&escape($udom),
	$homeserver);
} else {	} else {
$response=&reply('instuserrules:'.&escape($udom),	$response=&reply('instuserrules:'.&escape($udom),
$homeserver);	$homeserver);
Line 2352 sub get_domain_defaults {	Line 2510 sub get_domain_defaults {
&Apache::lonnet::get_dom('configuration',['defaults','quotas',	&Apache::lonnet::get_dom('configuration',['defaults','quotas',
'requestcourses','inststatus',	'requestcourses','inststatus',
'coursedefaults','usersessions',	'coursedefaults','usersessions',
'requestauthor','selfenrollment',	'requestauthor','authordefaults',
'coursecategories','autoenroll',	'selfenrollment','coursecategories',
'helpsettings','wafproxy'],$domain);	'autoenroll','helpsettings',
	'wafproxy','ltisec','toolsec',
	'domexttool','exttool'],$domain);
my @coursetypes = ('official','unofficial','community','textbook');	my @coursetypes = ('official','unofficial','community','textbook');
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'};
Line 2363 sub get_domain_defaults {	Line 2523 sub get_domain_defaults {
$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};	$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};	$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
$domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};	$domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};
	$domdefaults{'portal_def_email'} = $domconfig{'defaults'}{'portal_def_email'};
	$domdefaults{'portal_def_web'} = $domconfig{'defaults'}{'portal_def_web'};
$domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};	$domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};
$domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};	$domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};
$domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};	$domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};
	$domdefaults{'unamemap_rule'} = $domconfig{'defaults'}{'unamemap_rule'};
} else {	} else {
$domdefaults{'lang_def'} = &domain($domain,'lang_def');	$domdefaults{'lang_def'} = &domain($domain,'lang_def');
$domdefaults{'auth_def'} = &domain($domain,'auth_def');	$domdefaults{'auth_def'} = &domain($domain,'auth_def');
Line 2377 sub get_domain_defaults {	Line 2540 sub get_domain_defaults {
} else {	} else {
$domdefaults{'defaultquota'} = $domconfig{'quotas'};	$domdefaults{'defaultquota'} = $domconfig{'quotas'};
}	}
my @usertools = ('aboutme','blog','webdav','portfolio');	my @usertools = ('aboutme','blog','webdav','portfolio','portaccess');
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 2392 sub get_domain_defaults {	Line 2555 sub get_domain_defaults {
$domdefaults{$item} = $domconfig{'requestcourses'}{$item};	$domdefaults{$item} = $domconfig{'requestcourses'}{$item};
}	}
}	}
	if (ref($domconfig{'authordefaults'}) eq 'HASH') {
	foreach my $item ('nocodemirror','copyright','sourceavail','domcoordacc','editors','archive') {
	if ($item eq 'editors') {
	if (ref($domconfig{'authordefaults'}{'editors'}) eq 'ARRAY') {
	$domdefaults{$item} = join(',',@{$domconfig{'authordefaults'}{'editors'}});
	}
	} else {
	$domdefaults{$item} = $domconfig{'authordefaults'}{$item};
	}
	}
	}
if (ref($domconfig{'requestauthor'}) eq 'HASH') {	if (ref($domconfig{'requestauthor'}) eq 'HASH') {
$domdefaults{'requestauthor'} = $domconfig{'requestauthor'};	$domdefaults{'requestauthor'} = $domconfig{'requestauthor'};
}	}
Line 2407 sub get_domain_defaults {	Line 2581 sub get_domain_defaults {
if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {
$domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};	$domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};
}	}
	if (ref($domconfig{'coursedefaults'}{'crseditors'}) eq 'ARRAY') {
	$domdefaults{'crseditors'}=join(',',@{$domconfig{'coursedefaults'}{'crseditors'}});
	}
foreach my $type (@coursetypes) {	foreach my $type (@coursetypes) {
if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
unless ($type eq 'community') {	unless ($type eq 'community') {
Line 2416 sub get_domain_defaults {	Line 2593 sub get_domain_defaults {
if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
$domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};	$domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};
}	}
	if (ref($domconfig{'coursedefaults'}{'coursequota'}) eq 'HASH') {
	$domdefaults{$type.'coursequota'} = $domconfig{'coursedefaults'}{'coursequota'}{$type};
	}
if ($domdefaults{'postsubmit'} eq 'on') {	if ($domdefaults{'postsubmit'} eq 'on') {
if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') {
$domdefaults{$type.'postsubtimeout'} =	$domdefaults{$type.'postsubtimeout'} =
$domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type};	$domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type};
}	}
}	}
	if (ref($domconfig{'coursedefaults'}{'domexttool'}) eq 'HASH') {
	$domdefaults{$type.'domexttool'} = $domconfig{'coursedefaults'}{'domexttool'}{$type};
	} else {
	$domdefaults{$type.'domexttool'} = 1;
	}
	if (ref($domconfig{'coursedefaults'}{'exttool'}) eq 'HASH') {
	$domdefaults{$type.'exttool'} = $domconfig{'coursedefaults'}{'exttool'}{$type};
	} else {
	$domdefaults{$type.'exttool'} = 0;
	}
}	}
if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') {
if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') {	if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') {
Line 2436 sub get_domain_defaults {	Line 2626 sub get_domain_defaults {
if ($domconfig{'coursedefaults'}{'texengine'}) {	if ($domconfig{'coursedefaults'}{'texengine'}) {
$domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'};	$domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'};
}	}
	if (exists($domconfig{'coursedefaults'}{'ltiauth'})) {
	$domdefaults{'crsltiauth'} = $domconfig{'coursedefaults'}{'ltiauth'};
	}
}	}
if (ref($domconfig{'usersessions'}) eq 'HASH') {	if (ref($domconfig{'usersessions'}) eq 'HASH') {
if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {	if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {
Line 2506 sub get_domain_defaults {	Line 2699 sub get_domain_defaults {
}	}
}	}
}	}
	if (ref($domconfig{'ltisec'}) eq 'HASH') {
	if (ref($domconfig{'ltisec'}{'encrypt'}) eq 'HASH') {
	$domdefaults{'linkprotenc_crs'} = $domconfig{'ltisec'}{'encrypt'}{'crs'};
	$domdefaults{'linkprotenc_dom'} = $domconfig{'ltisec'}{'encrypt'}{'dom'};
	$domdefaults{'ltienc_consumers'} = $domconfig{'ltisec'}{'encrypt'}{'consumers'};
	}
	if (ref($domconfig{'ltisec'}{'private'}) eq 'HASH') {
	if (ref($domconfig{'ltisec'}{'private'}{'keys'}) eq 'ARRAY') {
	$domdefaults{'ltiprivhosts'} = $domconfig{'ltisec'}{'private'}{'keys'};
	}
	}
	if (ref($domconfig{'ltisec'}{'suggested'}) eq 'HASH') {
	my %suggestions = %{$domconfig{'ltisec'}{'suggested'}};
	foreach my $item (keys(%{$domconfig{'ltisec'}{'suggested'}})) {
	unless (ref($domconfig{'ltisec'}{'suggested'}{$item}) eq 'HASH') {
	delete($suggestions{$item});
	}
	}
	if (keys(%suggestions)) {
	$domdefaults{'linkprotsuggested'} = \%suggestions;
	}
	}
	}
	if (ref($domconfig{'toolsec'}) eq 'HASH') {
	if (ref($domconfig{'toolsec'}{'encrypt'}) eq 'HASH') {
	$domdefaults{'toolenc_crs'} = $domconfig{'toolsec'}{'encrypt'}{'crs'};
	$domdefaults{'toolenc_dom'} = $domconfig{'toolsec'}{'encrypt'}{'dom'};
	}
	if (ref($domconfig{'toolsec'}{'private'}) eq 'HASH') {
	if (ref($domconfig{'toolsec'}{'private'}{'keys'}) eq 'ARRAY') {
	$domdefaults{'toolprivhosts'} = $domconfig{'toolsec'}{'private'}{'keys'};
	}
	}
	}
&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);	&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
return %domdefaults;	return %domdefaults;
}	}
Line 2542 sub get_dom_instcats {	Line 2769 sub get_dom_instcats {
if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes,	if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes,
\@codetitles,\%cat_titles,\%cat_order) eq 'ok') {	\@codetitles,\%cat_titles,\%cat_order) eq 'ok') {
$instcats = {	$instcats = {
	totcodes => $totcodes,
codes => \%codes,	codes => \%codes,
codetitles => \@codetitles,	codetitles => \@codetitles,
cat_titles => \%cat_titles,	cat_titles => \%cat_titles,
Line 2610 sub course_portal_url {	Line 2838 sub course_portal_url {
return $firsturl;	return $firsturl;
}	}

	sub url_prefix {
	my ($r,$dom,$home,$context) = @_;
	my $prefix;
	my %domdefs = &get_domain_defaults($dom);
	if ($domdefs{'portal_def'} && $domdefs{'portal_def_'.$context}) {
	if ($domdefs{'portal_def'} =~ m{^(https?://[^/]+)}) {
	$prefix = $1;
	}
	}
	if ($prefix eq '') {
	my $hostname = &hostname($home);
	my $protocol = $protocol{$home};
	$protocol = 'http' if ($protocol{$home} ne 'https');
	my $alias = &use_proxy_alias($r,$home);
	$hostname = $alias if ($alias ne '');
	$prefix = $protocol.'://'.$hostname;
	}
	return $prefix;
	}

# --------------------------------------------------- Assign a key to a student	# --------------------------------------------------- Assign a key to a student

sub assign_access_key {	sub assign_access_key {
Line 3421 sub can_edit_resource {	Line 3669 sub can_edit_resource {
}	}
}	}

	#
	# For /adm/viewcoauthors can only edit if author or co-author who is manager.
	#

	if (($resurl eq '/adm/viewcoauthors') && ($cnum ne '') && ($cdom ne '')) {
	if (((&allowed('cca',"$cdom/$cnum")) \|\|
	(&allowed('caa',"$cdom/$cnum"))) \|\|
	((&allowed('vca',"$cdom/$cnum") \|\|
	&allowed('vaa',"$cdom/$cnum")) &&
	($env{"environment.internal.manager./$cdom/$cnum"}))) {
	$home = $env{'user.home'};
	$cfile = $resurl;
	if ($env{'form.forceedit'}) {
	$forceview = 1;
	} else {
	$forceedit = 1;
	}
	return ($cfile,$home,$switchserver,$forceedit,$forceview);
	} else {
	return;
	}
	}

if ($env{'request.course.id'}) {	if ($env{'request.course.id'}) {
my $crsedit = &Apache::lonnet::allowed('mdc',$env{'request.course.id'});	my $crsedit = &Apache::lonnet::allowed('mdc',$env{'request.course.id'});
if ($group ne '') {	if ($group ne '') {
Line 3455 sub can_edit_resource {	Line 3726 sub can_edit_resource {
return;	return;
}	}
} elsif (!$crsedit) {	} elsif (!$crsedit) {
	if ($env{'request.role'} =~ m{^st\./$cdom/$cnum}) {
#	#
# No edit allowed where CC has switched to student role.	# No edit allowed where CC has switched to student role.
#	#
return;	return;
	} elsif (($resurl !~ m{^/res/$match_domain/$match_username/}) \|\|
	($resurl =~ m{^/res/lib/templates/})) {
	return;
	}
}	}
}	}
}	}
Line 3867 sub resizeImage {	Line 4143 sub resizeImage {
# input: $formname - the contents of the file are in $env{"form.$formname"}	# input: $formname - the contents of the file are in $env{"form.$formname"}
# the desired filename is in $env{"form.$formname.filename"}	# the desired filename is in $env{"form.$formname.filename"}
# $context - possible values: coursedoc, existingfile, overwrite,	# $context - possible values: coursedoc, existingfile, overwrite,
# canceloverwrite, scantron or ''.	# canceloverwrite, scantron, toollogo or ''.
# if 'coursedoc': upload to the current course	# if 'coursedoc': upload to the current course
# if 'existingfile': write file to tmp/overwrites directory	# if 'existingfile': write file to tmp/overwrites directory
# if 'canceloverwrite': delete file written to tmp/overwrites directory	# if 'canceloverwrite': delete file written to tmp/overwrites directory
Line 3879 sub resizeImage {	Line 4155 sub resizeImage {
# Section => 4, CODE => 5, FirstQuestion => 9 }).	# Section => 4, CODE => 5, FirstQuestion => 9 }).
# $allfiles - reference to hash for embedded objects	# $allfiles - reference to hash for embedded objects
# $codebase - reference to hash for codebase of java objects	# $codebase - reference to hash for codebase of java objects
# $desuname - username for permanent storage of uploaded file	# $destuname - username for permanent storage of uploaded file
# $dsetudom - domain for permanaent storage of uploaded file	# $destudom - domain for permanaent storage of uploaded file
# $thumbwidth - width (pixels) of thumbnail to make for uploaded image	# $thumbwidth - width (pixels) of thumbnail to make for uploaded image
# $thumbheight - height (pixels) of thumbnail to make for uploaded image	# $thumbheight - height (pixels) of thumbnail to make for uploaded image
# $resizewidth - width (pixels) to which to resize uploaded image	# $resizewidth - width (pixels) to which to resize uploaded image
Line 4090 sub finishuserfileupload {	Line 4366 sub finishuserfileupload {
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {	if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
my $input = $filepath.'/'.$file;	my $input = $filepath.'/'.$file;
my $output = $filepath.'/'.'tn-'.$file;	my $output = $filepath.'/'.'tn-'.$file;
	my $makethumb;
my $thumbsize = $thumbwidth.'x'.$thumbheight;	my $thumbsize = $thumbwidth.'x'.$thumbheight;
my @args = ('convert','-sample',$thumbsize,$input,$output);	if ($context eq 'toollogo') {
system({$args[0]} @args);	my ($fullwidth,$fullheight) = &check_dimensions($input);
if (-e $filepath.'/'.'tn-'.$file) {	if ($fullwidth ne '' && $fullheight ne '') {
$fetchthumb = 1;	if ($fullwidth > $thumbwidth && $fullheight > $thumbheight) {
	$makethumb = 1;
	}
	}
	} else {
	$makethumb = 1;
	}
	if ($makethumb) {
	my @args = ('convert','-sample',$thumbsize,$input,$output);
	system({$args[0]} @args);
	if (-e $filepath.'/'.'tn-'.$file) {
	$fetchthumb = 1;
	}
}	}
}	}

Line 4326 sub embedded_dependency {	Line 4615 sub embedded_dependency {
return;	return;
}	}

	sub check_dimensions {
	my ($inputfile) = @_;
	my ($fullwidth,$fullheight);
	if (($inputfile =~ m\|^[/\w.\-]+$\|) && (-e $inputfile)) {
	my $mm = new File::MMagic;
	my $mime_type = $mm->checktype_filename($inputfile);
	if ($mime_type =~ m{^image/}) {
	if (open(PIPE,"identify $inputfile 2>&1 \|")) {
	my $imageinfo = <PIPE>;
	if (!close(PIPE)) {
	&Apache::lonnet::logthis("Failed to close PIPE opened to retrieve image information for $inputfile");
	}
	chomp($imageinfo);
	my ($fullsize) =
	($imageinfo =~ /^\Q$inputfile\E\s+\w+\s+(\d+x\d+)/);
	if ($fullsize) {
	($fullwidth,$fullheight) = split(/x/,$fullsize);
	}
	}
	}
	}
	return ($fullwidth,$fullheight);
	}

sub bubblesheet_converter {	sub bubblesheet_converter {
my ($cdom,$fullpath,$config,$format) = @_;	my ($cdom,$fullpath,$config,$format) = @_;
if ((&domain($cdom) ne '') &&	if ((&domain($cdom) ne '') &&
Line 4562 sub get_scantronformat_file {	Line 4875 sub get_scantronformat_file {
close($fh);	close($fh);
}	}
}	}
	chomp(@lines);
}	}
return @lines;	return @lines;
}	}
Line 4688 sub flushcourselogs {	Line 5002 sub flushcourselogs {
# Typo in rev. 1.458 (2003/12/09)??	# Typo in rev. 1.458 (2003/12/09)??
# These should likely by $env{'course.'.$cid.'.domain'} and $env{'course.'.$cid.'.num'}	# These should likely by $env{'course.'.$cid.'.domain'} and $env{'course.'.$cid.'.num'}
#	#
# While these ramain as $env{'request.'.$cid.'.domain'} and $env{'request.'.$cid.'.num'}	# While these remain as $env{'request.'.$cid.'.domain'} and $env{'request.'.$cid.'.num'}
# $dom and $name will always be null, so the &inc() call will default to storing this data	# $dom and $name will always be null, so the &inc() call will default to storing this data
# in a nohist_accesscount.db file for the user rather than the course.	# in a nohist_accesscount.db file for the user rather than the course.
#	#
Line 4917 sub courserolelog {	Line 5231 sub courserolelog {
$storehash{'group'} = $sec;	$storehash{'group'} = $sec;
} else {	} else {
$storehash{'section'} = $sec;	$storehash{'section'} = $sec;
	my ($curruserdomstr,$newuserdomstr);
	if (exists($env{'course.'.$cdom.'_'.$cnum.'.internal.userdomains'})) {
	$curruserdomstr = $env{'course.'.$env{'request.course.id'}.'.internal.userdomains'};
	} else {
	my %courseinfo = &coursedescription($cdom.'/'.$cnum);
	$curruserdomstr = $courseinfo{'internal.userdomains'};
	}
	if ($curruserdomstr ne '') {
	my @udoms = split(/,/,$curruserdomstr);
	unless (grep(/^\Q$domain\E/,@udoms)) {
	push(@udoms,$domain);
	$newuserdomstr = join(',',sort(@udoms));
	}
	} else {
	$newuserdomstr = $domain;
	}
	if ($newuserdomstr ne '') {
	my $putresult = &put('environment',{ 'internal.userdomains' => $newuserdomstr },
	$cdom,$cnum);
	if ($putresult eq 'ok') {
	unless (($selfenroll) \|\| ($context eq 'selfenroll')) {
	if (($context eq 'createcourse') \|\| ($context eq 'requestcourses') \|\|
	($context eq 'automated') \|\| ($context eq 'domain')) {
	$env{'course.'.$cdom.'_'.$cnum.'.internal.userdomains'} = $newuserdomstr;
	} elsif ($env{'request.course.id'} eq $cdom.'_'.$cnum) {
	&appenv({'course.'.$cdom.'_'.$cnum.'.internal.userdomains' => $newuserdomstr});
	}
	}
	}
	}
}	}
&write_log('course',$namespace,\%storehash,$delflag,$username,	&write_log('course',$namespace,\%storehash,$delflag,$username,
$domain,$cnum,$cdom);	$domain,$cnum,$cdom);
Line 4964 sub coauthorrolelog {	Line 5308 sub coauthorrolelog {
return;	return;
}	}

	sub authorarchivelog {
	my ($hashref,$size,$filesdest,$action) = @_;
	my $lonprtdir = $Apache::lonnet::perlvar{'lonPrtDir'};
	my $londocroot = $Apache::lonnet::perlvar{'lonDocRoot'};
	$filesdest =~ s{^\Q$lonprtdir/\E}{};
	if ($filesdest =~ m{^($match_username)_($match_domain)_archive_(\d+_\d+_\d+(\|[.\w]+))$}) {
	my ($auname,$audom,$id) = ($1,$2,$3);
	if (ref($hashref) eq 'HASH') {
	my $namespace = 'archivelog';
	my $dir;
	if ($hashref->{dir} =~ m{^\Q$londocroot/priv/$audom/$auname\E(.*)$}) {
	$dir = $1;
	}
	my $delflag = 0;
	my %storehash = (
	id => $id,
	dir => $dir,
	files => $hashref->{numfiles},
	subdirs => $hashref->{numdirs},
	bytes => $hashref->{bytes},
	size => $size,
	action => $action,
	);
	if ($action eq 'delete') {
	$delflag = 1;
	}
	&write_log('author',$namespace,\%storehash,$delflag,$auname,
	$audom,$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 5471 sub courselastaccess {	Line 5848 sub courselastaccess {
sub extract_lastaccess {	sub extract_lastaccess {
my ($returnhash,$rep) = @_;	my ($returnhash,$rep) = @_;
if (ref($returnhash) eq 'HASH') {	if (ref($returnhash) eq 'HASH') {
unless ($rep eq 'unknown_command' \|\| $rep eq 'no_such_host' \|\|	unless ($rep eq 'unknown_cmd' \|\| $rep eq 'no_such_host' \|\|
$rep eq 'con_lost' \|\| $rep eq 'rejected' \|\| $rep eq 'refused' \|\|	$rep eq 'con_lost' \|\| $rep eq 'rejected' \|\| $rep eq 'refused' \|\|
$rep eq '') {	$rep eq '') {
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
Line 6145 sub cstore {	Line 6522 sub cstore {

if ($stuname) { $home=&homeserver($stuname,$domain); }	if ($stuname) { $home=&homeserver($stuname,$domain); }

$symb=&symbclean($symb);	unless (($symb eq '_feedback') \|\| ($symb eq '_discussion')) {
	$symb=&symbclean($symb);
	}
if (!$symb) { unless ($symb=&symbread()) { return ''; } }	if (!$symb) { unless ($symb=&symbread()) { return ''; } }

if (!$domain) { $domain=$env{'user.domain'}; }	if (!$domain) { $domain=$env{'user.domain'}; }
if (!$stuname) { $stuname=$env{'user.name'}; }	if (!$stuname) { $stuname=$env{'user.name'}; }

&devalidate($symb,$stuname,$domain);	unless (($symb eq '_feedback') \|\| ($symb eq '_discussion')) {
	&devalidate($symb,$stuname,$domain);
	}

$symb=escape($symb);	$symb=escape($symb);
if (!$namespace) {	if (!$namespace) {
Line 6161 sub cstore {	Line 6542 sub cstore {
}	}
if (!$home) { $home=$env{'user.home'}; }	if (!$home) { $home=$env{'user.home'}; }

$$storehash{'ip'}=&get_requestor_ip();	$$storehash{'ip'} = &get_requestor_ip();
$$storehash{'host'}=$perlvar{'lonHostID'};	$$storehash{'host'}=$perlvar{'lonHostID'};

my $namevalue='';	my $namevalue='';
Line 6425 sub rolesinit {	Line 6806 sub rolesinit {
my %firstaccess = &dump('firstaccesstimes', $domain, $username);	my %firstaccess = &dump('firstaccesstimes', $domain, $username);
my %timerinterval = &dump('timerinterval', $domain, $username);	my %timerinterval = &dump('timerinterval', $domain, $username);
my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,	my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,
%timerintchk, %timerintenv);	%timerintchk, %timerintenv,%coauthorenv);

foreach my $key (keys(%firstaccess)) {	foreach my $key (keys(%firstaccess)) {
my ($cid, $rest) = split(/\0/, $key);	my ($cid, $rest) = split(/\0/, $key);
Line 6439 sub rolesinit {	Line 6820 sub rolesinit {

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

for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {	for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {
my $role = $rolesdump{$area};	my $role = $rolesdump{$area};
Line 6490 sub rolesinit {	Line 6873 sub rolesinit {
} else {	} else {
# Normal role, defined in roles.tab	# Normal role, defined in roles.tab
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);	&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
	if (($trole eq 'ca') \|\| ($trole eq 'aa')) {
	(undef,my ($audom,$auname)) = split(/\//,$area);
	unless ($gotcoauconfig{$area}) {
	my @ca_settings = ('authoreditors','coauthorlist','coauthoroptin');
	my %info = &userenvironment($audom,$auname,@ca_settings);
	$gotcoauconfig{$area} = 1;
	foreach my $item (@ca_settings) {
	if (exists($info{$item})) {
	my $name = $item;
	if ($item eq 'authoreditors') {
	$name = 'editors';
	unless ($info{'authoreditors'}) {
	my %domdefs;
	if (ref($domdefaults{$audom}) eq 'HASH') {
	%domdefs = %{$domdefaults{$audom}};
	} else {
	%domdefs = &get_domain_defaults($audom);
	$domdefaults{$audom} = \%domdefs;
	}
	if ($domdefs{$name} ne '') {
	$info{'authoreditors'} = $domdefs{$name};
	} else {
	$info{'authoreditors'} = 'edit,xml';
	}
	}
	}
	$coauthorenv{"environment.internal.$name.$area"} = $info{$item};
	}
	}
	}
	}
}	}

my $cid = $tdomain.'_'.$trest;	my $cid = $tdomain.'_'.$trest;
Line 6518 sub rolesinit {	Line 6932 sub rolesinit {
$env{'user.adv'} = $userroles{'user.adv'};	$env{'user.adv'} = $userroles{'user.adv'};
$env{'user.rar'} = $userroles{'user.rar'};	$env{'user.rar'} = $userroles{'user.rar'};

return (\%userroles,\%firstaccenv,\%timerintenv);	return (\%userroles,\%firstaccenv,\%timerintenv,\%coauthorenv);
}	}

sub set_arearole {	sub set_arearole {
Line 6579 sub course_adhocrole_privs {	Line 6993 sub course_adhocrole_privs {
$full{$priv} = $restrict;	$full{$priv} = $restrict;
}	}
foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) {	foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) {
next if ($item eq '');	next if ($item eq '');
my ($rule,$rest) = split(/=/,$item);	my ($rule,$rest) = split(/=/,$item);
next unless (($rule eq 'off') \|\| ($rule eq 'on'));	next unless (($rule eq 'off') \|\| ($rule eq 'on'));
foreach my $priv (split(/:/,$rest)) {	foreach my $priv (split(/:/,$rest)) {
if ($priv ne '') {	if ($priv ne '') {
if ($rule eq 'off') {	if ($rule eq 'off') {
$possremove{$priv} = 1;	$possremove{$priv} = 1;
} else {	} else {
$possadd{$priv} = 1;	$possadd{$priv} = 1;
}	}
}	}
}	}
}	}
foreach my $priv (sort(keys(%full))) {	foreach my $priv (sort(keys(%full))) {
if (exists($currprivs{$priv})) {	if (exists($currprivs{$priv})) {
unless (exists($possremove{$priv})) {	unless (exists($possremove{$priv})) {
$storeprivs{$priv} = $currprivs{$priv};	$storeprivs{$priv} = $currprivs{$priv};
}	}
} elsif (exists($possadd{$priv})) {	} elsif (exists($possadd{$priv})) {
$storeprivs{$priv} = $full{$priv};	$storeprivs{$priv} = $full{$priv};
}	}
}	}
$coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs)));	$coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs)));
}	}
return $coursepriv;	return $coursepriv;
}	}

sub group_roleprivs {	sub group_roleprivs {
Line 6878 sub set_adhoc_privileges {	Line 7292 sub set_adhoc_privileges {
if (&allowed('adv') eq 'F') { $tadv=1; }	if (&allowed('adv') eq 'F') { $tadv=1; }
&appenv({'request.role.adv' => $tadv});	&appenv({'request.role.adv' => $tadv});
}	}
	if ($role eq 'ca') {
	my @ca_settings = ('authoreditors','coauthorlist');
	my %info = &userenvironment($dcdom,$pickedcourse,@ca_settings);
	foreach my $item (@ca_settings) {
	if (exists($info{$item})) {
	my $name = $item;
	if ($item eq 'authoreditors') {
	$name = 'editors';
	unless ($info{'authoreditors'}) {
	my %domdefs = &get_domain_defaults($dcdom);
	if ($domdefs{$name} ne '') {
	$info{'authoreditors'} = $domdefs{$name};
	} else {
	$info{'authoreditors'} = 'edit,xml';
	}
	}
	}
	&appenv({"environment.internal.$name./$dcdom/$pickedcourse" => $info{$item}});
	}
	}
	}
}	}

# --------------------------------------------------------------- get interface	# --------------------------------------------------------------- get interface
Line 7410 sub portfolio_access {	Line 7845 sub portfolio_access {
}	}

sub get_portfolio_access {	sub get_portfolio_access {
my ($udom,$unum,$file_name,$group,$clientip,$access_hash) = @_;	my ($udom,$unum,$file_name,$group,$clientip,$access_hash,$portaccessref) = @_;

if (!ref($access_hash)) {	if (!ref($access_hash)) {
my $current_perms = &get_portfile_permissions($udom,$unum);	my $current_perms = &get_portfile_permissions($udom,$unum);
Line 7419 sub get_portfolio_access {	Line 7854 sub get_portfolio_access {
$access_hash = $access_controls{$file_name};	$access_hash = $access_controls{$file_name};
}	}

my ($public,$guest,@domains,@users,@courses,@groups,@ips);	my $portaccess;
	if (ref($portaccess) eq 'SCALAR') {
	$portaccess = $$portaccessref;
	} else {
	$portaccess = &usertools_access($unum,$udom,'portaccess',undef,'tools');
	}

	my ($public,$guest,@domains,@users,@courses,@groups,@ips,@userips);
my $now = time;	my $now = time;
if (ref($access_hash) eq 'HASH') {	if (ref($access_hash) eq 'HASH') {
foreach my $key (keys(%{$access_hash})) {	foreach my $key (keys(%{$access_hash})) {
my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d)_?(\d)$/);	my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d)_?(\d)$/);
	next if (($scope ne 'ip') && ($portaccess == 0));
if ($start > $now) {	if ($start > $now) {
next;	next;
}	}
Line 7445 sub get_portfolio_access {	Line 7888 sub get_portfolio_access {
push(@groups,$key);	push(@groups,$key);
} elsif ($scope eq 'ip') {	} elsif ($scope eq 'ip') {
push(@ips,$key);	push(@ips,$key);
	} elsif ($scope eq 'userip') {
	push(@userips,$key);
}	}
}	}
if ($public) {	if ($public) {
Line 7462 sub get_portfolio_access {	Line 7907 sub get_portfolio_access {
if ($allowed) {	if ($allowed) {
return 'ok';	return 'ok';
}	}
	} elsif (@userips > 0) {
	my $allowed;
	foreach my $useripkey (@userips) {
	if (ref($access_hash->{$useripkey}{'ip'}) eq 'ARRAY') {
	if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$useripkey}{'ip'}}),$clientip)) {
	$allowed = 1;
	last;
	}
	}
	}
	if ($allowed) {
	return 'ok';
	}
}	}
if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {	if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
if ($guest) {	if ($guest) {
Line 7637 sub is_portfolio_file {	Line 8095 sub is_portfolio_file {
return;	return;
}	}

	sub is_coursetool_logo {
	my ($uri) = @_;
	if ($env{'request.course.id'}) {
	my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
	if ($uri =~ m{^/*uploaded\Q$courseurl\E/toollogo/\d+/[^/]+$}) {
	return 1;
	}
	}
	return;
	}

sub usertools_access {	sub usertools_access {
my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;	my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;
my ($access,%tools);	my ($access,%tools);
Line 7649 sub usertools_access {	Line 8118 sub usertools_access {
unofficial => 1,	unofficial => 1,
community => 1,	community => 1,
textbook => 1,	textbook => 1,
	lti => 1,
);	);
} elsif ($context eq 'requestauthor') {	} elsif ($context eq 'requestauthor') {
%tools = (	%tools = (
requestauthor => 1,	requestauthor => 1,
);	);
	} elsif ($context eq 'authordefaults') {
	%tools = (
	webdav => 1,
	);
} else {	} else {
%tools = (	%tools = (
aboutme => 1,	aboutme => 1,
blog => 1,	blog => 1,
webdav => 1,	webdav => 1,
portfolio => 1,	portfolio => 1,
	portaccess => 1,
	timezone => 1,
);	);
}	}
return if (!defined($tools{$tool}));	return if (!defined($tools{$tool}));
Line 7675 sub usertools_access {	Line 8151 sub usertools_access {
return $env{'environment.canrequest.'.$tool};	return $env{'environment.canrequest.'.$tool};
} elsif ($context eq 'requestauthor') {	} elsif ($context eq 'requestauthor') {
return $env{'environment.canrequest.author'};	return $env{'environment.canrequest.author'};
	} elsif ($context eq 'authordefaults') {
	if ($tool eq 'webdav') {
	return $env{'environment.availabletools.'.$tool};
	}
} else {	} else {
return $env{'environment.availabletools.'.$tool};	return $env{'environment.availabletools.'.$tool};
}	}
Line 7684 sub usertools_access {	Line 8164 sub usertools_access {
my ($toolstatus,$inststatus,$envkey);	my ($toolstatus,$inststatus,$envkey);
if ($context eq 'requestauthor') {	if ($context eq 'requestauthor') {
$envkey = $context;	$envkey = $context;
	} elsif ($context eq 'authordefaults') {
	if ($tool eq 'webdav') {
	$envkey = 'tools.'.$tool;
	}
} else {	} else {
$envkey = $context.'.'.$tool;	$envkey = $context.'.'.$tool;
}	}
Line 7845 sub is_advanced_user {	Line 8329 sub is_advanced_user {
}	}

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

if ($priv eq 'evb') {	if ($priv eq 'evb') {
# Evade communication block restrictions for specified role in a course	# Evade communication block restrictions for specified role in a course or domain
if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {	if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
return $1;	return $1;
} else {	} else {
Line 8232 sub allowed {	Line 8720 sub allowed {

# If this is generating or modifying users, exit with special codes	# If this is generating or modifying users, exit with special codes

if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) {	if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa::vca:vaa:'=~/\:\Q$priv\E\:/) {
if (($priv eq 'cca') \|\| ($priv eq 'caa')) {	if (($priv eq 'cca') \|\| ($priv eq 'caa')) {
my ($audom,$auname)=split('/',$uri);	my ($audom,$auname)=split('/',$uri);
# no author name given, so this just checks on the general right to make a co-author in this domain	# no author name given, so this just checks on the general right to make a co-author in this domain
Line 8241 sub allowed {	Line 8729 sub allowed {
if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) \|\|	if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) \|\|
(($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) &&	(($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) &&
($audom ne $env{'request.role.domain'}))) { return ''; }	($audom ne $env{'request.role.domain'}))) { return ''; }
	} elsif (($priv eq 'vca') \|\| ($priv eq 'vaa')) {
	my ($audom,$auname)=split('/',$uri);
	unless ($auname) { return $thisallowed; }
	unless (($env{'request.role'} eq "dc./$audom") \|\|
	($env{'request.role'} eq "ca./$uri")) {
	return '';
	}
}	}
return $thisallowed;	return $thisallowed;
}	}
Line 8252 sub allowed {	Line 8747 sub allowed {

if ($env{'request.course.id'}) {	if ($env{'request.course.id'}) {

	if ($priv eq 'bre') {
	if (&is_coursetool_logo($uri)) {
	return 'F';
	}
	}

# If this is modifying password (internal auth) domains must match for user and user's role.	# If this is modifying password (internal auth) domains must match for user and user's role.

if ($priv eq 'mip') {	if ($priv eq 'mip') {
Line 8558 sub constructaccess {	Line 9059 sub constructaccess {
my ($ownername,$ownerdomain,$ownerhome);	my ($ownername,$ownerdomain,$ownerhome);

($ownerdomain,$ownername) =	($ownerdomain,$ownername) =
($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E\|)/priv/($match_domain)/($match_username)(?:/\|$)});	($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E\|)(?:/daxepage\|/daxeopen)?/priv/($match_domain)/($match_username)(?:/\|$)});

# The URL does not really point to any authorspace, forget it	# The URL does not really point to any authorspace, forget it
unless (($ownername) && ($ownerdomain)) { return ''; }	unless (($ownername) && ($ownerdomain)) { return ''; }
Line 9645 sub auto_instsec_reformat {	Line 10146 sub auto_instsec_reformat {
my $info = &freeze_escape($instsecref);	my $info = &freeze_escape($instsecref);
my $response=&reply('autoinstsecreformat:'.$cdom.':'.	my $response=&reply('autoinstsecreformat:'.$cdom.':'.
$action.':'.$info,$server);	$action.':'.$info,$server);
next if ($response =~ /(con_lost\|error\|no_such_host\|refused\|unknown_command)/);	next if ($response =~ /(con_lost\|error\|no_such_host\|refused\|unknown_cmd)/);
my @items = split(/&/,$response);	my @items = split(/&/,$response);
foreach my $item (@items) {	foreach my $item (@items) {
my ($key,$value) = split(/=/,$item);	my ($key,$value) = split(/=/,$item);
Line 9726 sub auto_export_grades {	Line 10227 sub auto_export_grades {
my $grades = &freeze_escape($gradesref);	my $grades = &freeze_escape($gradesref);
my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'.	my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'.
$info.':'.$grades,$homeserver);	$info.':'.$grades,$homeserver);
unless ($response =~ /(con_lost\|error\|no_such_host\|refused\|unknown_command)/) {	unless ($response =~ /(con_lost\|error\|no_such_host\|refused\|unknown_cmd)/) {
my @items = split(/&/,$response);	my @items = split(/&/,$response);
foreach my $item (@items) {	foreach my $item (@items) {
my ($key,$value) = split('=',$item);	my ($key,$value) = split('=',$item);
Line 9988 sub plaintext {	Line 10489 sub plaintext {
sub assignrole {	sub assignrole {
my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,	my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,
$context)=@_;	$context)=@_;
my $mrole;	my ($mrole,$rolelogcontext);
if ($role =~ /^cr\//) {	if ($role =~ /^cr\//) {
my $cwosec=$url;	my $cwosec=$url;
$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;	$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
Line 10060 sub assignrole {	Line 10561 sub assignrole {
}	}
}	}
}	}
} elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {	} elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
$refused = '';	if ($role eq 'st') {
	$refused = '';
	} elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) {
	$refused = '';
	}
} elsif ($context eq 'requestcourses') {	} elsif ($context eq 'requestcourses') {
my @possroles = ('st','ta','ep','in','cc','co');	my @possroles = ('st','ta','ep','in','cc','co');
if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {	if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
Line 10114 sub assignrole {	Line 10619 sub assignrole {
}	}
}	}
}	}
	} elsif (($context eq 'author') && (($role eq 'ca' \|\| $role eq 'aa'))) {
	if ($url =~ m{^/($match_domain)/($match_username)$}) {
	my ($audom,$auname) = ($1,$2);
	if ((&Apache::lonnet::allowed('v'.$role,"$audom/$auname")) &&
	($env{"environment.internal.manager.$url"})) {
	$refused = '';
	$rolelogcontext = 'coauthor';
	}
	}
}	}
if ($refused) {	if ($refused) {
&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.	&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
Line 10181 sub assignrole {	Line 10695 sub assignrole {
&domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,	&domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
$context);	$context);
} elsif (($role eq 'ca') \|\| ($role eq 'aa')) {	} elsif (($role eq 'ca') \|\| ($role eq 'aa')) {
	if ($rolelogcontext eq '') {
	$rolelogcontext = $context;
	}
&coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,	&coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
$context);	$rolelogcontext);
}	}
if ($role eq 'cc') {	if ($role eq 'cc') {
&autoupdate_coowners($url,$end,$start,$uname,$udom);	&autoupdate_coowners($url,$end,$start,$uname,$udom);
Line 10353 sub modifyuser {	Line 10870 sub modifyuser {
my $newuser;	my $newuser;
if ($uhome eq 'no_host') {	if ($uhome eq 'no_host') {
$newuser = 1;	$newuser = 1;
	unless (($umode && ($upass ne '')) \|\| ($umode eq 'localauth') \|\|
	($umode eq 'lti')) {
	return 'error: more information needed to create new user';
	}
}	}
# ----------------------------------------------------------------- Create User	# ----------------------------------------------------------------- Create User
if (($uhome eq 'no_host') &&	if (($uhome eq 'no_host') &&
(($umode && $upass) \|\| ($umode eq 'localauth'))) {	(($umode && $upass) \|\| ($umode eq 'localauth') \|\| ($umode eq 'lti'))) {
my $unhome='';	my $unhome='';
if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) {	if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) {
$unhome = $desiredhome;	$unhome = $desiredhome;
Line 10828 sub is_course {	Line 11349 sub is_course {
}	}

sub store_userdata {	sub store_userdata {
my ($storehash,$datakey,$namespace,$udom,$uname) = @_;	my ($storehash,$datakey,$namespace,$udom,$uname,$ip) = @_;
my $result;	my $result;
if ($datakey ne '') {	if ($datakey ne '') {
if (ref($storehash) eq 'HASH') {	if (ref($storehash) eq 'HASH') {
Line 10840 sub store_userdata {	Line 11361 sub store_userdata {
if (($uhome eq '') \|\| ($uhome eq 'no_host')) {	if (($uhome eq '') \|\| ($uhome eq 'no_host')) {
$result = 'error: no_host';	$result = 'error: no_host';
} else {	} else {
$storehash->{'ip'} = &get_requestor_ip();	if ($ip ne '') {
	$storehash->{'ip'} = $ip;
	} else {
	$storehash->{'ip'} = &get_requestor_ip();
	}
$storehash->{'host'} = $perlvar{'lonHostID'};	$storehash->{'host'} = $perlvar{'lonHostID'};

my $namevalue='';	my $namevalue='';
Line 11693 sub resdata {	Line 12218 sub resdata {

sub get_domain_lti {	sub get_domain_lti {
my ($cdom,$context) = @_;	my ($cdom,$context) = @_;
my ($name,%lti);	my ($name,$cachename,%lti);
if ($context eq 'consumer') {	if ($context eq 'consumer') {
$name = 'ltitools';	$name = 'ltitools';
} elsif ($context eq 'provider') {	} elsif ($context eq 'provider') {
$name = 'lti';	$name = 'lti';
	} elsif ($context eq 'linkprot') {
	$name = 'ltisec';
} else {	} else {
return %lti;	return %lti;
}	}
my ($result,$cached)=&is_cached_new($name,$cdom);	if ($context eq 'linkprot') {
	$cachename = $context;
	} else {
	$cachename = $name;
	}
	my ($result,$cached)=&is_cached_new($cachename,$cdom);
if (defined($cached)) {	if (defined($cached)) {
if (ref($result) eq 'HASH') {	if (ref($result) eq 'HASH') {
%lti = %{$result};	%lti = %{$result};
Line 11709 sub get_domain_lti {	Line 12241 sub get_domain_lti {
} else {	} else {
my %domconfig = &get_dom('configuration',[$name],$cdom);	my %domconfig = &get_dom('configuration',[$name],$cdom);
if (ref($domconfig{$name}) eq 'HASH') {	if (ref($domconfig{$name}) eq 'HASH') {
%lti = %{$domconfig{$name}};	if ($context eq 'linkprot') {
my %encdomconfig = &get_dom('encconfig',[$name],$cdom,undef,1);	if (ref($domconfig{$name}{'linkprot'}) eq 'HASH') {
if (ref($encdomconfig{$name}) eq 'HASH') {	%lti = %{$domconfig{$name}{'linkprot'}};
foreach my $id (keys(%lti)) {
if (ref($encdomconfig{$name}{$id}) eq 'HASH') {
foreach my $item ('key','secret') {
$lti{$id}{$item} = $encdomconfig{$name}{$id}{$item};
}
}
}	}
	} else {
	%lti = %{$domconfig{$name}};
}	}
}	}
my $cachetime = 246060;	my $cachetime = 246060;
&do_cache_new($name,$cdom,\%lti,$cachetime);	&do_cache_new($cachename,$cdom,\%lti,$cachetime);
}	}
return %lti;	return %lti;
}	}

sub get_course_lti {	sub get_course_lti {
my ($cnum,$cdom) = @_;	my ($cnum,$cdom,$context) = @_;
	my ($name,$cachename,%lti);
	if ($context eq 'consumer') {
	$name = 'ltitools';
	$cachename = 'courseltitools';
	} elsif ($context eq 'provider') {
	$name = 'lti';
	$cachename = 'courselti';
	} else {
	return %lti;
	}
my $hashid=$cdom.'_'.$cnum;	my $hashid=$cdom.'_'.$cnum;
my %courselti;	my ($result,$cached)=&is_cached_new($cachename,$hashid);
my ($result,$cached)=&is_cached_new('courselti',$hashid);
if (defined($cached)) {	if (defined($cached)) {
if (ref($result) eq 'HASH') {	if (ref($result) eq 'HASH') {
%courselti = %{$result};	%lti = %{$result};
}	}
} else {	} else {
%courselti = &dump('lti',$cdom,$cnum,undef,undef,undef,1);	%lti = &dump($name,$cdom,$cnum,undef,undef,undef,1);
my $cachetime = 246060;	my $cachetime = 246060;
&do_cache_new('courselti',$hashid,\%courselti,$cachetime);	&do_cache_new($cachename,$hashid,\%lti,$cachetime);
	}
	return %lti;
	}

	sub courselti_itemid {
	my ($cnum,$cdom,$url,$method,$params,$context) = @_;
	my ($chome,$itemid);
	$chome = &homeserver($cnum,$cdom);
	return if ($chome eq 'no_host');
	if (ref($params) eq 'HASH') {
	my $rep;
	if (grep { $_ eq $chome } current_machine_ids()) {
	$rep = LONCAPA::Lond::crslti_itemid($cdom,$cnum,$url,$method,$params,$perlvar{'lonVersion'});
	} else {
	my $escurl = &escape($url);
	my $escmethod = &escape($method);
	my $items = &freeze_escape($params);
	$rep = &reply("encrypt:lti:$cdom:$cnum:$context:$escurl:$escmethod:$items",$chome);
	}
	unless (($rep=~/^(refused\|rejected\|error)/) \|\| ($rep eq 'con_lost') \|\|
	($rep eq 'unknown_cmd')) {
	$itemid = $rep;
	}
	}
	return $itemid;
	}

	sub domainlti_itemid {
	my ($cdom,$url,$method,$params,$context) = @_;
	my ($primary_id,$itemid);
	$primary_id = &domain($cdom,'primary');
	return if ($primary_id eq '');
	if (ref($params) eq 'HASH') {
	my $rep;
	if (grep { $_ eq $primary_id } current_machine_ids()) {
	$rep = LONCAPA::Lond::domlti_itemid($cdom,$context,$url,$method,$params,$perlvar{'lonVersion'});
	} else {
	my $cnum = '';
	my $escurl = &escape($url);
	my $escmethod = &escape($method);
	my $items = &freeze_escape($params);
	$rep = &reply("encrypt:lti:$cdom:$cnum:$context:$escurl:$escmethod:$items",$primary_id);
	}
	unless (($rep=~/^(refused\|rejected\|error)/) \|\| ($rep eq 'con_lost') \|\|
	($rep eq 'unknown_cmd')) {
	$itemid = $rep;
	}
}	}
return %courselti;	return $itemid;
}	}

sub get_numsuppfiles {	sub get_ltitools_id {
my ($cnum,$cdom,$ignorecache)=@_;	my ($context,$cdom,$cnum,$title) = @_;
	my ($lockhash,$tries,$gotlock,$id,$error);

	# get lock on ltitools db
	$lockhash = {
	lock => $env{'user.name'}.
	':'.$env{'user.domain'},
	};
	$tries = 0;
	if ($context eq 'domain') {
	$gotlock = &newput_dom('ltitools',$lockhash,$cdom);
	} else {
	$gotlock = &newput('ltitools',$lockhash,$cdom,$cnum);
	}
	while (($gotlock ne 'ok') && ($tries<10)) {
	$tries ++;
	sleep (0.1);
	if ($context eq 'domain') {
	$gotlock = &newput_dom('ltitools',$lockhash,$cdom);
	} else {
	$gotlock = &newput('ltitools',$lockhash,$cdom,$cnum);
	}
	}
	if ($gotlock eq 'ok') {
	my %currids;
	if ($context eq 'domain') {
	%currids = &dump_dom('ltitools',$cdom);
	} else {
	%currids = &dump('ltitools',$cdom,$cnum);
	}
	if ($currids{'lock'}) {
	delete($currids{'lock'});
	if (keys(%currids)) {
	my @curr = sort { $a <=> $b } keys(%currids);
	if ($curr[-1] =~ /^\d+$/) {
	$id = 1 + $curr[-1];
	}
	} else {
	$id = 1;
	}
	if ($id) {
	if ($context eq 'domain') {
	unless (&newput_dom('ltitools',{ $id => $title },$cdom) eq 'ok') {
	$error = 'nostore';
	}
	} else {
	unless (&newput('ltitools',{ $id => $title },$cdom,$cnum) eq 'ok') {
	$error = 'nostore';
	}
	}
	} else {
	$error = 'nonumber';
	}
	}
	my $dellockoutcome;
	if ($context eq 'domain') {
	$dellockoutcome = &del_dom('ltitools',['lock'],$cdom);
	} else {
	$dellockoutcome = &del('ltitools',['lock'],$cdom,$cnum);
	}
	} else {
	$error = 'nolock';
	}
	return ($id,$error);
	}

	sub count_supptools {
	my ($cnum,$cdom,$ignorecache,$reload)=@_;
my $hashid=$cnum.':'.$cdom;	my $hashid=$cnum.':'.$cdom;
my ($suppcount,$cached);	my ($numexttools,$cached);
unless ($ignorecache) {	unless ($ignorecache) {
($suppcount,$cached) = &is_cached_new('suppcount',$hashid);	($numexttools,$cached) = &is_cached_new('supptools',$hashid);
}	}
unless (defined($cached)) {	unless (defined($cached)) {
my $chome=&homeserver($cnum,$cdom);	my $chome=&homeserver($cnum,$cdom);
	$numexttools = 0;
unless ($chome eq 'no_host') {	unless ($chome eq 'no_host') {
($suppcount,my $errors) = (0,0);	my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$reload);
my $suppmap = 'supplemental.sequence';	if (ref($supplemental) eq 'HASH') {
($suppcount,$errors) =	if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
&Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);	foreach my $key (keys(%{$supplemental->{'ids'}})) {
	if ($key =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
	$numexttools ++;
	}
	}
	}
	}
	}
	&do_cache_new('supptools',$hashid,$numexttools,600);
	}
	return $numexttools;
	}

	sub has_unhidden_suppfiles {
	my ($cnum,$cdom,$ignorecache,$possdel)=@_;
	my $hashid=$cnum.':'.$cdom;
	my ($showsupp,$cached);
	unless ($ignorecache) {
	($showsupp,$cached) = &is_cached_new('showsupp',$hashid);
	}
	unless (defined($cached)) {
	my $chome=&homeserver($cnum,$cdom);
	unless ($chome eq 'no_host') {
	my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$ignorecache,$possdel);
	if (ref($supplemental) eq 'HASH') {
	if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
	foreach my $key (keys(%{$supplemental->{'ids'}})) {
	next if ($key =~ /\.sequence$/);
	if (ref($supplemental->{'ids'}->{$key}) eq 'ARRAY') {
	foreach my $id (@{$supplemental->{'ids'}->{$key}}) {
	unless ($supplemental->{'hidden'}->{$id}) {
	$showsupp = 1;
	last;
	}
	}
	}
	last if ($showsupp);
	}
	}
	}
}	}
&do_cache_new('suppcount',$hashid,$suppcount,600);	&do_cache_new('showsupp',$hashid,$showsupp,600);
}	}
return $suppcount;	return $showsupp;
}	}

#	#
Line 12032 sub EXT {	Line 12723 sub EXT {
}	}
# ------------------------------------------ fourth, look in resource metadata	# ------------------------------------------ fourth, look in resource metadata

$spacequalifierrest=~s/\./\_/;	my $what = $spacequalifierrest;
my $filename;	$what=~s/\./\_/;
	my $filename;
if (!$symbparm) { $symbparm=&symbread(); }	if (!$symbparm) { $symbparm=&symbread(); }
if ($symbparm) {	if ($symbparm) {
$filename=(&decode_symb($symbparm))[2];	$filename=(&decode_symb($symbparm))[2];
} else {	} else {
$filename=$env{'request.filename'};	$filename=$env{'request.filename'};
}	}
my $metadata=&metadata($filename,$spacequalifierrest);	my $toolsymb;
	if (($filename =~ /ext\.tool$/) && ($what ne '0_gradable')) {
	$toolsymb = $symbparm;
	}
	my $metadata=&metadata($filename,$what,$toolsymb);
if (defined($metadata)) { return &get_reply([$metadata,'resource']); }	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);	$metadata=&metadata($filename,'parameter_'.$what,$toolsymb);
if (defined($metadata)) { return &get_reply([$metadata,'resource']); }	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }

# ---------------------------------------------- fourth, look in rest of course	# ----------------------------------------------- fifth, look in rest of course
if ($symbparm && defined($courseid) &&	if ($symbparm && defined($courseid) &&
$courseid eq $env{'request.course.id'}) {	$courseid eq $env{'request.course.id'}) {
my $coursereply=&resdata($env{'course.'.$courseid.'.num'},	my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
Line 12066 sub EXT {	Line 12762 sub EXT {
if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }	if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }
}	}
if ($recurse) { return undef; }	if ($recurse) { return undef; }
my $pack_def=&packages_tab_default($filename,$varname);	my $pack_def=&packages_tab_default($filename,$varname,$toolsymb);
if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }	if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }
# ---------------------------------------------------- Any other user namespace	# ---------------------------------------------------- Any other user namespace
} elsif ($realm eq 'environment') {	} elsif ($realm eq 'environment') {
Line 12150 sub get_map_hierarchy {	Line 12846 sub get_map_hierarchy {
return @recurseup;	return @recurseup;
}	}

)	}

sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().	sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
my ($courseid,@groups) = @_;	my ($courseid,@groups) = @_;
Line 12159 sub sort_course_groups { # Sort groups b	Line 12855 sub sort_course_groups { # Sort groups b
}	}

sub packages_tab_default {	sub packages_tab_default {
my ($uri,$varname)=@_;	my ($uri,$varname,$toolsymb)=@_;
my (undef,$part,$name)=split(/\./,$varname);	my (undef,$part,$name)=split(/\./,$varname);

my (@extension,@specifics,$do_default);	my (@extension,@specifics,$do_default);
foreach my $package (split(/,/,&metadata($uri,'packages'))) {	foreach my $package (split(/,/,&metadata($uri,'packages',$toolsymb))) {
my ($pack_type,$pack_part)=split(/_/,$package,2);	my ($pack_type,$pack_part)=split(/_/,$package,2);
if ($pack_type eq 'default') {	if ($pack_type eq 'default') {
$do_default=1;	$do_default=1;
Line 12232 my %metaentry;	Line 12928 my %metaentry;
my %importedpartids;	my %importedpartids;
my %importedrespids;	my %importedrespids;
sub metadata {	sub metadata {
my ($uri,$what,$liburi,$prefix,$depthcount)=@_;	my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_;
$uri=&declutter($uri);	$uri=&declutter($uri);
# if it is a non metadata possible uri return quickly	# if it is a non metadata possible uri return quickly
if (($uri eq '') \|\|	if (($uri eq '') \|\|
Line 12256 sub metadata {	Line 12952 sub metadata {
my ($result,$cached)=&is_cached_new('meta',$uri);	my ($result,$cached)=&is_cached_new('meta',$uri);
if (defined($cached)) { return $result->{':'.$what}; }	if (defined($cached)) { return $result->{':'.$what}; }
}	}

	#
	# If the uri is for an external tool the file from
	# which metadata should be retrieved depends on whether
	# the tool had been configured to be gradable (set in the Course
	# Editor or Resource Editor).
	#
	# If a valid symb has been included as the third arg in the call
	# to &metadata() that can be used to retrieve the value of
	# parameter_0_gradable set for the resource, and included in the
	# uploaded map containing the tool. The value is retrieved via
	# &EXT(), if a valid symb is available. Otherwise the value of
	# gradable in the exttool_$marker.db file for the tool instance
	# is retrieved via &get().
	#
	# When lonuserstate::traceroute() calls lonnet::EXT() for
	# hiddenresource and encrypturl (during course initialization)
	# the map-level parameter for resource.0.gradable included in the
	# uploaded map containing the tool will not yet have been stored
	# in the user_course_parms.db file for the user's session, so in
	# this case fall back to retrieving gradable status from the
	# exttool_$marker.db file.
	#
	# In order to avoid an infinite loop, &metadata() will return
	# before a call to &EXT(), if the uri is for an external tool
	# and the $what for which metadata is being requested is
	# parameter_0_gradable or 0_gradable.
	#

	if ($uri =~ /ext\.tool$/) {
	if (($what eq 'parameter_0_gradable') \|\| ($what eq '0_gradable')) {
	return;
	} else {
	my ($checked,$use_passback);
	if ($toolsymb ne '') {
	(undef,undef,my $tooluri) = &decode_symb($toolsymb);
	if (($tooluri eq $uri) && (&EXT('resource.0.gradable',$toolsymb))) {
	$checked = 1;
	if (&EXT('resource.0.gradable',$toolsymb) =~ /^yes$/i) {
	$use_passback = 1;
	}
	}
	}
	unless ($checked) {
	my ($ignore,$cdom,$cnum,$marker) = split(m{/},$uri);
	$marker=~s/\D//g;
	if ($marker) {
	my %toolsettings=&get('exttool_'.$marker,['gradable'],$cdom,$cnum);
	$use_passback = $toolsettings{'gradable'};
	}
	}
	if ($use_passback) {
	$filename = '/home/httpd/html/res/lib/templates/LTIpassback.tool';
	} else {
	$filename = '/home/httpd/html/res/lib/templates/LTIstandard.tool';
	}
	}
	}

{	{
# Imported parts would go here	# Imported parts would go here
my @origfiletagids=();	my @origfiletagids=();
Line 12429 sub metadata {	Line 13184 sub metadata {

if ($depthcount<20) {	if ($depthcount<20) {
my $metadata =	my $metadata =
&metadata($uri,'keys', $location,$unikey,	&metadata($uri,'keys',$toolsymb,$location,$unikey,
$depthcount+1);	$depthcount+1);
foreach my $meta (split(',',$metadata)) {	foreach my $meta (split(',',$metadata)) {
$metaentry{':'.$meta}=$metaentry{':'.$meta};	$metaentry{':'.$meta}=$metaentry{':'.$meta};
Line 12504 sub metadata {	Line 13259 sub metadata {
$dir=~s\|[^/]*$\|\|;	$dir=~s\|[^/]*$\|\|;
$location=&filelocation($dir,$location);	$location=&filelocation($dir,$location);
my $rights_metadata =	my $rights_metadata =
&metadata($uri,'keys',$location,'_rights',	&metadata($uri,'keys',$toolsymb,$location,'_rights',
$depthcount+1);	$depthcount+1);
foreach my $rights (split(',',$rights_metadata)) {	foreach my $rights (split(',',$rights_metadata)) {
#$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};	#$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
Line 12773 sub get_coursechange {	Line 13528 sub get_coursechange {
}	}

sub devalidate_coursechange_cache {	sub devalidate_coursechange_cache {
my ($cnum,$cdom)=@_;	my ($cdom,$cnum)=@_;
my $hashid=$cnum.':'.$cdom;	my $hashid=$cdom.'_'.$cnum;
&devalidate_cache_new('crschange',$hashid);	&devalidate_cache_new('crschange',$hashid);
}	}

	sub get_suppchange {
	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('suppchange',$hashid);
	if ((defined($cached)) && ($change ne '')) {
	return $change;
	} else {
	my %crshash = &get('environment',['internal.supplementalchange'],$cdom,$cnum);
	if ($crshash{'internal.supplementalchange'} 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.supplementalchange'};
	}
	my $cachetime = 600;
	&do_cache_new('suppchange',$hashid,$change,$cachetime);
	}
	return $change;
	}

	sub devalidate_suppchange_cache {
	my ($cdom,$cnum)=@_;
	my $hashid=$cdom.'_'.$cnum;
	&devalidate_cache_new('suppchange',$hashid);
	}

	sub update_supp_caches {
	my ($cdom,$cnum) = @_;
	my %servers = &internet_dom_servers($cdom);
	my @ids=&current_machine_ids();
	foreach my $server (keys(%servers)) {
	next if (grep(/^\Q$server\E$/,@ids));
	my $hashid=$cnum.':'.$cdom;
	my $cachekey = &escape('showsupp').':'.&escape($hashid);
	&remote_devalidate_cache($server,[$cachekey]);
	}
	&has_unhidden_suppfiles($cnum,$cdom,1,1);
	&count_supptools($cnum,$cdom,1);
	my $now = time;
	if ($env{'request.course.id'} eq $cdom.'_'.$cnum) {
	&Apache::lonnet::appenv({'request.course.suppupdated' => $now});
	}
	&put('environment',{'internal.supplementalchange' => $now},
	$cdom,$cnum);
	&Apache::lonnet::appenv(
	{'course.'.$cdom.'_'.$cnum.'.internal.supplementalchange' => $now});
	&do_cache_new('suppchange',$cdom.'_'.$cnum,$now,600);
	}

# ------------------------------------------------- Update symbolic store links	# ------------------------------------------------- Update symbolic store links

sub symblist {	sub symblist {
Line 12964 sub symbread {	Line 13776 sub symbread {
my %bighash;	my %bighash;
my $syval='';	my $syval='';
if (($env{'request.course.fn'}) && ($thisfn)) {	if (($env{'request.course.fn'}) && ($thisfn)) {
my $targetfn = $thisfn;
if ( ($thisfn =~ m/^(uploaded\|editupload)\//) && ($thisfn !~ m/\.(page\|sequence)$/) ) {
$targetfn = 'adm/wrapper/'.$thisfn;
}
if ($targetfn =~ m\|^adm/wrapper/(ext/.*)\|) {
$targetfn=$1;
}
unless ($ignoresymbdb) {	unless ($ignoresymbdb) {
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',	if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
&GDBM_READER(),0640)) {	&GDBM_READER(),0640)) {
$syval=$hash{$targetfn};	$syval=$hash{$thisfn};
untie(%hash);	untie(%hash);
}	}
if ($syval && $checkforblock) {	if ($syval && $checkforblock) {
Line 13496 sub receipt {	Line 14301 sub receipt {
}	}

sub whichuser {	sub whichuser {
my ($passedsymb)=@_;	my ($passedsymb,$ignorecachednull)=@_;
my ($symb,$courseid,$domain,$name,$publicuser);	my ($symb,$courseid,$domain,$name,$publicuser);
if (defined($env{'form.grade_symb'})) {	if (defined($env{'form.grade_symb'})) {
my ($tmp_courseid)=&get_env_multiple('form.grade_courseid');	my ($tmp_courseid)=&get_env_multiple('form.grade_courseid');
Line 13516 sub whichuser {	Line 14321 sub whichuser {
}	}
}	}
if (!$passedsymb) {	if (!$passedsymb) {
$symb=&symbread();	$symb=&symbread('','',$ignorecachednull);
} else {	} else {
$symb=$passedsymb;	$symb=$passedsymb;
}	}
Line 15512 data base, returning a hash that is keye	Line 16317 data base, returning a hash that is keye
values that are the resource value. I believe that the timestamps and	values that are the resource value. I believe that the timestamps and
versions are also returned.	versions are also returned.

get_numsuppfiles($cnum,$cdom) : retrieve number of files in a course's
supplemental content area. This routine caches the number of files for
10 minutes.

=back	=back

=head2 Course Modification	=head2 Course Modification
Line 15683 condval($condidx) : value of condition i	Line 16484 condval($condidx) : value of condition i

=item *	=item *

metadata($uri,$what,$liburi,$prefix,$depthcount) : request a	metadata($uri,$what,$toolsymb,$liburi,$prefix,$depthcount) : request a
resource's metadata, $what should be either a specific key, or either	resource's metadata, $what should be either a specific key, or either
'keys' (to get a list of possible keys) or 'packages' to get a list of	'keys' (to get a list of possible keys) or 'packages' to get a list of
packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata.	packages that this resource currently uses, the last 3 arguments are
	only used internally for recursive metadata.

	the toolsymb is only used where the uri is for an external tool (for which
	the uri as well as the symb are guaranteed to be unique).

this function automatically caches all requests	this function automatically caches all requests

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

Removed from v.1.1172.2.146.2.1
changed lines
	Added in v.1.1172.2.146.2.29