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

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

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

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

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

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


# check if user's browser sent load balancer cookie and server still has session	# check if user's browser sent load balancer cookie and server still has session
# and is not overloaded.	# and is not overloaded.
sub check_for_balancer_cookie {	sub check_for_balancer_cookie {
Line 2433 sub get_domain_defaults {	Line 2510 sub get_domain_defaults {
&Apache::lonnet::get_dom('configuration',['defaults','quotas',	&Apache::lonnet::get_dom('configuration',['defaults','quotas',
'requestcourses','inststatus',	'requestcourses','inststatus',
'coursedefaults','usersessions',	'coursedefaults','usersessions',
'requestauthor','selfenrollment',	'requestauthor','authordefaults',
'coursecategories','autoenroll',	'selfenrollment','coursecategories',
'helpsettings','wafproxy','ltisec'],$domain);	'autoenroll','helpsettings',
	'wafproxy','ltisec','toolsec',
	'domexttool','exttool'],$domain);
my @coursetypes = ('official','unofficial','community','textbook');	my @coursetypes = ('official','unofficial','community','textbook');
if (ref($domconfig{'defaults'}) eq 'HASH') {	if (ref($domconfig{'defaults'}) eq 'HASH') {
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};	$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
Line 2444 sub get_domain_defaults {	Line 2523 sub get_domain_defaults {
$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};	$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};	$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
$domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};	$domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};
	$domdefaults{'portal_def_email'} = $domconfig{'defaults'}{'portal_def_email'};
	$domdefaults{'portal_def_web'} = $domconfig{'defaults'}{'portal_def_web'};
$domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};	$domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};
$domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};	$domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};
$domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};	$domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};
Line 2459 sub get_domain_defaults {	Line 2540 sub get_domain_defaults {
} else {	} else {
$domdefaults{'defaultquota'} = $domconfig{'quotas'};	$domdefaults{'defaultquota'} = $domconfig{'quotas'};
}	}
my @usertools = ('aboutme','blog','webdav','portfolio');	my @usertools = ('aboutme','blog','webdav','portfolio','portaccess');
foreach my $item (@usertools) {	foreach my $item (@usertools) {
if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {	if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
$domdefaults{$item} = $domconfig{'quotas'}{$item};	$domdefaults{$item} = $domconfig{'quotas'}{$item};
Line 2474 sub get_domain_defaults {	Line 2555 sub get_domain_defaults {
$domdefaults{$item} = $domconfig{'requestcourses'}{$item};	$domdefaults{$item} = $domconfig{'requestcourses'}{$item};
}	}
}	}
	if (ref($domconfig{'authordefaults'}) eq 'HASH') {
	foreach my $item ('nocodemirror','copyright','sourceavail','domcoordacc','editors','archive') {
	if ($item eq 'editors') {
	if (ref($domconfig{'authordefaults'}{'editors'}) eq 'ARRAY') {
	$domdefaults{$item} = join(',',@{$domconfig{'authordefaults'}{'editors'}});
	}
	} else {
	$domdefaults{$item} = $domconfig{'authordefaults'}{$item};
	}
	}
	}
if (ref($domconfig{'requestauthor'}) eq 'HASH') {	if (ref($domconfig{'requestauthor'}) eq 'HASH') {
$domdefaults{'requestauthor'} = $domconfig{'requestauthor'};	$domdefaults{'requestauthor'} = $domconfig{'requestauthor'};
}	}
Line 2489 sub get_domain_defaults {	Line 2581 sub get_domain_defaults {
if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {
$domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};	$domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};
}	}
	if (ref($domconfig{'coursedefaults'}{'crseditors'}) eq 'ARRAY') {
	$domdefaults{'crseditors'}=join(',',@{$domconfig{'coursedefaults'}{'crseditors'}});
	}
foreach my $type (@coursetypes) {	foreach my $type (@coursetypes) {
if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
unless ($type eq 'community') {	unless ($type eq 'community') {
Line 2498 sub get_domain_defaults {	Line 2593 sub get_domain_defaults {
if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
$domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};	$domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};
}	}
	if (ref($domconfig{'coursedefaults'}{'coursequota'}) eq 'HASH') {
	$domdefaults{$type.'coursequota'} = $domconfig{'coursedefaults'}{'coursequota'}{$type};
	}
if ($domdefaults{'postsubmit'} eq 'on') {	if ($domdefaults{'postsubmit'} eq 'on') {
if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') {
$domdefaults{$type.'postsubtimeout'} =	$domdefaults{$type.'postsubtimeout'} =
$domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type};	$domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type};
}	}
}	}
	if (ref($domconfig{'coursedefaults'}{'domexttool'}) eq 'HASH') {
	$domdefaults{$type.'domexttool'} = $domconfig{'coursedefaults'}{'domexttool'}{$type};
	} else {
	$domdefaults{$type.'domexttool'} = 1;
	}
	if (ref($domconfig{'coursedefaults'}{'exttool'}) eq 'HASH') {
	$domdefaults{$type.'exttool'} = $domconfig{'coursedefaults'}{'exttool'}{$type};
	} else {
	$domdefaults{$type.'exttool'} = 0;
	}
}	}
if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') {
if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') {	if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') {
Line 2599 sub get_domain_defaults {	Line 2707 sub get_domain_defaults {
}	}
if (ref($domconfig{'ltisec'}{'private'}) eq 'HASH') {	if (ref($domconfig{'ltisec'}{'private'}) eq 'HASH') {
if (ref($domconfig{'ltisec'}{'private'}{'keys'}) eq 'ARRAY') {	if (ref($domconfig{'ltisec'}{'private'}{'keys'}) eq 'ARRAY') {
$domdefaults{'privhosts'} = $domconfig{'ltisec'}{'private'}{'keys'};	$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'};
}	}
}	}
}	}
Line 2708 sub course_portal_url {	Line 2838 sub course_portal_url {
return $firsturl;	return $firsturl;
}	}

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

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

sub assign_access_key {	sub assign_access_key {
Line 3519 sub can_edit_resource {	Line 3669 sub can_edit_resource {
}	}
}	}

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

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

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

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

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

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

	sub authorarchivelog {
	my ($hashref,$size,$filesdest,$action) = @_;
	my $lonprtdir = $Apache::lonnet::perlvar{'lonPrtDir'};
	my $londocroot = $Apache::lonnet::perlvar{'lonDocRoot'};
	$filesdest =~ s{^\Q$lonprtdir/\E}{};
	if ($filesdest =~ m{^($match_username)_($match_domain)_archive_(\d+_\d+_\d+(\|[.\w]+))$}) {
	my ($auname,$audom,$id) = ($1,$2,$3);
	if (ref($hashref) eq 'HASH') {
	my $namespace = 'archivelog';
	my $dir;
	if ($hashref->{dir} =~ m{^\Q$londocroot/priv/$audom/$auname\E(.*)$}) {
	$dir = $1;
	}
	my $delflag = 0;
	my %storehash = (
	id => $id,
	dir => $dir,
	files => $hashref->{numfiles},
	subdirs => $hashref->{numdirs},
	bytes => $hashref->{bytes},
	size => $size,
	action => $action,
	);
	if ($action eq 'delete') {
	$delflag = 1;
	}
	&write_log('author',$namespace,\%storehash,$delflag,$auname,
	$audom,$auname,$audom);
	}
	}
	return;
	}

sub get_course_adv_roles {	sub get_course_adv_roles {
my ($cid,$codes) = @_;	my ($cid,$codes) = @_;
$cid=$env{'request.course.id'} unless (defined($cid));	$cid=$env{'request.course.id'} unless (defined($cid));
Line 5570 sub courselastaccess {	Line 5848 sub courselastaccess {
sub extract_lastaccess {	sub extract_lastaccess {
my ($returnhash,$rep) = @_;	my ($returnhash,$rep) = @_;
if (ref($returnhash) eq 'HASH') {	if (ref($returnhash) eq 'HASH') {
unless ($rep eq 'unknown_command' \|\| $rep eq 'no_such_host' \|\|	unless ($rep eq 'unknown_cmd' \|\| $rep eq 'no_such_host' \|\|
$rep eq 'con_lost' \|\| $rep eq 'rejected' \|\| $rep eq 'refused' \|\|	$rep eq 'con_lost' \|\| $rep eq 'rejected' \|\| $rep eq 'refused' \|\|
$rep eq '') {	$rep eq '') {
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
Line 6244 sub cstore {	Line 6522 sub cstore {

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

my $namevalue='';	my $namevalue='';
Line 11803 sub get_domain_lti {	Line 12228 sub get_domain_lti {
} else {	} else {
return %lti;	return %lti;
}	}

if ($context eq 'linkprot') {	if ($context eq 'linkprot') {
$cachename = $context;	$cachename = $context;
} else {	} else {
$cachename = $name;	$cachename = $name;
}	}

my ($result,$cached)=&is_cached_new($cachename,$cdom);	my ($result,$cached)=&is_cached_new($cachename,$cdom);
if (defined($cached)) {	if (defined($cached)) {
if (ref($result) eq 'HASH') {	if (ref($result) eq 'HASH') {
Line 11825 sub get_domain_lti {	Line 12248 sub get_domain_lti {
} else {	} else {
%lti = %{$domconfig{$name}};	%lti = %{$domconfig{$name}};
}	}
if (($context eq 'consumer') && (keys(%lti))) {
my %encdomconfig = &get_dom('encconfig',[$name],$cdom,undef,1);
if (ref($encdomconfig{$name}) eq 'HASH') {
foreach my $id (keys(%lti)) {
if (ref($encdomconfig{$name}{$id}) eq 'HASH') {
foreach my $item ('key','secret') {
$lti{$id}{$item} = $encdomconfig{$name}{$id}{$item};
}
}
}
}
}
}	}
my $cachetime = 246060;	my $cachetime = 246060;
&do_cache_new($cachename,$cdom,\%lti,$cachetime);	&do_cache_new($cachename,$cdom,\%lti,$cachetime);
Line 11845 sub get_domain_lti {	Line 12256 sub get_domain_lti {
}	}

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

sub courselti_itemid {	sub courselti_itemid {
Line 11867 sub courselti_itemid {	Line 12287 sub courselti_itemid {
$chome = &homeserver($cnum,$cdom);	$chome = &homeserver($cnum,$cdom);
return if ($chome eq 'no_host');	return if ($chome eq 'no_host');
if (ref($params) eq 'HASH') {	if (ref($params) eq 'HASH') {
my $items = &freeze_escape($params);
my $rep;	my $rep;
if (grep { $_ eq $chome } current_machine_ids()) {	if (grep { $_ eq $chome } current_machine_ids()) {
$rep = LONCAPA::Lond::crslti_itemid($cdom,$cnum,$url,$method,$params,$perlvar{'lonVersion'});	$rep = LONCAPA::Lond::crslti_itemid($cdom,$cnum,$url,$method,$params,$perlvar{'lonVersion'});
Line 11891 sub domainlti_itemid {	Line 12310 sub domainlti_itemid {
$primary_id = &domain($cdom,'primary');	$primary_id = &domain($cdom,'primary');
return if ($primary_id eq '');	return if ($primary_id eq '');
if (ref($params) eq 'HASH') {	if (ref($params) eq 'HASH') {
my $items = &freeze_escape($params);
my $rep;	my $rep;
if (grep { $_ eq $primary_id } current_machine_ids()) {	if (grep { $_ eq $primary_id } current_machine_ids()) {
$rep = LONCAPA::Lond::domlti_itemid($cdom,$context,$url,$method,$params,$perlvar{'lonVersion'});	$rep = LONCAPA::Lond::domlti_itemid($cdom,$context,$url,$method,$params,$perlvar{'lonVersion'});
Line 11910 sub domainlti_itemid {	Line 12328 sub domainlti_itemid {
return $itemid;	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 {	sub count_supptools {
my ($cnum,$cdom,$ignorecache,$reload)=@_;	my ($cnum,$cdom,$ignorecache,$reload)=@_;
my $hashid=$cnum.':'.$cdom;	my $hashid=$cnum.':'.$cdom;
Line 12238 sub EXT {	Line 12723 sub EXT {
}	}
# ------------------------------------------ fourth, look in resource metadata	# ------------------------------------------ fourth, look in resource metadata

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

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

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

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

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

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

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

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

sub whichuser {	sub whichuser {
my ($passedsymb)=@_;	my ($passedsymb,$ignorecachednull)=@_;
my ($symb,$courseid,$domain,$name,$publicuser);	my ($symb,$courseid,$domain,$name,$publicuser);
if (defined($env{'form.grade_symb'})) {	if (defined($env{'form.grade_symb'})) {
my ($tmp_courseid)=&get_env_multiple('form.grade_courseid');	my ($tmp_courseid)=&get_env_multiple('form.grade_courseid');
Line 13772 sub whichuser {	Line 14321 sub whichuser {
}	}
}	}
if (!$passedsymb) {	if (!$passedsymb) {
$symb=&symbread();	$symb=&symbread('','',$ignorecachednull);
} else {	} else {
$symb=$passedsymb;	$symb=$passedsymb;
}	}
Line 15935 condval($condidx) : value of condition i	Line 16484 condval($condidx) : value of condition i

=item *	=item *

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

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

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

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

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