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.175 and 1.269

version 1.175, 2004/01/19 16:53:34	version 1.269, 2005/07/05 18:59:03
Line 55 redundancy from other modules and increa	Line 55 redundancy from other modules and increa
package Apache::loncommon;	package Apache::loncommon;

use strict;	use strict;
use Apache::lonnet();	use Apache::lonnet;
use GDBM_File;	use GDBM_File;
use POSIX qw(strftime mktime);	use POSIX qw(strftime mktime);
use Apache::Constants qw(:common :http :methods);	use Apache::Constants qw(:common :http :methods);
use Apache::lonmsg();
use Apache::lonmenu();	use Apache::lonmenu();
use Apache::lonlocal;	use Apache::lonlocal;
use HTML::Entities;	use HTML::Entities;
Line 74 my $readit;	Line 73 my $readit;
my %language;	my %language;
my %supported_language;	my %supported_language;
my %cprtag;	my %cprtag;
	my %scprtag;
my %fe; my %fd;	my %fe; my %fd;
my %category_extensions;	my %category_extensions;

Line 131 BEGIN {	Line 131 BEGIN {
close($fh);	close($fh);
}	}
}	}
	# ------------------------------------------------------------------ source copyrights
	{
	my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
	'/source_copyright.tab';
	if ( open (my $fh,"<$sourcecopyrightfile") ) {
	while (<$fh>) {
	next if /^\#/;
	chomp;
	my ($key,$val)=(split(/\s+/,$_,2));
	$scprtag{$key}=$val;
	}
	close($fh);
	}
	}

# -------------------------------------------------------------- domain designs	# -------------------------------------------------------------- domain designs

Line 220 formname and elementname indicate the na	Line 234 formname and elementname indicate the na
the element that the results of the browsing selection are to be placed in.	the element that the results of the browsing selection are to be placed in.

Specifying 'only' will restrict the browser to displaying only files	Specifying 'only' will restrict the browser to displaying only files
with the given extension. Can be a comma seperated list.	with the given extension. Can be a comma separated list.

Specifying 'omit' will restrict the browser to NOT displaying files	Specifying 'omit' will restrict the browser to NOT displaying files
with the given extension. Can be a comma seperated list.	with the given extension. Can be a comma separated list.

=item * opensearcher(formname, elementname) [javascript]	=item * opensearcher(formname, elementname) [javascript]

Line 235 of the element the selection from the se	Line 249 of the element the selection from the se
=cut	=cut

sub browser_and_searcher_javascript {	sub browser_and_searcher_javascript {
	my ($mode)=@_;
	if (!defined($mode)) { $mode='edit'; }
my $resurl=&lastresurl();	my $resurl=&lastresurl();
return <<END;	return <<END;
	// <!-- BEGIN LON-CAPA Internal
var editbrowser = null;	var editbrowser = null;
function openbrowser(formname,elementname,only,omit,titleelement) {	function openbrowser(formname,elementname,only,omit,titleelement) {
var url = '$resurl/?';	var url = '$resurl/?';
Line 244 sub browser_and_searcher_javascript {	Line 261 sub browser_and_searcher_javascript {
url += 'launch=1&';	url += 'launch=1&';
}	}
url += 'catalogmode=interactive&';	url += 'catalogmode=interactive&';
url += 'mode=edit&';	url += 'mode=$mode&';
url += 'form=' + formname + '&';	url += 'form=' + formname + '&';
if (only != null) {	if (only != null) {
url += 'only=' + only + '&';	url += 'only=' + only + '&';
}	} else {
	url += 'only=&';
	}
if (omit != null) {	if (omit != null) {
url += 'omit=' + omit + '&';	url += 'omit=' + omit + '&';
}	} else {
	url += 'omit=&';
	}
if (titleelement != null) {	if (titleelement != null) {
url += 'titleelement=' + titleelement + '&';	url += 'titleelement=' + titleelement + '&';
}	} else {
	url += 'titleelement=&';
	}
url += 'element=' + elementname + '';	url += 'element=' + elementname + '';
var title = 'Browser';	var title = 'Browser';
var options = 'scrollbars=1,resizable=1,menubar=0';	var options = 'scrollbars=1,resizable=1,menubar=1,location=1';
options += ',width=700,height=600';	options += ',width=700,height=600';
editbrowser = open(url,title,options,'1');	editbrowser = open(url,title,options,'1');
editbrowser.focus();	editbrowser.focus();
Line 269 sub browser_and_searcher_javascript {	Line 292 sub browser_and_searcher_javascript {
url += 'launch=1&';	url += 'launch=1&';
}	}
url += 'catalogmode=interactive&';	url += 'catalogmode=interactive&';
url += 'mode=edit&';	url += 'mode=$mode&';
url += 'form=' + formname + '&';	url += 'form=' + formname + '&';
if (titleelement != null) {	if (titleelement != null) {
url += 'titleelement=' + titleelement + '&';	url += 'titleelement=' + titleelement + '&';
}	} else {
	url += 'titleelement=&';
	}
url += 'element=' + elementname + '';	url += 'element=' + elementname + '';
var title = 'Search';	var title = 'Search';
var options = 'scrollbars=1,resizable=1,menubar=0';	var options = 'scrollbars=1,resizable=1,menubar=0';
Line 281 sub browser_and_searcher_javascript {	Line 306 sub browser_and_searcher_javascript {
editsearcher = open(url,title,options,'1');	editsearcher = open(url,title,options,'1');
editsearcher.focus();	editsearcher.focus();
}	}
	// END LON-CAPA Internal -->
END	END
}	}

sub lastresurl {	sub lastresurl {
if ($ENV{'environment.lastresurl'}) {	if ($env{'environment.lastresurl'}) {
return $ENV{'environment.lastresurl'}	return $env{'environment.lastresurl'}
} else {	} else {
return '/res';	return '/res';
}	}
Line 303 sub storeresurl {	Line 329 sub storeresurl {

sub studentbrowser_javascript {	sub studentbrowser_javascript {
unless (	unless (
(($ENV{'request.course.id'}) &&	(($env{'request.course.id'}) &&
(&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})))	(&Apache::lonnet::allowed('srm',$env{'request.course.id'})))
\|\| ($ENV{'request.role'}=~/^(au\|dc\|su)/)	\|\| ($env{'request.role'}=~/^(au\|dc\|su)/)
) { return ''; }	) { return ''; }
return (<<'ENDSTDBRW');	return (<<'ENDSTDBRW');
<script type="text/javascript" language="Javascript" >	<script type="text/javascript" language="Javascript" >
Line 334 ENDSTDBRW	Line 360 ENDSTDBRW

sub selectstudent_link {	sub selectstudent_link {
my ($form,$unameele,$udomele)=@_;	my ($form,$unameele,$udomele)=@_;
if ($ENV{'request.course.id'}) {	if ($env{'request.course.id'}) {
unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) {	unless (&Apache::lonnet::allowed('srm',$env{'request.course.id'})) {
return '';	return '';
}	}
return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.	return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
'","'.$udomele.'");'."'>".&mt('Select User')."</a>";	'","'.$udomele.'");'."'>".&mt('Select User')."</a>";
}	}
if ($ENV{'request.role'}=~/^(au\|dc\|su)/) {	if ($env{'request.role'}=~/^(au\|dc\|su)/) {
return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.	return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
'","'.$udomele.'",1);'."'>".&mt('Select User')."</a>";	'","'.$udomele.'",1);'."'>".&mt('Select User')."</a>";
}	}
Line 353 sub coursebrowser_javascript {	Line 379 sub coursebrowser_javascript {
return (<<ENDSTDBRW);	return (<<ENDSTDBRW);
<script type="text/javascript" language="Javascript" >	<script type="text/javascript" language="Javascript" >
var stdeditbrowser;	var stdeditbrowser;
function opencrsbrowser(formname,uname,udom) {	function opencrsbrowser(formname,uname,udom,desc,extra_element) {
var url = '/adm/pickcourse?';	var url = '/adm/pickcourse?';
var filter;	var filter;
if (filter != null) {	if (filter != null) {
Line 368 sub coursebrowser_javascript {	Line 394 sub coursebrowser_javascript {
}	}
}	}
url += 'form=' + formname + '&cnumelement='+uname+	url += 'form=' + formname + '&cnumelement='+uname+
'&cdomelement='+udom;	'&cdomelement='+udom+
	'&cnameelement='+desc;
	if (extra_element !=null && extra_element != '' && formname == 'rolechoice') {
	url += '&roleelement='+extra_element;
	if (domainfilter == null \|\| domainfilter == '') {
	url += '&domainfilter='+extra_element;
	}
	}
var title = 'Course_Browser';	var title = 'Course_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 380 ENDSTDBRW	Line 413 ENDSTDBRW
}	}

sub selectcourse_link {	sub selectcourse_link {
my ($form,$unameele,$udomele)=@_;	my ($form,$unameele,$udomele,$desc,$extra_element)=@_;
return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.	return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.
'","'.$udomele.'");'."'>".&mt('Select Course')."</a>";	'","'.$udomele.'","'.$desc.'","'.$extra_element.'");'."'>".&mt('Select Course')."</a>";
}	}

=pod	=pod
Line 465 sub linked_select_forms {	Line 498 sub linked_select_forms {
my $first = "document.$formname.$firstselectname";	my $first = "document.$formname.$firstselectname";
# output the javascript to do the changing	# output the javascript to do the changing
my $result = '';	my $result = '';
$result.="<script>\n";	$result.="<script type=\"text/javascript\">\n";
$result.="var select2data = new Object();\n";	$result.="var select2data = new Object();\n";
$" = '","';	$" = '","';
my $debug = '';	my $debug = '';
Line 514 END	Line 547 END
$result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";	$result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
foreach my $value (sort(keys(%$hashref))) {	foreach my $value (sort(keys(%$hashref))) {
$result.=" <option value=\"$value\" ";	$result.=" <option value=\"$value\" ";
$result.=" selected=\"true\" " if ($value eq $firstdefault);	$result.=" selected=\"selected\" " if ($value eq $firstdefault);
$result.=">".&mt($hashref->{$value}->{'text'})."</option>\n";	$result.=">".&mt($hashref->{$value}->{'text'})."</option>\n";
}	}
$result .= "</select>\n";	$result .= "</select>\n";
Line 524 END	Line 557 END
my $seconddefault = $hashref->{$firstdefault}->{'default'};	my $seconddefault = $hashref->{$firstdefault}->{'default'};
foreach my $value (sort(keys(%select2))) {	foreach my $value (sort(keys(%select2))) {
$result.=" <option value=\"$value\" ";	$result.=" <option value=\"$value\" ";
$result.=" selected=\"true\" " if ($value eq $seconddefault);	$result.=" selected=\"selected\" " if ($value eq $seconddefault);
$result.=">".&mt($select2{$value})."</option>\n";	$result.=">".&mt($select2{$value})."</option>\n";
}	}
$result .= "</select>\n";	$result .= "</select>\n";
Line 560 sub help_open_topic {	Line 593 sub help_open_topic {
my ($topic, $text, $stayOnPage, $width, $height) = @_;	my ($topic, $text, $stayOnPage, $width, $height) = @_;
$text = "" if (not defined $text);	$text = "" if (not defined $text);
$stayOnPage = 0 if (not defined $stayOnPage);	$stayOnPage = 0 if (not defined $stayOnPage);
if ($ENV{'browser.interface'} eq 'textual' \|\|	if ($env{'browser.interface'} eq 'textual' \|\|
$ENV{'environment.remote'} eq 'off' ) {	$env{'environment.remote'} eq 'off' ) {
$stayOnPage=1;	$stayOnPage=1;
}	}
$width = 350 if (not defined $width);	$width = 350 if (not defined $width);
Line 592 sub help_open_topic {	Line 625 sub help_open_topic {
}	}

# Add the graphic	# Add the graphic
	my $title = &mt('Online Help');
	my $helpicon=&lonhttpdurl("/adm/help/gif/smallHelp.gif");
$template .= <<"ENDTEMPLATE";	$template .= <<"ENDTEMPLATE";
<a href="$link" title="Online Help"><image src="/adm/help/gif/smallHelp.gif" border="0" alt="(Help: $topic)" /></a>	<a href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help: $topic)" /></a>
ENDTEMPLATE	ENDTEMPLATE
if ($text ne '') { $template.='</td></tr></table>' };	if ($text ne '') { $template.='</td></tr></table>' };
return $template;	return $template;
Line 620 sub helpLatexCheatsheet {	Line 655 sub helpLatexCheatsheet {
.'</td></tr></table>';	.'</td></tr></table>';
}	}

	sub help_open_menu {
	my ($color,$topic,$component_help,$function,$faq,$bug,$stayOnPage,$width,$height,$text) = @_;
	$text = "" if (not defined $text);
	$stayOnPage = 0 if (not defined $stayOnPage);
	if ($env{'browser.interface'} eq 'textual' \|\|
	$env{'environment.remote'} eq 'off' ) {
	$stayOnPage=1;
	}
	$width = 620 if (not defined $width);
	$height = 600 if (not defined $height);
	my $link='';
	my $title = &mt('Get help');
	my $origurl = $ENV{'REQUEST_URI'};
	$origurl=~s\|^/~\|/priv/\|;
	my $timestamp = time;
	foreach (\$color,\$function,\$topic,\$component_help,\$faq,\$bug,\$origurl) {
	$$_ = &Apache::lonnet::escape($$_);
	}
	if (!$stayOnPage) {
	$link = "javascript:helpMenu('open')";
	} else {
	$link = "javascript:helpMenu('display')";
	}
	my $banner_link = "/adm/helpmenu?page=banner&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp&stayonpage=$stayOnPage";
	my $details_link = "/adm/helpmenu?page=body&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp";
	my $template;
	if ($text ne "") {
	$template .=
	"<table bgcolor='#CC3300' cellspacing='1' cellpadding='1' border='0'><tr>".
	"<td bgcolor='#CC6600'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
	}
	my $nothing=&Apache::lonhtmlcommon::javascript_nothing();
	my $html=&Apache::lonxml::xmlbegin();
	my $helpicon=&lonhttpdurl("/adm/lonIcons/helpgateway.gif");
	$template .= <<"ENDTEMPLATE";
	<script type="text/javascript">
	// <!-- BEGIN LON-CAPA Internal
	// <![CDATA[
	function helpMenu(target) {
	var caller = this;
	if (target == 'open') {
	var newWindow = null;
	try {
	newWindow = window.open($nothing,"helpmenu","HEIGHT=$height,WIDTH=$width,resizable=yes,scrollbars=yes" )
	}
	catch(error) {
	writeHelp(caller);
	return;
	}
	if (newWindow) {
	caller = newWindow;
	}
	}
	writeHelp(caller);
	return;
	}
	function writeHelp(caller) {
	caller.document.writeln('$html<head><title>LON-CAPA Help Menu</title><meta http-equiv="pragma" content="no-cache"></head>')
	caller.document.writeln("<frameset rows='105,*' border='0'><frame name='bannerframe' src='$banner_link'><frame name='bodyframe' src='$details_link'></frameset>")
	caller.document.writeln("</html>")
	caller.document.close()
	caller.focus()
	}
	// ]]>
	// END LON-CAPA Internal -->
	</script>
	<a href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help Menu)" /></a>
	ENDTEMPLATE
	if ($component_help) {
	if (!$text) {
	$template=&help_open_topic($component_help,undef,$stayOnPage,
	$width,$height).' '.$template;
	} else {
	my $help_text;
	$help_text=&Apache::lonnet::unescape($topic);
	$template='<table><tr><td>'.
	&help_open_topic($component_help,$help_text,$stayOnPage,
	$width,$height).'</td><td>'.$template.
	'</td></tr></table>';
	}
	}
	if ($text ne '') { $template.='</td></tr></table>' };
	return $template;
	}

sub help_open_bug {	sub help_open_bug {
my ($topic, $text, $stayOnPage, $width, $height) = @_;	my ($topic, $text, $stayOnPage, $width, $height) = @_;
unless ($ENV{'user.adv'}) { return ''; }	unless ($env{'user.adv'}) { return ''; }
unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; }	unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; }
$text = "" if (not defined $text);	$text = "" if (not defined $text);
$stayOnPage = 0 if (not defined $stayOnPage);	$stayOnPage = 0 if (not defined $stayOnPage);
if ($ENV{'browser.interface'} eq 'textual' \|\|	if ($env{'browser.interface'} eq 'textual' \|\|
$ENV{'environment.remote'} eq 'off' ) {	$env{'environment.remote'} eq 'off' ) {
$stayOnPage=1;	$stayOnPage=1;
}	}
$width = 350 if (not defined $width);	$width = 600 if (not defined $width);
$height = 400 if (not defined $height);	$height = 600 if (not defined $height);

$topic=~s/\W+/\+/g;	$topic=~s/\W+/\+/g;
my $link='';	my $link='';
Line 655 sub help_open_bug {	Line 775 sub help_open_bug {
}	}

# Add the graphic	# Add the graphic
	my $title = &mt('Report a Bug');
	my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif");
$template .= <<"ENDTEMPLATE";	$template .= <<"ENDTEMPLATE";
<a href="$link" title="Report a Bug"><image src="/adm/lonMisc/smallBug.gif" border="0" alt="(Bug: $topic)" /></a>	<a href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a>
ENDTEMPLATE	ENDTEMPLATE
if ($text ne '') { $template.='</td></tr></table>' };	if ($text ne '') { $template.='</td></tr></table>' };
return $template;	return $template;
Line 665 ENDTEMPLATE	Line 787 ENDTEMPLATE

sub help_open_faq {	sub help_open_faq {
my ($topic, $text, $stayOnPage, $width, $height) = @_;	my ($topic, $text, $stayOnPage, $width, $height) = @_;
unless ($ENV{'user.adv'}) { return ''; }	unless ($env{'user.adv'}) { return ''; }
unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; }	unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; }
$text = "" if (not defined $text);	$text = "" if (not defined $text);
$stayOnPage = 0 if (not defined $stayOnPage);	$stayOnPage = 0 if (not defined $stayOnPage);
if ($ENV{'browser.interface'} eq 'textual' \|\|	if ($env{'browser.interface'} eq 'textual' \|\|
$ENV{'environment.remote'} eq 'off' ) {	$env{'environment.remote'} eq 'off' ) {
$stayOnPage=1;	$stayOnPage=1;
}	}
$width = 350 if (not defined $width);	$width = 350 if (not defined $width);
Line 698 sub help_open_faq {	Line 820 sub help_open_faq {
}	}

# Add the graphic	# Add the graphic
	my $title = &mt('View the FAQ');
	my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif");
$template .= <<"ENDTEMPLATE";	$template .= <<"ENDTEMPLATE";
<a href="$link" title="View the FAQ"><image src="/adm/lonMisc/smallFAQ.gif" border="0" alt="(FAQ: $topic)" /></a>	<a href="$link" title="$title"><img src="$faqicon" border="0" alt="(FAQ: $topic)" /></a>
ENDTEMPLATE	ENDTEMPLATE
if ($text ne '') { $template.='</td></tr></table>' };	if ($text ne '') { $template.='</td></tr></table>' };
return $template;	return $template;

}	}

=pod	###############################################################
	###############################################################
=item * csv_translate($text)

Translate $text to allow it to be output as a 'comma seperated values'
format.

=cut

sub csv_translate {
my $text = shift;
$text =~ s/\"/\"\"/g;
$text =~ s/\n//g;
return $text;
}

=pod	=pod

Line 754 pretty much any HTML.	Line 865 pretty much any HTML.

sub change_content_javascript {	sub change_content_javascript {
# If we're on Netscape 4, we need to use Layer-based code	# If we're on Netscape 4, we need to use Layer-based code
if ($ENV{'browser.type'} eq 'netscape' &&	if ($env{'browser.type'} eq 'netscape' &&
$ENV{'browser.version'} =~ /^4\./) {	$env{'browser.version'} =~ /^4\./) {
return (<<NETSCAPE4);	return (<<NETSCAPE4);
function change(name, content) {	function change(name, content) {
doc = document.layers[name+"___escape"].layers[0].document;	doc = document.layers[name+"___escape"].layers[0].document;
Line 792 the area will originally contain, which	Line 903 the area will originally contain, which
sub changable_area {	sub changable_area {
my ($name, $origContent) = @_;	my ($name, $origContent) = @_;

if ($ENV{'browser.type'} eq 'netscape' &&	if ($env{'browser.type'} eq 'netscape' &&
$ENV{'browser.version'} =~ /^4\./) {	$env{'browser.version'} =~ /^4\./) {
# If this is netscape 4, we need to use the Layer tag	# If this is netscape 4, we need to use the Layer tag
return "<ilayer width='100%' id='${name}___escape' overflow='none'><layer width='100%' id='$name' overflow='none'>$origContent</layer></ilayer>";	return "<ilayer width='100%' id='${name}___escape' overflow='none'><layer width='100%' id='$name' overflow='none'>$origContent</layer></ilayer>";
} else {	} else {
Line 805 sub changable_area {	Line 916 sub changable_area {

=back	=back

	=head1 Excel and CSV file utility routines

	=over 4

	=cut

	###############################################################
	###############################################################

	=pod

	=item * csv_translate($text)

	Translate $text to allow it to be output as a 'comma separated values'
	format.

	=cut

	###############################################################
	###############################################################
	sub csv_translate {
	my $text = shift;
	$text =~ s/\"/\"\"/g;
	$text =~ s/\n/ /g;
	return $text;
	}

	###############################################################
	###############################################################

	=pod

	=item * define_excel_formats

	Define some commonly used Excel cell formats.

	Currently supported formats:

	=over 4

	=item header

	=item bold

	=item h1

	=item h2

	=item h3

	=item h4

	=item i

	=item date

	=back

	Inputs: $workbook

	Returns: $format, a hash reference.

	=cut

	###############################################################
	###############################################################
	sub define_excel_formats {
	my ($workbook) = @_;
	my $format;
	$format->{'header'} = $workbook->add_format(bold => 1,
	bottom => 1,
	align => 'center');
	$format->{'bold'} = $workbook->add_format(bold=>1);
	$format->{'h1'} = $workbook->add_format(bold=>1, size=>18);
	$format->{'h2'} = $workbook->add_format(bold=>1, size=>16);
	$format->{'h3'} = $workbook->add_format(bold=>1, size=>14);
	$format->{'h4'} = $workbook->add_format(bold=>1, size=>12);
	$format->{'i'} = $workbook->add_format(italic=>1);
	$format->{'date'} = $workbook->add_format(num_format=>
	'mm/dd/yyyy hh:mm:ss');
	return $format;
	}

	###############################################################
	###############################################################

	=pod

	=item * create_workbook

	Create an Excel worksheet. If it fails, output message on the
	request object and return undefs.

	Inputs: Apache request object

	Returns (undef) on failure,
	Excel worksheet object, scalar with filename, and formats
	from &Apache::loncommon::define_excel_formats on success

	=cut

	###############################################################
	###############################################################
	sub create_workbook {
	my ($r) = @_;
	#
	# Create the excel spreadsheet
	my $filename = '/prtspool/'.
	$env{'user.name'}.'_'.$env{'user.domain'}.'_'.
	time.'_'.rand(1000000000).'.xls';
	my $workbook = Spreadsheet::WriteExcel->new('/home/httpd'.$filename);
	if (! defined($workbook)) {
	$r->log_error("Error creating excel spreadsheet $filename: $!");
	$r->print('<p>'.&mt("Unable to create new Excel file. ".
	"This error has been logged. ".
	"Please alert your LON-CAPA administrator").
	'</p>');
	return (undef);
	}
	#
	$workbook->set_tempdir('/home/httpd/perl/tmp');
	#
	my $format = &Apache::loncommon::define_excel_formats($workbook);
	return ($workbook,$filename,$format);
	}

	###############################################################
	###############################################################

	=pod

	=item * create_text_file

	Create a file to write to and eventually make available to the usre.
	If file creation fails, outputs an error message on the request object and
	return undefs.

	Inputs: Apache request object, and file suffix

	Returns (undef) on failure,
	Filehandle and filename on success.

	=cut

	###############################################################
	###############################################################
	sub create_text_file {
	my ($r,$suffix) = @_;
	if (! defined($suffix)) { $suffix = 'txt'; };
	my $fh;
	my $filename = '/prtspool/'.
	$env{'user.name'}.'_'.$env{'user.domain'}.'_'.
	time.'_'.rand(1000000000).'.'.$suffix;
	$fh = Apache::File->new('>/home/httpd'.$filename);
	if (! defined($fh)) {
	$r->log_error("Couldn't open $filename for output $!");
	$r->print("Problems occured in creating the output file. ".
	"This error has been logged. ".
	"Please alert your LON-CAPA administrator.");
	}
	return ($fh,$filename)
	}


	=pod

	=back

=cut	=cut

###############################################################	###############################################################
Line 844 sub domain_select {	Line 1123 sub domain_select {
} &get_domains;	} &get_domains;
if ($multiple) {	if ($multiple) {
$domains{''}=&mt('Any domain');	$domains{''}=&mt('Any domain');
return &multiple_select_form($name,$value,%domains);	return &multiple_select_form($name,$value,4,%domains);
} else {	} else {
return &select_form($name,$value,%domains);	return &select_form($name,$value,%domains);
}	}
}	}

sub multiple_select_form {	sub multiple_select_form {
my ($name,$value,%hash)=@_;	my ($name,$value,$size,%hash)=@_;
my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);	my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);
my $output='';	my $output='';
my $size =(scalar keys %hash<4?scalar keys %hash:4);	if (! defined($size)) {
	$size = 4;
	if (scalar(keys(%hash))<4) {
	$size = scalar(keys(%hash));
	}
	}
$output.="\n<select name='$name' size='$size' multiple='1'>";	$output.="\n<select name='$name' size='$size' multiple='1'>";
foreach (sort keys %hash) {	foreach (sort(keys(%hash))) {
$output.="<option name='$_'".	$output.='<option value="'.$_.'" ';
($selected{$_}?' selected="1"' :'').">$hash{$_}</option>\n";	$output.='selected="selected" ' if ($selected{$_});
	$output.='>'.$hash{$_}."</option>\n";
}	}
$output.="</select>\n";	$output.="</select>\n";
return $output;	return $output;
Line 888 sub select_form {	Line 1173 sub select_form {
}	}
foreach (@keys) {	foreach (@keys) {
$selectform.="<option value=\"$_\" ".	$selectform.="<option value=\"$_\" ".
($_ eq $def ? 'selected' : '').	($_ eq $def ? 'selected="selected" ' : '').
">".&mt($hash{$_})."</option>\n";	">".&mt($hash{$_})."</option>\n";
}	}
$selectform.="</select>";	$selectform.="</select>";
Line 925 sub select_level_form {	Line 1210 sub select_level_form {
my $selectform = "<select name=\"$name\" size=\"1\">\n";	my $selectform = "<select name=\"$name\" size=\"1\">\n";
for (my $i=0; $i<=18; $i++) {	for (my $i=0; $i<=18; $i++) {
$selectform.="<option value=\"$i\" ".	$selectform.="<option value=\"$i\" ".
($i==$deflevel ? 'selected' : '').	($i==$deflevel ? 'selected="selected" ' : '').
">".&gradeleveldescription($i)."</option>\n";	">".&gradeleveldescription($i)."</option>\n";
}	}
$selectform.="</select>";	$selectform.="</select>";
Line 955 sub select_dom_form {	Line 1240 sub select_dom_form {
my $selectdomain = "<select name=\"$name\" size=\"1\">\n";	my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
foreach (@domains) {	foreach (@domains) {
$selectdomain.="<option value=\"$_\" ".	$selectdomain.="<option value=\"$_\" ".
($_ eq $defdom ? 'selected' : '').	($_ eq $defdom ? 'selected="selected" ' : '').
">$_</option>\n";	">$_</option>\n";
}	}
$selectdomain.="</select>";	$selectdomain.="</select>";
Line 1054 Outputs:	Line 1339 Outputs:
###############################################################	###############################################################
###############################################################	###############################################################
sub decode_user_agent {	sub decode_user_agent {
	my ($r)=@_;
my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});	my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});
my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});	my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});
my $httpbrowser=$ENV{"HTTP_USER_AGENT"};	my $httpbrowser=$ENV{"HTTP_USER_AGENT"};
	if (!$httpbrowser && $r) { $httpbrowser=$r->header_in('User-Agent'); }
my $clientbrowser='unknown';	my $clientbrowser='unknown';
my $clientversion='0';	my $clientversion='0';
my $clientmathml='';	my $clientmathml='';
Line 1571 sub get_related_words {	Line 1858 sub get_related_words {

=over 4	=over 4

=item * plainname($uname,$udom)	=item * plainname($uname,$udom,$first)

Takes a users logon name and returns it as a string in	Takes a users logon name and returns it as a string in
"first middle last generation" form	"first middle last generation" form
	if $first is set to 'lastname' then it returns it as
	'lastname generation, firstname middlename' if their is a lastname

=cut	=cut

###############################################################	###############################################################
sub plainname {	sub plainname {
my ($uname,$udom)=@_;	my ($uname,$udom,$first)=@_;
my %names=&Apache::lonnet::get('environment',	my %names=&Apache::lonnet::get('environment',
['firstname','middlename','lastname','generation'],	['firstname','middlename','lastname','generation'],
$udom,$uname);	$udom,$uname);
my $name=$names{'firstname'}.' '.$names{'middlename'}.' '.	my $name=&Apache::lonnet::format_name($names{'firstname'},
$names{'lastname'}.' '.$names{'generation'};	$names{'middlename'},
	$names{'lastname'},
	$names{'generation'},$first);
	$name=~s/^\s+//;
$name=~s/\s+$//;	$name=~s/\s+$//;
$name=~s/\s+/ /g;	$name=~s/\s+/ /g;
	if ($name !~ /\S/) { $name=$uname.'@'.$udom; }
return $name;	return $name;
}	}

Line 1610 if the user does not	Line 1903 if the user does not

sub nickname {	sub nickname {
my ($uname,$udom)=@_;	my ($uname,$udom)=@_;
my %names=&Apache::lonnet::get('environment',	my %names;
['nickname','firstname','middlename','lastname','generation'],$udom,$uname);	if ($uname eq $env{'user.name'} &&
	$udom eq $env{'user.domain'}) {
	%names=('nickname' => $env{'environment.nickname'} ,
	'firstname' => $env{'environment.firstname'} ,
	'middlename' => $env{'environment.middlename'},
	'lastname' => $env{'environment.lastname'} ,
	'generation' => $env{'environment.generation'});
	} else {
	%names=&Apache::lonnet::get('environment',
	['nickname','firstname','middlename',
	'lastname','generation'],$udom,$uname);
	}
my $name=$names{'nickname'};	my $name=$names{'nickname'};
if ($name) {	if ($name) {
$name='"'.$name.'"';	$name='"'.$name.'"';
Line 1637 Gets a users screenname and returns it a	Line 1941 Gets a users screenname and returns it a

sub screenname {	sub screenname {
my ($uname,$udom)=@_;	my ($uname,$udom)=@_;
my %names=	if ($uname eq $env{'user.name'} &&
&Apache::lonnet::get('environment',['screenname'],$udom,$uname);	$udom eq $env{'user.domain'}) {return $env{'environment.screenname'};}
	my %names=&Apache::lonnet::get('environment',['screenname'],$udom,$uname);
return $names{'screenname'};	return $names{'screenname'};
}	}


# ------------------------------------------------------------- Message Wrapper	# ------------------------------------------------------------- Message Wrapper

sub messagewrapper {	sub messagewrapper {
my ($link,$un,$do)=@_;	my ($link,$username,$domain)=@_;
return	return
"<a href='/adm/email?compose=individual&recname=$un&recdom=$do'>$link</a>";	'<a href="/adm/email?compose=individual&'.
	'recname='.$username.'&recdom='.$domain.'" '.
	'title="'.&mt('Send message').'">'.$link.'</a>';
}	}
# --------------------------------------------------------------- Notes Wrapper	# --------------------------------------------------------------- Notes Wrapper

Line 1660 sub noteswrapper {	Line 1968 sub noteswrapper {

sub aboutmewrapper {	sub aboutmewrapper {
my ($link,$username,$domain,$target)=@_;	my ($link,$username,$domain,$target)=@_;
return "<a href='/adm/$domain/$username/aboutme'".	return '<a href="/adm/'.$domain.'/'.$username.'/aboutme"'.
($target?" target='$target'":'').">$link</a>";	($target?' target="$target"':'').' title="'.&mt('View this users personal page').'">'.$link.'</a>';
}	}

# ------------------------------------------------------------ Syllabus Wrapper	# ------------------------------------------------------------ Syllabus Wrapper
Line 1672 sub syllabuswrapper {	Line 1980 sub syllabuswrapper {
if ($fontcolor) {	if ($fontcolor) {
$linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>';	$linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>';
}	}
return "<a href='/public/$domain/$coursedir/syllabus'>$linktext</a>";	return qq{<a href="/public/$domain/$coursedir/syllabus">$linktext</a>};
	}

	sub track_student_link {
	my ($linktext,$sname,$sdom,$target,$start) = @_;
	my $link ="/adm/trackstudent?";
	my $title = 'View recent activity';
	if (defined($sname) && $sname !~ /^\s*$/ &&
	defined($sdom) && $sdom !~ /^\s*$/) {
	$link .= "selected_student=$sname:$sdom";
	$title .= ' of this student';
	}
	if (defined($target) && $target !~ /^\s*$/) {
	$target = qq{target="$target"};
	} else {
	$target = '';
	}
	if ($start) { $link.='&start='.$start; }
	return qq{<a href="$link" title="$title" $target>$linktext</a>};
}	}

=pod	=pod
Line 1744 sub copyrightdescription {	Line 2070 sub copyrightdescription {

=pod	=pod

	=item * source_copyrightids()

	returns list of all source copyrights

	=cut

	sub source_copyrightids {
	return sort(keys(%scprtag));
	}

	=pod

	=item * source_copyrightdescription()

	returns description of a specified source copyright id

	=cut

	sub source_copyrightdescription {
	return &mt($scprtag{shift(@_)});
	}

	=pod

=item * filecategories()	=item * filecategories()

returns list of all file categories	returns list of all file categories
Line 1782 sub fileembstyle {	Line 2132 sub fileembstyle {

sub filecategoryselect {	sub filecategoryselect {
my ($name,$value)=@_;	my ($name,$value)=@_;
return &select_form($name,$value,	return &select_form($value,$name,
'' => &mt('Any category'),	'' => &mt('Any category'),
map { $_,$_ } sort(keys(%category_extensions)));	map { $_,$_ } sort(keys(%category_extensions)));
}	}
Line 1796 returns description for a specified file	Line 2146 returns description for a specified file
=cut	=cut

sub filedescription {	sub filedescription {
return &mt($fd{lc(shift(@_))});	my $file_description = $fd{lc(shift())};
	$file_description =~ s:([\[\]]):~$1:g;
	return &mt($file_description);
}	}

=pod	=pod
Line 1810 extra formatting	Line 2162 extra formatting

sub filedescriptionex {	sub filedescriptionex {
my $ex=shift;	my $ex=shift;
return '.'.$ex.' '.&mt($fd{lc($ex)});	my $file_description = $fd{lc($ex)};
	$file_description =~ s:([\[\]]):~$1:g;
	return '.'.$ex.' '.&mt($file_description);
}	}

# End of .tab access	# End of .tab access
Line 1835 sub display_languages {	Line 2189 sub display_languages {
$languages{$_}=1;	$languages{$_}=1;
}	}
&get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);	&get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
if ($ENV{'form.displaylanguage'}) {	if ($env{'form.displaylanguage'}) {
foreach (split(/\s(\,\|\;\|\:)\s/,$ENV{'form.displaylanguage'})) {	foreach (split(/\s(\,\|\;\|\:)\s/,$env{'form.displaylanguage'})) {
$languages{$_}=1;	$languages{$_}=1;
}	}
}	}
Line 1845 sub display_languages {	Line 2199 sub display_languages {

sub preferred_languages {	sub preferred_languages {
my @languages=();	my @languages=();
if ($ENV{'environment.languages'}) {	if ($env{'course.'.$env{'request.course.id'}.'.languages'}) {
@languages=split(/\s(\,\|\;\|\:)\s/,$ENV{'environment.languages'});
}
if ($ENV{'course.'.$ENV{'request.course.id'}.'.languages'}) {
@languages=(@languages,split(/\s(\,\|\;\|\:)\s/,	@languages=(@languages,split(/\s(\,\|\;\|\:)\s/,
$ENV{'course.'.$ENV{'request.course.id'}.'.languages'}));	$env{'course.'.$env{'request.course.id'}.'.languages'}));
	}
	if ($env{'environment.languages'}) {
	@languages=split(/\s(\,\|\;\|\:)\s/,$env{'environment.languages'});
}	}
my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0];	my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0];
if ($browser) {	if ($browser) {
@languages=(@languages,split(/\s(\,\|\;\|\:)\s/,$browser));	@languages=(@languages,split(/\s(\,\|\;\|\:)\s/,$browser));
}	}
if ($Apache::lonnet::domain_lang_def{$ENV{'user.domain'}}) {	if ($Apache::lonnet::domain_lang_def{$env{'user.domain'}}) {
@languages=(@languages,	@languages=(@languages,
$Apache::lonnet::domain_lang_def{$ENV{'user.domain'}});	$Apache::lonnet::domain_lang_def{$env{'user.domain'}});
}	}
if ($Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}}) {	if ($Apache::lonnet::domain_lang_def{$env{'request.role.domain'}}) {
@languages=(@languages,	@languages=(@languages,
$Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}});	$Apache::lonnet::domain_lang_def{$env{'request.role.domain'}});
}	}
if ($Apache::lonnet::domain_lang_def{	if ($Apache::lonnet::domain_lang_def{
$Apache::lonnet::perlvar{'lonDefDomain'}}) {	$Apache::lonnet::perlvar{'lonDefDomain'}}) {
Line 2031 show a snapshot of what student was look	Line 2385 show a snapshot of what student was look
=cut	=cut

sub get_student_view {	sub get_student_view {
my ($symb,$username,$domain,$courseid,$target) = @_;	my ($symb,$username,$domain,$courseid,$target,$moreenv) = @_;
my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);	my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
my (%old,%moreenv);	my (%form);
my @elements=('symb','courseid','domain','username');	my @elements=('symb','courseid','domain','username');
foreach my $element (@elements) {	foreach my $element (@elements) {
$old{$element}=$ENV{'form.grade_'.$element};	$form{'grade_'.$element}=eval '$'.$element #'
$moreenv{'form.grade_'.$element}=eval '$'.$element #'
}	}
if ($target eq 'tex') {$moreenv{'form.grade_target'} = 'tex';}	if (defined($moreenv)) {
&Apache::lonnet::appenv(%moreenv);	%form=(%form,%{$moreenv});
$feedurl=&Apache::lonnet::clutter($feedurl);
my $userview=&Apache::lonnet::ssi_body($feedurl);
&Apache::lonnet::delenv('form.grade_');
foreach my $element (@elements) {
$ENV{'form.grade_'.$element}=$old{$element};
}	}
	if (defined($target)) { $form{'grade_target'} = $target; }
	$feedurl=&Apache::lonnet::clutter($feedurl);
	my $userview=&Apache::lonnet::ssi_body($feedurl,%form);
$userview=~s/\<body[^\>]*\>//gi;	$userview=~s/\<body[^\>]*\>//gi;
$userview=~s/\<\/body\>//gi;	$userview=~s/\<\/body\>//gi;
$userview=~s/\<html\>//gi;	$userview=~s/\<html\>//gi;
Line 2069 show a snapshot of how student was answe	Line 2420 show a snapshot of how student was answe
sub get_student_answers {	sub get_student_answers {
my ($symb,$username,$domain,$courseid,%form) = @_;	my ($symb,$username,$domain,$courseid,%form) = @_;
my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);	my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
my (%old,%moreenv);	my (%moreenv);
my @elements=('symb','courseid','domain','username');	my @elements=('symb','courseid','domain','username');
foreach my $element (@elements) {	foreach my $element (@elements) {
$old{$element}=$ENV{'form.grade_'.$element};	$moreenv{'grade_'.$element}=eval '$'.$element #'
$moreenv{'form.grade_'.$element}=eval '$'.$element #'
}
$moreenv{'form.grade_target'}='answer';
&Apache::lonnet::appenv(%moreenv);
my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%form);
&Apache::lonnet::delenv('form.grade_');
foreach my $element (@elements) {
$ENV{'form.grade_'.$element}=$old{$element};
}	}
	$moreenv{'grade_target'}='answer';
	%moreenv=(%form,%moreenv);
	my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%moreenv);
return $userview;	return $userview;
}	}

Line 2089 sub get_student_answers {	Line 2435 sub get_student_answers {

=item * &submlink()	=item * &submlink()

Inputs: $text $uname $udom $symb	Inputs: $text $uname $udom $symb $target

Returns: A link to grades.pm such as to see the SUBM view of a student	Returns: A link to grades.pm such as to see the SUBM view of a student

Line 2097 Returns: A link to grades.pm such as to	Line 2443 Returns: A link to grades.pm such as to

###############################################	###############################################
sub submlink {	sub submlink {
my ($text,$uname,$udom,$symb)=@_;	my ($text,$uname,$udom,$symb,$target)=@_;
	if (!($uname && $udom)) {
	(my $cursymb, my $courseid,$udom,$uname)=
	&Apache::lonxml::whichuser($symb);
	if (!$symb) { $symb=$cursymb; }
	}
	if (!$symb) { $symb=&Apache::lonnet::symbread(); }
	$symb=&Apache::lonnet::escape($symb);
	if ($target) { $target="target=\"$target\""; }
	return '<a href="/adm/grades?&command=submission&'.
	'symb='.$symb.'&student='.$uname.
	'&userdom='.$udom.'" '.$target.'>'.$text.'</a>';
	}
	##############################################

	=pod

	=item * &pgrdlink()

	Inputs: $text $uname $udom $symb $target

	Returns: A link to grades.pm such as to see the PGRD view of a student

	=cut

	###############################################
	sub pgrdlink {
	my $link=&submlink(@_);
	$link=~s/(&command=submission)/$1&showgrading=yes/;
	return $link;
	}
	##############################################

	=pod

	=item * &pprmlink()

	Inputs: $text $uname $udom $symb $target

	Returns: A link to parmset.pm such as to see the PPRM view of a
	student andn resource

	=cut

	###############################################
	sub pprmlink {
	my ($text,$uname,$udom,$symb,$target)=@_;
if (!($uname && $udom)) {	if (!($uname && $udom)) {
(my $cursymb, my $courseid,$udom,$uname)=	(my $cursymb, my $courseid,$udom,$uname)=
&Apache::lonxml::whichuser($symb);	&Apache::lonxml::whichuser($symb);
if (!$symb) { $symb=$cursymb; }	if (!$symb) { $symb=$cursymb; }
}	}
if (!$symb) { $symb=&symbread(); }	if (!$symb) { $symb=&Apache::lonnet::symbread(); }
return '<a href="/adm/grades?symb='.$symb.'&student='.$uname.	$symb=&Apache::lonnet::escape($symb);
'&userdom='.$udom.'&command=submission">'.$text.'</a>';	if ($target) { $target="target=\"$target\""; }
	return '<a href="/adm/parmset?&command=set&'.
	'symb='.$symb.'&uname='.$uname.
	'&udom='.$udom.'" '.$target.'>'.$text.'</a>';
}	}
##############################################	##############################################

Line 2135 sub maketime {	Line 2530 sub maketime {
my %th=@_;	my %th=@_;
return POSIX::mktime(	return POSIX::mktime(
($th{'seconds'},$th{'minutes'},$th{'hours'},	($th{'seconds'},$th{'minutes'},$th{'hours'},
$th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,$th{'dlsav'}));	$th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1));
}	}

#########################################	#########################################
Line 2143 sub maketime {	Line 2538 sub maketime {
sub findallcourses {	sub findallcourses {
my %courses=();	my %courses=();
my $now=time;	my $now=time;
foreach (keys %ENV) {	foreach (keys %env) {
if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) {	if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) {
my ($starttime,$endtime)=$ENV{$_};	my ($starttime,$endtime)=$env{$_};
my $active=1;	my $active=1;
if ($starttime) {	if ($starttime) {
if ($now<$starttime) { $active=0; }	if ($now<$starttime) { $active=0; }
Line 2182 sub determinedomain {	Line 2577 sub determinedomain {
if (! $domain) {	if (! $domain) {
# Determine domain if we have not been given one	# Determine domain if we have not been given one
$domain = $Apache::lonnet::perlvar{'lonDefDomain'};	$domain = $Apache::lonnet::perlvar{'lonDefDomain'};
if ($ENV{'user.domain'}) { $domain=$ENV{'user.domain'}; }	if ($env{'user.domain'}) { $domain=$env{'user.domain'}; }
if ($ENV{'request.role.domain'}) {	if ($env{'request.role.domain'}) {
$domain=$ENV{'request.role.domain'};	$domain=$env{'request.role.domain'};
}	}
}	}
return $domain;	return $domain;
Line 2206 sub domainlogo {	Line 2601 sub domainlogo {
my $domain = &determinedomain(shift);	my $domain = &determinedomain(shift);
# See if there is a logo	# See if there is a logo
if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') {	if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') {
my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};	my $logo=&lonhttpdurl("/adm/lonDomLogos/$domain.gif");
if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }	return '<img src="'.$logo.'" alt="'.$domain.'" />';
return '<img src="http://'.$ENV{'HTTP_HOST'}.':'.$lonhttpdPort.
'/adm/lonDomLogos/'.$domain.'.gif" alt="'.$domain.'" />';
} elsif(exists($Apache::lonnet::domaindescription{$domain})) {	} elsif(exists($Apache::lonnet::domaindescription{$domain})) {
return $Apache::lonnet::domaindescription{$domain};	return $Apache::lonnet::domaindescription{$domain};
} else {	} else {
Line 2231 Returns: value of designparamter $which	Line 2624 Returns: value of designparamter $which
##############################################	##############################################
sub designparm {	sub designparm {
my ($which,$domain)=@_;	my ($which,$domain)=@_;
if ($ENV{'browser.blackwhite'} eq 'on') {	if ($env{'browser.blackwhite'} eq 'on') {
if ($which=~/\.(font\|alink\|vlink\|link)$/) {	if ($which=~/\.(font\|alink\|vlink\|link)$/) {
return '#000000';	return '#000000';
}	}
Line 2242 sub designparm {	Line 2635 sub designparm {
return '#CCCCCC';	return '#CCCCCC';
}	}
}	}
if ($ENV{'environment.color.'.$which}) {	if ($env{'environment.color.'.$which}) {
return $ENV{'environment.color.'.$which};	return $env{'environment.color.'.$which};
}	}
$domain=&determinedomain($domain);	$domain=&determinedomain($domain);
if ($designhash{$domain.'.'.$which}) {	if ($designhash{$domain.'.'.$which}) {
Line 2295 other decorations will be returned.	Line 2688 other decorations will be returned.
=cut	=cut

sub bodytag {	sub bodytag {
my ($title,$function,$addentries,$bodyonly,$domain,$forcereg)=@_;	my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle)=@_;
$title=&mt($title);	$title=&mt($title);
unless ($function) {	$function = &get_users_function() if (!$function);
$function='student';
if ($ENV{'request.role'}=~/^(cc\|in\|ta\|ep)/) {
$function='coordinator';
}
if ($ENV{'request.role'}=~/^(su\|dc\|ad\|li)/) {
$function='admin';
}
if (($ENV{'request.role'}=~/^(au\|ca)/) \|\|
($ENV{'REQUEST_URI'}=~/^(\/priv\|\~)/)) {
$function='author';
}
}
my $img=&designparm($function.'.img',$domain);	my $img=&designparm($function.'.img',$domain);
my $pgbg=&designparm($function.'.pgbg',$domain);	my $pgbg=&designparm($function.'.pgbg',$domain);
my $tabbg=&designparm($function.'.tabbg',$domain);	my $tabbg=&designparm($function.'.tabbg',$domain);
Line 2321 sub bodytag {	Line 2702 sub bodytag {
# Accessibility font enhance	# Accessibility font enhance
unless ($addentries) { $addentries=''; }	unless ($addentries) { $addentries=''; }
my $addstyle='';	my $addstyle='';
if ($ENV{'browser.fontenhance'} eq 'on') {	if ($env{'browser.fontenhance'} eq 'on') {
$addstyle=' font-size: x-large;';	$addstyle=' font-size: x-large;';
}	}
# role and realm	# role and realm
my ($role,$realm)	my ($role,$realm)
=&Apache::lonnet::plaintext((split(/\./,$ENV{'request.role'}))[0]);	=&Apache::lonnet::plaintext((split(/\./,$env{'request.role'}))[0]);
# realm	# realm
if ($ENV{'request.course.id'}) {	if ($env{'request.course.id'}) {
$realm=	$realm=
$ENV{'course.'.$ENV{'request.course.id'}.'.description'};	$env{'course.'.$env{'request.course.id'}.'.description'};
}	}
unless ($realm) { $realm=' '; }	unless ($realm) { $realm=' '; }
# Set messages	# Set messages
Line 2340 sub bodytag {	Line 2721 sub bodytag {
if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }	if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
# construct main body tag	# construct main body tag
my $bodytag = <<END;	my $bodytag = <<END;
<style>	<style type="text/css">
h1, h2, h3, th { font-family: Arial, Helvetica, sans-serif }	h1, h2, h3, th { font-family: Arial, Helvetica, sans-serif }
a:focus { color: red; background: yellow }	a:focus { color: red; background: yellow }
</style>	</style>
<body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link"	<body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link"
style="margin-top: 0px;$addstyle" $addentries>	style="margin-top: 0px;$addstyle" $addentries>
END	END
	&Apache::lontexconvert::jsMath_reset();
	if ($env{'environment.texengine'} eq 'jsMath') {
	$bodytag.=&Apache::lontexconvert::jsMath_header();
	}

my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'.	my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'.
$lonhttpdPort.$img.'" alt="'.$function.'" />';	$lonhttpdPort.$img.'" alt="'.$function.'" />';
if ($bodyonly) {	if ($bodyonly) {
return $bodytag;	return $bodytag;
} elsif ($ENV{'browser.interface'} eq 'textual') {	} elsif ($env{'browser.interface'} eq 'textual') {
# Accessibility	# Accessibility

return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',	return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',
$forcereg).	$forcereg).
'<h1>LON-CAPA: '.$title.'</h1>';	'<h1>LON-CAPA: '.$title.'</h1>';
} elsif ($ENV{'environment.remote'} eq 'off') {	} elsif ($env{'environment.remote'} eq 'off') {
# No Remote	# No Remote
return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',	my $roleinfo=(<<ENDROLE);
$forcereg).	<td bgcolor="$tabbg" align="right">
'<table bgcolor="'.$pgbg.'" width="100%" border="0" cellspacing="3" cellpadding="3"><tr><td bgcolor="'.$tabbg.'"><font face="Arial, Helvetica, sans-serif" size="+3" color="'.$font.'"><b>'.$title.	<font size="2" face="Arial, Helvetica, sans-serif">
'</b></font></td></tr></table>';	$env{'environment.firstname'}
	$env{'environment.middlename'}
	$env{'environment.lastname'}
	$env{'environment.generation'}
	</font>
	<br />
	<font size="2" face="Arial, Helvetica, sans-serif">$role</font>
	<br />
	<font size="2" face="Arial, Helvetica, sans-serif">$realm</font>
	</td>
	ENDROLE
	my $titleinfo = '<font face="Arial, Helvetica, sans-serif" size="+3" color="'.
	$font.'"><b>'.$title.'</b></font>';
	if ($customtitle) {
	$titleinfo = $customtitle;
	}

	if ($env{'request.state'} eq 'construct') {
	my ($uname,$thisdisfn)=
	($env{'request.filename'} =~ m\|^/home/([^/]+)/public_html/(.*)\|);
	my $formaction='/priv/'.$uname.'/'.$thisdisfn;
	$formaction=~s/\/+/\//g;
	unless ($customtitle) { #this is for resources; directories have customtitle, and crumbs and select recent are created in lonpubdir.pm
	my $parentpath = '';
	my $lastitem = '';
	if ($thisdisfn =~ m-(.+/)([^/]*)$-) {
	$parentpath = $1;
	$lastitem = $2;
	} else {
	$lastitem = $thisdisfn;
	}
	$titleinfo = &Apache::loncommon::help_open_menu('','','','',3,'Authoring').
	'<font face="Arial, Helvetica, sans-serif"><b>Construction Space</b>:</font> '.
	'<form name="dirs" method="post" action="'.$formaction
	.'" target="_top"><tt><b>'
	.&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv','','+1',1)."<font size=\"+1\">$lastitem</font></b></tt><br />"
	.&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()')
	.'</form>'
	.&Apache::lonmenu::constspaceform();

	}
	$forcereg=1;
	}
	my $titletable = '<table bgcolor="'.$pgbg.'" width="100%" border="0" '.
	'cellspacing="3" cellpadding="3">'.
	'<tr><td rowspan="3" bgcolor="'.$tabbg.'">'.
	$titleinfo.'</td>'.$roleinfo.'</tr></table>';
	if ($env{'request.state'} eq 'construct') {
	$bodytag .= &Apache::lonmenu::menubuttons($forcereg,'web',$forcereg,$titletable);
	} else {
	$bodytag .= &Apache::lonmenu::menubuttons($forcereg,'web',$forcereg).
	$titletable;
	}
	return $bodytag;
}	}

#	#
# Top frame rendering, Remote is up	# Top frame rendering, Remote is up
#	#
	my $titleinfo = ' <font size="5" face="Arial, Helvetica, sans-serif"><b>'.$title.'</b></font>';
	if ($customtitle) {
	$titleinfo = $customtitle;
	}
	#
	# Extra info if you are the DC
	my $dc_info = '';
	if ($env{'user.adv'} && exists($env{'user.role.dc./'.
	$env{'course.'.$env{'request.course.id'}.
	'.domain'}.'/'})) {
	my $cid = $env{'request.course.id'};
	$dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'};
	$dc_info = '('.$dc_info.')';
	}
	#
return(<<ENDBODY);	return(<<ENDBODY);
$bodytag	$bodytag
<table width="100%" cellspacing="0" border="0" cellpadding="0">	<table width="100%" cellspacing="0" border="0" cellpadding="0">
Line 2376 $upperleft</td>	Line 2831 $upperleft</td>
</tr>	</tr>
<tr>	<tr>
<td rowspan="3" bgcolor="$tabbg">	<td rowspan="3" bgcolor="$tabbg">
<font size="5" face="Arial, Helvetica, sans-serif"><b>$title</b></font>	$titleinfo $dc_info
<td bgcolor="$tabbg" align="right">	</td><td bgcolor="$tabbg" align="right">
<font size="2" face="Arial, Helvetica, sans-serif">	<font size="2" face="Arial, Helvetica, sans-serif">
$ENV{'environment.firstname'}	$env{'environment.firstname'}
$ENV{'environment.middlename'}	$env{'environment.middlename'}
$ENV{'environment.lastname'}	$env{'environment.lastname'}
$ENV{'environment.generation'}	$env{'environment.generation'}
</font>	</font>
</td>	</td>
</tr>	</tr>
Line 2391 $upperleft</td>	Line 2846 $upperleft</td>
</td></tr>	</td></tr>
<tr>	<tr>
<td bgcolor="$tabbg" align="right"><font size="2" face="Arial, Helvetica, sans-serif">$realm</font> </td></tr>	<td bgcolor="$tabbg" align="right"><font size="2" face="Arial, Helvetica, sans-serif">$realm</font> </td></tr>
</table><br>	</table><br />
ENDBODY	ENDBODY
}	}

###############################################	###############################################
	###############################################

	=pod

	=back

	=head1 HTTP Helpers

	=over 4

	=item * &endbodytag()

	Returns a uniform footer for LON-CAPA web pages.

	Inputs:

	=over 4

	=back

	Returns: A uniform footer for LON-CAPA web pages.

	=cut

	sub endbodytag {
	my $endbodytag='</body>';
	$endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag;
	return $endbodytag;
	}

	###############################################

	=pod

	=item get_users_function

	Used by &bodytag to determine the current users primary role.
	Returns either 'student','coordinator','admin', or 'author'.

	=cut

	###############################################
	sub get_users_function {
	my $function = 'student';
	if ($env{'request.role'}=~/^(cc\|in\|ta\|ep)/) {
	$function='coordinator';
	}
	if ($env{'request.role'}=~/^(su\|dc\|ad\|li)/) {
	$function='admin';
	}
	if (($env{'request.role'}=~/^(au\|ca)/) \|\|
	($ENV{'REQUEST_URI'}=~/^(\/priv\|\~)/)) {
	$function='author';
	}
	return $function;
	}

	###############################################

	=pod

	=item get_sections

	Determines all the sections for a course including
	sections with students and sections containing other roles.
	Incoming parameters: domain, course number, reference to
	section hash (keys to be section/group IDs), reference to
	array containing roles for which sections should be gathered
	(optional). If the fourth argument is undefined, sections
	are gathered for any role.

	Returns number of sections.

	=cut

	###############################################
	sub get_sections {
	my ($cdom,$cnum,$sectioncount,$possible_roles) = @_;
	if (!($cdom && $cnum)) { return 0; }
	my $cid = $cdom.'_'.$cnum;
	my $numsections = 0;

	if (!defined($possible_roles) \|\| (grep/^st$/,@$possible_roles)) {
	my ($classlist) = &Apache::loncoursedata::get_classlist($cid,$cdom,$cnum);
	my $sec_index = &Apache::loncoursedata::CL_SECTION();
	my $status_index = &Apache::loncoursedata::CL_STATUS();
	while (my ($student,$data) = each %$classlist) {
	my ($section,$status) = ($data->[$sec_index],
	$data->[$status_index]);
	unless ($section eq '-1' \|\| $section =~ /^\s*$/) {
	if (!defined($$sectioncount{$section})) { $numsections++; }
	$$sectioncount{$section}++;
	}
	}
	}
	my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
	foreach my $user (sort(keys(%courseroles))) {
	if ($user !~ /^(\w{2})/) { next; }
	my ($role) = ($user =~ /^(\w{2})/);
	if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; }
	my $section;
	if ($role eq 'cr' &&
	$user =~ m-^$role/[^/]/[^/]/[^/]:[^:]:[^:]*:(\w+)-) {
	$section=$1;
	}
	if ($user =~ /^$role:[^:]:[^:]:(\w+)/) { $section=$1; }
	if (!defined($section) \|\| $section eq '-1') { next; }
	if (!defined($$sectioncount{$section})) { $numsections++; }
	$$sectioncount{$section}++;
	}
	return $numsections;
	}


sub get_posted_cgi {	sub get_posted_cgi {
my $r=shift;	my $r=shift;

my $buffer;	my $buffer;
	if ($r->header_in('Content-length')) {
$r->read($buffer,$r->header_in('Content-length'),0);	$r->read($buffer,$r->header_in('Content-length'),0);
	}
unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) {	unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) {
my @pairs=split(/&/,$buffer);	my @pairs=split(/&/,$buffer);
my $pair;	my $pair;
Line 2427 sub get_posted_cgi {	Line 2996 sub get_posted_cgi {
if ($name) {	if ($name) {
chomp($value);	chomp($value);
if ($fname) {	if ($fname) {
$ENV{"form.$name.filename"}=$fname;	$env{"form.$name.filename"}=$fname;
$ENV{"form.$name.mimetype"}=$fmime;	$env{"form.$name.mimetype"}=$fmime;
} else {	} else {
$value=~s/\s+$//s;	$value=~s/\s+$//s;
}	}
Line 2460 sub get_posted_cgi {	Line 3029 sub get_posted_cgi {
}	}
}	}
}	}
$ENV{'request.method'}=$ENV{'REQUEST_METHOD'};	$env{'request.method'}=$ENV{'REQUEST_METHOD'};
$r->method_number(M_GET);	$r->method_number(M_GET);
$r->method('GET');	$r->method('GET');
$r->headers_in->unset('Content-length');	$r->headers_in->unset('Content-length');
Line 2470 sub get_posted_cgi {	Line 3039 sub get_posted_cgi {

=item * get_unprocessed_cgi($query,$possible_names)	=item * get_unprocessed_cgi($query,$possible_names)

Modify the %ENV hash to contain unprocessed CGI form parameters held in	Modify the %env hash to contain unprocessed CGI form parameters held in
$query. The parameters listed in $possible_names (an array reference),	$query. The parameters listed in $possible_names (an array reference),
will be set in $ENV{'form.name'} if they do not already exist.	will be set in $env{'form.name'} if they do not already exist.

Typically called with $ENV{'QUERY_STRING'} as the first parameter.	Typically called with $ENV{'QUERY_STRING'} as the first parameter.
$possible_names is an ref to an array of form element names. As an example:	$possible_names is an ref to an array of form element names. As an example:
get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);	get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set.	will result in $env{'form.uname'} and $env{'form.udom'} being set.

=cut	=cut

Line 2491 sub get_unprocessed_cgi {	Line 3060 sub get_unprocessed_cgi {
$value =~ tr/+/ /;	$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;	$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
&Apache::lonxml::debug("Seting :$name: to :$value:");	&Apache::lonxml::debug("Seting :$name: to :$value:");
unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) };	unless (defined($env{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
}	}
}	}
}	}
Line 2505 returns cache-controlling header code	Line 3074 returns cache-controlling header code
=cut	=cut

sub cacheheader {	sub cacheheader {
unless ($ENV{'request.method'} eq 'GET') { return ''; }	unless ($env{'request.method'} eq 'GET') { return ''; }
my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);	my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />	my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
<meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />	<meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
<meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';	<meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
return $output;	return $output;
}	}

=pod	=pod
Line 2522 specifies header code to not have cache	Line 3091 specifies header code to not have cache
=cut	=cut

sub no_cache {	sub no_cache {
my ($r) = @_;	my ($r) = @_;
unless ($ENV{'request.method'} eq 'GET') { return ''; }	if ($ENV{'REQUEST_METHOD'} ne 'GET' &&
#my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);	$env{'request.method'} ne 'GET') { return ''; }
$r->no_cache(1);	my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time));
$r->header_out("Pragma" => "no-cache");	$r->no_cache(1);
#$r->header_out("Expires" => $date);	$r->header_out("Expires" => $date);
	$r->header_out("Pragma" => "no-cache");
}	}

sub content_type {	sub content_type {
my ($r,$type,$charset) = @_;	my ($r,$type,$charset) = @_;
unless ($charset) {	if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; }
$charset=&Apache::lonlocal::current_encoding;	unless ($charset) {
}	$charset=&Apache::lonlocal::current_encoding;
$r->content_type($type.($charset?'; charset='.$charset:''));	}
	if ($charset) { $type.='; charset='.$charset; }
	if ($r) {
	$r->content_type($type);
	} else {
	print("Content-type: $type\n\n");
	}
}	}

=pod	=pod

=item * add_to_env($name,$value)	=item * add_to_env($name,$value)

adds $name to the %ENV hash with value	adds $name to the %env hash with value
$value, if $name already exists, the entry is converted to an array	$value, if $name already exists, the entry is converted to an array
reference and $value is added to the array.	reference and $value is added to the array.

Line 2550 reference and $value is added to the arr	Line 3126 reference and $value is added to the arr

sub add_to_env {	sub add_to_env {
my ($name,$value)=@_;	my ($name,$value)=@_;
if (defined($ENV{$name})) {	if (defined($env{$name})) {
if (ref($ENV{$name})) {	if (ref($env{$name})) {
#already have multiple values	#already have multiple values
push(@{ $ENV{$name} },$value);	push(@{ $env{$name} },$value);
} else {	} else {
#first time seeing multiple values, convert hash entry to an arrayref	#first time seeing multiple values, convert hash entry to an arrayref
my $first=$ENV{$name};	my $first=$env{$name};
undef($ENV{$name});	undef($env{$name});
push(@{ $ENV{$name} },$first,$value);	push(@{ $env{$name} },$first,$value);
}	}
} else {	} else {
$ENV{$name}=$value;	$env{$name}=$value;
}	}
}	}

Line 2569 sub add_to_env {	Line 3145 sub add_to_env {

=item * get_env_multiple($name)	=item * get_env_multiple($name)

gets $name from the %ENV hash, it seemlessly handles the cases where multiple	gets $name from the %env hash, it seemlessly handles the cases where multiple
values may be defined and end up as an array ref.	values may be defined and end up as an array ref.

returns an array of values	returns an array of values
Line 2579 returns an array of values	Line 3155 returns an array of values
sub get_env_multiple {	sub get_env_multiple {
my ($name) = @_;	my ($name) = @_;
my @values;	my @values;
if (defined($ENV{$name})) {	if (defined($env{$name})) {
# exists is it an array	# exists is it an array
if (ref($ENV{$name})) {	if (ref($env{$name})) {
@values=@{ $ENV{$name} };	@values=@{ $env{$name} };
} else {	} else {
$values[0]=$ENV{$name};	$values[0]=$env{$name};
}	}
}	}
return(@values);	return(@values);
Line 2602 sub get_env_multiple {	Line 3178 sub get_env_multiple {
=item * upfile_store($r)	=item * upfile_store($r)

Store uploaded file, $r should be the HTTP Request object,	Store uploaded file, $r should be the HTTP Request object,
needs $ENV{'form.upfile'}	needs $env{'form.upfile'}
returns $datatoken to be put into hidden field	returns $datatoken to be put into hidden field

=cut	=cut

sub upfile_store {	sub upfile_store {
my $r=shift;	my $r=shift;
$ENV{'form.upfile'}=~s/\r/\n/gs;	$env{'form.upfile'}=~s/\r/\n/gs;
$ENV{'form.upfile'}=~s/\f/\n/gs;	$env{'form.upfile'}=~s/\f/\n/gs;
$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=$env{'user.name'}.'_'.$env{'user.domain'}.
'_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$;	'_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;
{	{
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 2632 sub upfile_store {	Line 3208 sub upfile_store {
=item * load_tmp_file($r)	=item * load_tmp_file($r)

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'},	needs $env{'form.datatoken'},
sets $ENV{'form.upfile'} to the contents of the file	sets $env{'form.upfile'} to the contents of the file

=cut	=cut

Line 2642 sub load_tmp_file {	Line 3218 sub load_tmp_file {
my @studentdata=();	my @studentdata=();
{	{
my $studentfile = $r->dir_config('lonDaemons').	my $studentfile = $r->dir_config('lonDaemons').
'/tmp/'.$ENV{'form.datatoken'}.'.tmp';	'/tmp/'.$env{'form.datatoken'}.'.tmp';
if ( open(my $fh,"<$studentfile") ) {	if ( open(my $fh,"<$studentfile") ) {
@studentdata=<$fh>;	@studentdata=<$fh>;
close($fh);	close($fh);
}	}
}	}
$ENV{'form.upfile'}=join('',@studentdata);	$env{'form.upfile'}=join('',@studentdata);
}	}

=pod	=pod
Line 2657 sub load_tmp_file {	Line 3233 sub load_tmp_file {

Separate uploaded file into records	Separate uploaded file into records
returns array of records,	returns array of records,
needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'}	needs $env{'form.upfile'} and $env{'form.upfiletype'}

=cut	=cut

sub upfile_record_sep {	sub upfile_record_sep {
if ($ENV{'form.upfiletype'} eq 'xml') {	if ($env{'form.upfiletype'} eq 'xml') {
} else {	} else {
return split(/\n/,$ENV{'form.upfile'});	my @records;
	foreach my $line (split(/\n/,$env{'form.upfile'})) {
	if ($line=~/^\s*$/) { next; }
	push(@records,$line);
	}
	return @records;
}	}
}	}

Line 2672 sub upfile_record_sep {	Line 3253 sub upfile_record_sep {

=item * record_sep($record)	=item * record_sep($record)

Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'}	Separate a record into fields $record should be an item from the upfile_record_sep(), needs $env{'form.upfiletype'}

=cut	=cut

	sub takeleft {
	my $index=shift;
	return substr('0000'.$index,-4,4);
	}

sub record_sep {	sub record_sep {
my $record=shift;	my $record=shift;
my %components=();	my %components=();
if ($ENV{'form.upfiletype'} eq 'xml') {	if ($env{'form.upfiletype'} eq 'xml') {
} elsif ($ENV{'form.upfiletype'} eq 'space') {	} elsif ($env{'form.upfiletype'} eq 'space') {
my $i=0;	my $i=0;
foreach (split(/\s+/,$record)) {	foreach (split(/\s+/,$record)) {
my $field=$_;	my $field=$_;
$field=~s/^(\"\|\')//;	$field=~s/^(\"\|\')//;
$field=~s/(\"\|\')$//;	$field=~s/(\"\|\')$//;
$components{$i}=$field;	$components{&takeleft($i)}=$field;
$i++;	$i++;
}	}
} elsif ($ENV{'form.upfiletype'} eq 'tab') {	} elsif ($env{'form.upfiletype'} eq 'tab') {
my $i=0;	my $i=0;
foreach (split(/\t/,$record)) {	foreach (split(/\t/,$record)) {
my $field=$_;	my $field=$_;
$field=~s/^(\"\|\')//;	$field=~s/^(\"\|\')//;
$field=~s/(\"\|\')$//;	$field=~s/(\"\|\')$//;
$components{$i}=$field;	$components{&takeleft($i)}=$field;
$i++;	$i++;
}	}
} else {	} else {
Line 2713 sub record_sep {	Line 3299 sub record_sep {
$field=~s/^\s*$delimiter//;	$field=~s/^\s*$delimiter//;
$field=~s/$delimiter\s*$//;	$field=~s/$delimiter\s*$//;
}	}
$components{$i}=$field;	$components{&takeleft($i)}=$field;
$i++;	$i++;
}	}
}	}
Line 2822 sub csv_print_select_table {	Line 3408 sub csv_print_select_table {
$r->print('<option value="none"></option>');	$r->print('<option value="none"></option>');
foreach (sort({$a <=> $b} keys(%sone))) {	foreach (sort({$a <=> $b} keys(%sone))) {
$r->print('<option value="'.$_.'"'.	$r->print('<option value="'.$_.'"'.
($_ eq $defaultcol ? ' selected ' : '').	($_ eq $defaultcol ? ' selected="selected" ' : '').
'>Column '.($_+1).'</option>');	'>Column '.($_+1).'</option>');
}	}
$r->print('</select></td></tr>'."\n");	$r->print('</select></td></tr>'."\n");
Line 2866 sub csv_samples_select_table {	Line 3452 sub csv_samples_select_table {
foreach (@$d) {	foreach (@$d) {
my ($value,$display,$defaultcol)=@{ $_ };	my ($value,$display,$defaultcol)=@{ $_ };
$r->print('<option value="'.$value.'"'.	$r->print('<option value="'.$value.'"'.
($i eq $defaultcol ? ' selected ':'').'>'.	($i eq $defaultcol ? ' selected="selected" ':'').'>'.
$display.'</option>');	$display.'</option>');
}	}
$r->print('</select></td><td>');	$r->print('</select></td><td>');
if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); }	if (defined($sone{$_})) { $r->print($sone{$_}."<br />\n"); }
if (defined($stwo{$_})) { $r->print($stwo{$_}."</br>\n"); }	if (defined($stwo{$_})) { $r->print($stwo{$_}."<br />\n"); }
if (defined($sthree{$_})) { $r->print($sthree{$_}."</br>\n"); }	if (defined($sthree{$_})) { $r->print($sthree{$_}."<br />\n"); }
$r->print('</td></tr>');	$r->print('</td></tr>');
$i++;	$i++;
}	}
Line 2992 If $Max is < any data point, the graph w	Line 3578 If $Max is < any data point, the graph w
=item $colors: array ref holding the colors to be used for the data sets when	=item $colors: array ref holding the colors to be used for the data sets when
they are plotted. If undefined, default values will be used.	they are plotted. If undefined, default values will be used.

	=item $labels: array ref holding the labels to use on the x-axis for the bars.

=item @Values: An array of array references. Each array reference holds data	=item @Values: An array of array references. Each array reference holds data
to be plotted in a stacked bar chart.	to be plotted in a stacked bar chart.

	=item If the final element of @Values is a hash reference the key/value
	pairs will be added to the graph definition.

=back	=back

Returns:	Returns:
Line 3007 information for the plot.	Line 3598 information for the plot.
############################################################	############################################################
############################################################	############################################################
sub DrawBarGraph {	sub DrawBarGraph {
my ($Title,$xlabel,$ylabel,$Max,$colors,@Values)=@_;	my ($Title,$xlabel,$ylabel,$Max,$colors,$labels,@Values)=@_;
#	#
if (! defined($colors)) {	if (! defined($colors)) {
$colors = ['#33ff00',	$colors = ['#33ff00',
Line 3015 sub DrawBarGraph {	Line 3606 sub DrawBarGraph {
'#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66',	'#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66',
];	];
}	}
	my $extra_settings = {};
	if (ref($Values[-1]) eq 'HASH') {
	$extra_settings = pop(@Values);
	}
#	#
my $identifier = &get_cgi_id();	my $identifier = &get_cgi_id();
my $id = 'cgi.'.$identifier;	my $id = 'cgi.'.$identifier;
if (! @Values \|\| ref($Values[0]) ne 'ARRAY') {	if (! @Values \|\| ref($Values[0]) ne 'ARRAY') {
return '';	return '';
}	}
	#
	my @Labels;
	if (defined($labels)) {
	@Labels = @$labels;
	} else {
	for (my $i=0;$i<@{$Values[0]};$i++) {
	push (@Labels,$i+1);
	}
	}
	#
my $NumBars = scalar(@{$Values[0]});	my $NumBars = scalar(@{$Values[0]});
	if ($NumBars < scalar(@Labels)) { $NumBars = scalar(@Labels); }
my %ValuesHash;	my %ValuesHash;
my $NumSets=1;	my $NumSets=1;
foreach my $array (@Values) {	foreach my $array (@Values) {
Line 3031 sub DrawBarGraph {	Line 3637 sub DrawBarGraph {
}	}
#	#
my ($height,$width,$xskip,$bar_width) = (200,120,1,15);	my ($height,$width,$xskip,$bar_width) = (200,120,1,15);
if ($NumBars < 10) {	if ($NumBars < 3) {
	$width = 120+$NumBars*32;
	$xskip = 1;
	$bar_width = 30;
	} elsif ($NumBars < 5) {
	$width = 120+$NumBars*20;
	$xskip = 1;
	$bar_width = 20;
	} elsif ($NumBars < 10) {
$width = 120+$NumBars*15;	$width = 120+$NumBars*15;
$xskip = 1;	$xskip = 1;
$bar_width = 15;	$bar_width = 15;
Line 3049 sub DrawBarGraph {	Line 3663 sub DrawBarGraph {
$bar_width = 4;	$bar_width = 4;
}	}
#	#
my @Labels;
for (my $i=0;$i<@{$Values[0]};$i++) {
push (@Labels,$i+1);
}
#
$Max = 1 if ($Max < 1);	$Max = 1 if ($Max < 1);
if ( int($Max) < $Max ) {	if ( int($Max) < $Max ) {
$Max++;	$Max++;
Line 3076 sub DrawBarGraph {	Line 3685 sub DrawBarGraph {
$ValuesHash{$id.'.bar_width'} = $bar_width;	$ValuesHash{$id.'.bar_width'} = $bar_width;
$ValuesHash{$id.'.labels'} = join(',',@Labels);	$ValuesHash{$id.'.labels'} = join(',',@Labels);
#	#
	# Deal with other parameters
	while (my ($key,$value) = each(%$extra_settings)) {
	$ValuesHash{$id.'.'.$key} = $value;
	}
	#
&Apache::lonnet::appenv(%ValuesHash);	&Apache::lonnet::appenv(%ValuesHash);
return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';	return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
}	}
Line 3110 plotted in. If undefined, default value	Line 3724 plotted in. If undefined, default value
=item $Xlabels: Array ref containing the labels to be used for the X-axis.	=item $Xlabels: Array ref containing the labels to be used for the X-axis.

=item $Ydata: Array ref containing Array refs.	=item $Ydata: Array ref containing Array refs.
Each of the contained arrays will be plotted as a seperate curve.	Each of the contained arrays will be plotted as a separate curve.

=item %Values: hash indicating or overriding any default values which are	=item %Values: hash indicating or overriding any default values which are
passed to graph.png.	passed to graph.png.
Line 3310 Inputs:	Line 3924 Inputs:
sub chartlink {	sub chartlink {
my ($linktext, $sname, $sdomain) = @_;	my ($linktext, $sname, $sdomain) = @_;
my $link = '<a href="/adm/statistics?reportSelected=student_assessment'.	my $link = '<a href="/adm/statistics?reportSelected=student_assessment'.
'&SelectedStudent='.&Apache::lonnet::escape($sname.':'.$sdomain).	'&SelectedStudent='.&Apache::lonnet::escape($sname.':'.$sdomain).
'&chartoutputmode='.HTML::Entities::encode('html, with all links').	'&chartoutputmode='.HTML::Entities::encode('html, with all links').
'">'.$linktext.'</a>';	'">'.$linktext.'</a>';
}	}

Line 3352 Returns: both routines return nothing	Line 3966 Returns: both routines return nothing
sub store_course_settings {	sub store_course_settings {
# save to the environment	# save to the environment
# appenv the same items, just to be safe	# appenv the same items, just to be safe
my $courseid = $ENV{'request.course.id'};	my $courseid = $env{'request.course.id'};
my $coursedom = $ENV{'course.'.$courseid.'.domain'};	my $coursedom = $env{'course.'.$courseid.'.domain'};
my ($prefix,$Settings) = @_;	my ($prefix,$Settings) = @_;
my %SaveHash;	my %SaveHash;
my %AppHash;	my %AppHash;
while (my ($setting,$type) = each(%$Settings)) {	while (my ($setting,$type) = each(%$Settings)) {
my $basename = 'env.internal.'.$prefix.'.'.$setting;	my $basename = 'internal.'.$prefix.'.'.$setting;
my $envname = 'course.'.$courseid.'.'.$basename;	my $envname = 'course.'.$courseid.'.'.$basename;
if (exists($ENV{'form.'.$setting})) {	if (exists($env{'form.'.$setting})) {
# Save this value away	# Save this value away
if ($type eq 'scalar' &&	if ($type eq 'scalar' &&
(! exists($ENV{$envname}) \|\|	(! exists($env{$envname}) \|\|
$ENV{$envname} ne $ENV{'form.'.$setting})) {	$env{$envname} ne $env{'form.'.$setting})) {
$SaveHash{$basename} = $ENV{'form.'.$setting};	$SaveHash{$basename} = $env{'form.'.$setting};
$AppHash{$envname} = $ENV{'form.'.$setting};	$AppHash{$envname} = $env{'form.'.$setting};
} elsif ($type eq 'array') {	} elsif ($type eq 'array') {
my $stored_form;	my $stored_form;
if (ref($ENV{'form.'.$setting})) {	if (ref($env{'form.'.$setting})) {
$stored_form = join(',',	$stored_form = join(',',
map {	map {
&Apache::lonnet::escape($_);	&Apache::lonnet::escape($_);
} sort(@{$ENV{'form.'.$setting}}));	} sort(@{$env{'form.'.$setting}}));
} else {	} else {
$stored_form =	$stored_form =
&Apache::lonnet::escape($ENV{'form.'.$setting});	&Apache::lonnet::escape($env{'form.'.$setting});
}	}
# Determine if the array contents are the same.	# Determine if the array contents are the same.
if ($stored_form ne $ENV{$envname}) {	if ($stored_form ne $env{$envname}) {
$SaveHash{$basename} = $stored_form;	$SaveHash{$basename} = $stored_form;
$AppHash{$envname} = $stored_form;	$AppHash{$envname} = $stored_form;
}	}
Line 3388 sub store_course_settings {	Line 4002 sub store_course_settings {
}	}
my $put_result = &Apache::lonnet::put('environment',\%SaveHash,	my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
$coursedom,	$coursedom,
$ENV{'course.'.$courseid.'.num'});	$env{'course.'.$courseid.'.num'});
if ($put_result !~ /^(ok\|delayed)/) {	if ($put_result !~ /^(ok\|delayed)/) {
&Apache::lonnet::logthis('unable to save form parameters, '.	&Apache::lonnet::logthis('unable to save form parameters, '.
'got error:'.$put_result);	'got error:'.$put_result);
Line 3399 sub store_course_settings {	Line 4013 sub store_course_settings {
}	}

sub restore_course_settings {	sub restore_course_settings {
my $courseid = $ENV{'request.course.id'};	my $courseid = $env{'request.course.id'};
my ($prefix,$Settings) = @_;	my ($prefix,$Settings) = @_;
while (my ($setting,$type) = each(%$Settings)) {	while (my ($setting,$type) = each(%$Settings)) {
next if (exists($ENV{'form.'.$setting}));	next if (exists($env{'form.'.$setting}));
my $envname = 'course.'.$courseid.'.env.internal.'.$prefix.	my $envname = 'course.'.$courseid.'.internal.'.$prefix.
'.'.$setting;	'.'.$setting;
if (exists($ENV{$envname})) {	if (exists($env{$envname})) {
if ($type eq 'scalar') {	if ($type eq 'scalar') {
$ENV{'form.'.$setting} = $ENV{$envname};	$env{'form.'.$setting} = $env{$envname};
} elsif ($type eq 'array') {	} elsif ($type eq 'array') {
$ENV{'form.'.$setting} = [	$env{'form.'.$setting} = [
map {	map {
&Apache::lonnet::unescape($_);	&Apache::lonnet::unescape($_);
} split(',',$ENV{$envname})	} split(',',$env{$envname})
];	];
}	}
}	}
Line 3445 sub icon {	Line 4059 sub icon {
$curfext.".gif";	$curfext.".gif";
}	}
}	}
return $iconname;	return &lonhttpdurl($iconname);
}	}

	sub lonhttpdurl {
	my ($url)=@_;
	my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'};
	if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; }
	return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url;
	}

	sub connection_aborted {
	my ($r)=@_;
	$r->print(" ");$r->rflush();
	my $c = $r->connection;
	return $c->aborted();
	}

	# Escapes strings that may have embedded 's that will be put into
	# strings as 'strings'.
	sub escape_single {
	my ($input) = @_;
	$input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)>
	$input =~ s/\'/\\\'/g; # Esacpe the 's....
	return $input;
	}

	# Same as escape_single, but escape's "'s This
	# can be used for "strings"
	sub escape_double {
	my ($input) = @_;
	$input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)>
	$input =~ s/\"/\\\"/g; # Esacpe the "s....
	return $input;
	}

	# Escapes the last element of a full URL.
	sub escape_url {
	my ($url) = @_;
	my @urlslices = split(/\//, $url,-1);
	my $lastitem = &Apache::lonnet::escape(pop(@urlslices));
	return join('/',@urlslices).'/'.$lastitem;
	}
=pod	=pod

=back	=back

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

Removed from v.1.175
changed lines
	Added in v.1.269