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.1075.2.94 and 1.1075.2.141.2.16

version 1.1075.2.94, 2015/05/11 16:07:35	version 1.1075.2.141.2.16, 2021/06/20 18:30:11
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 HTTP::Request;
use DateTime::TimeZone;	use DateTime::TimeZone;
use DateTime::Locale::Catalog;	use DateTime::Locale;
use Encode();	use Encode();
use Authen::Captcha;	use Authen::Captcha;
use Captcha::reCAPTCHA;	use Captcha::reCAPTCHA;
	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 File::Copy();
	use File::Path();
	use String::CRC32();
	use Short::URL();

# ---------------------------------------------- Designs	# ---------------------------------------------- Designs
use vars qw(%defaultdesign);	use vars qw(%defaultdesign);
Line 192 BEGIN {	Line 199 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 213 BEGIN {	Line 220 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 227 BEGIN {	Line 234 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 241 BEGIN {	Line 248 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 255 BEGIN {	Line 262 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 270 BEGIN {	Line 277 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 423 sub studentbrowser_javascript {	Line 430 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 438 sub studentbrowser_javascript {	Line 445 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 470 ENDRESBRW	Line 482 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 481 sub selectstudent_link {	Line 493 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 533 ENDAUTHORBRW	Line 549 ENDAUTHORBRW

sub coursebrowser_javascript {	sub coursebrowser_javascript {
my ($domainfilter,$sec_element,$formname,$role_element,$crstype,	my ($domainfilter,$sec_element,$formname,$role_element,$crstype,
$credits_element) = @_;	$credits_element,$instcode) = @_;
my $wintitle = 'Course_Browser';	my $wintitle = 'Course_Browser';
if ($crstype eq 'Community') {	if ($crstype eq 'Community') {
$wintitle = 'Community_Browser';	$wintitle = 'Community_Browser';
Line 584 sub coursebrowser_javascript {	Line 600 sub coursebrowser_javascript {
var ownername = document.forms[formid].ccuname.value;	var ownername = document.forms[formid].ccuname.value;
var ownerdom = document.forms[formid].ccdomain.options[document.forms[formid].ccdomain.selectedIndex].value;	var ownerdom = document.forms[formid].ccdomain.options[document.forms[formid].ccdomain.selectedIndex].value;
url += '&cloner='+ownername+':'+ownerdom;	url += '&cloner='+ownername+':'+ownerdom;
	if (type == 'Course') {
	url += '&crscode='+document.forms[formid].crscode.value;
	}
	}
	if (formname == 'requestcrs') {
	url += '&crsdom=$domainfilter&crscode=$instcode';
}	}
if (multflag !=null && multflag != '') {	if (multflag !=null && multflag != '') {
url += '&multiple='+multflag;	url += '&multiple='+multflag;
Line 928 ENDSCRT	Line 950 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 950 sub select_timezone {	Line 972 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 959 sub select_datelocale {	Line 981 sub select_datelocale {
}	}
$output .= '> </option>';	$output .= '> </option>';
}	}
	my @languages = &Apache::lonlocal::preferred_languages();
my (@possibles,%locale_names);	my (@possibles,%locale_names);
my @locales = DateTime::Locale::Catalog::Locales;	my @locales = DateTime::Locale->ids();
foreach my $locale (@locales) {	foreach my $id (@locales) {
if (ref($locale) eq 'HASH') {	if ($id ne '') {
my $id = $locale->{'id'};	my ($en_terr,$native_terr);
if ($id ne '') {	my $loc = DateTime::Locale->load($id);
my $en_terr = $locale->{'en_territory'};	if (ref($loc)) {
my $native_terr = $locale->{'native_territory'};	$en_terr = $loc->name();
my @languages = &Apache::lonlocal::preferred_languages();	$native_terr = $loc->native_name();
if (grep(/^en$/,@languages) \|\| !@languages) {	if (grep(/^en$/,@languages) \|\| !@languages) {
if ($en_terr ne '') {	if ($en_terr ne '') {
$locale_names{$id} = '('.$en_terr.')';	$locale_names{$id} = '('.$en_terr.')';
Line 982 sub select_datelocale {	Line 1005 sub select_datelocale {
}	}
}	}
$locale_names{$id} = Encode::encode('UTF-8',$locale_names{$id});	$locale_names{$id} = Encode::encode('UTF-8',$locale_names{$id});
push (@possibles,$id);	push(@possibles,$id);
}	}
}	}
}	}
Line 1002 sub select_datelocale {	Line 1025 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 1014 sub select_language {	Line 1037 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 1129 sub linked_select_forms {	Line 1152 sub linked_select_forms {
$result.="select2data.d_$s1.texts = new Array(";	$result.="select2data.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 1392 sub help_menu_js {	Line 1415 sub help_menu_js {
&Apache::loncommon::start_page('Help Menu', undef,	&Apache::loncommon::start_page('Help Menu', undef,
{'frameset' => 1,	{'frameset' => 1,
'js_ready' => 1,	'js_ready' => 1,
'use_absolute' => $httphost,	'use_absolute' => $httphost,
'add_entries' => {	'add_entries' => {
'border' => '0',	'border' => '0',
'rows' => "110,*",},});	'rows' => "110,*",},});
Line 1735 RESIZE	Line 1758 RESIZE

}	}

	sub colorfuleditor_js {
	return <<"COLORFULEDIT"
	<script type="text/javascript">
	// <![CDATA[>
	function fold_box(curDepth, lastresource){

	// we need a list because there can be several blocks you need to fold in one tag
	var block = document.getElementsByName('foldblock_'+curDepth);
	// but there is only one folding button per tag
	var foldbutton = document.getElementById('folding_btn_'+curDepth);

	if(block.item(0).style.display == 'none'){

	foldbutton.value = '@{[&mt("Hide")]}';
	for (i = 0; i < block.length; i++){
	block.item(i).style.display = '';
	}
	}else{

	foldbutton.value = '@{[&mt("Show")]}';
	for (i = 0; i < block.length; i++){
	// block.item(i).style.visibility = 'collapse';
	block.item(i).style.display = 'none';
	}
	};
	saveState(lastresource);
	}

	function saveState (lastresource) {

	var tag_list = getTagList();
	if(tag_list != null){
	var timestamp = new Date().getTime();
	var key = lastresource;

	// the value pattern is: 'time;key1,value1;key2,value2; ... '
	// starting with timestamp
	var value = timestamp+';';

	// building the list of key-value pairs
	for(var i = 0; i < tag_list.length; i++){
	value += tag_list[i]+',';
	value += document.getElementsByName(tag_list[i])[0].style.display+';';
	}

	// only iterate whole storage if nothing to override
	if(localStorage.getItem(key) == null){

	// prevent storage from growing large
	if(localStorage.length > 50){
	var regex_getTimestamp = /^(?:\d)+;/;
	var oldest_timestamp = regex_getTimestamp.exec(localStorage.key(0));
	var oldest_key;

	for(var i = 1; i < localStorage.length; i++){
	if (regex_getTimestamp.exec(localStorage.key(i)) < oldest_timestamp) {
	oldest_key = localStorage.key(i);
	oldest_timestamp = regex_getTimestamp.exec(oldest_key);
	}
	}
	localStorage.removeItem(oldest_key);
	}
	}
	localStorage.setItem(key,value);
	}
	}

	// restore folding status of blocks (on page load)
	function restoreState (lastresource) {
	if(localStorage.getItem(lastresource) != null){
	var key = lastresource;
	var value = localStorage.getItem(key);
	var regex_delTimestamp = /^\d+;/;

	value.replace(regex_delTimestamp, '');

	var valueArr = value.split(';');
	var pairs;
	var elements;
	for (var i = 0; i < valueArr.length; i++){
	pairs = valueArr[i].split(',');
	elements = document.getElementsByName(pairs[0]);

	for (var j = 0; j < elements.length; j++){
	elements[j].style.display = pairs[1];
	if (pairs[1] == "none"){
	var regex_id = /([_\\d]+)\$/;
	regex_id.exec(pairs[0]);
	document.getElementById("folding_btn"+RegExp.\$1).value = "Show";
	}
	}
	}
	}
	}

	function getTagList () {

	var stringToSearch = document.lonhomework.innerHTML;

	var ret = new Array();
	var regex_findBlock = /(foldblock_.*?)"/g;
	var tag_list = stringToSearch.match(regex_findBlock);

	if(tag_list != null){
	for(var i = 0; i < tag_list.length; i++){
	ret.push(tag_list[i].replace(/"/, ''));
	}
	}
	return ret;
	}

	function saveScrollPosition (resource) {
	var tag_list = getTagList();

	// we dont always want to jump to the first block
	// 170 is roughly above the "Problem Editing" header. we just want to save if the user scrolled down further than this
	if(\$(window).scrollTop() > 170){
	if(tag_list != null){
	var result;
	for(var i = 0; i < tag_list.length; i++){
	if(isElementInViewport(tag_list[i])){
	result += tag_list[i]+';';
	}
	}
	sessionStorage.setItem('anchor_'+resource, result);
	}
	} else {
	// we dont need to save zero, just delete the item to leave everything tidy
	sessionStorage.removeItem('anchor_'+resource);
	}
	}

	function restoreScrollPosition(resource){

	var elem = sessionStorage.getItem('anchor_'+resource);
	if(elem != null){
	var tag_list = elem.split(';');
	var elem_list;

	for(var i = 0; i < tag_list.length; i++){
	elem_list = document.getElementsByName(tag_list[i]);

	if(elem_list.length > 0){
	elem = elem_list[0];
	break;
	}
	}
	elem.scrollIntoView();
	}
	}

	function isElementInViewport(el) {

	// change to last element instead of first
	var elem = document.getElementsByName(el);
	var rect = elem[0].getBoundingClientRect();

	return (
	rect.top >= 0 &&
	rect.left >= 0 &&
	rect.bottom <= (window.innerHeight \|\| document.documentElement.clientHeight) && /or $(window).height() /
	rect.right <= (window.innerWidth \|\| document.documentElement.clientWidth) /or $(window).width() /
	);
	}

	function autosize(depth){
	var cmInst = window['cm'+depth];
	var fitsizeButton = document.getElementById('fitsize'+depth);

	// is fixed size, switching to dynamic
	if (sessionStorage.getItem("autosized_"+depth) == null) {
	cmInst.setSize("","auto");
	fitsizeButton.value = "@{[&mt('Fixed size')]}";
	sessionStorage.setItem("autosized_"+depth, "yes");

	// is dynamic size, switching to fixed
	} else {
	cmInst.setSize("","300px");
	fitsizeButton.value = "@{[&mt('Dynamic size')]}";
	sessionStorage.removeItem("autosized_"+depth);
	}
	}



	// ]]>
	</script>
	COLORFULEDIT
	}

	sub xmleditor_js {
	return <<XMLEDIT
	<script type="text/javascript" src="/adm/jQuery/addons/jquery-scrolltofixed.js"></script>
	<script type="text/javascript">
	// <![CDATA[>

	function saveScrollPosition (resource) {

	var scrollPos = \$(window).scrollTop();
	sessionStorage.setItem(resource,scrollPos);
	}

	function restoreScrollPosition(resource){

	var scrollPos = sessionStorage.getItem(resource);
	\$(window).scrollTop(scrollPos);
	}

	// unless internet explorer
	if (!(window.navigator.appName == "Microsoft Internet Explorer" && (document.documentMode \|\| document.compatMode))){

	\$(document).ready(function() {
	\$(".LC_edit_actionbar").scrollToFixed(\{zIndex: 100\});
	});
	}

	// inserts text at cursor position into codemirror (xml editor only)
	function insertText(text){
	cm.focus();
	var curPos = cm.getCursor();
	cm.replaceRange(text.replace(/ESCAPEDSCRIPT/g,'script'), {line: curPos.line,ch: curPos.ch});
	}
	// ]]>
	</script>
	XMLEDIT
	}

	sub insert_folding_button {
	my $curDepth = $Apache::lonxml::curdepth;
	my $lastresource = $env{'request.ambiguous'};

	return "<input type=\"button\" id=\"folding_btn_$curDepth\"
	value=\"".&mt('Hide')."\" onclick=\"fold_box('$curDepth','$lastresource')\">";
	}


=pod	=pod

=head1 Excel and CSV file utility routines	=head1 Excel and CSV file utility routines
Line 1994 sub multiple_select_form {	Line 2253 sub multiple_select_form {

=pod	=pod

=item * &select_form($defdom,$name,$hashref,$onchange)	=item * &select_form($defdom,$name,$hashref,$onchange,$readonly)

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 options from a ref to a hash containing:	allow a user to select options from a ref to a hash containing:
option_name => displayed text. An optional $onchange can include	option_name => displayed text. An optional $onchange can include
a javascript onchange item, e.g., onchange="this.form.submit();"	a javascript onchange item, e.g., onchange="this.form.submit();".
	An optional arg -- $readonly -- if true will cause the select form
	to be disabled, e.g., for the case where an instructor has a section-
	specific role, and is viewing/modifying parameters.

See lonrights.pm for an example invocation and use.	See lonrights.pm for an example invocation and use.

Line 2007 See lonrights.pm for an example invocati	Line 2269 See lonrights.pm for an example invocati

#-------------------------------------------	#-------------------------------------------
sub select_form {	sub select_form {
my ($def,$name,$hashref,$onchange) = @_;	my ($def,$name,$hashref,$onchange,$readonly) = @_;
return unless (ref($hashref) eq 'HASH');	return unless (ref($hashref) eq 'HASH');
if ($onchange) {	if ($onchange) {
$onchange = ' onchange="'.$onchange.'"';	$onchange = ' onchange="'.$onchange.'"';
}	}
my $selectform = "<select name=\"$name\" size=\"1\"$onchange>\n";	my $disabled;
	if ($readonly) {
	$disabled = ' disabled="disabled"';
	}
	my $selectform = "<select name=\"$name\" size=\"1\"$onchange$disabled>\n";
my @keys;	my @keys;
if (exists($hashref->{'select_form_order'})) {	if (exists($hashref->{'select_form_order'})) {
@keys=@{$hashref->{'select_form_order'}};	@keys=@{$hashref->{'select_form_order'}};
Line 2181 sub select_level_form {	Line 2447 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 2196 The optional $onchange argument specifie	Line 2462 The optional $onchange argument specifie

The optional $incdoms is a reference to an array of domains which will be the only available options.	The optional $incdoms is a reference to an array of domains which will be the only available options.

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 2216 sub select_dom_form {	Line 2487 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 2592 sub authform_kerberos {	Line 2863 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 2643 sub authform_kerberos {	Line 2917 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 2652 sub authform_kerberos {	Line 2926 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 2665 sub authform_kerberos {	Line 2939 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 2676 sub authform_kerberos {	Line 2950 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 2686 sub authform_kerberos {	Line 2960 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 2699 sub authform_internal {	Line 2973 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 2729 sub authform_internal {	Line 3006 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 2737 sub authform_internal {	Line 3014 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 2754 sub authform_local {	Line 3031 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 2784 sub authform_local {	Line 3064 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 2793 sub authform_local {	Line 3073 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 2808 sub authform_filesystem {	Line 3088 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 2835 sub authform_filesystem {	Line 3118 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 2844 sub authform_filesystem {	Line 3127 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="text" 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><input type="radio" name="login" value="fsys" '.
$fsyscheck.'onchange="'.$jscall.'" onclick="'.$jscall.'" />',	$fsyscheck.'onchange="'.$jscall.'" onclick="'.$jscall.'"'.$disabled.' />',
'</label><input type="password" size="10" name="fsysarg" value="" '.	'</label><input type="password" size="10" name="fsysarg" value="" '.
'onchange="'.$jscall.'" />');	'onchange="'.$jscall.'"'.$disabled.' />');
return $result;	return $result;
}	}

Line 2875 sub get_assignable_auth {	Line 3158 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 2899 sub get_assignable_auth {	Line 3182 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 4069 sub get_student_view_with_retries {	Line 4425 sub get_student_view_with_retries {
}	}
}	}

	sub css_links {
	my ($currsymb,$level) = @_;
	my ($links,@symbs,%cssrefs,%httpref);
	if ($level eq 'map') {
	my $navmap = Apache::lonnavmaps::navmap->new();
	if (ref($navmap)) {
	my ($map,undef,$url)=&Apache::lonnet::decode_symb($currsymb);
	my @resources = $navmap->retrieveResources($map,sub { $_[0]->is_problem() },0,0);
	foreach my $res (@resources) {
	if (ref($res) && $res->symb()) {
	push(@symbs,$res->symb());
	}
	}
	}
	} else {
	@symbs = ($currsymb);
	}
	foreach my $symb (@symbs) {
	my $css_href = &Apache::lonnet::EXT('resource.0.cssfile',$symb);
	if ($css_href =~ /\S/) {
	unless ($css_href =~ m{https?://}) {
	my $url = (&Apache::lonnet::decode_symb($symb))[-1];
	my $proburl = &Apache::lonnet::clutter($url);
	my ($probdir) = ($proburl =~ m{(.+)/[^/]+$});
	unless ($css_href =~ m{^/}) {
	$css_href = &Apache::lonnet::hreflocation($probdir,$css_href);
	}
	if ($css_href =~ m{^/(res\|uploaded)/}) {
	unless (($httpref{'httpref.'.$css_href}) \|\|
	(&Apache::lonnet::is_on_map($css_href))) {
	my $thisurl = $proburl;
	if ($env{'httpref.'.$proburl}) {
	$thisurl = $env{'httpref.'.$proburl};
	}
	$httpref{'httpref.'.$css_href} = $thisurl;
	}
	}
	}
	$cssrefs{$css_href} = 1;
	}
	}
	if (keys(%httpref)) {
	&Apache::lonnet::appenv(\%httpref);
	}
	if (keys(%cssrefs)) {
	foreach my $css_href (keys(%cssrefs)) {
	next unless ($css_href =~ m{^(/res/\|/uploaded/\|https?://)});
	$links .= '<link rel="stylesheet" type="text/css" href="'.$css_href.'" />'."\n";
	}
	}
	return $links;
	}

=pod	=pod

=item * &get_student_answers()	=item * &get_student_answers()
Line 4324 sub findallcourses {	Line 4733 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 4347 sub blockcheck {	Line 4756 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 4431 sub blockcheck {	Line 4842 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 4453 sub blockcheck {	Line 4864 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 4477 sub blockcheck {	Line 4888 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 4490 sub get_blocks {	Line 4901 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 4612 sub parse_block_record {	Line 5029 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 4628 sub blocking_status {	Line 5045 sub blocking_status {

# build a link to a popup window containing the details	# build a link to a popup window containing the details
my $querystring = "?activity=$activity";	my $querystring = "?activity=$activity";
# $uname and $udom decide whose portfolio the user is trying to look at	# $uname and $udom decide whose portfolio (or information page) the user is trying to look at
if ($activity eq 'port') {	if (($activity eq 'port') \|\| ($activity eq 'about') \|\| ($activity eq 'passwd')) {
$querystring .= "&udom=$udom" if $udom;	$querystring .= "&udom=$udom" if ($udom =~ /^$match_domain$/);
$querystring .= "&uname=$uname" if $uname;	$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 4656 END_MYBLOCK	Line 5078 END_MYBLOCK
$class = '';	$class = '';
} elsif ($activity eq 'printout') {	} elsif ($activity eq 'printout') {
$text = &mt('Printing Blocked');	$text = &mt('Printing Blocked');
	} elsif ($activity eq 'passwd') {
	$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');
	} elsif ($activity eq 'about') {
	$text = &mt('Access to User Information Pages Blocked');
}	}
$output .= <<"END_BLOCK";	$output .= <<"END_BLOCK";
<div class='$class'>	<div class='$class'>
Line 4674 END_BLOCK	Line 5108 END_BLOCK
###############################################	###############################################

sub check_ip_acc {	sub check_ip_acc {
my ($acc)=@_;	my ($acc,$clientip)=@_;
&Apache::lonxml::debug("acc is $acc");	&Apache::lonxml::debug("acc is $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=0;	my ($ip,$allowed);
my $ip=$env{'request.host'} \|\| $ENV{'REMOTE_ADDR'};	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 {
	my $remote_ip = &Apache::lonnet::get_requestor_ip();
	$ip = $remote_ip \|\| $env{'request.host'} \|\| $clientip;
	}

my $name;	my $name;
foreach my $pattern (split(',',$acc)) {	my %access = (
$pattern =~ s/^\s*//;	allowfrom => 1,
$pattern =~ s/\s*$//;	denyfrom => 0,
	);
	my @allows;
	my @denies;
	foreach my $item (split(',',$acc)) {
	$item =~ s/^\s*//;
	$item =~ s/\s*$//;
	if ($item =~ /^\!(.+)$/) {
	push(@denies,$1);
	} else {
	push(@allows,$item);
	}
	}
	my $numdenies = scalar(@denies);
	my $numallows = scalar(@allows);
	my $count = 0;
	foreach my $pattern (@denies,@allows) {
	$count ++;
	my $acctype = 'allowfrom';
	if ($count <= $numdenies) {
	$acctype = 'denyfrom';
	}
if ($pattern =~ /\*$/) {	if ($pattern =~ /\*$/) {
#35.8.*	#35.8.*
$pattern=~s/\*//;	$pattern=~s/\*//;
if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }	if ($ip =~ /^\Q$pattern\E/) { $allowed=$access{$acctype}; }
} elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) {	} elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) {
#35.8.3.[34-56]	#35.8.3.[34-56]
my $low=$2;	my $low=$2;
Line 4697 sub check_ip_acc {	Line 5158 sub check_ip_acc {
$pattern=$1;	$pattern=$1;
if ($ip =~ /^\Q$pattern\E/) {	if ($ip =~ /^\Q$pattern\E/) {
my $last=(split(/\./,$ip))[3];	my $last=(split(/\./,$ip))[3];
if ($last <=$high && $last >=$low) { $allowed=1; }	if ($last <=$high && $last >=$low) { $allowed=$access{$acctype}; }
}	}
} elsif ($pattern =~ /^\*/) {	} elsif ($pattern =~ /^\*/) {
#*.msu.edu	#*.msu.edu
Line 4707 sub check_ip_acc {	Line 5168 sub check_ip_acc {
my $netaddr=inet_aton($ip);	my $netaddr=inet_aton($ip);
($name)=gethostbyaddr($netaddr,AF_INET);	($name)=gethostbyaddr($netaddr,AF_INET);
}	}
if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }	if ($name =~ /\Q$pattern\E$/i) { $allowed=$access{$acctype}; }
} elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) {	} elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) {
#127.0.0.1	#127.0.0.1
if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }	if ($ip =~ /^\Q$pattern\E/) { $allowed=$access{$acctype}; }
} else {	} else {
#some.name.com	#some.name.com
if (!defined($name)) {	if (!defined($name)) {
Line 4718 sub check_ip_acc {	Line 5179 sub check_ip_acc {
my $netaddr=inet_aton($ip);	my $netaddr=inet_aton($ip);
($name)=gethostbyaddr($netaddr,AF_INET);	($name)=gethostbyaddr($netaddr,AF_INET);
}	}
if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }	if ($name =~ /\Q$pattern\E$/i) { $allowed=$access{$acctype}; }
	}
	if ($allowed =~ /^(0\|1)$/) { last; }
	}
	if ($allowed eq '') {
	if ($numdenies && !$numallows) {
	$allowed = 1;
	} else {
	$allowed = 0;
}	}
if ($allowed) { last; }
}	}
return $allowed;	return $allowed;
}	}
Line 4865 sub get_legacy_domconf {	Line 5333 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 5121 Inputs:	Line 5589 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
inherit_jsmath -> when creating popup window in a page,	use_absolute -> for external resource or syllabus, this will
should it have jsmath forced on by the	contain https://<hostname> if server uses
current page	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
Line 5149 sub bodytag {	Line 5618 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 5176 sub bodytag {	Line 5646 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 5191 sub bodytag {	Line 5669 sub bodytag {

# construct main body tag	# construct main body tag
my $bodytag = "<body $extra_body_attr>".	my $bodytag = "<body $extra_body_attr>".
&Apache::lontexconvert::init_math_support($args->{'inherit_jsmath'});	&Apache::lontexconvert::init_math_support();

&get_unprocessed_cgi($ENV{'QUERY_STRING'}, ['inhibitmenu']);	&get_unprocessed_cgi($ENV{'QUERY_STRING'}, ['inhibitmenu']);

Line 5215 sub bodytag {	Line 5693 sub bodytag {
$dc_info =~ s/\s+$//;	$dc_info =~ s/\s+$//;
}	}

$role = '<span class="LC_nobreak">('.$role.')</span>' if $role;	$role = '<span class="LC_nobreak">('.$role.')</span>' if ($role && !$env{'browser.mobile'});

if ($env{'request.state'} eq 'construct') { $forcereg=1; }	if ($env{'request.state'} eq 'construct') { $forcereg=1; }

Line 5229 sub bodytag {	Line 5707 sub 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,'',\$forbodytag);	$advtoolsref,'','',\$forbodytag);
unless (ref($args->{'bread_crumbs'}) eq 'ARRAY') {	unless (ref($args->{'bread_crumbs'}) eq 'ARRAY') {
$funclist = $forbodytag;	$funclist = $forbodytag;
}	}
Line 5275 sub bodytag {	Line 5753 sub bodytag {
$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);
} elsif ($forcereg) {	} elsif ($forcereg) {
$bodytag .= &Apache::lonmenu::innerregister($forcereg,undef,	$bodytag .= &Apache::lonmenu::innerregister($forcereg,undef,
$args->{'group'});	$args->{'group'},
	$args->{'hide_buttons',
	$hostname});
} else {	} else {
my $forbodytag;	my $forbodytag;
&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,'',\$forbodytag);	$advtoolsref,'',$hostname,
	\$forbodytag);
unless (ref($args->{'bread_crumbs'}) eq 'ARRAY') {	unless (ref($args->{'bread_crumbs'}) eq 'ARRAY') {
$bodytag .= $forbodytag;	$bodytag .= $forbodytag;
}	}
Line 5418 sub endbodytag {	Line 5899 sub endbodytag {
unless ((ref($args) eq 'HASH') && ($args->{'notbody'})) {	unless ((ref($args) eq 'HASH') && ($args->{'notbody'})) {
$endbodytag='</body>';	$endbodytag='</body>';
}	}
$endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag;
if ( exists( $env{'internal.head.redirect'} ) ) {	if ( exists( $env{'internal.head.redirect'} ) ) {
if (!(ref($args) eq 'HASH' && $args->{'noredirectlink'})) {	if (!(ref($args) eq 'HASH' && $args->{'noredirectlink'})) {
$endbodytag=	$endbodytag=
Line 5593 div.LC_confirm_box .LC_success img {	Line 6073 div.LC_confirm_box .LC_success img {
vertical-align: middle;	vertical-align: middle;
}	}

	.LC_maxwidth {
	max-width: 100%;
	height: auto;
	}

	.LC_textsize_mobile {
	\@media only screen and (max-device-width: 480px) {
	-webkit-text-size-adjust:100%; -moz-text-size-adjust:100%; -ms-text-size-adjust:100%;
	}
	}

.LC_icon {	.LC_icon {
border: none;	border: none;
vertical-align: middle;	vertical-align: middle;
Line 5714 table#LC_menubuttons img {	Line 6205 table#LC_menubuttons img {
vertical-align: middle;	vertical-align: middle;
}	}

	.LC_breadcrumbs_hoverable {
	background: $sidebg;
	}

td.LC_table_cell_checkbox {	td.LC_table_cell_checkbox {
text-align: center;	text-align: center;
}	}
Line 5784 td.LC_menubuttons_text {	Line 6279 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 6374 table.LC_prior_tries td {	Line 6874 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 6456 table.LC_data_table tr > td.LC_docs_entr	Line 6957 table.LC_data_table tr > td.LC_docs_entr
color: #990000;	color: #990000;
}	}

	.LC_domprefs_email,
.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 6571 div.LC_edit_problem_footer,	Line 7073 div.LC_edit_problem_footer,
div.LC_edit_problem_footer div,	div.LC_edit_problem_footer div,
div.LC_edit_problem_editxml_header,	div.LC_edit_problem_editxml_header,
div.LC_edit_problem_editxml_header div {	div.LC_edit_problem_editxml_header div {
margin-top: 5px;	z-index: 100;
}	}

div.LC_edit_problem_header_title {	div.LC_edit_problem_header_title {
Line 6587 table.LC_edit_problem_header_title {	Line 7089 table.LC_edit_problem_header_title {
background: $tabbg;	background: $tabbg;
}	}

div.LC_edit_problem_discards {	div.LC_edit_actionbar {
float: left;	background-color: $sidebg;
padding-bottom: 5px;	margin: 0;
	padding: 0;
	line-height: 200%;
}	}

div.LC_edit_problem_saves {	div.LC_edit_actionbar div{
float: right;	padding: 0;
padding-bottom: 5px;	margin: 0;
	display: inline-block;
}	}

.LC_edit_opt {	.LC_edit_opt {
Line 6610 div.LC_edit_problem_saves {	Line 7115 div.LC_edit_problem_saves {
margin-left: 40px;	margin-left: 40px;
}	}

	#LC_edit_problem_codemirror div{
	margin-left: 0px;
	}

img.stift {	img.stift {
border-width: 0;	border-width: 0;
vertical-align: middle;	vertical-align: middle;
Line 6728 fieldset > legend {	Line 7237 fieldset > legend {
ol.LC_primary_menu {	ol.LC_primary_menu {
margin: 0;	margin: 0;
padding: 0;	padding: 0;
background-color: $pgbg_or_bgcolor;
}	}

ol#LC_PathBreadcrumbs {	ol#LC_PathBreadcrumbs {
Line 6740 ol.LC_primary_menu li {	Line 7248 ol.LC_primary_menu li {
vertical-align: middle;	vertical-align: middle;
text-align: left;	text-align: left;
list-style: none;	list-style: none;
	position: relative;
float: left;	float: left;
	z-index: 100; /* will be displayed above codemirror and underneath the help-layer */
	line-height: 1.5em;
}	}

ol.LC_primary_menu li a {	ol.LC_primary_menu li a,
	ol.LC_primary_menu li p {
display: block;	display: block;
margin: 0;	margin: 0;
padding: 0 5px 0 10px;	padding: 0 5px 0 10px;
text-decoration: none;	text-decoration: none;
}	}

ol.LC_primary_menu li ul {	ol.LC_primary_menu li p span.LC_primary_menu_innertitle {
	display: inline-block;
	width: 95%;
	text-align: left;
	}

	ol.LC_primary_menu li p span.LC_primary_menu_innerarrow {
	display: inline-block;
	width: 5%;
	float: right;
	text-align: right;
	font-size: 70%;
	}

	ol.LC_primary_menu ul {
display: none;	display: none;
width: 10em;	width: 15em;
background-color: $data_table_light;	background-color: $data_table_light;
	position: absolute;
	top: 100%;
	}

	ol.LC_primary_menu ul ul {
	left: 100%;
	top: 0;
}	}

ol.LC_primary_menu li:hover ul, ol.LC_primary_menu li.hover ul {	ol.LC_primary_menu li:hover > ul, ol.LC_primary_menu li.hover > ul {
display: block;	display: block;
position: absolute;	position: absolute;
margin: 0;	margin: 0;
Line 6765 ol.LC_primary_menu li:hover ul, ol.LC_pr	Line 7298 ol.LC_primary_menu li:hover ul, ol.LC_pr
}	}

ol.LC_primary_menu li:hover li, ol.LC_primary_menu li.hover li {	ol.LC_primary_menu li:hover li, ol.LC_primary_menu li.hover li {
	/* First Submenu -> size should be smaller than the menu title of the whole menu */
font-size: 90%;	font-size: 90%;
vertical-align: top;	vertical-align: top;
float: none;	float: none;
border-left: 1px solid black;	border-left: 1px solid black;
border-right: 1px solid black;	border-right: 1px solid black;
	/* A dark bottom border to visualize different menu options;
	overwritten in the create_submenu routine for the last border-bottom of the menu */
	border-bottom: 1px solid $data_table_dark;
}	}

ol.LC_primary_menu li:hover li a, ol.LC_primary_menu li.hover li a {	ol.LC_primary_menu li li p:hover {
background-color:$data_table_light;	color:$button_hover;
	text-decoration:none;
	background-color:$data_table_dark;
}	}

ol.LC_primary_menu li li a:hover {	ol.LC_primary_menu li li a:hover {
Line 6781 ol.LC_primary_menu li li a:hover {	Line 7320 ol.LC_primary_menu li li a:hover {
background-color:$data_table_dark;	background-color:$data_table_dark;
}	}

	/* Font-size equal to the size of the predecessors*/
	ol.LC_primary_menu li:hover li li {
	font-size: 100%;
	}

ol.LC_primary_menu li img {	ol.LC_primary_menu li img {
vertical-align: bottom;	vertical-align: bottom;
height: 1.1em;	height: 1.1em;
Line 6837 ul#LC_secondary_menu li {	Line 7381 ul#LC_secondary_menu li {
font-weight: bold;	font-weight: bold;
line-height: 1.8em;	line-height: 1.8em;
border-right: 1px solid black;	border-right: 1px solid black;
vertical-align: middle;
float: left;	float: left;
}	}

Line 7323 ul.LC_funclist li {	Line 7866 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 by TTH when "Default set of options to pass to tth/m	styles used by TTH when "Default set of options to pass to tth/m
when converting TeX" in course settings has been set	when converting TeX" in course settings has been set
Line 7344 span.roman {font-family: serif; font-sty	Line 7895 span.roman {font-family: serif; font-sty
span.overacc2 {position: relative; left: .8em; top: -1.2ex;}	span.overacc2 {position: relative; left: .8em; top: -1.2ex;}
span.overacc1 {position: relative; left: .6em; top: -1.2ex;}	span.overacc1 {position: relative; left: .6em; top: -1.2ex;}

	#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 7449 ADDMETA	Line 8033 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,$offloadoth);
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)) {	if (($env{'user.domain'} ne '') && ($env{'user.domain'} ne $dom_in_use) &&
my $numsec = 5;	(!(($env{'user.name'} eq 'public') && ($env{'user.domain'} eq 'public')))) {
my $timeout = $numsec * 1000;	unless (&Apache::lonnet::shared_institution($env{'user.domain'})) {
my ($newurl,$locknum,%locks,$msg);	$offloadoth = 1;
if ($env{'request.role.adv'}) {	$dom_in_use = $env{'user.domain'};
($locknum,%locks) = &Apache::lonnet::get_locks();	}
}	}
my $disable_submit = 0;	}
if ($requrl =~ /$LONCAPA::assess_re/) {	}
$disable_submit = 1;	unless ($offload) {
}	if (ref($domdefs{'offloadoth'}) eq 'HASH') {
if ($locknum) {	if ($domdefs{'offloadoth'}{$lonhost}) {
my @lockinfo = sort(values(%locks));	if (($env{'user.domain'} ne '') && ($env{'user.domain'} ne $dom_in_use) &&
$msg = &mt('Once the following tasks are complete: ')."\\n".	(!(($env{'user.name'} eq 'public') && ($env{'user.domain'} eq 'public')))) {
join(", ",sort(values(%locks)))."\\n".	unless (&Apache::lonnet::shared_institution($env{'user.domain'})) {
&mt('your session will be transferred to a different server, after you click "Roles".');	$offload = 1;
} else {	$offloadoth = 1;
if (($requrl =~ m{^/res/}) && ($env{'form.submitted'} =~ /^part_/)) {	$dom_in_use = $env{'user.domain'};
$msg = &mt('Your LON-CAPA submission has been recorded')."\\n";
}	}
$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 ($offload) {
	my $newserver = &Apache::lonnet::spareserver(30000,undef,1,$dom_in_use);
	if (($newserver eq '') && ($offloadoth)) {
	my @domains = &Apache::lonnet::current_machine_domains();
	if (($dom_in_use ne '') && (!grep(/^\Q$dom_in_use\E$/,@domains))) {
	($newserver) = &Apache::lonnet::choose_server($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 {
	$msg .= &mt('your session will be transferred to a different server, after you click "Roles".');
	}
	} else {
	if (($requrl =~ m{^/res/}) && ($env{'form.submitted'} =~ /^part_/)) {
	$msg = &mt('Your LON-CAPA submission has been recorded')."\n";
	}
	$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;
}	}
$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 7505 function LC_Offload_Now() {	Line 8146 function LC_Offload_Now() {
// ]]>	// ]]>
</script>	</script>
OFFLOAD	OFFLOAD
}
}	}
}	}
}	}
Line 7524 OFFLOAD	Line 8164 OFFLOAD
$result .= '>'	$result .= '>'
.$inhibitprint	.$inhibitprint
.$head_extra;	.$head_extra;
if ($env{'browser.mobile'}) {	my $clientmobile;
	if (($env{'user.name'} eq '') && ($env{'user.domain'} eq '')) {
	(undef,undef,undef,undef,undef,undef,$clientmobile) = &decode_user_agent();
	} else {
	$clientmobile = $env{'browser.mobile'};
	}
	if ($clientmobile) {
$result .= '	$result .= '
<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 7708 $args - additional optional args support	Line 8355 $args - additional optional args support
no_inline_link -> if true and in remote mode, don't show the	no_inline_link -> if true and in remote mode, don't show the
'Switch To Inline Menu' link	'Switch To Inline Menu' link
no_auto_mt_title -> prevent &mt()ing the title arg	no_auto_mt_title -> prevent &mt()ing the title arg
inherit_jsmath -> when creating popup window in a page,
should it have jsmath forced on by the
current page
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 7778 sub start_page {	Line 8428 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'})) {
	$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);
}else{	}else{
$result .= &Apache::lonhtmlcommon::breadcrumbs();	$result .= &Apache::lonhtmlcommon::breadcrumbs('','',$menulink);
}	}
} elsif (($env{'environment.remote'} eq 'on') &&	} elsif (($env{'environment.remote'} eq 'on') &&
($env{'form.inhibitmenu'} ne 'yes') &&	($env{'form.inhibitmenu'} ne 'yes') &&
Line 7885 var modalWindow = {	Line 8541 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 7910 sub modal_link {	Line 8566 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 8014 sub end_togglebox {	Line 8669 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 8028 sub LCprogressbar_script {	Line 8684 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 8054 my $LCidcnt;	Line 8732 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 9201 sub get_secgrprole_info {	Line 9896 sub get_secgrprole_info {
}	}

sub user_picker {	sub user_picker {
my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype,$context) = @_;	my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype,$context,$fixeddom,$noinstd) = @_;
my $currdom = $dom;	my $currdom = $dom;
	my @alldoms = &Apache::lonnet::all_domains();
	if (@alldoms == 1) {
	my %domsrch = &Apache::lonnet::get_dom('configuration',
	['directorysrch'],$alldoms[0]);
	my $domdesc = &Apache::lonnet::domain($alldoms[0],'description');
	my $showdom = $domdesc;
	if ($showdom eq '') {
	$showdom = $dom;
	}
	if (ref($domsrch{'directorysrch'}) eq 'HASH') {
	if ((!$domsrch{'directorysrch'}{'available'}) &&
	($domsrch{'directorysrch'}{'lcavailable'} eq '0')) {
	return (&mt('LON-CAPA directory search is not available in domain: [_1]',$showdom),0);
	}
	}
	}
my %curr_selected = (	my %curr_selected = (
srchin => 'dom',	srchin => 'dom',
srchby => 'lastname',	srchby => 'lastname',
Line 9223 sub user_picker {	Line 9934 sub user_picker {
}	}
$srchterm = $srch->{'srchterm'};	$srchterm = $srch->{'srchterm'};
}	}
my %lt=&Apache::lonlocal::texthash(	my %html_lt=&Apache::lonlocal::texthash(
'usr' => 'Search criteria',	'usr' => 'Search criteria',
'doma' => 'Domain/institution to search',	'doma' => 'Domain/institution to search',
'uname' => 'username',	'uname' => 'username',
Line 9236 sub user_picker {	Line 9947 sub user_picker {
'exact' => 'is',	'exact' => 'is',
'contains' => 'contains',	'contains' => 'contains',
'begins' => 'begins with',	'begins' => 'begins with',
	);
	my %js_lt=&Apache::lonlocal::texthash(
'youm' => "You must include some text to search for.",	'youm' => "You must include some text to search for.",
'thte' => "The text you are searching for must contain at least two characters when using a 'begins' type search.",	'thte' => "The text you are searching for must contain at least two characters when using a 'begins' type search.",
'thet' => "The text you are searching for must contain at least three characters when using a 'contains' type search.",	'thet' => "The text you are searching for must contain at least three characters when using a 'contains' type search.",
Line 9245 sub user_picker {	Line 9958 sub user_picker {
'whse' => "When searching by last,first you must include at least one character in the first name.",	'whse' => "When searching by last,first you must include at least one character in the first name.",
'thfo' => "The following need to be corrected before the search can be run:",	'thfo' => "The following need to be corrected before the search can be run:",
);	);
my $domform = &select_dom_form($currdom,'srchdomain',1,1);	&html_escape(\%html_lt);
	&js_escape(\%js_lt);
	my $domform;
	my $allow_blank = 1;
	if ($fixeddom) {
	$allow_blank = 0;
	$domform = &select_dom_form($currdom,'srchdomain',$allow_blank,1,undef,[$currdom]);
	} else {
	$domform = &select_dom_form($currdom,'srchdomain',$allow_blank,1);
	}
my $srchinsel = ' <select name="srchin">';	my $srchinsel = ' <select name="srchin">';

my @srchins = ('crs','dom','alc','instd');	my @srchins = ('crs','dom','alc','instd');
Line 9257 sub user_picker {	Line 9979 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">'.$lt{$option}.'</option>';	<option value="'.$option.'" selected="selected">'.$html_lt{$option}.'</option>';
} else {	} else {
$srchinsel .= '	$srchinsel .= '
<option value="'.$option.'">'.$lt{$option}.'</option>';	<option value="'.$option.'">'.$html_lt{$option}.'</option>';
}	}
}	}
$srchinsel .= "\n </select>\n";	$srchinsel .= "\n </select>\n";
Line 9271 sub user_picker {	Line 9994 sub user_picker {
foreach my $option ('lastname','lastfirst','uname') {	foreach my $option ('lastname','lastfirst','uname') {
if ($curr_selected{'srchby'} eq $option) {	if ($curr_selected{'srchby'} eq $option) {
$srchbysel .= '	$srchbysel .= '
<option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';	<option value="'.$option.'" selected="selected">'.$html_lt{$option}.'</option>';
} else {	} else {
$srchbysel .= '	$srchbysel .= '
<option value="'.$option.'">'.$lt{$option}.'</option>';	<option value="'.$option.'">'.$html_lt{$option}.'</option>';
}	}
}	}
$srchbysel .= "\n </select>\n";	$srchbysel .= "\n </select>\n";
Line 9283 sub user_picker {	Line 10006 sub user_picker {
foreach my $option ('begins','contains','exact') {	foreach my $option ('begins','contains','exact') {
if ($curr_selected{'srchtype'} eq $option) {	if ($curr_selected{'srchtype'} eq $option) {
$srchtypesel .= '	$srchtypesel .= '
<option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';	<option value="'.$option.'" selected="selected">'.$html_lt{$option}.'</option>';
} else {	} else {
$srchtypesel .= '	$srchtypesel .= '
<option value="'.$option.'">'.$lt{$option}.'</option>';	<option value="'.$option.'">'.$html_lt{$option}.'</option>';
}	}
}	}
$srchtypesel .= "\n </select>\n";	$srchtypesel .= "\n </select>\n";
Line 9371 function validateEntry(callingForm) {	Line 10094 function validateEntry(callingForm) {

if (srchterm == "") {	if (srchterm == "") {
checkok = 0;	checkok = 0;
msg += "$lt{'youm'}\\n";	msg += "$js_lt{'youm'}\\n";
}	}

if (srchtype== 'begins') {	if (srchtype== 'begins') {
if (srchterm.length < 2) {	if (srchterm.length < 2) {
checkok = 0;	checkok = 0;
msg += "$lt{'thte'}\\n";	msg += "$js_lt{'thte'}\\n";
}	}
}	}

if (srchtype== 'contains') {	if (srchtype== 'contains') {
if (srchterm.length < 3) {	if (srchterm.length < 3) {
checkok = 0;	checkok = 0;
msg += "$lt{'thet'}\\n";	msg += "$js_lt{'thet'}\\n";
}	}
}	}
if (srchin == 'instd') {	if (srchin == 'instd') {
if (srchdomain == '') {	if (srchdomain == '') {
checkok = 0;	checkok = 0;
msg += "$lt{'yomc'}\\n";	msg += "$js_lt{'yomc'}\\n";
}	}
}	}
if (srchin == 'dom') {	if (srchin == 'dom') {
if (srchdomain == '') {	if (srchdomain == '') {
checkok = 0;	checkok = 0;
msg += "$lt{'ymcd'}\\n";	msg += "$js_lt{'ymcd'}\\n";
}	}
}	}
if (srchby == 'lastfirst') {	if (srchby == 'lastfirst') {
if (srchterm.indexOf(",") == -1) {	if (srchterm.indexOf(",") == -1) {
checkok = 0;	checkok = 0;
msg += "$lt{'whus'}\\n";	msg += "$js_lt{'whus'}\\n";
}	}
if (srchterm.indexOf(",") == srchterm.length -1) {	if (srchterm.indexOf(",") == srchterm.length -1) {
checkok = 0;	checkok = 0;
msg += "$lt{'whse'}\\n";	msg += "$js_lt{'whse'}\\n";
}	}
}	}
if (checkok == 0) {	if (checkok == 0) {
alert("$lt{'thfo'}\\n"+msg);	alert("$js_lt{'thfo'}\\n"+msg);
return;	return;
}	}
if (checkok == 1) {	if (checkok == 1) {
Line 9428 $new_user_create	Line 10151 $new_user_create
END_BLOCK	END_BLOCK

$output .= &Apache::lonhtmlcommon::start_pick_box().	$output .= &Apache::lonhtmlcommon::start_pick_box().
&Apache::lonhtmlcommon::row_title($lt{'doma'}).	&Apache::lonhtmlcommon::row_title($html_lt{'doma'}).
$domform.	$domform.
&Apache::lonhtmlcommon::row_closure().	&Apache::lonhtmlcommon::row_closure().
&Apache::lonhtmlcommon::row_title($lt{'usr'}).	&Apache::lonhtmlcommon::row_title($html_lt{'usr'}).
$srchbysel.	$srchbysel.
$srchtypesel.	$srchtypesel.
'<input type="text" size="15" name="srchterm" value="'.$srchterm.'" />'.	'<input type="text" size="15" name="srchterm" value="'.$srchterm.'" />'.
Line 9439 END_BLOCK	Line 10162 END_BLOCK
&Apache::lonhtmlcommon::row_closure(1).	&Apache::lonhtmlcommon::row_closure(1).
&Apache::lonhtmlcommon::end_pick_box().	&Apache::lonhtmlcommon::end_pick_box().
'<br />';	'<br />';
return $output;	return ($output,1);
}	}

sub user_rule_check {	sub user_rule_check {
my ($usershash,$checks,$alerts,$rulematch,$inst_results,$curr_rules,$got_rules) = @_;	my ($usershash,$checks,$alerts,$rulematch,$inst_results,$curr_rules,$got_rules) = @_;
my $response;	my ($response,%inst_response);
if (ref($usershash) eq 'HASH') {	if (ref($usershash) eq 'HASH') {
foreach my $user (keys(%{$usershash})) {	if (keys(%{$usershash}) > 1) {
my ($uname,$udom) = split(/:/,$user);	my (%by_username,%by_id,%userdoms);
next if ($udom eq '' \|\| $uname eq '');	my $checkid;
my ($id,$newuser);
if (ref($usershash->{$user}) eq 'HASH') {
$newuser = $usershash->{$user}->{'newuser'};
$id = $usershash->{$user}->{'id'};
}
my $inst_response;
if (ref($checks) eq 'HASH') {	if (ref($checks) eq 'HASH') {
if (defined($checks->{'username'})) {	if ((!defined($checks->{'username'})) && (defined($checks->{'id'}))) {
($inst_response,%{$inst_results->{$user}}) =	$checkid = 1;
&Apache::lonnet::get_instuser($udom,$uname);	}
} elsif (defined($checks->{'id'})) {	}
($inst_response,%{$inst_results->{$user}}) =	foreach my $user (keys(%{$usershash})) {
&Apache::lonnet::get_instuser($udom,undef,$id);	my ($uname,$udom) = split(/:/,$user);
	if ($checkid) {
	if (ref($usershash->{$user}) eq 'HASH') {
	if ($usershash->{$user}->{'id'} ne '') {
	$by_id{$udom}{$usershash->{$user}->{'id'}} = $uname;
	$userdoms{$udom} = 1;
	if (ref($inst_results) eq 'HASH') {
	$inst_results->{$uname.':'.$udom} = {};
	}
	}
	}
	} else {
	$by_username{$udom}{$uname} = 1;
	$userdoms{$udom} = 1;
	if (ref($inst_results) eq 'HASH') {
	$inst_results->{$uname.':'.$udom} = {};
	}
	}
	}
	foreach my $udom (keys(%userdoms)) {
	if (!$got_rules->{$udom}) {
	my %domconfig = &Apache::lonnet::get_dom('configuration',
	['usercreation'],$udom);
	if (ref($domconfig{'usercreation'}) eq 'HASH') {
	foreach my $item ('username','id') {
	if (ref($domconfig{'usercreation'}{$item.'_rule'}) eq 'ARRAY') {
	$$curr_rules{$udom}{$item} =
	$domconfig{'usercreation'}{$item.'_rule'};
	}
	}
	}
	$got_rules->{$udom} = 1;
	}
	}
	if ($checkid) {
	foreach my $udom (keys(%by_id)) {
	my ($outcome,$results) = &Apache::lonnet::get_multiple_instusers($udom,$by_id{$udom},'id');
	if ($outcome eq 'ok') {
	foreach my $id (keys(%{$by_id{$udom}})) {
	my $uname = $by_id{$udom}{$id};
	$inst_response{$uname.':'.$udom} = $outcome;
	}
	if (ref($results) eq 'HASH') {
	foreach my $uname (keys(%{$results})) {
	if (exists($inst_response{$uname.':'.$udom})) {
	$inst_response{$uname.':'.$udom} = $outcome;
	$inst_results->{$uname.':'.$udom} = $results->{$uname};
	}
	}
	}
	}
}	}
} else {	} else {
($inst_response,%{$inst_results->{$user}}) =	foreach my $udom (keys(%by_username)) {
&Apache::lonnet::get_instuser($udom,$uname);	my ($outcome,$results) = &Apache::lonnet::get_multiple_instusers($udom,$by_username{$udom});
return;	if ($outcome eq 'ok') {
	foreach my $uname (keys(%{$by_username{$udom}})) {
	$inst_response{$uname.':'.$udom} = $outcome;
	}
	if (ref($results) eq 'HASH') {
	foreach my $uname (keys(%{$results})) {
	$inst_results->{$uname.':'.$udom} = $results->{$uname};
	}
	}
	}
	}
}	}
if (!$got_rules->{$udom}) {	} elsif (keys(%{$usershash}) == 1) {
my %domconfig = &Apache::lonnet::get_dom('configuration',	my $user = (keys(%{$usershash}))[0];
['usercreation'],$udom);	my ($uname,$udom) = split(/:/,$user);
if (ref($domconfig{'usercreation'}) eq 'HASH') {	if (($udom ne '') && ($uname ne '')) {
foreach my $item ('username','id') {	if (ref($usershash->{$user}) eq 'HASH') {
if (ref($domconfig{'usercreation'}{$item.'_rule'}) eq 'ARRAY') {	if (ref($checks) eq 'HASH') {
$$curr_rules{$udom}{$item} =	if (defined($checks->{'username'})) {
$domconfig{'usercreation'}{$item.'_rule'};	($inst_response{$user},%{$inst_results->{$user}}) =
	&Apache::lonnet::get_instuser($udom,$uname);
	} elsif (defined($checks->{'id'})) {
	if ($usershash->{$user}->{'id'} ne '') {
	($inst_response{$user},%{$inst_results->{$user}}) =
	&Apache::lonnet::get_instuser($udom,undef,
	$usershash->{$user}->{'id'});
	} else {
	($inst_response{$user},%{$inst_results->{$user}}) =
	&Apache::lonnet::get_instuser($udom,$uname);
	}
}	}
	} else {
	($inst_response{$user},%{$inst_results->{$user}}) =
	&Apache::lonnet::get_instuser($udom,$uname);
	return;
	}
	if (!$got_rules->{$udom}) {
	my %domconfig = &Apache::lonnet::get_dom('configuration',
	['usercreation'],$udom);
	if (ref($domconfig{'usercreation'}) eq 'HASH') {
	foreach my $item ('username','id') {
	if (ref($domconfig{'usercreation'}{$item.'_rule'}) eq 'ARRAY') {
	$$curr_rules{$udom}{$item} =
	$domconfig{'usercreation'}{$item.'_rule'};
	}
	}
	}
	$got_rules->{$udom} = 1;
}	}
}	}
$got_rules->{$udom} = 1;	} else {
	return;
	}
	} else {
	return;
	}
	foreach my $user (keys(%{$usershash})) {
	my ($uname,$udom) = split(/:/,$user);
	next if (($udom eq '') \|\| ($uname eq ''));
	my $id;
	if (ref($inst_results) eq 'HASH') {
	if (ref($inst_results->{$user}) eq 'HASH') {
	$id = $inst_results->{$user}->{'id'};
	}
	}
	if ($id eq '') {
	if (ref($usershash->{$user})) {
	$id = $usershash->{$user}->{'id'};
	}
}	}
foreach my $item (keys(%{$checks})) {	foreach my $item (keys(%{$checks})) {
if (ref($$curr_rules{$udom}) eq 'HASH') {	if (ref($$curr_rules{$udom}) eq 'HASH') {
if (ref($$curr_rules{$udom}{$item}) eq 'ARRAY') {	if (ref($$curr_rules{$udom}{$item}) eq 'ARRAY') {
if (@{$$curr_rules{$udom}{$item}} > 0) {	if (@{$$curr_rules{$udom}{$item}} > 0) {
my %rule_check = &Apache::lonnet::inst_rulecheck($udom,$uname,$id,$item,$$curr_rules{$udom}{$item});	my %rule_check = &Apache::lonnet::inst_rulecheck($udom,$uname,$id,$item,
	$$curr_rules{$udom}{$item});
foreach my $rule (@{$$curr_rules{$udom}{$item}}) {	foreach my $rule (@{$$curr_rules{$udom}{$item}}) {
if ($rule_check{$rule}) {	if ($rule_check{$rule}) {
$$rulematch{$user}{$item} = $rule;	$$rulematch{$user}{$item} = $rule;
if ($inst_response eq 'ok') {	if ($inst_response{$user} eq 'ok') {
if (ref($inst_results) eq 'HASH') {	if (ref($inst_results) eq 'HASH') {
if (ref($inst_results->{$user}) eq 'HASH') {	if (ref($inst_results->{$user}) eq 'HASH') {
if (keys(%{$inst_results->{$user}}) == 0) {	if (keys(%{$inst_results->{$user}}) == 0) {
$$alerts{$item}{$udom}{$uname} = 1;	$$alerts{$item}{$udom}{$uname} = 1;
	} elsif ($item eq 'id') {
	if ($inst_results->{$user}->{'id'} eq '') {
	$$alerts{$item}{$udom}{$uname} = 1;
	}
}	}
}	}
}	}
Line 9632 sub sorted_inst_types {	Line 10459 sub sorted_inst_types {
}	}

sub get_institutional_codes {	sub get_institutional_codes {
my ($settings,$allcourses,$LC_code) = @_;	my ($cdom,$crs,$settings,$allcourses,$LC_code) = @_;
# Get complete list of course sections to update	# Get complete list of course sections to update
my @currsections = ();	my @currsections = ();
my @currxlists = ();	my @currxlists = ();
	my (%unclutteredsec,%unclutteredlcsec);
my $coursecode = $$settings{'internal.coursecode'};	my $coursecode = $$settings{'internal.coursecode'};
	my $crskey = $crs.':'.$coursecode;
	@{$unclutteredsec{$crskey}} = ();
	@{$unclutteredlcsec{$crskey}} = ();

if ($$settings{'internal.sectionnums'} ne '') {	if ($$settings{'internal.sectionnums'} ne '') {
@currsections = split(/,/,$$settings{'internal.sectionnums'});	@currsections = split(/,/,$$settings{'internal.sectionnums'});
Line 9647 sub get_institutional_codes {	Line 10478 sub get_institutional_codes {
}	}

if (@currxlists > 0) {	if (@currxlists > 0) {
foreach (@currxlists) {	foreach my $xl (@currxlists) {
if (m/^([^:]+):(\w*)$/) {	if ($xl =~ /^([^:]+):(\w*)$/) {
unless (grep/^$1$/,@{$allcourses}) {	unless (grep/^$1$/,@{$allcourses}) {
push @{$allcourses},$1;	push(@{$allcourses},$1);
$$LC_code{$1} = $2;	$$LC_code{$1} = $2;
}	}
}	}
}	}
}	}

if (@currsections > 0) {	if (@currsections > 0) {
foreach (@currsections) {	foreach my $sec (@currsections) {
if (m/^(\w+):(\w*)$/) {	if ($sec =~ m/^(\w+):(\w*)$/) {
my $sec = $coursecode.$1;	my $instsec = $1;
my $lc_sec = $2;	my $lc_sec = $2;
unless (grep/^$sec$/,@{$allcourses}) {	unless (grep/^\Q$instsec\E$/,@{$unclutteredsec{$crskey}}) {
push @{$allcourses},$sec;	push(@{$unclutteredsec{$crskey}},$instsec);
$$LC_code{$sec} = $lc_sec;	push(@{$unclutteredlcsec{$crskey}},$lc_sec);
	}
	}
	}
	}

	if (@{$unclutteredsec{$crskey}} > 0) {
	my %formattedsec = &Apache::lonnet::auto_instsec_reformat($cdom,'clutter',\%unclutteredsec);
	if ((ref($formattedsec{$crskey}) eq 'ARRAY') && (ref($unclutteredlcsec{$crskey}) eq 'ARRAY')) {
	for (my $i=0; $i<@{$formattedsec{$crskey}}; $i++) {
	my $sec = $coursecode.$formattedsec{$crskey}[$i];
	unless (grep/^\Q$sec\E$/,@{$allcourses}) {
	push(@{$allcourses},$sec);
	$$LC_code{$sec} = $unclutteredlcsec{$crskey}[$i];
}	}
}	}
}	}
Line 9761 reservable_now - ref to hash of student_	Line 10605 reservable_now - ref to hash of student_

Keys in inner hash are:	Keys in inner hash are:
(a) symb: either blank or symb to which slot use is restricted.	(a) symb: either blank or symb to which slot use is restricted.
(b) endreserve: end date of reservation period.	(b) endreserve: end date of reservation period.
	(c) uniqueperiod: start,end dates when slot is to be uniquely
	selected.

sorted_future - ref to array of student_schedulable slots reservable in	sorted_future - ref to array of student_schedulable slots reservable in
the future, ordered by start date of reservation period.	the future, ordered by start date of reservation period.
Line 9772 future_reservable - ref to hash of stude	Line 10618 future_reservable - ref to hash of stude
Keys in inner hash are:	Keys in inner hash are:
(a) symb: either blank or symb to which slot use is restricted.	(a) symb: either blank or symb to which slot use is restricted.
(b) startreserve: start date of reservation period.	(b) startreserve: start date of reservation period.
	(c) uniqueperiod: start,end dates when slot is to be uniquely
	selected.

=back	=back

Line 9825 sub get_future_slots {	Line 10673 sub get_future_slots {
my $startreserve = $slots{$slot}->{'startreserve'};	my $startreserve = $slots{$slot}->{'startreserve'};
my $endreserve = $slots{$slot}->{'endreserve'};	my $endreserve = $slots{$slot}->{'endreserve'};
my $symb = $slots{$slot}->{'symb'};	my $symb = $slots{$slot}->{'symb'};
	my $uniqueperiod;
	if (ref($slots{$slot}->{'uniqueperiod'}) eq 'ARRAY') {
	$uniqueperiod = join(',',@{$slots{$slot}->{'uniqueperiod'}});
	}
if (($startreserve < $now) &&	if (($startreserve < $now) &&
(!$endreserve \|\| $endreserve > $now)) {	(!$endreserve \|\| $endreserve > $now)) {
my $lastres = $endreserve;	my $lastres = $endreserve;
Line 9833 sub get_future_slots {	Line 10685 sub get_future_slots {
}	}
$reservable_now{$slot} = {	$reservable_now{$slot} = {
symb => $symb,	symb => $symb,
endreserve => $lastres	endreserve => $lastres,
	uniqueperiod => $uniqueperiod,
};	};
} elsif (($startreserve > $now) &&	} elsif (($startreserve > $now) &&
(!$endreserve \|\| $endreserve > $startreserve)) {	(!$endreserve \|\| $endreserve > $startreserve)) {
$future_reservable{$slot} = {	$future_reservable{$slot} = {
symb => $symb,	symb => $symb,
startreserve => $startreserve	startreserve => $startreserve,
	uniqueperiod => $uniqueperiod,
};	};
}	}
}	}
Line 10904 sub modify_html_refs {	Line 11758 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 10969 sub modify_html_refs {	Line 11823 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 11486 sub decompress_uploaded_file {	Line 12340 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 11520 sub process_decompression {	Line 12386 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 11561 sub process_decompression {	Line 12441 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 12047 END	Line 12926 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 12060 sub process_extracted_files {	Line 12939 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 12149 sub process_extracted_files {	Line 13028 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 12158 sub process_extracted_files {	Line 13039 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);
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',$docstitle).'</li>'."\n";
}	}
	if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
	if (rename("$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;
	}
	}
	}
	$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 12250 sub process_extracted_files {	Line 13140 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 12259 sub process_extracted_files {	Line 13151 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 12547 sub upfile_store {	Line 13444 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 12562 sub upfile_store {	Line 13462 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 12584 sub load_tmp_file {	Line 13485 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 13024 sub DrawBarGraph {	Line 13933 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 13472 defdom (domain for which to retrieve con	Line 14381 defdom (domain for which to retrieve con
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.

=back	=back
Line 13481 Returns: comma separated list of address	Line 14396 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 13497 sub build_recipient_list {	Line 14412 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 13524 sub build_recipient_list {	Line 14608 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 13616 jsarray (reference to array of categorie	Line 14713 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 13623 Side effects: populates trails and allit	Line 14722 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 13649 sub extract_categories {	Line 14748 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 13692 Side effects: populates trails and allit	Line 14794 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++) {
Line 13719 sub recurse_categories {	Line 14821 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 13749 currcat - scalar with an & separated lis	Line 14856 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 13790 sub assign_categories_table {	Line 14900 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 13833 path - Array containing all categories b	Line 14943 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 13861 sub assign_category_rows {	Line 14974 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 14077 sub check_clone {	Line 15190 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 14085 sub check_clone {	Line 15199 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 {
my %clonehash = &Apache::lonnet::get('environment',['cloners'],	my %clonehash = &Apache::lonnet::get('environment',['cloners','internal.coursecode'],
$args->{'clonedomain'},$args->{'clonecourse'});	$args->{'clonedomain'},$args->{'clonecourse'});
my @cloners = split(/,/,$clonehash{'cloners'});	if ($clonehash{'cloners'} eq '') {
if (grep(/^\*$/,@cloners)) {	my %domdefs = &Apache::lonnet::get_domain_defaults($args->{'course_domain'});
$can_clone = 1;	if ($domdefs{'canclone'}) {
} elsif (grep(/^\*\:\Q$args->{'ccdomain'}\E$/,@cloners)) {	unless ($domdefs{'canclone'} eq 'none') {
$can_clone = 1;	if ($domdefs{'canclone'} eq 'domain') {
	if ($args->{'ccdomain'} eq $args->{'clonedomain'}) {
	$can_clone = 1;
	}
	} elsif (($clonehash{'internal.coursecode'}) && ($args->{'crscode'}) &&
	($args->{'clonedomain'} eq $args->{'course_domain'})) {
	if (&Apache::lonnet::default_instcode_cloning($args->{'clonedomain'},$domdefs{'canclone'},
	$clonehash{'internal.coursecode'},$args->{'crscode'})) {
	$can_clone = 1;
	}
	}
	}
	}
} else {	} else {
	my @cloners = split(/,/,$clonehash{'cloners'});
	if (grep(/^\*$/,@cloners)) {
	$can_clone = 1;
	} elsif (grep(/^\*\:\Q$args->{'ccdomain'}\E$/,@cloners)) {
	$can_clone = 1;
	} elsif (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners)) {
	$can_clone = 1;
	}
	unless ($can_clone) {
	if (($clonehash{'internal.coursecode'}) && ($args->{'crscode'}) &&
	($args->{'clonedomain'} eq $args->{'course_domain'})) {
	my (%gotdomdefaults,%gotcodedefaults);
	foreach my $cloner (@cloners) {
	if (($cloner ne '') && ($cloner !~ /^\\:$match_domain$/) &&
	($cloner !~ /^$match_username\:$match_domain$/) && ($cloner ne '')) {
	my (%codedefaults,@code_order);
	if (ref($gotcodedefaults{$args->{'clonedomain'}}) eq 'HASH') {
	if (ref($gotcodedefaults{$args->{'clonedomain'}}{'defaults'}) eq 'HASH') {
	%codedefaults = %{$gotcodedefaults{$args->{'clonedomain'}}{'defaults'}};
	}
	if (ref($gotcodedefaults{$args->{'clonedomain'}}{'order'}) eq 'ARRAY') {
	@code_order = @{$gotcodedefaults{$args->{'clonedomain'}}{'order'}};
	}
	} else {
	&Apache::lonnet::auto_instcode_defaults($args->{'clonedomain'},
	\%codedefaults,
	\@code_order);
	$gotcodedefaults{$args->{'clonedomain'}}{'defaults'} = \%codedefaults;
	$gotcodedefaults{$args->{'clonedomain'}}{'order'} = \@code_order;
	}
	if (@code_order > 0) {
	if (&Apache::lonnet::check_instcode_cloning(\%codedefaults,\@code_order,
	$cloner,$clonehash{'internal.coursecode'},
	$args->{'crscode'})) {
	$can_clone = 1;
	last;
	}
	}
	}
	}
	}
	}
	}
	unless ($can_clone) {
my $ccrole = 'cc';	my $ccrole = 'cc';
if ($args->{'crstype'} eq 'Community') {	if ($args->{'crstype'} eq 'Community') {
$ccrole = 'co';	$ccrole = 'co';
}	}
my %roleshash =	my %roleshash =
&Apache::lonnet::get_my_roles($args->{'ccuname'},	&Apache::lonnet::get_my_roles($args->{'ccuname'},
$args->{'ccdomain'},	$args->{'ccdomain'},
'userroles',['active'],[$ccrole],	'userroles',['active'],[$ccrole],
[$args->{'clonedomain'}]);	[$args->{'clonedomain'}]);
if (($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':'.$ccrole}) \|\| (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners))) {	if ($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':'.$ccrole}) {
$can_clone = 1;	$can_clone = 1;
} elsif (&Apache::lonnet::is_course_owner($args->{'clonedomain'},$args->{'clonecourse'},$args->{'ccuname'},$args->{'ccdomain'})) {	} elsif (&Apache::lonnet::is_course_owner($args->{'clonedomain'},$args->{'clonecourse'},
	$args->{'ccuname'},$args->{'ccdomain'})) {
$can_clone = 1;	$can_clone = 1;
	}
	}
	unless ($can_clone) {
	if ($args->{'crstype'} eq 'Community') {
	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 {
if ($args->{'crstype'} eq 'Community') {	push(@clonemsg,({
$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'});	mt => 'No new course created.',
} else {	args => [],
$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'});	},
}	{
}	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 14146 sub construct_course {	Line 15355 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 14175 sub construct_course {	Line 15377 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]',$crstype,$$courseid).$linefeed;	if (($callercontext eq 'auto') && ($user_lh ne '')) {
	$outcome .= &mt_user($user_lh,'New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
	} else {
	$outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
	}
if ($$courseid =~ /^error:/) {	if ($$courseid =~ /^error:/) {
return (0,$outcome);	return (0,$outcome,$clonemsgref);
}	}

#	#
Line 14192 sub construct_course {	Line 15399 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]',$crstype,$clonehome);	push(@clonemsg,
if ($context ne 'auto') {	{
$clonemsg = '<span class="LC_success">'.$clonemsg.'</span>';	mt => 'Created [_1] by cloning from [_2]',
}	args => [$crstype,$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 14284 sub construct_course {	Line 15505 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 14312 sub construct_course {	Line 15533 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 14347 sub construct_course {	Line 15568 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'}) {
$args->{'endaccess'} = 0;	$args->{'endaccess'} = 0;
Line 14400 sub construct_course {	Line 15622 sub construct_course {
if ($args->{'setcontent'}) {	if ($args->{'setcontent'}) {
$cenv{'question.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};	$cenv{'question.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
}	}
	if ($args->{'setcomment'}) {
	$cenv{'comment.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
	}
}	}
if ($args->{'reshome'}) {	if ($args->{'reshome'}) {
$cenv{'reshome'}=$args->{'reshome'}.'/';	$cenv{'reshome'}=$args->{'reshome'}.'/';
Line 14471 sub construct_course {	Line 15696 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 14506 sub construct_course {	Line 15736 sub construct_course {
$outcome .= ($fatal?$errtext:'write ok').$linefeed;	$outcome .= ($fatal?$errtext:'write ok').$linefeed;
}	}

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

sub make_unique_code {	sub make_unique_code {
Line 14675 sub compare_arrays {	Line 15905 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 14710 sub init_user_environment {	Line 15958 sub init_user_environment {
opendir(DIR,$lonids);	opendir(DIR,$lonids);
while ($filename=readdir(DIR)) {	while ($filename=readdir(DIR)) {
if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {	if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {
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 14761 sub init_user_environment {	Line 16025 sub init_user_environment {
# --------------------------------------------------------- Write first profile	# --------------------------------------------------------- Write first profile

{	{
	my $ip = &Apache::lonnet::get_requestor_ip();
my %initial_env =	my %initial_env =
("user.name" => $username,	("user.name" => $username,
"user.domain" => $domain,	"user.domain" => $domain,
Line 14779 sub init_user_environment {	Line 16044 sub init_user_environment {
"request.course.sec" => '',	"request.course.sec" => '',
"request.role" => 'cm',	"request.role" => 'cm',
"request.role.adv" => $env{'user.adv'},	"request.role.adv" => $env{'user.adv'},
"request.host" => $ENV{'REMOTE_ADDR'},);	"request.host" => $ip,);

if ($form->{'localpath'}) {	if ($form->{'localpath'}) {
$initial_env{"browser.localpath"} = $form->{'localpath'};	$initial_env{"browser.localpath"} = $form->{'localpath'};
Line 14798 sub init_user_environment {	Line 16063 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') {	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);	}
}
	foreach my $crstype ('official','unofficial','community','textbook') {
	$userenv{'canrequest.'.$crstype} =
	&Apache::lonnet::usertools_access($username,$domain,$crstype,
	'reload','requestcourses',
	\%userenv,\%domdef,\%is_adv);
	}

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

Line 15341 cloneruname - optional username of new c	Line 16614 cloneruname - optional username of new c

clonerudom - optional domain of new course owner	clonerudom - optional domain of new course owner

domcloner - Optional "domcloner" flag; has value=1 if user has ccc priv in domain being filtered by,	domcloner - optional "domcloner" flag; has value=1 if user has ccc priv in domain being filtered by,
(used when DC is using course creation form)	(used when DC is using course creation form)

codetitles - reference to array of titles of components in institutional codes (official courses).	codetitles - reference to array of titles of components in institutional codes (official courses).

	cc_clone - escaped comma separated list of courses for which course cloner has active CC role
	(and so can clone automatically)

	reqcrsdom - domain of new course, where search_courses is used to identify potential courses to clone

	reqinstcode - institutional code of new course, where search_courses is used to identify potential
	courses to clone

Returns: %courses - hash of courses satisfying search criteria, keys = course IDs, values are corresponding colon-separated escaped description, institutional code, owner and type.	Returns: %courses - hash of courses satisfying search criteria, keys = course IDs, values are corresponding colon-separated escaped description, institutional code, owner and type.

Line 15356 Side Effects: None	Line 16636 Side Effects: None


sub search_courses {	sub search_courses {
my ($dom,$type,$filter,$numtitles,$cloneruname,$clonerudom,$domcloner,$codetitles) = @_;	my ($dom,$type,$filter,$numtitles,$cloneruname,$clonerudom,$domcloner,$codetitles,
	$cc_clone,$reqcrsdom,$reqinstcode) = @_;
my (%courses,%showcourses,$cloner);	my (%courses,%showcourses,$cloner);
if (($filter->{'ownerfilter'} ne '') \|\|	if (($filter->{'ownerfilter'} ne '') \|\|
($filter->{'ownerdomfilter'} ne '')) {	($filter->{'ownerdomfilter'} ne '')) {
Line 15404 sub search_courses {	Line 16685 sub search_courses {
$filter->{'combownerfilter'},	$filter->{'combownerfilter'},
$filter->{'coursefilter'},	$filter->{'coursefilter'},
undef,undef,$type,$regexpok,undef,undef,	undef,undef,$type,$regexpok,undef,undef,
undef,undef,$cloner,$env{'form.cc_clone'},	undef,undef,$cloner,$cc_clone,
$filter->{'cloneableonly'},	$filter->{'cloneableonly'},
$createdbefore,$createdafter,undef,	$createdbefore,$createdafter,undef,
$domcloner);	$domcloner,undef,$reqcrsdom,$reqinstcode);
if (($filter->{'personfilter'} ne '') && ($filter->{'persondomfilter'} ne '')) {	if (($filter->{'personfilter'} ne '') && ($filter->{'persondomfilter'} ne '')) {
my $ccrole;	my $ccrole;
if ($type eq 'Community') {	if ($type eq 'Community') {
Line 15427 sub search_courses {	Line 16708 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 15623 sub needs_coursereinit {	Line 16904 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 15757 sub recurse_supplemental {	Line 17042 sub recurse_supplemental {
}	}

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 15766 sub symb_to_docspath {	Line 17051 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 15778 sub symb_to_docspath {	Line 17065 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 15825 sub symb_to_docspath {	Line 17112 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) = &get_captcha_config($context,$lonhost);	my ($captcha,$pubkey,$privkey,$version) =
	&get_captcha_config($context,$lonhost,$defdom);
if ($captcha eq 'original') {	if ($captcha eq 'original') {
$output = &create_captcha();	$output = &create_captcha();
unless ($output) {	unless ($output) {
$error = 'captcha';	$error = 'captcha';
}	}
} elsif ($captcha eq 'recaptcha') {	} elsif ($captcha eq 'recaptcha') {
$output = &create_recaptcha($pubkey);	$output = &create_recaptcha($pubkey,$version);
unless ($output) {	unless ($output) {
$error = 'recaptcha';	$error = 'recaptcha';
}	}
}	}
return ($output,$error,$captcha);	return ($output,$error,$captcha,$version);
}	}

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) = &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') {
$captcha_chk = &check_recaptcha($privkey);	$captcha_chk = &check_recaptcha($privkey,$version);
} else {	} else {
$captcha_chk = 1;	$captcha_chk = 1;
}	}
Line 15857 sub captcha_response {	Line 17145 sub captcha_response {
}	}

sub get_captcha_config {	sub get_captcha_config {
my ($context,$lonhost) = @_;	my ($context,$lonhost,$dom_in_effect) = @_;
my ($captcha,$pubkey,$privkey,$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);
my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID);	my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID);
Line 15874 sub get_captcha_config {	Line 17162 sub get_captcha_config {
}	}
if ($privkey && $pubkey) {	if ($privkey && $pubkey) {
$captcha = 'recaptcha';	$captcha = 'recaptcha';
	$version = $hashtocheck->{'recaptchaversion'};
	if ($version ne '2') {
	$version = 1;
	}
} else {	} else {
$captcha = 'original';	$captcha = 'original';
}	}
Line 15891 sub get_captcha_config {	Line 17183 sub get_captcha_config {
$privkey = $domconfhash{$serverhomedom.'.login.recaptchakeys_private'};	$privkey = $domconfhash{$serverhomedom.'.login.recaptchakeys_private'};
if ($privkey && $pubkey) {	if ($privkey && $pubkey) {
$captcha = 'recaptcha';	$captcha = 'recaptcha';
	$version = $domconfhash{$serverhomedom.'.login.recaptchaversion'};
	if ($version ne '2') {
	$version = 1;
	}
} else {	} else {
$captcha = 'original';	$captcha = 'original';
}	}
} 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);	return ($captcha,$pubkey,$privkey,$version);
}	}

sub create_captcha {	sub create_captcha {
Line 15957 sub check_captcha {	Line 17274 sub check_captcha {
}	}

sub create_recaptcha {	sub create_recaptcha {
my ($pubkey) = @_;	my ($pubkey,$version) = @_;
my $use_ssl;	if ($version >= 2) {
if ($ENV{'SERVER_PORT'} == 443) {	return '<div class="g-recaptcha" data-sitekey="'.$pubkey.'"></div>';
$use_ssl = 1;	} else {
}	my $use_ssl;
my $captcha = Captcha::reCAPTCHA->new;	if ($ENV{'SERVER_PORT'} == 443) {
return $captcha->get_options_setter({theme => 'white'})."\n".	$use_ssl = 1;
$captcha->get_html($pubkey,undef,$use_ssl).	}
&mt('If the text is hard to read, [_1] will replace them.',	my $captcha = Captcha::reCAPTCHA->new;
'<img src="/res/adm/pages/refresh.gif" alt="reCAPTCHA refresh" />').	return $captcha->get_options_setter({theme => 'white'})."\n".
'<br /><br />';	$captcha->get_html($pubkey,undef,$use_ssl).
	&mt('If the text is hard to read, [_1] will replace them.',
	'<img src="/res/adm/pages/refresh.gif" alt="reCAPTCHA refresh" />').
	'<br /><br />';
	}
}	}

sub check_recaptcha {	sub check_recaptcha {
my ($privkey) = @_;	my ($privkey,$version) = @_;
my $captcha_chk;	my $captcha_chk;
my $captcha = Captcha::reCAPTCHA->new;	my $ip = &Apache::lonnet::get_requestor_ip();
my $captcha_result =	if ($version >= 2) {
$captcha->check_answer(	my $ua = LWP::UserAgent->new;
$privkey,	$ua->timeout(10);
$ENV{'REMOTE_ADDR'},	my %info = (
$env{'form.recaptcha_challenge_field'},	secret => $privkey,
$env{'form.recaptcha_response_field'},	response => $env{'form.g-recaptcha-response'},
);	remoteip => $ip,
if ($captcha_result->{is_valid}) {	);
$captcha_chk = 1;	my $response = $ua->post('https://www.google.com/recaptcha/api/siteverify',\%info);
	if ($response->is_success) {
	my $data = JSON::DWIW->from_json($response->decoded_content);
	if (ref($data) eq 'HASH') {
	if ($data->{'success'}) {
	$captcha_chk = 1;
	}
	}
	}
	} else {
	my $captcha = Captcha::reCAPTCHA->new;
	my $captcha_result =
	$captcha->check_answer(
	$privkey,
	$ip,
	$env{'form.recaptcha_challenge_field'},
	$env{'form.recaptcha_response_field'},
	);
	if ($captcha_result->{is_valid}) {
	$captcha_chk = 1;
	}
}	}
return $captcha_chk;	return $captcha_chk;
}	}

sub emailusername_info {	sub emailusername_info {
my @fields = ('firstname','lastname','institution','web','location','officialemail');	my @fields = ('firstname','lastname','institution','web','location','officialemail','id');
my %titles = &Apache::lonlocal::texthash (	my %titles = &Apache::lonlocal::texthash (
lastname => 'Last Name',	lastname => 'Last Name',
firstname => 'First Name',	firstname => 'First Name',
Line 15996 sub emailusername_info {	Line 17337 sub emailusername_info {
location => "School's city, state/province, country",	location => "School's city, state/province, country",
web => "School's web address",	web => "School's web address",
officialemail => 'E-mail address at institution (if different)',	officialemail => 'E-mail address at institution (if different)',
	id => 'Student/Employee ID',
);	);
return (\@fields,\%titles);	return (\@fields,\%titles);
}	}
Line 16024 sub cleanup_html {	Line 17366 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 16076 sub des_decrypt {	Line 17434 sub des_decrypt {
} else {	} else {
$cypher=new DES $keybin;	$cypher=new DES $keybin;
}	}
my $plaintext=	my $plaintext='';
$cypher->decrypt(unpack("a8",pack("H16",substr($cyphertext,0,16))));	my $cypherlength = length($cyphertext);
$plaintext.=	my $numchunks = int($cypherlength/32);
$cypher->decrypt(unpack("a8",pack("H16",substr($cyphertext,16,16))));	for (my $j=0; $j<$numchunks; $j++) {
$plaintext=substr($plaintext,1,ord(substr($plaintext,0,1)) );	my $start = $j*32;
	my $cypherblock = substr($cyphertext,$start,32);
	my $chunk =
	$cypher->decrypt(unpack("a8",pack("H16",substr($cypherblock,0,16))));
	$chunk .=
	$cypher->decrypt(unpack("a8",pack("H16",substr($cypherblock,16,16))));
	$chunk=substr($chunk,1,ord(substr($chunk,0,1)) );
	$plaintext .= $chunk;
	}
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'));
	}
	}
	}
	}
	}
	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;
	$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 $ua = LWP::UserAgent->new;
	$ua->timeout(5);
	my $response=$ua->request($request);
	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.1075.2.94
changed lines
	Added in v.1.1075.2.141.2.16