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.97 and 1.134

version 1.97, 2003/05/03 20:35:43	version 1.134, 2003/10/24 13:35:37
Line 47 Apache::loncommon - pile of common routi	Line 47 Apache::loncommon - pile of common routi

=head1 SYNOPSIS	=head1 SYNOPSIS

Referenced by other mod_perl Apache modules.	Common routines for manipulating connections, student answers,
	domains, common Javascript fragments, etc.

Invocation:	=head1 OVERVIEW
&Apache::loncommon::SUBROUTINENAME(ARGUMENTS);

=head1 INTRODUCTION	A collection of commonly used subroutines that don't have a natural
	home anywhere else. This collection helps remove
Common collection of used subroutines. This collection helps remove
redundancy from other modules and increase efficiency of memory usage.	redundancy from other modules and increase efficiency of memory usage.

Current things done:

Makes a table out of the previous homework attempts
Inputs result_from_symbread, user, domain, course_id
Reads in non-network-related .tab files

This is part of the LearningOnline Network with CAPA project
described at http://www.lon-capa.org.

=head2 General Subroutines

=over 4

=cut	=cut

# End of POD header	# End of POD header
Line 79 use strict;	Line 65 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);	use Apache::Constants qw(:common :http :methods);
use Apache::lonmsg();	use Apache::lonmsg();
use Apache::lonmenu();	use Apache::lonmenu();
	use Apache::lonlocal;

my $readit;	my $readit;

=pod	=pod

=item Global Variables	=head1 Global Variables

=over 4

=cut	=cut

# ----------------------------------------------- Filetypes/Languages/Copyright	# ----------------------------------------------- Filetypes/Languages/Copyright
my %language;	my %language;
	my %supported_language;
my %cprtag;	my %cprtag;
my %fe; my %fd;	my %fe; my %fd;
my %category_extensions;	my %category_extensions;
Line 103 my %designhash;	Line 91 my %designhash;

# ---------------------------------------------- Thesaurus variables	# ---------------------------------------------- Thesaurus variables

	# FIXME: I don't think it's necessary to document these things;
	# they're privately used - Jeremy

=pod	=pod

=item %Keywords	=over 4

	=item * %Keywords

A hash used by &keyword to determine if a word is considered a keyword.	A hash used by &keyword to determine if a word is considered a keyword.

=item $thesaurus_db_file	=item * $thesaurus_db_file

Scalar containing the full path to the thesaurus database.	Scalar containing the full path to the thesaurus database.

	=back

=cut	=cut

my %Keywords;	my %Keywords;
my $thesaurus_db_file;	my $thesaurus_db_file;

	# ----------------------------------------------------------------------- BEGIN

	# FIXME: I don't think this needs to be documented, it prepares
	# private data structures - Jeremy
=pod	=pod

=back	=head1 General Subroutines

=cut

# ----------------------------------------------------------------------- BEGIN

=pod	=over 4

=item BEGIN()	=item * BEGIN()

Initialize values from language.tab, copyright.tab, filetypes.tab,	Initialize values from language.tab, copyright.tab, filetypes.tab,
thesaurus.tab, and filecategories.tab.	thesaurus.tab, and filecategories.tab.

	=back

=cut	=cut

# ----------------------------------------------------------------------- BEGIN	# ----------------------------------------------------------------------- BEGIN
Line 151 BEGIN {	Line 147 BEGIN {
while (<$fh>) {	while (<$fh>) {
next if /^\#/;	next if /^\#/;
chomp;	chomp;
my ($key,$val)=(split(/\s+/,$_,2));	my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$_));
$language{$key}=$val;	$language{$key}=$val.' - '.$enc;
	if ($sup) {
	$supported_language{$key}=$sup;
	}
}	}
}	}
}	}
Line 228 BEGIN {	Line 227 BEGIN {
} # end of unless($readit)	} # end of unless($readit)

}	}
# ============================================================= END BEGIN BLOCK
###############################################################	###############################################################
## HTML and Javascript Helper Functions ##	## HTML and Javascript Helper Functions ##
###############################################################	###############################################################

=pod	=pod

=item browser_and_searcher_javascript	=head1 HTML and Javascript Functions

Returns scalar containing javascript to open a browser window	=over 4
or a searcher window. Also creates
	=item * browser_and_searcher_javascript ()

	X<browsing, javascript>X<searching, javascript>Returns a string
	containing javascript with two functions, C<openbrowser> and
	C<opensearcher>. Returned string does not contain E<lt>scriptE<gt>
	tags.

=over 4	=over 4

=item openbrowser(formname,elementname,only,omit) [javascript]	=item * openbrowser(formname,elementname,only,omit) [javascript]

inputs: formname, elementname, only, omit	inputs: formname, elementname, only, omit

Line 255 with the given extension. Can be a comm	Line 260 with the given extension. Can be a comm
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 seperated list.

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

Inputs: formname, elementname	Inputs: formname, elementname

Line 266 of the element the selection from the se	Line 271 of the element the selection from the se

=cut	=cut

###############################################################
sub browser_and_searcher_javascript {	sub browser_and_searcher_javascript {
return <<END;	return <<END;
var editbrowser = null;	var editbrowser = null;
Line 311 END	Line 315 END
}	}

sub studentbrowser_javascript {	sub studentbrowser_javascript {
unless ($ENV{'request.course.id'}) { return ''; }	unless (
unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) {	(($ENV{'request.course.id'}) &&
return '';	(&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})))
}	\|\| ($ENV{'request.role'}=~/^(au\|dc\|su)/)
	) { return ''; }
return (<<'ENDSTDBRW');	return (<<'ENDSTDBRW');
<script type="text/javascript" language="Javascript" >	<script type="text/javascript" language="Javascript" >
var stdeditbrowser;	var stdeditbrowser;
function openstdbrowser(formname,uname,udom) {	function openstdbrowser(formname,uname,udom,roleflag) {
var url = '/adm/pickstudent?';	var url = '/adm/pickstudent?';
var filter;	var filter;
eval('filter=document.'+formname+'.'+uname+'.value;');	eval('filter=document.'+formname+'.'+uname+'.value;');
Line 329 sub studentbrowser_javascript {	Line 334 sub studentbrowser_javascript {
}	}
url += 'form=' + formname + '&unameelement='+uname+	url += 'form=' + formname + '&unameelement='+uname+
'&udomelement='+udom;	'&udomelement='+udom;
var title = 'Student Browser';	if (roleflag) { url+="&roles=1"; }
	var title = 'Student_Browser';
var options = 'scrollbars=1,resizable=1,menubar=0';	var options = 'scrollbars=1,resizable=1,menubar=0';
options += ',width=700,height=600';	options += ',width=700,height=600';
stdeditbrowser = open(url,title,options,'1');	stdeditbrowser = open(url,title,options,'1');
Line 340 ENDSTDBRW	Line 346 ENDSTDBRW
}	}

sub selectstudent_link {	sub selectstudent_link {
my ($form,$unameele,$udomele)=@_;	my ($form,$unameele,$udomele)=@_;
unless ($ENV{'request.course.id'}) { return ''; }	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.
	'","'.$udomele.'");'."'>".&mt('Select User')."</a>";
}	}
return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.	if ($ENV{'request.role'}=~/^(au\|dc\|su)/) {
'","'.$udomele.'");'."'>Select User</a>";	return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
	'","'.$udomele.'",1);'."'>".&mt('Select User')."</a>";
	}
	return '';
}	}

sub coursebrowser_javascript {	sub coursebrowser_javascript {
return (<<'ENDSTDBRW');	my ($domainfilter)=@_;
	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) {
Line 361 sub coursebrowser_javascript {	Line 374 sub coursebrowser_javascript {
url += 'filter='+filter+'&';	url += 'filter='+filter+'&';
}	}
}	}
	var domainfilter='$domainfilter';
	if (domainfilter != null) {
	if (domainfilter != '') {
	url += 'domainfilter='+domainfilter+'&';
	}
	}
url += 'form=' + formname + '&cnumelement='+uname+	url += 'form=' + formname + '&cnumelement='+uname+
'&cdomelement='+udom;	'&cdomelement='+udom;
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';
stdeditbrowser = open(url,title,options,'1');	stdeditbrowser = open(url,title,options,'1');
Line 376 ENDSTDBRW	Line 395 ENDSTDBRW
sub selectcourse_link {	sub selectcourse_link {
my ($form,$unameele,$udomele)=@_;	my ($form,$unameele,$udomele)=@_;
return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.	return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.
'","'.$udomele.'");'."'>Select Course</a>";	'","'.$udomele.'");'."'>".&mt('Select Course')."</a>";
}	}

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

=pod	=pod

=item linked_select_forms(...)	=item * linked_select_forms(...)

linked_select_forms returns a string containing a <script></script> block	linked_select_forms returns a string containing a <script></script> block
and html for two <select> menus. The select menus will be linked in that	and html for two <select> menus. The select menus will be linked in that
Line 395 linked_select_forms takes the following	Line 412 linked_select_forms takes the following

=over 4	=over 4

=item $formname, the name of the <form> tag	=item * $formname, the name of the <form> tag

=item $middletext, the text which appears between the <select> tags	=item * $middletext, the text which appears between the <select> tags

=item $firstdefault, the default value for the first menu	=item * $firstdefault, the default value for the first menu

=item $firstselectname, the name of the first <select> tag	=item * $firstselectname, the name of the first <select> tag

=item $secondselectname, the name of the second <select> tag	=item * $secondselectname, the name of the second <select> tag

=item $hashref, a reference to a hash containing the data for the menus.	=item * $hashref, a reference to a hash containing the data for the menus.

=back	=back

Line 416 first menu value is given in $menu{$choi	Line 433 first menu value is given in $menu{$choi
and text for the second menu are given in the hash pointed to by	and text for the second menu are given in the hash pointed to by
$menu{$choice1}->{'select2'}.	$menu{$choice1}->{'select2'}.

my %menu = ( A1 => { text =>"Choice A1" ,	my %menu = ( A1 => { text =>"Choice A1" ,
default => "B3",	default => "B3",
select2 => {	select2 => {
B1 => "Choice B1",	B1 => "Choice B1",
B2 => "Choice B2",	B2 => "Choice B2",
B3 => "Choice B3",	B3 => "Choice B3",
B4 => "Choice B4"	B4 => "Choice B4"
}	}
},	},
A2 => { text =>"Choice A2" ,	A2 => { text =>"Choice A2" ,
default => "C2",	default => "C2",
select2 => {	select2 => {
C1 => "Choice C1",	C1 => "Choice C1",
C2 => "Choice C2",	C2 => "Choice C2",
C3 => "Choice C3"	C3 => "Choice C3"
}	}
},	},
A3 => { text =>"Choice A3" ,	A3 => { text =>"Choice A3" ,
default => "D6",	default => "D6",
select2 => {	select2 => {
D1 => "Choice D1",	D1 => "Choice D1",
D2 => "Choice D2",	D2 => "Choice D2",
D3 => "Choice D3",	D3 => "Choice D3",
D4 => "Choice D4",	D4 => "Choice D4",
D5 => "Choice D5",	D5 => "Choice D5",
D6 => "Choice D6",	D6 => "Choice D6",
D7 => "Choice D7"	D7 => "Choice D7"
}	}
}	}
);	);

=cut	=cut

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

sub linked_select_forms {	sub linked_select_forms {
my ($formname,	my ($formname,
$middletext,	$middletext,
Line 512 END	Line 527 END
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=\"true\" " if ($value eq $firstdefault);
$result.=">$hashref->{$value}->{'text'}</option>\n";	$result.=">".&mt($hashref->{$value}->{'text'})."</option>\n";
}	}
$result .= "</select>\n";	$result .= "</select>\n";
my %select2 = %{$hashref->{$firstdefault}->{'select2'}};	my %select2 = %{$hashref->{$firstdefault}->{'select2'}};
Line 522 END	Line 537 END
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=\"true\" " if ($value eq $seconddefault);
$result.=">$select2{$value}</option>\n";	$result.=">".&mt($select2{$value})."</option>\n";
}	}
$result .= "</select>\n";	$result .= "</select>\n";
# return $debug;	# return $debug;
return $result;	return $result;
} # end of sub linked_select_forms {	} # end of sub linked_select_forms {

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

=pod	=pod

=item help_open_topic($topic, $text, $stayOnPage, $width, $height)	=item * help_open_topic($topic, $text, $stayOnPage, $width, $height)

Returns a string corresponding to an HTML link to the given help $topic, where $topic corresponds to the name of a .tex file in /home/httpd/html/adm/help/tex, with underscores replaced by spaces.

$text will optionally be linked to the same topic, allowing you to link text in addition to the graphic. If you do not want to link text, but wish to specify one of the later parameters, pass an empty string.

$stayOnPage is a value that will be interpreted as a boolean. If true, the link will not open a new window. If false, the link will open a new window using Javascript. (Default is false.)	Returns a string corresponding to an HTML link to the given help
	$topic, where $topic corresponds to the name of a .tex file in
$width and $height are optional numerical parameters that will override the width and height of the popped up window, which may be useful for certain help topics with big pictures included.	/home/httpd/html/adm/help/tex, with underscores replaced by
	spaces.

	$text will optionally be linked to the same topic, allowing you to
	link text in addition to the graphic. If you do not want to link
	text, but wish to specify one of the later parameters, pass an
	empty string.

	$stayOnPage is a value that will be interpreted as a boolean. If true,
	the link will not open a new window. If false, the link will open
	a new window using Javascript. (Default is false.)

	$width and $height are optional numerical parameters that will
	override the width and height of the popped up window, which may
	be useful for certain help topics with big pictures included.

=cut	=cut

Line 549 sub help_open_topic {	Line 572 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' ) {
$stayOnPage=1;	$stayOnPage=1;
}	}
$width = 350 if (not defined $width);	$width = 350 if (not defined $width);
Line 586 ENDTEMPLATE	Line 610 ENDTEMPLATE

}	}

	# This is a quicky function for Latex cheatsheet editing, since it
	# appears in at least four places
	sub helpLatexCheatsheet {
	my $other = shift;
	my $addOther = '';
	if ($other) {
	$addOther = Apache::loncommon::help_open_topic($other, shift,
	undef, undef, 600) .
	'</td><td>';
	}
	return '<table><tr><td>'.
	$addOther .
	&Apache::loncommon::help_open_topic("Greek_Symbols",'Greek Symbols',
	undef,undef,600)
	.'</td><td>'.
	&Apache::loncommon::help_open_topic("Other_Symbols",'Other Symbols',
	undef,undef,600)
	.'</td></tr></table>';
	}

=pod	=pod

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

Translate $text to allow it to be output as a 'comma seperated values'	Translate $text to allow it to be output as a 'comma seperated values'
format.	format.
Line 602 sub csv_translate {	Line 646 sub csv_translate {
return $text;	return $text;
}	}

	=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

	=cut

###############################################################	###############################################################
## Home server <option> list generating code ##	## Home server <option> list generating code ##
###############################################################	###############################################################
#-------------------------------------------

=pod	=pod

=item get_domains()	=head1 Home Server option list generating code

	=over 4

	=item * get_domains()

Returns an array containing each of the domains listed in the hosts.tab	Returns an array containing each of the domains listed in the hosts.tab
file.	file.
Line 631 sub get_domains {	Line 763 sub get_domains {

=pod	=pod

=item select_form($defdom,$name,%hash)	=item * select_form($defdom,$name,%hash)

Returns a string containing a <select name='$name' size='1'> form to	Returns a string containing a <select name='$name' size='1'> form to
allow a user to select options from a hash option_name => displayed text.	allow a user to select options from a hash option_name => displayed text.
Line 643 See lonrights.pm for an example invocati	Line 775 See lonrights.pm for an example invocati
sub select_form {	sub select_form {
my ($def,$name,%hash) = @_;	my ($def,$name,%hash) = @_;
my $selectform = "<select name=\"$name\" size=\"1\">\n";	my $selectform = "<select name=\"$name\" size=\"1\">\n";
foreach (sort keys %hash) {	my @keys;
	if (exists($hash{'select_form_order'})) {
	@keys=@{$hash{'select_form_order'}};
	} else {
	@keys=sort(keys(%hash));
	}
	foreach (@keys) {
$selectform.="<option value=\"$_\" ".	$selectform.="<option value=\"$_\" ".
($_ eq $def ? 'selected' : '').	($_ eq $def ? 'selected' : '').
">".$hash{$_}."</option>\n";	">".&mt($hash{$_})."</option>\n";
}	}
$selectform.="</select>";	$selectform.="</select>";
return $selectform;	return $selectform;
Line 657 sub select_form {	Line 795 sub select_form {

=pod	=pod

=item select_dom_form($defdom,$name,$includeempty)	=item * select_dom_form($defdom,$name,$includeempty)

Returns a string containing a <select name='$name' size='1'> form to	Returns a string containing a <select name='$name' size='1'> form to
allow a user to select the domain to preform an operation in.	allow a user to select the domain to preform an operation in.
Line 687 sub select_dom_form {	Line 825 sub select_dom_form {

=pod	=pod

=item get_library_servers($domain)	=item * get_library_servers($domain)

Returns a hash which contains keys like '103l3' and values like	Returns a hash which contains keys like '103l3' and values like
'kirk.lite.msu.edu'. All of the keys will be for machines in the	'kirk.lite.msu.edu'. All of the keys will be for machines in the
Line 711 sub get_library_servers {	Line 849 sub get_library_servers {

=pod	=pod

=item home_server_option_list($domain)	=item * home_server_option_list($domain)

returns a string which contains an <option> list to be used in a	returns a string which contains an <option> list to be used in a
<select> form input. See loncreateuser.pm for an example.	<select> form input. See loncreateuser.pm for an example.
Line 729 sub home_server_option_list {	Line 867 sub home_server_option_list {
}	}
return $result;	return $result;
}	}
###############################################################
## End of home server <option> list generating code ##	=pod
###############################################################
	=back

	=cut

###############################################################	###############################################################
	## Decoding User Agent ##
###############################################################	###############################################################

=pod	=pod

=item &decode_user_agent()	=head1 Decoding the User Agent

	=over 4

	=item * &decode_user_agent()

Inputs: $r	Inputs: $r

Line 746 Outputs:	Line 892 Outputs:

=over 4	=over 4

=item $httpbrowser	=item * $httpbrowser

=item $clientbrowser	=item * $clientbrowser

=item $clientversion	=item * $clientversion

=item $clientmathml	=item * $clientmathml

=item $clientunicode	=item * $clientunicode

=item $clientos	=item * $clientos

=back	=back

Line 798 sub decode_user_agent {	Line 944 sub decode_user_agent {
$clientunicode,$clientos,);	$clientunicode,$clientos,);
}	}

###############################################################	=pod
###############################################################

	=back

	=cut

###############################################################	###############################################################
## Authentication changing form generation subroutines ##	## Authentication changing form generation subroutines ##
Line 814 sub decode_user_agent {	Line 962 sub decode_user_agent {

=pod	=pod

=item authform_xxxxxx	=head1 Authentication Routines

	=over 4

	=item * authform_xxxxxx

The authform_xxxxxx subroutines provide javascript and html forms which	The authform_xxxxxx subroutines provide javascript and html forms which
handle some of the conveniences required for authentication forms.	handle some of the conveniences required for authentication forms.
Line 824 See loncreateuser.pm for invocation and	Line 976 See loncreateuser.pm for invocation and

=over 4	=over 4

=item authform_header	=item * authform_header

=item authform_authorwarning	=item * authform_authorwarning

=item authform_nochange	=item * authform_nochange

=item authform_kerberos	=item * authform_kerberos

=item authform_internal	=item * authform_internal

=item authform_filesystem	=item * authform_filesystem

=back	=back

Line 1032 END	Line 1184 END
return $result;	return $result;
}	}

###############################################################	=pod
## End Authentication changing form generation functions ##
###############################################################	=back

	=cut

###############################################################	###############################################################
## Get Authentication Defaults for Domain ##	## Get Authentication Defaults for Domain ##
###############################################################	###############################################################
##
## Returns default authentication type and an associated argument
## as listed in file domain.tab
##
#-------------------------------------------

=pod	=pod

=item get_auth_defaults	=head1 Domains and Authentication

	Returns default authentication type and an associated argument as
	listed in file 'domain.tab'.

	=over 4

	=item * get_auth_defaults

get_auth_defaults($target_domain) returns the default authentication	get_auth_defaults($target_domain) returns the default authentication
type and an associated argument (initial password or a kerberos domain).	type and an associated argument (initial password or a kerberos domain).
Line 1057 These values are stored in lonTabs/domai	Line 1213 These values are stored in lonTabs/domai

If target_domain is not found in domain.tab, returns nothing ('').	If target_domain is not found in domain.tab, returns nothing ('').

=over 4

=item get_auth_defaults

=back

=cut	=cut

#-------------------------------------------	#-------------------------------------------
Line 1086 sub get_auth_defaults {	Line 1236 sub get_auth_defaults {

=pod	=pod

=item get_kerberos_defaults	=item * get_kerberos_defaults

get_kerberos_defaults($target_domain) returns the default kerberos	get_kerberos_defaults($target_domain) returns the default kerberos
version and domain. If not found in domain.tabs, it defaults to	version and domain. If not found in domain.tabs, it defaults to
Line 1094 version 4 and the domain of the server.	Line 1244 version 4 and the domain of the server.

($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain);	($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain);

=over 4

=item get_kerberos_defaults

=back

=cut	=cut

#-------------------------------------------	#-------------------------------------------
Line 1115 sub get_kerberos_defaults {	Line 1259 sub get_kerberos_defaults {
}	}
return ($krbdef,$krbdefdom);	return ($krbdef,$krbdefdom);
}	}
###############################################################
## End Get Kerberos Defaults for Domain ##	=pod
###############################################################
	=back

	=cut

###############################################################	###############################################################
## Thesaurus Functions ##	## Thesaurus Functions ##
Line 1125 sub get_kerberos_defaults {	Line 1272 sub get_kerberos_defaults {

=pod	=pod

=item initialize_keywords	=head1 Thesaurus Functions

	=over 4

	=item * initialize_keywords

Initializes the package variable %Keywords if it is empty. Uses the	Initializes the package variable %Keywords if it is empty. Uses the
package variable $thesaurus_db_file.	package variable $thesaurus_db_file.
Line 1170 sub initialize_keywords {	Line 1321 sub initialize_keywords {

=pod	=pod

=item keyword($word)	=item * keyword($word)

Returns true if $word is a keyword. A keyword is a word that appears more	Returns true if $word is a keyword. A keyword is a word that appears more
than the average number of times in the thesaurus database. Calls	than the average number of times in the thesaurus database. Calls
Line 1191 sub keyword {	Line 1342 sub keyword {

=pod	=pod

=item get_related_words	=item * get_related_words

Look up a word in the thesaurus. Takes a scalar arguement and returns	Look up a word in the thesaurus. Takes a scalar arguement and returns
an array of words. If the keyword is not in the thesaurus, an empty array	an array of words. If the keyword is not in the thesaurus, an empty array
Line 1228 sub get_related_words {	Line 1379 sub get_related_words {
return @Words;	return @Words;
}	}

###############################################################	=pod
## End Thesaurus Functions ##
###############################################################	=back

	=cut

# -------------------------------------------------------------- Plaintext name	# -------------------------------------------------------------- Plaintext name
=pod	=pod

=item plainname($uname,$udom)	=head1 User Name Functions

Gets a users name and returns it as a string in	=over 4
"first middle last generation"
form	=item * plainname($uname,$udom)

	Takes a users logon name and returns it as a string in
	"first middle last generation" form

=cut	=cut

Line 1259 sub plainname {	Line 1415 sub plainname {
# -------------------------------------------------------------------- Nickname	# -------------------------------------------------------------------- Nickname
=pod	=pod

=item nickname($uname,$udom)	=item * nickname($uname,$udom)

Gets a users name and returns it as a string as	Gets a users name and returns it as a string as

Line 1294 sub nickname {	Line 1450 sub nickname {

=pod	=pod

=item screenname($uname,$udom)	=item * screenname($uname,$udom)

Gets a users screenname and returns it as a string	Gets a users screenname and returns it as a string

Line 1332 sub aboutmewrapper {	Line 1488 sub aboutmewrapper {


sub syllabuswrapper {	sub syllabuswrapper {
my ($link,$un,$do,$tf)=@_;	my ($linktext,$coursedir,$domain,$fontcolor)=@_;
if ($tf) { $link='<font color="'.$tf.'">'.$link.'</font>'; }	if ($fontcolor) {
return "<a href='/public/$do/$un/syllabus'>$link</a>";	$linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>';
	}
	return "<a href='/public/$domain/$coursedir/syllabus'>$linktext</a>";
}	}

# ---------------------------------------------------------------- Language IDs	=pod

	=back

	=head1 Access .tab File Data

	=over 4

	=item * languageids()

	returns list of all language ids

	=cut

sub languageids {	sub languageids {
return sort(keys(%language));	return sort(keys(%language));
}	}

# -------------------------------------------------------- Language Description	=pod

	=item * languagedescription()

	returns description of a specified language id

	=cut

sub languagedescription {	sub languagedescription {
return $language{shift(@_)};	my $code=shift;
	return ($supported_language{$code}?'* ':'').
	$language{$code}.
	($supported_language{$code}?' ('.&mt('interface available').')':'');
}	}

# ----------------------------------------------------------- Display Languages	=pod
# returns a hash with all desired display languages
#

sub display_languages {	=item * copyrightids()
my %languages=();
if ($ENV{'environment.languages'}) {	returns list of all copyrights
foreach (split(/\s(\,\|\;\|\:)\s/,$ENV{'environment.languages'})) {
$languages{$_}=1;	=cut
}
}
&get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
if ($ENV{'form.displaylanguage'}) {
foreach (split(/\s(\,\|\;\|\:)\s/,$ENV{'form.displaylanguage'})) {
$languages{$_}=1;
}
}
return %languages;
}

# --------------------------------------------------------------- Copyright IDs
sub copyrightids {	sub copyrightids {
return sort(keys(%cprtag));	return sort(keys(%cprtag));
}	}

# ------------------------------------------------------- Copyright Description	=pod

	=item * copyrightdescription()

	returns description of a specified copyright id

	=cut

sub copyrightdescription {	sub copyrightdescription {
return $cprtag{shift(@_)};	return $cprtag{shift(@_)};
}	}

# ------------------------------------------------------------- File Categories	=pod

	=item * filecategories()

	returns list of all file categories

	=cut

sub filecategories {	sub filecategories {
return sort(keys(%category_extensions));	return sort(keys(%category_extensions));
}	}

# -------------------------------------- File Types within a specified category	=pod

	=item * filecategorytypes()

	returns list of file types belonging to a given file
	category

	=cut

sub filecategorytypes {	sub filecategorytypes {
return @{$category_extensions{lc($_[0])}};	return @{$category_extensions{lc($_[0])}};
}	}

# ------------------------------------------------------------------ File Types	=pod
sub fileextensions {
return sort(keys(%fe));	=item * fileembstyle()
}
	returns embedding style for a specified file type

	=cut

# ------------------------------------------------------------- Embedding Style
sub fileembstyle {	sub fileembstyle {
return $fe{lc(shift(@_))};	return $fe{lc(shift(@_))};
}	}

# ------------------------------------------------------------ Description Text	=pod

	=item * filedescription()

	returns description for a specified file type

	=cut

sub filedescription {	sub filedescription {
return $fd{lc(shift(@_))};	return $fd{lc(shift(@_))};
}	}

# ------------------------------------------------------------ Description Text	=pod

	=item * filedescriptionex()

	returns description for a specified file type with
	extra formatting

	=cut

sub filedescriptionex {	sub filedescriptionex {
my $ex=shift;	my $ex=shift;
return '.'.$ex.' '.$fd{lc($ex)};	return '.'.$ex.' '.$fd{lc($ex)};
}	}

# ---- Retrieve attempts by students	# End of .tab access
# input	=pod
# $symb - problem including path
# $username,$domain - that of the student	=back
# $course - course name
# $getattempt - leave blank if want all attempts, else put something.	=cut
# $regexp - regular expression. If string matches regexp send to
# $gradesub - routine that process the string if it matches regexp	# ------------------------------------------------------------------ File Types
#	sub fileextensions {
# output	return sort(keys(%fe));
# formatted as a table all the attempts, if any.	}

	# ----------------------------------------------------------- Display Languages
	# returns a hash with all desired display languages
#	#

	sub display_languages {
	my %languages=();
	foreach (&preferred_languages()) {
	$languages{$_}=1;
	}
	&get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
	if ($ENV{'form.displaylanguage'}) {
	foreach (split(/\s(\,\|\;\|\:)\s/,$ENV{'form.displaylanguage'})) {
	$languages{$_}=1;
	}
	}
	return %languages;
	}

	sub preferred_languages {
	my @languages=();
	if ($ENV{'environment.languages'}) {
	@languages=split(/\s(\,\|\;\|\:)\s/,$ENV{'environment.languages'});
	}
	if ($ENV{'course.'.$ENV{'request.course.id'}.'.languages'}) {
	@languages=(@languages,split(/\s(\,\|\;\|\:)\s/,
	$ENV{'course.'.$ENV{'request.course.id'}.'.languages'}));
	}
	my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0];
	if ($browser) {
	@languages=(@languages,split(/\s(\,\|\;\|\:)\s/,$browser));
	}
	if ($Apache::lonnet::domain_lang_def{$ENV{'user.domain'}}) {
	@languages=(@languages,
	$Apache::lonnet::domain_lang_def{$ENV{'user.domain'}});
	}
	if ($Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}}) {
	@languages=(@languages,
	$Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}});
	}
	if ($Apache::lonnet::domain_lang_def{
	$Apache::lonnet::perlvar{'lonDefDomain'}}) {
	@languages=(@languages,
	$Apache::lonnet::domain_lang_def{
	$Apache::lonnet::perlvar{'lonDefDomain'}});
	}
	# turn "en-ca" into "en-ca,en"
	my @genlanguages;
	foreach (@languages) {
	unless ($_=~/\w/) { next; }
	push (@genlanguages,$_);
	if ($_=~/(\-\|\_)/) {
	push (@genlanguages,(split(/(\-\|\_)/,$_))[0]);
	}
	}
	return @genlanguages;
	}

	###############################################################
	## Student Answer Attempts ##
	###############################################################

	=pod

	=head1 Alternate Problem Views

	=over 4

	=item * get_previous_attempt($symb, $username, $domain, $course,
	$getattempt, $regexp, $gradesub)

	Return string with previous attempt on problem. Arguments:

	=over 4

	=item * $symb: Problem, including path

	=item * $username: username of the desired student

	=item * $domain: domain of the desired student

	=item * $course: Course ID

	=item * $getattempt: Leave blank for all attempts, otherwise put
	something

	=item * $regexp: if string matches this regexp, the string will be
	sent to $gradesub

	=item * $gradesub: routine that processes the string if it matches $regexp

	=back

	The output string is a table containing all desired attempts, if any.

	=cut

sub get_previous_attempt {	sub get_previous_attempt {
my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_;	my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_;
my $prevattempts='';	my $prevattempts='';
Line 1485 sub get_previous_attempt {	Line 1788 sub get_previous_attempt {
}	}
}	}

	sub relative_to_absolute {
	my ($url,$output)=@_;
	my $parser=HTML::TokeParser->new(\$output);
	my $token;
	my $thisdir=$url;
	my @rlinks=();
	while ($token=$parser->get_token) {
	if ($token->[0] eq 'S') {
	if ($token->[1] eq 'a') {
	if ($token->[2]->{'href'}) {
	$rlinks[$#rlinks+1]=$token->[2]->{'href'};
	}
	} elsif ($token->[1] eq 'img' \|\| $token->[1] eq 'embed' ) {
	$rlinks[$#rlinks+1]=$token->[2]->{'src'};
	} elsif ($token->[1] eq 'base') {
	$thisdir=$token->[2]->{'href'};
	}
	}
	}
	$thisdir=~s-/[^/]*$--;
	foreach (@rlinks) {
	unless (($_=~/^http:\/\//i) \|\|
	($_=~/^\//) \|\|
	($_=~/^javascript:/i) \|\|
	($_=~/^mailto:/i) \|\|
	($_=~/^\#/)) {
	my $newlocation=&Apache::lonnet::hreflocation($thisdir,$_);
	$output=~s/(\"\|\'\|\=\s*)$_(\"\|\'\|\s\|\>)/$1$newlocation$2/;
	}
	}
	# -------------------------------------------------- Deal with Applet codebases
	$output=~s/(\<applet[^\>]+)(codebase\=[^\S\>]+)([^\>])\>/$1.($2?$2:' codebase="'.$thisdir.'"').$3.'>'/gei;
	return $output;
	}

	=pod

	=item * get_student_view

	show a snapshot of what student was looking at

	=cut

sub get_student_view {	sub get_student_view {
my ($symb,$username,$domain,$courseid,$target) = @_;	my ($symb,$username,$domain,$courseid,$target) = @_;
my ($map,$id,$feedurl) = split(/___/,$symb);	my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
my (%old,%moreenv);	my (%old,%moreenv);
my @elements=('symb','courseid','domain','username');	my @elements=('symb','courseid','domain','username');
foreach my $element (@elements) {	foreach my $element (@elements) {
Line 1496 sub get_student_view {	Line 1842 sub get_student_view {
}	}
if ($target eq 'tex') {$moreenv{'form.grade_target'} = 'tex';}	if ($target eq 'tex') {$moreenv{'form.grade_target'} = 'tex';}
&Apache::lonnet::appenv(%moreenv);	&Apache::lonnet::appenv(%moreenv);
my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);	$feedurl=&Apache::lonnet::clutter($feedurl);
	my $userview=&Apache::lonnet::ssi_body($feedurl);
&Apache::lonnet::delenv('form.grade_');	&Apache::lonnet::delenv('form.grade_');
foreach my $element (@elements) {	foreach my $element (@elements) {
$ENV{'form.grade_'.$element}=$old{$element};	$ENV{'form.grade_'.$element}=$old{$element};
Line 1508 sub get_student_view {	Line 1855 sub get_student_view {
$userview=~s/\<head\>//gi;	$userview=~s/\<head\>//gi;
$userview=~s/\<\/head\>//gi;	$userview=~s/\<\/head\>//gi;
$userview=~s/action\s*\=/would_be_action\=/gi;	$userview=~s/action\s*\=/would_be_action\=/gi;
	$userview=&relative_to_absolute($feedurl,$userview);
return $userview;	return $userview;
}	}

	=pod

	=item * get_student_answers()

	show a snapshot of how student was answering problem

	=cut

sub get_student_answers {	sub get_student_answers {
my ($symb,$username,$domain,$courseid) = @_;	my ($symb,$username,$domain,$courseid,%form) = @_;
my ($map,$id,$feedurl) = split(/___/,$symb);	my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
my (%old,%moreenv);	my (%old,%moreenv);
my @elements=('symb','courseid','domain','username');	my @elements=('symb','courseid','domain','username');
foreach my $element (@elements) {	foreach my $element (@elements) {
Line 1522 sub get_student_answers {	Line 1878 sub get_student_answers {
}	}
$moreenv{'form.grade_target'}='answer';	$moreenv{'form.grade_target'}='answer';
&Apache::lonnet::appenv(%moreenv);	&Apache::lonnet::appenv(%moreenv);
my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);	my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%form);
&Apache::lonnet::delenv('form.grade_');	&Apache::lonnet::delenv('form.grade_');
foreach my $element (@elements) {	foreach my $element (@elements) {
$ENV{'form.grade_'.$element}=$old{$element};	$ENV{'form.grade_'.$element}=$old{$element};
Line 1530 sub get_student_answers {	Line 1886 sub get_student_answers {
return $userview;	return $userview;
}	}

	=pod

	=item * &submlink()

	Inputs: $text $uname $udom $symb

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

	=cut

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

	=pod

	=back

	=cut

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


Line 1594 sub findallcourses {	Line 1980 sub findallcourses {

=pod	=pod

=item &determinedomain()	=head1 Domain Template Functions

	=over 4

	=item * &determinedomain()

Inputs: $domain (usually will be undef)	Inputs: $domain (usually will be undef)

Line 1618 sub determinedomain {	Line 2008 sub determinedomain {
###############################################	###############################################
=pod	=pod

=item &domainlogo()	=item * &domainlogo()

Inputs: $domain (usually will be undef)	Inputs: $domain (usually will be undef)

Line 1626 Returns: A link to a domain logo, if the	Line 2016 Returns: A link to a domain logo, if the
If the domain logo does not exist, a description of the domain.	If the domain logo does not exist, a description of the domain.

=cut	=cut

###############################################	###############################################
sub domainlogo {	sub domainlogo {
my $domain = &determinedomain(shift);	my $domain = &determinedomain(shift);
Line 1645 sub domainlogo {	Line 2036 sub domainlogo {

=pod	=pod

=item &designparm()	=item * &designparm()

Inputs: $which parameter; $domain (usually will be undef)	Inputs: $which parameter; $domain (usually will be undef)

Returns: value of designparamter $which	Returns: value of designparamter $which

=cut	=cut

##############################################	##############################################
sub designparm {	sub designparm {
my ($which,$domain)=@_;	my ($which,$domain)=@_;
	if ($ENV{'browser.blackwhite'} eq 'on') {
	if ($which=~/\.(font\|alink\|vlink\|link)$/) {
	return '#000000';
	}
	if ($which=~/\.(pgbg\|sidebg)$/) {
	return '#FFFFFF';
	}
	if ($which=~/\.tabbg$/) {
	return '#CCCCCC';
	}
	}
if ($ENV{'environment.color.'.$which}) {	if ($ENV{'environment.color.'.$which}) {
return $ENV{'environment.color.'.$which};	return $ENV{'environment.color.'.$which};
}	}
Line 1671 sub designparm {	Line 2074 sub designparm {

=pod	=pod

=item &bodytag()	=back

	=head1 HTTP Helpers

	=over 4

	=item * &bodytag()

Returns a uniform header for LON-CAPA web pages.	Returns a uniform header for LON-CAPA web pages.

Inputs:	Inputs:

$title, A title to be displayed on the page.	=over 4
$function, the current role (can be undef).
$addentries, extra parameters for the <body> tag.	=item * $title, A title to be displayed on the page.
$bodyonly, if defined, only return the <body> tag.
$domain, if defined, force a given domain.	=item * $function, the current role (can be undef).
$forcereg, if page should register as content page (relevant for
	=item * $addentries, extra parameters for the <body> tag.

	=item * $bodyonly, if defined, only return the <body> tag.

	=item * $domain, if defined, force a given domain.

	=item * $forcereg, if page should register as content page (relevant for
text interface only)	text interface only)

	=back

Returns: A uniform header for LON-CAPA web pages.	Returns: A uniform header for LON-CAPA web pages.
If $bodyonly is nonzero, a string containing a <body> tag will be returned.	If $bodyonly is nonzero, a string containing a <body> tag will be returned.
If $bodyonly is undef or zero, an html string containing a <body> tag and	If $bodyonly is undef or zero, an html string containing a <body> tag and
Line 1692 other decorations will be returned.	Line 2110 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)=@_;
	$title=&mt($title);
unless ($function) {	unless ($function) {
$function='student';	$function='student';
if ($ENV{'request.role'}=~/^(cc\|in\|ta\|ep)/) {	if ($ENV{'request.role'}=~/^(cc\|in\|ta\|ep)/) {
Line 1719 sub bodytag {	Line 2134 sub bodytag {
my $alink=&designparm($function.'.alink',$domain);	my $alink=&designparm($function.'.alink',$domain);
my $vlink=&designparm($function.'.vlink',$domain);	my $vlink=&designparm($function.'.vlink',$domain);
my $sidebg=&designparm($function.'.sidebg',$domain);	my $sidebg=&designparm($function.'.sidebg',$domain);
	# Accessibility font enhance
	unless ($addentries) { $addentries=''; }
	if ($ENV{'browser.fontenhance'} eq 'on') {
	$addentries.=' style="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]);
Line 1731 sub bodytag {	Line 2150 sub bodytag {
unless ($realm) { $realm=' '; }	unless ($realm) { $realm=' '; }
# Set messages	# Set messages
my $messages=&domainlogo($domain);	my $messages=&domainlogo($domain);
# Output	# Port for miniserver
my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};	my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }	if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
	# construct main body tag
my $bodytag = <<END;	my $bodytag = <<END;
<body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link"	<body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link"
$addentries>	$addentries>
Line 1785 $upperleft</td>	Line 2205 $upperleft</td>
</table><br>	</table><br>
ENDBODY	ENDBODY
}	}

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

	sub get_posted_cgi {
	my $r=shift;

	my $buffer;

	$r->read($buffer,$r->header_in('Content-length'),0);
	unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) {
	my @pairs=split(/&/,$buffer);
	my $pair;
	foreach $pair (@pairs) {
	my ($name,$value) = split(/=/,$pair);
	$value =~ tr/+/ /;
	$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
	$name =~ tr/+/ /;
	$name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
	&add_to_env("form.$name",$value);
	}
	} else {
	my $contentsep=$1;
	my @lines = split (/\n/,$buffer);
	my $name='';
	my $value='';
	my $fname='';
	my $fmime='';
	my $i;
	for ($i=0;$i<=$#lines;$i++) {
	if ($lines[$i]=~/^$contentsep/) {
	if ($name) {
	chomp($value);
	if ($fname) {
	$ENV{"form.$name.filename"}=$fname;
	$ENV{"form.$name.mimetype"}=$fmime;
	} else {
	$value=~s/\s+$//s;
	}
	&add_to_env("form.$name",$value);
	}
	if ($i<$#lines) {
	$i++;
	$lines[$i]=~
	/Content\-Disposition\:\sform\-data\;\sname\=\"([^\"]+)\"/i;
	$name=$1;
	$value='';
	if ($lines[$i]=~/filename\=\"([^\"]+)\"/i) {
	$fname=$1;
	if
	($lines[$i+1]=~/Content\-Type\:\s*([\w\-\/]+)/i) {
	$fmime=$1;
	$i++;
	} else {
	$fmime='';
	}
	} else {
	$fname='';
	$fmime='';
	}
	$i++;
	}
	} else {
	$value.=$lines[$i]."\n";
	}
	}
	}
	$ENV{'request.method'}=$ENV{'REQUEST_METHOD'};
	$r->method_number(M_GET);
	$r->method('GET');
	$r->headers_in->unset('Content-length');
	}

	=pod

	=item * get_unprocessed_cgi($query,$possible_names)

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

	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:
	get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
	will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set.

	=cut

sub get_unprocessed_cgi {	sub get_unprocessed_cgi {
my ($query,$possible_names)= @_;	my ($query,$possible_names)= @_;
# $Apache::lonxml::debug=1;	# $Apache::lonxml::debug=1;
Line 1802 sub get_unprocessed_cgi {	Line 2307 sub get_unprocessed_cgi {
}	}
}	}

	=pod

	=item * cacheheader()

	returns cache-controlling header code

	=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);
Line 1811 sub cacheheader {	Line 2324 sub cacheheader {
return $output;	return $output;
}	}

	=pod

	=item * no_cache($r)

	specifies header code to not have cache

	=cut

sub no_cache {	sub no_cache {
my ($r) = @_;	my ($r) = @_;
unless ($ENV{'request.method'} eq 'GET') { return ''; }	unless ($ENV{'request.method'} eq 'GET') { return ''; }
Line 1820 sub no_cache {	Line 2341 sub no_cache {
#$r->header_out("Expires" => $date);	#$r->header_out("Expires" => $date);
}	}

	sub content_type {
	my ($r,$type,$charset) = @_;
	unless ($charset) {
	$charset=&Apache::lonlocal::current_encoding;
	}
	$r->content_type($type.($charset?'; charset='.$charset:''));
	}

	=pod

	=item * add_to_env($name,$value)

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

	=cut

sub add_to_env {	sub add_to_env {
my ($name,$value)=@_;	my ($name,$value)=@_;
if (defined($ENV{$name})) {	if (defined($ENV{$name})) {
Line 1841 sub add_to_env {	Line 2380 sub add_to_env {

=back	=back

=head2 CSV Upload/Handling functions	=head1 CSV Upload/Handling functions

=over 4	=over 4

=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'}
Line 1872 sub upfile_store {	Line 2411 sub upfile_store {

=pod	=pod

=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'},
Line 1895 sub load_tmp_file {	Line 2434 sub load_tmp_file {

=pod	=pod

=item upfile_record_sep()	=item * upfile_record_sep()

Separate uploaded file into records	Separate uploaded file into records
returns array of records,	returns array of records,
Line 1912 sub upfile_record_sep {	Line 2451 sub upfile_record_sep {

=pod	=pod

=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'}

Line 1964 sub record_sep {	Line 2503 sub record_sep {

=pod	=pod

=item upfile_select_html()	=item * upfile_select_html()

return HTML code to select file and specify its type	return HTML code to select file and specify its type

Line 1984 ENDUPFORM	Line 2523 ENDUPFORM

=pod	=pod

=item csv_print_samples($r,$records)	=item * csv_print_samples($r,$records)

Prints a table of sample values from each column uploaded $r is an	Prints a table of sample values from each column uploaded $r is an
Apache Request ref, $records is an arrayref from	Apache Request ref, $records is an arrayref from
Line 2016 sub csv_print_samples {	Line 2555 sub csv_print_samples {

=pod	=pod

=item csv_print_select_table($r,$records,$d)	=item * csv_print_select_table($r,$records,$d)

Prints a table to create associations between values and table columns.	Prints a table to create associations between values and table columns.
$r is an Apache Request ref,	$r is an Apache Request ref,
Line 2050 sub csv_print_select_table {	Line 2589 sub csv_print_select_table {

=pod	=pod

=item csv_samples_select_table($r,$records,$d)	=item * csv_samples_select_table($r,$records,$d)

Prints a table of sample values from the upload and can make associate samples to internal names.	Prints a table of sample values from the upload and can make associate samples to internal names.

Line 2090 sub csv_samples_select_table {	Line 2629 sub csv_samples_select_table {

=pod	=pod

=item check_if_partid_hidden($id,$symb,$udom,$uname)	=item clean_excel_name($name)

	Returns a replacement for $name which does not contain any illegal characters.

	=cut

	sub clean_excel_name {
	my ($name) = @_;
	$name =~ s/[:\*\?\/\\]//g;
	if (length($name) > 31) {
	$name = substr($name,0,31);
	}
	return $name;
	}

	=pod

	=item * check_if_partid_hidden($id,$symb,$udom,$uname)

Returns either 1 or undef	Returns either 1 or undef

Line 2107 $uname, optional the username of the use	Line 2663 $uname, optional the username of the use

sub check_if_partid_hidden {	sub check_if_partid_hidden {
my ($id,$symb,$udom,$uname) = @_;	my ($id,$symb,$udom,$uname) = @_;
my $hiddenparts=&Apache::lonnet::EXT('resource.0.parameter_hiddenparts',	my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts',
$symb,$udom,$uname);	$symb,$udom,$uname);
my @hiddenlist=split(/,/,$hiddenparts);	my @hiddenlist=split(/,/,$hiddenparts);
foreach my $checkid (@hiddenlist) {	foreach my $checkid (@hiddenlist) {
Line 2116 sub check_if_partid_hidden {	Line 2672 sub check_if_partid_hidden {
return undef;	return undef;
}	}

	############################################################
	############################################################
1;
__END__;

=pod	=pod

=back	=item DrawBarGraph

=head2 Access .tab File Data

=over 4

=item languageids()

returns list of all language ids

=item languagedescription()

returns description of a specified language id

=item copyrightids()

returns list of all copyrights

=item copyrightdescription()

returns description of a specified copyright id

=item filecategories()

returns list of all file categories

=item filecategorytypes()

returns list of file types belonging to a given file
category

=item fileembstyle()

returns embedding style for a specified file type

=item filedescription()

returns description for a specified file type

=item filedescriptionex()

returns description for a specified file type with
extra formatting

=back

=head2 Alternate Problem Views

=over 4

=item get_previous_attempt()

return string with previous attempt on problem	=cut

=item get_student_view()

show a snapshot of what student was looking at	############################################################
	############################################################
	sub DrawBarGraph {
	my ($Title,$xlabel,$ylabel,$Max,$colors,@Values)=@_;
	#
	if (! defined($colors)) {
	$colors = ['#33ff00',
	'#0033cc', '#990000', '#aaaa66', '#663399', '#ff9933',
	'#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66',
	];
	}
	#
	my $identifier = time.'_'.int(rand(1000));
	if (! @Values \|\| ref($Values[0]) ne 'ARRAY') {
	return '';
	}
	my $NumBars = scalar(@{$Values[0]});
	my %ValuesHash;
	my $NumSets=1;
	foreach my $array (@Values) {
	next if (! ref($array));
	$ValuesHash{'cgi.'.$identifier.'.data.'.$NumSets++} =
	join(',',@$array);
	}
	#
	$Title = '' if (! defined($Title));
	$xlabel = '' if (! defined($xlabel));
	$ylabel = '' if (! defined($ylabel));
	$Title = &Apache::lonnet::escape($Title);
	$xlabel = &Apache::lonnet::escape($xlabel);
	$ylabel = &Apache::lonnet::escape($ylabel);
	#
	$Max = 1 if ($Max < 1);
	if ( int($Max) < $Max ) {
	$Max++;
	$Max = int($Max);
	}
	#
	&Apache::lonnet::appenv('cgi.'.$identifier.'.title' => $Title,
	'cgi.'.$identifier.'.xlabel' => $xlabel,
	'cgi.'.$identifier.'.ylabel' => $ylabel,
	'cgi.'.$identifier.'.Max' => $Max,
	'cgi.'.$identifier.'.NumBars' => $NumBars,
	'cgi.'.$identifier.'.NumSets' => $NumSets,
	'cgi.'.$identifier.'.Colors' => join(',',@{$colors}),
	%ValuesHash);
	return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
	}

=item get_student_answers()	############################################################
	############################################################

show a snapshot of how student was answering problem	=pod

=back	=back

=head2 HTTP Helper	=cut

=over 4

=item get_unprocessed_cgi($query,$possible_names)

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

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:
get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set.

=item cacheheader()

returns cache-controlling header code

=item no_cache($r)

specifies header code to not have cache

=item add_to_env($name,$value)

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

=back	1;
	__END__;

=cut

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

Removed from v.1.97
changed lines
	Added in v.1.134