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.1255 and 1.1348

version 1.1255, 2016/10/10 03:02:47	version 1.1348, 2020/10/01 10:16:33
Line 71 use Apache::lonuserutils();	Line 71 use Apache::lonuserutils();
use Apache::lonuserstate();	use Apache::lonuserstate();
use Apache::courseclassifier();	use Apache::courseclassifier();
use LONCAPA qw(:DEFAULT :match);	use LONCAPA qw(:DEFAULT :match);
	use LONCAPA::LWPReq;
	use HTTP::Request;
use DateTime::TimeZone;	use DateTime::TimeZone;
use DateTime::Locale;	use DateTime::Locale;
use Encode();	use Encode();
Line 78 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;
use MIME::Types;	use MIME::Types;
	use File::Copy();
	use File::Path();
	use String::CRC32();
	use Short::URL();

# ---------------------------------------------- Designs	# ---------------------------------------------- Designs
use vars qw(%defaultdesign);	use vars qw(%defaultdesign);
Line 198 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 220 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 234 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 248 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 262 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);
my ($extension,$category)=(split(/\s+/,$line,2));	my ($extension,$category)=(split(/\s+/,$line,2));
push @{$category_extensions{lc($category)}},$extension;	push(@{$category_extensions{lc($category)}},$extension);
}	}
close($fh);	close($fh);
}	}
Line 277 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 430 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 445 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 477 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 488 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 943 ENDSCRT	Line 957 ENDSCRT
}	}

sub select_timezone {	sub select_timezone {
my ($name,$selected,$onchange,$includeempty)=@_;	my ($name,$selected,$onchange,$includeempty,$disabled)=@_;
my $output='<select name="'.$name.'" '.$onchange.'>'."\n";	my $output='<select name="'.$name.'" '.$onchange.$disabled.'>'."\n";
if ($includeempty) {	if ($includeempty) {
$output .= '<option value=""';	$output .= '<option value=""';
if (($selected eq '') \|\| ($selected eq 'local')) {	if (($selected eq '') \|\| ($selected eq 'local')) {
Line 965 sub select_timezone {	Line 979 sub select_timezone {
}	}

sub select_datelocale {	sub select_datelocale {
my ($name,$selected,$onchange,$includeempty)=@_;	my ($name,$selected,$onchange,$includeempty,$disabled)=@_;
my $output='<select name="'.$name.'" '.$onchange.'>'."\n";	my $output='<select name="'.$name.'" '.$onchange.$disabled.'>'."\n";
if ($includeempty) {	if ($includeempty) {
$output .= '<option value=""';	$output .= '<option value=""';
if ($selected eq '') {	if ($selected eq '') {
Line 1018 sub select_datelocale {	Line 1032 sub select_datelocale {
}	}

sub select_language {	sub select_language {
my ($name,$selected,$includeempty) = @_;	my ($name,$selected,$includeempty,$noedit) = @_;
my %langchoices;	my %langchoices;
if ($includeempty) {	if ($includeempty) {
%langchoices = ('' => 'No language preference');	%langchoices = ('' => 'No language preference');
Line 1030 sub select_language {	Line 1044 sub select_language {
}	}
}	}
%langchoices = &Apache::lonlocal::texthash(%langchoices);	%langchoices = &Apache::lonlocal::texthash(%langchoices);
return &select_form($selected,$name,\%langchoices);	return &select_form($selected,$name,\%langchoices,undef,$noedit);
}	}

=pod	=pod
Line 1054 sub list_languages {	Line 1068 sub list_languages {
if ($code) {	if ($code) {
my $selector = $supported_codes{$id};	my $selector = $supported_codes{$id};
my $description = &plainlanguagedescription($id);	my $description = &plainlanguagedescription($id);
push (@lang_choices, [$selector, $description]);	push(@lang_choices, [$selector, $description]);
}	}
}	}
return \@lang_choices;	return \@lang_choices;
Line 1176 sub linked_select_forms {	Line 1190 sub linked_select_forms {
$result.="select2data${suffix}['d_$s1'].texts = new Array(";	$result.="select2data${suffix}['d_$s1'].texts = new Array(";
my @s2texts;	my @s2texts;
foreach my $value (@s2values) {	foreach my $value (@s2values) {
push @s2texts, $hashref->{$s1}->{'select2'}->{$value};	push(@s2texts, $hashref->{$s1}->{'select2'}->{$value});
}	}
$result.="\"@s2texts\");\n";	$result.="\"@s2texts\");\n";
}	}
Line 1292 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 1304 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 1497 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 2185 sub crsauthor_url {	Line 2208 sub crsauthor_url {
}	}

sub import_crsauthor_form {	sub import_crsauthor_form {
my ($form,$firstselectname,$secondselectname,$onchangefirst,$only,$suffix) = @_;	my ($form,$firstselectname,$secondselectname,$onchangefirst,$only,$suffix,$disabled) = @_;
return (0) unless ($env{'request.course.id'});	return (0) unless ($env{'request.course.id'});
my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};	my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};	my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
Line 2220 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 2263 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 2476 sub create_text_file {	Line 2502 sub create_text_file {
# ------------------------------------------	# ------------------------------------------

sub domain_select {	sub domain_select {
my ($name,$value,$multiple)=@_;	my ($name,$value,$multiple,$incdoms,$excdoms)=@_;
	my @possdoms;
	if (ref($incdoms) eq 'ARRAY') {
	@possdoms = @{$incdoms};
	} else {
	@possdoms = &Apache::lonnet::all_domains();
	}

my %domains=map {	my %domains=map {
$_ => $_.' '. &Apache::lonnet::domain($_,'description')	$_ => $_.' '. &Apache::lonnet::domain($_,'description')
} &Apache::lonnet::all_domains();	} @possdoms;

	if ((ref($excdoms) eq 'ARRAY') && (@{$excdoms} > 0)) {
	foreach my $dom (@{$excdoms}) {
	delete($domains{$dom});
	}
	}

if ($multiple) {	if ($multiple) {
$domains{''}=&mt('Any domain');	$domains{''}=&mt('Any domain');
$domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))];	$domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))];
Line 2742 sub select_level_form {	Line 2782 sub select_level_form {

=pod	=pod

=item * &select_dom_form($defdom,$name,$includeempty,$showdomdesc,$onchange,$incdoms,$excdoms)	=item * &select_dom_form($defdom,$name,$includeempty,$showdomdesc,$onchange,$incdoms,$excdoms,$disabled)

Returns a string containing a <select name='$name' size='1'> form to	Returns a string containing a <select name='$name' size='1'> form to
allow a user to select the domain to preform an operation in.	allow a user to select the domain to preform an operation in.
Line 2759 The optional $incdoms is a reference to	Line 2799 The optional $incdoms is a reference to

The optional $excdoms is a reference to an array of domains which will be excluded from the available options.	The optional $excdoms is a reference to an array of domains which will be excluded from the available options.

	The optional $disabled argument, if true, adds the disabled attribute to the select tag.

=cut	=cut

#-------------------------------------------	#-------------------------------------------
sub select_dom_form {	sub select_dom_form {
my ($defdom,$name,$includeempty,$showdomdesc,$onchange,$incdoms,$excdoms) = @_;	my ($defdom,$name,$includeempty,$showdomdesc,$onchange,$incdoms,$excdoms,$disabled) = @_;
if ($onchange) {	if ($onchange) {
$onchange = ' onchange="'.$onchange.'"';	$onchange = ' onchange="'.$onchange.'"';
}	}
	if ($disabled) {
	$disabled = ' disabled="disabled"';
	}
my (@domains,%exclude);	my (@domains,%exclude);
if (ref($incdoms) eq 'ARRAY') {	if (ref($incdoms) eq 'ARRAY') {
@domains = sort {lc($a) cmp lc($b)} (@{$incdoms});	@domains = sort {lc($a) cmp lc($b)} (@{$incdoms});
Line 2777 sub select_dom_form {	Line 2822 sub select_dom_form {
if (ref($excdoms) eq 'ARRAY') {	if (ref($excdoms) eq 'ARRAY') {
map { $exclude{$_} = 1; } @{$excdoms};	map { $exclude{$_} = 1; } @{$excdoms};
}	}
my $selectdomain = "<select name=\"$name\" size=\"1\"$onchange>\n";	my $selectdomain = "<select name=\"$name\" size=\"1\"$onchange$disabled>\n";
foreach my $dom (@domains) {	foreach my $dom (@domains) {
next if ($exclude{$dom});	next if ($exclude{$dom});
$selectdomain.="<option value=\"$dom\" ".	$selectdomain.="<option value=\"$dom\" ".
Line 3003 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 3153 sub authform_kerberos {	Line 3200 sub authform_kerberos {
@_,	@_,
);	);
my ($check4,$check5,$krbcheck,$krbarg,$krbver,$result,$authtype,	my ($check4,$check5,$krbcheck,$krbarg,$krbver,$result,$authtype,
$autharg,$jscall);	$autharg,$jscall,$disabled);
my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});	my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
if ($in{'kerb_def_auth'} eq 'krb5') {	if ($in{'kerb_def_auth'} eq 'krb5') {
$check5 = ' checked="checked"';	$check5 = ' checked="checked"';
} else {	} else {
$check4 = ' checked="checked"';	$check4 = ' checked="checked"';
}	}
	if ($in{'readonly'}) {
	$disabled = ' disabled="disabled"';
	}
$krbarg = $in{'kerb_def_dom'};	$krbarg = $in{'kerb_def_dom'};
if (defined($in{'curr_authtype'})) {	if (defined($in{'curr_authtype'})) {
if ($in{'curr_authtype'} eq 'krb') {	if ($in{'curr_authtype'} eq 'krb') {
Line 3204 sub authform_kerberos {	Line 3254 sub authform_kerberos {
if (defined($in{'mode'})) {	if (defined($in{'mode'})) {
if ($in{'mode'} eq 'modifycourse') {	if ($in{'mode'} eq 'modifycourse') {
if ($authnum == 1) {	if ($authnum == 1) {
$authtype = '<input type="radio" name="login" value="krb" />';	$authtype = '<input type="radio" name="login" value="krb"'.$disabled.' />';
}	}
}	}
}	}
Line 3213 sub authform_kerberos {	Line 3263 sub authform_kerberos {
if ($authtype eq '') {	if ($authtype eq '') {
$authtype = '<input type="radio" name="login" value="krb" '.	$authtype = '<input type="radio" name="login" value="krb" '.
'onclick="'.$jscall.'" onchange="'.$jscall.'"'.	'onclick="'.$jscall.'" onchange="'.$jscall.'"'.
$krbcheck.' />';	$krbcheck.$disabled.' />';
}	}
if (($can_assign{'krb4'} && $can_assign{'krb5'}) \|\|	if (($can_assign{'krb4'} && $can_assign{'krb5'}) \|\|
($can_assign{'krb4'} && !$can_assign{'krb5'} &&	($can_assign{'krb4'} && !$can_assign{'krb5'} &&
Line 3226 sub authform_kerberos {	Line 3276 sub authform_kerberos {
'<label>'.$authtype,	'<label>'.$authtype,
'</label><input type="text" size="10" name="krbarg" '.	'</label><input type="text" size="10" name="krbarg" '.
'value="'.$krbarg.'" '.	'value="'.$krbarg.'" '.
'onchange="'.$jscall.'" />',	'onchange="'.$jscall.'"'.$disabled.' />',
'<label><input type="radio" name="krbver" value="4" '.$check4.' />',	'<label><input type="radio" name="krbver" value="4" '.$check4.$disabled.' />',
'</label><label><input type="radio" name="krbver" value="5" '.$check5.' />',	'</label><label><input type="radio" name="krbver" value="5" '.$check5.$disabled.' />',
'</label>');	'</label>');
} elsif ($can_assign{'krb4'}) {	} elsif ($can_assign{'krb4'}) {
$result .= &mt	$result .= &mt
Line 3237 sub authform_kerberos {	Line 3287 sub authform_kerberos {
'<label>'.$authtype,	'<label>'.$authtype,
'</label><input type="text" size="10" name="krbarg" '.	'</label><input type="text" size="10" name="krbarg" '.
'value="'.$krbarg.'" '.	'value="'.$krbarg.'" '.
'onchange="'.$jscall.'" />',	'onchange="'.$jscall.'"'.$disabled.' />',
'<label><input type="hidden" name="krbver" value="4" />',	'<label><input type="hidden" name="krbver" value="4" />',
'</label>');	'</label>');
} elsif ($can_assign{'krb5'}) {	} elsif ($can_assign{'krb5'}) {
Line 3247 sub authform_kerberos {	Line 3297 sub authform_kerberos {
'<label>'.$authtype,	'<label>'.$authtype,
'</label><input type="text" size="10" name="krbarg" '.	'</label><input type="text" size="10" name="krbarg" '.
'value="'.$krbarg.'" '.	'value="'.$krbarg.'" '.
'onchange="'.$jscall.'" />',	'onchange="'.$jscall.'"'.$disabled.' />',
'<label><input type="hidden" name="krbver" value="5" />',	'<label><input type="hidden" name="krbver" value="5" />',
'</label>');	'</label>');
}	}
Line 3260 sub authform_internal {	Line 3310 sub authform_internal {
kerb_def_dom => 'MSU.EDU',	kerb_def_dom => 'MSU.EDU',
@_,	@_,
);	);
my ($intcheck,$intarg,$result,$authtype,$autharg,$jscall);	my ($intcheck,$intarg,$result,$authtype,$autharg,$jscall,$disabled);
my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});	my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
	if ($in{'readonly'}) {
	$disabled = ' disabled="disabled"';
	}
if (defined($in{'curr_authtype'})) {	if (defined($in{'curr_authtype'})) {
if ($in{'curr_authtype'} eq 'int') {	if ($in{'curr_authtype'} eq 'int') {
if ($can_assign{'int'}) {	if ($can_assign{'int'}) {
Line 3290 sub authform_internal {	Line 3343 sub authform_internal {
if (defined($in{'mode'})) {	if (defined($in{'mode'})) {
if ($in{'mode'} eq 'modifycourse') {	if ($in{'mode'} eq 'modifycourse') {
if ($authnum == 1) {	if ($authnum == 1) {
$authtype = '<input type="radio" name="login" value="int" />';	$authtype = '<input type="radio" name="login" value="int"'.$disabled.' />';
}	}
}	}
}	}
Line 3298 sub authform_internal {	Line 3351 sub authform_internal {
$jscall = "javascript:changed_radio('int',$in{'formname'});";	$jscall = "javascript:changed_radio('int',$in{'formname'});";
if ($authtype eq '') {	if ($authtype eq '') {
$authtype = '<input type="radio" name="login" value="int" '.$intcheck.	$authtype = '<input type="radio" name="login" value="int" '.$intcheck.
' onchange="'.$jscall.'" onclick="'.$jscall.'" />';	' onchange="'.$jscall.'" onclick="'.$jscall.'"'.$disabled.' />';
}	}
$autharg = '<input type="password" size="10" name="intarg" value="'.	$autharg = '<input type="password" size="10" name="intarg" value="'.
$intarg.'" onchange="'.$jscall.'" />';	$intarg.'" onchange="'.$jscall.'"'.$disabled.' />';
$result = &mt	$result = &mt
('[_1] Internally authenticated (with initial password [_2])',	('[_1] Internally authenticated (with initial password [_2])',
'<label>'.$authtype,'</label>'.$autharg);	'<label>'.$authtype,'</label>'.$autharg);
$result.="<label><input type=\"checkbox\" name=\"visible\" onclick='if (this.checked) { this.form.intarg.type=\"text\" } else { this.form.intarg.type=\"password\" }' />".&mt('Visible input').'</label>';	$result.='<label><input type="checkbox" name="visible" onclick="if (this.checked) { this.form.intarg.type='."'text'".' } else { this.form.intarg.type='."'password'".' }"'.$disabled.' />'.&mt('Visible input').'</label>';
return $result;	return $result;
}	}

Line 3315 sub authform_local {	Line 3368 sub authform_local {
kerb_def_dom => 'MSU.EDU',	kerb_def_dom => 'MSU.EDU',
@_,	@_,
);	);
my ($loccheck,$locarg,$result,$authtype,$autharg,$jscall);	my ($loccheck,$locarg,$result,$authtype,$autharg,$jscall,$disabled);
my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});	my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
	if ($in{'readonly'}) {
	$disabled = ' disabled="disabled"';
	}
if (defined($in{'curr_authtype'})) {	if (defined($in{'curr_authtype'})) {
if ($in{'curr_authtype'} eq 'loc') {	if ($in{'curr_authtype'} eq 'loc') {
if ($can_assign{'loc'}) {	if ($can_assign{'loc'}) {
Line 3345 sub authform_local {	Line 3401 sub authform_local {
if (defined($in{'mode'})) {	if (defined($in{'mode'})) {
if ($in{'mode'} eq 'modifycourse') {	if ($in{'mode'} eq 'modifycourse') {
if ($authnum == 1) {	if ($authnum == 1) {
$authtype = '<input type="radio" name="login" value="loc" />';	$authtype = '<input type="radio" name="login" value="loc"'.$disabled.' />';
}	}
}	}
}	}
Line 3354 sub authform_local {	Line 3410 sub authform_local {
if ($authtype eq '') {	if ($authtype eq '') {
$authtype = '<input type="radio" name="login" value="loc" '.	$authtype = '<input type="radio" name="login" value="loc" '.
$loccheck.' onchange="'.$jscall.'" onclick="'.	$loccheck.' onchange="'.$jscall.'" onclick="'.
$jscall.'" />';	$jscall.'"'.$disabled.' />';
}	}
$autharg = '<input type="text" size="10" name="locarg" value="'.	$autharg = '<input type="text" size="10" name="locarg" value="'.
$locarg.'" onchange="'.$jscall.'" />';	$locarg.'" onchange="'.$jscall.'"'.$disabled.' />';
$result = &mt('[_1] Local Authentication with argument [_2]',	$result = &mt('[_1] Local Authentication with argument [_2]',
'<label>'.$authtype,'</label>'.$autharg);	'<label>'.$authtype,'</label>'.$autharg);
return $result;	return $result;
Line 3369 sub authform_filesystem {	Line 3425 sub authform_filesystem {
kerb_def_dom => 'MSU.EDU',	kerb_def_dom => 'MSU.EDU',
@_,	@_,
);	);
my ($fsyscheck,$result,$authtype,$autharg,$jscall);	my ($fsyscheck,$result,$authtype,$autharg,$jscall,$disabled);
my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});	my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
	if ($in{'readonly'}) {
	$disabled = ' disabled="disabled"';
	}
if (defined($in{'curr_authtype'})) {	if (defined($in{'curr_authtype'})) {
if ($in{'curr_authtype'} eq 'fsys') {	if ($in{'curr_authtype'} eq 'fsys') {
if ($can_assign{'fsys'}) {	if ($can_assign{'fsys'}) {
Line 3383 sub authform_filesystem {	Line 3442 sub authform_filesystem {
} else {	} else {
$result = &mt('Currently Filesystem Authenticated.');	$result = &mt('Currently Filesystem Authenticated.');
return $result;	return $result;
}	}
}	}
} else {	} else {
if ($authnum == 1) {	if ($authnum == 1) {
Line 3396 sub authform_filesystem {	Line 3455 sub authform_filesystem {
if (defined($in{'mode'})) {	if (defined($in{'mode'})) {
if ($in{'mode'} eq 'modifycourse') {	if ($in{'mode'} eq 'modifycourse') {
if ($authnum == 1) {	if ($authnum == 1) {
$authtype = '<input type="radio" name="login" value="fsys" />';	$authtype = '<input type="radio" name="login" value="fsys"'.$disabled.' />';
}	}
}	}
}	}
Line 3405 sub authform_filesystem {	Line 3464 sub authform_filesystem {
if ($authtype eq '') {	if ($authtype eq '') {
$authtype = '<input type="radio" name="login" value="fsys" '.	$authtype = '<input type="radio" name="login" value="fsys" '.
$fsyscheck.' onchange="'.$jscall.'" onclick="'.	$fsyscheck.' onchange="'.$jscall.'" onclick="'.
$jscall.'" />';	$jscall.'"'.$disabled.' />';
}	}
$autharg = '<input type="text" size="10" name="fsysarg" value=""'.	$autharg = '<input type="password" size="10" name="fsysarg" value=""'.
' onchange="'.$jscall.'" />';	' 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.'" />',	return $result;
'</label><input type="password" size="10" name="fsysarg" value="" '.	}
'onchange="'.$jscall.'" />');
	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 3428 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 3436 sub get_assignable_auth {	Line 3551 sub get_assignable_auth {
my $context;	my $context;
if ($env{'request.role'} =~ /^au/) {	if ($env{'request.role'} =~ /^au/) {
$context = 'author';	$context = 'author';
} elsif ($env{'request.role'} =~ /^dc/) {	} elsif ($env{'request.role'} =~ /^(dc\|dh)/) {
$context = 'domain';	$context = 'domain';
} elsif ($env{'request.course.id'}) {	} elsif ($env{'request.course.id'}) {
$context = 'course';	$context = 'course';
Line 3460 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 4545 sub get_previous_attempt {	Line 4733 sub get_previous_attempt {
}	}
$prevattempts.= &end_data_table_row().&end_data_table();	$prevattempts.= &end_data_table_row().&end_data_table();
} else {	} else {
	my $msg;
	if ($symb =~ /ext\.tool$/) {
	$msg = &mt('No grade passed back.');
	} else {
	$msg = &mt('Nothing submitted - no attempts.');
	}
$prevattempts=	$prevattempts=
&start_data_table().&start_data_table_row().	&start_data_table().&start_data_table_row().
'<td>'.&mt('Nothing submitted - no attempts.').'</td>'.	'<td>'.$msg.'</td>'.
&end_data_table_row().&end_data_table();	&end_data_table_row().&end_data_table();
}	}
} else {	} else {
Line 4652 sub get_student_view {	Line 4846 sub get_student_view {
}	}
if (defined($target)) { $form{'grade_target'} = $target; }	if (defined($target)) { $form{'grade_target'} = $target; }
$feedurl=&Apache::lonnet::clutter($feedurl);	$feedurl=&Apache::lonnet::clutter($feedurl);
	if (($feedurl =~ /ext\.tool$/) && ($target eq 'tex')) {
	$feedurl =~ s{^/adm/wrapper}{};
	}
my ($userview,$response)=&Apache::lonnet::ssi_body($feedurl,%form);	my ($userview,$response)=&Apache::lonnet::ssi_body($feedurl,%form);
$userview=~s/\<body[^\>]*\>//gi;	$userview=~s/\<body[^\>]*\>//gi;
$userview=~s/\<\/body\>//gi;	$userview=~s/\<\/body\>//gi;
Line 4951 sub findallcourses {	Line 5148 sub findallcourses {
###############################################	###############################################

sub blockcheck {	sub blockcheck {
my ($setters,$activity,$uname,$udom,$url,$is_course) = @_;	my ($setters,$activity,$uname,$udom,$url,$is_course,$symb,$caller) = @_;

if (defined($udom) && defined($uname)) {	if (defined($udom) && defined($uname)) {
# If uname and udom are for a course, check for blocks in the course.	# If uname and udom are for a course, check for blocks in the course.
if (($is_course) \|\| (&Apache::lonnet::is_course($udom,$uname))) {	if (($is_course) \|\| (&Apache::lonnet::is_course($udom,$uname))) {
my ($startblock,$endblock,$triggerblock) =	my ($startblock,$endblock,$triggerblock) =
&get_blocks($setters,$activity,$udom,$uname,$url);	&get_blocks($setters,$activity,$udom,$uname,$url,$symb,$caller);
return ($startblock,$endblock,$triggerblock);	return ($startblock,$endblock,$triggerblock);
}	}
} else {	} else {
Line 4974 sub blockcheck {	Line 5171 sub blockcheck {
# boards, chat or groups, check for blocking in current course only.	# boards, chat or groups, check for blocking in current course only.

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 '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 5058 sub blockcheck {	Line 5257 sub blockcheck {
$tdom,$spec,$trest,$area);	$tdom,$spec,$trest,$area);
}	}
}	}
my ($author,$adv) = &Apache::lonnet::set_userprivs(\%userroles,\%allroles);	my ($author,$adv,$rar) = &Apache::lonnet::set_userprivs(\%userroles,\%allroles);
if ($userroles{'user.priv.'.$checkrole} =~ /evb\&([^\:]*)/) {	if ($userroles{'user.priv.'.$checkrole} =~ /evb\&([^\:]*)/) {
if ($1) {	if ($1) {
$no_userblock = 1;	$no_userblock = 1;
Line 5080 sub blockcheck {	Line 5279 sub blockcheck {
($env{'request.role'} !~ m{^st\./\Q$cdom\E/\Q$cnum\E}));	($env{'request.role'} !~ m{^st\./\Q$cdom\E/\Q$cnum\E}));
next if ($no_userblock);	next if ($no_userblock);

# Retrieve blocking times and identity of locker for course	# Retrieve blocking times and identity of blocker for course
# of specified user, unless user has 'evb' privilege.	# of specified user, unless user has 'evb' privilege.

my ($start,$end,$trigger) =	my ($start,$end,$trigger) =
&get_blocks($setters,$activity,$cdom,$cnum,$url);	&get_blocks($setters,$activity,$cdom,$cnum,$url,$symb,$caller);
if (($start != 0) &&	if (($start != 0) &&
(($startblock == 0) \|\| ($startblock > $start))) {	(($startblock == 0) \|\| ($startblock > $start))) {
$startblock = $start;	$startblock = $start;
Line 5104 sub blockcheck {	Line 5303 sub blockcheck {
}	}

sub get_blocks {	sub get_blocks {
my ($setters,$activity,$cdom,$cnum,$url) = @_;	my ($setters,$activity,$cdom,$cnum,$url,$symb,$caller) = @_;
my $startblock = 0;	my $startblock = 0;
my $endblock = 0;	my $endblock = 0;
my $triggerblock = '';	my $triggerblock = '';
Line 5117 sub get_blocks {	Line 5316 sub get_blocks {
my $now = time;	my $now = time;
my %commblocks = &Apache::lonnet::get_comm_blocks($cdom,$cnum);	my %commblocks = &Apache::lonnet::get_comm_blocks($cdom,$cnum);
if ($activity eq 'docs') {	if ($activity eq 'docs') {
@blockers = &Apache::lonnet::has_comm_blocking('bre',undef,$url,\%commblocks);	my ($blocked,$nosymbcache,$noenccheck);
	if (($caller eq 'blockedaccess') \|\| ($caller eq 'blockingstatus')) {
	$blocked = 1;
	$nosymbcache = 1;
	$noenccheck = 1;
	}
	@blockers = &Apache::lonnet::has_comm_blocking('bre',$symb,$url,$nosymbcache,$noenccheck,$blocked,\%commblocks);
foreach my $block (@blockers) {	foreach my $block (@blockers) {
if ($block =~ /^firstaccess____(.+)$/) {	if ($block =~ /^firstaccess____(.+)$/) {
my $item = $1;	my $item = $1;
Line 5169 sub get_blocks {	Line 5374 sub get_blocks {
my $end = $start + $env{'course.'.$cdom.'_'.$cnum.'.timerinterval.'.$timersymb};	my $end = $start + $env{'course.'.$cdom.'_'.$cnum.'.timerinterval.'.$timersymb};
if ($start && $end) {	if ($start && $end) {
if (($start <= time) && ($end >= time)) {	if (($start <= time) && ($end >= time)) {
unless (grep(/^\Q$block\E$/,@blockers)) {	if (ref($commblocks{$block}) eq 'HASH') {
push(@blockers,$block);	if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
$triggered{$block} = {	if ($commblocks{$block}{'blocks'}{$activity} eq 'on') {
start => $start,	unless(grep(/^\Q$block\E$/,@blockers)) {
end => $end,	push(@blockers,$block);
type => $type,	$triggered{$block} = {
};	start => $start,
	end => $end,
	type => $type,
	};
	}
	}
	}
}	}
}	}
}	}
Line 5239 sub parse_block_record {	Line 5450 sub parse_block_record {
}	}

sub blocking_status {	sub blocking_status {
my ($activity,$uname,$udom,$url,$is_course) = @_;	my ($activity,$uname,$udom,$url,$is_course,$symb,$caller) = @_;
my %setters;	my %setters;

# check for active blocking	# check for active blocking
my ($startblock,$endblock,$triggerblock) =	my ($startblock,$endblock,$triggerblock) =
&blockcheck(\%setters,$activity,$uname,$udom,$url,$is_course);	&blockcheck(\%setters,$activity,$uname,$udom,$url,$is_course,$symb,$caller);
my $blocked = 0;	my $blocked = 0;
if ($startblock && $endblock) {	if ($startblock && $endblock) {
$blocked = 1;	$blocked = 1;
Line 5260 sub blocking_status {	Line 5471 sub blocking_status {
$querystring .= "&udom=$udom" if ($udom =~ /^$match_domain$/);	$querystring .= "&udom=$udom" if ($udom =~ /^$match_domain$/);
$querystring .= "&uname=$uname" if ($uname =~ /^$match_username$/);	$querystring .= "&uname=$uname" if ($uname =~ /^$match_username$/);
} elsif ($activity eq 'docs') {	} elsif ($activity eq 'docs') {
$querystring .= '&url='.&HTML::Entities::encode($url,'&"');	my $showurl = &Apache::lonenc::check_encrypt($url);
	$querystring .= '&url='.&HTML::Entities::encode($showurl,'\'&"<>');
	if ($symb) {
	my $showsymb = &Apache::lonenc::check_encrypt($symb);
	$querystring .= '&symb='.&HTML::Entities::encode($showsymb,'\'&"<>');
	}
}	}

my $output .= <<'END_MYBLOCK';	my $output .= <<'END_MYBLOCK';
Line 5285 END_MYBLOCK	Line 5501 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') {
	$text = &mt('Checking Critical Messages Blocked');
	} elsif ($activity eq 'reinit') {
	$text = &mt('Checking Course Update Blocked');
}	}
$output .= <<"END_BLOCK";	$output .= <<"END_BLOCK";
<div class='$class'>	<div class='$class'>
Line 5308 sub check_ip_acc {	Line 5532 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 5524 sub get_legacy_domconf {	Line 5753 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 5723 sub CSTR_pageheader {	Line 5952 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 5743 sub CSTR_pageheader {	Line 5977 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 5792 Inputs:	Line 6026 Inputs:

=item * $args, optional argument valid values are	=item * $args, optional argument valid values are
no_auto_mt_title -> prevents &mt()ing the title arg	no_auto_mt_title -> prevents &mt()ing the title arg
	use_absolute -> for external resource or syllabus, this will
	contain https://<hostname> if server uses
	https (as per hosts.tab), but request is for http
	hostname -> hostname, from $r->hostname().

=item * $advtoolsref, optional argument, ref to an array containing	=item * $advtoolsref, optional argument, ref to an array containing
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 5808 other decorations will be returned.	Line 6059 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 5817 sub bodytag {	Line 6068 sub bodytag {
}	}
if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }	if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
my $httphost = $args->{'use_absolute'};	my $httphost = $args->{'use_absolute'};
	my $hostname = $args->{'hostname'};

$function = &get_users_function() if (!$function);	$function = &get_users_function() if (!$function);
my $img = &designparm($function.'.img',$domain);	my $img = &designparm($function.'.img',$domain);
Line 5844 sub bodytag {	Line 6096 sub bodytag {
if ($env{'request.course.id'}) {	if ($env{'request.course.id'}) {
if ($env{'request.role'} !~ /^cr/) {	if ($env{'request.role'} !~ /^cr/) {
$role = &Apache::lonnet::plaintext($role,&course_type());	$role = &Apache::lonnet::plaintext($role,&course_type());
	} elsif ($role =~ m{^cr/($match_domain)/\1-domainconfig/(\w+)$}) {
	if ($env{'request.role.desc'}) {
	$role = $env{'request.role.desc'};
	} else {
	$role = &mt('Helpdesk[_1]',' '.$2);
	}
	} else {
	$role = (split(/\//,$role,4))[-1];
}	}
if ($env{'request.course.sec'}) {	if ($env{'request.course.sec'}) {
$role .= (' 'x2).'- '.&mt('section:').' '.$env{'request.course.sec'};	$role .= (' 'x2).'- '.&mt('section:').' '.$env{'request.course.sec'};
Line 5870 sub bodytag {	Line 6130 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 5904 sub bodytag {	Line 6175 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 5932 sub bodytag {	Line 6205 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'});	$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'},
	$hostname,$ltiscope,$ltiuri);
} else {	} else {
$bodytag .=	$bodytag .=
&Apache::lonmenu::prepare_functions($env{'request.noversionuri'},	&Apache::lonmenu::prepare_functions($env{'request.noversionuri'},
$forcereg,$args->{'group'},	$forcereg,$args->{'group'},
$args->{'bread_crumbs'},	$args->{'bread_crumbs'},
$advtoolsref);	$advtoolsref,'',$hostname);
}	}
}else{	}else{
# this is to seperate menu from content when there's no secondary	# this is to seperate menu from content when there's no secondary
Line 6408 td.LC_menubuttons_text {	Line 6686 td.LC_menubuttons_text {
background: $tabbg;	background: $tabbg;
}	}

	td.LC_zero_height {
	line-height: 0;
	cellpadding: 0;
	}

table.LC_data_table {	table.LC_data_table {
border: 1px solid #000000;	border: 1px solid #000000;
border-collapse: separate;	border-collapse: separate;
Line 6729 td.LC_parm_overview_restrictions {	Line 7012 td.LC_parm_overview_restrictions {
border-collapse: collapse;	border-collapse: collapse;
}	}

	span.LC_parm_recursive,
	td.LC_parm_recursive {
	font-weight: bold;
	font-size: smaller;
	}

table.LC_parm_overview_restrictions td {	table.LC_parm_overview_restrictions td {
border-width: 1px 4px 1px 4px;	border-width: 1px 4px 1px 4px;
border-style: solid;	border-style: solid;
Line 6998 table.LC_prior_tries td {	Line 7287 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 7080 table.LC_data_table tr > td.LC_docs_entr	Line 7370 table.LC_data_table tr > td.LC_docs_entr
color: #990000;	color: #990000;
}	}

	.LC_docs_alias {
	color: #440055;
	}

	.LC_domprefs_email,
	.LC_docs_alias_name,
.LC_docs_reinit_warn,	.LC_docs_reinit_warn,
.LC_docs_ext_edit {	.LC_docs_ext_edit {
font-size: x-small;	font-size: x-small;
Line 7988 ul.LC_funclist li {	Line 8284 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 8100 section.role-warning>h1:before {	Line 8404 section.role-warning>h1:before {
content:url('/adm/daxe/images/section_icons/warning.png');	content:url('/adm/daxe/images/section_icons/warning.png');
}	}

	#LC_minitab_header {
	float:left;
	width:100%;
	background:#DAE0D2 url("/res/adm/pages/minitabmenu_bg.gif") repeat-x bottom;
	font-size:93%;
	line-height:normal;
	margin: 0.5em 0 0.5em 0;
	}
	#LC_minitab_header ul {
	margin:0;
	padding:10px 10px 0;
	list-style:none;
	}
	#LC_minitab_header li {
	float:left;
	background:url("/res/adm/pages/minitabmenu_left.gif") no-repeat left top;
	margin:0;
	padding:0 0 0 9px;
	}
	#LC_minitab_header a {
	display:block;
	background:url("/res/adm/pages/minitabmenu_right.gif") no-repeat right top;
	padding:5px 15px 4px 6px;
	}
	#LC_minitab_header #LC_current_minitab {
	background-image:url("/res/adm/pages/minitabmenu_left_on.gif");
	}
	#LC_minitab_header #LC_current_minitab a {
	background-image:url("/res/adm/pages/minitabmenu_right_on.gif");
	padding-bottom:5px;
	}


END	END
}	}

Line 8205 ADDMETA	Line 8542 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 8262 function LC_Offload_Now() {	Line 8641 function LC_Offload_Now() {
// ]]>	// ]]>
</script>	</script>
OFFLOAD	OFFLOAD
}
}	}
}	}
}	}
Line 8292 OFFLOAD	Line 8670 OFFLOAD
<meta name="viewport" content="width=device-width, initial-scale=1.0, user-scalable=0, minimum-scale=1.0, maximum-scale=1.0">	<meta name="viewport" content="width=device-width, initial-scale=1.0, user-scalable=0, minimum-scale=1.0, maximum-scale=1.0">
<meta name="apple-mobile-web-app-capable" content="yes" />';	<meta name="apple-mobile-web-app-capable" content="yes" />';
}	}
	$result .= '<meta name="google" content="notranslate" />'."\n";
return $result.'</head>';	return $result.'</head>';
}	}

Line 8471 $args - additional optional args support	Line 8850 $args - additional optional args support
no_auto_mt_title -> prevent &mt()ing the title arg	no_auto_mt_title -> prevent &mt()ing the title arg
bread_crumbs -> Array containing breadcrumbs	bread_crumbs -> Array containing breadcrumbs
bread_crumbs_component -> if exists show it as headline else show only the breadcrumbs	bread_crumbs_component -> if exists show it as headline else show only the breadcrumbs
	bread_crumbs_nomenu -> if true will pass false as the value of $menulink
	to lonhtmlcommon::breadcrumbs
group -> includes the current group, if page is for a	group -> includes the current group, if page is for a
specific group	specific group
	use_absolute -> for request for external resource or syllabus, this
	will contain https://<hostname> if server uses
	https (as per hosts.tab), but request is for http
	hostname -> hostname, originally from $r->hostname(), (optional).

=back	=back

Line 8485 sub start_page {	Line 8870 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 8503 sub start_page {	Line 8919 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 8536 sub start_page {	Line 8952 sub start_page {
if (@advtools > 0) {	if (@advtools > 0) {
&Apache::lonmenu::advtools_crumbs(@advtools);	&Apache::lonmenu::advtools_crumbs(@advtools);
}	}
	my $menulink;
	# if arg: bread_crumbs_nomenu is true pass 0 as $menulink item.
	if ((exists($args->{'bread_crumbs_nomenu'})) \|\|
	($ltiscope eq 'map') \|\| ($ltiscope eq 'resource') \|\|
	((($args->{'crstype'} eq 'Placement') \|\| (($env{'request.course.id'}) &&
	($env{'course.'.$env{'request.course.id'}.'.type'} eq 'Placement'))) &&
	(!$env{'request.role.adv'}))) {
	$menulink = 0;
	} else {
	undef($menulink);
	}
#if bread_crumbs_component exists show it as headline else show only the breadcrumbs	#if bread_crumbs_component exists show it as headline else show only the breadcrumbs
if(exists($args->{'bread_crumbs_component'})){	if(exists($args->{'bread_crumbs_component'})){
$result .= &Apache::lonhtmlcommon::breadcrumbs($args->{'bread_crumbs_component'});	$result .= &Apache::lonhtmlcommon::breadcrumbs($args->{'bread_crumbs_component'},'',$menulink);
} elsif ($args->{'crstype'} eq 'Placement') {
$result .= &Apache::lonhtmlcommon::breadcrumbs('','','','','','','','','',
$args->{'crstype'});
} else {	} else {
$result .= &Apache::lonhtmlcommon::breadcrumbs();	$result .= &Apache::lonhtmlcommon::breadcrumbs('','',$menulink);
}	}
}	}
return $result;	return $result;
Line 8641 var modalWindow = {	Line 9064 var modalWindow = {
};	};
var openMyModal = function(source,width,height,scrolling,transparency,style)	var openMyModal = function(source,width,height,scrolling,transparency,style)
{	{
source = source.replace("'","'");	source = source.replace(/'/g,"'");
modalWindow.windowId = "myModal";	modalWindow.windowId = "myModal";
modalWindow.width = width;	modalWindow.width = width;
modalWindow.height = height;	modalWindow.height = height;
Line 8666 sub modal_link {	Line 9089 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 8770 sub end_togglebox {	Line 9192 sub end_togglebox {
}	}

sub LCprogressbar_script {	sub LCprogressbar_script {
my ($id)=@_;	my ($id,$number_to_do)=@_;
return(<<ENDPROGRESS);	if ($number_to_do) {
	return(<<ENDPROGRESS);
<script type="text/javascript">	<script type="text/javascript">
// <![CDATA[	// <![CDATA[
\$('#progressbar$id').progressbar({	\$('#progressbar$id').progressbar({
Line 8784 sub LCprogressbar_script {	Line 9207 sub LCprogressbar_script {
// ]]>	// ]]>
</script>	</script>
ENDPROGRESS	ENDPROGRESS
	} else {
	return(<<ENDPROGRESS);
	<script type="text/javascript">
	// <![CDATA[
	\$('#progressbar$id').progressbar({
	value: false,
	create: function(event, ui) {
	\$('.ui-widget-header', this).css({'background':'#F0F0F0'});
	\$('.ui-progressbar-overlay', this).css({'margin':'0'});
	}
	});
	// ]]>
	</script>
	ENDPROGRESS
	}
}	}

sub LCprogressbarUpdate_script {	sub LCprogressbarUpdate_script {
return(<<ENDPROGRESSUPDATE);	return(<<ENDPROGRESSUPDATE);
<style type="text/css">	<style type="text/css">
.ui-progressbar { position:relative; }	.ui-progressbar { position:relative; }
	.progress-label {position: absolute; width: 100%; text-align: center; top: 1px; font-weight: bold; text-shadow: 1px 1px 0 #fff;margin: 0; line-height: 200%; }
.pblabel { position: absolute; width: 100%; text-align: center; line-height: 1.9em; }	.pblabel { position: absolute; width: 100%; text-align: center; line-height: 1.9em; }
</style>	</style>
<script type="text/javascript">	<script type="text/javascript">
// <![CDATA[	// <![CDATA[
var LCprogressTxt='---';	var LCprogressTxt='---';

function LCupdateProgress(percent,progresstext,id) {	function LCupdateProgress(percent,progresstext,id,maxnum) {
LCprogressTxt=progresstext;	LCprogressTxt=progresstext;
\$('#progressbar'+id).progressbar('value',percent);	if ((maxnum == '') \|\| (maxnum == undefined) \|\| (maxnum == null)) {
	\$('#progressbar'+id).find('.progress-label').text(LCprogressTxt);
	} else if (percent === \$('#progressbar'+id).progressbar( "value" )) {
	\$('#progressbar'+id).find('.pblabel').text(LCprogressTxt);
	} else {
	\$('#progressbar'+id).progressbar('value',percent);
	}
}	}
// ]]>	// ]]>
</script>	</script>
Line 8810 my $LCidcnt;	Line 9255 my $LCidcnt;
my $LCcurrentid;	my $LCcurrentid;

sub LCprogressbar {	sub LCprogressbar {
my ($r)=(@_);	my ($r,$number_to_do,$preamble)=@_;
$LClastpercent=0;	$LClastpercent=0;
$LCidcnt++;	$LCidcnt++;
$LCcurrentid=$$.'_'.$LCidcnt;	$LCcurrentid=$$.'_'.$LCidcnt;
my $starting=&mt('Starting');	my ($starting,$content);
my $content=(<<ENDPROGBAR);	if ($number_to_do) {
	$starting=&mt('Starting');
	$content=(<<ENDPROGBAR);
	$preamble
<div id="progressbar$LCcurrentid">	<div id="progressbar$LCcurrentid">
<span class="pblabel">$starting</span>	<span class="pblabel">$starting</span>
</div>	</div>
ENDPROGBAR	ENDPROGBAR
&r_print($r,$content.&LCprogressbar_script($LCcurrentid));	} else {
	$starting=&mt('Loading...');
	$LClastpercent='false';
	$content=(<<ENDPROGBAR);
	$preamble
	<div id="progressbar$LCcurrentid">
	<div class="progress-label">$starting</div>
	</div>
	ENDPROGBAR
	}
	&r_print($r,$content.&LCprogressbar_script($LCcurrentid,$number_to_do));
}	}

sub LCprogressbarUpdate {	sub LCprogressbarUpdate {
my ($r,$val,$text)=@_;	my ($r,$val,$text,$number_to_do)=@_;
unless ($val) {	if ($number_to_do) {
if ($LClastpercent) {	unless ($val) {
$val=$LClastpercent;	if ($LClastpercent) {
} else {	$val=$LClastpercent;
$val=0;	} else {
}	$val=0;
	}
	}
	if ($val<0) { $val=0; }
	if ($val>100) { $val=0; }
	$LClastpercent=$val;
	unless ($text) { $text=$val.'%'; }
	} else {
	$val = 'false';
}	}
if ($val<0) { $val=0; }
if ($val>100) { $val=0; }
$LClastpercent=$val;
unless ($text) { $text=$val.'%'; }
$text=&js_ready($text);	$text=&js_ready($text);
&r_print($r,<<ENDUPDATE);	&r_print($r,<<ENDUPDATE);
<script type="text/javascript">	<script type="text/javascript">
// <![CDATA[	// <![CDATA[
LCupdateProgress($val,'$text','$LCcurrentid');	LCupdateProgress($val,'$text','$LCcurrentid','$number_to_do');
// ]]>	// ]]>
</script>	</script>
ENDUPDATE	ENDUPDATE
Line 9025 function expand_div(caller) {	Line 9487 function expand_div(caller) {

sub simple_error_page {	sub simple_error_page {
my ($r,$title,$msg,$args) = @_;	my ($r,$title,$msg,$args) = @_;
	my %displayargs;
if (ref($args) eq 'HASH') {	if (ref($args) eq 'HASH') {
if (!$args->{'no_auto_mt_msg'}) { $msg = &mt($msg); }	if (!$args->{'no_auto_mt_msg'}) { $msg = &mt($msg); }
	if ($args->{'only_body'}) {
	$displayargs{'only_body'} = 1;
	}
	if ($args->{'no_nav_bar'}) {
	$displayargs{'no_nav_bar'} = 1;
	}
} else {	} else {
$msg = &mt($msg);	$msg = &mt($msg);
}	}

my $page =	my $page =
&Apache::loncommon::start_page($title).	&Apache::loncommon::start_page($title,'',\%displayargs).
'<p class="LC_error">'.$msg.'</p>'.	'<p class="LC_error">'.$msg.'</p>'.
&Apache::loncommon::end_page();	&Apache::loncommon::end_page();
if (ref($r)) {	if (ref($r)) {
Line 9960 sub get_secgrprole_info {	Line 10429 sub get_secgrprole_info {
}	}

sub user_picker {	sub user_picker {
my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype,$context,$fixeddom) = @_;	my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype,$context,$fixeddom,$noinstd) = @_;
my $currdom = $dom;	my $currdom = $dom;
my @alldoms = &Apache::lonnet::all_domains();	my @alldoms = &Apache::lonnet::all_domains();
if (@alldoms == 1) {	if (@alldoms == 1) {
Line 10025 sub user_picker {	Line 10494 sub user_picker {
&html_escape(\%html_lt);	&html_escape(\%html_lt);
&js_escape(\%js_lt);	&js_escape(\%js_lt);
my $domform;	my $domform;
	my $allow_blank = 1;
if ($fixeddom) {	if ($fixeddom) {
$domform = &select_dom_form($currdom,'srchdomain',1,1,undef,[$currdom]);	$allow_blank = 0;
	$domform = &select_dom_form($currdom,'srchdomain',$allow_blank,1,undef,[$currdom]);
} else {	} else {
$domform = &select_dom_form($currdom,'srchdomain',1,1);	my $defdom = $env{'request.role.domain'};
	my ($trusted,$untrusted);
	if (($context eq 'requestcrs') \|\| ($context eq 'course')) {
	($trusted,$untrusted) = &Apache::lonnet::trusted_domains('enroll',$defdom);
	} elsif ($context eq 'author') {
	($trusted,$untrusted) = &Apache::lonnet::trusted_domains('othcoau',$defdom);
	} elsif ($context eq 'domain') {
	($trusted,$untrusted) = &Apache::lonnet::trusted_domains('domroles',$defdom);
	}
	$domform = &select_dom_form($currdom,'srchdomain',$allow_blank,1,undef,$trusted,$untrusted);
}	}
my $srchinsel = ' <select name="srchin">';	my $srchinsel = ' <select name="srchin">';

Line 10041 sub user_picker {	Line 10521 sub user_picker {
next if ($option eq 'alc');	next if ($option eq 'alc');
next if (($option eq 'crs') && ($env{'form.form'} eq 'requestcrs'));	next if (($option eq 'crs') && ($env{'form.form'} eq 'requestcrs'));
next if ($option eq 'crs' && !$env{'request.course.id'});	next if ($option eq 'crs' && !$env{'request.course.id'});
	next if (($option eq 'instd') && ($noinstd));
if ($curr_selected{'srchin'} eq $option) {	if ($curr_selected{'srchin'} eq $option) {
$srchinsel .= '	$srchinsel .= '
<option value="'.$option.'" selected="selected">'.$html_lt{$option}.'</option>';	<option value="'.$option.'" selected="selected">'.$html_lt{$option}.'</option>';
Line 10538 sub get_institutional_codes {	Line 11019 sub get_institutional_codes {
foreach (@currxlists) {	foreach (@currxlists) {
if (m/^([^:]+):(\w*)$/) {	if (m/^([^:]+):(\w*)$/) {
unless (grep/^$1$/,@{$allcourses}) {	unless (grep/^$1$/,@{$allcourses}) {
push @{$allcourses},$1;	push(@{$allcourses},$1);
$$LC_code{$1} = $2;	$$LC_code{$1} = $2;
}	}
}	}
Line 10551 sub get_institutional_codes {	Line 11032 sub get_institutional_codes {
my $sec = $coursecode.$1;	my $sec = $coursecode.$1;
my $lc_sec = $2;	my $lc_sec = $2;
unless (grep/^$sec$/,@{$allcourses}) {	unless (grep/^$sec$/,@{$allcourses}) {
push @{$allcourses},$sec;	push(@{$allcourses},$sec);
$$LC_code{$sec} = $lc_sec;	$$LC_code{$sec} = $lc_sec;
}	}
}	}
Line 11879 sub modify_html_refs {	Line 12360 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 11944 sub modify_html_refs {	Line 12425 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 12461 sub decompress_uploaded_file {	Line 12942 sub decompress_uploaded_file {

sub process_decompression {	sub process_decompression {
my ($docudom,$docuname,$file,$destination,$dir_root,$hiddenelem) = @_;	my ($docudom,$docuname,$file,$destination,$dir_root,$hiddenelem) = @_;
	unless (($dir_root eq '/userfiles') && ($destination =~ m{^(docs\|supplemental)/(default\|\d+)/\d+$})) {
	return '<p class="LC_error">'.&mt('Not extracted.').'<br />'.
	&mt('Unexpected file path.').'</p>'."\n";
	}
	unless (($docudom =~ /^$match_domain$/) && ($docuname =~ /^$match_courseid$/)) {
	return '<p class="LC_error">'.&mt('Not extracted.').'<br />'.
	&mt('Unexpected course context.').'</p>'."\n";
	}
	unless ($file eq &Apache::lonnet::clean_filename($file)) {
	return '<p class="LC_error">'.&mt('Not extracted.').'<br />'.
	&mt('Filename contained unexpected characters.').'</p>'."\n";
	}
my ($dir,$error,$warning,$output);	my ($dir,$error,$warning,$output);
if ($file !~ /\.(zip\|tar\|bz2\|gz\|tar.gz\|tar.bz2\|tgz)$/i) {	if ($file !~ /\.(zip\|tar\|bz2\|gz\|tar.gz\|tar.bz2\|tgz)$/i) {
$error = &mt('Filename not a supported archive file type.').	$error = &mt('Filename not a supported archive file type.').
Line 12495 sub process_decompression {	Line 12988 sub process_decompression {
}	}
}	}
my $numskip = scalar(@to_skip);	my $numskip = scalar(@to_skip);
if (($numskip > 0) &&	my $numoverwrite = scalar(@to_overwrite);
($numskip == $env{'form.archive_itemcount'})) {	if (($numskip) && (!$numoverwrite)) {
$warning = &mt('All items in the archive file already exist, and no overwriting of existing files has been requested.');	$warning = &mt('All items in the archive file already exist, and no overwriting of existing files has been requested.');
} elsif ($dir eq '') {	} elsif ($dir eq '') {
$error = &mt('Directory containing archive file unavailable.');	$error = &mt('Directory containing archive file unavailable.');
} elsif (!$error) {	} elsif (!$error) {
my ($decompressed,$display);	my ($decompressed,$display);
if ($numskip > 0) {	if (($numskip) \|\| ($numoverwrite)) {
my $tempdir = time.'_'.$$.int(rand(10000));	my $tempdir = time.'_'.$$.int(rand(10000));
mkdir("$dir/$tempdir",0755);	mkdir("$dir/$tempdir",0755);
system("mv $dir/$file $dir/$tempdir/$file");	if (&File::Copy::move("$dir/$file","$dir/$tempdir/$file")) {
($decompressed,$display) =	($decompressed,$display) =
&decompress_uploaded_file($file,"$dir/$tempdir");	&decompress_uploaded_file($file,"$dir/$tempdir");
foreach my $item (@to_skip) {	foreach my $item (@to_skip) {
if (($item ne '') && ($item !~ /\.\./)) {	if (($item ne '') && ($item !~ /\.\./)) {
if (-f "$dir/$tempdir/$item") {	if (-f "$dir/$tempdir/$item") {
unlink("$dir/$tempdir/$item");	unlink("$dir/$tempdir/$item");
} elsif (-d "$dir/$tempdir/$item") {	} elsif (-d "$dir/$tempdir/$item") {
system("rm -rf $dir/$tempdir/$item");	&File::Path::remove_tree("$dir/$tempdir/$item",{ safe => 1 });
	}
}	}
}	}
	foreach my $item (@to_overwrite) {
	if ((-e "$dir/$tempdir/$item") && (-e "$dir/$item")) {
	if (($item ne '') && ($item !~ /\.\./)) {
	if (-f "$dir/$item") {
	unlink("$dir/$item");
	} elsif (-d "$dir/$item") {
	&File::Path::remove_tree("$dir/$item",{ safe => 1 });
	}
	&File::Copy::move("$dir/$tempdir/$item","$dir/$item");
	}
	}
	}
	if (&File::Copy::move("$dir/$tempdir/$file","$dir/$file")) {
	&File::Path::remove_tree("$dir/$tempdir",{ safe => 1 });
	}
}	}
system("mv $dir/$tempdir/* $dir");
rmdir("$dir/$tempdir");
} else {	} else {
($decompressed,$display) =	($decompressed,$display) =
&decompress_uploaded_file($file,$dir);	&decompress_uploaded_file($file,$dir);
Line 12536 sub process_decompression {	Line 13043 sub process_decompression {
if (ref($newdirlistref) eq 'ARRAY') {	if (ref($newdirlistref) eq 'ARRAY') {
foreach my $dir_line (@{$newdirlistref}) {	foreach my $dir_line (@{$newdirlistref}) {
my ($item,undef,undef,$testdir)=split(/\&/,$dir_line,5);	my ($item,undef,undef,$testdir)=split(/\&/,$dir_line,5);
unless (($item =~ /^\.+$/) \|\| ($item eq $file) \|\|	unless (($item =~ /^\.+$/) \|\| ($item eq $file)) {
((@to_skip > 0) && (grep(/^\Q$item\E$/,@to_skip)))) {
push(@newitems,$item);	push(@newitems,$item);
if ($dirptr&$testdir) {	if ($dirptr&$testdir) {
$is_dir{$item} = 1;	$is_dir{$item} = 1;
Line 13022 END	Line 13528 END
sub process_extracted_files {	sub process_extracted_files {
my ($context,$docudom,$docuname,$destination,$dir_root,$hiddenelem) = @_;	my ($context,$docudom,$docuname,$destination,$dir_root,$hiddenelem) = @_;
my $numitems = $env{'form.archive_count'};	my $numitems = $env{'form.archive_count'};
return unless ($numitems);	return if ((!$numitems) \|\| ($numitems =~ /\D/));
my @ids=&Apache::lonnet::current_machine_ids();	my @ids=&Apache::lonnet::current_machine_ids();
my ($prefix,$pathtocheck,$dir,$ishome,$error,$warning,%toplevelitems,%is_dir,	my ($prefix,$pathtocheck,$dir,$ishome,$error,$warning,%toplevelitems,%is_dir,
%folders,%containers,%mapinner,%prompttofetch);	%folders,%containers,%mapinner,%prompttofetch);
Line 13035 sub process_extracted_files {	Line 13541 sub process_extracted_files {
} else {	} else {
$prefix = $Apache::lonnet::perlvar{'lonDocRoot'};	$prefix = $Apache::lonnet::perlvar{'lonDocRoot'};
$pathtocheck = "$dir_root/$docudom/$docuname/$destination";	$pathtocheck = "$dir_root/$docudom/$docuname/$destination";
$dir = "$dir_root/$docudom/$docuname";	$dir = "$dir_root/$docudom/$docuname";
}	}
my $currdir = "$dir_root/$destination";	my $currdir = "$dir_root/$destination";
(my $docstype,$mapinner{'0'}) = ($destination =~ m{^(docs\|supplemental)/(\w+)/});	(my $docstype,$mapinner{'0'}) = ($destination =~ m{^(docs\|supplemental)/(\w+)/});
Line 13124 sub process_extracted_files {	Line 13630 sub process_extracted_files {
'.'.$containers{$outer},1,1);	'.'.$containers{$outer},1,1);
$newseqid{$i} = $newidx;	$newseqid{$i} = $newidx;
unless ($errtext) {	unless ($errtext) {
$result .= '<li>'.&mt('Folder: [_1] added to course',$docstitle).'</li>'."\n";	$result .= '<li>'.&mt('Folder: [_1] added to course',
	&HTML::Entities::encode($docstitle,'<>&"')).
	'</li>'."\n";
}	}
}	}
} else {	} else {
Line 13133 sub process_extracted_files {	Line 13641 sub process_extracted_files {
my $url = '/uploaded/'.$docudom.'/'.$docuname.'/'.	my $url = '/uploaded/'.$docudom.'/'.$docuname.'/'.
$docstype.'/'.$mapinner{$outer}.'/'.$newidx.'/'.	$docstype.'/'.$mapinner{$outer}.'/'.$newidx.'/'.
$title;	$title;
if (!-e "$prefix$dir/$docstype/$mapinner{$outer}") {	if (($outer !~ /\D/) && ($mapinner{$outer} !~ /\D/) && ($newidx !~ /\D/)) {
mkdir("$prefix$dir/$docstype/$mapinner{$outer}",0755);	if (!-e "$prefix$dir/$docstype/$mapinner{$outer}") {
}	mkdir("$prefix$dir/$docstype/$mapinner{$outer}",0755);
if (!-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
mkdir("$prefix$dir/$docstype/$mapinner{$outer}/$newidx");
}
if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
system("mv $prefix$path $prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title");
$newdest{$i} = "$prefix$dir/$docstype/$mapinner{$outer}/$newidx";
unless ($ishome) {
my $fetch = "$newdest{$i}/$title";
$fetch =~ s/^\Q$prefix$dir\E//;
$prompttofetch{$fetch} = 1;
}	}
}	if (!-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
$LONCAPA::map::resources[$newidx]=	mkdir("$prefix$dir/$docstype/$mapinner{$outer}/$newidx");
$docstitle.':'.$url.':false:normal:res';	}
push(@LONCAPA::map::order, $newidx);	if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
my ($outtext,$errtext)=	if (rename("$prefix$path","$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title")) {
&LONCAPA::map::storemap('/uploaded/'.$docudom.'/'.	$newdest{$i} = "$prefix$dir/$docstype/$mapinner{$outer}/$newidx";
$docuname.'/'.$folders{$outer}.	unless ($ishome) {
'.'.$containers{$outer},1,1);	my $fetch = "$newdest{$i}/$title";
unless ($errtext) {	$fetch =~ s/^\Q$prefix$dir\E//;
if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") {	$prompttofetch{$fetch} = 1;
$result .= '<li>'.&mt('File: [_1] added to course',$docstitle).'</li>'."\n";	}
	}
	}
	$LONCAPA::map::resources[$newidx]=
	$docstitle.':'.$url.':false:normal:res';
	push(@LONCAPA::map::order, $newidx);
	my ($outtext,$errtext)=
	&LONCAPA::map::storemap('/uploaded/'.$docudom.'/'.
	$docuname.'/'.$folders{$outer}.
	'.'.$containers{$outer},1,1);
	unless ($errtext) {
	if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") {
	$result .= '<li>'.&mt('File: [_1] added to course',
	&HTML::Entities::encode($docstitle,'<>&"')).
	'</li>'."\n";
	}
}	}
	} else {
	$warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
	&HTML::Entities::encode($path,'<>&"')).'<br />';
}	}
}	}
}	}
}	}
} else {	} else {
$warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'<br />';	$warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
	&HTML::Entities::encode($path,'<>&"')).'<br />';
}	}
}	}
for (my $i=1; $i<=$numitems; $i++) {	for (my $i=1; $i<=$numitems; $i++) {
Line 13225 sub process_extracted_files {	Line 13742 sub process_extracted_files {
}	}
if ($fullpath ne '') {	if ($fullpath ne '') {
if (-e "$prefix$path") {	if (-e "$prefix$path") {
system("mv $prefix$path $fullpath/$title");	unless (rename("$prefix$path","$fullpath/$title")) {
	$warning .= &mt('Failed to rename dependency').'<br />';
	}
}	}
if (-e "$fullpath/$title") {	if (-e "$fullpath/$title") {
my $showpath;	my $showpath;
Line 13234 sub process_extracted_files {	Line 13753 sub process_extracted_files {
} else {	} else {
$showpath = "/$title";	$showpath = "/$title";
}	}
$result .= '<li>'.&mt('[_1] included as a dependency',$showpath).'</li>'."\n";	$result .= '<li>'.&mt('[_1] included as a dependency',
}	&HTML::Entities::encode($showpath,'<>&"')).
unless ($ishome) {	'</li>'."\n";
my $fetch = "$fullpath/$title";	unless ($ishome) {
$fetch =~ s/^\Q$prefix$dir\E//;	my $fetch = "$fullpath/$title";
$prompttofetch{$fetch} = 1;	$fetch =~ s/^\Q$prefix$dir\E//;
	$prompttofetch{$fetch} = 1;
	}
}	}
}	}
}	}
} elsif ($env{'form.archive_'.$referrer{$i}} eq 'discard') {	} elsif ($env{'form.archive_'.$referrer{$i}} eq 'discard') {
$warning .= &mt('[_1] is a dependency of [_2], which was discarded.',	$warning .= &mt('[_1] is a dependency of [_2], which was discarded.',
$path,$env{'form.archive_content_'.$referrer{$i}}).'<br />';	&HTML::Entities::encode($path,'<>&"'),
	&HTML::Entities::encode($env{'form.archive_content_'.$referrer{$i}},'<>&"')).
	'<br />';
}	}
} else {	} else {
$warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'<br />';	$warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
	&HTML::Entities::encode($path)).'<br />';
}	}
}	}
if (keys(%todelete)) {	if (keys(%todelete)) {
Line 13522 sub upfile_store {	Line 14046 sub upfile_store {
$env{'form.upfile'}=~s/\n+/\n/gs;	$env{'form.upfile'}=~s/\n+/\n/gs;
$env{'form.upfile'}=~s/\n+$//gs;	$env{'form.upfile'}=~s/\n+$//gs;

my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.	my $datatoken = &valid_datatoken($env{'user.name'}.'_'.$env{'user.domain'}.
'_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;	'_enroll_'.$env{'request.course.id'}.'_'.
	time.'_'.$$);
	return if ($datatoken eq '');

{	{
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 13537 sub upfile_store {	Line 14064 sub upfile_store {

=pod	=pod

=item * &load_tmp_file($r)	=item * &load_tmp_file($r,$datatoken)

Load uploaded file from tmp, $r should be the HTTP Request object,	Load uploaded file from tmp, $r should be the HTTP Request object,
needs $env{'form.datatoken'},	$datatoken is the name to assign to the temporary file.
sets $env{'form.upfile'} to the contents of the file	sets $env{'form.upfile'} to the contents of the file

=cut	=cut

sub load_tmp_file {	sub load_tmp_file {
my $r=shift;	my ($r,$datatoken) = @_;
	return if ($datatoken eq '');
my @studentdata=();	my @studentdata=();
{	{
my $studentfile = $r->dir_config('lonDaemons').	my $studentfile = $r->dir_config('lonDaemons').
'/tmp/'.$env{'form.datatoken'}.'.tmp';	'/tmp/'.$datatoken.'.tmp';
if ( open(my $fh,"<$studentfile") ) {	if ( open(my $fh,'<',$studentfile) ) {
@studentdata=<$fh>;	@studentdata=<$fh>;
close($fh);	close($fh);
}	}
Line 13559 sub load_tmp_file {	Line 14087 sub load_tmp_file {
$env{'form.upfile'}=join('',@studentdata);	$env{'form.upfile'}=join('',@studentdata);
}	}

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

=pod	=pod

=item * &upfile_record_sep()	=item * &upfile_record_sep()
Line 13999 sub DrawBarGraph {	Line 14535 sub DrawBarGraph {
@Labels = @$labels;	@Labels = @$labels;
} else {	} else {
for (my $i=0;$i<@{$Values[0]};$i++) {	for (my $i=0;$i<@{$Values[0]};$i++) {
push (@Labels,$i+1);	push(@Labels,$i+1);
}	}
}	}
#	#
Line 14445 requestsmail, updatesmail, or idconflict	Line 14981 requestsmail, updatesmail, or idconflict
defdom (domain for which to retrieve configuration settings),	defdom (domain for which to retrieve configuration settings),

origmail (scalar - email address of recipient from loncapa.conf,	origmail (scalar - email address of recipient from loncapa.conf,
i.e., predates configuration by DC via domainprefs.pm	i.e., predates configuration by DC via domainprefs.pm

	$requname username of requester (if mailing type is helpdeskmail)

	$requdom domain of requester (if mailing type is helpdeskmail)

	$reqemail e-mail address of requester (if mailing type is helpdeskmail)


Returns: comma separated list of addresses to which to send e-mail.	Returns: comma separated list of addresses to which to send e-mail.

Line 14456 Returns: comma separated list of address	Line 14999 Returns: comma separated list of address
############################################################	############################################################
############################################################	############################################################
sub build_recipient_list {	sub build_recipient_list {
my ($defmail,$mailing,$defdom,$origmail) = @_;	my ($defmail,$mailing,$defdom,$origmail,$requname,$requdom,$reqemail) = @_;
my @recipients;	my @recipients;
my $otheremails;	my ($otheremails,$lastresort,$allbcc,$addtext);
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['contacts'],$defdom);	&Apache::lonnet::get_dom('configuration',['contacts'],$defdom);
if (ref($domconfig{'contacts'}) eq 'HASH') {	if (ref($domconfig{'contacts'}) eq 'HASH') {
if (exists($domconfig{'contacts'}{$mailing})) {	if (exists($domconfig{'contacts'}{$mailing})) {
if (ref($domconfig{'contacts'}{$mailing}) eq 'HASH') {	if (ref($domconfig{'contacts'}{$mailing}) eq 'HASH') {
Line 14472 sub build_recipient_list {	Line 15015 sub build_recipient_list {
push(@recipients,$addr);	push(@recipients,$addr);
}	}
}	}
$otheremails = $domconfig{'contacts'}{$mailing}{'others'};	}
	$otheremails = $domconfig{'contacts'}{$mailing}{'others'};
	if ($mailing eq 'helpdeskmail') {
	if ($domconfig{'contacts'}{$mailing}{'bcc'}) {
	my @bccs = split(/,/,$domconfig{'contacts'}{$mailing}{'bcc'});
	my @ok_bccs;
	foreach my $bcc (@bccs) {
	$bcc =~ s/^\s+//g;
	$bcc =~ s/\s+$//g;
	if ($bcc =~ m/^[^\@]+\@[^\@]+$/) {
	if (!(grep(/^\Q$bcc\E$/,@ok_bccs))) {
	push(@ok_bccs,$bcc);
	}
	}
	}
	if (@ok_bccs > 0) {
	$allbcc = join(', ',@ok_bccs);
	}
	}
	$addtext = $domconfig{'contacts'}{$mailing}{'include'};
}	}
}	}
} elsif ($origmail ne '') {	} elsif ($origmail ne '') {
push(@recipients,$origmail);	$lastresort = $origmail;
	}
	if ($mailing eq 'helpdeskmail') {
	if ((ref($domconfig{'contacts'}{'overrides'}) eq 'HASH') &&
	(keys(%{$domconfig{'contacts'}{'overrides'}}))) {
	my ($inststatus,$inststatus_checked);
	if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') &&
	($env{'user.domain'} ne 'public')) {
	$inststatus_checked = 1;
	$inststatus = $env{'environment.inststatus'};
	}
	unless ($inststatus_checked) {
	if (($requname ne '') && ($requdom ne '')) {
	if (($requname =~ /^$match_username$/) &&
	($requdom =~ /^$match_domain$/) &&
	(&Apache::lonnet::domain($requdom))) {
	my $requhome = &Apache::lonnet::homeserver($requname,
	$requdom);
	unless ($requhome eq 'no_host') {
	my %userenv = &Apache::lonnet::userenvironment($requdom,$requname,'inststatus');
	$inststatus = $userenv{'inststatus'};
	$inststatus_checked = 1;
	}
	}
	}
	}
	unless ($inststatus_checked) {
	if ($reqemail =~ /^[^\@]+\@[^\@]+$/) {
	my %srch = (srchby => 'email',
	srchdomain => $defdom,
	srchterm => $reqemail,
	srchtype => 'exact');
	my %srch_results = &Apache::lonnet::usersearch(\%srch);
	foreach my $uname (keys(%srch_results)) {
	if (ref($srch_results{$uname}{'inststatus'}) eq 'ARRAY') {
	$inststatus = join(',',@{$srch_results{$uname}{'inststatus'}});
	$inststatus_checked = 1;
	last;
	}
	}
	unless ($inststatus_checked) {
	my ($dirsrchres,%srch_results) = &Apache::lonnet::inst_directory_query(\%srch);
	if ($dirsrchres eq 'ok') {
	foreach my $uname (keys(%srch_results)) {
	if (ref($srch_results{$uname}{'inststatus'}) eq 'ARRAY') {
	$inststatus = join(',',@{$srch_results{$uname}{'inststatus'}});
	$inststatus_checked = 1;
	last;
	}
	}
	}
	}
	}
	}
	if ($inststatus ne '') {
	foreach my $status (split(/\:/,$inststatus)) {
	if (ref($domconfig{'contacts'}{'overrides'}{$status}) eq 'HASH') {
	my @contacts = ('adminemail','supportemail');
	foreach my $item (@contacts) {
	if ($domconfig{'contacts'}{'overrides'}{$status}{$item}) {
	my $addr = $domconfig{'contacts'}{'overrides'}{$status};
	if (!grep(/^\Q$addr\E$/,@recipients)) {
	push(@recipients,$addr);
	}
	}
	}
	$otheremails = $domconfig{'contacts'}{'overrides'}{$status}{'others'};
	if ($domconfig{'contacts'}{'overrides'}{$status}{'bcc'}) {
	my @bccs = split(/,/,$domconfig{'contacts'}{'overrides'}{$status}{'bcc'});
	my @ok_bccs;
	foreach my $bcc (@bccs) {
	$bcc =~ s/^\s+//g;
	$bcc =~ s/\s+$//g;
	if ($bcc =~ m/^[^\@]+\@[^\@]+$/) {
	if (!(grep(/^\Q$bcc\E$/,@ok_bccs))) {
	push(@ok_bccs,$bcc);
	}
	}
	}
	if (@ok_bccs > 0) {
	$allbcc = join(', ',@ok_bccs);
	}
	}
	$addtext = $domconfig{'contacts'}{'overrides'}{$status}{'include'};
	last;
	}
	}
	}
	}
}	}
} elsif ($origmail ne '') {	} elsif ($origmail ne '') {
push(@recipients,$origmail);	$lastresort = $origmail;
	}
	if (($mailing eq 'helpdeskmail') && ($lastresort ne '')) {
	unless (grep(/^\Q$defdom\E$/,&Apache::lonnet::current_machine_domains())) {
	my $lonhost = $Apache::lonnet::perlvar{'lonHostID'};
	my $machinedom = $Apache::lonnet::perlvar{'lonDefDomain'};
	my %what = (
	perlvar => 1,
	);
	my $primary = &Apache::lonnet::domain($defdom,'primary');
	if ($primary) {
	my $gotaddr;
	my ($result,$returnhash) =
	&Apache::lonnet::get_remote_globals($primary,{ perlvar => 1 });
	if (($result eq 'ok') && (ref($returnhash) eq 'HASH')) {
	if ($returnhash->{'lonSupportEMail'} =~ /^[^\@]+\@[^\@]+$/) {
	$lastresort = $returnhash->{'lonSupportEMail'};
	$gotaddr = 1;
	}
	}
	unless ($gotaddr) {
	my $uintdom = &Apache::lonnet::internet_dom($primary);
	my $intdom = &Apache::lonnet::internet_dom($lonhost);
	unless ($uintdom eq $intdom) {
	my %domconfig =
	&Apache::lonnet::get_dom('configuration',['contacts'],$machinedom);
	if (ref($domconfig{'contacts'}) eq 'HASH') {
	if (ref($domconfig{'contacts'}{'otherdomsmail'}) eq 'HASH') {
	my @contacts = ('adminemail','supportemail');
	foreach my $item (@contacts) {
	if ($domconfig{'contacts'}{'otherdomsmail'}{$item}) {
	my $addr = $domconfig{'contacts'}{$item};
	if (!grep(/^\Q$addr\E$/,@recipients)) {
	push(@recipients,$addr);
	}
	}
	}
	if ($domconfig{'contacts'}{'otherdomsmail'}{'others'}) {
	$otheremails = $domconfig{'contacts'}{'otherdomsmail'}{'others'};
	}
	if ($domconfig{'contacts'}{'otherdomsmail'}{'bcc'}) {
	my @bccs = split(/,/,$domconfig{'contacts'}{'otherdomsmail'}{'bcc'});
	my @ok_bccs;
	foreach my $bcc (@bccs) {
	$bcc =~ s/^\s+//g;
	$bcc =~ s/\s+$//g;
	if ($bcc =~ m/^[^\@]+\@[^\@]+$/) {
	if (!(grep(/^\Q$bcc\E$/,@ok_bccs))) {
	push(@ok_bccs,$bcc);
	}
	}
	}
	if (@ok_bccs > 0) {
	$allbcc = join(', ',@ok_bccs);
	}
	}
	$addtext = $domconfig{'contacts'}{'otherdomsmail'}{'include'};
	}
	}
	}
	}
	}
	}
}	}
if (defined($defmail)) {	if (defined($defmail)) {
if ($defmail ne '') {	if ($defmail ne '') {
Line 14499 sub build_recipient_list {	Line 15211 sub build_recipient_list {
}	}
}	}
}	}
my $recipientlist = join(',',@recipients);	if ($mailing eq 'helpdeskmail') {
return $recipientlist;	if ((!@recipients) && ($lastresort ne '')) {
	push(@recipients,$lastresort);
	}
	} elsif ($lastresort ne '') {
	if (!grep(/^\Q$lastresort\E$/,@recipients)) {
	push(@recipients,$lastresort);
	}
	}
	my $recipientlist = join(',',@recipients);
	if (wantarray) {
	return ($recipientlist,$allbcc,$addtext);
	} else {
	return $recipientlist;
	}
}	}

############################################################	############################################################
Line 14520 Inputs:	Line 15245 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 14530 cc_string - Carbon copy email ad	Line 15257 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 14548 attachment_text - The body of an attac	Line 15273 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 14557 sub mime_email {	Line 15283 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 14672 jsarray (reference to array of categorie	Line 15401 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 14679 Side effects: populates trails and allit	Line 15410 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 14707 sub extract_categories {	Line 15438 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 14750 Side effects: populates trails and allit	Line 15484 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 14777 sub recurse_categories {	Line 15511 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 14807 currcat - scalar with an & separated lis	Line 15546 currcat - scalar with an & separated lis

type - scalar contains course type (Course or Community).	type - scalar contains course type (Course or Community).

	disabled - scalar (optional) contains disabled="disabled" if input elements are
	to be readonly (e.g., Domain Helpdesk role viewing course settings).

Returns: $output (markup to be displayed)	Returns: $output (markup to be displayed)

=cut	=cut

sub assign_categories_table {	sub assign_categories_table {
my ($cathash,$currcat,$type) = @_;	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 14852 sub assign_categories_table {	Line 15594 sub assign_categories_table {
}	}
$table .= '<tr '.$css_class.'><td><span class="LC_nobreak">'.	$table .= '<tr '.$css_class.'><td><span class="LC_nobreak">'.
'<input type="checkbox" name="usecategory" value="'.	'<input type="checkbox" name="usecategory" value="'.
$item.'"'.$checked.' />'.$parent_title.'</span>'.	$item.'"'.$checked.$disabled.' />'.$parent_title.'</span>'.
'<input type="hidden" name="catname" value="'.$parent.'" /></td>';	'<input type="hidden" name="catname" value="'.$parent.'" /></td>';
my $depth = 1;	my $depth = 1;
push(@path,$parent);	push(@path,$parent);
$table .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories);	$table .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories,$disabled);
pop(@path);	pop(@path);
$table .= '</tr><tr><td colspan="'.$maxdepth.'" class="LC_row_separator"></td></tr>';	$table .= '</tr><tr><td colspan="'.$maxdepth.'" class="LC_row_separator"></td></tr>';
$itemcount ++;	$itemcount ++;
Line 14895 path - Array containing all categories b	Line 15637 path - Array containing all categories b

currcategories - reference to array of current categories assigned to the course	currcategories - reference to array of current categories assigned to the course

	disabled - scalar (optional) contains disabled="disabled" if input elements are
	to be readonly (e.g., Domain Helpdesk role viewing course settings).

Returns: $output (markup to be displayed).	Returns: $output (markup to be displayed).

=cut	=cut

sub assign_category_rows {	sub assign_category_rows {
my ($itemcount,$cats,$depth,$parent,$path,$currcategories) = @_;	my ($itemcount,$cats,$depth,$parent,$path,$currcategories,$disabled) = @_;
my ($text,$name,$item,$chgstr);	my ($text,$name,$item,$chgstr);
if (ref($cats) eq 'ARRAY') {	if (ref($cats) eq 'ARRAY') {
my $maxdepth = scalar(@{$cats});	my $maxdepth = scalar(@{$cats});
Line 14923 sub assign_category_rows {	Line 15668 sub assign_category_rows {
}	}
$text .= '<tr><td><span class="LC_nobreak"><label>'.	$text .= '<tr><td><span class="LC_nobreak"><label>'.
'<input type="checkbox" name="usecategory" value="'.	'<input type="checkbox" name="usecategory" value="'.
$item.'"'.$checked.' />'.$name.'</label></span>'.	$item.'"'.$checked.$disabled.' />'.$name.'</label></span>'.
'<input type="hidden" name="catname" value="'.$name.'" />'.	'<input type="hidden" name="catname" value="'.$name.'" />'.
'</td><td>';	'</td><td>';
if (ref($path) eq 'ARRAY') {	if (ref($path) eq 'ARRAY') {
push(@{$path},$name);	push(@{$path},$name);
$text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories);	$text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories,$disabled);
pop(@{$path});	pop(@{$path});
}	}
$text .= '</td></tr>';	$text .= '</td></tr>';
Line 15139 sub check_clone {	Line 15884 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 15147 sub check_clone {	Line 15893 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'}) &&
(&Apache::lonnet::allowed('ccc',$env{'request.role.domain'}))) {	(&Apache::lonnet::allowed('ccc',$env{'request.role.domain'}))) {
$can_clone = 1;	$can_clone = 1;
} else {	} else {
Line 15245 sub check_clone {	Line 16013 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,$cnum,$category,$coderef) = @_;	my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,
my $outcome;	$cnum,$category,$coderef,$callercontext,$user_lh) = @_;
	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 15266 sub construct_course {	Line 16049 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 15300 sub construct_course {	Line 16076 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 15317 sub construct_course {	Line 16098 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 15409 sub construct_course {	Line 16204 sub construct_course {
my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$class,$cenv{'internal.courseowner'});	my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$class,$cenv{'internal.courseowner'});
$cenv{'internal.sectionnums'} .= $item.',';	$cenv{'internal.sectionnums'} .= $item.',';
unless ($addcheck eq 'ok') {	unless ($addcheck eq 'ok') {
push @badclasses, $class;	push(@badclasses,$class);
}	}
}	}
$cenv{'internal.sectionnums'} =~ s/,$//;	$cenv{'internal.sectionnums'} =~ s/,$//;
Line 15437 sub construct_course {	Line 16232 sub construct_course {
my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$xl,$cenv{'internal.courseowner'});	my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$xl,$cenv{'internal.courseowner'});
$cenv{'internal.crosslistings'} .= $item.',';	$cenv{'internal.crosslistings'} .= $item.',';
unless ($addcheck eq 'ok') {	unless ($addcheck eq 'ok') {
push @badclasses, $xl;	push(@badclasses,$xl);
}	}
}	}
$cenv{'internal.crosslistings'} =~ s/,$//;	$cenv{'internal.crosslistings'} =~ s/,$//;
Line 15472 sub construct_course {	Line 16267 sub construct_course {
}	}
if (@badclasses > 0) {	if (@badclasses > 0) {
my %lt=&Apache::lonlocal::texthash(	my %lt=&Apache::lonlocal::texthash(
'tclb' => 'The courses listed below were included as sections or crosslistings affiliated with your new LON-CAPA course. However, if automated course roster updates are enabled for this class, these particular sections/crosslistings will not contribute towards enrollment, because the user identified as the course owner for this LON-CAPA course',	'tclb' => 'The courses listed below were included as sections or crosslistings affiliated with your new LON-CAPA course.',
'dnhr' => 'does not have rights to access enrollment in these classes',	'howi' => 'However, if automated course roster updates are enabled for this class, these particular sections/crosslistings are not guaranteed to contribute towards enrollment.',
'adby' => 'as determined by the policies of your institution on access to official classlists'	'itis' => 'It is possible that rights to access enrollment for these classes will be available through assignment of co-owners.',
);	);
my $badclass_msg = $cenv{'internal.courseowner'}.') - '.$lt{'dnhr'}.	my $badclass_msg = $lt{'tclb'}.$linefeed.$lt{'howi'}.$linefeed.
' ('.$lt{'adby'}.')';	&mt('That is because the user identified as the course owner ([_1]) does not have rights to access enrollment in these classes, as determined by the policies of your institution on access to official classlists',$cenv{'internal.courseowner'}).$linefeed.$lt{'itis'};
if ($context eq 'auto') {	if ($context eq 'auto') {
$outcome .= $badclass_msg.$linefeed;	$outcome .= $badclass_msg.$linefeed;
	} else {
$outcome .= '<div class="LC_warning">'.$badclass_msg.$linefeed.'<ul>'."\n";	$outcome .= '<div class="LC_warning">'.$badclass_msg.$linefeed.'<ul>'."\n";
foreach my $item (@badclasses) {	}
if ($context eq 'auto') {	foreach my $item (@badclasses) {
$outcome .= " - $item\n";
} else {
$outcome .= "<li>$item</li>\n";
}
}
if ($context eq 'auto') {	if ($context eq 'auto') {
$outcome .= $linefeed;	$outcome .= " - $item\n";
} else {	} else {
$outcome .= "</ul><br /><br /></div>\n";	$outcome .= "<li>$item</li>\n";
}	}
	}
	if ($context eq 'auto') {
	$outcome .= $linefeed;
	} else {
	$outcome .= "</ul><br /><br /></div>\n";
}	}
}	}
if ($args->{'no_end_date'}) {	if ($args->{'no_end_date'}) {
Line 15599 sub construct_course {	Line 16395 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 15658 sub construct_course {	Line 16459 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 15742 sub group_term {	Line 16543 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 15828 sub compare_arrays {	Line 16630 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 15835 sub init_user_environment {	Line 16655 sub init_user_environment {

my $public=($username eq 'public' && $domain eq 'public');	my $public=($username eq 'public' && $domain eq 'public');

# See if old ID present, if so, remove

my ($filename,$cookie,$userroles,$firstaccenv,$timerintenv);	my ($filename,$cookie,$userroles,$firstaccenv,$timerintenv);
my $now=time;	my $now=time;

Line 15858 sub init_user_environment {	Line 16676 sub init_user_environment {
}	}
if (!$cookie) { $cookie="publicuser_$oldest"; }	if (!$cookie) { $cookie="publicuser_$oldest"; }
} else {	} else {
# if this isn't a robot, kill any existing non-robot sessions	# See if old ID present, if so, remove if this isn't a robot,
	# killing any existing non-robot sessions
if (!$args->{'robot'}) {	if (!$args->{'robot'}) {
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$/) {
unlink($lonids.'/'.$filename);	if (tie(my %oldenv,'GDBM_File',"$lonids/$filename",
	&GDBM_READER(),0640)) {
	my $linkedfile;
	if (exists($oldenv{'user.linkedenv'})) {
	$linkedfile = $oldenv{'user.linkedenv'};
	}
	untie(%oldenv);
	if (unlink("$lonids/$filename")) {
	if ($linkedfile =~ /^[a-f0-9]+_linked$/) {
	if (-l "$lonids/$linkedfile.id") {
	unlink("$lonids/$linkedfile.id");
	}
	}
	}
	} else {
	unlink($lonids.'/'.$filename);
	}
}	}
}	}
closedir(DIR);	closedir(DIR);
Line 15898 sub init_user_environment {	Line 16733 sub init_user_environment {

my %userenv = &Apache::lonnet::dump('environment',$domain,$username);	my %userenv = &Apache::lonnet::dump('environment',$domain,$username);
my ($tmp) = keys(%userenv);	my ($tmp) = keys(%userenv);
if ($tmp !~ /^(con_lost\|error\|no_such_host)/i) {	if ($tmp =~ /^(con_lost\|error\|no_such_host)/i) {
} else {
undef(%userenv);	undef(%userenv);
}	}
if (($userenv{'interface'}) && (!$form->{'interface'})) {	if (($userenv{'interface'}) && (!$form->{'interface'})) {
Line 15951 sub init_user_environment {	Line 16785 sub init_user_environment {
$env{'user.noloadbalance'} = $lonhost;	$env{'user.noloadbalance'} = $lonhost;
}	}

my %is_adv = ( is_adv => $env{'user.adv'} );	if ($form->{'noloadbalance'}) {
my %domdef;	my @hosts = &Apache::lonnet::current_machine_ids();
unless ($domain eq 'public') {	my $hosthere = $form->{'noloadbalance'};
%domdef = &Apache::lonnet::get_domain_defaults($domain);	if (grep(/^\Q$hosthere\E$/,@hosts)) {
	$initial_env{"user.noloadbalance"} = $hosthere;
	$env{'user.noloadbalance'} = $hosthere;
	}
}	}

foreach my $tool ('aboutme','blog','webdav','portfolio') {	unless ($domain eq 'public') {
$userenv{'availabletools.'.$tool} =	my %is_adv = ( is_adv => $env{'user.adv'} );
&Apache::lonnet::usertools_access($username,$domain,$tool,'reload',	my %domdef = &Apache::lonnet::get_domain_defaults($domain);
undef,\%userenv,\%domdef,\%is_adv);
}

foreach my $crstype ('official','unofficial','community','textbook','placement') {	foreach my $tool ('aboutme','blog','webdav','portfolio') {
$userenv{'canrequest.'.$crstype} =	$userenv{'availabletools.'.$tool} =
&Apache::lonnet::usertools_access($username,$domain,$crstype,	&Apache::lonnet::usertools_access($username,$domain,$tool,'reload',
'reload','requestcourses',	undef,\%userenv,\%domdef,\%is_adv);
\%userenv,\%domdef,\%is_adv);	}
}

$userenv{'canrequest.author'} =	foreach my $crstype ('official','unofficial','community','textbook','placement','lti') {
&Apache::lonnet::usertools_access($username,$domain,'requestauthor',	$userenv{'canrequest.'.$crstype} =
'reload','requestauthor',	&Apache::lonnet::usertools_access($username,$domain,$crstype,
\%userenv,\%domdef,\%is_adv);	'reload','requestcourses',
my %reqauthor = &Apache::lonnet::get('requestauthor',['author_status','author'],	\%userenv,\%domdef,\%is_adv);
$domain,$username);
my $reqstatus = $reqauthor{'author_status'};
if ($reqstatus eq 'approval' \|\| $reqstatus eq 'approved') {
if (ref($reqauthor{'author'}) eq 'HASH') {
$userenv{'requestauthorqueued'} = $reqstatus.':'.
$reqauthor{'author'}{'timestamp'};
}	}
}

	$userenv{'canrequest.author'} =
	&Apache::lonnet::usertools_access($username,$domain,'requestauthor',
	'reload','requestauthor',
	\%userenv,\%domdef,\%is_adv);
	my %reqauthor = &Apache::lonnet::get('requestauthor',['author_status','author'],
	$domain,$username);
	my $reqstatus = $reqauthor{'author_status'};
	if ($reqstatus eq 'approval' \|\| $reqstatus eq 'approved') {
	if (ref($reqauthor{'author'}) eq 'HASH') {
	$userenv{'requestauthorqueued'} = $reqstatus.':'.
	$reqauthor{'author'}{'timestamp'};
	}
	}
	my ($types,$typename) = &course_types();
	if (ref($types) eq 'ARRAY') {
	my @options = ('approval','validate','autolimit');
	my $optregex = join('\|',@options);
	my (%willtrust,%trustchecked);
	foreach my $type (@{$types}) {
	my $dom_str = $env{'environment.reqcrsotherdom.'.$type};
	if ($dom_str ne '') {
	my $updatedstr = '';
	my @possdomains = split(',',$dom_str);
	foreach my $entry (@possdomains) {
	my ($extdom,$extopt) = split(':',$entry);
	unless ($trustchecked{$extdom}) {
	$willtrust{$extdom} = &Apache::lonnet::will_trust('reqcrs',$domain,$extdom);
	$trustchecked{$extdom} = 1;
	}
	if ($willtrust{$extdom}) {
	$updatedstr .= $entry.',';
	}
	}
	$updatedstr =~ s/,$//;
	if ($updatedstr) {
	$userenv{'reqcrsotherdom.'.$type} = $updatedstr;
	} else {
	delete($userenv{'reqcrsotherdom.'.$type});
	}
	}
	}
	}
	}
$env{'user.environment'} = "$lonids/$cookie.id";	$env{'user.environment'} = "$lonids/$cookie.id";

if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id",	if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id",
Line 16600 sub search_courses {	Line 17470 sub search_courses {
if (ref($courses{$cid}) eq 'HASH') {	if (ref($courses{$cid}) eq 'HASH') {
if (ref($courses{$cid}{roles}) eq 'ARRAY') {	if (ref($courses{$cid}{roles}) eq 'ARRAY') {
if (!grep(/^\Q$courserole\E$/,@{$courses{$cid}{roles}})) {	if (!grep(/^\Q$courserole\E$/,@{$courses{$cid}{roles}})) {
push (@{$courses{$cid}{roles}},$courserole);	push(@{$courses{$cid}{roles}},$courserole);
}	}
} else {	} else {
$courses{$cid}{roles} = [$courserole];	$courses{$cid}{roles} = [$courserole];
Line 16796 sub needs_coursereinit {	Line 17666 sub needs_coursereinit {
$interval = 600;	$interval = 600;
}	}
if (($now-$env{'request.course.timechecked'})>$interval) {	if (($now-$env{'request.course.timechecked'})>$interval) {
my $lastchange = &Apache::lonnet::get_coursechange($cdom,$cnum);
&Apache::lonnet::appenv({'request.course.timechecked'=>$now});	&Apache::lonnet::appenv({'request.course.timechecked'=>$now});
	my $blocked = &blocking_status('reinit',$cnum,$cdom,undef,1);
	if ($blocked) {
	return ();
	}
	my $lastchange = &Apache::lonnet::get_coursechange($cdom,$cnum);
if ($lastchange > $env{'request.course.tied'}) {	if ($lastchange > $env{'request.course.tied'}) {
my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired');	my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired');
if ($curr_reqd_hash{'internal.releaserequired'} ne '') {	if ($curr_reqd_hash{'internal.releaserequired'} ne '') {
Line 16820 sub needs_coursereinit {	Line 17694 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;	my (%checkresponsetypes,%checkcrsrestypes);
foreach my $key (keys(%Apache::lonnet::needsrelease)) {	foreach my $key (keys(%Apache::lonnet::needsrelease)) {
my ($item,$name,$value) = split(/:/,$key);	my ($item,$name,$value) = split(/:/,$key);
if ($item eq 'resourcetag') {	if ($item eq 'resourcetag') {
if ($name eq 'responsetype') {	if ($name eq 'responsetype') {
$checkresponsetypes{$value} = $Apache::lonnet::needsrelease{$key}	$checkresponsetypes{$value} = $Apache::lonnet::needsrelease{$key}
}	}
	} elsif ($item eq 'course') {
	if ($name eq 'courserestype') {
	$checkcrsrestypes{$value} = $Apache::lonnet::needsrelease{$key};
	}
}	}
}	}
my $navmap = Apache::lonnavmaps::navmap->new();	my $navmap = Apache::lonnavmaps::navmap->new();
if (defined($navmap)) {	if (defined($navmap)) {
my %allresponses;	my (%allresponses,%allcrsrestypes);
foreach my $res ($navmap->retrieveResources(undef,sub { $_[0]->is_problem() },1,0)) {	foreach my $res ($navmap->retrieveResources(undef,sub { $_[0]->is_problem() \|\| $_[0]->is_tool() },1,0)) {
	if ($res->is_tool()) {
	if ($allcrsrestypes{'exttool'}) {
	$allcrsrestypes{'exttool'} ++;
	} else {
	$allcrsrestypes{'exttool'} = 1;
	}
	next;
	}
my %responses = $res->responseTypes();	my %responses = $res->responseTypes();
foreach my $key (keys(%responses)) {	foreach my $key (keys(%responses)) {
next unless(exists($checkresponsetypes{$key}));	next unless(exists($checkresponsetypes{$key}));
Line 16848 sub update_content_constraints {	Line 17734 sub update_content_constraints {
($reqdmajor,$reqdminor) = ($major,$minor);	($reqdmajor,$reqdminor) = ($major,$minor);
}	}
}	}
	foreach my $key (keys(%allcrsrestypes)) {
	my ($major,$minor) = split(/\./,$checkcrsrestypes{$key});
	if (($major > $reqdmajor) \|\| ($major == $reqdmajor && $minor > $reqdminor)) {
	($reqdmajor,$reqdminor) = ($major,$minor);
	}
	}
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 ($suppcount,$supptools,$errors) = (0,0,0);
	($suppcount,$supptools,$errors) = &recurse_supplemental($cnum,$cdom,$suppmap,
	$suppcount,$supptools,$errors);
	if ($keeporder) {
	@LONCAPA::map::resources = @resources;
	@LONCAPA::map::order = @order;
	@LONCAPA::map::resparms = @resparms;
	@LONCAPA::map::zombies = @zombies;
	}
	if ($supptools) {
	my ($major,$minor) = split(/\./,$checkcrsrestypes{'exttool'});
	if (($major > $reqdmajor) \|\| ($major == $reqdmajor && $minor > $reqdminor)) {
	($reqdmajor,$reqdminor) = ($major,$minor);
	}
	}
unless (($reqdmajor eq '') && ($reqdminor eq '')) {	unless (($reqdmajor eq '') && ($reqdminor eq '')) {
&Apache::lonnet::update_released_required($reqdmajor.'.'.$reqdminor,$cdom,$cnum,$chome,$cid);	&Apache::lonnet::update_released_required($reqdmajor.'.'.$reqdminor,$cdom,$cnum,$chome,$cid);
}	}
Line 16870 sub allmaps_incourse {	Line 17786 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 16906 sub parse_supplemental_title {	Line 17822 sub parse_supplemental_title {
}	}

sub recurse_supplemental {	sub recurse_supplemental {
my ($cnum,$cdom,$suppmap,$numfiles,$errors) = @_;	my ($cnum,$cdom,$suppmap,$numfiles,$numexttools,$errors) = @_;
if ($suppmap) {	if ($suppmap) {
my ($errtext,$fatal) = &LONCAPA::map::mapread('/uploaded/'.$cdom.'/'.$cnum.'/'.$suppmap);	my ($errtext,$fatal) = &LONCAPA::map::mapread('/uploaded/'.$cdom.'/'.$cnum.'/'.$suppmap);
if ($fatal) {	if ($fatal) {
Line 16917 sub recurse_supplemental {	Line 17833 sub recurse_supplemental {
my ($title,$src,$ext,$type,$status)=split(/\:/,$res);	my ($title,$src,$ext,$type,$status)=split(/\:/,$res);
if (($src ne '') && ($status eq 'res')) {	if (($src ne '') && ($status eq 'res')) {
if ($src =~ m{^\Q/uploaded/$cdom/$cnum/\E(supplemental_\d+\.sequence)$}) {	if ($src =~ m{^\Q/uploaded/$cdom/$cnum/\E(supplemental_\d+\.sequence)$}) {
($numfiles,$errors) = &recurse_supplemental($cnum,$cdom,$1,$numfiles,$errors);	($numfiles,$numexttools,$errors) = &recurse_supplemental($cnum,$cdom,$1,
	$numfiles,$numexttools,$errors);
} else {	} else {
	if ($src =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
	$numexttools ++;
	}
$numfiles ++;	$numfiles ++;
}	}
}	}
Line 16926 sub recurse_supplemental {	Line 17846 sub recurse_supplemental {
}	}
}	}
}	}
return ($numfiles,$errors);	return ($numfiles,$numexttools,$errors);
}	}

sub symb_to_docspath {	sub symb_to_docspath {
my ($symb) = @_;	my ($symb,$navmapref) = @_;
return unless ($symb);	return unless ($symb && ref($navmapref));
my ($mapurl,$id,$resurl) = &Apache::lonnet::decode_symb($symb);	my ($mapurl,$id,$resurl) = &Apache::lonnet::decode_symb($symb);
if ($resurl=~/\.(sequence\|page)$/) {	if ($resurl=~/\.(sequence\|page)$/) {
$mapurl=$resurl;	$mapurl=$resurl;
Line 16939 sub symb_to_docspath {	Line 17859 sub symb_to_docspath {
$mapurl=$env{'course.'.$env{'request.course.id'}.'.url'};	$mapurl=$env{'course.'.$env{'request.course.id'}.'.url'};
}	}
my $mapresobj;	my $mapresobj;
my $navmap = Apache::lonnavmaps::navmap->new();	unless (ref($$navmapref)) {
if (ref($navmap)) {	$$navmapref = Apache::lonnavmaps::navmap->new();
$mapresobj = $navmap->getResourceByUrl($mapurl);	}
	if (ref($$navmapref)) {
	$mapresobj = $$navmapref->getResourceByUrl($mapurl);
}	}
$mapurl=~s{^.*/([^/]+)\.(\w+)$}{$1};	$mapurl=~s{^.*/([^/]+)\.(\w+)$}{$1};
my $type=$2;	my $type=$2;
Line 16951 sub symb_to_docspath {	Line 17873 sub symb_to_docspath {
if ($pcslist ne '') {	if ($pcslist ne '') {
foreach my $pc (split(/,/,$pcslist)) {	foreach my $pc (split(/,/,$pcslist)) {
next if ($pc <= 1);	next if ($pc <= 1);
my $res = $navmap->getByMapPc($pc);	my $res = $$navmapref->getByMapPc($pc);
if (ref($res)) {	if (ref($res)) {
my $thisurl = $res->src();	my $thisurl = $res->src();
$thisurl=~s{^.*/([^/]+)\.\w+$}{$1};	$thisurl=~s{^.*/([^/]+)\.\w+$}{$1};
Line 16998 sub symb_to_docspath {	Line 17920 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 17017 sub captcha_display {	Line 17939 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 17031 sub captcha_response {	Line 17953 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 17079 sub get_captcha_config {	Line 18001 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 17103 sub create_captcha {	Line 18046 sub create_captcha {
last;	last;
}	}
}	}
	if ($output eq '') {
	&Apache::lonnet::logthis("Failed to create Captcha code after $tries attempts.");
	}
return $output;	return $output;
}	}

Line 17160 sub check_recaptcha {	Line 18106 sub check_recaptcha {
my ($privkey,$version) = @_;	my ($privkey,$version) = @_;
my $captcha_chk;	my $captcha_chk;
if ($version >= 2) {	if ($version >= 2) {
my $ua = LWP::UserAgent->new;
$ua->timeout(10);
my %info = (	my %info = (
secret => $privkey,	secret => $privkey,
response => $env{'form.g-recaptcha-response'},	response => $env{'form.g-recaptcha-response'},
remoteip => $ENV{'REMOTE_ADDR'},	remoteip => $ENV{'REMOTE_ADDR'},
);	);
my $response = $ua->post('https://www.google.com/recaptcha/api/siteverify',\%info);	my $request=new HTTP::Request('POST','https://www.google.com/recaptcha/api/siteverify');
	$request->content(join('&',map {
	my $name = escape($_);
	"$name=" . ( ref($info{$_}) eq 'ARRAY'
	? join("&$name=", map {escape($_) } @{$info{$_}})
	: &escape($info{$_}) );
	} keys(%info)));
	my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10,1);
if ($response->is_success) {	if ($response->is_success) {
my $data = JSON::DWIW->from_json($response->decoded_content);	my $data = JSON::DWIW->from_json($response->decoded_content);
if (ref($data) eq 'HASH') {	if (ref($data) eq 'HASH') {
Line 17230 sub cleanup_html {	Line 18181 sub cleanup_html {

# Checks for critical messages and returns a redirect url if one exists.	# Checks for critical messages and returns a redirect url if one exists.
# $interval indicates how often to check for messages.	# $interval indicates how often to check for messages.
	# $context is the calling context -- roles, grades, contents, menu or flip.
sub critical_redirect {	sub critical_redirect {
my ($interval) = @_;	my ($interval,$context) = @_;
if ((time-$env{'user.criticalcheck.time'})>$interval) {	if ((time-$env{'user.criticalcheck.time'})>$interval) {
	if (($env{'request.course.id'}) && (($context eq 'flip') \|\| ($context eq 'contents'))) {
	my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
	my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
	my $blocked = &blocking_status('alert',$cnum,$cdom,undef,1);
	if ($blocked) {
	my $checkrole = "cm./$cdom/$cnum";
	if ($env{'request.course.sec'} ne '') {
	$checkrole .= "/$env{'request.course.sec'}";
	}
	unless ((&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) &&
	($env{'request.role'} !~ m{^st\./$cdom/$cnum})) {
	return;
	}
	}
	}
my @what=&Apache::lonnet::dump('critical', $env{'user.domain'},	my @what=&Apache::lonnet::dump('critical', $env{'user.domain'},
$env{'user.name'});	$env{'user.name'});
&Apache::lonnet::appenv({'user.criticalcheck.time'=>time});	&Apache::lonnet::appenv({'user.criticalcheck.time'=>time});
Line 17298 sub des_decrypt {	Line 18265 sub des_decrypt {
return $plaintext;	return $plaintext;
}	}

	sub get_requested_shorturls {
	my ($cdom,$cnum,$navmap) = @_;
	return unless (ref($navmap));
	my ($numnew,$errors);
	my @toshorten = &Apache::loncommon::get_env_multiple('form.addtiny');
	if (@toshorten) {
	my (%maps,%resources,%titles);
	&Apache::loncourserespicker::enumerate_course_contents($navmap,\%maps,\%resources,\%titles,
	'shorturls',$cdom,$cnum);
	if (keys(%resources)) {
	my %tocreate;
	foreach my $item (sort {$a <=> $b} (@toshorten)) {
	my $symb = $resources{$item};
	if ($symb) {
	$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)) {
	my %coursetiny = &Apache::lonnet::dump('tiny',$cdom,$cnum);
	my $su = Short::URL->new(no_vowels => 1);
	my $init = '';
	my (%newunique,%addcourse,%courseonly,%failed);
	# get lock on tiny db
	my $now = time;
	if ($lockuser eq '') {
	$lockuser = $env{'user.name'}.':'.$env{'user.domain'};
	}
	my $lockhash = {
	"lock\0$now" => $lockuser,
	};
	my $tries = 0;
	my $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom);
	my ($code,$error);
	while (($gotlock ne 'ok') && ($tries<3)) {
	$tries ++;
	sleep 1;
	$gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom);
	}
	if ($gotlock eq 'ok') {
	$init = &shorten_symbs($cdom,$init,$su,\%coursetiny,\%tocreate,\%newunique,
	\%addcourse,\%courseonly,\%failed);
	if (keys(%failed)) {
	my $numfailed = scalar(keys(%failed));
	push(@errors,&mt('error: could not obtain unique six character URL for [quant,_1,resource]',$numfailed));
	}
	if (keys(%newunique)) {
	my $putres = &Apache::lonnet::newput_dom('tiny',\%newunique,$cdom);
	if ($putres eq 'ok') {
	$numnew = scalar(keys(%newunique));
	my $newputres = &Apache::lonnet::newput('tiny',\%addcourse,$cdom,$cnum);
	unless ($newputres eq 'ok') {
	push(@errors,&mt('error: could not store course look-up of short URLs'));
	}
	} else {
	push(@errors,&mt('error: could not store unique six character URLs'));
	}
	}
	my $dellockres = &Apache::lonnet::del_dom('tiny',["lock\0$now"],$cdom);
	unless ($dellockres eq 'ok') {
	push(@errors,&mt('error: could not release lockfile'));
	}
	} else {
	push(@errors,&mt('error: could not obtain lockfile'));
	}
	if (keys(%courseonly)) {
	my $result = &Apache::lonnet::newput('tiny',\%courseonly,$cdom,$cnum);
	if ($result ne 'ok') {
	push(@errors,&mt('error: could not update course look-up of short URLs'));
	}
	}
	}
	}
	return ($numnew,\@errors);
	}

	sub shorten_symbs {
	my ($cdom,$init,$su,$coursetiny,$tocreate,$newunique,$addcourse,$courseonly,$failed) = @_;
	return unless ((ref($su)) && (ref($coursetiny) eq 'HASH') && (ref($tocreate) eq 'HASH') &&
	(ref($newunique) eq 'HASH') && (ref($addcourse) eq 'HASH') &&
	(ref($courseonly) eq 'HASH') && (ref($failed) eq 'HASH'));
	my (%possibles,%collisions);
	foreach my $key (keys(%{$tocreate})) {
	my $num = String::CRC32::crc32($key);
	my $tiny = $su->encode($num,$init);
	if ($tiny) {
	$possibles{$tiny} = $key;
	}
	}
	if (!$init) {
	$init = 1;
	} else {
	$init ++;
	}
	if (keys(%possibles)) {
	my @posstiny = keys(%possibles);
	my $configuname = &Apache::lonnet::get_domainconfiguser($cdom);
	my %currtiny = &Apache::lonnet::get('tiny',\@posstiny,$cdom,$configuname);
	if (keys(%currtiny)) {
	foreach my $key (keys(%currtiny)) {
	next if ($currtiny{$key} eq '');
	if ($currtiny{$key} eq $possibles{$key}) {
	my ($tcnum,$tsymb) = split(/\&/,$currtiny{$key});
	unless (($coursetiny->{$tsymb} eq $key) \|\| ($addcourse->{$tsymb} eq $key) \|\| ($courseonly->{$tsymb} eq $key)) {
	$courseonly->{$tsymb} = $key;
	}
	} else {
	$collisions{$possibles{$key}} = 1;
	}
	delete($possibles{$key});
	}
	}
	foreach my $key (keys(%possibles)) {
	$newunique->{$key} = $possibles{$key};
	my ($tcnum,$tsymb) = split(/\&/,$possibles{$key});
	unless (($coursetiny->{$tsymb} eq $key) \|\| ($addcourse->{$tsymb} eq $key) \|\| ($courseonly->{$tsymb} eq $key)) {
	$addcourse->{$tsymb} = $key;
	}
	}
	}
	if (keys(%collisions)) {
	if ($init <5) {
	if (!$init) {
	$init = 1;
	} else {
	$init ++;
	}
	$init = &shorten_symbs($cdom,$init,$su,$coursetiny,\%collisions,
	$newunique,$addcourse,$courseonly,$failed);
	} else {
	foreach my $key (keys(%collisions)) {
	$failed->{$key} = 1;
	}
	}
	}
	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.1255
changed lines
	Added in v.1.1348