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.28 and 1.1172.2.147

version 1.1172.2.146.2.28, 2025/02/07 22:54:30	version 1.1172.2.147, 2022/02/27 02:19:13
Line 127 our @EXPORT = qw(%env);	Line 127 our @EXPORT = qw(%env);
$logid ++;	$logid ++;
my $now = time();	my $now = time();
my $id=$now.'00000'.$$.'00000'.$logid;	my $id=$now.'00000'.$$.'00000'.$logid;
my $ip = &get_requestor_ip();	my $ip = &get_requestor_ip();
my $logentry = {	my $logentry = {
$id => {	$id => {
'exe_uname' => $env{'user.name'},	'exe_uname' => $env{'user.name'},
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_cmd' \|\| $rep eq 'no_such_host' \|\|	unless ($rep eq 'unknown_command' \|\| $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 475 sub reply {	Line 418 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 'put')) {	($subcmd eq 'autoexportgrades')) {
splice(@rest,3,1,'Hidden');	splice(@rest,3,1,'Hidden');
}	}
$logged = join(':',('encrypt:'.$subcmd,@rest));	$logged = join(':',('encrypt:'.$subcmd,@rest));
Line 752 sub check_for_valid_session {	Line 694 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 1098 sub find_existing_session {	Line 1035 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 1386 sub authenticate {	Line 1309 sub authenticate {
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 1982 sub dump_dom {	Line 1882 sub dump_dom {
# ------------------------------------------ get items from domain db files	# ------------------------------------------ get items from domain db files

sub get_dom {	sub get_dom {
my ($namespace,$storearr,$udom,$uhome,$encrypt)=@_;	my ($namespace,$storearr,$udom,$uhome)=@_;
return if ($udom eq 'public');	return if ($udom eq 'public');
my $items='';	my $items='';
foreach my $item (@$storearr) {	foreach my $item (@$storearr) {
Line 2009 sub get_dom {	Line 1909 sub get_dom {
if (grep { $_ eq $uhome } &current_machine_ids()) {	if (grep { $_ eq $uhome } &current_machine_ids()) {
# domain information is hosted on this machine	# domain information is hosted on this machine
$rep = &LONCAPA::Lond::get_dom("getdom:$udom:$namespace:$items");	$rep = &LONCAPA::Lond::get_dom("getdom:$udom:$namespace:$items");
} else {	} else {
if ($encrypt) {	$rep=&reply("getdom:$udom:$namespace:$items",$uhome);
$rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);
} else {
$rep=&reply("getdom:$udom:$namespace:$items",$uhome);
}
}	}
my %returnhash;	my %returnhash;
if ($rep eq '' \|\| $rep =~ /^error: 2 /) {	if ($rep eq '' \|\| $rep =~ /^error: 2 /) {
Line 2038 sub get_dom {	Line 1934 sub get_dom {
# -------------------------------------------- put items in domain db files	# -------------------------------------------- put items in domain db files

sub put_dom {	sub put_dom {
my ($namespace,$storehash,$udom,$uhome,$encrypt)=@_;	my ($namespace,$storehash,$udom,$uhome)=@_;
if (!$udom) {	if (!$udom) {
$udom=$env{'user.domain'};	$udom=$env{'user.domain'};
if (defined(&domain($udom,'primary'))) {	if (defined(&domain($udom,'primary'))) {
Line 2059 sub put_dom {	Line 1955 sub put_dom {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';	$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
if ($encrypt) {	return &reply("putdom:$udom:$namespace:$items",$uhome);
return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);
} else {
return &reply("putdom:$udom:$namespace:$items",$uhome);
}
} else {	} else {
&logthis("put_dom failed - no homeserver and/or domain");	&logthis("put_dom failed - no homeserver and/or domain");
}	}
Line 2097 sub del_dom {	Line 1989 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 2426 sub inst_rulecheck {	Line 2267 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).
':'.$rulestr,$homeserver));	':'.$rulestr,$homeserver));
	} elsif ($item eq 'unamemap') {
	$response=&unescape(&reply('instunamemapcheck:'.
	&escape($udom).':'.&escape($uname).
	':'.$rulestr,$homeserver));
}	}
if ($response ne 'refused') {	if ($response ne 'refused') {
my @pairs=split(/\&/,$response);	my @pairs=split(/\&/,$response);
Line 2510 sub get_domain_defaults {	Line 2351 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','authordefaults',	'requestauthor','selfenrollment',
'selfenrollment','coursecategories',	'coursecategories','autoenroll',
'autoenroll','helpsettings',	'helpsettings','wafproxy'],$domain);
'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 2523 sub get_domain_defaults {	Line 2362 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'};
Line 2540 sub get_domain_defaults {	Line 2377 sub get_domain_defaults {
} else {	} else {
$domdefaults{'defaultquota'} = $domconfig{'quotas'};	$domdefaults{'defaultquota'} = $domconfig{'quotas'};
}	}
my @usertools = ('aboutme','blog','webdav','portfolio','portaccess');	my @usertools = ('aboutme','blog','webdav','portfolio');
foreach my $item (@usertools) {	foreach my $item (@usertools) {
if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {	if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
$domdefaults{$item} = $domconfig{'quotas'}{$item};	$domdefaults{$item} = $domconfig{'quotas'}{$item};
Line 2555 sub get_domain_defaults {	Line 2392 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 2581 sub get_domain_defaults {	Line 2407 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 2593 sub get_domain_defaults {	Line 2416 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 2626 sub get_domain_defaults {	Line 2436 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 2699 sub get_domain_defaults {	Line 2506 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 2769 sub get_dom_instcats {	Line 2542 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 2820 sub get_passwdconf {	Line 2592 sub get_passwdconf {
return %passwdconf;	return %passwdconf;
}	}

sub course_portal_url {
my ($cnum,$cdom,$r) = @_;
my $chome = &homeserver($cnum,$cdom);
my $hostname = &hostname($chome);
my $protocol = $protocol{$chome};
$protocol = 'http' if ($protocol ne 'https');
my %domdefaults = &get_domain_defaults($cdom);
my $firsturl;
if ($domdefaults{'portal_def'}) {
$firsturl = $domdefaults{'portal_def'};
} else {
my $alias = &Apache::lonnet::use_proxy_alias($r,$chome);
$hostname = $alias if ($alias ne '');
$firsturl = $protocol.'://'.$hostname;
}
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 3669 sub can_edit_resource {	Line 3403 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 3726 sub can_edit_resource {	Line 3437 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 3792 sub can_edit_resource {	Line 3498 sub can_edit_resource {
$cfile = '/adm/wrapper'.$resurl;	$cfile = '/adm/wrapper'.$resurl;
}	}
}	}
} elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {
$incourse = 1;
if ($env{'form.forceedit'}) {
$forceview = 1;
} else {
$forceedit = 1;
}
$cfile = $resurl;
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) {	} elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
$incourse = 1;	$incourse = 1;
if ($env{'form.forceedit'}) {	if ($env{'form.forceedit'}) {
Line 3824 sub can_edit_resource {	Line 3522 sub can_edit_resource {
$forceedit = 1;	$forceedit = 1;
}	}
$cfile = $resurl;	$cfile = $resurl;
} elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
$incourse = 1;
if ($env{'form.forceedit'}) {
$forceview = 1;
} else {
$forceedit = 1;
}
$cfile = $resurl;
} elsif (($resurl eq '/adm/extresedit') && ($symb \|\| $env{'form.folderpath'})) {	} elsif (($resurl eq '/adm/extresedit') && ($symb \|\| $env{'form.folderpath'})) {
$incourse = 1;	$incourse = 1;
$forceview = 1;	$forceview = 1;
Line 3841 sub can_edit_resource {	Line 3531 sub can_edit_resource {
$cfile = &clutter($res);	$cfile = &clutter($res);
} else {	} else {
$cfile = $env{'form.suppurl'};	$cfile = $env{'form.suppurl'};
my $escfile = &unescape($cfile);	$cfile =~ s{^http://}{};
if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {	$cfile = '/adm/wrapper/ext/'.$cfile;
$cfile = '/adm/wrapper'.$escfile;
} else {
$escfile =~ s{^http://}{};
$cfile = &escape("/adm/wrapper/ext/$escfile");
}
}	}
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) {	} elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
if ($env{'form.forceedit'}) {	if ($env{'form.forceedit'}) {
Line 4143 sub resizeImage {	Line 3828 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, toollogo or ''.	# canceloverwrite, scantron 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 4155 sub resizeImage {	Line 3840 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
# $destuname - username for permanent storage of uploaded file	# $desuname - username for permanent storage of uploaded file
# $destudom - domain for permanaent storage of uploaded file	# $dsetudom - 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 4366 sub finishuserfileupload {	Line 4051 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;
if ($context eq 'toollogo') {	my @args = ('convert','-sample',$thumbsize,$input,$output);
my ($fullwidth,$fullheight) = &check_dimensions($input);	system({$args[0]} @args);
if ($fullwidth ne '' && $fullheight ne '') {	if (-e $filepath.'/'.'tn-'.$file) {
if ($fullwidth > $thumbwidth && $fullheight > $thumbheight) {	$fetchthumb = 1;
$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 4615 sub embedded_dependency {	Line 4287 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 4875 sub get_scantronformat_file {	Line 4523 sub get_scantronformat_file {
close($fh);	close($fh);
}	}
}	}
chomp(@lines);
}	}
return @lines;	return @lines;
}	}
Line 5002 sub flushcourselogs {	Line 4649 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 remain as $env{'request.'.$cid.'.domain'} and $env{'request.'.$cid.'.num'}	# While these ramain 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 5231 sub courserolelog {	Line 4878 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 5308 sub coauthorrolelog {	Line 4925 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 5848 sub courselastaccess {	Line 5432 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_cmd' \|\| $rep eq 'no_such_host' \|\|	unless ($rep eq 'unknown_command' \|\| $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 5952 my %cachedtimes=();	Line 5536 my %cachedtimes=();
my $cachedtime='';	my $cachedtime='';

sub load_all_first_access {	sub load_all_first_access {
my ($uname,$udom,$ignorecache)=@_;	my ($uname,$udom)=@_;
if (($cachedkey eq $uname.':'.$udom) &&	if (($cachedkey eq $uname.':'.$udom) &&
(abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) &&	(abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) {
(!$ignorecache)) {
return;	return;
}	}
$cachedtime=time;	$cachedtime=time;
Line 5964 sub load_all_first_access {	Line 5547 sub load_all_first_access {
}	}

sub get_first_access {	sub get_first_access {
my ($type,$argsymb,$argmap,$ignorecache)=@_;	my ($type,$argsymb,$argmap)=@_;
my ($symb,$courseid,$udom,$uname)=&whichuser();	my ($symb,$courseid,$udom,$uname)=&whichuser();
if ($argsymb) { $symb=$argsymb; }	if ($argsymb) { $symb=$argsymb; }
my ($map,$id,$res)=&decode_symb($symb);	my ($map,$id,$res)=&decode_symb($symb);
Line 5976 sub get_first_access {	Line 5559 sub get_first_access {
} else {	} else {
$res=$symb;	$res=$symb;
}	}
&load_all_first_access($uname,$udom,$ignorecache);	&load_all_first_access($uname,$udom);
return $cachedtimes{"$courseid\0$res"};	return $cachedtimes{"$courseid\0$res"};
}	}

Line 6522 sub cstore {	Line 6105 sub cstore {

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

unless (($symb eq '_feedback') \|\| ($symb eq '_discussion')) {	$symb=&symbclean($symb);
$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'}; }

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

$symb=escape($symb);	$symb=escape($symb);
if (!$namespace) {	if (!$namespace) {
Line 6542 sub cstore {	Line 6121 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 6806 sub rolesinit {	Line 6385 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,%coauthorenv);	%timerintchk, %timerintenv);

foreach my $key (keys(%firstaccess)) {	foreach my $key (keys(%firstaccess)) {
my ($cid, $rest) = split(/\0/, $key);	my ($cid, $rest) = split(/\0/, $key);
Line 6820 sub rolesinit {	Line 6399 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 6873 sub rolesinit {	Line 6450 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 6932 sub rolesinit {	Line 6478 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,\%coauthorenv);	return (\%userroles,\%firstaccenv,\%timerintenv);
}	}

sub set_arearole {	sub set_arearole {
Line 6993 sub course_adhocrole_privs {	Line 6539 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 7281 sub set_adhoc_privileges {	Line 6827 sub set_adhoc_privileges {
my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash);	my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash);
&appenv(\%userroles,[$role,'cm']);	&appenv(\%userroles,[$role,'cm']);
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);	&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
unless (($caller eq 'constructaccess' && $env{'request.course.id'}) \|\|	unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {
($caller eq 'tiny')) {
&appenv( {'request.role' => $spec,	&appenv( {'request.role' => $spec,
'request.role.domain' => $dcdom,	'request.role.domain' => $dcdom,
'request.course.sec' => $sec,	'request.course.sec' => $sec,
Line 7292 sub set_adhoc_privileges {	Line 6837 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 7378 sub unserialize {	Line 6902 sub unserialize {
# see Lond::dump_with_regexp	# see Lond::dump_with_regexp
# if $escapedkeys hash keys won't get unescaped.	# if $escapedkeys hash keys won't get unescaped.
sub dump {	sub dump {
my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys,$encrypt)=@_;	my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }	if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }	if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);
Line 7394 sub dump {	Line 6918 sub dump {
$uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});	$uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
return %{&unserialize($reply, $escapedkeys)};	return %{&unserialize($reply, $escapedkeys)};
}	}
my $rep;	my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
if ($encrypt) {
$rep=&reply("encrypt:edump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
} else {
$rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
}
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
my %returnhash=();	my %returnhash=();
if (!($rep =~ /^error/ )) {	if (!($rep =~ /^error/ )) {
Line 7545 sub inc {	Line 7064 sub inc {
# --------------------------------------------------------------- put interface	# --------------------------------------------------------------- put interface

sub put {	sub put {
my ($namespace,$storehash,$udomain,$uname,$encrypt)=@_;	my ($namespace,$storehash,$udomain,$uname)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }	if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }	if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);
Line 7554 sub put {	Line 7073 sub put {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';	$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
if ($encrypt) {	return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
return &reply("encrypt:put:$udomain:$uname:$namespace:$items",$uhome);
} else {
return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
}
}	}

# ------------------------------------------------------------ newput interface	# ------------------------------------------------------------ newput interface
Line 7845 sub portfolio_access {	Line 7360 sub portfolio_access {
}	}

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

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 7854 sub get_portfolio_access {	Line 7369 sub get_portfolio_access {
$access_hash = $access_controls{$file_name};	$access_hash = $access_controls{$file_name};
}	}

my $portaccess;	my ($public,$guest,@domains,@users,@courses,@groups,@ips);
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 7888 sub get_portfolio_access {	Line 7395 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 7907 sub get_portfolio_access {	Line 7412 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 8095 sub is_portfolio_file {	Line 7587 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 8118 sub usertools_access {	Line 7599 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 8151 sub usertools_access {	Line 7625 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 8164 sub usertools_access {	Line 7634 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 8329 sub is_advanced_user {	Line 7795 sub is_advanced_user {
}	}

sub check_can_request {	sub check_can_request {
my ($dom,$can_request,$request_domains,$uname,$udom) = @_;	my ($dom,$can_request,$request_domains) = @_;
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($uname,$udom,$type,undef,	if (&usertools_access($env{'user.name'},
'requestcourses')) {	$env{'user.domain'},
	$type,undef,'requestcourses')) {
$canreq ++;	$canreq ++;
if (ref($request_domains) eq 'HASH') {	if (ref($request_domains) eq 'HASH') {
push(@{$request_domains->{$type}},$udom);	push(@{$request_domains->{$type}},$env{'user.domain'});
}	}
if ($dom eq $udom) {	if ($dom eq $env{'user.domain'}) {
$can_request->{$type} = 1;	$can_request->{$type} = 1;
}	}
}	}
if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') &&	if ($env{'environment.reqcrsotherdom.'.$type} 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 8368 sub check_can_request {	Line 7830 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 8433 sub customaccess {	Line 7895 sub customaccess {
# ------------------------------------------------- Check for a user privilege	# ------------------------------------------------- Check for a user privilege

sub allowed {	sub allowed {
my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache,$nodeeplinkcheck,$nodeeplinkout)=@_;	my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache)=@_;
my $ver_orguri=$uri;	my $ver_orguri=$uri;
$uri=&deversion($uri);	$uri=&deversion($uri);
my $orguri=$uri;	my $orguri=$uri;
$uri=&declutter($uri);	$uri=&declutter($uri);

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

if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }	if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
# Free bre access to adm and meta resources	# Free bre access to adm and meta resources
if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg\|bulletinboard\|viewclasslist\|aboutme\|ext\.tool)$}))	if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg\|bulletinboard\|viewclasslist\|aboutme)$}))
\|\| (($uri=~/\.meta$/) && ($uri!~m\|^uploaded/\|) ))	\|\| (($uri=~/\.meta$/) && ($uri!~m\|^uploaded/\|) ))
&& ($priv eq 'bre')) {	&& ($priv eq 'bre')) {
return 'F';	return 'F';
Line 8498 sub allowed {	Line 7960 sub allowed {
# Free bre to public access	# Free bre to public access

if ($priv eq 'bre') {	if ($priv eq 'bre') {
my $copyright;	my $copyright=&metadata($uri,'copyright');
unless ($uri =~ /ext\.tool/) {
$copyright=&metadata($uri,'copyright');
}
if (($copyright eq 'public') && (!$env{'request.course.id'})) {	if (($copyright eq 'public') && (!$env{'request.course.id'})) {
return 'F';	return 'F';
}	}
Line 8658 sub allowed {	Line 8117 sub allowed {
if ($env{'user.priv.'.$env{'request.role'}.'./'}	if ($env{'user.priv.'.$env{'request.role'}.'./'}
=~/\Q$priv\E\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
my $value = $1;	my $value = $1;
my $deeplinkblock;	if ($noblockcheck) {
unless ($nodeeplinkcheck) {
$deeplinkblock = &deeplink_check($priv,$symb,$uri);
}
if ($deeplinkblock) {
$thisallowed='D';
} elsif ($noblockcheck) {
$thisallowed.=$value;	$thisallowed.=$value;
} else {	} else {
my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);	my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
Line 8684 sub allowed {	Line 8137 sub allowed {
$refuri=&declutter($refuri);	$refuri=&declutter($refuri);
my ($match) = &is_on_map($refuri);	my ($match) = &is_on_map($refuri);
if ($match) {	if ($match) {
my $deeplinkblock;	if ($noblockcheck) {
unless ($nodeeplinkcheck) {
$deeplinkblock = &deeplink_check($priv,$symb,$refuri);
}
if ($deeplinkblock) {
$thisallowed='D';
} elsif ($noblockcheck) {
$thisallowed='F';	$thisallowed='F';
} else {	} else {
my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);	my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
Line 8720 sub allowed {	Line 8167 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::vca:vaa:'=~/\:\Q$priv\E\:/) {	if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\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 8729 sub allowed {	Line 8176 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 8747 sub allowed {	Line 8187 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 8776 sub allowed {	Line 8210 sub allowed {
=~/\Q$priv\E\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
my $value = $1;	my $value = $1;
if ($priv eq 'bre') {	if ($priv eq 'bre') {
my $deeplinkblock;	if ($noblockcheck) {
unless ($nodeeplinkcheck) {
$deeplinkblock = &deeplink_check($priv,$symb,$uri);
}
if ($deeplinkblock) {
$thisallowed = 'D';
} elsif ($noblockcheck) {
$thisallowed.=$value;	$thisallowed.=$value;
} else {	} else {
my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);	my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
Line 8824 sub allowed {	Line 8252 sub allowed {
=~/\Q$priv\E\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
my $value = $1;	my $value = $1;
if ($priv eq 'bre') {	if ($priv eq 'bre') {
my $deeplinkblock;	if ($noblockcheck) {
unless ($nodeeplinkcheck) {
$deeplinkblock = &deeplink_check($priv,$symb,$refuri);
}
if ($deeplinkblock) {
$thisallowed = 'D';
} elsif ($noblockcheck) {
$thisallowed.=$value;	$thisallowed.=$value;
} else {	} else {
my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);	my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
Line 9010 sub allowed {	Line 8432 sub allowed {
}	}
}	}

# Restricted for deeplinked session?

if ($env{'request.deeplink.login'}) {
if ($env{'acc.deeplinkout'} && !$nodeeplinkout) {
if (!$symb) { $symb=&symbread($uri,1); }
if (($symb) && ($env{'acc.deeplinkout'}=~/\&\Q$symb\E\&/)) {
return '';
}
}
}

# Restricted by state or randomout?	# Restricted by state or randomout?

if ($thisallowed=~/X/) {	if ($thisallowed=~/X/) {
Line 9041 sub allowed {	Line 8452 sub allowed {
return 'A';	return 'A';
} elsif ($thisallowed eq 'B') {	} elsif ($thisallowed eq 'B') {
return 'B';	return 'B';
} elsif ($thisallowed eq 'D') {
return 'D';
}	}
return 'F';	return 'F';
}	}
Line 9059 sub constructaccess {	Line 8468 sub constructaccess {
my ($ownername,$ownerdomain,$ownerhome);	my ($ownername,$ownerdomain,$ownerhome);

($ownerdomain,$ownername) =	($ownerdomain,$ownername) =
($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E\|)(?:/daxepage\|/daxeopen)?/priv/($match_domain)/($match_username)(?:/\|$)});	($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E\|)/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 9224 sub get_commblock_resources {	Line 8633 sub get_commblock_resources {
}	}
}	}
}	}
if ($interval[0] =~ /^(\d+)/) {	if ($interval[0] =~ /^\d+$/) {
my $timelimit = $1;
my $first_access;	my $first_access;
if ($type eq 'resource') {	if ($type eq 'resource') {
$first_access=&get_first_access($interval[1],$item);	$first_access=&get_first_access($interval[1],$item);
Line 9235 sub get_commblock_resources {	Line 8643 sub get_commblock_resources {
$first_access=&get_first_access($interval[1]);	$first_access=&get_first_access($interval[1]);
}	}
if ($first_access) {	if ($first_access) {
my $timesup = $first_access+$timelimit;	my $timesup = $first_access+$interval[0];
if ($timesup > $now) {	if ($timesup > $now) {
my $activeblock;	my $activeblock;
if ($type eq 'resource') {	if ($type eq 'resource') {
Line 9360 sub has_comm_blocking {	Line 8768 sub has_comm_blocking {
}	}
}	}

sub deeplink_check {
my ($priv,$symb,$uri) = @_;
return unless ($env{'request.course.id'});
return unless ($priv eq 'bre');
return if ($env{'request.state'} eq 'construct');
return if ($env{'request.role.adv'});
my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
my (%possibles,@symbs);
if (!$symb) {
$symb = &symbread($uri,1,1,1,\%possibles);
}
if ($symb) {
@symbs = ($symb);
} elsif (keys(%possibles)) {
@symbs = keys(%possibles);
}

my ($deeplink_symb,$allow);
if ($env{'request.deeplink.login'}) {
$deeplink_symb = &Apache::loncommon::deeplink_login_symb($cnum,$cdom);
}
foreach my $symb (@symbs) {
last if ($allow);
my $deeplink = &EXT("resource.0.deeplink",$symb);
if ($deeplink eq '') {
$allow = 1;
} else {
my ($state,$others,$listed,$scope,$protect) = split(/,/,$deeplink);
if ($state ne 'only') {
$allow = 1;
} else {
my $check_deeplink_entry;
if ($protect ne 'none') {
my ($acctype,$item) = split(/:/,$protect);
if (($acctype eq 'ltic') && ($env{'user.linkprotector'})) {
if (grep(/^\Q$item\Ec$/,split(/,/,$env{'user.linkprotector'}))) {
$check_deeplink_entry = 1
}
} elsif (($acctype eq 'ltid') && ($env{'user.linkprotector'})) {
if (grep(/^\Q$item\Ed$/,split(/,/,$env{'user.linkprotector'}))) {
$check_deeplink_entry = 1;
}
} elsif (($acctype eq 'key') && ($env{'user.deeplinkkey'})) {
if (grep(/^\Q$item\E$/,split(/,/,$env{'user.deeplinkkey'}))) {
$check_deeplink_entry = 1;
}
}
}
if (($protect eq 'none') \|\| ($check_deeplink_entry)) {
if ($scope eq 'res') {
if ($symb eq $deeplink_symb) {
$allow = 1;
}
} elsif (($scope eq 'map') \|\| ($scope eq 'rec')) {
my ($map_from_symb,$map_from_login);
$map_from_symb = &deversion((&decode_symb($symb))[0]);
if ($deeplink_symb =~ /\.(page\|sequence)$/) {
$map_from_login = &deversion((&decode_symb($deeplink_symb))[2]);
} else {
$map_from_login = &deversion((&decode_symb($deeplink_symb))[0]);
}
if (($map_from_symb) && ($map_from_login)) {
if ($map_from_symb eq $map_from_login) {
$allow = 1;
} elsif ($scope eq 'rec') {
my @recurseup = &get_map_hierarchy($map_from_symb,$env{'request.course.id'});
if (grep(/^\Q$map_from_login\E$/,@recurseup)) {
$allow = 1;
}
}
}
}
}
}
}
}
return if ($allow);
return 1;
}

# -------------------------------- Deversion and split uri into path an filename	# -------------------------------- Deversion and split uri into path an filename

#	#
Line 10146 sub auto_instsec_reformat {	Line 9473 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_cmd)/);	next if ($response =~ /(con_lost\|error\|no_such_host\|refused\|unknown_command)/);
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 10227 sub auto_export_grades {	Line 9554 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_cmd)/) {	unless ($response =~ /(con_lost\|error\|no_such_host\|refused\|unknown_command)/) {
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 10489 sub plaintext {	Line 9816 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,$rolelogcontext);	my $mrole;
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 10561 sub assignrole {	Line 9888 sub assignrole {
}	}
}	}
}	}
} elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {	} elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
if ($role eq 'st') {	$refused = '';
$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 10619 sub assignrole {	Line 9942 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 10695 sub assignrole {	Line 10009 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,
$rolelogcontext);	$context);
}	}
if ($role eq 'cc') {	if ($role eq 'cc') {
&autoupdate_coowners($url,$end,$start,$uname,$udom);	&autoupdate_coowners($url,$end,$start,$uname,$udom);
Line 10870 sub modifyuser {	Line 10181 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 eq 'lti'))) {	(($umode && $upass) \|\| ($umode eq 'localauth'))) {
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 11165 sub writecoursepref {	Line 10472 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,$cnum,$context,$category,$callercontext)=@_;	$course_owner,$crstype,$cnum,$context,$category)=@_;
$url=&declutter($url);	$url=&declutter($url);
my $cid='';	my $cid='';
if ($context eq 'requestcourses') {	if ($context eq 'requestcourses') {
my $can_create = 0;	my $can_create = 0;
my ($ownername,$ownerdom) = split(':',$course_owner);	my ($ownername,$ownerdom) = split(':',$course_owner);
if ($udom eq $ownerdom) {	if ($udom eq $ownerdom) {
my $reload;	if (&usertools_access($ownername,$ownerdom,$category,undef,
if (($callercontext eq 'auto') &&
($ownerdom eq $env{'user.domain'}) && ($ownername eq $env{'user.name'})) {
$reload = 'reload';
}
if (&usertools_access($ownername,$ownerdom,$category,$reload,
$context)) {	$context)) {
$can_create = 1;	$can_create = 1;
}	}
Line 11349 sub is_course {	Line 10651 sub is_course {
}	}

sub store_userdata {	sub store_userdata {
my ($storehash,$datakey,$namespace,$udom,$uname,$ip) = @_;	my ($storehash,$datakey,$namespace,$udom,$uname) = @_;
my $result;	my $result;
if ($datakey ne '') {	if ($datakey ne '') {
if (ref($storehash) eq 'HASH') {	if (ref($storehash) eq 'HASH') {
Line 11361 sub store_userdata {	Line 10663 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 {
if ($ip ne '') {	$storehash->{'ip'} = &get_requestor_ip();
$storehash->{'ip'} = $ip;
} else {
$storehash->{'ip'} = &get_requestor_ip();
}
$storehash->{'host'} = $perlvar{'lonHostID'};	$storehash->{'host'} = $perlvar{'lonHostID'};

my $namevalue='';	my $namevalue='';
Line 12216 sub resdata {	Line 11514 sub resdata {
return undef;	return undef;
}	}

sub get_domain_lti {	sub get_numsuppfiles {
my ($cdom,$context) = @_;	my ($cnum,$cdom,$ignorecache)=@_;
my ($name,$cachename,%lti);
if ($context eq 'consumer') {
$name = 'ltitools';
} elsif ($context eq 'provider') {
$name = 'lti';
} elsif ($context eq 'linkprot') {
$name = 'ltisec';
} else {
return %lti;
}
if ($context eq 'linkprot') {
$cachename = $context;
} else {
$cachename = $name;
}
my ($result,$cached)=&is_cached_new($cachename,$cdom);
if (defined($cached)) {
if (ref($result) eq 'HASH') {
%lti = %{$result};
}
} else {
my %domconfig = &get_dom('configuration',[$name],$cdom);
if (ref($domconfig{$name}) eq 'HASH') {
if ($context eq 'linkprot') {
if (ref($domconfig{$name}{'linkprot'}) eq 'HASH') {
%lti = %{$domconfig{$name}{'linkprot'}};
}
} else {
%lti = %{$domconfig{$name}};
}
}
my $cachetime = 246060;
&do_cache_new($cachename,$cdom,\%lti,$cachetime);
}
return %lti;
}

sub get_course_lti {
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 ($result,$cached)=&is_cached_new($cachename,$hashid);
if (defined($cached)) {
if (ref($result) eq 'HASH') {
%lti = %{$result};
}
} else {
%lti = &dump($name,$cdom,$cnum,undef,undef,undef,1);
my $cachetime = 246060;
&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 $itemid;
}

sub get_ltitools_id {
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 ($numexttools,$cached);
unless ($ignorecache) {
($numexttools,$cached) = &is_cached_new('supptools',$hashid);
}
unless (defined($cached)) {
my $chome=&homeserver($cnum,$cdom);
$numexttools = 0;
unless ($chome eq 'no_host') {
my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$reload);
if (ref($supplemental) eq 'HASH') {
if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
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 $hashid=$cnum.':'.$cdom;
my ($showsupp,$cached);	my ($suppcount,$cached);
unless ($ignorecache) {	unless ($ignorecache) {
($showsupp,$cached) = &is_cached_new('showsupp',$hashid);	($suppcount,$cached) = &is_cached_new('suppcount',$hashid);
}	}
unless (defined($cached)) {	unless (defined($cached)) {
my $chome=&homeserver($cnum,$cdom);	my $chome=&homeserver($cnum,$cdom);
unless ($chome eq 'no_host') {	unless ($chome eq 'no_host') {
my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$ignorecache,$possdel);	($suppcount,my $errors) = (0,0);
if (ref($supplemental) eq 'HASH') {	my $suppmap = 'supplemental.sequence';
if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {	($suppcount,$errors) =
foreach my $key (keys(%{$supplemental->{'ids'}})) {	&Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);
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('showsupp',$hashid,$showsupp,600);	&do_cache_new('suppcount',$hashid,$suppcount,600);
}	}
return $showsupp;	return $suppcount;
}	}

#	#
# EXT resource caching routines	# EXT resource caching routines
#	#

{
# Cache (5 seconds) of map hierarchy for speedup of navmaps display
#
# The course for which we cache
my $cachedmapkey='';
# The cached recursive maps for this course
my %cachedmaps=();
# When this was last done
my $cachedmaptime='';

sub clear_EXT_cache_status {	sub clear_EXT_cache_status {
&delenv('cache.EXT.');	&delenv('cache.EXT.');
}	}
Line 12723 sub EXT {	Line 11792 sub EXT {
}	}
# ------------------------------------------ fourth, look in resource metadata	# ------------------------------------------ fourth, look in resource metadata

my $what = $spacequalifierrest;	$spacequalifierrest=~s/\./\_/;
$what=~s/\./\_/;	my $filename;
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 $toolsymb;	my $metadata=&metadata($filename,$spacequalifierrest);
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_'.$what,$toolsymb);	$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
if (defined($metadata)) { return &get_reply([$metadata,'resource']); }	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }

# ----------------------------------------------- fifth, look in rest of course	# ---------------------------------------------- fourth, 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 12762 sub EXT {	Line 11826 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,$toolsymb);	my $pack_def=&packages_tab_default($filename,$varname);
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 12787 sub EXT {	Line 11851 sub EXT {
if ($space eq 'name') {	if ($space eq 'name') {
return $ENV{'SERVER_NAME'};	return $ENV{'SERVER_NAME'};
}	}
} elsif ($realm eq 'client') {
if ($space eq 'remote_addr') {
return &get_requestor_ip();
}
}	}
return '';	return '';
}	}
Line 12824 sub check_group_parms {	Line 11884 sub check_group_parms {
return $coursereply;	return $coursereply;
}	}

sub get_map_hierarchy {
my ($mapname,$courseid) = @_;
my @recurseup = ();
if ($mapname) {
if (($cachedmapkey eq $courseid) &&
(abs($cachedmaptime-time)<5)) {
if (ref($cachedmaps{$mapname}) eq 'ARRAY') {
return @{$cachedmaps{$mapname}};
}
}
my $navmap = Apache::lonnavmaps::navmap->new();
if (ref($navmap)) {
@recurseup = $navmap->recurseup_maps($mapname);
undef($navmap);
$cachedmaps{$mapname} = \@recurseup;
$cachedmaptime=time;
$cachedmapkey=$courseid;
}
}
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) = @_;
@groups = sort(@groups);	@groups = sort(@groups);
Line 12855 sub sort_course_groups { # Sort groups b	Line 11891 sub sort_course_groups { # Sort groups b
}	}

sub packages_tab_default {	sub packages_tab_default {
my ($uri,$varname,$toolsymb)=@_;	my ($uri,$varname)=@_;
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',$toolsymb))) {	foreach my $package (split(/,/,&metadata($uri,'packages'))) {
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 12928 my %metaentry;	Line 11964 my %metaentry;
my %importedpartids;	my %importedpartids;
my %importedrespids;	my %importedrespids;
sub metadata {	sub metadata {
my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_;	my ($uri,$what,$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 '') \|\|
(($uri =~ m\|^/*adm/\|) &&	(($uri =~ m\|^/*adm/\|) &&
($uri !~ m\|^adm/includes\|) && ($uri !~ m{/(smppg\|bulletinboard\|ext\.tool)$})) \|\|	($uri !~ m\|^adm/includes\|) && ($uri !~ m{/(smppg\|bulletinboard)$})) \|\|
($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ m{^/*uploaded/.+\.sequence$})) {	($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ m{^/*uploaded/.+\.sequence$})) {
return undef;	return undef;
}	}
Line 12952 sub metadata {	Line 11988 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 13184 sub metadata {	Line 12161 sub metadata {

if ($depthcount<20) {	if ($depthcount<20) {
my $metadata =	my $metadata =
&metadata($uri,'keys',$toolsymb,$location,$unikey,	&metadata($uri,'keys', $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 13259 sub metadata {	Line 12236 sub metadata {
$dir=~s\|[^/]*$\|\|;	$dir=~s\|[^/]*$\|\|;
$location=&filelocation($dir,$location);	$location=&filelocation($dir,$location);
my $rights_metadata =	my $rights_metadata =
&metadata($uri,'keys',$toolsymb,$location,'_rights',	&metadata($uri,'keys',$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 13528 sub get_coursechange {	Line 12505 sub get_coursechange {
}	}

sub devalidate_coursechange_cache {	sub devalidate_coursechange_cache {
my ($cdom,$cnum)=@_;	my ($cnum,$cdom)=@_;
my $hashid=$cdom.'_'.$cnum;	my $hashid=$cnum.':'.$cdom;
&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 13776 sub symbread {	Line 12696 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{$thisfn};	$syval=$hash{$targetfn};
untie(%hash);	untie(%hash);
}	}
if ($syval && $checkforblock) {	if ($syval && $checkforblock) {
Line 14951 sub clutter {	Line 13878 sub clutter {
# &logthis("Got a blank emb style");	# &logthis("Got a blank emb style");
}	}
}	}
} elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) {
$thisfn='/adm/wrapper'.$thisfn;
}	}
return $thisfn;	return $thisfn;
}	}
Line 16024 prevents recursive calls to &allowed.	Line 14949 prevents recursive calls to &allowed.
2: browse allowed	2: browse allowed
A: passphrase authentication needed	A: passphrase authentication needed
B: access temporarily blocked because of a blocking event in a course.	B: access temporarily blocked because of a blocking event in a course.
D: access blocked because access is required via session initiated via deep-link

=item *	=item *

Line 16317 data base, returning a hash that is keye	Line 15241 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 16484 condval($condidx) : value of condition i	Line 15412 condval($condidx) : value of condition i

=item *	=item *

metadata($uri,$what,$toolsymb,$liburi,$prefix,$depthcount) : request a	metadata($uri,$what,$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	packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata.
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.28
changed lines
	Added in v.1.1172.2.147