version 1.21, 2001/12/25 21:57:54
|
version 1.233, 2004/11/21 04:24:49
|
Line 25
|
Line 25
|
# |
# |
# http://www.lon-capa.org/ |
# http://www.lon-capa.org/ |
# |
# |
# YEAR=2001 |
|
# 2/13-12/7 Guy Albertelli |
|
# 12/11,12/12,12/17 Scott Harrison |
|
# 12/21 Gerd Kortemeyer |
|
# 12/21 Scott Harrison |
|
# 12/25 Gerd Kortemeyer |
|
|
|
# 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 |
# 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 Apache::lonmsg(); |
use POSIX qw(strftime mktime); |
|
use Apache::Constants qw(:common :http :methods); |
|
use Apache::lonmenu(); |
|
use Apache::lonlocal; |
|
use HTML::Entities; |
|
|
|
my $readit; |
|
|
|
## |
|
## Global Variables |
|
## |
|
|
# ----------------------------------------------- Filetypes/Languages/Copyright |
# ----------------------------------------------- Filetypes/Languages/Copyright |
my %language; |
my %language; |
|
my %supported_language; |
my %cprtag; |
my %cprtag; |
|
my %scprtag; |
my %fe; my %fd; |
my %fe; my %fd; |
my %fc; |
my %category_extensions; |
|
|
|
# ---------------------------------------------- Designs |
|
|
# -------------------------------------------------------------- Thesaurus data |
my %designhash; |
my @therelated; |
|
my @theword; |
|
my @thecount; |
|
my %theindex; |
|
my $thetotalcount; |
|
my $thefuzzy=2; |
|
my $thethreshold=0.1/$thefuzzy; |
|
my $theavecount; |
|
|
|
# ----------------------------------------------------------------------- BEGIN |
# ---------------------------------------------- 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 { |
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 $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}. |
'/language.tab'); |
'/language.tab'; |
if ($fh) { |
if ( open(my $fh,"<$langtabfile") ) { |
while (<$fh>) { |
while (<$fh>) { |
next if /^\#/; |
next if /^\#/; |
chomp; |
chomp; |
my ($key,$val)=(split(/\s+/,$_,2)); |
my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$_)); |
$language{$key}=$val; |
$language{$key}=$val.' - '.$enc; |
} |
if ($sup) { |
} |
$supported_language{$key}=$sup; |
|
} |
|
} |
|
close($fh); |
|
} |
} |
} |
# ------------------------------------------------------------------ copyrights |
# ------------------------------------------------------------------ copyrights |
{ |
{ |
my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonIncludes'}. |
my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. |
'/copyright.tab'); |
'/copyright.tab'; |
if ($fh) { |
if ( open (my $fh,"<$copyrightfile") ) { |
while (<$fh>) { |
while (<$fh>) { |
next if /^\#/; |
next if /^\#/; |
chomp; |
chomp; |
my ($key,$val)=(split(/\s+/,$_,2)); |
my ($key,$val)=(split(/\s+/,$_,2)); |
$cprtag{$key}=$val; |
$cprtag{$key}=$val; |
} |
} |
} |
close($fh); |
|
} |
|
} |
|
# ------------------------------------------------------------------ source copyrights |
|
{ |
|
my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. |
|
'/source_copyright.tab'; |
|
if ( open (my $fh,"<$sourcecopyrightfile") ) { |
|
while (<$fh>) { |
|
next if /^\#/; |
|
chomp; |
|
my ($key,$val)=(split(/\s+/,$_,2)); |
|
$scprtag{$key}=$val; |
|
} |
|
close($fh); |
|
} |
|
} |
|
|
|
# -------------------------------------------------------------- domain designs |
|
|
|
my $filename; |
|
my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; |
|
opendir(DIR,$designdir); |
|
while ($filename=readdir(DIR)) { |
|
my ($domain)=($filename=~/^(\w+)\./); |
|
{ |
|
my $designfile = $designdir.'/'.$filename; |
|
if ( open (my $fh,"<$designfile") ) { |
|
while (<$fh>) { |
|
next if /^\#/; |
|
chomp; |
|
my ($key,$val)=(split(/\=/,$_)); |
|
if ($val) { $designhash{$domain.'.'.$key}=$val; } |
|
} |
|
close($fh); |
|
} |
|
} |
|
|
} |
} |
|
closedir(DIR); |
|
|
|
|
# ------------------------------------------------------------- file categories |
# ------------------------------------------------------------- file categories |
{ |
{ |
my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. |
my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}. |
'/filecategories.tab'); |
'/filecategories.tab'; |
if ($fh) { |
if ( open (my $fh,"<$categoryfile") ) { |
while (<$fh>) { |
while (<$fh>) { |
next if /^\#/; |
next if /^\#/; |
chomp; |
chomp; |
my ($key,$val)=(split(/\s+/,$_,2)); |
my ($extension,$category)=(split(/\s+/,$_,2)); |
push @{$fc{$key}},$val; |
push @{$category_extensions{lc($category)}},$extension; |
} |
} |
} |
close($fh); |
|
} |
|
|
} |
} |
# ------------------------------------------------------------------ file types |
# ------------------------------------------------------------------ file types |
{ |
{ |
my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. |
my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}. |
'/filetypes.tab'); |
'/filetypes.tab'; |
if ($fh) { |
if ( open (my $fh,"<$typesfile") ) { |
while (<$fh>) { |
while (<$fh>) { |
next if (/^\#/); |
next if (/^\#/); |
chomp; |
chomp; |
my ($ending,$emb,$descr)=split(/\s+/,$_,3); |
my ($ending,$emb,$descr)=split(/\s+/,$_,3); |
if ($descr ne '') { |
if ($descr ne '') { |
$fe{$ending}=lc($emb); |
$fe{$ending}=lc($emb); |
$fd{$ending}=$descr; |
$fd{$ending}=$descr; |
} |
} |
} |
} |
|
close($fh); |
|
} |
|
} |
|
&Apache::lonnet::logthis( |
|
"<font color=yellow>INFO: Read file types</font>"); |
|
$readit=1; |
|
} # end of unless($readit) |
|
|
|
} |
|
|
|
############################################################### |
|
## HTML and Javascript Helper Functions ## |
|
############################################################### |
|
|
|
=pod |
|
|
|
=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. |
|
|
|
=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 separated list. |
|
|
|
Specifying 'omit' will restrict the browser to NOT displaying files |
|
with the given extension. Can be a comma separated 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. |
|
|
|
=cut |
|
|
|
sub browser_and_searcher_javascript { |
|
my ($mode)=@_; |
|
if (!defined($mode)) { $mode='edit'; } |
|
my $resurl=&lastresurl(); |
|
return <<END; |
|
// <!-- BEGIN LON-CAPA Internal |
|
var editbrowser = null; |
|
function openbrowser(formname,elementname,only,omit,titleelement) { |
|
var url = '$resurl/?'; |
|
if (editbrowser == null) { |
|
url += 'launch=1&'; |
|
} |
|
url += 'catalogmode=interactive&'; |
|
url += 'mode=$mode&'; |
|
url += 'form=' + formname + '&'; |
|
if (only != null) { |
|
url += 'only=' + only + '&'; |
|
} else { |
|
url += 'only=&'; |
|
} |
|
if (omit != null) { |
|
url += 'omit=' + omit + '&'; |
|
} else { |
|
url += 'omit=&'; |
} |
} |
|
if (titleelement != null) { |
|
url += 'titleelement=' + titleelement + '&'; |
|
} else { |
|
url += 'titleelement=&'; |
|
} |
|
url += 'element=' + elementname + ''; |
|
var title = 'Browser'; |
|
var options = 'scrollbars=1,resizable=1,menubar=1,location=1'; |
|
options += ',width=700,height=600'; |
|
editbrowser = open(url,title,options,'1'); |
|
editbrowser.focus(); |
} |
} |
# -------------------------------------------------------------- Thesaurus data |
var editsearcher; |
{ |
function opensearcher(formname,elementname,titleelement) { |
my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. |
var url = '/adm/searchcat?'; |
'/thesaurus.dat'); |
if (editsearcher == null) { |
if ($fh) { |
url += 'launch=1&'; |
while (<$fh>) { |
} |
my ($tword,$tindex,$tcount,$trelated)=split(/\@/,$_); |
url += 'catalogmode=interactive&'; |
$theindex{$tword}=$tindex; |
url += 'mode=$mode&'; |
$theword[$tindex]=$tword; |
url += 'form=' + formname + '&'; |
$thecount[$tindex]=$tcount; |
if (titleelement != null) { |
$thetotalcount+=$tcount; |
url += 'titleelement=' + titleelement + '&'; |
$therelated[$tindex]=$trelated; |
} else { |
|
url += '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 LON-CAPA Internal --> |
|
END |
|
} |
|
|
|
sub lastresurl { |
|
if ($ENV{'environment.lastresurl'}) { |
|
return $ENV{'environment.lastresurl'} |
|
} else { |
|
return '/res'; |
|
} |
|
} |
|
|
|
sub storeresurl { |
|
my $resurl=&Apache::lonnet::clutter(shift); |
|
unless ($resurl=~/^\/res/) { return 0; } |
|
$resurl=~s/\/$//; |
|
&Apache::lonnet::put('environment',{'lastresurl' => $resurl}); |
|
&Apache::lonnet::appenv('environment.lastresurl' => $resurl); |
|
return 1; |
|
} |
|
|
|
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+'&'; |
} |
} |
} |
} |
$theavecount=$thetotalcount/$#thecount; |
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 |
} |
} |
# ============================================================= END BEGIN BLOCK |
|
|
|
|
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 ''; |
|
} |
|
|
# ---------------------------------------------------------- Is this a keyword? |
sub coursebrowser_javascript { |
|
my ($domainfilter,$roleelement)=@_; |
|
return (<<ENDSTDBRW); |
|
<script type="text/javascript" language="Javascript" > |
|
var extra_element = "$roleelement" |
|
var stdeditbrowser; |
|
function opencrsbrowser(formname,uname,udom,desc) { |
|
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+ |
|
'&cnameelement='+desc; |
|
if (extra_element != '') { |
|
url += '&roleelement=$roleelement'; |
|
} |
|
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 keyword { |
sub selectcourse_link { |
my $newword=shift; |
my ($form,$unameele,$udomele,$desc)=@_; |
$newword=~s/\W//g; |
return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele. |
$newword=~tr/A-Z/a-z/; |
'","'.$udomele.'","'.$desc.'");'."'>".&mt('Select Course')."</a>"; |
my $tindex=$theindex{$newword}; |
} |
if ($tindex) { |
|
if ($thecount[$tindex]>$theavecount) { |
=pod |
return 1; |
|
} |
=item * linked_select_forms(...) |
} |
|
return 0; |
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 |
# -------------------------------------------------------- Return related words |
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 |
sub related { |
order. |
my $newword=shift; |
|
$newword=~s/\W//g; |
linked_select_forms takes the following ordered inputs: |
$newword=~tr/A-Z/a-z/; |
|
my $tindex=$theindex{$newword}; |
=over 4 |
if ($tindex) { |
|
my %found=(); |
=item * $formname, the name of the <form> tag |
foreach (split(/\,/,$therelated[$tindex])) { |
|
# - Related word found |
=item * $middletext, the text which appears between the <select> tags |
my ($ridx,$rcount)=split(/\:/,$_); |
|
# - Direct relation index |
=item * $firstdefault, the default value for the first menu |
my $directrel=$rcount/$thecount[$tindex]; |
|
if ($directrel>$thethreshold) { |
=item * $firstselectname, the name of the first <select> tag |
foreach (split(/\,/,$therelated[$ridx])) { |
|
my ($rridx,$rrcount)=split(/\:/,$_); |
=item * $secondselectname, the name of the second <select> tag |
if ($rridx==$tindex) { |
|
# - Determine reverse relation index |
=item * $hashref, a reference to a hash containing the data for the menus. |
my $revrel=$rrcount/$thecount[$ridx]; |
|
# - Calculate full index |
=back |
$found{$ridx}=$directrel*$revrel; |
|
if ($found{$ridx}>$thethreshold) { |
Below is an example of such a hash. Only the 'text', 'default', and |
foreach (split(/\,/,$therelated[$ridx])) { |
'select2' keys must appear as stated. keys(%menu) are the possible |
my ($rrridx,$rrrcount)=split(/\:/,$_); |
values for the first select menu. The text that coincides with the |
unless ($found{$rrridx}) { |
first menu value is given in $menu{$choice1}->{'text'}. The values |
my $revrevrel=$rrrcount/$thecount[$ridx]; |
and text for the second menu are given in the hash pointed to by |
if ( |
$menu{$choice1}->{'select2'}. |
$directrel*$revrel*$revrevrel>$thethreshold |
|
) { |
my %menu = ( A1 => { text =>"Choice A1" , |
$found{$rrridx}= |
default => "B3", |
$directrel*$revrel*$revrevrel; |
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 type=\"text/javascript\">\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; |
|
|
|
$topic=~s/\W/\_/g; |
|
|
|
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 |
|
my $title = &mt('Online Help'); |
|
my $helpicon=&lonhttpdurl("/adm/help/gif/smallHelp.gif"); |
|
$template .= <<"ENDTEMPLATE"; |
|
<a href="$link" title="$title"><img src="$helpicon" 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>'; |
|
} |
|
|
|
sub help_open_menu { |
|
my ($color,$topic,$component_help,$function,$faq,$bug,$stayOnPage,$width,$height,$text) = @_; |
|
$text = "" if (not defined $text); |
|
$stayOnPage = 0 if (not defined $stayOnPage); |
|
if ($ENV{'browser.interface'} eq 'textual' || |
|
$ENV{'environment.remote'} eq 'off' ) { |
|
$stayOnPage=1; |
|
} |
|
$width = 620 if (not defined $width); |
|
$height = 600 if (not defined $height); |
|
my $link=''; |
|
my $title = &mt('Get help'); |
|
my $origurl = $ENV{'REQUEST_URI'}; |
|
$origurl=~s|^/~|/priv/|; |
|
my $timestamp = time; |
|
foreach (\$color,\$function,\$topic,\$component_help,\$faq,\$bug,\$origurl) { |
|
$$_ = &Apache::lonnet::escape($$_); |
|
} |
|
|
|
if (!$stayOnPage) { |
|
$link = "javascript:helpMenu('open')"; |
|
} else { |
|
$link = "javascript:helpMenu('display')"; |
|
} |
|
my $banner_link = "/adm/helpmenu?page=banner&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp&stayonpage=$stayOnPage"; |
|
my $details_link = "/adm/helpmenu?page=body&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp"; |
|
my $template; |
|
if ($text ne "") { |
|
$template .= |
|
"<table bgcolor='#773311' cellspacing='1' cellpadding='1' border='0'><tr>". |
|
"<td bgcolor='#886622'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>"; |
|
} |
|
my $helpicon=&lonhttpdurl("/adm/lonIcons/helpgateway.gif"); |
|
$template .= <<"ENDTEMPLATE"; |
|
<script type="text/javascript"> |
|
//<!-- BEGIN LON-CAPA Internal |
|
function helpMenu(caller) { |
|
if (caller == 'open') { |
|
newWindow = window.open("","helpmenu","HEIGHT=$height,WIDTH=$width,resize=yes,scrollbars=yes" ) |
|
caller = newWindow.document |
|
} else { |
|
caller = this.document |
|
} |
|
caller.write("<html><head><title>LON-CAPA Help Menu</title><meta http-equiv='pragma' content='no-cache'></head>") |
|
caller.write("<frameset rows='105,*' border='0'><frame name='bannerframe' src='$banner_link'><frame name='bodyframe' src='$details_link'></frameset>") |
|
caller.write("</html>") |
|
caller.close() |
|
if (caller == newWindow.document) { |
|
caller.focus() |
|
} |
|
} |
|
// END LON-CAPA Internal --> |
|
</script> |
|
<a href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help Menu)" /></a> |
|
ENDTEMPLATE |
|
if ($component_help) { |
|
if (!$text) { |
|
$template=&help_open_topic($component_help,undef,$stayOnPage, |
|
$width,$height).' '.$template; |
|
} else { |
|
my $help_text; |
|
$help_text=&Apache::lonnet::unescape($topic); |
|
$template='<table><tr><td>'. |
|
&help_open_topic($component_help,$help_text,$stayOnPage, |
|
$width,$height).'</td><td>'.$template. |
|
'</td></tr></table>'; |
|
} |
|
} |
|
if ($text ne '') { $template.='</td></tr></table>' }; |
|
return $template; |
|
} |
|
|
|
sub help_open_bug { |
|
my ($topic, $text, $stayOnPage, $width, $height) = @_; |
|
unless ($ENV{'user.adv'}) { return ''; } |
|
unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; } |
|
$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 = 600 if (not defined $width); |
|
$height = 600 if (not defined $height); |
|
|
|
$topic=~s/\W+/\+/g; |
|
my $link=''; |
|
my $template=''; |
|
my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='. |
|
&Apache::lonnet::escape($ENV{'REQUEST_URI'}).'&component='.$topic; |
|
if (!$stayOnPage) |
|
{ |
|
$link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; |
|
} |
|
else |
|
{ |
|
$link = $url; |
|
} |
|
# Add the text |
|
if ($text ne "") |
|
{ |
|
$template .= |
|
"<table bgcolor='#AA3333' cellspacing='1' cellpadding='1' border='0'><tr>". |
|
"<td bgcolor='#FF5555'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>"; |
|
} |
|
|
|
# Add the graphic |
|
my $title = &mt('Report a Bug'); |
|
my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif"); |
|
$template .= <<"ENDTEMPLATE"; |
|
<a href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a> |
|
ENDTEMPLATE |
|
if ($text ne '') { $template.='</td></tr></table>' }; |
|
return $template; |
|
|
|
} |
|
|
|
sub help_open_faq { |
|
my ($topic, $text, $stayOnPage, $width, $height) = @_; |
|
unless ($ENV{'user.adv'}) { return ''; } |
|
unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; } |
|
$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); |
|
|
|
$topic=~s/\W+/\+/g; |
|
my $link=''; |
|
my $template=''; |
|
my $url=$Apache::lonnet::perlvar{'FAQHost'}.'/fom/cache/'.$topic.'.html'; |
|
if (!$stayOnPage) |
|
{ |
|
$link = "javascript:void(open('$url', 'FAQ-O-Matic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; |
|
} |
|
else |
|
{ |
|
$link = $url; |
|
} |
|
|
|
# Add the text |
|
if ($text ne "") |
|
{ |
|
$template .= |
|
"<table bgcolor='#337733' cellspacing='1' cellpadding='1' border='0'><tr>". |
|
"<td bgcolor='#448844'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>"; |
|
} |
|
|
|
# Add the graphic |
|
my $title = &mt('View the FAQ'); |
|
my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif"); |
|
$template .= <<"ENDTEMPLATE"; |
|
<a href="$link" title="$title"><img src="$faqicon" border="0" alt="(FAQ: $topic)" /></a> |
|
ENDTEMPLATE |
|
if ($text ne '') { $template.='</td></tr></table>' }; |
|
return $template; |
|
|
|
} |
|
|
|
############################################################### |
|
############################################################### |
|
|
|
=pod |
|
|
|
=item * csv_translate($text) |
|
|
|
Translate $text to allow it to be output as a 'comma separated values' |
|
format. |
|
|
|
=cut |
|
|
|
############################################################### |
|
############################################################### |
|
sub csv_translate { |
|
my $text = shift; |
|
$text =~ s/\"/\"\"/g; |
|
$text =~ s/\n/ /g; |
|
return $text; |
|
} |
|
|
|
|
|
############################################################### |
|
############################################################### |
|
|
|
=pod |
|
|
|
=item * define_excel_formats |
|
|
|
Define some commonly used Excel cell formats. |
|
|
|
Currently supported formats: |
|
|
|
=over 4 |
|
|
|
=item header |
|
|
|
=item bold |
|
|
|
=item h1 |
|
|
|
=item h2 |
|
|
|
=item h3 |
|
|
|
=item date |
|
|
|
=back |
|
|
|
Inputs: $workbook |
|
|
|
Returns: $format, a hash reference. |
|
|
|
=cut |
|
|
|
############################################################### |
|
############################################################### |
|
sub define_excel_formats { |
|
my ($workbook) = @_; |
|
my $format; |
|
$format->{'header'} = $workbook->add_format(bold => 1, |
|
bottom => 1, |
|
align => 'center'); |
|
$format->{'bold'} = $workbook->add_format(bold=>1); |
|
$format->{'h1'} = $workbook->add_format(bold=>1, size=>18); |
|
$format->{'h2'} = $workbook->add_format(bold=>1, size=>16); |
|
$format->{'h3'} = $workbook->add_format(bold=>1, size=>14); |
|
$format->{'date'} = $workbook->add_format(num_format=> |
|
'mm/dd/yyyy hh:mm:ss'); |
|
return $format; |
|
} |
|
|
|
############################################################### |
|
############################################################### |
|
|
|
=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; |
|
} |
|
|
|
# ------------------------------------------ |
|
|
|
sub domain_select { |
|
my ($name,$value,$multiple)=@_; |
|
my %domains=map { |
|
$_ => $_.' '.$Apache::lonnet::domaindescription{$_} |
|
} &get_domains; |
|
if ($multiple) { |
|
$domains{''}=&mt('Any domain'); |
|
return &multiple_select_form($name,$value,4,%domains); |
|
} else { |
|
return &select_form($name,$value,%domains); |
|
} |
|
} |
|
|
|
sub multiple_select_form { |
|
my ($name,$value,$size,%hash)=@_; |
|
my %selected = map { $_ => 1 } ref($value)?@{$value}:($value); |
|
my $output=''; |
|
if (! defined($size)) { |
|
$size = 4; |
|
if (scalar(keys(%hash))<4) { |
|
$size = scalar(keys(%hash)); |
|
} |
|
} |
|
$output.="\n<select name='$name' size='$size' multiple='1'>"; |
|
foreach (sort(keys(%hash))) { |
|
$output.='<option value="'.$_.'" '; |
|
$output.='selected ' if ($selected{$_}); |
|
$output.='>'.$hash{$_}."</option>\n"; |
|
} |
|
$output.="</select>\n"; |
|
return $output; |
|
} |
|
|
|
#------------------------------------------- |
|
|
|
=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; |
|
} |
|
|
|
sub gradeleveldescription { |
|
my $gradelevel=shift; |
|
my %gradelevels=(0 => 'Not specified', |
|
1 => 'Grade 1', |
|
2 => 'Grade 2', |
|
3 => 'Grade 3', |
|
4 => 'Grade 4', |
|
5 => 'Grade 5', |
|
6 => 'Grade 6', |
|
7 => 'Grade 7', |
|
8 => 'Grade 8', |
|
9 => 'Grade 9', |
|
10 => 'Grade 10', |
|
11 => 'Grade 11', |
|
12 => 'Grade 12', |
|
13 => 'Grade 13', |
|
14 => '100 Level', |
|
15 => '200 Level', |
|
16 => '300 Level', |
|
17 => '400 Level', |
|
18 => 'Graduate Level'); |
|
return &mt($gradelevels{$gradelevel}); |
|
} |
|
|
|
sub select_level_form { |
|
my ($deflevel,$name)=@_; |
|
unless ($deflevel) { $deflevel=0; } |
|
my $selectform = "<select name=\"$name\" size=\"1\">\n"; |
|
for (my $i=0; $i<=18; $i++) { |
|
$selectform.="<option value=\"$i\" ". |
|
($i==$deflevel ? 'selected' : ''). |
|
">".&gradeleveldescription($i)."</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 |
|
|
|
=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,); |
|
} |
|
|
|
############################################################### |
|
## 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 |
|
|
|
=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 = ""; |
|
} |
|
|
|
my $radioval = "'nochange'"; |
|
if (exists($in{'curr_authtype'}) && |
|
defined($in{'curr_authtype'}) && |
|
$in{'curr_authtype'} ne '') { |
|
$radioval = "'$in{'curr_authtype'}arg'"; |
|
} |
|
my $argfield = 'null'; |
|
if ( grep/^mode$/,(keys %in) ) { |
|
if ($in{'mode'} eq 'modifycourse') { |
|
if ( grep/^curr_authtype$/,(keys %in) ) { |
|
$radioval = "'$in{'curr_authtype'}'"; |
|
} |
|
if ( grep/^curr_autharg$/,(keys %in) ) { |
|
unless ($in{'curr_autharg'} eq '') { |
|
$argfield = "'$in{'curr_autharg'}'"; |
|
} |
} |
} |
} |
} |
} |
} |
return (); |
|
|
$result.=<<"END"; |
|
var current = new Object(); |
|
current.radiovalue = $radioval; |
|
current.argfield = $argfield; |
|
|
|
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; |
} |
} |
|
|
# ---------------------------------------------------------------- Language IDs |
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,$krbarg); |
|
if ($in{'kerb_def_auth'} eq 'krb5') { |
|
$check5 = " checked=\"on\""; |
|
} else { |
|
$check4 = " checked=\"on\""; |
|
} |
|
$krbarg = $in{'kerb_def_dom'}; |
|
|
|
my $krbcheck = ""; |
|
if ( grep/^curr_authtype$/,(keys %in) ) { |
|
if ($in{'curr_authtype'} =~ m/^krb/) { |
|
$krbcheck = " checked=\"on\""; |
|
if ( grep/^curr_autharg$/,(keys %in) ) { |
|
$krbarg = $in{'curr_autharg'}; |
|
} |
|
} |
|
} |
|
|
|
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.'"'.$krbcheck.' />', |
|
'<input type="text" size="10" name="krbarg" '. |
|
'value="'.$krbarg.'" '. |
|
'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 $intcheck = ""; |
|
my $intarg = 'value=""'; |
|
if ( grep/^curr_authtype$/,(keys %args) ) { |
|
if ($args{'curr_authtype'} eq 'int') { |
|
$intcheck = " checked=\"on\""; |
|
if ( grep/^curr_autharg$/,(keys %args) ) { |
|
$intarg = "value=\"$args{'curr_autharg'}\""; |
|
} |
|
} |
|
} |
|
|
|
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" '.$intcheck. |
|
' onchange="'.$jscall.'" onclick="'.$jscall.'" />', |
|
'<input type="text" size="10" name="intarg" '.$intarg. |
|
' onchange="'.$jscall.'" />'); |
|
return $result; |
|
} |
|
|
|
sub authform_local{ |
|
my %in = ( |
|
formname => 'document.cu', |
|
kerb_def_dom => 'MSU.EDU', |
|
@_, |
|
); |
|
|
|
my $loccheck = ""; |
|
my $locarg = 'value=""'; |
|
if ( grep/^curr_authtype$/,(keys %in) ) { |
|
if ($in{'curr_authtype'} eq 'loc') { |
|
$loccheck = " checked=\"on\""; |
|
if ( grep/^curr_autharg$/,(keys %in) ) { |
|
$locarg = "value=\"$in{'curr_autharg'}\""; |
|
} |
|
} |
|
} |
|
|
|
my $jscall = "javascript:changed_radio('loc',$in{'formname'});"; |
|
my $result.=&mt('[_1] Local Authentication with argument [_2]', |
|
'<input type="radio" name="login" value="loc" '.$loccheck. |
|
' onchange="'.$jscall.'" onclick="'.$jscall.'" />', |
|
'<input type="text" size="10" name="locarg" '.$locarg. |
|
' 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; |
|
} |
|
|
|
############################################################### |
|
## 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 argument 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,$first) |
|
|
|
Takes a users logon name and returns it as a string in |
|
"first middle last generation" form |
|
if $first is set to 'lastname' then it returns it as |
|
'lastname generation, firstname middlename' if their is a lastname |
|
|
|
=cut |
|
|
|
############################################################### |
|
sub plainname { |
|
my ($uname,$udom,$first)=@_; |
|
my %names=&Apache::lonnet::get('environment', |
|
['firstname','middlename','lastname','generation'], |
|
$udom,$uname); |
|
my $name=&Apache::lonnet::format_name($names{'firstname'}, |
|
$names{'middlename'}, |
|
$names{'lastname'}, |
|
$names{'generation'},$first); |
|
$name=~s/^\s+//; |
|
$name=~s/\s+$//; |
|
$name=~s/\s+/ /g; |
|
if ($name !~ /\S/) { $name=$uname.'@'.$udom; } |
|
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; |
|
if ($uname eq $ENV{'user.name'} && |
|
$udom eq $ENV{'user.domain'}) { |
|
%names=('nickname' => $ENV{'environment.nickname'} , |
|
'firstname' => $ENV{'environment.firstname'} , |
|
'middlename' => $ENV{'environment.middlename'}, |
|
'lastname' => $ENV{'environment.lastname'} , |
|
'generation' => $ENV{'environment.generation'}); |
|
} else { |
|
%names=&Apache::lonnet::get('environment', |
|
['nickname','firstname','middlename', |
|
'lastname','generation'],$udom,$uname); |
|
} |
|
my $name=$names{'nickname'}; |
|
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)=@_; |
|
if ($uname eq $ENV{'user.name'} && |
|
$udom eq $ENV{'user.domain'}) {return $ENV{'environment.screenname'};} |
|
my %names=&Apache::lonnet::get('environment',['screenname'],$udom,$uname); |
|
return $names{'screenname'}; |
|
} |
|
|
|
|
|
# ------------------------------------------------------------- Message Wrapper |
|
|
|
sub messagewrapper { |
|
my ($link,$username,$domain)=@_; |
|
return |
|
'<a href="/adm/email?compose=individual&'. |
|
'recname='.$username.'&recdom='.$domain.'" '. |
|
'title="'.&mt('Send message').'">'.$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,$target)=@_; |
|
return '<a href="/adm/'.$domain.'/'.$username.'/aboutme"'. |
|
($target?' target="$target"':'').' title="'.&mt('View this users personal page').'">'.$link.'</a>'; |
|
} |
|
|
|
# ------------------------------------------------------------ Syllabus Wrapper |
|
|
|
|
|
sub syllabuswrapper { |
|
my ($linktext,$coursedir,$domain,$fontcolor)=@_; |
|
if ($fontcolor) { |
|
$linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>'; |
|
} |
|
return qq{<a href="/public/$domain/$coursedir/syllabus">$linktext</a>}; |
|
} |
|
|
|
sub track_student_link { |
|
my ($linktext,$sname,$sdom,$target) = @_; |
|
my $link ="/adm/trackstudent"; |
|
my $title = 'View recent activity'; |
|
if (defined($sname) && $sname !~ /^\s*$/ && |
|
defined($sdom) && $sdom !~ /^\s*$/) { |
|
$link .= "?selected_student=$sname:$sdom"; |
|
$title .= ' of this student'; |
|
} |
|
if (defined($target) && $target !~ /^\s*$/) { |
|
$target = qq{target="$target"}; |
|
} else { |
|
$target = ''; |
|
} |
|
return qq{<a href="$link" title="$title" $target>$linktext</a>}; |
|
} |
|
|
|
|
|
|
|
=pod |
|
|
|
=back |
|
|
|
=head1 Access .tab File Data |
|
|
|
=over 4 |
|
|
|
=item * languageids() |
|
|
|
returns list of all language ids |
|
|
|
=cut |
|
|
sub languageids { |
sub languageids { |
return sort(keys(%language)); |
return sort(keys(%language)); |
} |
} |
|
|
# -------------------------------------------------------- Language Description |
=pod |
|
|
|
=item * languagedescription() |
|
|
|
returns description of a specified language id |
|
|
|
=cut |
|
|
sub languagedescription { |
sub languagedescription { |
return $language{shift(@_)}; |
my $code=shift; |
|
return ($supported_language{$code}?'* ':''). |
|
$language{$code}. |
|
($supported_language{$code}?' ('.&mt('interface available').')':''); |
} |
} |
|
|
# --------------------------------------------------------------- Copyright IDs |
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 { |
sub copyrightids { |
return sort(keys(%cprtag)); |
return sort(keys(%cprtag)); |
} |
} |
|
|
# ------------------------------------------------------- Copyright Description |
=pod |
|
|
|
=item * copyrightdescription() |
|
|
|
returns description of a specified copyright id |
|
|
|
=cut |
|
|
sub copyrightdescription { |
sub copyrightdescription { |
return $cprtag{shift(@_)}; |
return &mt($cprtag{shift(@_)}); |
|
} |
|
|
|
=pod |
|
|
|
=item * source_copyrightids() |
|
|
|
returns list of all source copyrights |
|
|
|
=cut |
|
|
|
sub source_copyrightids { |
|
return sort(keys(%scprtag)); |
} |
} |
|
|
# ------------------------------------------------------------- File Categories |
=pod |
|
|
|
=item * source_copyrightdescription() |
|
|
|
returns description of a specified source copyright id |
|
|
|
=cut |
|
|
|
sub source_copyrightdescription { |
|
return &mt($scprtag{shift(@_)}); |
|
} |
|
|
|
=pod |
|
|
|
=item * filecategories() |
|
|
|
returns list of all file categories |
|
|
|
=cut |
|
|
sub filecategories { |
sub filecategories { |
return sort(keys(%fc)); |
return sort(keys(%category_extensions)); |
} |
} |
|
|
# -------------------------------------- File Types within a specified category |
=pod |
|
|
|
=item * filecategorytypes() |
|
|
|
returns list of file types belonging to a given file |
|
category |
|
|
|
=cut |
|
|
sub filecategorytypes { |
sub filecategorytypes { |
return @{$fc{lc(shift(@_))}}; |
return @{$category_extensions{lc($_[0])}}; |
} |
} |
|
|
# ------------------------------------------------------------------ File Types |
=pod |
sub fileextensions { |
|
return sort(keys(%fe)); |
=item * fileembstyle() |
} |
|
|
returns embedding style for a specified file type |
|
|
|
=cut |
|
|
# ------------------------------------------------------------- Embedding Style |
|
sub fileembstyle { |
sub fileembstyle { |
return $fe{lc(shift(@_))}; |
return $fe{lc(shift(@_))}; |
} |
} |
|
|
# ------------------------------------------------------------ Description Text |
|
|
sub filecategoryselect { |
|
my ($name,$value)=@_; |
|
return &select_form($value,$name, |
|
'' => &mt('Any category'), |
|
map { $_,$_ } sort(keys(%category_extensions))); |
|
} |
|
|
|
=pod |
|
|
|
=item * filedescription() |
|
|
|
returns description for a specified file type |
|
|
|
=cut |
|
|
sub filedescription { |
sub filedescription { |
return $fd{lc(shift(@_))}; |
my $file_description = $fd{lc(shift())}; |
|
$file_description =~ s:([\[\]]):~$1:g; |
|
return &mt($file_description); |
} |
} |
|
|
# ------------------------------------------------------------ Description Text |
=pod |
|
|
|
=item * filedescriptionex() |
|
|
|
returns description for a specified file type with |
|
extra formatting |
|
|
|
=cut |
|
|
sub filedescriptionex { |
sub filedescriptionex { |
my $ex=shift; |
my $ex=shift; |
return '.'.$ex.' '.$fd{lc($ex)}; |
my $file_description = $fd{lc($ex)}; |
|
$file_description =~ s:([\[\]]):~$1:g; |
|
return '.'.$ex.' '.&mt($file_description); |
} |
} |
|
|
|
# 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{'course.'.$ENV{'request.course.id'}.'.languages'}) { |
|
@languages=(@languages,split(/\s*(\,|\;|\:)\s*/, |
|
$ENV{'course.'.$ENV{'request.course.id'}.'.languages'})); |
|
} |
|
if ($ENV{'environment.languages'}) { |
|
@languages=split(/\s*(\,|\;|\:)\s*/,$ENV{'environment.languages'}); |
|
} |
|
my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0]; |
|
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 259 sub get_previous_attempt {
|
Line 2178 sub get_previous_attempt {
|
$lasthash{$_}=$returnhash{$version.':'.$_}; |
$lasthash{$_}=$returnhash{$version.':'.$_}; |
} |
} |
} |
} |
$prevattempts='<table border=2></tr><th>History</th>'; |
$prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">'; |
|
$prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>'; |
foreach (sort(keys %lasthash)) { |
foreach (sort(keys %lasthash)) { |
$prevattempts.='<th>'.$_.'</th>'; |
my ($ign,@parts) = split(/\./,$_); |
} |
if ($#parts > 0) { |
for ($version=1;$version<=$returnhash{'version'};$version++) { |
my $data=$parts[-1]; |
$prevattempts.='</tr><tr><th>Attempt '.$version.'</th>'; |
pop(@parts); |
foreach (sort(keys %lasthash)) { |
$prevattempts.='<td>Part '.join('.',@parts).'<br />'.$data.' </td>'; |
my $value; |
} else { |
if ($_ =~ /timestamp/) { |
if ($#parts == 0) { |
$value=scalar(localtime($returnhash{$version.':'.$_})); |
$prevattempts.='<th>'.$parts[0].'</th>'; |
} else { |
} else { |
$value=$returnhash{$version.':'.$_}; |
$prevattempts.='<th>'.$ign.'</th>'; |
} |
} |
$prevattempts.='<td>'.$value.'</td>'; |
} |
} |
|
} |
} |
$prevattempts.='</tr><tr><th>Current</th>'; |
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 bgcolor="#ffffe6"><td>Current</td>'; |
foreach (sort(keys %lasthash)) { |
foreach (sort(keys %lasthash)) { |
my $value; |
my $value; |
if ($_ =~ /timestamp/) { |
if ($_ =~ /timestamp/) { |
Line 283 sub get_previous_attempt {
|
Line 2216 sub get_previous_attempt {
|
} else { |
} else { |
$value=$lasthash{$_}; |
$value=$lasthash{$_}; |
} |
} |
$prevattempts.='<td>'.$value.'</td>'; |
$value=&Apache::lonnet::unescape($value); |
|
if ($_ =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)} |
|
$prevattempts.='<td>'.$value.' </td>'; |
} |
} |
$prevattempts.='</tr></table>'; |
$prevattempts.='</tr></table></td></tr></table>'; |
} else { |
} else { |
$prevattempts='Nothing submitted - no attempts.'; |
$prevattempts='Nothing submitted - no attempts.'; |
} |
} |
Line 294 sub get_previous_attempt {
|
Line 2229 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,$moreenv) = @_; |
my ($map,$id,$feedurl) = split(/___/,$symb); |
my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb); |
my (%old,%moreenv); |
my (%form); |
my @elements=('symb','courseid','domain','username'); |
my @elements=('symb','courseid','domain','username'); |
foreach my $element (@elements) { |
foreach my $element (@elements) { |
$old{$element}=$ENV{'form.grade_'.$element}; |
$form{'grade_'.$element}=eval '$'.$element #' |
$moreenv{'form.grade_'.$element}=eval '$'.$element #' |
|
} |
} |
&Apache::lonnet::appenv(%moreenv); |
if (defined($moreenv)) { |
my $userview=&Apache::lonnet::ssi('/res/'.$feedurl); |
%form=(%form,%{$moreenv}); |
&Apache::lonnet::delenv('form.grade_'); |
|
foreach my $element (@elements) { |
|
$ENV{'form.grade_'.$element}=$old{$element}; |
|
} |
} |
|
if ($target eq 'tex') {$form{'grade_target'} = 'tex';} |
|
$feedurl=&Apache::lonnet::clutter($feedurl); |
|
my $userview=&Apache::lonnet::ssi_body($feedurl,%form); |
$userview=~s/\<body[^\>]*\>//gi; |
$userview=~s/\<body[^\>]*\>//gi; |
$userview=~s/\<\/body\>//gi; |
$userview=~s/\<\/body\>//gi; |
$userview=~s/\<html\>//gi; |
$userview=~s/\<html\>//gi; |
Line 316 sub get_student_view {
|
Line 2293 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 (%moreenv); |
my @elements=('symb','courseid','domain','username'); |
my @elements=('symb','courseid','domain','username'); |
foreach my $element (@elements) { |
foreach my $element (@elements) { |
$old{$element}=$ENV{'form.grade_'.$element}; |
$moreenv{'grade_'.$element}=eval '$'.$element #' |
$moreenv{'form.grade_'.$element}=eval '$'.$element #' |
|
} |
} |
$moreenv{'form.grade_target'}='answer'; |
$moreenv{'grade_target'}='answer'; |
&Apache::lonnet::appenv(%moreenv); |
%moreenv=(%form,%moreenv); |
my $userview=&Apache::lonnet::ssi('/res/'.$feedurl); |
my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%moreenv); |
&Apache::lonnet::delenv('form.grade_'); |
|
foreach my $element (@elements) { |
|
$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,-1)); |
|
} |
|
|
|
######################################### |
|
|
|
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 $logo=&lonhttpdurl("/adm/lonDomLogos/$domain.gif"); |
|
return '<img src="'.$logo.'" 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,$customtitle)=@_; |
|
$title=&mt($title); |
|
$function = &get_users_function() if (!$function); |
|
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 type="text/css"> |
|
h1, h2, h3, th { font-family: Arial, Helvetica, sans-serif } |
|
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 |
|
my $roleinfo=(<<ENDROLE); |
|
<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> |
|
<br /> |
|
<font size="2" face="Arial, Helvetica, sans-serif">$role</font> |
|
<br /> |
|
<font size="2" face="Arial, Helvetica, sans-serif">$realm</font> |
|
</td> |
|
ENDROLE |
|
my $titleinfo = '<font face="Arial, Helvetica, sans-serif" size="+3" color="'. |
|
$font.'"><b>'.$title.'</b></font>'; |
|
if ($customtitle) { |
|
$titleinfo = $customtitle; |
|
} |
|
if ($ENV{'request.state'} eq 'construct') { |
|
my ($uname,$thisdisfn)= |
|
($ENV{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|); |
|
my $formaction='/priv/'.$uname.'/'.$thisdisfn; |
|
$formaction=~s/\/+/\//g; |
|
$titleinfo = '<form name="dirs" method="post" action="'.$formaction |
|
.'" target="_top">' |
|
.&Apache::lonhtmlcommon::crumbs($uname.'/'.$thisdisfn,'_top','/priv','',-1,1)."<br />" |
|
.&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()') |
|
.'</form>' |
|
.&Apache::lonmenu::constspaceform(); |
|
|
|
&Apache::lonhtmlcommon::store_recent('construct',$formaction,$formaction); |
|
if ($thisdisfn!~m|/$|) { $forcereg=1; } |
|
} |
|
|
|
return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web', |
|
$forcereg). |
|
'<table bgcolor="'.$pgbg.'" width="100%" border="0" cellspacing="3" cellpadding="3"><tr><td rowspan="3" bgcolor="'.$tabbg.'">'.$titleinfo.'</td>'.$roleinfo.'</tr></table>'; |
|
} |
|
|
|
# |
|
# Top frame rendering, Remote is up |
|
# |
|
my $titleinfo = ' <font size="5" face="Arial, Helvetica, sans-serif"><b>'.$title.'</b></font>'; |
|
if ($customtitle) { |
|
$titleinfo = $customtitle; |
|
} |
|
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"> |
|
$titleinfo |
|
<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 |
|
} |
|
|
|
############################################### |
|
|
|
=pod |
|
|
|
=item get_users_function |
|
|
|
Used by &bodytag to determine the current users primary role. |
|
Returns either 'student','coordinator','admin', or 'author'. |
|
|
|
=cut |
|
|
|
############################################### |
|
sub get_users_function { |
|
my $function = 'student'; |
|
if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) { |
|
$function='coordinator'; |
|
} |
|
if ($ENV{'request.role'}=~/^(su|dc|ad|li)/) { |
|
$function='admin'; |
|
} |
|
if (($ENV{'request.role'}=~/^(au|ca)/) || |
|
($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) { |
|
$function='author'; |
|
} |
|
return $function; |
|
} |
|
|
|
############################################### |
|
|
|
=pod |
|
|
|
=item get_sections |
|
|
|
Determines all the sections for a course including |
|
sections with students and sections containing other roles. |
|
Incoming parameters: domain, course number, reference to |
|
section hash (keys to be section/group IDs), reference to |
|
array containing roles for which sections should be gathered |
|
(optional). If the fourth argument is undefined, sections |
|
are gathered for any role. |
|
|
|
Returns number of sections. |
|
|
|
=cut |
|
|
|
############################################### |
|
sub get_sections { |
|
my ($cdom,$cnum,$sectioncount,$possible_roles) = @_; |
|
my $cid = $cdom.'_'.$cnum; |
|
my $numsections = 0; |
|
if ($cdom && $cnum) { |
|
if (!defined($possible_roles) || (grep/^st$/,@$possible_roles)) { |
|
my ($classlist) = &Apache::loncoursedata::get_classlist($cid,$cdom,$cnum); |
|
my $sec_index = &Apache::loncoursedata::CL_SECTION(); |
|
my $status_index = &Apache::loncoursedata::CL_STATUS(); |
|
while (my ($student,$data) = each %$classlist) { |
|
my ($section,$status) = ($data->[$sec_index], |
|
$data->[$status_index]); |
|
unless ($section eq '' || $section =~ /^\s*$/) { |
|
if (!defined($$sectioncount{$section})) { |
|
$$sectioncount{$section} = 1; |
|
$numsections ++; |
|
} else { |
|
$$sectioncount{$section} ++; |
|
} |
|
} |
|
} |
|
} |
|
my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum); |
|
foreach my $user (sort keys %courseroles) { |
|
if ($user =~ /^(\w{2})/) { |
|
my $role = $1; |
|
if (!defined($possible_roles) || (grep/^$role$/,@$possible_roles)) { |
|
if ($role eq 'cr') { |
|
if ($user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) { |
|
if (!defined($$sectioncount{$1})) { |
|
$$sectioncount{$1} = 1; |
|
$numsections ++; |
|
} else { |
|
$$sectioncount{$1} ++; |
|
} |
|
} |
|
} |
|
if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { |
|
if (!defined($$sectioncount{$1})) { |
|
$$sectioncount{$1} = 1; |
|
$numsections ++; |
|
} else { |
|
$$sectioncount{$1} ++; |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
return $numsections; |
|
} |
|
|
|
|
|
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)= @_; |
|
# $Apache::lonxml::debug=1; |
foreach (split(/&/,$query)) { |
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/+/ /; |
|
$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 { |
my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); |
unless ($ENV{'request.method'} eq 'GET') { return ''; } |
my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" /> |
my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); |
|
my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" /> |
<meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" /> |
<meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" /> |
<meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />'; |
<meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />'; |
return $output; |
return $output; |
} |
} |
|
|
|
=pod |
|
|
|
=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); |
if ($ENV{'REQUEST_METHOD'} ne 'GET' && |
$r->no_cache(1); |
$ENV{'request.method'} ne 'GET') { return ''; } |
$r->header_out("Pragma" => "no-cache"); |
my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time)); |
$r->header_out("Expires" => $date); |
$r->no_cache(1); |
|
$r->header_out("Expires" => $date); |
|
$r->header_out("Pragma" => "no-cache"); |
} |
} |
1; |
|
__END__; |
|
|
|
|
sub content_type { |
|
my ($r,$type,$charset) = @_; |
|
unless ($charset) { |
|
$charset=&Apache::lonlocal::current_encoding; |
|
} |
|
if ($charset) { $type.='; charset='.$charset; } |
|
if ($r) { |
|
$r->content_type($type); |
|
} else { |
|
print("Content-type: $type\n\n"); |
|
} |
|
} |
|
|
=head1 NAME |
=pod |
|
|
Apache::loncommon - pile of common routines |
=item * add_to_env($name,$value) |
|
|
=head1 SYNOPSIS |
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. |
|
|
Referenced by other mod_perl Apache modules. |
=cut |
|
|
Invocation: |
sub add_to_env { |
&Apache::loncommon::SUBROUTINENAME(ARGUMENTS); |
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; |
|
} |
|
} |
|
|
=head1 INTRODUCTION |
=pod |
|
|
Common collection of used subroutines. This collection helps remove |
=item * get_env_multiple($name) |
redundancy from other modules and increase efficiency of memory usage. |
|
|
gets $name from the %ENV hash, it seemlessly handles the cases where multiple |
|
values may be defined and end up as an array ref. |
|
|
Current things done: |
returns an array of values |
|
|
|
=cut |
|
|
Makes a table out of the previous homework attempts |
sub get_env_multiple { |
Inputs result_from_symbread, user, domain, course_id |
my ($name) = @_; |
Reads in non-network-related .tab files |
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); |
|
} |
|
|
This is part of the LearningOnline Network with CAPA project |
|
described at http://www.lon-capa.org. |
|
|
|
=head1 HANDLER SUBROUTINE |
=pod |
|
|
There is no handler subroutine. |
=back |
|
|
=head1 OTHER SUBROUTINES |
=head1 CSV Upload/Handling functions |
|
|
=over 4 |
=over 4 |
|
|
=item * |
=item * upfile_store($r) |
|
|
BEGIN() : initialize values from language.tab, copyright.tab, filetypes.tab, |
Store uploaded file, $r should be the HTTP Request object, |
and filecategories.tab. |
needs $ENV{'form.upfile'} |
|
returns $datatoken to be put into hidden field |
|
|
=item * |
=cut |
|
|
languageids() : returns list of all language ids |
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; |
|
|
=item * |
my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}. |
|
'_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$; |
|
{ |
|
my $datafile = $r->dir_config('lonDaemons'). |
|
'/tmp/'.$datatoken.'.tmp'; |
|
if ( open(my $fh,">$datafile") ) { |
|
print $fh $ENV{'form.upfile'}; |
|
close($fh); |
|
} |
|
} |
|
return $datatoken; |
|
} |
|
|
languagedescription() : returns description of a specified language id |
=pod |
|
|
=item * |
=item * load_tmp_file($r) |
|
|
copyrightids() : returns list of all copyrights |
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 |
|
|
=item * |
=cut |
|
|
copyrightdescription() : returns description of a specified copyright id |
sub load_tmp_file { |
|
my $r=shift; |
|
my @studentdata=(); |
|
{ |
|
my $studentfile = $r->dir_config('lonDaemons'). |
|
'/tmp/'.$ENV{'form.datatoken'}.'.tmp'; |
|
if ( open(my $fh,"<$studentfile") ) { |
|
@studentdata=<$fh>; |
|
close($fh); |
|
} |
|
} |
|
$ENV{'form.upfile'}=join('',@studentdata); |
|
} |
|
|
=item * |
=pod |
|
|
filecategories() : returns list of all file categories |
=item * upfile_record_sep() |
|
|
=item * |
Separate uploaded file into records |
|
returns array of records, |
|
needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'} |
|
|
filecategorytypes() : returns list of file types belonging to a given file |
=cut |
category |
|
|
|
=item * |
sub upfile_record_sep { |
|
if ($ENV{'form.upfiletype'} eq 'xml') { |
|
} else { |
|
return split(/\n/,$ENV{'form.upfile'}); |
|
} |
|
} |
|
|
fileembstyle() : returns embedding style for a specified file type |
=pod |
|
|
=item * |
=item * record_sep($record) |
|
|
filedescription() : returns description for a specified file type |
Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'} |
|
|
=item * |
=cut |
|
|
filedescriptionex() : returns description for a specified file type with |
sub record_sep { |
extra formatting |
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,defaultcol) |
|
|
|
=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,$defaultcol)=@{ $_ }; |
|
$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="'.$_.'"'. |
|
($_ eq $defaultcol ? ' selected ' : ''). |
|
'>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,$defaultcol)=@{ $_ }; |
|
$r->print('<option value="'.$value.'"'. |
|
($i eq $defaultcol ? ' selected ':'').'>'. |
|
$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 |
|
|
|
=back |
|
|
|
=head1 cgi-bin script and graphing routines |
|
|
|
=over 4 |
|
|
|
=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+1)%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'. |
|
|
=item * |
Inputs: |
|
|
get_previous_attempt() : return string with previous attempt on problem |
=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 $labels: array ref holding the labels to use on the x-axis for the bars. |
|
|
|
=item @Values: An array of array references. Each array reference holds data |
|
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,$labels,@Values)=@_; |
|
# |
|
if (! defined($colors)) { |
|
$colors = ['#33ff00', |
|
'#0033cc', '#990000', '#aaaa66', '#663399', '#ff9933', |
|
'#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66', |
|
]; |
|
} |
|
my $extra_settings = {}; |
|
if (ref($Values[-1]) eq 'HASH') { |
|
$extra_settings = pop(@Values); |
|
} |
|
# |
|
my $identifier = &get_cgi_id(); |
|
my $id = 'cgi.'.$identifier; |
|
if (! @Values || ref($Values[0]) ne 'ARRAY') { |
|
return ''; |
|
} |
|
# |
|
my @Labels; |
|
if (defined($labels)) { |
|
@Labels = @$labels; |
|
} else { |
|
for (my $i=0;$i<@{$Values[0]};$i++) { |
|
push (@Labels,$i+1); |
|
} |
|
} |
|
# |
|
my $NumBars = scalar(@{$Values[0]}); |
|
if ($NumBars < scalar(@Labels)) { $NumBars = scalar(@Labels); } |
|
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 < 3) { |
|
$width = 120+$NumBars*32; |
|
$xskip = 1; |
|
$bar_width = 30; |
|
} elsif ($NumBars < 5) { |
|
$width = 120+$NumBars*20; |
|
$xskip = 1; |
|
$bar_width = 20; |
|
} elsif ($NumBars < 10) { |
|
$width = 120+$NumBars*15; |
|
$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; |
|
} |
|
# |
|
$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); |
|
# |
|
# Deal with other parameters |
|
while (my ($key,$value) = each(%$extra_settings)) { |
|
$ValuesHash{$id.'.'.$key} = $value; |
|
} |
|
# |
|
&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 separate 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 * |
=item $Ydata2: The second data set |
|
|
get_student_view() : show a snapshot of what student was looking at |
=item $Min2: The minimum value of the right Y-axis |
|
|
=item * |
=item $Max2: The maximum value of the left Y-axis |
|
|
get_student_answers() : show a snapshot of how student was answering problem |
=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. |
|
|
=item * |
=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" />'; |
|
} |
|
|
|
############################################################ |
|
############################################################ |
|
|
get_unprocessed_cgi() : get unparsed CGI parameters |
=pod |
|
|
=item * |
=back |
|
|
cacheheader() : returns cache-controlling header code |
=head1 Statistics helper routines? |
|
|
=item * |
Bad place for them but what the hell. |
|
|
|
=over 4 |
|
|
nocache() : specifies header code to not have cache |
=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 |
|
|
=back |
=back |
|
|
=cut |
=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 |
|
|
|
=head1 Course Environment Routines |
|
|
|
=over 4 |
|
|
|
=item &restore_course_settings |
|
|
|
=item &store_course_settings |
|
|
|
Restores/Store indicated form parameters from the course environment. |
|
Will not overwrite existing values of the form parameters. |
|
|
|
Inputs: |
|
a scalar describing the data (e.g. 'chart', 'problem_analysis') |
|
|
|
a hash ref describing the data to be stored. For example: |
|
|
|
%Save_Parameters = ('Status' => 'scalar', |
|
'chartoutputmode' => 'scalar', |
|
'chartoutputdata' => 'scalar', |
|
'Section' => 'array', |
|
'StudentData' => 'array', |
|
'Maps' => 'array'); |
|
|
|
Returns: both routines return nothing |
|
|
|
=cut |
|
|
|
####################################################### |
|
####################################################### |
|
sub store_course_settings { |
|
# save to the environment |
|
# appenv the same items, just to be safe |
|
my $courseid = $ENV{'request.course.id'}; |
|
my $coursedom = $ENV{'course.'.$courseid.'.domain'}; |
|
my ($prefix,$Settings) = @_; |
|
my %SaveHash; |
|
my %AppHash; |
|
while (my ($setting,$type) = each(%$Settings)) { |
|
my $basename = 'internal.'.$prefix.'.'.$setting; |
|
my $envname = 'course.'.$courseid.'.'.$basename; |
|
if (exists($ENV{'form.'.$setting})) { |
|
# Save this value away |
|
if ($type eq 'scalar' && |
|
(! exists($ENV{$envname}) || |
|
$ENV{$envname} ne $ENV{'form.'.$setting})) { |
|
$SaveHash{$basename} = $ENV{'form.'.$setting}; |
|
$AppHash{$envname} = $ENV{'form.'.$setting}; |
|
} elsif ($type eq 'array') { |
|
my $stored_form; |
|
if (ref($ENV{'form.'.$setting})) { |
|
$stored_form = join(',', |
|
map { |
|
&Apache::lonnet::escape($_); |
|
} sort(@{$ENV{'form.'.$setting}})); |
|
} else { |
|
$stored_form = |
|
&Apache::lonnet::escape($ENV{'form.'.$setting}); |
|
} |
|
# Determine if the array contents are the same. |
|
if ($stored_form ne $ENV{$envname}) { |
|
$SaveHash{$basename} = $stored_form; |
|
$AppHash{$envname} = $stored_form; |
|
} |
|
} |
|
} |
|
} |
|
my $put_result = &Apache::lonnet::put('environment',\%SaveHash, |
|
$coursedom, |
|
$ENV{'course.'.$courseid.'.num'}); |
|
if ($put_result !~ /^(ok|delayed)/) { |
|
&Apache::lonnet::logthis('unable to save form parameters, '. |
|
'got error:'.$put_result); |
|
} |
|
# Make sure these settings stick around in this session, too |
|
&Apache::lonnet::appenv(%AppHash); |
|
return; |
|
} |
|
|
|
sub restore_course_settings { |
|
my $courseid = $ENV{'request.course.id'}; |
|
my ($prefix,$Settings) = @_; |
|
while (my ($setting,$type) = each(%$Settings)) { |
|
next if (exists($ENV{'form.'.$setting})); |
|
my $envname = 'course.'.$courseid.'.internal.'.$prefix. |
|
'.'.$setting; |
|
if (exists($ENV{$envname})) { |
|
if ($type eq 'scalar') { |
|
$ENV{'form.'.$setting} = $ENV{$envname}; |
|
} elsif ($type eq 'array') { |
|
$ENV{'form.'.$setting} = [ |
|
map { |
|
&Apache::lonnet::unescape($_); |
|
} split(',',$ENV{$envname}) |
|
]; |
|
} |
|
} |
|
} |
|
} |
|
|
|
############################################################ |
|
############################################################ |
|
|
|
sub propath { |
|
my ($udom,$uname)=@_; |
|
$udom=~s/\W//g; |
|
$uname=~s/\W//g; |
|
my $subdir=$uname.'__'; |
|
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
|
my $proname="$Apache::lonnet::perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; |
|
return $proname; |
|
} |
|
|
|
sub icon { |
|
my ($file)=@_; |
|
my $curfext = (split(/\./,$file))[-1]; |
|
my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif'; |
|
my $embstyle = &Apache::loncommon::fileembstyle($curfext); |
|
if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) { |
|
if (-e $Apache::lonnet::perlvar{'lonDocRoot'}.'/'. |
|
$Apache::lonnet::perlvar{'lonIconsURL'}.'/'. |
|
$curfext.".gif") { |
|
$iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'. |
|
$curfext.".gif"; |
|
} |
|
} |
|
return $iconname; |
|
} |
|
|
|
sub lonhttpdurl { |
|
my ($url)=@_; |
|
my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'}; |
|
if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; } |
|
return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url; |
|
} |
|
|
|
sub connection_aborted { |
|
my ($r)=@_; |
|
$r->print(" ");$r->rflush(); |
|
my $c = $r->connection; |
|
return $c->aborted(); |
|
} |
|
|
|
# Escapes strings that may have embedded 's that will be put into |
|
# strings as 'strings'. |
|
sub escape_single { |
|
my ($input) = @_; |
|
$input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)> |
|
$input =~ s/\'/\\\'/g; # Esacpe the 's.... |
|
return $input; |
|
} |
|
|
|
# Same as escape_single, but escape's "'s This |
|
# can be used for "strings" |
|
sub escape_double { |
|
my ($input) = @_; |
|
$input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)> |
|
$input =~ s/\"/\\\"/g; # Esacpe the "s.... |
|
return $input; |
|
} |
|
|
|
# Escapes the last element of a full URL. |
|
sub escape_url { |
|
my ($url) = @_; |
|
my @urlslices = split(/\//, $url); |
|
my $lastitem = &Apache::lonnet::escape(pop(@urlslices)); |
|
return join('/',@urlslices).'/'.$lastitem; |
|
} |
|
=pod |
|
|
|
=back |
|
|
|
=cut |
|
|
|
1; |
|
__END__; |
|
|