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.13 and 1.1172.2.152

version 1.1172.2.146.2.13, 2023/07/09 00:49:22	version 1.1172.2.152, 2024/12/29 14:47:27
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_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 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 1982 sub dump_dom {	Line 1905 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 1932 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 1957 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 1978 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 2012 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 2290 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 2512 sub get_domain_defaults {	Line 2376 sub get_domain_defaults {
'coursedefaults','usersessions',	'coursedefaults','usersessions',
'requestauthor','selfenrollment',	'requestauthor','selfenrollment',
'coursecategories','autoenroll',	'coursecategories','autoenroll',
'helpsettings','wafproxy','ltisec',	'helpsettings','wafproxy'],$domain);
'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 2385 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 2585 sub get_domain_defaults {	Line 2445 sub get_domain_defaults {
$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 2609 sub get_domain_defaults {	Line 2459 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 2682 sub get_domain_defaults {	Line 2529 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{'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 2792 sub get_passwdconf {	Line 2616 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 3675 sub can_edit_resource {	Line 3461 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 3736 sub can_edit_resource {	Line 3527 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 3768 sub can_edit_resource {	Line 3551 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 3785 sub can_edit_resource {	Line 3560 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 4087 sub resizeImage {	Line 3857 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 4099 sub resizeImage {	Line 3869 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 4310 sub finishuserfileupload {	Line 4080 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 4559 sub embedded_dependency {	Line 4316 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 4946 sub flushcourselogs {	Line 4679 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 5729 sub courselastaccess {	Line 5462 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 5833 my %cachedtimes=();	Line 5566 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 5845 sub load_all_first_access {	Line 5577 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 5857 sub get_first_access {	Line 5589 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 6837 sub course_adhocrole_privs {	Line 6569 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 7125 sub set_adhoc_privileges {	Line 6857 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 7201 sub unserialize {	Line 6932 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 7217 sub dump {	Line 6948 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 7368 sub inc {	Line 7094 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 7377 sub put {	Line 7103 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 7895 sub is_portfolio_file {	Line 7617 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 7918 sub usertools_access {	Line 7629 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 = (
Line 7930 sub usertools_access {	Line 7640 sub usertools_access {
blog => 1,	blog => 1,
webdav => 1,	webdav => 1,
portfolio => 1,	portfolio => 1,
timezone => 1,
);	);
}	}
return if (!defined($tools{$tool}));	return if (!defined($tools{$tool}));
Line 8116 sub is_advanced_user {	Line 7825 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 8155 sub check_can_request {	Line 7860 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 8220 sub customaccess {	Line 7925 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 8237 sub allowed {	Line 7942 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 8285 sub allowed {	Line 7990 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 8445 sub allowed {	Line 8147 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 8471 sub allowed {	Line 8167 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 8527 sub allowed {	Line 8217 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 8556 sub allowed {	Line 8240 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 8604 sub allowed {	Line 8282 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 8790 sub allowed {	Line 8462 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 8821 sub allowed {	Line 8482 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 9004 sub get_commblock_resources {	Line 8663 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 9015 sub get_commblock_resources {	Line 8673 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 9140 sub has_comm_blocking {	Line 8798 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 9926 sub auto_instsec_reformat {	Line 9503 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 10007 sub auto_export_grades {	Line 9584 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 10341 sub assignrole {	Line 9918 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 10638 sub modifyuser {	Line 10211 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 10933 sub writecoursepref {	Line 10502 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 11980 sub resdata {	Line 11544 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 count_supptools {
my ($cnum,$cdom,$ignorecache,$reload)=@_;
my $hashid=$cnum.':'.$cdom;	my $hashid=$cnum.':'.$cdom;
my ($numexttools,$cached);	my ($suppcount,$cached);
unless ($ignorecache) {	unless ($ignorecache) {
($numexttools,$cached) = &is_cached_new('supptools',$hashid);	($suppcount,$cached) = &is_cached_new('suppcount',$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') {
my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$reload);	($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);
if ($key =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
$numexttools ++;
}
}
}
}
}	}
&do_cache_new('supptools',$hashid,$numexttools,600);	&do_cache_new('suppcount',$hashid,$suppcount,600);
}	}
return $numexttools;	return $suppcount;
}

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('showsupp',$hashid,$showsupp,600);
}
return $showsupp;
}	}

#	#
# 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 12420 sub EXT {	Line 11822 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 12459 sub EXT {	Line 11856 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 12484 sub EXT {	Line 11881 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 12521 sub check_group_parms {	Line 11914 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 12552 sub sort_course_groups { # Sort groups b	Line 11921 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 12625 my %metaentry;	Line 11994 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 12649 sub metadata {	Line 12018 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 12881 sub metadata {	Line 12191 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 12956 sub metadata {	Line 12266 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 13225 sub get_coursechange {	Line 12535 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 14648 sub clutter {	Line 13901 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 15721 prevents recursive calls to &allowed.	Line 14972 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 16014 data base, returning a hash that is keye	Line 15264 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 16181 condval($condidx) : value of condition i	Line 15435 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.13
changed lines
	Added in v.1.1172.2.152