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.226 and 1.286

version 1.226, 2004/11/02 20:48:02	version 1.286, 2005/11/10 00:37:39
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);
Line 152 BEGIN {	Line 152 BEGIN {
my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';	my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
opendir(DIR,$designdir);	opendir(DIR,$designdir);
while ($filename=readdir(DIR)) {	while ($filename=readdir(DIR)) {
	if ($filename!~/\.tab$/) { next; }
my ($domain)=($filename=~/^(\w+)\./);	my ($domain)=($filename=~/^(\w+)\./);
{	{
my $designfile = $designdir.'/'.$filename;	my $designfile = $designdir.'/'.$filename;
if ( open (my $fh,"<$designfile") ) {	if ( open (my $fh,"<$designfile") ) {
while (<$fh>) {	while (<$fh>) {
next if /^\#/;	next if /^\#/;
chomp;	chomp;
my ($key,$val)=(split(/\=/,$_));	my ($key,$val)=(split(/\=/,$_));
if ($val) { $designhash{$domain.'.'.$key}=$val; }	if ($val) { $designhash{$domain.'.'.$key}=$val; }
}	}
close($fh);	close($fh);
}	}
}	}

}	}
closedir(DIR);	closedir(DIR);
Line 311 END	Line 312 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 329 sub storeresurl {	Line 330 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 360 ENDSTDBRW	Line 361 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 379 sub coursebrowser_javascript {	Line 380 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,desc) {	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 396 sub coursebrowser_javascript {	Line 397 sub coursebrowser_javascript {
url += 'form=' + formname + '&cnumelement='+uname+	url += 'form=' + formname + '&cnumelement='+uname+
'&cdomelement='+udom+	'&cdomelement='+udom+
'&cnameelement='+desc;	'&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 407 ENDSTDBRW	Line 414 ENDSTDBRW
}	}

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

	sub check_uncheck_jscript {
	my $jscript = <<"ENDSCRT";
	function checkAll(field) {
	if (field.length > 0) {
	for (i = 0; i < field.length; i++) {
	field[i].checked = true ;
	}
	} else {
	field.checked = true
	}
}	}

	function uncheckAll(field) {
	if (field.length > 0) {
	for (i = 0; i < field.length; i++) {
	field[i].checked = false ;
	} } else {
	field.checked = false ;
	}
	}
	ENDSCRT
	return $jscript;
	}


=pod	=pod

Line 541 END	Line 573 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 551 END	Line 583 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 587 sub help_open_topic {	Line 619 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 653 sub help_open_menu {	Line 685 sub help_open_menu {
my ($color,$topic,$component_help,$function,$faq,$bug,$stayOnPage,$width,$height,$text) = @_;	my ($color,$topic,$component_help,$function,$faq,$bug,$stayOnPage,$width,$height,$text) = @_;
$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 = 620 if (not defined $width);	$width = 620 if (not defined $width);
Line 662 sub help_open_menu {	Line 694 sub help_open_menu {
my $link='';	my $link='';
my $title = &mt('Get help');	my $title = &mt('Get help');
my $origurl = $ENV{'REQUEST_URI'};	my $origurl = $ENV{'REQUEST_URI'};
	$origurl=~s\|^/~\|/priv/\|;
my $timestamp = time;	my $timestamp = time;
foreach (\$color,\$function,\$topic,\$component_help,\$faq,\$bug,\$origurl) {	foreach (\$color,\$function,\$topic,\$component_help,\$faq,\$bug,\$origurl) {
$$_ = &Apache::lonnet::escape($$_);	$$_ = &Apache::lonnet::escape($$_);
}	}

if (!$stayOnPage) {	if (!$stayOnPage) {
$link = "javascript:helpMenu('open')";	$link = "javascript:helpMenu('open')";
} else {	} else {
Line 677 sub help_open_menu {	Line 709 sub help_open_menu {
my $template;	my $template;
if ($text ne "") {	if ($text ne "") {
$template .=	$template .=
"<table bgcolor='#773311' cellspacing='1' cellpadding='1' border='0'><tr>".	"<table bgcolor='#CC3300' cellspacing='1' cellpadding='1' border='0'><tr>".
"<td bgcolor='#886622'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";	"<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");	my $helpicon=&lonhttpdurl("/adm/lonIcons/helpgateway.gif");
$template .= <<"ENDTEMPLATE";	$template .= <<"ENDTEMPLATE";
<script type="text/javascript">	<script type="text/javascript">
//<!-- BEGIN LON-CAPA Internal	// <!-- BEGIN LON-CAPA Internal
function helpMenu(caller) {	// <![CDATA[
if (caller == 'open') {	function helpMenu(target) {
newWindow = window.open("","helpmenu","HEIGHT=$height,WIDTH=$width,resize=yes,scrollbars=yes" )	var caller = this;
caller = newWindow.document	if (target == 'open') {
} else {	var newWindow = null;
caller = this.document	try {
}	newWindow = window.open($nothing,"helpmenu","HEIGHT=$height,WIDTH=$width,resizable=yes,scrollbars=yes" )
caller.write("<html><head><title>LON-CAPA Help Menu</title><meta http-equiv='pragma' content='no-cache'></head>")	}
caller.write("<frameset rows='105,*' border='0'><frame name='bannerframe' src='$banner_link'><frame name='bodyframe' src='$details_link'></frameset>")	catch(error) {
caller.write("</html>")	writeHelp(caller);
caller.close()	return;
if (caller == newWindow.document) {	}
caller.focus()	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 -->	// END LON-CAPA Internal -->
</script>	</script>
<a href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help Menu)" /></a>	<a href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help Menu)" /></a>
Line 722 ENDTEMPLATE	Line 768 ENDTEMPLATE

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 = 600 if (not defined $width);	$width = 600 if (not defined $width);
Line 767 ENDTEMPLATE	Line 813 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 815 ENDTEMPLATE	Line 861 ENDTEMPLATE

=pod	=pod

	=item * change_content_javascript():

	This and the next function allow you to create small sections of an
	otherwise static HTML page that you can update on the fly with
	Javascript, even in Netscape 4.

	The Javascript fragment returned by this function (no E<lt>scriptE<gt> tag)
	must be written to the HTML page once. It will prove the Javascript
	function "change(name, content)". Calling the change function with the
	name of the section
	you want to update, matching the name passed to C<changable_area>, and
	the new content you want to put in there, will put the content into
	that area.

	B<Note>: Netscape 4 only reserves enough space for the changable area
	to contain room for the original contents. You need to "make space"
	for whatever changes you wish to make, and be B<sure> to check your
	code in Netscape 4. This feature in Netscape 4 is B<not> powerful;
	it's adequate for updating a one-line status display, but little more.
	This script will set the space to 100% width, so you only need to
	worry about height in Netscape 4.

	Modern browsers are much less limiting, and if you can commit to the
	user not using Netscape 4, this feature may be used freely with
	pretty much any HTML.

	=cut

	sub change_content_javascript {
	# If we're on Netscape 4, we need to use Layer-based code
	if ($env{'browser.type'} eq 'netscape' &&
	$env{'browser.version'} =~ /^4\./) {
	return (<<NETSCAPE4);
	function change(name, content) {
	doc = document.layers[name+"___escape"].layers[0].document;
	doc.open();
	doc.write(content);
	doc.close();
	}
	NETSCAPE4
	} else {
	# Otherwise, we need to use semi-standards-compliant code
	# (technically, "innerHTML" isn't standard but the equivalent
	# is really scary, and every useful browser supports it
	return (<<DOMBASED);
	function change(name, content) {
	element = document.getElementById(name);
	element.innerHTML = content;
	}
	DOMBASED
	}
	}

	=pod

	=item * changable_area($name, $origContent):

	This provides a "changable area" that can be modified on the fly via
	the Javascript code provided in C<change_content_javascript>. $name is
	the name you will use to reference the area later; do not repeat the
	same name on a given HTML page more then once. $origContent is what
	the area will originally contain, which can be left blank.

	=cut

	sub changable_area {
	my ($name, $origContent) = @_;

	if ($env{'browser.type'} eq 'netscape' &&
	$env{'browser.version'} =~ /^4\./) {
	# 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>";
	} else {
	return "<span id='$name'>$origContent</span>";
	}
	}

	=pod

	=back

	=head1 Excel and CSV file utility routines

	=over 4

	=cut

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

	=pod

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

Translate $text to allow it to be output as a 'comma separated values'	Translate $text to allow it to be output as a 'comma separated values'
Line 831 sub csv_translate {	Line 969 sub csv_translate {
return $text;	return $text;
}	}


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

Line 855 Currently supported formats:	Line 992 Currently supported formats:

=item h3	=item h3

	=item h4

	=item i

=item date	=item date

=back	=back
Line 877 sub define_excel_formats {	Line 1018 sub define_excel_formats {
$format->{'h1'} = $workbook->add_format(bold=>1, size=>18);	$format->{'h1'} = $workbook->add_format(bold=>1, size=>18);
$format->{'h2'} = $workbook->add_format(bold=>1, size=>16);	$format->{'h2'} = $workbook->add_format(bold=>1, size=>16);
$format->{'h3'} = $workbook->add_format(bold=>1, size=>14);	$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=>	$format->{'date'} = $workbook->add_format(num_format=>
'mm/dd/yyyy hh:mm:ss');	'mm/dd/yyyy hh:mm:ss');
return $format;	return $format;
Line 887 sub define_excel_formats {	Line 1030 sub define_excel_formats {

=pod	=pod

=item * change_content_javascript():	=item * create_workbook

This and the next function allow you to create small sections of an
otherwise static HTML page that you can update on the fly with
Javascript, even in Netscape 4.

The Javascript fragment returned by this function (no E<lt>scriptE<gt> tag)	Create an Excel worksheet. If it fails, output message on the
must be written to the HTML page once. It will prove the Javascript	request object and return undefs.
function "change(name, content)". Calling the change function with the
name of the section
you want to update, matching the name passed to C<changable_area>, and
the new content you want to put in there, will put the content into
that area.

B<Note>: Netscape 4 only reserves enough space for the changable area	Inputs: Apache request object
to contain room for the original contents. You need to "make space"
for whatever changes you wish to make, and be B<sure> to check your
code in Netscape 4. This feature in Netscape 4 is B<not> powerful;
it's adequate for updating a one-line status display, but little more.
This script will set the space to 100% width, so you only need to
worry about height in Netscape 4.

Modern browsers are much less limiting, and if you can commit to the	Returns (undef) on failure,
user not using Netscape 4, this feature may be used freely with	Excel worksheet object, scalar with filename, and formats
pretty much any HTML.	from &Apache::loncommon::define_excel_formats on success

=cut	=cut

sub change_content_javascript {	###############################################################
# If we're on Netscape 4, we need to use Layer-based code	###############################################################
if ($ENV{'browser.type'} eq 'netscape' &&	sub create_workbook {
$ENV{'browser.version'} =~ /^4\./) {	my ($r) = @_;
return (<<NETSCAPE4);	#
function change(name, content) {	# Create the excel spreadsheet
doc = document.layers[name+"___escape"].layers[0].document;	my $filename = '/prtspool/'.
doc.open();	$env{'user.name'}.'_'.$env{'user.domain'}.'_'.
doc.write(content);	time.'_'.rand(1000000000).'.xls';
doc.close();	my $workbook = Spreadsheet::WriteExcel->new('/home/httpd'.$filename);
}	if (! defined($workbook)) {
NETSCAPE4	$r->log_error("Error creating excel spreadsheet $filename: $!");
} else {	$r->print('<p>'.&mt("Unable to create new Excel file. ".
# Otherwise, we need to use semi-standards-compliant code	"This error has been logged. ".
# (technically, "innerHTML" isn't standard but the equivalent	"Please alert your LON-CAPA administrator").
# is really scary, and every useful browser supports it	'</p>');
return (<<DOMBASED);	return (undef);
function change(name, content) {
element = document.getElementById(name);
element.innerHTML = content;
}
DOMBASED
}	}
	#
	$workbook->set_tempdir('/home/httpd/perl/tmp');
	#
	my $format = &Apache::loncommon::define_excel_formats($workbook);
	return ($workbook,$filename,$format);
}	}

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

=pod	=pod

=item * changable_area($name, $origContent):	=item * create_text_file

This provides a "changable area" that can be modified on the fly via	Create a file to write to and eventually make available to the usre.
the Javascript code provided in C<change_content_javascript>. $name is	If file creation fails, outputs an error message on the request object and
the name you will use to reference the area later; do not repeat the	return undefs.
same name on a given HTML page more then once. $origContent is what
the area will originally contain, which can be left blank.

=cut	Inputs: Apache request object, and file suffix

sub changable_area {	Returns (undef) on failure,
my ($name, $origContent) = @_;	Filehandle and filename on success.

if ($ENV{'browser.type'} eq 'netscape' &&	=cut
$ENV{'browser.version'} =~ /^4\./) {
# 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>";	###############################################################
} else {	sub create_text_file {
return "<span id='$name'>$origContent</span>";	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
	=pod

=back	=back

Line 1013 sub domain_select {	Line 1155 sub domain_select {
}	}
}	}

	#-------------------------------------------

	=pod

	=item * multiple_select_form($name,$value,$size,%hash)

	Returns a string containing a <select> element int multiple mode


	Args:
	$name - name of the <select> element
	$value - sclara or array ref of values that should already be selected
	$size - number of rows long the select element is
	$hash - the elements should be 'option' => 'shown text'
	(shown text should already have been &mt())
	$order - (optional) array ref of the order to show the elments in

	=cut

	#-------------------------------------------
sub multiple_select_form {	sub multiple_select_form {
my ($name,$value,$size,%hash)=@_;	my ($name,$value,$size,$hash,$order)=@_;
my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);	my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);
my $output='';	my $output='';
if (! defined($size)) {	if (! defined($size)) {
$size = 4;	$size = 4;
if (scalar(keys(%hash))<4) {	if (scalar(keys(%$hash))<4) {
$size = scalar(keys(%hash));	$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))) {	my @order = ref($order) ? @$order
$output.='<option value="'.$_.'" ';	: sort(keys(%$hash));
$output.='selected ' if ($selected{$_});	foreach my $key (@order) {
$output.='>'.$hash{$_}."</option>\n";	$output.='<option value="'.$key.'" ';
	$output.='selected="selected" ' if ($selected{$key});
	$output.='>'.$hash->{$key}."</option>\n";
}	}
$output.="</select>\n";	$output.="</select>\n";
return $output;	return $output;
Line 1057 sub select_form {	Line 1221 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 1094 sub select_level_form {	Line 1258 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 1124 sub select_dom_form {	Line 1288 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 1223 Outputs:	Line 1387 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 1421 sub authform_nochange{	Line 1587 sub authform_nochange{
kerb_def_dom => 'MSU.EDU',	kerb_def_dom => 'MSU.EDU',
@_,	@_,
);	);
my $result = &mt('[_1] Do not change login data',	my $result = '<label>'.&mt('[_1] Do not change login data',
'<input type="radio" name="login" value="nochange" '.	'<input type="radio" name="login" value="nochange" '.
'checked="checked" onclick="'.	'checked="checked" onclick="'.
"javascript:changed_radio('nochange',$in{'formname'});".'" />');	"javascript:changed_radio('nochange',$in{'formname'});".'" />').
	'</label>';
return $result;	return $result;
}	}

Line 1456 sub authform_kerberos{	Line 1623 sub authform_kerberos{
my $jscall = "javascript:changed_radio('krb',$in{'formname'});";	my $jscall = "javascript:changed_radio('krb',$in{'formname'});";
my $result .= &mt	my $result .= &mt
('[_1] Kerberos authenticated with domain [_2] '.	('[_1] Kerberos authenticated with domain [_2] '.
'[_3] Version 4 [_4] Version 5',	'[_3] Version 4 [_4] Version 5 [_5]',
'<input type="radio" name="login" value="krb" '.	'<label><input type="radio" name="login" value="krb" '.
'onclick="'.$jscall.'" onchange="'.$jscall.'"'.$krbcheck.' />',	'onclick="'.$jscall.'" onchange="'.$jscall.'"'.$krbcheck.' />',
'<input type="text" size="10" name="krbarg" '.	'</label><input type="text" size="10" name="krbarg" '.
'value="'.$krbarg.'" '.	'value="'.$krbarg.'" '.
'onchange="'.$jscall.'" />',	'onchange="'.$jscall.'" />',
'<input type="radio" name="krbver" value="4" '.$check4.' />',	'<label><input type="radio" name="krbver" value="4" '.$check4.' />',
'<input type="radio" name="krbver" value="5" '.$check5.' />');	'</label><label><input type="radio" name="krbver" value="5" '.$check5.' />',
	'</label>');
return $result;	return $result;
}	}

Line 1488 sub authform_internal{	Line 1656 sub authform_internal{
my $jscall = "javascript:changed_radio('int',$args{'formname'});";	my $jscall = "javascript:changed_radio('int',$args{'formname'});";
my $result.=&mt	my $result.=&mt
('[_1] Internally authenticated (with initial password [_2])',	('[_1] Internally authenticated (with initial password [_2])',
'<input type="radio" name="login" value="int" '.$intcheck.	'<label><input type="radio" name="login" value="int" '.$intcheck.
' onchange="'.$jscall.'" onclick="'.$jscall.'" />',	' onchange="'.$jscall.'" onclick="'.$jscall.'" />',
'<input type="text" size="10" name="intarg" '.$intarg.	'</label><input type="text" size="10" name="intarg" '.$intarg.
' onchange="'.$jscall.'" />');	' onchange="'.$jscall.'" />');
return $result;	return $result;
}	}
Line 1515 sub authform_local{	Line 1683 sub authform_local{

my $jscall = "javascript:changed_radio('loc',$in{'formname'});";	my $jscall = "javascript:changed_radio('loc',$in{'formname'});";
my $result.=&mt('[_1] Local Authentication with argument [_2]',	my $result.=&mt('[_1] Local Authentication with argument [_2]',
'<input type="radio" name="login" value="loc" '.$loccheck.	'<label><input type="radio" name="login" value="loc" '.$loccheck.
' onchange="'.$jscall.'" onclick="'.$jscall.'" />',	' onchange="'.$jscall.'" onclick="'.$jscall.'" />',
'<input type="text" size="10" name="locarg" '.$locarg.	'</label><input type="text" size="10" name="locarg" '.$locarg.
' onchange="'.$jscall.'" />');	' onchange="'.$jscall.'" />');
return $result;	return $result;
}	}
Line 1531 sub authform_filesystem{	Line 1699 sub authform_filesystem{
my $jscall = "javascript:changed_radio('fsys',$in{'formname'});";	my $jscall = "javascript:changed_radio('fsys',$in{'formname'});";
my $result.= &mt	my $result.= &mt
('[_1] Filesystem Authenticated (with initial password [_2])',	('[_1] Filesystem Authenticated (with initial password [_2])',
'<input type="radio" name="login" value="fsys" '.	'<label><input type="radio" name="login" value="fsys" '.
'onchange="'.$jscall.'" onclick="'.$jscall.'" />',	'onchange="'.$jscall.'" onclick="'.$jscall.'" />',
'<input type="text" size="10" name="fsysarg" value="" '.	'</label><input type="text" size="10" name="fsysarg" value="" '.
'onchange="'.$jscall.'" />');	'onchange="'.$jscall.'" />');
return $result;	return $result;
}	}
Line 1786 if the user does not	Line 1954 if the user does not
sub nickname {	sub nickname {
my ($uname,$udom)=@_;	my ($uname,$udom)=@_;
my %names;	my %names;
if ($uname eq $ENV{'user.name'} &&	if ($uname eq $env{'user.name'} &&
$udom eq $ENV{'user.domain'}) {	$udom eq $env{'user.domain'}) {
%names=('nickname' => $ENV{'environment.nickname'} ,	%names=('nickname' => $env{'environment.nickname'} ,
'firstname' => $ENV{'environment.firstname'} ,	'firstname' => $env{'environment.firstname'} ,
'middlename' => $ENV{'environment.middlename'},	'middlename' => $env{'environment.middlename'},
'lastname' => $ENV{'environment.lastname'} ,	'lastname' => $env{'environment.lastname'} ,
'generation' => $ENV{'environment.generation'});	'generation' => $env{'environment.generation'});
} else {	} else {
%names=&Apache::lonnet::get('environment',	%names=&Apache::lonnet::get('environment',
['nickname','firstname','middlename',	['nickname','firstname','middlename',
Line 1823 Gets a users screenname and returns it a	Line 1991 Gets a users screenname and returns it a

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

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



=pod	=pod

=back	=back
Line 2072 sub display_languages {	Line 2239 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 2082 sub display_languages {	Line 2249 sub display_languages {

sub preferred_languages {	sub preferred_languages {
my @languages=();	my @languages=();
if ($ENV{'course.'.$ENV{'request.course.id'}.'.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'}) {	if ($env{'environment.languages'}) {
@languages=split(/\s(\,\|\;\|\:)\s/,$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 2278 sub get_student_view {	Line 2445 sub get_student_view {
if (defined($moreenv)) {	if (defined($moreenv)) {
%form=(%form,%{$moreenv});	%form=(%form,%{$moreenv});
}	}
if ($target eq 'tex') {$form{'grade_target'} = 'tex';}	if (defined($target)) { $form{'grade_target'} = $target; }
$feedurl=&Apache::lonnet::clutter($feedurl);	$feedurl=&Apache::lonnet::clutter($feedurl);
my $userview=&Apache::lonnet::ssi_body($feedurl,%form);	my $userview=&Apache::lonnet::ssi_body($feedurl,%form);
$userview=~s/\<body[^\>]*\>//gi;	$userview=~s/\<body[^\>]*\>//gi;
Line 2318 sub get_student_answers {	Line 2485 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 2326 Returns: A link to grades.pm such as to	Line 2493 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 and a specific 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 2372 sub maketime {	Line 2588 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 2411 sub determinedomain {	Line 2627 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 2458 Returns: value of designparamter $which	Line 2674 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 2469 sub designparm {	Line 2685 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 2522 other decorations will be returned.	Line 2738 other decorations will be returned.
=cut	=cut

sub bodytag {	sub bodytag {
my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle)=@_;	my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle,$notopbar)=@_;
$title=&mt($title);	$title=&mt($title);
$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 2536 sub bodytag {	Line 2752 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 2555 sub bodytag {	Line 2771 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 }
	table.thinborder { border-collapse: collapse; }
	table.thinborder tr th { border-style: solid; border-width: 1px}
	table.thinborder tr td { border-style: solid; border-width: 1px}
	.center { text-align: center; }
</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
my $roleinfo=(<<ENDROLE);	my $roleinfo=(<<ENDROLE);
<td bgcolor="$tabbg" align="right">	<td bgcolor="$tabbg" align="right">
<p>
<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>
<br />	<br />
<font size="2" face="Arial, Helvetica, sans-serif">$role</font>	<font size="2" face="Arial, Helvetica, sans-serif">$role</font>
<br />	<br />
<font size="2" face="Arial, Helvetica, sans-serif">$realm</font>	<font size="2" face="Arial, Helvetica, sans-serif">$realm</font>
</p>
</td>	</td>
ENDROLE	ENDROLE
my $titleinfo = '<font face="Arial, Helvetica, sans-serif" size="+3" color="'.	my $titleinfo = '<font face="Arial, Helvetica, sans-serif" size="+3" color="'.
$font.'"><b>'.$title.'</b></font>';	$font.'"><b>'.$title.'</b></font>';
if ($customtitle) {	if ($customtitle) {
$titleinfo = $customtitle;	$titleinfo = $customtitle;
}	}
return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',
$forcereg).	if ($env{'request.state'} eq 'construct') {
'<table bgcolor="'.$pgbg.'" width="100%" border="0" cellspacing="3" cellpadding="3"><tr><td rowspan="3" bgcolor="'.$tabbg.'">'.$titleinfo.'</td>'.$roleinfo.'</tr></table>';	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 bgcolor="'.$tabbg.'">'.
	$titleinfo.'</td>'.$roleinfo.'</tr></table>';
	if ($env{'request.state'} eq 'construct') {
	if ($notopbar) {
	$bodytag .= $titletable;
	} else {
	$bodytag .= &Apache::lonmenu::menubuttons($forcereg,'web',$forcereg,$titletable);
	}
	} else {
	if ($notopbar) {
	$bodytag .= $titletable;
	} else {
	$bodytag .= &Apache::lonmenu::menubuttons($forcereg,'web',$forcereg).
	$titletable;
	}
	}
	return $bodytag;
}	}

#	#
Line 2607 ENDROLE	Line 2873 ENDROLE
if ($customtitle) {	if ($customtitle) {
$titleinfo = $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 class="thinborder" width="100%" cellspacing="0" border="0" cellpadding="0">
<tr><td bgcolor="$sidebg">	<tr><td bgcolor="$sidebg">
$upperleft</td>	$upperleft</td>
<td bgcolor="$sidebg" align="right">$messages </td>	<td bgcolor="$sidebg" align="right">$messages </td>
</tr>	</tr>
<tr>	<tr>
<td rowspan="3" bgcolor="$tabbg">	<td rowspan="3" bgcolor="$tabbg">
$titleinfo	$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 2636 ENDBODY	Line 2913 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	=pod

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

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

	=pod

	=item check_user_status

	Determines current status of supplied role for a
	specific user. Roles can be active, previous or future.

	Inputs:
	user's domain, user's username, course's domain,
	course's number, optional section/group.

	Outputs:
	role status: active, previous or future.

	=cut

	sub check_user_status {
	my ($udom,$uname,$cdom,$crs,$role,$secgrp) = @_;
	my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname);
	my @uroles = keys %userinfo;
	my $srchstr;
	my $active_chk = 'none';
	if (@uroles > 0) {
	if (($role eq 'cc') \|\| ($secgrp eq '') \|\| (!defined($secgrp))) {
	$srchstr = '/'.$cdom.'/'.$crs.'_'.$role;
	} else {
	$srchstr = '/'.$cdom.'/'.$crs.'/'.$secgrp.'_'.$role; }
	if (grep/^$srchstr$/,@uroles) {
	my $role_end = 0;
	my $role_start = 0;
	$active_chk = 'active';
	if ($userinfo{$srchstr} =~ m/^($role)_(\d+)/) {
	$role_end = $2;
	if ($userinfo{$srchstr} =~ m/^($role)_($role_end)_(\d+)$/) {
	$role_start = $3;
	}
	}
	if ($role_start > 0) {
	if (time < $role_start) {
	$active_chk = 'future';
	}
	}
	if ($role_end > 0) {
	if (time > $role_end) {
	$active_chk = 'previous';
	}
	}
	}
	}
	return $active_chk;
	}

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

	=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 $numsections = 0;

	if (!defined($possible_roles) \|\| (grep/^st$/,@$possible_roles)) {
	my ($classlist) = &Apache::loncoursedata::get_classlist($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;
	}

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

	=pod

	=item get_course_users

	Retrieves usernames:domains for users in the specified course
	with specific role(s), and access status.

	Incoming parameters:
	1. course domain
	2. course number
	3. access status: users must have - either active,
	previous, future, or all.
	4. reference to array of permissible roles
	5. reference to results object (hash of hashes).
	Keys of top level hash are roles.
	Keys of inner hashes are username:domain, with
	values set to access type.

	=cut

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

	sub get_course_users {
	my ($cdom,$cnum,$types,$roles,$users) = @_;
	if (grep/^st$/,@{$roles}) {
	my $statusidx = &Apache::loncoursedata::CL_STATUS();
	my $startidx = &Apache::loncoursedata::CL_START();
	my $endidx = &Apache::loncoursedata::CL_END();
	my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum);
	my $now = time;
	foreach my $student (keys(%{$classlist})) {
	if (defined($$types{'active'})) {
	if ($$classlist{$student}[$statusidx] eq 'Active') {
	push(@{$$users{st}{$student}},'active');
	}
	}
	if (defined($$types{'previous'})) {
	if ($$classlist{$student}[$endidx] <= $now) {
	push(@{$$users{st}{$student}},'previous');
	}
	}
	if (defined($$types{'future'})) {
	if (($$classlist{$student}[$startidx] > $now) && ($$classlist{$student}[$endidx] > $now) \|\| ($$classlist{$student}[$endidx] == 0) \|\| ($$classlist{$student}[$endidx] eq '')) {
	push(@{$$users{st}{$student}},'future');
	}
	}
	}
	}
	if ((@{$roles} > 0) && (@{$roles} ne "st")) {
	my @coursepersonnel = &Apache::lonnet::getkeys('nohist_userroles',$cdom,$cnum);
	foreach my $person (@coursepersonnel) {
	my ($role,$user) = ($person =~ /^([^:]*):([^:]+:[^:]+)/);
	$user =~ s/:$//;
	if (($role) && (grep(/^$role$/,@{$roles}))) {
	my ($uname,$udom) = split(/:/,$user);
	if ($uname ne '' && $udom ne '') {
	my $status = &check_user_status($udom,$uname,$cdom,$cnum,$role);
	foreach my $type (keys(%{$types})) {
	if ($status eq $type) {
	$$users{$role}{$user} = $type;
	}
	}
	}
	}
	}
	if (grep/^ow$/,@{$roles}) {
	if ((defined($cdom)) && (defined($cnum))) {
	my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum);
	if ( defined($csettings{'internal.courseowner'}) ) {
	my $owner = $csettings{'internal.courseowner'};
	$$users{'ow'}{$owner.':'.$cdom} = 'any';
	}
	}
	}
	}
	return;
	}



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

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 2694 sub get_posted_cgi {	Line 3194 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 2727 sub get_posted_cgi {	Line 3227 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 2737 sub get_posted_cgi {	Line 3237 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 2757 sub get_unprocessed_cgi {	Line 3257 sub get_unprocessed_cgi {
if (!defined($possible_names) \|\| (grep {$_ eq $name} @$possible_names)) {	if (!defined($possible_names) \|\| (grep {$_ eq $name} @$possible_names)) {
$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:");	unless (defined($env{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
}	}
}	}
}	}
Line 2772 returns cache-controlling header code	Line 3271 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" />
Line 2791 specifies header code to not have cache	Line 3290 specifies header code to not have cache
sub no_cache {	sub no_cache {
my ($r) = @_;	my ($r) = @_;
if ($ENV{'REQUEST_METHOD'} ne 'GET' &&	if ($ENV{'REQUEST_METHOD'} ne 'GET' &&
$ENV{'request.method'} ne 'GET') { return ''; }	$env{'request.method'} ne 'GET') { return ''; }
my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time));	my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time));
$r->no_cache(1);	$r->no_cache(1);
$r->header_out("Expires" => $date);	$r->header_out("Expires" => $date);
Line 2800 sub no_cache {	Line 3299 sub no_cache {

sub content_type {	sub content_type {
my ($r,$type,$charset) = @_;	my ($r,$type,$charset) = @_;
	if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; }
unless ($charset) {	unless ($charset) {
$charset=&Apache::lonlocal::current_encoding;	$charset=&Apache::lonlocal::current_encoding;
}	}
Line 2815 sub content_type {	Line 3315 sub content_type {

=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 2823 reference and $value is added to the arr	Line 3323 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 2842 sub add_to_env {	Line 3342 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 2852 returns an array of values	Line 3352 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 2875 sub get_env_multiple {	Line 3375 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 2905 sub upfile_store {	Line 3405 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 2915 sub load_tmp_file {	Line 3415 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 2930 sub load_tmp_file {	Line 3430 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 2945 sub upfile_record_sep {	Line 3450 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 2986 sub record_sep {	Line 3496 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 3095 sub csv_print_select_table {	Line 3605 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 3139 sub csv_samples_select_table {	Line 3649 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 3234 the routine &Apache::lonnet::transfer_pr	Line 3744 the routine &Apache::lonnet::transfer_pr
my $uniq=0;	my $uniq=0;
sub get_cgi_id {	sub get_cgi_id {
$uniq=($uniq+1)%100000;	$uniq=($uniq+1)%100000;
return (time.'_'.$uniq);	return (time.'_'.$$.'_'.$uniq);
}	}

############################################################	############################################################
Line 3270 they are plotted. If undefined, default	Line 3780 they are plotted. If undefined, default
=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 3290 sub DrawBarGraph {	Line 3803 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;
Line 3365 sub DrawBarGraph {	Line 3882 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 3641 Returns: both routines return nothing	Line 4163 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 = '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 3677 sub store_course_settings {	Line 4199 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 3688 sub store_course_settings {	Line 4210 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.'.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 3734 sub icon {	Line 4256 sub icon {
$curfext.".gif";	$curfext.".gif";
}	}
}	}
return $iconname;	return &lonhttpdurl($iconname);
}	}

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

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

Removed from v.1.226
changed lines
	Added in v.1.286