|
version 1.12, 2001/12/11 13:49:57
|
version 1.152, 2003/11/10 23:25:52
|
|
Line 27
|
Line 27
|
| # |
# |
| # YEAR=2001 |
# YEAR=2001 |
| # 2/13-12/7 Guy Albertelli |
# 2/13-12/7 Guy Albertelli |
| # 12/11 Scott Harrison |
# 12/21 Gerd Kortemeyer |
| |
# 12/25,12/28 Gerd Kortemeyer |
| |
# YEAR=2002 |
| |
# 1/4 Gerd Kortemeyer |
| |
# 6/24,7/2 H. K. Ng |
| |
|
| # Makes a table out of the previous attempts |
# Makes a table out of the previous attempts |
| # Inputs result_from_symbread, user, domain, course_id |
# Inputs result_from_symbread, user, domain, course_id |
| |
# Reads in non-network-related .tab files |
| |
|
| |
# POD header: |
| |
|
| |
=pod |
| |
|
| |
=head1 NAME |
| |
|
| |
Apache::loncommon - pile of common routines |
| |
|
| |
=head1 SYNOPSIS |
| |
|
| |
Common routines for manipulating connections, student answers, |
| |
domains, common Javascript fragments, etc. |
| |
|
| |
=head1 OVERVIEW |
| |
|
| |
A collection of commonly used subroutines that don't have a natural |
| |
home anywhere else. This collection helps remove |
| |
redundancy from other modules and increase efficiency of memory usage. |
| |
|
| |
=cut |
| |
|
| |
# End of POD header |
| package Apache::loncommon; |
package Apache::loncommon; |
| |
|
| use strict; |
use strict; |
| use POSIX qw(strftime); |
use Apache::lonnet(); |
| use Apache::Constants qw(:common); |
use GDBM_File; |
| |
use POSIX qw(strftime mktime); |
| |
use Apache::Constants qw(:common :http :methods); |
| use Apache::lonmsg(); |
use Apache::lonmsg(); |
| |
use Apache::lonmenu(); |
| |
use Apache::lonlocal; |
| |
use HTML::Entities; |
| |
|
| |
my $readit; |
| |
|
| |
=pod |
| |
|
| |
=head1 Global Variables |
| |
|
| |
=cut |
| |
|
| |
# ----------------------------------------------- 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; |
| |
|
| # ----------------------------------------------------------------------- BEGIN |
# ---------------------------------------------- Designs |
| sub BEGIN { |
|
| |
my %designhash; |
| |
|
| |
# ---------------------------------------------- Thesaurus variables |
| |
# |
| |
# %Keywords: |
| |
# A hash used by &keyword to determine if a word is considered a keyword. |
| |
# $thesaurus_db_file |
| |
# Scalar containing the full path to the thesaurus database. |
| |
|
| |
my %Keywords; |
| |
my $thesaurus_db_file; |
| |
|
| |
# |
| |
# Initialize values from language.tab, copyright.tab, filetypes.tab, |
| |
# thesaurus.tab, and filecategories.tab. |
| |
# |
| |
BEGIN { |
| |
# Variable initialization |
| |
$thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db"; |
| |
# |
| |
unless ($readit) { |
| # ------------------------------------------------------------------- languages |
# ------------------------------------------------------------------- languages |
| { |
{ |
| my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. |
my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. |
| '/language.tab'); |
'/language.tab'); |
| while (<$fh>) { |
if ($fh) { |
| next if /^\#/; |
while (<$fh>) { |
| chomp; |
next if /^\#/; |
| my ($key,$val)=(split(/\s+/,$_,2)); |
chomp; |
| $language{$key}=$val; |
my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$_)); |
| |
$language{$key}=$val.' - '.$enc; |
| |
if ($sup) { |
| |
$supported_language{$key}=$sup; |
| |
} |
| |
} |
| } |
} |
| } |
} |
| # ------------------------------------------------------------------ copyrights |
# ------------------------------------------------------------------ copyrights |
| { |
{ |
| |
my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonIncludes'}. |
| |
'/copyright.tab'); |
| |
if ($fh) { |
| |
while (<$fh>) { |
| |
next if /^\#/; |
| |
chomp; |
| |
my ($key,$val)=(split(/\s+/,$_,2)); |
| |
$cprtag{$key}=$val; |
| |
} |
| |
} |
| |
} |
| |
|
| |
# -------------------------------------------------------------- domain designs |
| |
|
| |
my $filename; |
| |
my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; |
| |
opendir(DIR,$designdir); |
| |
while ($filename=readdir(DIR)) { |
| |
my ($domain)=($filename=~/^(\w+)\./); |
| |
{ |
| |
my $fh=Apache::File->new($designdir.'/'.$filename); |
| |
if ($fh) { |
| |
while (<$fh>) { |
| |
next if /^\#/; |
| |
chomp; |
| |
my ($key,$val)=(split(/\=/,$_)); |
| |
if ($val) { $designhash{$domain.'.'.$key}=$val; } |
| |
} |
| |
} |
| |
} |
| |
|
| |
} |
| |
closedir(DIR); |
| |
|
| |
|
| |
# ------------------------------------------------------------- file categories |
| |
{ |
| my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. |
my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. |
| '/copyright.tab'); |
'/filecategories.tab'); |
| while (<$fh>) { |
if ($fh) { |
| next if /^\#/; |
while (<$fh>) { |
| chomp; |
next if /^\#/; |
| my ($key,$val)=(split(/\s+/,$_,2)); |
chomp; |
| $copyright{$key}=$val; |
my ($extension,$category)=(split(/\s+/,$_,2)); |
| |
push @{$category_extensions{lc($category)}},$extension; |
| |
} |
| } |
} |
| } |
} |
| # ------------------------------------------------------------------ file types |
# ------------------------------------------------------------------ file types |
| { |
{ |
| my $fh=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab"); |
my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. |
| while (<$fh>) { |
'/filetypes.tab'); |
| next if (/^\#/); |
if ($fh) { |
| chomp; |
while (<$fh>) { |
| my ($ending,$emb,$descr)=split(/\s+/,$_,3); |
next if (/^\#/); |
| if ($descr ne '') { |
chomp; |
| $fe{$ending}=lc($emb); |
my ($ending,$emb,$descr)=split(/\s+/,$_,3); |
| $fd{$ending}=join(' ',@descr); |
if ($descr ne '') { |
| |
$fe{$ending}=lc($emb); |
| |
$fd{$ending}=$descr; |
| |
} |
| } |
} |
| } |
} |
| } |
} |
| |
&Apache::lonnet::logthis( |
| |
"<font color=yellow>INFO: Read file types</font>"); |
| |
$readit=1; |
| |
} # end of unless($readit) |
| |
|
| |
} |
| |
|
| |
############################################################### |
| |
## HTML and Javascript Helper Functions ## |
| |
############################################################### |
| |
|
| |
=pod |
| |
|
| |
=head1 General Subroutines |
| |
|
| |
=over 4 |
| |
|
| |
=head1 HTML and Javascript Functions |
| |
|
| |
=over 4 |
| |
|
| |
=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 |
| |
|
| |
=item * openbrowser(formname,elementname,only,omit) [javascript] |
| |
|
| |
inputs: formname, elementname, only, omit |
| |
|
| |
formname and elementname indicate the name of the html form and name of |
| |
the element that the results of the browsing selection are to be placed in. |
| |
|
| |
Specifying 'only' will restrict the browser to displaying only files |
| |
with the given extension. Can be a comma seperated list. |
| |
|
| |
Specifying 'omit' will restrict the browser to NOT displaying files |
| |
with the given extension. Can be a comma seperated list. |
| |
|
| |
=item * opensearcher(formname, elementname) [javascript] |
| |
|
| |
Inputs: formname, elementname |
| |
|
| |
formname and elementname specify the name of the html form and the name |
| |
of the element the selection from the search results will be placed in. |
| |
|
| |
=back |
| |
|
| |
=cut |
| |
|
| |
sub browser_and_searcher_javascript { |
| |
return <<END; |
| |
var editbrowser = null; |
| |
function openbrowser(formname,elementname,only,omit,titleelement) { |
| |
var url = '/res/?'; |
| |
if (editbrowser == null) { |
| |
url += 'launch=1&'; |
| |
} |
| |
url += 'catalogmode=interactive&'; |
| |
url += 'mode=edit&'; |
| |
url += 'form=' + formname + '&'; |
| |
if (only != null) { |
| |
url += 'only=' + only + '&'; |
| |
} |
| |
if (omit != null) { |
| |
url += 'omit=' + omit + '&'; |
| |
} |
| |
if (titleelement != null) { |
| |
url += 'titleelement=' + titleelement + '&'; |
| |
} |
| |
url += 'element=' + elementname + ''; |
| |
var title = 'Browser'; |
| |
var options = 'scrollbars=1,resizable=1,menubar=0'; |
| |
options += ',width=700,height=600'; |
| |
editbrowser = open(url,title,options,'1'); |
| |
editbrowser.focus(); |
| |
} |
| |
var editsearcher; |
| |
function opensearcher(formname,elementname,titleelement) { |
| |
var url = '/adm/searchcat?'; |
| |
if (editsearcher == null) { |
| |
url += 'launch=1&'; |
| |
} |
| |
url += 'catalogmode=interactive&'; |
| |
url += 'mode=edit&'; |
| |
url += 'form=' + formname + '&'; |
| |
if (titleelement != null) { |
| |
url += 'titleelement=' + titleelement + '&'; |
| |
} |
| |
url += 'element=' + elementname + ''; |
| |
var title = 'Search'; |
| |
var options = 'scrollbars=1,resizable=1,menubar=0'; |
| |
options += ',width=700,height=600'; |
| |
editsearcher = open(url,title,options,'1'); |
| |
editsearcher.focus(); |
| |
} |
| |
END |
| |
} |
| |
|
| |
sub studentbrowser_javascript { |
| |
unless ( |
| |
(($ENV{'request.course.id'}) && |
| |
(&Apache::lonnet::allowed('srm',$ENV{'request.course.id'}))) |
| |
|| ($ENV{'request.role'}=~/^(au|dc|su)/) |
| |
) { return ''; } |
| |
return (<<'ENDSTDBRW'); |
| |
<script type="text/javascript" language="Javascript" > |
| |
var stdeditbrowser; |
| |
function openstdbrowser(formname,uname,udom,roleflag) { |
| |
var url = '/adm/pickstudent?'; |
| |
var filter; |
| |
eval('filter=document.'+formname+'.'+uname+'.value;'); |
| |
if (filter != null) { |
| |
if (filter != '') { |
| |
url += 'filter='+filter+'&'; |
| |
} |
| |
} |
| |
url += 'form=' + formname + '&unameelement='+uname+ |
| |
'&udomelement='+udom; |
| |
if (roleflag) { url+="&roles=1"; } |
| |
var title = 'Student_Browser'; |
| |
var options = 'scrollbars=1,resizable=1,menubar=0'; |
| |
options += ',width=700,height=600'; |
| |
stdeditbrowser = open(url,title,options,'1'); |
| |
stdeditbrowser.focus(); |
| |
} |
| |
</script> |
| |
ENDSTDBRW |
| |
} |
| |
|
| |
sub selectstudent_link { |
| |
my ($form,$unameele,$udomele)=@_; |
| |
if ($ENV{'request.course.id'}) { |
| |
unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) { |
| |
return ''; |
| |
} |
| |
return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele. |
| |
'","'.$udomele.'");'."'>".&mt('Select User')."</a>"; |
| |
} |
| |
if ($ENV{'request.role'}=~/^(au|dc|su)/) { |
| |
return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele. |
| |
'","'.$udomele.'",1);'."'>".&mt('Select User')."</a>"; |
| |
} |
| |
return ''; |
| |
} |
| |
|
| |
sub coursebrowser_javascript { |
| |
my ($domainfilter)=@_; |
| |
return (<<ENDSTDBRW); |
| |
<script type="text/javascript" language="Javascript" > |
| |
var stdeditbrowser; |
| |
function opencrsbrowser(formname,uname,udom) { |
| |
var url = '/adm/pickcourse?'; |
| |
var filter; |
| |
if (filter != null) { |
| |
if (filter != '') { |
| |
url += 'filter='+filter+'&'; |
| |
} |
| |
} |
| |
var domainfilter='$domainfilter'; |
| |
if (domainfilter != null) { |
| |
if (domainfilter != '') { |
| |
url += 'domainfilter='+domainfilter+'&'; |
| |
} |
| |
} |
| |
url += 'form=' + formname + '&cnumelement='+uname+ |
| |
'&cdomelement='+udom; |
| |
var title = 'Course_Browser'; |
| |
var options = 'scrollbars=1,resizable=1,menubar=0'; |
| |
options += ',width=700,height=600'; |
| |
stdeditbrowser = open(url,title,options,'1'); |
| |
stdeditbrowser.focus(); |
| |
} |
| |
</script> |
| |
ENDSTDBRW |
| |
} |
| |
|
| |
sub selectcourse_link { |
| |
my ($form,$unameele,$udomele)=@_; |
| |
return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele. |
| |
'","'.$udomele.'");'."'>".&mt('Select Course')."</a>"; |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=item * linked_select_forms(...) |
| |
|
| |
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 |
| |
changing the value of the first menu will result in new values being placed |
| |
in the second menu. The values in the select menu will appear in alphabetical |
| |
order. |
| |
|
| |
linked_select_forms takes the following ordered inputs: |
| |
|
| |
=over 4 |
| |
|
| |
=item * $formname, the name of the <form> tag |
| |
|
| |
=item * $middletext, the text which appears between the <select> tags |
| |
|
| |
=item * $firstdefault, the default value for the first menu |
| |
|
| |
=item * $firstselectname, the name of the first <select> tag |
| |
|
| |
=item * $secondselectname, the name of the second <select> tag |
| |
|
| |
=item * $hashref, a reference to a hash containing the data for the menus. |
| |
|
| |
=back |
| |
|
| |
Below is an example of such a hash. Only the 'text', 'default', and |
| |
'select2' keys must appear as stated. keys(%menu) are the possible |
| |
values for the first select menu. The text that coincides with the |
| |
first menu value is given in $menu{$choice1}->{'text'}. The values |
| |
and text for the second menu are given in the hash pointed to by |
| |
$menu{$choice1}->{'select2'}. |
| |
|
| |
my %menu = ( A1 => { text =>"Choice A1" , |
| |
default => "B3", |
| |
select2 => { |
| |
B1 => "Choice B1", |
| |
B2 => "Choice B2", |
| |
B3 => "Choice B3", |
| |
B4 => "Choice B4" |
| |
} |
| |
}, |
| |
A2 => { text =>"Choice A2" , |
| |
default => "C2", |
| |
select2 => { |
| |
C1 => "Choice C1", |
| |
C2 => "Choice C2", |
| |
C3 => "Choice C3" |
| |
} |
| |
}, |
| |
A3 => { text =>"Choice A3" , |
| |
default => "D6", |
| |
select2 => { |
| |
D1 => "Choice D1", |
| |
D2 => "Choice D2", |
| |
D3 => "Choice D3", |
| |
D4 => "Choice D4", |
| |
D5 => "Choice D5", |
| |
D6 => "Choice D6", |
| |
D7 => "Choice D7" |
| |
} |
| |
} |
| |
); |
| |
|
| |
=cut |
| |
|
| |
sub linked_select_forms { |
| |
my ($formname, |
| |
$middletext, |
| |
$firstdefault, |
| |
$firstselectname, |
| |
$secondselectname, |
| |
$hashref |
| |
) = @_; |
| |
my $second = "document.$formname.$secondselectname"; |
| |
my $first = "document.$formname.$firstselectname"; |
| |
# output the javascript to do the changing |
| |
my $result = ''; |
| |
$result.="<script>\n"; |
| |
$result.="var select2data = new Object();\n"; |
| |
$" = '","'; |
| |
my $debug = ''; |
| |
foreach my $s1 (sort(keys(%$hashref))) { |
| |
$result.="select2data.d_$s1 = new Object();\n"; |
| |
$result.="select2data.d_$s1.def = new String('". |
| |
$hashref->{$s1}->{'default'}."');\n"; |
| |
$result.="select2data.d_$s1.values = new Array("; |
| |
my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } )); |
| |
$result.="\"@s2values\");\n"; |
| |
$result.="select2data.d_$s1.texts = new Array("; |
| |
my @s2texts; |
| |
foreach my $value (@s2values) { |
| |
push @s2texts, $hashref->{$s1}->{'select2'}->{$value}; |
| |
} |
| |
$result.="\"@s2texts\");\n"; |
| |
} |
| |
$"=' '; |
| |
$result.= <<"END"; |
| |
|
| |
function select1_changed() { |
| |
// Determine new choice |
| |
var newvalue = "d_" + $first.value; |
| |
// update select2 |
| |
var values = select2data[newvalue].values; |
| |
var texts = select2data[newvalue].texts; |
| |
var select2def = select2data[newvalue].def; |
| |
var i; |
| |
// out with the old |
| |
for (i = 0; i < $second.options.length; i++) { |
| |
$second.options[i] = null; |
| |
} |
| |
// in with the nuclear |
| |
for (i=0;i<values.length; i++) { |
| |
$second.options[i] = new Option(values[i]); |
| |
$second.options[i].value = values[i]; |
| |
$second.options[i].text = texts[i]; |
| |
if (values[i] == select2def) { |
| |
$second.options[i].selected = true; |
| |
} |
| |
} |
| |
} |
| |
</script> |
| |
END |
| |
# output the initial values for the selection lists |
| |
$result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n"; |
| |
foreach my $value (sort(keys(%$hashref))) { |
| |
$result.=" <option value=\"$value\" "; |
| |
$result.=" selected=\"true\" " if ($value eq $firstdefault); |
| |
$result.=">".&mt($hashref->{$value}->{'text'})."</option>\n"; |
| |
} |
| |
$result .= "</select>\n"; |
| |
my %select2 = %{$hashref->{$firstdefault}->{'select2'}}; |
| |
$result .= $middletext; |
| |
$result .= "<select size=\"1\" name=\"$secondselectname\">\n"; |
| |
my $seconddefault = $hashref->{$firstdefault}->{'default'}; |
| |
foreach my $value (sort(keys(%select2))) { |
| |
$result.=" <option value=\"$value\" "; |
| |
$result.=" selected=\"true\" " if ($value eq $seconddefault); |
| |
$result.=">".&mt($select2{$value})."</option>\n"; |
| |
} |
| |
$result .= "</select>\n"; |
| |
# return $debug; |
| |
return $result; |
| |
} # end of sub linked_select_forms { |
| |
|
| |
=pod |
| |
|
| |
=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.) |
| |
|
| |
$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 |
| |
|
| |
sub help_open_topic { |
| |
my ($topic, $text, $stayOnPage, $width, $height) = @_; |
| |
$text = "" if (not defined $text); |
| |
$stayOnPage = 0 if (not defined $stayOnPage); |
| |
if ($ENV{'browser.interface'} eq 'textual' || |
| |
$ENV{'environment.remote'} eq 'off' ) { |
| |
$stayOnPage=1; |
| |
} |
| |
$width = 350 if (not defined $width); |
| |
$height = 400 if (not defined $height); |
| |
my $filename = $topic; |
| |
$filename =~ s/ /_/g; |
| |
|
| |
my $template = ""; |
| |
my $link; |
| |
|
| |
if (!$stayOnPage) |
| |
{ |
| |
$link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; |
| |
} |
| |
else |
| |
{ |
| |
$link = "/adm/help/${filename}.hlp"; |
| |
} |
| |
|
| |
# Add the text |
| |
if ($text ne "") |
| |
{ |
| |
$template .= |
| |
"<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>". |
| |
"<td bgcolor='#5555FF'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>"; |
| |
} |
| |
|
| |
# Add the graphic |
| |
$template .= <<"ENDTEMPLATE"; |
| |
<a href="$link"><image src="/adm/help/gif/smallHelp.gif" border="0" alt="(Help: $topic)" /></a> |
| |
ENDTEMPLATE |
| |
if ($text ne '') { $template.='</td></tr></table>' }; |
| |
return $template; |
| |
|
| |
} |
| |
|
| |
# 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 |
| |
|
| |
=item * csv_translate($text) |
| |
|
| |
Translate $text to allow it to be output as a 'comma seperated values' |
| |
format. |
| |
|
| |
=cut |
| |
|
| |
sub csv_translate { |
| |
my $text = shift; |
| |
$text =~ s/\"/\"\"/g; |
| |
$text =~ s/\n//g; |
| |
return $text; |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=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 ## |
| |
############################################################### |
| |
|
| |
=pod |
| |
|
| |
=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 |
| |
file. |
| |
|
| |
=cut |
| |
|
| |
#------------------------------------------- |
| |
sub get_domains { |
| |
# The code below was stolen from "The Perl Cookbook", p 102, 1st ed. |
| |
my @domains; |
| |
my %seen; |
| |
foreach (sort values(%Apache::lonnet::hostdom)) { |
| |
push (@domains,$_) unless $seen{$_}++; |
| |
} |
| |
return @domains; |
| |
} |
| |
|
| |
#------------------------------------------- |
| |
|
| |
=pod |
| |
|
| |
=item * select_form($defdom,$name,%hash) |
| |
|
| |
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. |
| |
See lonrights.pm for an example invocation and use. |
| |
|
| |
=cut |
| |
|
| |
#------------------------------------------- |
| |
sub select_form { |
| |
my ($def,$name,%hash) = @_; |
| |
my $selectform = "<select name=\"$name\" size=\"1\">\n"; |
| |
my @keys; |
| |
if (exists($hash{'select_form_order'})) { |
| |
@keys=@{$hash{'select_form_order'}}; |
| |
} else { |
| |
@keys=sort(keys(%hash)); |
| |
} |
| |
foreach (@keys) { |
| |
$selectform.="<option value=\"$_\" ". |
| |
($_ eq $def ? 'selected' : ''). |
| |
">".&mt($hash{$_})."</option>\n"; |
| |
} |
| |
$selectform.="</select>"; |
| |
return $selectform; |
| |
} |
| |
|
| |
|
| |
#------------------------------------------- |
| |
|
| |
=pod |
| |
|
| |
=item * select_dom_form($defdom,$name,$includeempty) |
| |
|
| |
Returns a string containing a <select name='$name' size='1'> form to |
| |
allow a user to select the domain to preform an operation in. |
| |
See loncreateuser.pm for an example invocation and use. |
| |
|
| |
If the $includeempty flag is set, it also includes an empty choice ("no domain |
| |
selected"); |
| |
|
| |
=cut |
| |
|
| |
#------------------------------------------- |
| |
sub select_dom_form { |
| |
my ($defdom,$name,$includeempty) = @_; |
| |
my @domains = get_domains(); |
| |
if ($includeempty) { @domains=('',@domains); } |
| |
my $selectdomain = "<select name=\"$name\" size=\"1\">\n"; |
| |
foreach (@domains) { |
| |
$selectdomain.="<option value=\"$_\" ". |
| |
($_ eq $defdom ? 'selected' : ''). |
| |
">$_</option>\n"; |
| |
} |
| |
$selectdomain.="</select>"; |
| |
return $selectdomain; |
| |
} |
| |
|
| |
#------------------------------------------- |
| |
|
| |
=pod |
| |
|
| |
=item * get_library_servers($domain) |
| |
|
| |
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 |
| |
given $domain. |
| |
|
| |
=cut |
| |
|
| |
#------------------------------------------- |
| |
sub get_library_servers { |
| |
my $domain = shift; |
| |
my %library_servers; |
| |
foreach (keys(%Apache::lonnet::libserv)) { |
| |
if ($Apache::lonnet::hostdom{$_} eq $domain) { |
| |
$library_servers{$_} = $Apache::lonnet::hostname{$_}; |
| |
} |
| |
} |
| |
return %library_servers; |
| } |
} |
| |
|
| |
#------------------------------------------- |
| |
|
| |
=pod |
| |
|
| |
=item * home_server_option_list($domain) |
| |
|
| |
returns a string which contains an <option> list to be used in a |
| |
<select> form input. See loncreateuser.pm for an example. |
| |
|
| |
=cut |
| |
|
| |
#------------------------------------------- |
| |
sub home_server_option_list { |
| |
my $domain = shift; |
| |
my %servers = &get_library_servers($domain); |
| |
my $result = ''; |
| |
foreach (sort keys(%servers)) { |
| |
$result.= |
| |
'<option value="'.$_.'">'.$_.' '.$servers{$_}."</option>\n"; |
| |
} |
| |
return $result; |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=back |
| |
|
| |
=cut |
| |
|
| |
############################################################### |
| |
## Decoding User Agent ## |
| |
############################################################### |
| |
|
| |
=pod |
| |
|
| |
=head1 Decoding the User Agent |
| |
|
| |
=over 4 |
| |
|
| |
=item * &decode_user_agent() |
| |
|
| |
Inputs: $r |
| |
|
| |
Outputs: |
| |
|
| |
=over 4 |
| |
|
| |
=item * $httpbrowser |
| |
|
| |
=item * $clientbrowser |
| |
|
| |
=item * $clientversion |
| |
|
| |
=item * $clientmathml |
| |
|
| |
=item * $clientunicode |
| |
|
| |
=item * $clientos |
| |
|
| |
=back |
| |
|
| |
=cut |
| |
|
| |
############################################################### |
| |
############################################################### |
| |
sub decode_user_agent { |
| |
my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"}); |
| |
my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"}); |
| |
my $httpbrowser=$ENV{"HTTP_USER_AGENT"}; |
| |
my $clientbrowser='unknown'; |
| |
my $clientversion='0'; |
| |
my $clientmathml=''; |
| |
my $clientunicode='0'; |
| |
for (my $i=0;$i<=$#browsertype;$i++) { |
| |
my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]); |
| |
if (($httpbrowser=~/$match/i) && ($httpbrowser!~/$notmatch/i)) { |
| |
$clientbrowser=$bname; |
| |
$httpbrowser=~/$vreg/i; |
| |
$clientversion=$1; |
| |
$clientmathml=($clientversion>=$minv); |
| |
$clientunicode=($clientversion>=$univ); |
| |
} |
| |
} |
| |
my $clientos='unknown'; |
| |
if (($httpbrowser=~/linux/i) || |
| |
($httpbrowser=~/unix/i) || |
| |
($httpbrowser=~/ux/i) || |
| |
($httpbrowser=~/solaris/i)) { $clientos='unix'; } |
| |
if (($httpbrowser=~/vax/i) || |
| |
($httpbrowser=~/vms/i)) { $clientos='vms'; } |
| |
if ($httpbrowser=~/next/i) { $clientos='next'; } |
| |
if (($httpbrowser=~/mac/i) || |
| |
($httpbrowser=~/powerpc/i)) { $clientos='mac'; } |
| |
if ($httpbrowser=~/win/i) { $clientos='win'; } |
| |
if ($httpbrowser=~/embed/i) { $clientos='pda'; } |
| |
return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml, |
| |
$clientunicode,$clientos,); |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=back |
| |
|
| |
=cut |
| |
|
| |
############################################################### |
| |
## Authentication changing form generation subroutines ## |
| |
############################################################### |
| |
## |
| |
## All of the authform_xxxxxxx subroutines take their inputs in a |
| |
## hash, and have reasonable default values. |
| |
## |
| |
## formname = the name given in the <form> tag. |
| |
#------------------------------------------- |
| |
|
| |
=pod |
| |
|
| |
=head1 Authentication Routines |
| |
|
| |
=over 4 |
| |
|
| |
=item * authform_xxxxxx |
| |
|
| |
The authform_xxxxxx subroutines provide javascript and html forms which |
| |
handle some of the conveniences required for authentication forms. |
| |
This is not an optimal method, but it works. |
| |
|
| |
See loncreateuser.pm for invocation and use examples. |
| |
|
| |
=over 4 |
| |
|
| |
=item * authform_header |
| |
|
| |
=item * authform_authorwarning |
| |
|
| |
=item * authform_nochange |
| |
|
| |
=item * authform_kerberos |
| |
|
| |
=item * authform_internal |
| |
|
| |
=item * authform_filesystem |
| |
|
| |
=back |
| |
|
| |
=cut |
| |
|
| |
#------------------------------------------- |
| |
sub authform_header{ |
| |
my %in = ( |
| |
formname => 'cu', |
| |
kerb_def_dom => '', |
| |
@_, |
| |
); |
| |
$in{'formname'} = 'document.' . $in{'formname'}; |
| |
my $result=''; |
| |
|
| |
#---------------------------------------------- Code for upper case translation |
| |
my $Javascript_toUpperCase; |
| |
unless ($in{kerb_def_dom}) { |
| |
$Javascript_toUpperCase =<<"END"; |
| |
switch (choice) { |
| |
case 'krb': currentform.elements[choicearg].value = |
| |
currentform.elements[choicearg].value.toUpperCase(); |
| |
break; |
| |
default: |
| |
} |
| |
END |
| |
} else { |
| |
$Javascript_toUpperCase = ""; |
| |
} |
| |
|
| |
$result.=<<"END"; |
| |
var current = new Object(); |
| |
current.radiovalue = 'nochange'; |
| |
current.argfield = null; |
| |
|
| |
function changed_radio(choice,currentform) { |
| |
var choicearg = choice + 'arg'; |
| |
// If a radio button in changed, we need to change the argfield |
| |
if (current.radiovalue != choice) { |
| |
current.radiovalue = choice; |
| |
if (current.argfield != null) { |
| |
currentform.elements[current.argfield].value = ''; |
| |
} |
| |
if (choice == 'nochange') { |
| |
current.argfield = null; |
| |
} else { |
| |
current.argfield = choicearg; |
| |
switch(choice) { |
| |
case 'krb': |
| |
currentform.elements[current.argfield].value = |
| |
"$in{'kerb_def_dom'}"; |
| |
break; |
| |
default: |
| |
break; |
| |
} |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
function changed_text(choice,currentform) { |
| |
var choicearg = choice + 'arg'; |
| |
if (currentform.elements[choicearg].value !='') { |
| |
$Javascript_toUpperCase |
| |
// clear old field |
| |
if ((current.argfield != choicearg) && (current.argfield != null)) { |
| |
currentform.elements[current.argfield].value = ''; |
| |
} |
| |
current.argfield = choicearg; |
| |
} |
| |
set_auth_radio_buttons(choice,currentform); |
| |
return; |
| |
} |
| |
|
| |
function set_auth_radio_buttons(newvalue,currentform) { |
| |
var i=0; |
| |
while (i < currentform.login.length) { |
| |
if (currentform.login[i].value == newvalue) { break; } |
| |
i++; |
| |
} |
| |
if (i == currentform.login.length) { |
| |
return; |
| |
} |
| |
current.radiovalue = newvalue; |
| |
currentform.login[i].checked = true; |
| |
return; |
| |
} |
| |
END |
| |
return $result; |
| |
} |
| |
|
| |
sub authform_authorwarning{ |
| |
my $result=''; |
| |
$result='<i>'. |
| |
&mt('As a general rule, only authors or co-authors should be '. |
| |
'filesystem authenticated '. |
| |
'(which allows access to the server filesystem).')."</i>\n"; |
| |
return $result; |
| |
} |
| |
|
| |
sub authform_nochange{ |
| |
my %in = ( |
| |
formname => 'document.cu', |
| |
kerb_def_dom => 'MSU.EDU', |
| |
@_, |
| |
); |
| |
my $result = &mt('[_1] Do not change login data', |
| |
'<input type="radio" name="login" value="nochange" '. |
| |
'checked="checked" onclick="'. |
| |
"javascript:changed_radio('nochange',$in{'formname'});".'" />'); |
| |
return $result; |
| |
} |
| |
|
| |
sub authform_kerberos{ |
| |
my %in = ( |
| |
formname => 'document.cu', |
| |
kerb_def_dom => 'MSU.EDU', |
| |
kerb_def_auth => 'krb4', |
| |
@_, |
| |
); |
| |
my ($check4,$check5); |
| |
if ($in{'kerb_def_auth'} eq 'krb5') { |
| |
$check5 = " checked=\"on\""; |
| |
} else { |
| |
$check4 = " checked=\"on\""; |
| |
} |
| |
my $jscall = "javascript:changed_radio('krb',$in{'formname'});"; |
| |
my $result .= &mt |
| |
('[_1] Kerberos authenticated with domain [_2] '. |
| |
'[_3] Version 4 [_4] Version 5', |
| |
'<input type="radio" name="login" value="krb" '. |
| |
'onclick="'.$jscall.'" onchange="'.$jscall.'" />', |
| |
'<input type="text" size="10" name="krbarg" '. |
| |
'value="'.$in{'kerb_def_dom'}.'" '. |
| |
'onchange="'.$jscall.'" />', |
| |
'<input type="radio" name="krbver" value="4" '.$check4.' />', |
| |
'<input type="radio" name="krbver" value="5" '.$check5.' />'); |
| |
return $result; |
| |
} |
| |
|
| |
sub authform_internal{ |
| |
my %args = ( |
| |
formname => 'document.cu', |
| |
kerb_def_dom => 'MSU.EDU', |
| |
@_, |
| |
); |
| |
my $jscall = "javascript:changed_radio('int',$args{'formname'});"; |
| |
my $result.=&mt |
| |
('[_1] Internally authenticated (with initial password [_2])', |
| |
'<input type="radio" name="login" value="int" '. |
| |
'onchange="'.$jscall.'" onclick="'.$jscall.'" />', |
| |
'<input type="text" size="10" name="intarg" value="" '. |
| |
'onchange="'.$jscall.'" />'); |
| |
return $result; |
| |
} |
| |
|
| |
sub authform_local{ |
| |
my %in = ( |
| |
formname => 'document.cu', |
| |
kerb_def_dom => 'MSU.EDU', |
| |
@_, |
| |
); |
| |
my $jscall = "javascript:changed_radio('loc',$in{'formname'});"; |
| |
my $result.=&mt('[_1] Local Authentication with arguement [_2]', |
| |
'<input type="radio" name="login" value="loc" '. |
| |
'onchange="'.$jscall.'" onclick="'.$jscall.'" />', |
| |
'<input type="text" size="10" name="locarg" value="" '. |
| |
'onchange="'.$jscall.'" />'); |
| |
return $result; |
| |
} |
| |
|
| |
sub authform_filesystem{ |
| |
my %in = ( |
| |
formname => 'document.cu', |
| |
kerb_def_dom => 'MSU.EDU', |
| |
@_, |
| |
); |
| |
my $jscall = "javascript:changed_radio('fsys',$in{'formname'});"; |
| |
my $result.= &mt |
| |
('[_1] Filesystem Authenticated (with initial password [_2])', |
| |
'<input type="radio" name="login" value="fsys" '. |
| |
'onchange="'.$jscall.'" onclick="'.$jscall.'" />', |
| |
'<input type="text" size="10" name="fsysarg" value="" '. |
| |
'onchange="'.$jscall.'" />'); |
| |
return $result; |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=back |
| |
|
| |
=cut |
| |
|
| |
############################################################### |
| |
## Get Authentication Defaults for Domain ## |
| |
############################################################### |
| |
|
| |
=pod |
| |
|
| |
=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 |
| |
type and an associated argument (initial password or a kerberos domain). |
| |
These values are stored in lonTabs/domain.tab |
| |
|
| |
($def_auth, $def_arg) = &get_auth_defaults($target_domain); |
| |
|
| |
If target_domain is not found in domain.tab, returns nothing (''). |
| |
|
| |
=cut |
| |
|
| |
#------------------------------------------- |
| |
sub get_auth_defaults { |
| |
my $domain=shift; |
| |
return ($Apache::lonnet::domain_auth_def{$domain},$Apache::lonnet::domain_auth_arg_def{$domain}); |
| |
} |
| |
############################################################### |
| |
## End Get Authentication Defaults for Domain ## |
| |
############################################################### |
| |
|
| |
############################################################### |
| |
## Get Kerberos Defaults for Domain ## |
| |
############################################################### |
| |
## |
| |
## Returns default kerberos version and an associated argument |
| |
## as listed in file domain.tab. If not listed, provides |
| |
## appropriate default domain and kerberos version. |
| |
## |
| |
#------------------------------------------- |
| |
|
| |
=pod |
| |
|
| |
=item * get_kerberos_defaults |
| |
|
| |
get_kerberos_defaults($target_domain) returns the default kerberos |
| |
version and domain. If not found in domain.tabs, it defaults to |
| |
version 4 and the domain of the server. |
| |
|
| |
($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain); |
| |
|
| |
=cut |
| |
|
| |
#------------------------------------------- |
| |
sub get_kerberos_defaults { |
| |
my $domain=shift; |
| |
my ($krbdef,$krbdefdom) = |
| |
&Apache::loncommon::get_auth_defaults($domain); |
| |
unless ($krbdef =~/^krb/ && $krbdefdom) { |
| |
$ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/; |
| |
my $krbdefdom=$1; |
| |
$krbdefdom=~tr/a-z/A-Z/; |
| |
$krbdef = "krb4"; |
| |
} |
| |
return ($krbdef,$krbdefdom); |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=back |
| |
|
| |
=cut |
| |
|
| |
############################################################### |
| |
## Thesaurus Functions ## |
| |
############################################################### |
| |
|
| |
=pod |
| |
|
| |
=head1 Thesaurus Functions |
| |
|
| |
=over 4 |
| |
|
| |
=item * initialize_keywords |
| |
|
| |
Initializes the package variable %Keywords if it is empty. Uses the |
| |
package variable $thesaurus_db_file. |
| |
|
| |
=cut |
| |
|
| |
################################################### |
| |
|
| |
sub initialize_keywords { |
| |
return 1 if (scalar keys(%Keywords)); |
| |
# If we are here, %Keywords is empty, so fill it up |
| |
# Make sure the file we need exists... |
| |
if (! -e $thesaurus_db_file) { |
| |
&Apache::lonnet::logthis("Attempt to access $thesaurus_db_file". |
| |
" failed because it does not exist"); |
| |
return 0; |
| |
} |
| |
# Set up the hash as a database |
| |
my %thesaurus_db; |
| |
if (! tie(%thesaurus_db,'GDBM_File', |
| |
$thesaurus_db_file,&GDBM_READER(),0640)){ |
| |
&Apache::lonnet::logthis("Could not tie \%thesaurus_db to ". |
| |
$thesaurus_db_file); |
| |
return 0; |
| |
} |
| |
# Get the average number of appearances of a word. |
| |
my $avecount = $thesaurus_db{'average.count'}; |
| |
# Put keywords (those that appear > average) into %Keywords |
| |
while (my ($word,$data)=each (%thesaurus_db)) { |
| |
my ($count,undef) = split /:/,$data; |
| |
$Keywords{$word}++ if ($count > $avecount); |
| |
} |
| |
untie %thesaurus_db; |
| |
# Remove special values from %Keywords. |
| |
foreach ('total.count','average.count') { |
| |
delete($Keywords{$_}) if (exists($Keywords{$_})); |
| |
} |
| |
return 1; |
| |
} |
| |
|
| |
################################################### |
| |
|
| |
=pod |
| |
|
| |
=item * keyword($word) |
| |
|
| |
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 |
| |
&initialize_keywords |
| |
|
| |
=cut |
| |
|
| |
################################################### |
| |
|
| |
sub keyword { |
| |
return if (!&initialize_keywords()); |
| |
my $word=lc(shift()); |
| |
$word=~s/\W//g; |
| |
return exists($Keywords{$word}); |
| |
} |
| |
|
| |
############################################################### |
| |
|
| |
=pod |
| |
|
| |
=item * get_related_words |
| |
|
| |
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 |
| |
will be returned. The order of the words returned is determined by the |
| |
database which holds them. |
| |
|
| |
Uses global $thesaurus_db_file. |
| |
|
| |
=cut |
| |
|
| |
############################################################### |
| |
sub get_related_words { |
| |
my $keyword = shift; |
| |
my %thesaurus_db; |
| |
if (! -e $thesaurus_db_file) { |
| |
&Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ". |
| |
"failed because the file does not exist"); |
| |
return (); |
| |
} |
| |
if (! tie(%thesaurus_db,'GDBM_File', |
| |
$thesaurus_db_file,&GDBM_READER(),0640)){ |
| |
return (); |
| |
} |
| |
my @Words=(); |
| |
if (exists($thesaurus_db{$keyword})) { |
| |
$_ = $thesaurus_db{$keyword}; |
| |
(undef,@Words) = split/:/; # The first element is the number of times |
| |
# the word appears. We do not need it now. |
| |
for (my $i=0;$i<=$#Words;$i++) { |
| |
($Words[$i],undef)= split/\,/,$Words[$i]; |
| |
} |
| |
} |
| |
untie %thesaurus_db; |
| |
return @Words; |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=back |
| |
|
| |
=cut |
| |
|
| |
# -------------------------------------------------------------- Plaintext name |
| |
=pod |
| |
|
| |
=head1 User Name Functions |
| |
|
| |
=over 4 |
| |
|
| |
=item * plainname($uname,$udom) |
| |
|
| |
Takes a users logon name and returns it as a string in |
| |
"first middle last generation" form |
| |
|
| |
=cut |
| |
|
| |
############################################################### |
| |
sub plainname { |
| |
my ($uname,$udom)=@_; |
| |
my %names=&Apache::lonnet::get('environment', |
| |
['firstname','middlename','lastname','generation'], |
| |
$udom,$uname); |
| |
my $name=$names{'firstname'}.' '.$names{'middlename'}.' '. |
| |
$names{'lastname'}.' '.$names{'generation'}; |
| |
$name=~s/\s+$//; |
| |
$name=~s/\s+/ /g; |
| |
return $name; |
| |
} |
| |
|
| |
# -------------------------------------------------------------------- Nickname |
| |
=pod |
| |
|
| |
=item * nickname($uname,$udom) |
| |
|
| |
Gets a users name and returns it as a string as |
| |
|
| |
""nickname"" |
| |
|
| |
if the user has a nickname or |
| |
|
| |
"first middle last generation" |
| |
|
| |
if the user does not |
| |
|
| |
=cut |
| |
|
| |
sub nickname { |
| |
my ($uname,$udom)=@_; |
| |
my %names=&Apache::lonnet::get('environment', |
| |
['nickname','firstname','middlename','lastname','generation'],$udom,$uname); |
| |
my $name=$names{'nickname'}; |
| |
if ($name) { |
| |
$name='"'.$name.'"'; |
| |
} else { |
| |
$name=$names{'firstname'}.' '.$names{'middlename'}.' '. |
| |
$names{'lastname'}.' '.$names{'generation'}; |
| |
$name=~s/\s+$//; |
| |
$name=~s/\s+/ /g; |
| |
} |
| |
return $name; |
| |
} |
| |
|
| |
|
| |
# ------------------------------------------------------------------ Screenname |
| |
|
| |
=pod |
| |
|
| |
=item * screenname($uname,$udom) |
| |
|
| |
Gets a users screenname and returns it as a string |
| |
|
| |
=cut |
| |
|
| |
sub screenname { |
| |
my ($uname,$udom)=@_; |
| |
my %names= |
| |
&Apache::lonnet::get('environment',['screenname'],$udom,$uname); |
| |
return $names{'screenname'}; |
| |
} |
| |
|
| |
# ------------------------------------------------------------- Message Wrapper |
| |
|
| |
sub messagewrapper { |
| |
my ($link,$un,$do)=@_; |
| |
return |
| |
"<a href='/adm/email?compose=individual&recname=$un&recdom=$do'>$link</a>"; |
| |
} |
| |
# --------------------------------------------------------------- Notes Wrapper |
| |
|
| |
sub noteswrapper { |
| |
my ($link,$un,$do)=@_; |
| |
return |
| |
"<a href='/adm/email?recordftf=retrieve&recname=$un&recdom=$do'>$link</a>"; |
| |
} |
| |
# ------------------------------------------------------------- Aboutme Wrapper |
| |
|
| |
sub aboutmewrapper { |
| |
my ($link,$username,$domain)=@_; |
| |
return "<a href='/adm/$domain/$username/aboutme'>$link</a>"; |
| |
} |
| |
|
| |
# ------------------------------------------------------------ Syllabus Wrapper |
| |
|
| |
|
| |
sub syllabuswrapper { |
| |
my ($linktext,$coursedir,$domain,$fontcolor)=@_; |
| |
if ($fontcolor) { |
| |
$linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>'; |
| |
} |
| |
return "<a href='/public/$domain/$coursedir/syllabus'>$linktext</a>"; |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=back |
| |
|
| |
=head1 Access .tab File Data |
| |
|
| |
=over 4 |
| |
|
| |
=item * languageids() |
| |
|
| |
returns list of all language ids |
| |
|
| |
=cut |
| |
|
| |
sub languageids { |
| |
return sort(keys(%language)); |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=item * languagedescription() |
| |
|
| |
returns description of a specified language id |
| |
|
| |
=cut |
| |
|
| |
sub languagedescription { |
| |
my $code=shift; |
| |
return ($supported_language{$code}?'* ':''). |
| |
$language{$code}. |
| |
($supported_language{$code}?' ('.&mt('interface available').')':''); |
| |
} |
| |
|
| |
sub plainlanguagedescription { |
| |
my $code=shift; |
| |
return $language{$code}; |
| |
} |
| |
|
| |
sub supportedlanguagecode { |
| |
my $code=shift; |
| |
return $supported_language{$code}; |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=item * copyrightids() |
| |
|
| |
returns list of all copyrights |
| |
|
| |
=cut |
| |
|
| |
sub copyrightids { |
| |
return sort(keys(%cprtag)); |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=item * copyrightdescription() |
| |
|
| |
returns description of a specified copyright id |
| |
|
| |
=cut |
| |
|
| |
sub copyrightdescription { |
| |
return $cprtag{shift(@_)}; |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=item * filecategories() |
| |
|
| |
returns list of all file categories |
| |
|
| |
=cut |
| |
|
| |
sub filecategories { |
| |
return sort(keys(%category_extensions)); |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=item * filecategorytypes() |
| |
|
| |
returns list of file types belonging to a given file |
| |
category |
| |
|
| |
=cut |
| |
|
| |
sub filecategorytypes { |
| |
return @{$category_extensions{lc($_[0])}}; |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=item * fileembstyle() |
| |
|
| |
returns embedding style for a specified file type |
| |
|
| |
=cut |
| |
|
| |
sub fileembstyle { |
| |
return $fe{lc(shift(@_))}; |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=item * filedescription() |
| |
|
| |
returns description for a specified file type |
| |
|
| |
=cut |
| |
|
| |
sub filedescription { |
| |
return $fd{lc(shift(@_))}; |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=item * filedescriptionex() |
| |
|
| |
returns description for a specified file type with |
| |
extra formatting |
| |
|
| |
=cut |
| |
|
| |
sub filedescriptionex { |
| |
my $ex=shift; |
| |
return '.'.$ex.' '.$fd{lc($ex)}; |
| |
} |
| |
|
| |
# End of .tab access |
| |
=pod |
| |
|
| |
=back |
| |
|
| |
=cut |
| |
|
| |
# ------------------------------------------------------------------ File Types |
| |
sub fileextensions { |
| |
return sort(keys(%fe)); |
| |
} |
| |
|
| |
# ----------------------------------------------------------- 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)=@_; |
my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_; |
| my $prevattempts=''; |
my $prevattempts=''; |
| |
no strict 'refs'; |
| if ($symb) { |
if ($symb) { |
| my (%returnhash)= |
my (%returnhash)= |
| &Apache::lonnet::restore($symb,$course,$domain,$username); |
&Apache::lonnet::restore($symb,$course,$domain,$username); |
|
Line 92 sub get_previous_attempt {
|
Line 1715 sub get_previous_attempt {
|
| my %lasthash=(); |
my %lasthash=(); |
| my $version; |
my $version; |
| for ($version=1;$version<=$returnhash{'version'};$version++) { |
for ($version=1;$version<=$returnhash{'version'};$version++) { |
| map { |
foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) { |
| $lasthash{$_}=$returnhash{$version.':'.$_}; |
$lasthash{$_}=$returnhash{$version.':'.$_}; |
| } sort(split(/\:/,$returnhash{$version.':keys'})); |
} |
| } |
} |
| $prevattempts='<table border=2></tr><th>History</th>'; |
$prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">'; |
| map { |
$prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>'; |
| $prevattempts.='<th>'.$_.'</th>'; |
foreach (sort(keys %lasthash)) { |
| } sort(keys %lasthash); |
my ($ign,@parts) = split(/\./,$_); |
| for ($version=1;$version<=$returnhash{'version'};$version++) { |
if ($#parts > 0) { |
| $prevattempts.='</tr><tr><th>Attempt '.$version.'</th>'; |
my $data=$parts[-1]; |
| map { |
pop(@parts); |
| my $value; |
$prevattempts.='<td>Part '.join('.',@parts).'<br />'.$data.' </td>'; |
| if ($_ =~ /timestamp/) { |
} else { |
| $value=scalar(localtime($returnhash{$version.':'.$_})); |
if ($#parts == 0) { |
| |
$prevattempts.='<th>'.$parts[0].'</th>'; |
| } else { |
} else { |
| $value=$returnhash{$version.':'.$_}; |
$prevattempts.='<th>'.$ign.'</th>'; |
| } |
} |
| $prevattempts.='<td>'.$value.'</td>'; |
} |
| } sort(keys %lasthash); |
} |
| |
if ($getattempt eq '') { |
| |
for ($version=1;$version<=$returnhash{'version'};$version++) { |
| |
$prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Transaction '.$version.'</td>'; |
| |
foreach (sort(keys %lasthash)) { |
| |
my $value; |
| |
if ($_ =~ /timestamp/) { |
| |
$value=scalar(localtime($returnhash{$version.':'.$_})); |
| |
} else { |
| |
$value=$returnhash{$version.':'.$_}; |
| |
} |
| |
$prevattempts.='<td>'.&Apache::lonnet::unescape($value).' </td>'; |
| |
} |
| |
} |
| } |
} |
| $prevattempts.='</tr><tr><th>Current</th>'; |
$prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Current</td>'; |
| map { |
foreach (sort(keys %lasthash)) { |
| my $value; |
my $value; |
| if ($_ =~ /timestamp/) { |
if ($_ =~ /timestamp/) { |
| $value=scalar(localtime($lasthash{$_})); |
$value=scalar(localtime($lasthash{$_})); |
| } else { |
} else { |
| $value=$lasthash{$_}; |
$value=$lasthash{$_}; |
| } |
} |
| $prevattempts.='<td>'.$value.'</td>'; |
$value=&Apache::lonnet::unescape($value); |
| } sort(keys %lasthash); |
if ($_ =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)} |
| $prevattempts.='</tr></table>'; |
$prevattempts.='<td>'.$value.' </td>'; |
| |
} |
| |
$prevattempts.='</tr></table></td></tr></table>'; |
| } else { |
} else { |
| $prevattempts='Nothing submitted - no attempts.'; |
$prevattempts='Nothing submitted - no attempts.'; |
| } |
} |
|
Line 131 sub get_previous_attempt {
|
Line 1770 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) = @_; |
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) { |
| $old{$element}=$ENV{'form.grade_'.$element}; |
$old{$element}=$ENV{'form.grade_'.$element}; |
| $moreenv{'form.grade_'.$element}=eval '$'.$element #' |
$moreenv{'form.grade_'.$element}=eval '$'.$element #' |
| } |
} |
| |
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 153 sub get_student_view {
|
Line 1837 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 167 sub get_student_answers {
|
Line 1860 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}; |
| } |
} |
| $userview=~s/\<body[^\>]*\>//gi; |
|
| $userview=~s/\<\/body\>//gi; |
|
| $userview=~s/\<html\>//gi; |
|
| $userview=~s/\<\/html\>//gi; |
|
| $userview=~s/\<head\>//gi; |
|
| $userview=~s/\<\/head\>//gi; |
|
| $userview=~s/action\s*\=/would_be_action\=/gi; |
|
| 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 |
| |
|
| |
############################################### |
| |
|
| |
|
| |
sub timehash { |
| |
my @ltime=localtime(shift); |
| |
return ( 'seconds' => $ltime[0], |
| |
'minutes' => $ltime[1], |
| |
'hours' => $ltime[2], |
| |
'day' => $ltime[3], |
| |
'month' => $ltime[4]+1, |
| |
'year' => $ltime[5]+1900, |
| |
'weekday' => $ltime[6], |
| |
'dayyear' => $ltime[7]+1, |
| |
'dlsav' => $ltime[8] ); |
| |
} |
| |
|
| |
sub maketime { |
| |
my %th=@_; |
| |
return POSIX::mktime( |
| |
($th{'seconds'},$th{'minutes'},$th{'hours'}, |
| |
$th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,$th{'dlsav'})); |
| |
} |
| |
|
| |
|
| |
######################################### |
| |
# |
| |
# Retro-fixing of un-backward-compatible time format |
| |
|
| |
sub unsqltime { |
| |
my $timestamp=shift; |
| |
if ($timestamp=~/^(\d+)\-(\d+)\-(\d+)\s+(\d+)\:(\d+)\:(\d+)$/) { |
| |
$timestamp=&maketime( |
| |
'year'=>$1,'month'=>$2,'day'=>$3, |
| |
'hours'=>$4,'minutes'=>$5,'seconds'=>$6); |
| |
} |
| |
return $timestamp; |
| |
} |
| |
|
| |
######################################### |
| |
|
| |
sub findallcourses { |
| |
my %courses=(); |
| |
my $now=time; |
| |
foreach (keys %ENV) { |
| |
if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) { |
| |
my ($starttime,$endtime)=$ENV{$_}; |
| |
my $active=1; |
| |
if ($starttime) { |
| |
if ($now<$starttime) { $active=0; } |
| |
} |
| |
if ($endtime) { |
| |
if ($now>$endtime) { $active=0; } |
| |
} |
| |
if ($active) { $courses{$1.'_'.$2}=1; } |
| |
} |
| |
} |
| |
return keys %courses; |
| |
} |
| |
|
| |
############################################### |
| |
############################################### |
| |
|
| |
=pod |
| |
|
| |
=head1 Domain Template Functions |
| |
|
| |
=over 4 |
| |
|
| |
=item * &determinedomain() |
| |
|
| |
Inputs: $domain (usually will be undef) |
| |
|
| |
Returns: Determines which domain should be used for designs |
| |
|
| |
=cut |
| |
|
| |
############################################### |
| |
sub determinedomain { |
| |
my $domain=shift; |
| |
if (! $domain) { |
| |
# Determine domain if we have not been given one |
| |
$domain = $Apache::lonnet::perlvar{'lonDefDomain'}; |
| |
if ($ENV{'user.domain'}) { $domain=$ENV{'user.domain'}; } |
| |
if ($ENV{'request.role.domain'}) { |
| |
$domain=$ENV{'request.role.domain'}; |
| |
} |
| |
} |
| |
return $domain; |
| |
} |
| |
############################################### |
| |
=pod |
| |
|
| |
=item * &domainlogo() |
| |
|
| |
Inputs: $domain (usually will be undef) |
| |
|
| |
Returns: A link to a domain logo, if the domain logo exists. |
| |
If the domain logo does not exist, a description of the domain. |
| |
|
| |
=cut |
| |
|
| |
############################################### |
| |
sub domainlogo { |
| |
my $domain = &determinedomain(shift); |
| |
# See if there is a logo |
| |
if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') { |
| |
my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'}; |
| |
if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; } |
| |
return '<img src="http://'.$ENV{'HTTP_HOST'}.':'.$lonhttpdPort. |
| |
'/adm/lonDomLogos/'.$domain.'.gif" alt="'.$domain.'" />'; |
| |
} elsif(exists($Apache::lonnet::domaindescription{$domain})) { |
| |
return $Apache::lonnet::domaindescription{$domain}; |
| |
} else { |
| |
return ''; |
| |
} |
| |
} |
| |
############################################## |
| |
|
| |
=pod |
| |
|
| |
=item * &designparm() |
| |
|
| |
Inputs: $which parameter; $domain (usually will be undef) |
| |
|
| |
Returns: value of designparamter $which |
| |
|
| |
=cut |
| |
|
| |
############################################## |
| |
sub designparm { |
| |
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}) { |
| |
return $ENV{'environment.color.'.$which}; |
| |
} |
| |
$domain=&determinedomain($domain); |
| |
if ($designhash{$domain.'.'.$which}) { |
| |
return $designhash{$domain.'.'.$which}; |
| |
} else { |
| |
return $designhash{'default.'.$which}; |
| |
} |
| |
} |
| |
|
| |
############################################### |
| |
############################################### |
| |
|
| |
=pod |
| |
|
| |
=back |
| |
|
| |
=head1 HTTP Helpers |
| |
|
| |
=over 4 |
| |
|
| |
=item * &bodytag() |
| |
|
| |
Returns a uniform header for LON-CAPA web pages. |
| |
|
| |
Inputs: |
| |
|
| |
=over 4 |
| |
|
| |
=item * $title, A title to be displayed on the page. |
| |
|
| |
=item * $function, the current role (can be undef). |
| |
|
| |
=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) |
| |
|
| |
=back |
| |
|
| |
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 undef or zero, an html string containing a <body> tag and |
| |
other decorations will be returned. |
| |
|
| |
=cut |
| |
|
| |
sub bodytag { |
| |
my ($title,$function,$addentries,$bodyonly,$domain,$forcereg)=@_; |
| |
$title=&mt($title); |
| |
unless ($function) { |
| |
$function='student'; |
| |
if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) { |
| |
$function='coordinator'; |
| |
} |
| |
if ($ENV{'request.role'}=~/^(su|dc|ad|li)/) { |
| |
$function='admin'; |
| |
} |
| |
if (($ENV{'request.role'}=~/^(au|ca)/) || |
| |
($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) { |
| |
$function='author'; |
| |
} |
| |
} |
| |
my $img=&designparm($function.'.img',$domain); |
| |
my $pgbg=&designparm($function.'.pgbg',$domain); |
| |
my $tabbg=&designparm($function.'.tabbg',$domain); |
| |
my $font=&designparm($function.'.font',$domain); |
| |
my $link=&designparm($function.'.link',$domain); |
| |
my $alink=&designparm($function.'.alink',$domain); |
| |
my $vlink=&designparm($function.'.vlink',$domain); |
| |
my $sidebg=&designparm($function.'.sidebg',$domain); |
| |
# Accessibility font enhance |
| |
unless ($addentries) { $addentries=''; } |
| |
my $addstyle=''; |
| |
if ($ENV{'browser.fontenhance'} eq 'on') { |
| |
$addstyle=' font-size: x-large;'; |
| |
} |
| |
# role and realm |
| |
my ($role,$realm) |
| |
=&Apache::lonnet::plaintext((split(/\./,$ENV{'request.role'}))[0]); |
| |
# realm |
| |
if ($ENV{'request.course.id'}) { |
| |
$realm= |
| |
$ENV{'course.'.$ENV{'request.course.id'}.'.description'}; |
| |
} |
| |
unless ($realm) { $realm=' '; } |
| |
# Set messages |
| |
my $messages=&domainlogo($domain); |
| |
# Port for miniserver |
| |
my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'}; |
| |
if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; } |
| |
# construct main body tag |
| |
my $bodytag = <<END; |
| |
<style> |
| |
h1, h2, h3, th { font-family: Arial, Helvetica, sans-serif } |
| |
a:hover { color: black; background: yellow } |
| |
a:focus { color: red; background: yellow } |
| |
</style> |
| |
<body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link" |
| |
style="margin-top: 0px;$addstyle" $addentries> |
| |
END |
| |
my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'. |
| |
$lonhttpdPort.$img.'" alt="'.$function.'" />'; |
| |
if ($bodyonly) { |
| |
return $bodytag; |
| |
} elsif ($ENV{'browser.interface'} eq 'textual') { |
| |
# Accessibility |
| |
return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web', |
| |
$forcereg). |
| |
'<h1>LON-CAPA: '.$title.'</h1>'; |
| |
} elsif ($ENV{'environment.remote'} eq 'off') { |
| |
# No Remote |
| |
return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web', |
| |
$forcereg). |
| |
'<table bgcolor="'.$pgbg.'" width="100%" border="0" cellspacing="3" cellpadding="3"><tr><td bgcolor="'.$tabbg.'"><font face="Arial, Helvetica, sans-serif" size="+3" color="'.$font.'"><b>'.$title. |
| |
'</b></font></td></tr></table>'; |
| |
} |
| |
|
| |
# |
| |
# Top frame rendering, Remote is up |
| |
# |
| |
return(<<ENDBODY); |
| |
$bodytag |
| |
<table width="100%" cellspacing="0" border="0" cellpadding="0"> |
| |
<tr><td bgcolor="$sidebg"> |
| |
$upperleft</td> |
| |
<td bgcolor="$sidebg" align="right">$messages </td> |
| |
</tr> |
| |
<tr> |
| |
<td rowspan="3" bgcolor="$tabbg"> |
| |
<font size="5" face="Arial, Helvetica, sans-serif"><b>$title</b></font> |
| |
<td bgcolor="$tabbg" align="right"> |
| |
<font size="2" face="Arial, Helvetica, sans-serif"> |
| |
$ENV{'environment.firstname'} |
| |
$ENV{'environment.middlename'} |
| |
$ENV{'environment.lastname'} |
| |
$ENV{'environment.generation'} |
| |
</font> |
| |
</td> |
| |
</tr> |
| |
<tr><td bgcolor="$tabbg" align="right"> |
| |
<font size="2" face="Arial, Helvetica, sans-serif">$role</font> |
| |
</td></tr> |
| |
<tr> |
| |
<td bgcolor="$tabbg" align="right"><font size="2" face="Arial, Helvetica, sans-serif">$realm</font> </td></tr> |
| |
</table><br> |
| |
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\:\s*form\-data\;\s*name\=\"([^\"]+)\"/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)= @_; |
my ($query,$possible_names)= @_; |
| map { |
# $Apache::lonxml::debug=1; |
| |
foreach (split(/&/,$query)) { |
| my ($name, $value) = split(/=/,$_); |
my ($name, $value) = split(/=/,$_); |
| $value =~ tr/+/ /; |
$name = &Apache::lonnet::unescape($name); |
| $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; |
if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) { |
| if (!defined($ENV{'form.'.$name})) { $ENV{'form.'.$name}=$value; } |
$value =~ tr/+/ /; |
| } (split(/&/,$query)); |
$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) }; |
| |
} |
| |
} |
| } |
} |
| |
|
| |
=pod |
| |
|
| |
=item * cacheheader() |
| |
|
| |
returns cache-controlling header code |
| |
|
| |
=cut |
| |
|
| sub cacheheader { |
sub cacheheader { |
| |
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 200 sub cacheheader {
|
Line 2312 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) = @_; |
| my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); |
unless ($ENV{'request.method'} eq 'GET') { return ''; } |
| |
#my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); |
| $r->no_cache(1); |
$r->no_cache(1); |
| $r->header_out("Pragma" => "no-cache"); |
$r->header_out("Pragma" => "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 { |
| |
my ($name,$value)=@_; |
| |
if (defined($ENV{$name})) { |
| |
if (ref($ENV{$name})) { |
| |
#already have multiple values |
| |
push(@{ $ENV{$name} },$value); |
| |
} else { |
| |
#first time seeing multiple values, convert hash entry to an arrayref |
| |
my $first=$ENV{$name}; |
| |
undef($ENV{$name}); |
| |
push(@{ $ENV{$name} },$first,$value); |
| |
} |
| |
} else { |
| |
$ENV{$name}=$value; |
| |
} |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=item * get_env_multiple($name) |
| |
|
| |
gets $name from the %ENV hash, it seemlessly handles the cases where multiple |
| |
values may be defined and end up as an array ref. |
| |
|
| |
returns an array of values |
| |
|
| |
=cut |
| |
|
| |
sub get_env_multiple { |
| |
my ($name) = @_; |
| |
my @values; |
| |
if (defined($ENV{$name})) { |
| |
# exists is it an array |
| |
if (ref($ENV{$name})) { |
| |
@values=@{ $ENV{$name} }; |
| |
} else { |
| |
$values[0]=$ENV{$name}; |
| |
} |
| |
} |
| |
return(@values); |
| |
} |
| |
|
| |
|
| |
=pod |
| |
|
| |
=back |
| |
|
| |
=head1 CSV Upload/Handling functions |
| |
|
| |
=over 4 |
| |
|
| |
=item * upfile_store($r) |
| |
|
| |
Store uploaded file, $r should be the HTTP Request object, |
| |
needs $ENV{'form.upfile'} |
| |
returns $datatoken to be put into hidden field |
| |
|
| |
=cut |
| |
|
| |
sub upfile_store { |
| |
my $r=shift; |
| |
$ENV{'form.upfile'}=~s/\r/\n/gs; |
| |
$ENV{'form.upfile'}=~s/\f/\n/gs; |
| |
$ENV{'form.upfile'}=~s/\n+/\n/gs; |
| |
$ENV{'form.upfile'}=~s/\n+$//gs; |
| |
|
| |
my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}. |
| |
'_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$; |
| |
{ |
| |
my $fh=Apache::File->new('>'.$r->dir_config('lonDaemons'). |
| |
'/tmp/'.$datatoken.'.tmp'); |
| |
print $fh $ENV{'form.upfile'}; |
| |
} |
| |
return $datatoken; |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=item * load_tmp_file($r) |
| |
|
| |
Load uploaded file from tmp, $r should be the HTTP Request object, |
| |
needs $ENV{'form.datatoken'}, |
| |
sets $ENV{'form.upfile'} to the contents of the file |
| |
|
| |
=cut |
| |
|
| |
sub load_tmp_file { |
| |
my $r=shift; |
| |
my @studentdata=(); |
| |
{ |
| |
my $fh; |
| |
if ($fh=Apache::File->new($r->dir_config('lonDaemons'). |
| |
'/tmp/'.$ENV{'form.datatoken'}.'.tmp')) { |
| |
@studentdata=<$fh>; |
| |
} |
| |
} |
| |
$ENV{'form.upfile'}=join('',@studentdata); |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=item * upfile_record_sep() |
| |
|
| |
Separate uploaded file into records |
| |
returns array of records, |
| |
needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'} |
| |
|
| |
=cut |
| |
|
| |
sub upfile_record_sep { |
| |
if ($ENV{'form.upfiletype'} eq 'xml') { |
| |
} else { |
| |
return split(/\n/,$ENV{'form.upfile'}); |
| |
} |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=item * record_sep($record) |
| |
|
| |
Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'} |
| |
|
| |
=cut |
| |
|
| |
sub record_sep { |
| |
my $record=shift; |
| |
my %components=(); |
| |
if ($ENV{'form.upfiletype'} eq 'xml') { |
| |
} elsif ($ENV{'form.upfiletype'} eq 'space') { |
| |
my $i=0; |
| |
foreach (split(/\s+/,$record)) { |
| |
my $field=$_; |
| |
$field=~s/^(\"|\')//; |
| |
$field=~s/(\"|\')$//; |
| |
$components{$i}=$field; |
| |
$i++; |
| |
} |
| |
} elsif ($ENV{'form.upfiletype'} eq 'tab') { |
| |
my $i=0; |
| |
foreach (split(/\t+/,$record)) { |
| |
my $field=$_; |
| |
$field=~s/^(\"|\')//; |
| |
$field=~s/(\"|\')$//; |
| |
$components{$i}=$field; |
| |
$i++; |
| |
} |
| |
} else { |
| |
my @allfields=split(/\,/,$record); |
| |
my $i=0; |
| |
my $j; |
| |
for ($j=0;$j<=$#allfields;$j++) { |
| |
my $field=$allfields[$j]; |
| |
if ($field=~/^\s*(\"|\')/) { |
| |
my $delimiter=$1; |
| |
while (($field!~/$delimiter$/) && ($j<$#allfields)) { |
| |
$j++; |
| |
$field.=','.$allfields[$j]; |
| |
} |
| |
$field=~s/^\s*$delimiter//; |
| |
$field=~s/$delimiter\s*$//; |
| |
} |
| |
$components{$i}=$field; |
| |
$i++; |
| |
} |
| |
} |
| |
return %components; |
| |
} |
| |
|
| |
###################################################### |
| |
###################################################### |
| |
|
| |
=pod |
| |
|
| |
=item * upfile_select_html() |
| |
|
| |
Return HTML code to select a file from the users machine and specify |
| |
the file type. |
| |
|
| |
=cut |
| |
|
| |
###################################################### |
| |
###################################################### |
| |
sub upfile_select_html { |
| |
my %Types = ( |
| |
csv => &mt('CSV (comma separated values, spreadsheet)'), |
| |
space => &mt('Space separated'), |
| |
tab => &mt('Tabulator separated'), |
| |
# xml => &mt('HTML/XML'), |
| |
); |
| |
my $Str = '<input type="file" name="upfile" size="50" />'. |
| |
'<br />Type: <select name="upfiletype">'; |
| |
foreach my $type (sort(keys(%Types))) { |
| |
$Str .= '<option value="'.$type.'" >'.$Types{$type}."</option>\n"; |
| |
} |
| |
$Str .= "</select>\n"; |
| |
return $Str; |
| |
} |
| |
|
| |
###################################################### |
| |
###################################################### |
| |
|
| |
=pod |
| |
|
| |
=item * csv_print_samples($r,$records) |
| |
|
| |
Prints a table of sample values from each column uploaded $r is an |
| |
Apache Request ref, $records is an arrayref from |
| |
&Apache::loncommon::upfile_record_sep |
| |
|
| |
=cut |
| |
|
| |
###################################################### |
| |
###################################################### |
| |
sub csv_print_samples { |
| |
my ($r,$records) = @_; |
| |
my (%sone,%stwo,%sthree); |
| |
%sone=&record_sep($$records[0]); |
| |
if (defined($$records[1])) {%stwo=&record_sep($$records[1]);} |
| |
if (defined($$records[2])) {%sthree=&record_sep($$records[2]);} |
| |
# |
| |
$r->print(&mt('Samples').'<br /><table border="2"><tr>'); |
| |
foreach (sort({$a <=> $b} keys(%sone))) { |
| |
$r->print('<th>'.&mt('Column [_1]',($_+1)).'</th>'); } |
| |
$r->print('</tr>'); |
| |
foreach my $hash (\%sone,\%stwo,\%sthree) { |
| |
$r->print('<tr>'); |
| |
foreach (sort({$a <=> $b} keys(%sone))) { |
| |
$r->print('<td>'); |
| |
if (defined($$hash{$_})) { $r->print($$hash{$_}); } |
| |
$r->print('</td>'); |
| |
} |
| |
$r->print('</tr>'); |
| |
} |
| |
$r->print('</tr></table><br />'."\n"); |
| |
} |
| |
|
| |
###################################################### |
| |
###################################################### |
| |
|
| |
=pod |
| |
|
| |
=item * csv_print_select_table($r,$records,$d) |
| |
|
| |
Prints a table to create associations between values and table columns. |
| |
|
| |
$r is an Apache Request ref, |
| |
$records is an arrayref from &Apache::loncommon::upfile_record_sep, |
| |
$d is an array of 2 element arrays (internal name, displayed name) |
| |
|
| |
=cut |
| |
|
| |
###################################################### |
| |
###################################################### |
| |
sub csv_print_select_table { |
| |
my ($r,$records,$d) = @_; |
| |
my $i=0;my %sone; |
| |
%sone=&record_sep($$records[0]); |
| |
$r->print(&mt('Associate columns with student attributes.')."\n". |
| |
'<table border="2"><tr>'. |
| |
'<th>'.&mt('Attribute').'</th>'. |
| |
'<th>'.&mt('Column').'</th></tr>'."\n"); |
| |
foreach (@$d) { |
| |
my ($value,$display)=@{ $_ }; |
| |
$r->print('<tr><td>'.$display.'</td>'); |
| |
|
| |
$r->print('<td><select name=f'.$i. |
| |
' onchange="javascript:flip(this.form,'.$i.');">'); |
| |
$r->print('<option value="none"></option>'); |
| |
foreach (sort({$a <=> $b} keys(%sone))) { |
| |
$r->print('<option value="'.$_.'">Column '.($_+1).'</option>'); |
| |
} |
| |
$r->print('</select></td></tr>'."\n"); |
| |
$i++; |
| |
} |
| |
$i--; |
| |
return $i; |
| |
} |
| |
|
| |
###################################################### |
| |
###################################################### |
| |
|
| |
=pod |
| |
|
| |
=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. |
| |
|
| |
$r is an Apache Request ref, |
| |
$records is an arrayref from &Apache::loncommon::upfile_record_sep, |
| |
$d is an array of 2 element arrays (internal name, displayed name) |
| |
|
| |
=cut |
| |
|
| |
###################################################### |
| |
###################################################### |
| |
sub csv_samples_select_table { |
| |
my ($r,$records,$d) = @_; |
| |
my %sone; my %stwo; my %sthree; |
| |
my $i=0; |
| |
# |
| |
$r->print('<table border=2><tr><th>'. |
| |
&mt('Field').'</th><th>'.&mt('Samples').'</th></tr>'); |
| |
%sone=&record_sep($$records[0]); |
| |
if (defined($$records[1])) {%stwo=&record_sep($$records[1]);} |
| |
if (defined($$records[2])) {%sthree=&record_sep($$records[2]);} |
| |
# |
| |
foreach (sort keys %sone) { |
| |
$r->print('<tr><td><select name="f'.$i.'"'. |
| |
' onchange="javascript:flip(this.form,'.$i.');">'); |
| |
foreach (@$d) { |
| |
my ($value,$display)=@{ $_ }; |
| |
$r->print('<option value="'.$value.'">'.$display.'</option>'); |
| |
} |
| |
$r->print('</select></td><td>'); |
| |
if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); } |
| |
if (defined($stwo{$_})) { $r->print($stwo{$_}."</br>\n"); } |
| |
if (defined($sthree{$_})) { $r->print($sthree{$_}."</br>\n"); } |
| |
$r->print('</td></tr>'); |
| |
$i++; |
| |
} |
| |
$i--; |
| |
return($i); |
| |
} |
| |
|
| |
###################################################### |
| |
###################################################### |
| |
|
| |
=pod |
| |
|
| |
=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 |
| |
|
| |
1 if the part is to be hidden, undef if it is to be shown |
| |
|
| |
Arguments are: |
| |
|
| |
$id the id of the part to be checked |
| |
$symb, optional the symb of the resource to check |
| |
$udom, optional the domain of the user to check for |
| |
$uname, optional the username of the user to check for |
| |
|
| |
=cut |
| |
|
| |
sub check_if_partid_hidden { |
| |
my ($id,$symb,$udom,$uname) = @_; |
| |
my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts', |
| |
$symb,$udom,$uname); |
| |
my $truth=1; |
| |
#if the string starts with !, then the list is the list to show not hide |
| |
if ($hiddenparts=~s/^\s*!//) { $truth=undef; } |
| |
my @hiddenlist=split(/,/,$hiddenparts); |
| |
foreach my $checkid (@hiddenlist) { |
| |
if ($checkid =~ /^\s*\Q$id\E\s*$/) { return $truth; } |
| |
} |
| |
return !$truth; |
| } |
} |
| |
|
| |
|
| |
############################################################ |
| |
############################################################ |
| |
|
| |
=pod |
| |
|
| |
=head1 cgi-bin script and graphing routines |
| |
|
| |
=item get_cgi_id |
| |
|
| |
Inputs: none |
| |
|
| |
Returns an id which can be used to pass environment variables |
| |
to various cgi-bin scripts. These environment variables will |
| |
be removed from the users environment after a given time by |
| |
the routine &Apache::lonnet::transfer_profile_to_env. |
| |
|
| |
=cut |
| |
|
| |
############################################################ |
| |
############################################################ |
| |
my $uniq=0; |
| |
sub get_cgi_id { |
| |
$uniq=($uniq++)%100000; |
| |
return (time.'_'.$uniq); |
| |
} |
| |
|
| |
############################################################ |
| |
############################################################ |
| |
|
| |
=pod |
| |
|
| |
=item DrawBarGraph |
| |
|
| |
Facilitates the plotting of data in a (stacked) bar graph. |
| |
Puts plot definition data into the users environment in order for |
| |
graph.png to plot it. Returns an <img> tag for the plot. |
| |
The bars on the plot are labeled '1','2',...,'n'. |
| |
|
| |
Inputs: |
| |
|
| |
=over 4 |
| |
|
| |
=item $Title: string, the title of the plot |
| |
|
| |
=item $xlabel: string, text describing the X-axis of the plot |
| |
|
| |
=item $ylabel: string, text describing the Y-axis of the plot |
| |
|
| |
=item $Max: scalar, the maximum Y value to use in the plot |
| |
If $Max is < any data point, the graph will not be rendered. |
| |
|
| |
=item $colors: array ref holding the colors to be used for the data sets when |
| |
they are plotted. If undefined, default values will be used. |
| |
|
| |
=item @Values: An array of array references. Each array reference holds data |
| |
to be plotted in a stacked bar chart. |
| |
|
| |
=back |
| |
|
| |
Returns: |
| |
|
| |
An <img> tag which references graph.png and the appropriate identifying |
| |
information for the plot. |
| |
|
| |
=cut |
| |
|
| |
############################################################ |
| |
############################################################ |
| |
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 = &get_cgi_id(); |
| |
my $id = 'cgi.'.$identifier; |
| |
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{$id.'.data.'.$NumSets++} = |
| |
join(',',@$array); |
| |
} |
| |
# |
| |
my ($height,$width,$xskip,$bar_width) = (200,120,1,15); |
| |
if ($NumBars < 10) { |
| |
$width = 120+$NumBars*15; |
| |
$xskip = 1; |
| |
$bar_width = 15; |
| |
} elsif ($NumBars <= 25) { |
| |
$width = 120+$NumBars*11; |
| |
$xskip = 5; |
| |
$bar_width = 8; |
| |
} elsif ($NumBars <= 50) { |
| |
$width = 120+$NumBars*8; |
| |
$xskip = 5; |
| |
$bar_width = 4; |
| |
} else { |
| |
$width = 120+$NumBars*8; |
| |
$xskip = 5; |
| |
$bar_width = 4; |
| |
} |
| |
# |
| |
my @Labels; |
| |
for (my $i=0;$i<@{$Values[0]};$i++) { |
| |
push (@Labels,$i+1); |
| |
} |
| |
# |
| |
$Max = 1 if ($Max < 1); |
| |
if ( int($Max) < $Max ) { |
| |
$Max++; |
| |
$Max = int($Max); |
| |
} |
| |
$Title = '' if (! defined($Title)); |
| |
$xlabel = '' if (! defined($xlabel)); |
| |
$ylabel = '' if (! defined($ylabel)); |
| |
$ValuesHash{$id.'.title'} = &Apache::lonnet::escape($Title); |
| |
$ValuesHash{$id.'.xlabel'} = &Apache::lonnet::escape($xlabel); |
| |
$ValuesHash{$id.'.ylabel'} = &Apache::lonnet::escape($ylabel); |
| |
$ValuesHash{$id.'.y_max_value'} = $Max; |
| |
$ValuesHash{$id.'.NumBars'} = $NumBars; |
| |
$ValuesHash{$id.'.NumSets'} = $NumSets; |
| |
$ValuesHash{$id.'.PlotType'} = 'bar'; |
| |
$ValuesHash{$id.'.Colors'} = join(',',@{$colors}); |
| |
$ValuesHash{$id.'.height'} = $height; |
| |
$ValuesHash{$id.'.width'} = $width; |
| |
$ValuesHash{$id.'.xskip'} = $xskip; |
| |
$ValuesHash{$id.'.bar_width'} = $bar_width; |
| |
$ValuesHash{$id.'.labels'} = join(',',@Labels); |
| |
# |
| |
&Apache::lonnet::appenv(%ValuesHash); |
| |
return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />'; |
| |
} |
| |
|
| |
############################################################ |
| |
############################################################ |
| |
|
| |
=pod |
| |
|
| |
=item DrawXYGraph |
| |
|
| |
Facilitates the plotting of data in an XY graph. |
| |
Puts plot definition data into the users environment in order for |
| |
graph.png to plot it. Returns an <img> tag for the plot. |
| |
|
| |
Inputs: |
| |
|
| |
=over 4 |
| |
|
| |
=item $Title: string, the title of the plot |
| |
|
| |
=item $xlabel: string, text describing the X-axis of the plot |
| |
|
| |
=item $ylabel: string, text describing the Y-axis of the plot |
| |
|
| |
=item $Max: scalar, the maximum Y value to use in the plot |
| |
If $Max is < any data point, the graph will not be rendered. |
| |
|
| |
=item $colors: Array ref containing the hex color codes for the data to be |
| |
plotted in. If undefined, default values will be used. |
| |
|
| |
=item $Xlabels: Array ref containing the labels to be used for the X-axis. |
| |
|
| |
=item $Ydata: Array ref containing Array refs. |
| |
Each of the contained arrays will be plotted as a seperate curve. |
| |
|
| |
=item %Values: hash indicating or overriding any default values which are |
| |
passed to graph.png. |
| |
Possible values are: width, xskip, x_ticks, x_tick_offset, among others. |
| |
|
| |
=back |
| |
|
| |
Returns: |
| |
|
| |
An <img> tag which references graph.png and the appropriate identifying |
| |
information for the plot. |
| |
|
| |
=cut |
| |
|
| |
############################################################ |
| |
############################################################ |
| |
sub DrawXYGraph { |
| |
my ($Title,$xlabel,$ylabel,$Max,$colors,$Xlabels,$Ydata,%Values)=@_; |
| |
# |
| |
# Create the identifier for the graph |
| |
my $identifier = &get_cgi_id(); |
| |
my $id = 'cgi.'.$identifier; |
| |
# |
| |
$Title = '' if (! defined($Title)); |
| |
$xlabel = '' if (! defined($xlabel)); |
| |
$ylabel = '' if (! defined($ylabel)); |
| |
my %ValuesHash = |
| |
( |
| |
$id.'.title' => &Apache::lonnet::escape($Title), |
| |
$id.'.xlabel' => &Apache::lonnet::escape($xlabel), |
| |
$id.'.ylabel' => &Apache::lonnet::escape($ylabel), |
| |
$id.'.y_max_value'=> $Max, |
| |
$id.'.labels' => join(',',@$Xlabels), |
| |
$id.'.PlotType' => 'XY', |
| |
); |
| |
# |
| |
if (defined($colors) && ref($colors) eq 'ARRAY') { |
| |
$ValuesHash{$id.'.Colors'} = join(',',@{$colors}); |
| |
} |
| |
# |
| |
if (! ref($Ydata) || ref($Ydata) ne 'ARRAY') { |
| |
return ''; |
| |
} |
| |
my $NumSets=1; |
| |
foreach my $array (@{$Ydata}){ |
| |
next if (! ref($array)); |
| |
$ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array); |
| |
} |
| |
$ValuesHash{$id.'.NumSets'} = $NumSets-1; |
| |
# |
| |
# Deal with other parameters |
| |
while (my ($key,$value) = each(%Values)) { |
| |
$ValuesHash{$id.'.'.$key} = $value; |
| |
} |
| |
# |
| |
&Apache::lonnet::appenv(%ValuesHash); |
| |
return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />'; |
| |
} |
| |
|
| |
############################################################ |
| |
############################################################ |
| |
|
| |
=pod |
| |
|
| |
=item DrawXYYGraph |
| |
|
| |
Facilitates the plotting of data in an XY graph with two Y axes. |
| |
Puts plot definition data into the users environment in order for |
| |
graph.png to plot it. Returns an <img> tag for the plot. |
| |
|
| |
Inputs: |
| |
|
| |
=over 4 |
| |
|
| |
=item $Title: string, the title of the plot |
| |
|
| |
=item $xlabel: string, text describing the X-axis of the plot |
| |
|
| |
=item $ylabel: string, text describing the Y-axis of the plot |
| |
|
| |
=item $colors: Array ref containing the hex color codes for the data to be |
| |
plotted in. If undefined, default values will be used. |
| |
|
| |
=item $Xlabels: Array ref containing the labels to be used for the X-axis. |
| |
|
| |
=item $Ydata1: The first data set |
| |
|
| |
=item $Min1: The minimum value of the left Y-axis |
| |
|
| |
=item $Max1: The maximum value of the left Y-axis |
| |
|
| |
=item $Ydata2: The second data set |
| |
|
| |
=item $Min2: The minimum value of the right Y-axis |
| |
|
| |
=item $Max2: The maximum value of the left Y-axis |
| |
|
| |
=item %Values: hash indicating or overriding any default values which are |
| |
passed to graph.png. |
| |
Possible values are: width, xskip, x_ticks, x_tick_offset, among others. |
| |
|
| |
=back |
| |
|
| |
Returns: |
| |
|
| |
An <img> tag which references graph.png and the appropriate identifying |
| |
information for the plot. |
| |
|
| |
=cut |
| |
|
| |
############################################################ |
| |
############################################################ |
| |
sub DrawXYYGraph { |
| |
my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1, |
| |
$Ydata2,$Min2,$Max2,%Values)=@_; |
| |
# |
| |
# Create the identifier for the graph |
| |
my $identifier = &get_cgi_id(); |
| |
my $id = 'cgi.'.$identifier; |
| |
# |
| |
$Title = '' if (! defined($Title)); |
| |
$xlabel = '' if (! defined($xlabel)); |
| |
$ylabel = '' if (! defined($ylabel)); |
| |
my %ValuesHash = |
| |
( |
| |
$id.'.title' => &Apache::lonnet::escape($Title), |
| |
$id.'.xlabel' => &Apache::lonnet::escape($xlabel), |
| |
$id.'.ylabel' => &Apache::lonnet::escape($ylabel), |
| |
$id.'.labels' => join(',',@$Xlabels), |
| |
$id.'.PlotType' => 'XY', |
| |
$id.'.NumSets' => 2, |
| |
$id.'.two_axes' => 1, |
| |
$id.'.y1_max_value' => $Max1, |
| |
$id.'.y1_min_value' => $Min1, |
| |
$id.'.y2_max_value' => $Max2, |
| |
$id.'.y2_min_value' => $Min2, |
| |
); |
| |
# |
| |
if (defined($colors) && ref($colors) eq 'ARRAY') { |
| |
$ValuesHash{$id.'.Colors'} = join(',',@{$colors}); |
| |
} |
| |
# |
| |
if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' || |
| |
! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){ |
| |
return ''; |
| |
} |
| |
my $NumSets=1; |
| |
foreach my $array ($Ydata1,$Ydata2){ |
| |
next if (! ref($array)); |
| |
$ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array); |
| |
} |
| |
# |
| |
# Deal with other parameters |
| |
while (my ($key,$value) = each(%Values)) { |
| |
$ValuesHash{$id.'.'.$key} = $value; |
| |
} |
| |
# |
| |
&Apache::lonnet::appenv(%ValuesHash); |
| |
return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />'; |
| |
} |
| |
|
| |
############################################################ |
| |
############################################################ |
| |
|
| |
=pod |
| |
|
| |
=head1 Statistics helper routines? |
| |
|
| |
Bad place for them but what the hell. |
| |
|
| |
=item &chartlink |
| |
|
| |
Returns a link to the chart for a specific student. |
| |
|
| |
Inputs: |
| |
|
| |
=over 4 |
| |
|
| |
=item $linktext: The text of the link |
| |
|
| |
=item $sname: The students username |
| |
|
| |
=item $sdomain: The students domain |
| |
|
| |
=back |
| |
|
| |
=cut |
| |
|
| |
############################################################ |
| |
############################################################ |
| |
sub chartlink { |
| |
my ($linktext, $sname, $sdomain) = @_; |
| |
my $link = '<a href="/adm/statistics?reportSelected=student_assessment'. |
| |
'&SelectedStudent='.&Apache::lonnet::escape($sname.':'.$sdomain). |
| |
'&chartoutputmode='.HTML::Entities::encode('html, with all links'). |
| |
'">'.$linktext.'</a>'; |
| |
} |
| |
|
| |
############################################################ |
| |
############################################################ |
| |
|
| |
=pod |
| |
|
| |
=back |
| |
|
| |
=cut |
| |
|
| 1; |
1; |
| __END__; |
__END__; |
| |
|
![[BACK]](/icons/back.gif){kind=icon}
Return to loncommon.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / interface