loncom/interface/loncommon.pm - diff

Return to loncommon.pm CVS log

Up to [LON-CAPA] / loncom / interface

Diff for /loncom/interface/loncommon.pm between versions 1.1309 and 1.1346

version 1.1309, 2018/01/12 13:33:38	version 1.1346, 2020/09/22 12:19:15
Line 72 use Apache::lonuserstate();	Line 72 use Apache::lonuserstate();
use Apache::courseclassifier();	use Apache::courseclassifier();
use LONCAPA qw(:DEFAULT :match);	use LONCAPA qw(:DEFAULT :match);
use LONCAPA::LWPReq;	use LONCAPA::LWPReq;
	use HTTP::Request;
use DateTime::TimeZone;	use DateTime::TimeZone;
use DateTime::Locale;	use DateTime::Locale;
use Encode();	use Encode();
Line 79 use Text::Aspell;	Line 80 use Text::Aspell;
use Authen::Captcha;	use Authen::Captcha;
use Captcha::reCAPTCHA;	use Captcha::reCAPTCHA;
use JSON::DWIW;	use JSON::DWIW;
use LWP::UserAgent;
use Crypt::DES;	use Crypt::DES;
use DynaLoader; # for Crypt::DES version	use DynaLoader; # for Crypt::DES version
use MIME::Lite;	use MIME::Lite;
Line 203 BEGIN {	Line 203 BEGIN {
{	{
my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.	my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.
'/language.tab';	'/language.tab';
if ( open(my $fh,"<$langtabfile") ) {	if ( open(my $fh,'<',$langtabfile) ) {
while (my $line = <$fh>) {	while (my $line = <$fh>) {
next if ($line=~/^\#/);	next if ($line=~/^\#/);
chomp($line);	chomp($line);
Line 225 BEGIN {	Line 225 BEGIN {
{	{
my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.	my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
'/copyright.tab';	'/copyright.tab';
if ( open (my $fh,"<$copyrightfile") ) {	if ( open (my $fh,'<',$copyrightfile) ) {
while (my $line = <$fh>) {	while (my $line = <$fh>) {
next if ($line=~/^\#/);	next if ($line=~/^\#/);
chomp($line);	chomp($line);
Line 239 BEGIN {	Line 239 BEGIN {
{	{
my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.	my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
'/source_copyright.tab';	'/source_copyright.tab';
if ( open (my $fh,"<$sourcecopyrightfile") ) {	if ( open (my $fh,'<',$sourcecopyrightfile) ) {
while (my $line = <$fh>) {	while (my $line = <$fh>) {
next if ($line =~ /^\#/);	next if ($line =~ /^\#/);
chomp($line);	chomp($line);
Line 253 BEGIN {	Line 253 BEGIN {
# -------------------------------------------------------------- default domain designs	# -------------------------------------------------------------- default domain designs
my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';	my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
my $designfile = $designdir.'/default.tab';	my $designfile = $designdir.'/default.tab';
if ( open (my $fh,"<$designfile") ) {	if ( open (my $fh,'<',$designfile) ) {
while (my $line = <$fh>) {	while (my $line = <$fh>) {
next if ($line =~ /^\#/);	next if ($line =~ /^\#/);
chomp($line);	chomp($line);
Line 267 BEGIN {	Line 267 BEGIN {
{	{
my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.	my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.
'/filecategories.tab';	'/filecategories.tab';
if ( open (my $fh,"<$categoryfile") ) {	if ( open (my $fh,'<',$categoryfile) ) {
while (my $line = <$fh>) {	while (my $line = <$fh>) {
next if ($line =~ /^\#/);	next if ($line =~ /^\#/);
chomp($line);	chomp($line);
Line 282 BEGIN {	Line 282 BEGIN {
{	{
my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.	my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.
'/filetypes.tab';	'/filetypes.tab';
if ( open (my $fh,"<$typesfile") ) {	if ( open (my $fh,'<',$typesfile) ) {
while (my $line = <$fh>) {	while (my $line = <$fh>) {
next if ($line =~ /^\#/);	next if ($line =~ /^\#/);
chomp($line);	chomp($line);
Line 435 sub studentbrowser_javascript {	Line 435 sub studentbrowser_javascript {
<script type="text/javascript" language="Javascript">	<script type="text/javascript" language="Javascript">
// <![CDATA[	// <![CDATA[
var stdeditbrowser;	var stdeditbrowser;
function openstdbrowser(formname,uname,udom,clicker,roleflag,ignorefilter,courseadvonly) {	function openstdbrowser(formname,uname,udom,clicker,roleflag,ignorefilter,courseadv) {
var url = '/adm/pickstudent?';	var url = '/adm/pickstudent?';
var filter;	var filter;
if (!ignorefilter) {	if (!ignorefilter) {
Line 450 sub studentbrowser_javascript {	Line 450 sub studentbrowser_javascript {
'&udomelement='+udom+	'&udomelement='+udom+
'&clicker='+clicker;	'&clicker='+clicker;
if (roleflag) { url+="&roles=1"; }	if (roleflag) { url+="&roles=1"; }
if (courseadvonly) { url+="&courseadvonly=1"; }	if (courseadv == 'condition') {
	if (document.getElementById('courseadv')) {
	courseadv = document.getElementById('courseadv').value;
	}
	}
	if ((courseadv == 'only') \|\| (courseadv == 'none')) { url+="&courseadv="+courseadv; }
var title = 'Student_Browser';	var title = 'Student_Browser';
var options = 'scrollbars=1,resizable=1,menubar=0';	var options = 'scrollbars=1,resizable=1,menubar=0';
options += ',width=700,height=600';	options += ',width=700,height=600';
Line 482 ENDRESBRW	Line 487 ENDRESBRW
}	}

sub selectstudent_link {	sub selectstudent_link {
my ($form,$unameele,$udomele,$courseadvonly,$clickerid)=@_;	my ($form,$unameele,$udomele,$courseadv,$clickerid)=@_;
my $callargs = "'".&Apache::lonhtmlcommon::entity_encode($form)."','".	my $callargs = "'".&Apache::lonhtmlcommon::entity_encode($form)."','".
&Apache::lonhtmlcommon::entity_encode($unameele)."','".	&Apache::lonhtmlcommon::entity_encode($unameele)."','".
&Apache::lonhtmlcommon::entity_encode($udomele)."'";	&Apache::lonhtmlcommon::entity_encode($udomele)."'";
Line 493 sub selectstudent_link {	Line 498 sub selectstudent_link {
return '';	return '';
}	}
$callargs.=",'".&Apache::lonhtmlcommon::entity_encode($clickerid)."'";	$callargs.=",'".&Apache::lonhtmlcommon::entity_encode($clickerid)."'";
if ($courseadvonly) {	if ($courseadv eq 'only') {
$callargs .= ",'',1,1";	$callargs .= ",'',1,'$courseadv'";
	} elsif ($courseadv eq 'none') {
	$callargs .= ",'','','$courseadv'";
	} elsif ($courseadv eq 'condition') {
	$callargs .= ",'','','$courseadv'";
}	}
return '<span class="LC_nobreak">'.	return '<span class="LC_nobreak">'.
'<a href="javascript:openstdbrowser('.$callargs.');">'.	'<a href="javascript:openstdbrowser('.$callargs.');">'.
Line 1297 sub help_open_topic {	Line 1306 sub help_open_topic {
}	}

# Add the text	# Add the text
	my $target = ' target="_top"';
	if (($env{'request.lti.login'}) && ($env{'request.lti.target'} eq 'iframe')) {
	$target = '';
	}
if ($text ne "") {	if ($text ne "") {
$template.='<span class="LC_help_open_topic">'	$template.='<span class="LC_help_open_topic">'
.'<a target="_top" href="'.$link.'">'	.'<a'.$target.' href="'.$link.'">'
.$text.'</a>';	.$text.'</a>';
}	}

Line 1309 sub help_open_topic {	Line 1322 sub help_open_topic {
if ($imgid ne '') {	if ($imgid ne '') {
$imgid = ' id="'.$imgid.'"';	$imgid = ' id="'.$imgid.'"';
}	}
$template.=' <a target="_top" href="'.$link.'" title="'.$title.'">'	$template.=' <a'.$target.' href="'.$link.'" title="'.$title.'">'
.'<img src="'.$helpicon.'" border="0"'	.'<img src="'.$helpicon.'" border="0"'
.' alt="'.&mt('Help: [_1]',$topic).'"'	.' alt="'.&mt('Help: [_1]',$topic).'"'
.' title="'.$title.'" style="vertical-align:middle;"'.$imgid	.' title="'.$title.'" style="vertical-align:middle;"'.$imgid
Line 1502 sub help_open_bug {	Line 1515 sub help_open_bug {
{	{
$link = $url;	$link = $url;
}	}

	my $target = ' target="_top"';
	if (($env{'request.lti.login'}) && ($env{'request.lti.target'} eq 'iframe')) {
	$target = '';
	}
# Add the text	# Add the text
if ($text ne "")	if ($text ne "")
{	{
$template .=	$template .=
"<table bgcolor='#AA3333' cellspacing='1' cellpadding='1' border='0'><tr>".	"<table bgcolor='#AA3333' cellspacing='1' cellpadding='1' border='0'><tr>".
"<td bgcolor='#FF5555'><a target=\"_top\" href=\"$link\"><span style=\"color:#FFFFFF;font-size:10pt;\">$text</span></a>";	"<td bgcolor='#FF5555'><a".$target." href=\"$link\"><span style=\"color:#FFFFFF;font-size:10pt;\">$text</span></a>";
}	}

# Add the graphic	# Add the graphic
my $title = &mt('Report a Bug');	my $title = &mt('Report a Bug');
my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif");	my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif");
$template .= <<"ENDTEMPLATE";	$template .= <<"ENDTEMPLATE";
<a target="_top" href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a>	<a$target href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a>
ENDTEMPLATE	ENDTEMPLATE
if ($text ne '') { $template.='</td></tr></table>' };	if ($text ne '') { $template.='</td></tr></table>' };
return $template;	return $template;
Line 2225 sub import_crsauthor_form {	Line 2243 sub import_crsauthor_form {
}	}
my @ordered = ();	my @ordered = ();
foreach my $file (sort { lc($a) cmp lc($b) } (keys(%{$files{$key}}))) {	foreach my $file (sort { lc($a) cmp lc($b) } (keys(%{$files{$key}}))) {
	next if ($file =~ /\.rights$/);
if ($only) {	if ($only) {
my ($ext) = ($file =~ /\.([^.]+)$/);	my ($ext) = ($file =~ /\.([^.]+)$/);
unless ($possexts{lc($ext)}) {	unless ($possexts{lc($ext)}) {
Line 2268 sub import_crsauthor_form {	Line 2287 sub import_crsauthor_form {
unless ($possexts{lc($ext)}) {	unless ($possexts{lc($ext)}) {
next;	next;
}	}
	} else {
	next if ($file =~ /\.rights$/);
}	}
push(@singledirfiles,$file);	push(@singledirfiles,$file);
}	}
if (@singledirfiles) {	if (@singledirfiles) {
$possdirs == 1;	$possdirs = 1;
}	}
}	}
if (($possdirs == 1) && (@singledirfiles)) {	if (($possdirs == 1) && (@singledirfiles)) {
Line 3027 This is not an optimal method, but it wo	Line 3048 This is not an optimal method, but it wo

=item * authform_filesystem	=item * authform_filesystem

	=item * authform_lti

=back	=back

See loncreateuser.pm for invocation and use examples.	See loncreateuser.pm for invocation and use examples.
Line 3443 sub authform_filesystem {	Line 3466 sub authform_filesystem {
$fsyscheck.' onchange="'.$jscall.'" onclick="'.	$fsyscheck.' onchange="'.$jscall.'" onclick="'.
$jscall.'"'.$disabled.' />';	$jscall.'"'.$disabled.' />';
}	}
$autharg = '<input type="text" size="10" name="fsysarg" value=""'.	$autharg = '<input type="password" size="10" name="fsysarg" value=""'.
' onchange="'.$jscall.'"'.$disabled.' />';	' onchange="'.$jscall.'"'.$disabled.' />';
$result = &mt	$result = &mt
('[_1] Filesystem Authenticated (with initial password [_2])',	('[_1] Filesystem Authenticated (with initial password [_2])',
'<label><input type="radio" name="login" value="fsys" '.	'<label>'.$authtype,'</label>'.$autharg);
$fsyscheck.'onchange="'.$jscall.'" onclick="'.$jscall.'"'.$disabled.' />',	return $result;
'</label><input type="password" size="10" name="fsysarg" value="" '.	}
'onchange="'.$jscall.'"'.$disabled.' />');
	sub authform_lti {
	my %in = (
	formname => 'document.cu',
	kerb_def_dom => 'MSU.EDU',
	@_,
	);
	my ($lticheck,$result,$authtype,$autharg,$jscall,$disabled);
	my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
	if ($in{'readonly'}) {
	$disabled = ' disabled="disabled"';
	}
	if (defined($in{'curr_authtype'})) {
	if ($in{'curr_authtype'} eq 'lti') {
	if ($can_assign{'lti'}) {
	$lticheck = 'checked="checked" ';
	if (defined($in{'mode'})) {
	if ($in{'mode'} eq 'modifyuser') {
	$lticheck = '';
	}
	}
	} else {
	$result = &mt('Currently LTI Authenticated.');
	return $result;
	}
	}
	} else {
	if ($authnum == 1) {
	$authtype = '<input type="hidden" name="login" value="lti" />';
	}
	}
	if (!$can_assign{'lti'}) {
	return;
	} elsif ($authtype eq '') {
	if (defined($in{'mode'})) {
	if ($in{'mode'} eq 'modifycourse') {
	if ($authnum == 1) {
	$authtype = '<input type="radio" name="login" value="lti"'.$disabled.' />';
	}
	}
	}
	}
	$jscall = "javascript:changed_radio('lti',$in{'formname'});";
	if (($authtype eq '') && (($in{'mode'} eq 'modifycourse') \|\| ($in{'curr_authtype'} ne 'lti'))) {
	$authtype = '<input type="radio" name="login" value="lti" '.
	$lticheck.' onchange="'.$jscall.'" onclick="'.
	$jscall.'"'.$disabled.' />';
	}
	$autharg = '<input type="hidden" name="ltiarg" value="" />';
	if ($authtype) {
	$result = &mt('[_1] LTI Authenticated',
	'<label>'.$authtype.'</label>'.$autharg);
	} else {
	$result = '<b>'.&mt('LTI Authenticated').'</b>'.
	$autharg;
	}
return $result;	return $result;
}	}

Line 3464 sub get_assignable_auth {	Line 3542 sub get_assignable_auth {
krb5 => 1,	krb5 => 1,
int => 1,	int => 1,
loc => 1,	loc => 1,
	lti => 1,
);	);
my %domconfig = &Apache::lonnet::get_dom('configuration',['usercreation'],$dom);	my %domconfig = &Apache::lonnet::get_dom('configuration',['usercreation'],$dom);
if (ref($domconfig{'usercreation'}) eq 'HASH') {	if (ref($domconfig{'usercreation'}) eq 'HASH') {
Line 3496 sub get_assignable_auth {	Line 3575 sub get_assignable_auth {
return ($authnum,%can_assign);	return ($authnum,%can_assign);
}	}

	sub check_passwd_rules {
	my ($domain,$plainpass) = @_;
	my %passwdconf = &Apache::lonnet::get_passwdconf($domain);
	my ($min,$max,@chars,@brokerule,$warning);
	$min = $Apache::lonnet::passwdmin;
	if (ref($passwdconf{'chars'}) eq 'ARRAY') {
	if ($passwdconf{'min'} =~ /^\d+$/) {
	if ($passwdconf{'min'} > $min) {
	$min = $passwdconf{'min'};
	}
	}
	if ($passwdconf{'max'} =~ /^\d+$/) {
	$max = $passwdconf{'max'};
	}
	@chars = @{$passwdconf{'chars'}};
	}
	if (($min) && (length($plainpass) < $min)) {
	push(@brokerule,'min');
	}
	if (($max) && (length($plainpass) > $max)) {
	push(@brokerule,'max');
	}
	if (@chars) {
	my %rules;
	map { $rules{$_} = 1; } @chars;
	if ($rules{'uc'}) {
	unless ($plainpass =~ /[A-Z]/) {
	push(@brokerule,'uc');
	}
	}
	if ($rules{'lc'}) {
	unless ($plainpass =~ /[a-z]/) {
	push(@brokerule,'lc');
	}
	}
	if ($rules{'num'}) {
	unless ($plainpass =~ /\d/) {
	push(@brokerule,'num');
	}
	}
	if ($rules{'spec'}) {
	unless ($plainpass =~ /[!"#$%&'()*+,\-.\/:;<=>?@[\\\]^_`{\|}~]/) {
	push(@brokerule,'spec');
	}
	}
	}
	if (@brokerule) {
	my %rulenames = &Apache::lonlocal::texthash(
	uc => 'At least one upper case letter',
	lc => 'At least one lower case letter',
	num => 'At least one number',
	spec => 'At least one non-alphanumeric',
	);
	$rulenames{'uc'} .= ': ABCDEFGHIJKLMNOPQRSTUVWXYZ';
	$rulenames{'lc'} .= ': abcdefghijklmnopqrstuvwxyz';
	$rulenames{'num'} .= ': 0123456789';
	$rulenames{'spec'} .= ': !"\#$%&\'()*+,-./:;<=>?@[\]^_\`{\|}~';
	$rulenames{'min'} = &mt('Minimum password length: [_1]',$min);
	$rulenames{'max'} = &mt('Maximum password length: [_1]',$max);
	$warning = &mt('Password did not satisfy the following:').'<ul>';
	foreach my $rule ('min','max','uc','lc','num','spec') {
	if (grep(/^$rule$/,@brokerule)) {
	$warning .= '<li>'.$rulenames{$rule}.'</li>';
	}
	}
	$warning .= '</ul>';
	}
	if (wantarray) {
	return @brokerule;
	}
	return $warning;
	}

###############################################################	###############################################################
## Get Kerberos Defaults for Domain ##	## Get Kerberos Defaults for Domain ##
###############################################################	###############################################################
Line 5020 sub blockcheck {	Line 5172 sub blockcheck {

if (($activity eq 'boards' \|\| $activity eq 'chat' \|\|	if (($activity eq 'boards' \|\| $activity eq 'chat' \|\|
$activity eq 'groups' \|\| $activity eq 'printout' \|\|	$activity eq 'groups' \|\| $activity eq 'printout' \|\|
$activity eq 'reinit' \|\| $activity eq 'alert') &&	$activity eq 'search' \|\| $activity eq 'reinit' \|\|
	$activity eq 'alert') &&
($env{'request.course.id'})) {	($env{'request.course.id'})) {
foreach my $key (keys(%live_courses)) {	foreach my $key (keys(%live_courses)) {
if ($key ne $env{'request.course.id'}) {	if ($key ne $env{'request.course.id'}) {
Line 5337 END_MYBLOCK	Line 5490 END_MYBLOCK
$text = &mt('Printing Blocked');	$text = &mt('Printing Blocked');
} elsif ($activity eq 'passwd') {	} elsif ($activity eq 'passwd') {
$text = &mt('Password Changing Blocked');	$text = &mt('Password Changing Blocked');
	} elsif ($activity eq 'grades') {
	$text = &mt('Gradebook Blocked');
	} elsif ($activity eq 'search') {
	$text = &mt('Search Blocked');
} elsif ($activity eq 'alert') {	} elsif ($activity eq 'alert') {
$text = &mt('Checking Critical Messages Blocked');	$text = &mt('Checking Critical Messages Blocked');
} elsif ($activity eq 'reinit') {	} elsif ($activity eq 'reinit') {
Line 5364 sub check_ip_acc {	Line 5521 sub check_ip_acc {
if (!defined($acc) \|\| $acc =~ /^\s$/ \|\| $acc =~/^\sno\s*$/i) {	if (!defined($acc) \|\| $acc =~ /^\s$/ \|\| $acc =~/^\sno\s*$/i) {
return 1;	return 1;
}	}
my $allowed;	my ($ip,$allowed);
my $ip=$ENV{'REMOTE_ADDR'} \|\| $clientip \|\| $env{'request.host'};	if (($ENV{'REMOTE_ADDR'} eq '127.0.0.1') \|\|
	($ENV{'REMOTE_ADDR'} eq &Apache::lonnet::get_host_ip($Apache::lonnet::perlvar{'lonHostID'}))) {
	$ip = $env{'request.host'} \|\| $ENV{'REMOTE_ADDR'} \|\| $clientip;
	} else {
	$ip = $ENV{'REMOTE_ADDR'} \|\| $env{'request.host'} \|\| $clientip;
	}

my $name;	my $name;
my %access = (	my %access = (
Line 5580 sub get_legacy_domconf {	Line 5742 sub get_legacy_domconf {
my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';	my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
my $designfile = $designdir.'/'.$udom.'.tab';	my $designfile = $designdir.'/'.$udom.'.tab';
if (-e $designfile) {	if (-e $designfile) {
if ( open (my $fh,"<$designfile") ) {	if ( open (my $fh,'<',$designfile) ) {
while (my $line = <$fh>) {	while (my $line = <$fh>) {
next if ($line =~ /^\#/);	next if ($line =~ /^\#/);
chomp($line);	chomp($line);
Line 5779 sub CSTR_pageheader {	Line 5941 sub CSTR_pageheader {
$title = &mt('Authoring Space');	$title = &mt('Authoring Space');
}	}

	my ($target,$crumbtarget) = (' target="_top"','_top'); #FIXME lonpubdir: target="_parent"
	if (($env{'request.lti.login'}) && ($env{'request.lti.target'} eq 'iframe')) {
	$target = '';
	$crumbtarget = '';
	}

my $output =	my $output =
'<div>'	'<div>'
.&Apache::loncommon::help_open_menu('','',3,'Authoring') #FIXME: Broken? Where is it?	.&Apache::loncommon::help_open_menu('','',3,'Authoring') #FIXME: Broken? Where is it?
.'<b>'.$title.'</b> '	.'<b>'.$title.'</b> '
.'<form name="dirs" method="post" action="'.$formaction	.'<form name="dirs" method="post" action="'.$formaction.'"'.$target.'>'
.'" target="_top">' #FIXME lonpubdir: target="_parent"	.&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,$crumbtarget,'/priv/'.$udom,undef,undef);
.&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv/'.$udom,undef,undef);

if ($lastitem) {	if ($lastitem) {
$output .=	$output .=
Line 5799 sub CSTR_pageheader {	Line 5966 sub CSTR_pageheader {
} else {	} else {
$output .=	$output .=
'<br />'	'<br />'
#FIXME lonpubdir: &Apache::lonhtmlcommon::crumbs($uname.$thisdisfn.'/','_top','/priv','','+1',1)."</b></tt><br />"	#FIXME lonpubdir: &Apache::lonhtmlcommon::crumbs($uname.$thisdisfn.'/',$crumbtarget,'/priv','','+1',1)."</b></tt><br />"
.&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()')	.&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()')
.'</form>'	.'</form>'
.&Apache::lonmenu::constspaceform();	.&Apache::lonmenu::constspaceform();
Line 5857 Inputs:	Line 6024 Inputs:
inlineremote items to be added in "Functions" menu below	inlineremote items to be added in "Functions" menu below
breadcrumbs.	breadcrumbs.

	=item * $ltiscope, optional argument, will be one of: resource, map or
	course, if LON-CAPA is in LTI Provider context. Value is
	the scope of use, i.e., launch was for access to a single, a map
	or the entire course.

	=item * $ltiuri, optional argument, if LON-CAPA is in LTI Provider
	context, this will contain the URL for the landing item in
	the course, after launch from an LTI Consumer

	=item * $ltimenu, optional argument, if LON-CAPA is in LTI Provider
	context, this will contain a reference to hash of items
	to be included in the page header and/or inline menu.

=back	=back

Returns: A uniform header for LON-CAPA web pages.	Returns: A uniform header for LON-CAPA web pages.
Line 5868 other decorations will be returned.	Line 6048 other decorations will be returned.

sub bodytag {	sub bodytag {
my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,	my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,
$no_nav_bar,$bgcolor,$args,$advtoolsref)=@_;	$no_nav_bar,$bgcolor,$args,$advtoolsref,$ltiscope,$ltiuri,$ltimenu)=@_;

my $public;	my $public;
if ((($env{'user.name'} eq 'public') && ($env{'user.domain'} eq 'public'))	if ((($env{'user.name'} eq 'public') && ($env{'user.domain'} eq 'public'))
Line 5939 sub bodytag {	Line 6119 sub bodytag {
if ($public) {	if ($public) {
undef($role);	undef($role);
}	}

	if (($env{'request.course.id'}) && ($env{'request.lti.login'})) {
	if (ref($ltimenu) eq 'HASH') {
	unless ($ltimenu->{'role'}) {
	undef($role);
	}
	unless ($ltimenu->{'coursetitle'}) {
	$realm=' ';
	}
	}
	}

my $titleinfo = '<h1>'.$title.'</h1>';	my $titleinfo = '<h1>'.$title.'</h1>';
#	#
# Extra info if you are the DC	# Extra info if you are the DC
Line 5973 sub bodytag {	Line 6164 sub bodytag {
$bodytag .= Apache::lonhtmlcommon::scripttag(	$bodytag .= Apache::lonhtmlcommon::scripttag(
Apache::lonmenu::utilityfunctions($httphost), 'start');	Apache::lonmenu::utilityfunctions($httphost), 'start');

my ($left,$right) = Apache::lonmenu::primary_menu($crstype);	unless ($args->{'no_primary_menu'}) {
	my ($left,$right) = Apache::lonmenu::primary_menu($crstype,$ltimenu);

if ($env{'request.noversionuri'} =~ m{^/res/adm/pages/}) {	if ($env{'request.noversionuri'} =~ m{^/res/adm/pages/}) {
if ($dc_info) {	if ($dc_info) {
$dc_info = qq\|<span class="LC_cusr_subheading">$dc_info</span>\|;	$dc_info = qq\|<span class="LC_cusr_subheading">$dc_info</span>\|;
}	}
$bodytag .= qq\|<div id="LC_nav_bar">$left $role<br />	$bodytag .= qq\|<div id="LC_nav_bar">$left $role<br />
<em>$realm</em> $dc_info</div>\|;	<em>$realm</em> $dc_info</div>\|;
return $bodytag;	return $bodytag;
}	}

unless ($env{'request.symb'} =~ m/\.page___\d+___/) {	unless ($env{'request.symb'} =~ m/\.page___\d+___/) {
$bodytag .= qq\|<div id="LC_nav_bar">$left $role</div>\|;	$bodytag .= qq\|<div id="LC_nav_bar">$left $role</div>\|;
}	}

$bodytag .= $right;	$bodytag .= $right;

if ($dc_info) {	if ($dc_info) {
$dc_info = &dc_courseid_toggle($dc_info);	$dc_info = &dc_courseid_toggle($dc_info);
	}
	$bodytag .= qq\|<div id="LC_realm">$realm $dc_info</div>\|;
}	}
$bodytag .= qq\|<div id="LC_realm">$realm $dc_info</div>\|;

#if directed to not display the secondary menu, don't.	#if directed to not display the secondary menu, don't.
if ($args->{'no_secondary_menu'}) {	if ($args->{'no_secondary_menu'}) {
Line 6001 sub bodytag {	Line 6194 sub bodytag {
}	}
#don't show menus for public users	#don't show menus for public users
if (!$public){	if (!$public){
$bodytag .= Apache::lonmenu::secondary_menu($httphost);	unless ($args->{'no_inline_menu'}) {
	$bodytag .= Apache::lonmenu::secondary_menu($httphost,$ltiscope,$ltimenu,
	$args->{'no_primary_menu'});
	}
$bodytag .= Apache::lonmenu::serverform();	$bodytag .= Apache::lonmenu::serverform();
$bodytag .= Apache::lonhtmlcommon::scripttag('', 'end');	$bodytag .= Apache::lonhtmlcommon::scripttag('', 'end');
if ($env{'request.state'} eq 'construct') {	if ($env{'request.state'} eq 'construct') {
$bodytag .= &Apache::lonmenu::innerregister($forcereg,	$bodytag .= &Apache::lonmenu::innerregister($forcereg,
$args->{'bread_crumbs'},'','',$hostname);	$args->{'bread_crumbs'},'','',$hostname,$ltiscope,$ltiuri);
} elsif ($forcereg) {	} elsif ($forcereg) {
$bodytag .= &Apache::lonmenu::innerregister($forcereg,undef,	$bodytag .= &Apache::lonmenu::innerregister($forcereg,undef,
$args->{'group'},	$args->{'group'},
$args->{'hide_buttons'},	$args->{'hide_buttons'},
$hostname);	$hostname,$ltiscope,$ltiuri);
} else {	} else {
$bodytag .=	$bodytag .=
&Apache::lonmenu::prepare_functions($env{'request.noversionuri'},	&Apache::lonmenu::prepare_functions($env{'request.noversionuri'},
Line 7080 table.LC_prior_tries td {	Line 7276 table.LC_prior_tries td {
padding: 6px;	padding: 6px;
}	}

.LC_answer_unknown {	.LC_answer_unknown,
	.LC_answer_warning {
background: orange;	background: orange;
color: black;	color: black;
padding: 6px;	padding: 6px;
Line 8076 ul.LC_funclist li {	Line 8273 ul.LC_funclist li {
cursor:pointer;	cursor:pointer;
}	}

	pre.LC_wordwrap {
	white-space: pre-wrap;
	white-space: -moz-pre-wrap;
	white-space: -pre-wrap;
	white-space: -o-pre-wrap;
	word-wrap: break-word;
	}

/*	/*
styles used for response display	styles used for response display
*/	*/
Line 8326 ADDMETA	Line 8531 ADDMETA
my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'};	my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'};
unless (&Apache::lonnet::allowed('mau',$dom_in_use)) {	unless (&Apache::lonnet::allowed('mau',$dom_in_use)) {
my %domdefs = &Apache::lonnet::get_domain_defaults($dom_in_use);	my %domdefs = &Apache::lonnet::get_domain_defaults($dom_in_use);
	my $lonhost = $Apache::lonnet::perlvar{'lonHostID'};
	my $offload;
if (ref($domdefs{'offloadnow'}) eq 'HASH') {	if (ref($domdefs{'offloadnow'}) eq 'HASH') {
my $lonhost = $Apache::lonnet::perlvar{'lonHostID'};
if ($domdefs{'offloadnow'}{$lonhost}) {	if ($domdefs{'offloadnow'}{$lonhost}) {
my $newserver = &Apache::lonnet::spareserver(30000,undef,1,$dom_in_use);	$offload = 1;
if (($newserver) && ($newserver ne $lonhost)) {	}
my $numsec = 5;	}
my $timeout = $numsec * 1000;	unless ($offload) {
my ($newurl,$locknum,%locks,$msg);	if (ref($domdefs{'offloadoth'}) eq 'HASH') {
if ($env{'request.role.adv'}) {	if ($domdefs{'offloadoth'}{$lonhost}) {
($locknum,%locks) = &Apache::lonnet::get_locks();	if (($env{'user.domain'} ne '') && ($env{'user.domain'} ne $dom_in_use) &&
}	(!(($env{'user.name'} eq 'public') && ($env{'user.domain'} eq 'public')))) {
my $disable_submit = 0;	unless (&Apache::lonnet::shared_institution($env{'user.domain'})) {
if ($requrl =~ /$LONCAPA::assess_re/) {	$offload = 1;
$disable_submit = 1;	$dom_in_use = $env{'user.domain'};
	}
}	}
if ($locknum) {	}
my @lockinfo = sort(values(%locks));	}
$msg = &mt('Once the following tasks are complete: ')."\\n".	}
join(", ",sort(values(%locks)))."\\n".	if ($offload) {
&mt('your session will be transferred to a different server, after you click "Roles".');	my $newserver = &Apache::lonnet::spareserver(30000,undef,1,$dom_in_use);
	if (($newserver) && ($newserver ne $lonhost)) {
	my $numsec = 5;
	my $timeout = $numsec * 1000;
	my ($newurl,$locknum,%locks,$msg);
	if ($env{'request.role.adv'}) {
	($locknum,%locks) = &Apache::lonnet::get_locks();
	}
	my $disable_submit = 0;
	if ($requrl =~ /$LONCAPA::assess_re/) {
	$disable_submit = 1;
	}
	if ($locknum) {
	my @lockinfo = sort(values(%locks));
	$msg = &mt('Once the following tasks are complete: ')."\n".
	join(", ",sort(values(%locks)))."\n";
	if (&show_course()) {
	$msg .= &mt('your session will be transferred to a different server, after you click "Courses".');
} else {	} else {
if (($requrl =~ m{^/res/}) && ($env{'form.submitted'} =~ /^part_/)) {	$msg .= &mt('your session will be transferred to a different server, after you click "Roles".');
$msg = &mt('Your LON-CAPA submission has been recorded')."\\n";	}
}	} else {
$msg .= &mt('Your current LON-CAPA session will be transferred to a different server in [quant,_1,second].',$numsec);	if (($requrl =~ m{^/res/}) && ($env{'form.submitted'} =~ /^part_/)) {
$newurl = '/adm/switchserver?otherserver='.$newserver;	$msg = &mt('Your LON-CAPA submission has been recorded')."\n";
if (($env{'request.role'}) && ($env{'request.role'} ne 'cm')) {	}
$newurl .= '&role='.$env{'request.role'};	$msg .= &mt('Your current LON-CAPA session will be transferred to a different server in [quant,_1,second].',$numsec);
	$newurl = '/adm/switchserver?otherserver='.$newserver;
	if (($env{'request.role'}) && ($env{'request.role'} ne 'cm')) {
	$newurl .= '&role='.$env{'request.role'};
	}
	if ($env{'request.symb'}) {
	my $shownsymb = &Apache::lonenc::check_encrypt($env{'request.symb'});
	if ($shownsymb =~ m{^/enc/}) {
	my $reqdmajor = 2;
	my $reqdminor = 11;
	my $reqdsubminor = 3;
	my $newserverrev = &Apache::lonnet::get_server_loncaparev('',$newserver);
	my $remoterev = &Apache::lonnet::get_server_loncaparev(undef,$newserver);
	my ($major,$minor,$subminor) = ($remoterev =~ /^\'?(\d+)\.(\d+)\.(\d+\|)[\w.\-]+\'?$/);
	if (($major eq '' && $minor eq '') \|\|
	(($reqdmajor > $major) \|\| (($reqdmajor == $major) && ($reqdminor > $minor)) \|\|
	(($reqdmajor == $major) && ($reqdminor == $minor) && (($subminor eq '') \|\|
	($reqdsubminor > $subminor))))) {
	undef($shownsymb);
	}
}	}
if ($env{'request.symb'}) {	if ($shownsymb) {
$newurl .= '&symb='.$env{'request.symb'};	&js_escape(\$shownsymb);
} else {	$newurl .= '&symb='.$shownsymb;
$newurl .= '&origurl='.$requrl;
}	}
	} else {
	my $shownurl = &Apache::lonenc::check_encrypt($requrl);
	&js_escape(\$shownurl);
	$newurl .= '&origurl='.$shownurl;
}	}
&js_escape(\$msg);	}
$result.=<<OFFLOAD	&js_escape(\$msg);
	$result.=<<OFFLOAD
<meta http-equiv="pragma" content="no-cache" />	<meta http-equiv="pragma" content="no-cache" />
<script type="text/javascript">	<script type="text/javascript">
// <![CDATA[	// <![CDATA[
Line 8383 function LC_Offload_Now() {	Line 8630 function LC_Offload_Now() {
// ]]>	// ]]>
</script>	</script>
OFFLOAD	OFFLOAD
}
}	}
}	}
}	}
Line 8613 sub start_page {	Line 8859 sub start_page {
#&Apache::lonnet::logthis("start_page ".join(':',caller(0)));	#&Apache::lonnet::logthis("start_page ".join(':',caller(0)));

$env{'internal.start_page'}++;	$env{'internal.start_page'}++;
my ($result,@advtools);	my ($result,@advtools,$ltiscope,$ltiuri,%ltimenu);

if (! exists($args->{'skip_phases'}{'head'}) ) {	if (! exists($args->{'skip_phases'}{'head'}) ) {
$result .= &xml_begin($args->{'frameset'}) . &headtag($title, $head_extra, $args);	$result .= &xml_begin($args->{'frameset'}) . &headtag($title, $head_extra, $args);
}	}

	if (($env{'request.course.id'}) && ($env{'request.lti.login'})) {
	if ($env{'course.'.$env{'request.course.id'}.'.lti.override'}) {
	unless ($env{'course.'.$env{'request.course.id'}.'.lti.topmenu'}) {
	$args->{'no_primary_menu'} = 1;
	}
	unless ($env{'course.'.$env{'request.course.id'}.'.lti.inlinemenu'}) {
	$args->{'no_inline_menu'} = 1;
	}
	if ($env{'course.'.$env{'request.course.id'}.'.lti.lcmenu'}) {
	map { $ltimenu{$_} = 1; } split(/,/,$env{'course.'.$env{'request.course.id'}.'.lti.lcmenu'});
	}
	} else {
	my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
	my %lti = &Apache::lonnet::get_domain_lti($cdom,'provider');
	if (ref($lti{$env{'request.lti.login'}}) eq 'HASH') {
	unless ($lti{$env{'request.lti.login'}}{'topmenu'}) {
	$args->{'no_primary_menu'} = 1;
	}
	unless ($lti{$env{'request.lti.login'}}{'inlinemenu'}) {
	$args->{'no_inline_menu'} = 1;
	}
	if (ref($lti{$env{'request.lti.login'}}{'lcmenu'}) eq 'ARRAY') {
	map { $ltimenu{$_} = 1; } @{$lti{$env{'request.lti.login'}}{'lcmenu'}};
	}
	}
	}
	($ltiscope,$ltiuri) = &LONCAPA::ltiutils::lti_provider_scope($env{'request.lti.uri'},
	$env{'course.'.$env{'request.course.id'}.'.domain'},
	$env{'course.'.$env{'request.course.id'}.'.num'});
	}

if (! exists($args->{'skip_phases'}{'body'}) ) {	if (! exists($args->{'skip_phases'}{'body'}) ) {
if ($args->{'frameset'}) {	if ($args->{'frameset'}) {
Line 8631 sub start_page {	Line 8908 sub start_page {
$args->{'only_body'}, $args->{'domain'},	$args->{'only_body'}, $args->{'domain'},
$args->{'force_register'}, $args->{'no_nav_bar'},	$args->{'force_register'}, $args->{'no_nav_bar'},
$args->{'bgcolor'}, $args,	$args->{'bgcolor'}, $args,
\@advtools);	\@advtools,$ltiscope,$ltiuri,\%ltimenu);
}	}
}	}

Line 8667 sub start_page {	Line 8944 sub start_page {
my $menulink;	my $menulink;
# if arg: bread_crumbs_nomenu is true pass 0 as $menulink item.	# if arg: bread_crumbs_nomenu is true pass 0 as $menulink item.
if ((exists($args->{'bread_crumbs_nomenu'})) \|\|	if ((exists($args->{'bread_crumbs_nomenu'})) \|\|
	($ltiscope eq 'map') \|\| ($ltiscope eq 'resource') \|\|
((($args->{'crstype'} eq 'Placement') \|\| (($env{'request.course.id'}) &&	((($args->{'crstype'} eq 'Placement') \|\| (($env{'request.course.id'}) &&
($env{'course.'.$env{'request.course.id'}.'.type'} eq 'Placement'))) &&	($env{'course.'.$env{'request.course.id'}.'.type'} eq 'Placement'))) &&
(!$env{'request.role.adv'}))) {	(!$env{'request.role.adv'}))) {
Line 8800 sub modal_link {	Line 9078 sub modal_link {
$target_attr = 'target="'.$target.'"';	$target_attr = 'target="'.$target.'"';
}	}
return <<"ENDLINK";	return <<"ENDLINK";
<a href="$link" $target_attr title="$title" onclick="javascript:openMyModal('$link',$width,$height,'$scrolling','$transparency','$style'); return false;">	<a href="$link" $target_attr title="$title" onclick="javascript:openMyModal('$link',$width,$height,'$scrolling','$transparency','$style'); return false;">$linktext</a>
$linktext</a>
ENDLINK	ENDLINK
}	}

Line 12072 sub modify_html_refs {	Line 12349 sub modify_html_refs {
return;	return;
}	}
}	}
if (open(my $fh,"<$container")) {	if (open(my $fh,'<',$container)) {
$content = join('', <$fh>);	$content = join('', <$fh>);
close($fh);	close($fh);
} else {	} else {
Line 12137 sub modify_html_refs {	Line 12414 sub modify_html_refs {
}	}
}	}
} else {	} else {
if (open(my $fh,">$container")) {	if (open(my $fh,'>',$container)) {
print $fh $content;	print $fh $content;
close($fh);	close($fh);
$output = '<p>'.&mt('Updated [quant,_1,reference] in [_2].',	$output = '<p>'.&mt('Updated [quant,_1,reference] in [_2].',
Line 13766 sub upfile_store {	Line 14043 sub upfile_store {
{	{
my $datafile = $r->dir_config('lonDaemons').	my $datafile = $r->dir_config('lonDaemons').
'/tmp/'.$datatoken.'.tmp';	'/tmp/'.$datatoken.'.tmp';
if ( open(my $fh,">$datafile") ) {	if ( open(my $fh,'>',$datafile) ) {
print $fh $env{'form.upfile'};	print $fh $env{'form.upfile'};
close($fh);	close($fh);
}	}
Line 13791 sub load_tmp_file {	Line 14068 sub load_tmp_file {
{	{
my $studentfile = $r->dir_config('lonDaemons').	my $studentfile = $r->dir_config('lonDaemons').
'/tmp/'.$datatoken.'.tmp';	'/tmp/'.$datatoken.'.tmp';
if ( open(my $fh,"<$studentfile") ) {	if ( open(my $fh,'<',$studentfile) ) {
@studentdata=<$fh>;	@studentdata=<$fh>;
close($fh);	close($fh);
}	}
Line 13801 sub load_tmp_file {	Line 14078 sub load_tmp_file {

sub valid_datatoken {	sub valid_datatoken {
my ($datatoken) = @_;	my ($datatoken) = @_;
if ($datatoken =~ /^$match_username\_$match_domain\_enroll_$match_domain\_$match_courseid\_\d+_\d+$/) {	if ($datatoken =~ /^$match_username\_$match_domain\_enroll_(\|$match_domain\_$match_courseid)\_\d+_\d+$/) {
return $datatoken;	return $datatoken;
}	}
return;	return;
Line 14957 Inputs:	Line 15234 Inputs:

from - Sender's email address	from - Sender's email address

	replyto - Reply-To email address

to - Email address of recipient	to - Email address of recipient

subject - Subject of email	subject - Subject of email
Line 14967 cc_string - Carbon copy email ad	Line 15246 cc_string - Carbon copy email ad

bcc - Blind carbon copy email address	bcc - Blind carbon copy email address

type - File type of attachment

attachment_path - Path of file to be attached	attachment_path - Path of file to be attached

file_name - Name of file to be attached	file_name - Name of file to be attached
Line 14985 attachment_text - The body of an attac	Line 15262 attachment_text - The body of an attac
############################################################	############################################################

sub mime_email {	sub mime_email {
my ($from, $to, $subject, $body, $cc_string, $bcc, $attachment_path,	my ($from,$replyto,$to,$subject,$body,$cc_string,$bcc,$attachment_path,
$file_name, $attachment_text) = @_;	$file_name,$attachment_text) = @_;

my $msg = MIME::Lite->new(	my $msg = MIME::Lite->new(
From => $from,	From => $from,
To => $to,	To => $to,
Line 14994 sub mime_email {	Line 15272 sub mime_email {
Type =>'TEXT',	Type =>'TEXT',
Data => $body,	Data => $body,
);	);
	if ($replyto ne '') {
	$msg->add("Reply-To" => $replyto);
	}
if ($cc_string ne '') {	if ($cc_string ne '') {
$msg->add("Cc" => $cc_string);	$msg->add("Cc" => $cc_string);
}	}
Line 15109 jsarray (reference to array of categorie	Line 15390 jsarray (reference to array of categorie
subcats (reference to hash of arrays containing all subcategories within each	subcats (reference to hash of arrays containing all subcategories within each
category, -recursive)	category, -recursive)

	maxd (reference to hash used to hold max depth for all top-level categories).

Returns: nothing	Returns: nothing

Side effects: populates trails and allitems hash references.	Side effects: populates trails and allitems hash references.
Line 15116 Side effects: populates trails and allit	Line 15399 Side effects: populates trails and allit
=cut	=cut

sub extract_categories {	sub extract_categories {
my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats) = @_;	my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats,$maxd) = @_;
if (ref($categories) eq 'HASH') {	if (ref($categories) eq 'HASH') {
&gather_categories($categories,$cats,$idx,$jsarray);	&gather_categories($categories,$cats,$idx,$jsarray);
if (ref($cats->[0]) eq 'ARRAY') {	if (ref($cats->[0]) eq 'ARRAY') {
Line 15144 sub extract_categories {	Line 15427 sub extract_categories {
if (ref($subcats) eq 'HASH') {	if (ref($subcats) eq 'HASH') {
push(@{$subcats->{$item}},&escape($category).':'.&escape($name).':1');	push(@{$subcats->{$item}},&escape($category).':'.&escape($name).':1');
}	}
&recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats);	&recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats,$maxd);
}	}
} else {	} else {
if (ref($subcats) eq 'HASH') {	if (ref($subcats) eq 'HASH') {
$subcats->{$item} = [];	$subcats->{$item} = [];
}	}
	if (ref($maxd) eq 'HASH') {
	$maxd->{$name} = 1;
	}
}	}
}	}
}	}
Line 15187 Side effects: populates trails and allit	Line 15473 Side effects: populates trails and allit
=cut	=cut

sub recurse_categories {	sub recurse_categories {
my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats) = @_;	my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats,$maxd) = @_;
my $shallower = $depth - 1;	my $shallower = $depth - 1;
if (ref($cats->[$depth]{$category}) eq 'ARRAY') {	if (ref($cats->[$depth]{$category}) eq 'ARRAY') {
for (my $k=0; $k<@{$cats->[$depth]{$category}}; $k++) {	for (my $k=0; $k<@{$cats->[$depth]{$category}}; $k++) {
my $name = $cats->[$depth]{$category}[$k];	my $name = $cats->[$depth]{$category}[$k];
my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;	my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
my $trailstr = join(' -> ',(@{$parents},$category));	my $trailstr = join(' » ',(@{$parents},$category));
if ($allitems->{$item} eq '') {	if ($allitems->{$item} eq '') {
push(@{$trails},$trailstr);	push(@{$trails},$trailstr);
$allitems->{$item} = scalar(@{$trails})-1;	$allitems->{$item} = scalar(@{$trails})-1;
Line 15214 sub recurse_categories {	Line 15500 sub recurse_categories {
}	}
}	}
&recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents,	&recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents,
$subcats);	$subcats,$maxd);
pop(@{$parents});	pop(@{$parents});
}	}
} else {	} else {
my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;	my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
my $trailstr = join(' -> ',(@{$parents},$category));	my $trailstr = join(' » ',(@{$parents},$category));
if ($allitems->{$item} eq '') {	if ($allitems->{$item} eq '') {
push(@{$trails},$trailstr);	push(@{$trails},$trailstr);
$allitems->{$item} = scalar(@{$trails})-1;	$allitems->{$item} = scalar(@{$trails})-1;
}	}
	if (ref($maxd) eq 'HASH') {
	if ($depth > $maxd->{$parents->[0]}) {
	$maxd->{$parents->[0]} = $depth;
	}
	}
}	}
return;	return;
}	}
Line 15255 sub assign_categories_table {	Line 15546 sub assign_categories_table {
my ($cathash,$currcat,$type,$disabled) = @_;	my ($cathash,$currcat,$type,$disabled) = @_;
my $output;	my $output;
if (ref($cathash) eq 'HASH') {	if (ref($cathash) eq 'HASH') {
my (@cats,@trails,%allitems,%idx,@jsarray,@path,$maxdepth);	my (@cats,@trails,%allitems,%idx,@jsarray,%maxd,@path,$maxdepth);
&extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray);	&extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray,\%maxd);
$maxdepth = scalar(@cats);	$maxdepth = scalar(@cats);
if (@cats > 0) {	if (@cats > 0) {
my $itemcount = 0;	my $itemcount = 0;
Line 15582 sub check_clone {	Line 15873 sub check_clone {
my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'};	my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'};
my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid);	my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid);
my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom);	my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom);
my $clonemsg;	my $clonetitle;
	my @clonemsg;
my $can_clone = 0;	my $can_clone = 0;
my $lctype = lc($args->{'crstype'});	my $lctype = lc($args->{'crstype'});
if ($lctype ne 'community') {	if ($lctype ne 'community') {
Line 15590 sub check_clone {	Line 15882 sub check_clone {
}	}
if ($clonehome eq 'no_host') {	if ($clonehome eq 'no_host') {
if ($args->{'crstype'} eq 'Community') {	if ($args->{'crstype'} eq 'Community') {
$clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a non-existent community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'});	push(@clonemsg,({
	mt => 'No new community created.',
	args => [],
	},
	{
	mt => 'A new community could not be cloned from the specified original - [_1] - because it is a non-existent community.',
	args => [$args->{'clonedomain'}.':'.$args->{'clonedomain'}],
	}));
} else {	} else {
$clonemsg = &mt('No new course created.').$linefeed.&mt('A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.',$args->{'clonecourse'}.':'.$args->{'clonedomain'});	push(@clonemsg,({
}	mt => 'No new course created.',
	args => [],
	},
	{
	mt => 'A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.',
	args => [$args->{'clonecourse'}.':'.$args->{'clonedomain'}],
	}));
	}
} else {	} else {
my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1});	my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1});
	$clonetitle = $clonedesc{'description'};
if ($args->{'crstype'} eq 'Community') {	if ($args->{'crstype'} eq 'Community') {
if ($clonedesc{'type'} ne 'Community') {	if ($clonedesc{'type'} ne 'Community') {
$clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a course not a community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'});	push(@clonemsg,({
return ($can_clone, $clonemsg, $cloneid, $clonehome);	mt => 'No new community created.',
	args => [],
	},
	{
	mt => 'A new community could not be cloned from the specified original - [_1] - because it is a course not a community.',
	args => [$args->{'clonecourse'}.':'.$args->{'clonedomain'}],
	}));
	return ($can_clone,\@clonemsg,$cloneid,$clonehome);
}	}
}	}
if (($env{'request.role.domain'} eq $args->{'clonedomain'}) &&	if (($env{'request.role.domain'} eq $args->{'clonedomain'}) &&
Line 15688 sub check_clone {	Line 16002 sub check_clone {
}	}
unless ($can_clone) {	unless ($can_clone) {
if ($args->{'crstype'} eq 'Community') {	if ($args->{'crstype'} eq 'Community') {
$clonemsg = &mt('No new community created.').$linefeed.&mt('The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'});	push(@clonemsg,({
	mt => 'No new community created.',
	args => [],
	},
	{
	mt => 'The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).',
	args => [$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}],
	}));
} else {	} else {
$clonemsg = &mt('No new course created.').$linefeed.&mt('The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'});	push(@clonemsg,({
	mt => 'No new course created.',
	args => [],
	},
	{
	mt => 'The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',
	args => [$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}],
	}));
}	}
}	}
}	}
}	}
return ($can_clone, $clonemsg, $cloneid, $clonehome);	return ($can_clone,\@clonemsg,$cloneid,$clonehome,$clonetitle);
}	}

sub construct_course {	sub construct_course {
my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,	my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,
$cnum,$category,$coderef) = @_;	$cnum,$category,$coderef,$callercontext,$user_lh) = @_;
my $outcome;	my ($outcome,$msgref,$clonemsgref);
my $linefeed = '<br />'."\n";	my $linefeed = '<br />'."\n";
if ($context eq 'auto') {	if ($context eq 'auto') {
$linefeed = "\n";	$linefeed = "\n";
Line 15710 sub construct_course {	Line 16038 sub construct_course {
#	#
# Are we cloning?	# Are we cloning?
#	#
my ($can_clone, $clonemsg, $cloneid, $clonehome);	my ($can_clone,$cloneid,$clonehome,$clonetitle);
if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {	if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {
($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed);	($can_clone,$clonemsgref,$cloneid,$clonehome,$clonetitle) = &check_clone($args,$linefeed);
if ($context ne 'auto') {
if ($clonemsg ne '') {
$clonemsg = '<span class="LC_error">'.$clonemsg.'</span>';
}
}
$outcome .= $clonemsg.$linefeed;

if (!$can_clone) {	if (!$can_clone) {
return (0,$outcome);	return (0,$outcome,$clonemsgref);
}	}
}	}

Line 15744 sub construct_course {	Line 16065 sub construct_course {
$args->{'ccuname'}.':'.	$args->{'ccuname'}.':'.
$args->{'ccdomain'},	$args->{'ccdomain'},
$args->{'crstype'},	$args->{'crstype'},
$cnum,$context,$category);	$cnum,$context,$category,
	$callercontext);

# Note: The testing routines depend on this being output; see	# Note: The testing routines depend on this being output; see
# Utils::Course. This needs to at least be output as a comment	# Utils::Course. This needs to at least be output as a comment
# if anyone ever decides to not show this, and Utils::Course::new	# if anyone ever decides to not show this, and Utils::Course::new
# will need to be suitably modified.	# will need to be suitably modified.
$outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$showncrstype,$$courseid).$linefeed;	if (($callercontext eq 'auto') && ($user_lh ne '')) {
	$outcome .= &mt_user($user_lh,'New LON-CAPA [_1] ID: [_2]',$showncrstype,$$courseid).$linefeed;
	} else {
	$outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$showncrstype,$$courseid).$linefeed;
	}
if ($$courseid =~ /^error:/) {	if ($$courseid =~ /^error:/) {
return (0,$outcome);	return (0,$outcome,$clonemsgref);
}	}

#	#
Line 15761 sub construct_course {	Line 16087 sub construct_course {
($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid);	($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid);
my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom);	my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom);
if ($crsuhome eq 'no_host') {	if ($crsuhome eq 'no_host') {
$outcome .= &mt('Course creation failed, unrecognized course home server.').$linefeed;	if (($callercontext eq 'auto') && ($user_lh ne '')) {
return (0,$outcome);	$outcome .= &mt_user($user_lh,
	'Course creation failed, unrecognized course home server.');
	} else {
	$outcome .= &mt('Course creation failed, unrecognized course home server.');
	}
	$outcome .= $linefeed;
	return (0,$outcome,$clonemsgref);
}	}
$outcome .= &mt('Created on').': '.$crsuhome.$linefeed;	$outcome .= &mt('Created on').': '.$crsuhome.$linefeed;

#	#
# Do the cloning	# Do the cloning
#	#
	my @clonemsg;
if ($can_clone && $cloneid) {	if ($can_clone && $cloneid) {
$clonemsg = &mt('Cloning [_1] from [_2]',$showncrstype,$clonehome);	push(@clonemsg,
if ($context ne 'auto') {	{
$clonemsg = '<span class="LC_success">'.$clonemsg.'</span>';	mt => 'Created [_1] by cloning from [_2]',
}	args => [$showncrstype,$clonetitle],
$outcome .= $clonemsg.$linefeed;	});
my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum);	my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum);
# Copy all files	# Copy all files
&Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'});	my @info =
	&Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},
	$args->{'dateshift'},$args->{'crscode'},
	$args->{'ccuname'}.':'.$args->{'ccdomain'},
	$args->{'tinyurls'});
	if (@info) {
	push(@clonemsg,@info);
	}
# Restore URL	# Restore URL
$cenv{'url'}=$oldcenv{'url'};	$cenv{'url'}=$oldcenv{'url'};
# Restore title	# Restore title
Line 16044 sub construct_course {	Line 16384 sub construct_course {
# Open all assignments	# Open all assignments
#	#
if ($args->{'openall'}) {	if ($args->{'openall'}) {
	my $opendate = time;
	if ($args->{'openallfrom'} =~ /^\d+$/) {
	$opendate = $args->{'openallfrom'};
	}
my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate';	my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate';
my %storecontent = ($storeunder => time,	my %storecontent = ($storeunder => $opendate,
$storeunder.'.type' => 'date_start');	$storeunder.'.type' => 'date_start');
	$outcome .= &mt('All assignments open starting [_1]',
$outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput	&Apache::lonlocal::locallocaltime($opendate)).': '.
('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;	&Apache::lonnet::cput
	('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
}	}
#	#
# Set first page	# Set first page
Line 16103 sub construct_course {	Line 16448 sub construct_course {
('resourcedata',\%storecontent,$$crsudom,$$crsunum);	('resourcedata',\%storecontent,$$crsudom,$$crsunum);
}	}

return (1,$outcome);	return (1,$outcome,\@clonemsg);
}	}

sub make_unique_code {	sub make_unique_code {
Line 16187 sub group_term {	Line 16532 sub group_term {
}	}

sub course_types {	sub course_types {
my @types = ('official','unofficial','community','textbook','placement');	my @types = ('official','unofficial','community','textbook','placement','lti');
my %typename = (	my %typename = (
official => 'Official course',	official => 'Official course',
unofficial => 'Unofficial course',	unofficial => 'Unofficial course',
community => 'Community',	community => 'Community',
textbook => 'Textbook course',	textbook => 'Textbook course',
placement => 'Placement test',	placement => 'Placement test',
	lti => 'LTI provider',
);	);
return (\@types,\%typename);	return (\@types,\%typename);
}	}
Line 16273 sub compare_arrays {	Line 16619 sub compare_arrays {
return @difference;	return @difference;
}	}

	sub lon_status_items {
	my %defaults = (
	E => 100,
	W => 4,
	N => 1,
	U => 5,
	threshold => 200,
	sysmail => 2500,
	);
	my %names = (
	E => 'Errors',
	W => 'Warnings',
	N => 'Notices',
	U => 'Unsent',
	);
	return (\%defaults,\%names);
	}

# -------------------------------------------------------- Initialize user login	# -------------------------------------------------------- Initialize user login
sub init_user_environment {	sub init_user_environment {
my ($r, $username, $domain, $authhost, $form, $args) = @_;	my ($r, $username, $domain, $authhost, $form, $args) = @_;
Line 16307 sub init_user_environment {	Line 16671 sub init_user_environment {
opendir(DIR,$lonids);	opendir(DIR,$lonids);
while ($filename=readdir(DIR)) {	while ($filename=readdir(DIR)) {
if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {	if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {
if ($ENV{'SERVER_PORT'} == 443) {	if (tie(my %oldenv,'GDBM_File',"$lonids/$filename",
	&GDBM_READER(),0640)) {
my $linkedfile;	my $linkedfile;
if (tie(my %oldenv,'GDBM_File',"$lonids/$cookie.id",	if (exists($oldenv{'user.linkedenv'})) {
&GDBM_READER(),0640)) {	$linkedfile = $oldenv{'user.linkedenv'};
if (exists($oldenv{'user.linkedenv'})) {
$linkedfile = $oldenv{'user.linkedenv'};
}
untie(%oldenv);
}	}
if (unlink($lonids.'/'.$filename)) {	untie(%oldenv);
if ($linkedfile =~ /^[a-f0-9]+_linked\.id$/) {	if (unlink("$lonids/$filename")) {
unlink($lonids.'/'.$linkedfile);	if ($linkedfile =~ /^[a-f0-9]+_linked$/) {
	if (-l "$lonids/$linkedfile.id") {
	unlink("$lonids/$linkedfile.id");
	}
}	}
}	}
} else {	} else {
Line 16429 sub init_user_environment {	Line 16793 sub init_user_environment {
undef,\%userenv,\%domdef,\%is_adv);	undef,\%userenv,\%domdef,\%is_adv);
}	}

foreach my $crstype ('official','unofficial','community','textbook','placement') {	foreach my $crstype ('official','unofficial','community','textbook','placement','lti') {
$userenv{'canrequest.'.$crstype} =	$userenv{'canrequest.'.$crstype} =
&Apache::lonnet::usertools_access($username,$domain,$crstype,	&Apache::lonnet::usertools_access($username,$domain,$crstype,
'reload','requestcourses',	'reload','requestcourses',
Line 17319 sub needs_coursereinit {	Line 17683 sub needs_coursereinit {
}	}

sub update_content_constraints {	sub update_content_constraints {
my ($cdom,$cnum,$chome,$cid) = @_;	my ($cdom,$cnum,$chome,$cid,$keeporder) = @_;
my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired');	my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired');
my ($reqdmajor,$reqdminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'});	my ($reqdmajor,$reqdminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'});
my (%checkresponsetypes,%checkcrsrestypes);	my (%checkresponsetypes,%checkcrsrestypes);
Line 17367 sub update_content_constraints {	Line 17731 sub update_content_constraints {
}	}
undef($navmap);	undef($navmap);
}	}
	my (@resources,@order,@resparms,@zombies);
	if ($keeporder) {
	use LONCAPA::map;
	@resources = @LONCAPA::map::resources;
	@order = @LONCAPA::map::order;
	@resparms = @LONCAPA::map::resparms;
	@zombies = @LONCAPA::map::zombies;
	}
my $suppmap = 'supplemental.sequence';	my $suppmap = 'supplemental.sequence';
my ($suppcount,$supptools,$errors) = (0,0,0);	my ($suppcount,$supptools,$errors) = (0,0,0);
($suppcount,$supptools,$errors) = &recurse_supplemental($cnum,$cdom,$suppmap,	($suppcount,$supptools,$errors) = &recurse_supplemental($cnum,$cdom,$suppmap,
$suppcount,$supptools,$errors);	$suppcount,$supptools,$errors);
	if ($keeporder) {
	@LONCAPA::map::resources = @resources;
	@LONCAPA::map::order = @order;
	@LONCAPA::map::resparms = @resparms;
	@LONCAPA::map::zombies = @zombies;
	}
if ($supptools) {	if ($supptools) {
my ($major,$minor) = split(/\./,$checkcrsrestypes{'exttool'});	my ($major,$minor) = split(/\./,$checkcrsrestypes{'exttool'});
if (($major > $reqdmajor) \|\| ($major == $reqdmajor && $minor > $reqdminor)) {	if (($major > $reqdmajor) \|\| ($major == $reqdmajor && $minor > $reqdminor)) {
Line 17397 sub allmaps_incourse {	Line 17775 sub allmaps_incourse {
if ($lastchange > $env{'request.course.tied'}) {	if ($lastchange > $env{'request.course.tied'}) {
my ($furl,$ferr) = &Apache::lonuserstate::readmap("$cdom/$cnum");	my ($furl,$ferr) = &Apache::lonuserstate::readmap("$cdom/$cnum");
unless ($ferr) {	unless ($ferr) {
&update_content_constraints($cdom,$cnum,$chome,$cid);	&update_content_constraints($cdom,$cnum,$chome,$cid,1);
}	}
}	}
my $navmap = Apache::lonnavmaps::navmap->new();	my $navmap = Apache::lonnavmaps::navmap->new();
Line 17531 sub symb_to_docspath {	Line 17909 sub symb_to_docspath {
}	}

sub captcha_display {	sub captcha_display {
my ($context,$lonhost) = @_;	my ($context,$lonhost,$defdom) = @_;
my ($output,$error);	my ($output,$error);
my ($captcha,$pubkey,$privkey,$version) =	my ($captcha,$pubkey,$privkey,$version) =
&get_captcha_config($context,$lonhost);	&get_captcha_config($context,$lonhost,$defdom);
if ($captcha eq 'original') {	if ($captcha eq 'original') {
$output = &create_captcha();	$output = &create_captcha();
unless ($output) {	unless ($output) {
Line 17550 sub captcha_display {	Line 17928 sub captcha_display {
}	}

sub captcha_response {	sub captcha_response {
my ($context,$lonhost) = @_;	my ($context,$lonhost,$defdom) = @_;
my ($captcha_chk,$captcha_error);	my ($captcha_chk,$captcha_error);
my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost);	my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost,$defdom);
if ($captcha eq 'original') {	if ($captcha eq 'original') {
($captcha_chk,$captcha_error) = &check_captcha();	($captcha_chk,$captcha_error) = &check_captcha();
} elsif ($captcha eq 'recaptcha') {	} elsif ($captcha eq 'recaptcha') {
Line 17564 sub captcha_response {	Line 17942 sub captcha_response {
}	}

sub get_captcha_config {	sub get_captcha_config {
my ($context,$lonhost) = @_;	my ($context,$lonhost,$dom_in_effect) = @_;
my ($captcha,$pubkey,$privkey,$version,$hashtocheck);	my ($captcha,$pubkey,$privkey,$version,$hashtocheck);
my $hostname = &Apache::lonnet::hostname($lonhost);	my $hostname = &Apache::lonnet::hostname($lonhost);
my $serverhomeID = &Apache::lonnet::get_server_homeID($hostname);	my $serverhomeID = &Apache::lonnet::get_server_homeID($hostname);
Line 17612 sub get_captcha_config {	Line 17990 sub get_captcha_config {
} elsif ($domconfhash{$serverhomedom.'.login.captcha'} eq 'original') {	} elsif ($domconfhash{$serverhomedom.'.login.captcha'} eq 'original') {
$captcha = 'original';	$captcha = 'original';
}	}
}	} elsif ($context eq 'passwords') {
	if ($dom_in_effect) {
	my %passwdconf = &Apache::lonnet::get_passwdconf($dom_in_effect);
	if ($passwdconf{'captcha'} eq 'recaptcha') {
	if (ref($passwdconf{'recaptchakeys'}) eq 'HASH') {
	$pubkey = $passwdconf{'recaptchakeys'}{'public'};
	$privkey = $passwdconf{'recaptchakeys'}{'private'};
	}
	if ($privkey && $pubkey) {
	$captcha = 'recaptcha';
	$version = $passwdconf{'recaptchaversion'};
	if ($version ne '2') {
	$version = 1;
	}
	} else {
	$captcha = 'original';
	}
	} elsif ($passwdconf{'captcha'} ne 'notused') {
	$captcha = 'original';
	}
	}
	}
return ($captcha,$pubkey,$privkey,$version);	return ($captcha,$pubkey,$privkey,$version);
}	}

Line 17636 sub create_captcha {	Line 18035 sub create_captcha {
last;	last;
}	}
}	}
	if ($output eq '') {
	&Apache::lonnet::logthis("Failed to create Captcha code after $tries attempts.");
	}
return $output;	return $output;
}	}

Line 17852 sub des_decrypt {	Line 18254 sub des_decrypt {
return $plaintext;	return $plaintext;
}	}

sub make_short_symbs {	sub get_requested_shorturls {
my ($cdom,$cnum,$navmap) = @_;	my ($cdom,$cnum,$navmap) = @_;
return unless (ref($navmap));	return unless (ref($navmap));
my ($numnew,@errors);	my ($numnew,$errors);
my @toshorten = &Apache::loncommon::get_env_multiple('form.addtiny');	my @toshorten = &Apache::loncommon::get_env_multiple('form.addtiny');
if (@toshorten) {	if (@toshorten) {
my (%maps,%resources,%titles);	my (%maps,%resources,%titles);
&Apache::loncourserespicker::enumerate_course_contents($navmap,\%maps,\%resources,\%titles,	&Apache::loncourserespicker::enumerate_course_contents($navmap,\%maps,\%resources,\%titles,
'shorturls',$cdom,$cnum);	'shorturls',$cdom,$cnum);
my %tocreate;
if (keys(%resources)) {	if (keys(%resources)) {
	my %tocreate;
foreach my $item (sort {$a <=> $b} (@toshorten)) {	foreach my $item (sort {$a <=> $b} (@toshorten)) {
my $symb = $resources{$item};	my $symb = $resources{$item};
if ($symb) {	if ($symb) {
$tocreate{$cnum.'&'.$symb} = 1;	$tocreate{$cnum.'&'.$symb} = 1;
}	}
}	}
	if (keys(%tocreate)) {
	($numnew,$errors) = &make_short_symbs($cdom,$cnum,
	\%tocreate);
	}
}	}
	}
	return ($numnew,$errors);
	}

	sub make_short_symbs {
	my ($cdom,$cnum,$tocreateref,$lockuser) = @_;
	my ($numnew,@errors);
	if (ref($tocreateref) eq 'HASH') {
	my %tocreate = %{$tocreateref};
if (keys(%tocreate)) {	if (keys(%tocreate)) {
my %coursetiny = &Apache::lonnet::dump('tiny',$cdom,$cnum);	my %coursetiny = &Apache::lonnet::dump('tiny',$cdom,$cnum);
my $su = Short::URL->new(no_vowels => 1);	my $su = Short::URL->new(no_vowels => 1);
Line 17877 sub make_short_symbs {	Line 18292 sub make_short_symbs {
my (%newunique,%addcourse,%courseonly,%failed);	my (%newunique,%addcourse,%courseonly,%failed);
# get lock on tiny db	# get lock on tiny db
my $now = time;	my $now = time;
	if ($lockuser eq '') {
	$lockuser = $env{'user.name'}.':'.$env{'user.domain'};
	}
my $lockhash = {	my $lockhash = {
"lock\0$now" => $env{'user.name'}.	"lock\0$now" => $lockuser,
':'.$env{'user.domain'},
};	};
my $tries = 0;	my $tries = 0;
my $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom);	my $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom);
Line 17887 sub make_short_symbs {	Line 18304 sub make_short_symbs {
while (($gotlock ne 'ok') && ($tries<3)) {	while (($gotlock ne 'ok') && ($tries<3)) {
$tries ++;	$tries ++;
sleep 1;	sleep 1;
$gotlock = &Apache::lonnet::newput_dom('uniquecodes',$lockhash,$cdom);	$gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom);
}	}
if ($gotlock eq 'ok') {	if ($gotlock eq 'ok') {
$init = &shorten_symbs($cdom,$init,$su,\%coursetiny,\%tocreate,\%newunique,	$init = &shorten_symbs($cdom,$init,$su,\%coursetiny,\%tocreate,\%newunique,
Line 17988 sub shorten_symbs {	Line 18405 sub shorten_symbs {
return $init;	return $init;
}	}

	sub is_nonframeable {
	my ($url,$absolute,$hostname,$ip,$nocache) = @_;
	my ($remprotocol,$remhost) = ($url =~ m{^(https?)\://(([a-z0-9]+(-[a-z0-9]+)*\.)+[a-z]{2,})}i);
	return if (($remprotocol eq '') \|\| ($remhost eq ''));

	$remprotocol = lc($remprotocol);
	$remhost = lc($remhost);
	my $remport = 80;
	if ($remprotocol eq 'https') {
	$remport = 443;
	}
	my ($result,$cached) = &Apache::lonnet::is_cached_new('noiframe',$remhost.':'.$remport);
	if ($cached) {
	unless ($nocache) {
	if ($result) {
	return 1;
	} else {
	return 0;
	}
	}
	}
	my $uselink;
	my $request = new HTTP::Request('HEAD',$url);
	my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',5);
	if ($response->is_success()) {
	my $secpolicy = lc($response->header('content-security-policy'));
	my $xframeop = lc($response->header('x-frame-options'));
	$secpolicy =~ s/^\s+\|\s+$//g;
	$xframeop =~ s/^\s+\|\s+$//g;
	if (($secpolicy ne '') \|\| ($xframeop ne '')) {
	my $remotehost = $remprotocol.'://'.$remhost;
	my ($origin,$protocol,$port);
	if ($ENV{'SERVER_PORT'} =~/^\d+$/) {
	$port = $ENV{'SERVER_PORT'};
	} else {
	$port = 80;
	}
	if ($absolute eq '') {
	$protocol = 'http:';
	if ($port == 443) {
	$protocol = 'https:';
	}
	$origin = $protocol.'//'.lc($hostname);
	} else {
	$origin = lc($absolute);
	($protocol,$hostname) = ($absolute =~ m{^(https?:)//([^/]+)$});
	}
	if (($secpolicy) && ($secpolicy =~ /\Qframe-ancestors\E([^;]*)(;\|$)/)) {
	my $framepolicy = $1;
	$framepolicy =~ s/^\s+\|\s+$//g;
	my @policies = split(/\s+/,$framepolicy);
	if (@policies) {
	if (grep(/^\Q'none'\E$/,@policies)) {
	$uselink = 1;
	} else {
	$uselink = 1;
	if ((grep(/^\Q*\E$/,@policies)) \|\| (grep(/^\Q$protocol\E$/,@policies)) \|\|
	(($origin ne '') && (grep(/^\Q$origin\E$/,@policies))) \|\|
	(($ip ne '') && (grep(/^\Q$ip\E$/,@policies)))) {
	undef($uselink);
	}
	if ($uselink) {
	if (grep(/^\Q'self'\E$/,@policies)) {
	if (($origin ne '') && ($remotehost eq $origin)) {
	undef($uselink);
	}
	}
	}
	if ($uselink) {
	my @possok;
	if ($ip ne '') {
	push(@possok,$ip);
	}
	my $hoststr = '';
	foreach my $part (reverse(split(/\./,$hostname))) {
	if ($hoststr eq '') {
	$hoststr = $part;
	} else {
	$hoststr = "$part.$hoststr";
	}
	if ($hoststr eq $hostname) {
	push(@possok,$hostname);
	} else {
	push(@possok,"*.$hoststr");
	}
	}
	if (@possok) {
	foreach my $poss (@possok) {
	last if (!$uselink);
	foreach my $policy (@policies) {
	if ($policy =~ m{^(\Q$protocol\E//\|)\Q$poss\E(\Q:$port\E\|)$}) {
	undef($uselink);
	last;
	}
	}
	}
	}
	}
	}
	}
	} elsif ($xframeop ne '') {
	$uselink = 1;
	my @policies = split(/\s,\s/,$xframeop);
	if (@policies) {
	unless (grep(/^deny$/,@policies)) {
	if ($origin ne '') {
	if (grep(/^sameorigin$/,@policies)) {
	if ($remotehost eq $origin) {
	undef($uselink);
	}
	}
	if ($uselink) {
	foreach my $policy (@policies) {
	if ($policy =~ /^allow-from\s*(.+)$/) {
	my $allowfrom = $1;
	if (($allowfrom ne '') && ($allowfrom eq $origin)) {
	undef($uselink);
	last;
	}
	}
	}
	}
	}
	}
	}
	}
	}
	}
	if ($nocache) {
	if ($cached) {
	my $devalidate;
	if ($uselink && !$result) {
	$devalidate = 1;
	} elsif (!$uselink && $result) {
	$devalidate = 1;
	}
	if ($devalidate) {
	&Apache::lonnet::devalidate_cache_new('noiframe',$remhost.':'.$remport);
	}
	}
	} else {
	if ($uselink) {
	$result = 1;
	} else {
	$result = 0;
	}
	&Apache::lonnet::do_cache_new('noiframe',$remhost.':'.$remport,$result,3600);
	}
	return $uselink;
	}

1;	1;
__END__;	__END__;

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

Removed from v.1.1309
changed lines
	Added in v.1.1346