version 1.4, 2001/07/30 22:24:34
|
version 1.385, 2006/06/22 17:34:40
|
Line 1
|
Line 1
|
# The LearningOnline Network |
# The LearningOnline Network with CAPA |
# a pile of common routines |
# a pile of common routines |
# 2/13 Guy Albertelli |
# |
|
# $Id$ |
|
# |
|
# Copyright Michigan State University Board of Trustees |
|
# |
|
# This file is part of the LearningOnline Network with CAPA (LON-CAPA). |
|
# |
|
# LON-CAPA is free software; you can redistribute it and/or modify |
|
# it under the terms of the GNU General Public License as published by |
|
# the Free Software Foundation; either version 2 of the License, or |
|
# (at your option) any later version. |
|
# |
|
# LON-CAPA is distributed in the hope that it will be useful, |
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
# GNU General Public License for more details. |
|
# |
|
# You should have received a copy of the GNU General Public License |
|
# along with LON-CAPA; if not, write to the Free Software |
|
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
|
# |
|
# /home/httpd/html/adm/gpl.txt |
|
# |
|
# http://www.lon-capa.org/ |
|
# |
|
|
# Makes a table out of the previous attempts |
# Makes a table out of the previous attempts |
# Inputs result_from_symbread, user, domain, course_id |
# Inputs result_from_symbread, user, domain, course_id |
|
# Reads in non-network-related .tab files |
|
|
|
# POD header: |
|
|
|
=pod |
|
|
|
=head1 NAME |
|
|
|
Apache::loncommon - pile of common routines |
|
|
|
=head1 SYNOPSIS |
|
|
|
Common routines for manipulating connections, student answers, |
|
domains, common Javascript fragments, etc. |
|
|
|
=head1 OVERVIEW |
|
|
|
A collection of commonly used subroutines that don't have a natural |
|
home anywhere else. This collection helps remove |
|
redundancy from other modules and increase efficiency of memory usage. |
|
|
|
=cut |
|
|
|
# End of POD header |
package Apache::loncommon; |
package Apache::loncommon; |
|
|
use strict; |
use strict; |
use Apache::Constants qw(:common); |
use Apache::lonnet; |
use Apache::lonmsg(); |
use GDBM_File; |
|
use POSIX qw(strftime mktime); |
|
use Apache::lonmenu(); |
|
use Apache::lonlocal; |
|
use HTML::Entities; |
|
use Apache::lonhtmlcommon(); |
|
use Apache::loncoursedata(); |
|
use Apache::lontexconvert(); |
|
use LONCAPA; |
|
|
|
my $readit; |
|
|
|
## |
|
## Global Variables |
|
## |
|
|
|
# ----------------------------------------------- Filetypes/Languages/Copyright |
|
my %language; |
|
my %supported_language; |
|
my %cprtag; |
|
my %scprtag; |
|
my %fe; my %fd; my %fm; |
|
my %category_extensions; |
|
|
|
# ---------------------------------------------- Designs |
|
|
|
my %designhash; |
|
|
|
# ---------------------------------------------- Thesaurus variables |
|
# |
|
# %Keywords: |
|
# A hash used by &keyword to determine if a word is considered a keyword. |
|
# $thesaurus_db_file |
|
# Scalar containing the full path to the thesaurus database. |
|
|
|
my %Keywords; |
|
my $thesaurus_db_file; |
|
|
|
# |
|
# Initialize values from language.tab, copyright.tab, filetypes.tab, |
|
# thesaurus.tab, and filecategories.tab. |
|
# |
|
BEGIN { |
|
# Variable initialization |
|
$thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db"; |
|
# |
|
unless ($readit) { |
|
# ------------------------------------------------------------------- languages |
|
{ |
|
my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}. |
|
'/language.tab'; |
|
if ( open(my $fh,"<$langtabfile") ) { |
|
while (my $line = <$fh>) { |
|
next if ($line=~/^\#/); |
|
chomp($line); |
|
my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$line)); |
|
$language{$key}=$val.' - '.$enc; |
|
if ($sup) { |
|
$supported_language{$key}=$sup; |
|
} |
|
} |
|
close($fh); |
|
} |
|
} |
|
# ------------------------------------------------------------------ copyrights |
|
{ |
|
my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. |
|
'/copyright.tab'; |
|
if ( open (my $fh,"<$copyrightfile") ) { |
|
while (my $line = <$fh>) { |
|
next if ($line=~/^\#/); |
|
chomp($line); |
|
my ($key,$val)=(split(/\s+/,$line,2)); |
|
$cprtag{$key}=$val; |
|
} |
|
close($fh); |
|
} |
|
} |
|
# ----------------------------------------------------------- source copyrights |
|
{ |
|
my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. |
|
'/source_copyright.tab'; |
|
if ( open (my $fh,"<$sourcecopyrightfile") ) { |
|
while (my $line = <$fh>) { |
|
next if ($line =~ /^\#/); |
|
chomp($line); |
|
my ($key,$val)=(split(/\s+/,$line,2)); |
|
$scprtag{$key}=$val; |
|
} |
|
close($fh); |
|
} |
|
} |
|
|
|
# -------------------------------------------------------------- domain designs |
|
|
|
my $filename; |
|
my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; |
|
opendir(DIR,$designdir); |
|
while ($filename=readdir(DIR)) { |
|
if ($filename!~/\.tab$/) { next; } |
|
my ($domain)=($filename=~/^(\w+)\./); |
|
{ |
|
my $designfile = $designdir.'/'.$filename; |
|
if ( open (my $fh,"<$designfile") ) { |
|
while (my $line = <$fh>) { |
|
next if ($line =~ /^\#/); |
|
chomp($line); |
|
my ($key,$val)=(split(/\=/,$line)); |
|
if ($val) { $designhash{$domain.'.'.$key}=$val; } |
|
} |
|
close($fh); |
|
} |
|
} |
|
|
|
} |
|
closedir(DIR); |
|
|
|
|
|
# ------------------------------------------------------------- file categories |
|
{ |
|
my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}. |
|
'/filecategories.tab'; |
|
if ( open (my $fh,"<$categoryfile") ) { |
|
while (my $line = <$fh>) { |
|
next if ($line =~ /^\#/); |
|
chomp($line); |
|
my ($extension,$category)=(split(/\s+/,$line,2)); |
|
push @{$category_extensions{lc($category)}},$extension; |
|
} |
|
close($fh); |
|
} |
|
|
|
} |
|
# ------------------------------------------------------------------ file types |
|
{ |
|
my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}. |
|
'/filetypes.tab'; |
|
if ( open (my $fh,"<$typesfile") ) { |
|
while (my $line = <$fh>) { |
|
next if ($line =~ /^\#/); |
|
chomp($line); |
|
my ($ending,$emb,$mime,$descr)=split(/\s+/,$line,4); |
|
if ($descr ne '') { |
|
$fe{$ending}=lc($emb); |
|
$fd{$ending}=$descr; |
|
if ($mime ne 'unk') { $fm{$ending}=$mime; } |
|
} |
|
} |
|
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(); |
|
} |
|
var editsearcher; |
|
function opensearcher(formname,elementname,titleelement) { |
|
var url = '/adm/searchcat?'; |
|
if (editsearcher == null) { |
|
url += 'launch=1&'; |
|
} |
|
url += 'catalogmode=interactive&'; |
|
url += 'mode=$mode&'; |
|
url += 'form=' + formname + '&'; |
|
if (titleelement != null) { |
|
url += 'titleelement=' + titleelement + '&'; |
|
} 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'}) |
|
|| &Apache::lonnet::allowed('srm',$env{'request.course.id'}. |
|
'/'.$env{'request.course.sec'}) |
|
)) |
|
|| ($env{'request.role'}=~/^(au|dc|su)/) |
|
) { return ''; } |
|
return (<<'ENDSTDBRW'); |
|
<script type="text/javascript" language="Javascript" > |
|
var stdeditbrowser; |
|
function openstdbrowser(formname,uname,udom,roleflag) { |
|
var url = '/adm/pickstudent?'; |
|
var filter; |
|
eval('filter=document.'+formname+'.'+uname+'.value;'); |
|
if (filter != null) { |
|
if (filter != '') { |
|
url += 'filter='+filter+'&'; |
|
} |
|
} |
|
url += 'form=' + formname + '&unameelement='+uname+ |
|
'&udomelement='+udom; |
|
if (roleflag) { url+="&roles=1"; } |
|
var title = 'Student_Browser'; |
|
var options = 'scrollbars=1,resizable=1,menubar=0'; |
|
options += ',width=700,height=600'; |
|
stdeditbrowser = open(url,title,options,'1'); |
|
stdeditbrowser.focus(); |
|
} |
|
</script> |
|
ENDSTDBRW |
|
} |
|
|
|
sub selectstudent_link { |
|
my ($form,$unameele,$udomele)=@_; |
|
if ($env{'request.course.id'}) { |
|
if (!&Apache::lonnet::allowed('srm',$env{'request.course.id'}) |
|
&& !&Apache::lonnet::allowed('srm',$env{'request.course.id'}. |
|
'/'.$env{'request.course.sec'})) { |
|
return ''; |
|
} |
|
return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele. |
|
'","'.$udomele.'");'."'>".&mt('Select User')."</a>"; |
|
} |
|
if ($env{'request.role'}=~/^(au|dc|su)/) { |
|
return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele. |
|
'","'.$udomele.'",1);'."'>".&mt('Select User')."</a>"; |
|
} |
|
return ''; |
|
} |
|
|
|
sub coursebrowser_javascript { |
|
my ($domainfilter)=@_; |
|
my $crs_or_grp_alert = &mt('Please select the type of LON-CAPA entity - Course or Group - for which you wish to add/modify a user role'); |
|
return (<<ENDSTDBRW); |
|
<script type="text/javascript" language="Javascript" > |
|
var stdeditbrowser; |
|
function opencrsbrowser(formname,uname,udom,desc,extra_element,multflag,crstype) { |
|
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 !=null && extra_element != '' && formname == 'rolechoice') { |
|
url += '&roleelement='+extra_element; |
|
if (domainfilter == null || domainfilter == '') { |
|
url += '&domainfilter='+extra_element; |
|
} |
|
} |
|
if (multflag !=null && multflag != '') { |
|
url += '&multiple='+multflag; |
|
} |
|
if (crstype == 'Course/Group') { |
|
if (formname == 'cu') { |
|
crstype = document.cu.crstype.options[document.cu.crstype.selectedIndex].value; |
|
if (crstype == "") { |
|
alert("$crs_or_grp_alert"); |
|
return; |
|
} |
|
} |
|
} |
|
if (crstype !=null && crstype != '') { |
|
url += '&type='+crstype; |
|
} |
|
var title = 'Course_Browser'; |
|
var options = 'scrollbars=1,resizable=1,menubar=0'; |
|
options += ',width=700,height=600'; |
|
stdeditbrowser = open(url,title,options,'1'); |
|
stdeditbrowser.focus(); |
|
} |
|
</script> |
|
ENDSTDBRW |
|
} |
|
|
|
sub selectcourse_link { |
|
my ($form,$unameele,$udomele,$desc,$extra_element,$multflag,$selecttype)=@_; |
|
return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele. |
|
'","'.$udomele.'","'.$desc.'","'.$extra_element.'","'.$multflag.'","'.$selecttype.'");'."'>".&mt('Select [_1]',$selecttype)."</a>"; |
|
} |
|
|
|
sub check_uncheck_jscript { |
|
my $jscript = <<"ENDSCRT"; |
|
function checkAll(field) { |
|
if (field.length > 0) { |
|
for (i = 0; i < field.length; i++) { |
|
field[i].checked = true ; |
|
} |
|
} else { |
|
field.checked = true |
|
} |
|
} |
|
|
|
function uncheckAll(field) { |
|
if (field.length > 0) { |
|
for (i = 0; i < field.length; i++) { |
|
field[i].checked = false ; |
|
} } else { |
|
field.checked = false ; |
|
} |
|
} |
|
ENDSCRT |
|
return $jscript; |
|
} |
|
|
|
|
|
=pod |
|
|
|
=item * linked_select_forms(...) |
|
|
|
linked_select_forms returns a string containing a <script></script> block |
|
and html for two <select> menus. The select menus will be linked in that |
|
changing the value of the first menu will result in new values being placed |
|
in the second menu. The values in the select menu will appear in alphabetical |
|
order. |
|
|
|
linked_select_forms takes the following ordered inputs: |
|
|
|
=over 4 |
|
|
|
=item * $formname, the name of the <form> tag |
|
|
|
=item * $middletext, the text which appears between the <select> tags |
|
|
|
=item * $firstdefault, the default value for the first menu |
|
|
|
=item * $firstselectname, the name of the first <select> tag |
|
|
|
=item * $secondselectname, the name of the second <select> tag |
|
|
|
=item * $hashref, a reference to a hash containing the data for the menus. |
|
|
|
=back |
|
|
|
Below is an example of such a hash. Only the 'text', 'default', and |
|
'select2' keys must appear as stated. keys(%menu) are the possible |
|
values for the first select menu. The text that coincides with the |
|
first menu value is given in $menu{$choice1}->{'text'}. The values |
|
and text for the second menu are given in the hash pointed to by |
|
$menu{$choice1}->{'select2'}. |
|
|
|
my %menu = ( A1 => { text =>"Choice A1" , |
|
default => "B3", |
|
select2 => { |
|
B1 => "Choice B1", |
|
B2 => "Choice B2", |
|
B3 => "Choice B3", |
|
B4 => "Choice B4" |
|
} |
|
}, |
|
A2 => { text =>"Choice A2" , |
|
default => "C2", |
|
select2 => { |
|
C1 => "Choice C1", |
|
C2 => "Choice C2", |
|
C3 => "Choice C3" |
|
} |
|
}, |
|
A3 => { text =>"Choice A3" , |
|
default => "D6", |
|
select2 => { |
|
D1 => "Choice D1", |
|
D2 => "Choice D2", |
|
D3 => "Choice D3", |
|
D4 => "Choice D4", |
|
D5 => "Choice D5", |
|
D6 => "Choice D6", |
|
D7 => "Choice D7" |
|
} |
|
} |
|
); |
|
|
|
=cut |
|
|
|
sub linked_select_forms { |
|
my ($formname, |
|
$middletext, |
|
$firstdefault, |
|
$firstselectname, |
|
$secondselectname, |
|
$hashref |
|
) = @_; |
|
my $second = "document.$formname.$secondselectname"; |
|
my $first = "document.$formname.$firstselectname"; |
|
# output the javascript to do the changing |
|
my $result = ''; |
|
$result.="<script 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=\"selected\" " 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=\"selected\" " 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 my $datum (\$color,\$function,\$topic,\$component_help,\$faq, |
|
\$bug,\$origurl) { |
|
$$datum = &escape($$datum); |
|
} |
|
if (!$stayOnPage) { |
|
$link = "javascript:helpMenu('open')"; |
|
} else { |
|
$link = "javascript:helpMenu('display')"; |
|
} |
|
my $banner_link = "/adm/helpmenu?page=banner&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp&stayonpage=$stayOnPage"; |
|
my $details_link = "/adm/helpmenu?page=body&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp"; |
|
my $template; |
|
if ($text ne "") { |
|
$template .= |
|
"<table bgcolor='#CC3300' cellspacing='1' cellpadding='1' border='0'><tr>". |
|
"<td bgcolor='#CC6600'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>"; |
|
} |
|
my $nothing=&Apache::lonhtmlcommon::javascript_nothing(); |
|
my $helpicon=&lonhttpdurl("/adm/lonIcons/helpgateway.gif"); |
|
my $start_page = |
|
&Apache::loncommon::start_page('Help Menu', undef, |
|
{'frameset' => 1, |
|
'js_ready' => 1, |
|
'add_entries' => { |
|
'border' => '0', |
|
'rows' => "105,*",},}); |
|
my $end_page = |
|
&Apache::loncommon::end_page({'frameset' => 1, |
|
'js_ready' => 1,}); |
|
|
|
$template .= <<"ENDTEMPLATE"; |
|
<script type="text/javascript"> |
|
// <!-- BEGIN LON-CAPA Internal |
|
// <![CDATA[ |
|
function helpMenu(target) { |
|
var caller = this; |
|
if (target == 'open') { |
|
var newWindow = null; |
|
try { |
|
newWindow = window.open($nothing,"helpmenu","HEIGHT=$height,WIDTH=$width,resizable=yes,scrollbars=yes" ) |
|
} |
|
catch(error) { |
|
writeHelp(caller); |
|
return; |
|
} |
|
if (newWindow) { |
|
caller = newWindow; |
|
} |
|
} |
|
writeHelp(caller); |
|
return; |
|
} |
|
function writeHelp(caller) { |
|
caller.document.writeln('$start_page<frame name="bannerframe" src="$banner_link" /><frame name="bodyframe" src="$details_link" /> $end_page') |
|
caller.document.close() |
|
caller.focus() |
|
} |
|
// ]]> |
|
// END LON-CAPA Internal --> |
|
</script> |
|
<a href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help Menu)" /></a> |
|
ENDTEMPLATE |
|
if ($component_help) { |
|
if (!$text) { |
|
$template=&help_open_topic($component_help,undef,$stayOnPage, |
|
$width,$height).' '.$template; |
|
} else { |
|
my $help_text; |
|
$help_text=&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='. |
|
&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 * change_content_javascript(): |
|
|
|
This and the next function allow you to create small sections of an |
|
otherwise static HTML page that you can update on the fly with |
|
Javascript, even in Netscape 4. |
|
|
|
The Javascript fragment returned by this function (no E<lt>scriptE<gt> tag) |
|
must be written to the HTML page once. It will prove the Javascript |
|
function "change(name, content)". Calling the change function with the |
|
name of the section |
|
you want to update, matching the name passed to C<changable_area>, and |
|
the new content you want to put in there, will put the content into |
|
that area. |
|
|
|
B<Note>: Netscape 4 only reserves enough space for the changable area |
|
to contain room for the original contents. You need to "make space" |
|
for whatever changes you wish to make, and be B<sure> to check your |
|
code in Netscape 4. This feature in Netscape 4 is B<not> powerful; |
|
it's adequate for updating a one-line status display, but little more. |
|
This script will set the space to 100% width, so you only need to |
|
worry about height in Netscape 4. |
|
|
|
Modern browsers are much less limiting, and if you can commit to the |
|
user not using Netscape 4, this feature may be used freely with |
|
pretty much any HTML. |
|
|
|
=cut |
|
|
|
sub change_content_javascript { |
|
# If we're on Netscape 4, we need to use Layer-based code |
|
if ($env{'browser.type'} eq 'netscape' && |
|
$env{'browser.version'} =~ /^4\./) { |
|
return (<<NETSCAPE4); |
|
function change(name, content) { |
|
doc = document.layers[name+"___escape"].layers[0].document; |
|
doc.open(); |
|
doc.write(content); |
|
doc.close(); |
|
} |
|
NETSCAPE4 |
|
} else { |
|
# Otherwise, we need to use semi-standards-compliant code |
|
# (technically, "innerHTML" isn't standard but the equivalent |
|
# is really scary, and every useful browser supports it |
|
return (<<DOMBASED); |
|
function change(name, content) { |
|
element = document.getElementById(name); |
|
element.innerHTML = content; |
|
} |
|
DOMBASED |
|
} |
|
} |
|
|
|
=pod |
|
|
|
=item * changable_area($name, $origContent): |
|
|
|
This provides a "changable area" that can be modified on the fly via |
|
the Javascript code provided in C<change_content_javascript>. $name is |
|
the name you will use to reference the area later; do not repeat the |
|
same name on a given HTML page more then once. $origContent is what |
|
the area will originally contain, which can be left blank. |
|
|
|
=cut |
|
|
|
sub changable_area { |
|
my ($name, $origContent) = @_; |
|
|
|
if ($env{'browser.type'} eq 'netscape' && |
|
$env{'browser.version'} =~ /^4\./) { |
|
# If this is netscape 4, we need to use the Layer tag |
|
return "<ilayer width='100%' id='${name}___escape' overflow='none'><layer width='100%' id='$name' overflow='none'>$origContent</layer></ilayer>"; |
|
} else { |
|
return "<span id='$name'>$origContent</span>"; |
|
} |
|
} |
|
|
|
=pod |
|
|
|
=back |
|
|
|
=head1 Excel and CSV file utility routines |
|
|
|
=over 4 |
|
|
|
=cut |
|
|
|
############################################################### |
|
############################################################### |
|
|
|
=pod |
|
|
|
=item * csv_translate($text) |
|
|
|
Translate $text to allow it to be output as a 'comma separated values' |
|
format. |
|
|
|
=cut |
|
|
|
############################################################### |
|
############################################################### |
|
sub csv_translate { |
|
my $text = shift; |
|
$text =~ s/\"/\"\"/g; |
|
$text =~ s/\n/ /g; |
|
return $text; |
|
} |
|
|
|
############################################################### |
|
############################################################### |
|
|
|
=pod |
|
|
|
=item * define_excel_formats |
|
|
|
Define some commonly used Excel cell formats. |
|
|
|
Currently supported formats: |
|
|
|
=over 4 |
|
|
|
=item header |
|
|
|
=item bold |
|
|
|
=item h1 |
|
|
|
=item h2 |
|
|
|
=item h3 |
|
|
|
=item h4 |
|
|
|
=item i |
|
|
|
=item date |
|
|
|
=back |
|
|
|
Inputs: $workbook |
|
|
|
Returns: $format, a hash reference. |
|
|
|
=cut |
|
|
|
############################################################### |
|
############################################################### |
|
sub define_excel_formats { |
|
my ($workbook) = @_; |
|
my $format; |
|
$format->{'header'} = $workbook->add_format(bold => 1, |
|
bottom => 1, |
|
align => 'center'); |
|
$format->{'bold'} = $workbook->add_format(bold=>1); |
|
$format->{'h1'} = $workbook->add_format(bold=>1, size=>18); |
|
$format->{'h2'} = $workbook->add_format(bold=>1, size=>16); |
|
$format->{'h3'} = $workbook->add_format(bold=>1, size=>14); |
|
$format->{'h4'} = $workbook->add_format(bold=>1, size=>12); |
|
$format->{'i'} = $workbook->add_format(italic=>1); |
|
$format->{'date'} = $workbook->add_format(num_format=> |
|
'mm/dd/yyyy hh:mm:ss'); |
|
return $format; |
|
} |
|
|
|
############################################################### |
|
############################################################### |
|
|
|
=pod |
|
|
|
=item * create_workbook |
|
|
|
Create an Excel worksheet. If it fails, output message on the |
|
request object and return undefs. |
|
|
|
Inputs: Apache request object |
|
|
|
Returns (undef) on failure, |
|
Excel worksheet object, scalar with filename, and formats |
|
from &Apache::loncommon::define_excel_formats on success |
|
|
|
=cut |
|
|
|
############################################################### |
|
############################################################### |
|
sub create_workbook { |
|
my ($r) = @_; |
|
# |
|
# Create the excel spreadsheet |
|
my $filename = '/prtspool/'. |
|
$env{'user.name'}.'_'.$env{'user.domain'}.'_'. |
|
time.'_'.rand(1000000000).'.xls'; |
|
my $workbook = Spreadsheet::WriteExcel->new('/home/httpd'.$filename); |
|
if (! defined($workbook)) { |
|
$r->log_error("Error creating excel spreadsheet $filename: $!"); |
|
$r->print('<p>'.&mt("Unable to create new Excel file. ". |
|
"This error has been logged. ". |
|
"Please alert your LON-CAPA administrator"). |
|
'</p>'); |
|
return (undef); |
|
} |
|
# |
|
$workbook->set_tempdir('/home/httpd/perl/tmp'); |
|
# |
|
my $format = &Apache::loncommon::define_excel_formats($workbook); |
|
return ($workbook,$filename,$format); |
|
} |
|
|
|
############################################################### |
|
############################################################### |
|
|
|
=pod |
|
|
|
=item * create_text_file |
|
|
|
Create a file to write to and eventually make available to the usre. |
|
If file creation fails, outputs an error message on the request object and |
|
return undefs. |
|
|
|
Inputs: Apache request object, and file suffix |
|
|
|
Returns (undef) on failure, |
|
Filehandle and filename on success. |
|
|
|
=cut |
|
|
|
############################################################### |
|
############################################################### |
|
sub create_text_file { |
|
my ($r,$suffix) = @_; |
|
if (! defined($suffix)) { $suffix = 'txt'; }; |
|
my $fh; |
|
my $filename = '/prtspool/'. |
|
$env{'user.name'}.'_'.$env{'user.domain'}.'_'. |
|
time.'_'.rand(1000000000).'.'.$suffix; |
|
$fh = Apache::File->new('>/home/httpd'.$filename); |
|
if (! defined($fh)) { |
|
$r->log_error("Couldn't open $filename for output $!"); |
|
$r->print("Problems occured in creating the output file. ". |
|
"This error has been logged. ". |
|
"Please alert your LON-CAPA administrator."); |
|
} |
|
return ($fh,$filename) |
|
} |
|
|
|
|
|
=pod |
|
|
|
=back |
|
|
|
=cut |
|
|
|
############################################################### |
|
## 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 my $dom (sort(values(%Apache::lonnet::hostdom))) { |
|
push(@domains,$dom) unless $seen{$dom}++; |
|
} |
|
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); |
|
} |
|
} |
|
|
|
#------------------------------------------- |
|
|
|
=pod |
|
|
|
=item * multiple_select_form($name,$value,$size,$hash,$order) |
|
|
|
Returns a string containing a <select> element int multiple mode |
|
|
|
|
|
Args: |
|
$name - name of the <select> element |
|
$value - sclara or array ref of values that should already be selected |
|
$size - number of rows long the select element is |
|
$hash - the elements should be 'option' => 'shown text' |
|
(shown text should already have been &mt()) |
|
$order - (optional) array ref of the order to show the elments in |
|
|
|
=cut |
|
|
|
#------------------------------------------- |
|
sub multiple_select_form { |
|
my ($name,$value,$size,$hash,$order)=@_; |
|
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'>"; |
|
my @order = ref($order) ? @$order |
|
: sort(keys(%$hash)); |
|
foreach my $key (@order) { |
|
$output.='<option value="'.&HTML::Entities::encode($key,'"<>&').'" '; |
|
$output.='selected="selected" ' if ($selected{$key}); |
|
$output.='>'.$hash->{$key}."</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 my $key (@keys) { |
|
$selectform.= |
|
'<option value="'.&HTML::Entities::encode($key,'"<>&').'" '. |
|
($key eq $def ? 'selected="selected" ' : ''). |
|
">".&mt($hash{$key})."</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="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 my $dom (@domains) { |
|
$selectdomain.="<option value=\"$dom\" ". |
|
($dom eq $defdom ? 'selected="selected" ' : ''). |
|
">$dom</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 my $hostid (keys(%Apache::lonnet::libserv)) { |
|
if ($Apache::lonnet::hostdom{$hostid} eq $domain) { |
|
$library_servers{$hostid} = $Apache::lonnet::hostname{$hostid}; |
|
} |
|
} |
|
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 my $hostid (sort(keys(%servers))) { |
|
$result.= |
|
'<option value="'.$hostid.'">'. |
|
$hostid.' '.$servers{$hostid}."</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 ($r)=@_; |
|
my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"}); |
|
my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"}); |
|
my $httpbrowser=$ENV{"HTTP_USER_AGENT"}; |
|
if (!$httpbrowser && $r) { $httpbrowser=$r->header_in('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'}'"; |
|
} |
|
} |
|
} |
|
} |
|
|
|
$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; |
|
} |
|
|
|
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 = '<label>'.&mt('[_1] Do not change login data', |
|
'<input type="radio" name="login" value="nochange" '. |
|
'checked="checked" onclick="'. |
|
"javascript:changed_radio('nochange',$in{'formname'});".'" />'). |
|
'</label>'; |
|
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 [_5]', |
|
'<label><input type="radio" name="login" value="krb" '. |
|
'onclick="'.$jscall.'" onchange="'.$jscall.'"'.$krbcheck.' />', |
|
'</label><input type="text" size="10" name="krbarg" '. |
|
'value="'.$krbarg.'" '. |
|
'onchange="'.$jscall.'" />', |
|
'<label><input type="radio" name="krbver" value="4" '.$check4.' />', |
|
'</label><label><input type="radio" name="krbver" value="5" '.$check5.' />', |
|
'</label>'); |
|
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])', |
|
'<label><input type="radio" name="login" value="int" '.$intcheck. |
|
' onchange="'.$jscall.'" onclick="'.$jscall.'" />', |
|
'</label><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]', |
|
'<label><input type="radio" name="login" value="loc" '.$loccheck. |
|
' onchange="'.$jscall.'" onclick="'.$jscall.'" />', |
|
'</label><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])', |
|
'<label><input type="radio" name="login" value="fsys" '. |
|
'onchange="'.$jscall.'" onclick="'.$jscall.'" />', |
|
'</label><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 my $value ('total.count','average.count') { |
|
delete($Keywords{$value}) if (exists($Keywords{$value})); |
|
} |
|
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})) { |
|
# The first element is the number of times |
|
# the word appears. We do not need it now. |
|
(undef,@Words) = (split(/:/,$thesaurus_db{$keyword})); |
|
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=&getnames($uname,$udom); |
|
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=&getnames($uname,$udom); |
|
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; |
|
} |
|
|
|
sub getnames { |
|
my ($uname,$udom)=@_; |
|
my $id=$uname.':'.$udom; |
|
my ($names,$cached)=&Apache::lonnet::is_cached_new('namescache',$id); |
|
if ($cached) { |
|
return %{$names}; |
|
} else { |
|
my %loadnames=&Apache::lonnet::get('environment', |
|
['firstname','middlename','lastname','generation','nickname'], |
|
$udom,$uname); |
|
&Apache::lonnet::do_cache_new('namescache',$id,\%loadnames); |
|
return %loadnames; |
|
} |
|
} |
|
|
|
# ------------------------------------------------------------------ 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,$subject,$text)=@_; |
|
return |
|
'<a href="/adm/email?compose=individual&'. |
|
'recname='.$username.'&recdom='.$domain. |
|
'&subject='.&escape($subject).'&text='.&escape($text).'" '. |
|
'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,$start) = @_; |
|
my $link ="/adm/trackstudent?"; |
|
my $title = 'View recent activity'; |
|
if (defined($sname) && $sname !~ /^\s*$/ && |
|
defined($sdom) && $sdom !~ /^\s*$/) { |
|
$link .= "selected_student=$sname:$sdom"; |
|
$title .= ' of this student'; |
|
} |
|
if (defined($target) && $target !~ /^\s*$/) { |
|
$target = qq{target="$target"}; |
|
} else { |
|
$target = ''; |
|
} |
|
if ($start) { $link.='&start='.$start; } |
|
return qq{<a href="$link" title="$title" $target>$linktext</a>}; |
|
} |
|
|
|
=pod |
|
|
|
=back |
|
|
|
=head1 Access .tab File Data |
|
|
|
=over 4 |
|
|
|
=item * languageids() |
|
|
|
returns list of all language ids |
|
|
|
=cut |
|
|
|
sub languageids { |
|
return sort(keys(%language)); |
|
} |
|
|
|
=pod |
|
|
|
=item * languagedescription() |
|
|
|
returns description of a specified language id |
|
|
|
=cut |
|
|
|
sub languagedescription { |
|
my $code=shift; |
|
return ($supported_language{$code}?'* ':''). |
|
$language{$code}. |
|
($supported_language{$code}?' ('.&mt('interface available').')':''); |
|
} |
|
|
|
sub plainlanguagedescription { |
|
my $code=shift; |
|
return $language{$code}; |
|
} |
|
|
|
sub supportedlanguagecode { |
|
my $code=shift; |
|
return $supported_language{$code}; |
|
} |
|
|
|
=pod |
|
|
|
=item * copyrightids() |
|
|
|
returns list of all copyrights |
|
|
|
=cut |
|
|
|
sub copyrightids { |
|
return sort(keys(%cprtag)); |
|
} |
|
|
|
=pod |
|
|
|
=item * copyrightdescription() |
|
|
|
returns description of a specified copyright id |
|
|
|
=cut |
|
|
|
sub copyrightdescription { |
|
return &mt($cprtag{shift(@_)}); |
|
} |
|
|
|
=pod |
|
|
|
=item * source_copyrightids() |
|
|
|
returns list of all source copyrights |
|
|
|
=cut |
|
|
|
sub source_copyrightids { |
|
return sort(keys(%scprtag)); |
|
} |
|
|
|
=pod |
|
|
|
=item * source_copyrightdescription() |
|
|
|
returns description of a specified source copyright id |
|
|
|
=cut |
|
|
|
sub source_copyrightdescription { |
|
return &mt($scprtag{shift(@_)}); |
|
} |
|
|
|
=pod |
|
|
|
=item * filecategories() |
|
|
|
returns list of all file categories |
|
|
|
=cut |
|
|
|
sub filecategories { |
|
return sort(keys(%category_extensions)); |
|
} |
|
|
|
=pod |
|
|
|
=item * filecategorytypes() |
|
|
|
returns list of file types belonging to a given file |
|
category |
|
|
|
=cut |
|
|
|
sub filecategorytypes { |
|
my ($cat) = @_; |
|
return @{$category_extensions{lc($cat)}}; |
|
} |
|
|
|
=pod |
|
|
|
=item * fileembstyle() |
|
|
|
returns embedding style for a specified file type |
|
|
|
=cut |
|
|
|
sub fileembstyle { |
|
return $fe{lc(shift(@_))}; |
|
} |
|
|
|
sub filemimetype { |
|
return $fm{lc(shift(@_))}; |
|
} |
|
|
|
|
|
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 { |
|
my $file_description = $fd{lc(shift())}; |
|
$file_description =~ s:([\[\]]):~$1:g; |
|
return &mt($file_description); |
|
} |
|
|
|
=pod |
|
|
|
=item * filedescriptionex() |
|
|
|
returns description for a specified file type with |
|
extra formatting |
|
|
|
=cut |
|
|
|
sub filedescriptionex { |
|
my $ex=shift; |
|
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 my $lang (&preferred_languages()) { |
|
$languages{$lang}=1; |
|
} |
|
&get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']); |
|
if ($env{'form.displaylanguage'}) { |
|
foreach my $lang (split(/\s*(\,|\;|\:)\s*/,$env{'form.displaylanguage'})) { |
|
$languages{$lang}=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 my $lang (@languages) { |
|
unless ($lang=~/\w/) { next; } |
|
push (@genlanguages,$lang); |
|
if ($lang=~/(\-|\_)/) { |
|
push(@genlanguages,(split(/(\-|\_)/,$lang))[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 21 sub get_previous_attempt {
|
Line 2379 sub get_previous_attempt {
|
my %lasthash=(); |
my %lasthash=(); |
my $version; |
my $version; |
for ($version=1;$version<=$returnhash{'version'};$version++) { |
for ($version=1;$version<=$returnhash{'version'};$version++) { |
map { |
foreach my $key (sort(split(/\:/,$returnhash{$version.':keys'}))) { |
$lasthash{$_}=$returnhash{$version.':'.$_}; |
$lasthash{$key}=$returnhash{$version.':'.$key}; |
} sort(split(/\:/,$returnhash{$version.':keys'})); |
} |
} |
} |
$prevattempts='<table border=2></tr><th>History</th>'; |
$prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">'; |
map { |
$prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>'; |
$prevattempts.='<th>'.$_.'</th>'; |
foreach my $key (sort(keys(%lasthash))) { |
} sort(keys %lasthash); |
my ($ign,@parts) = split(/\./,$key); |
for ($version=1;$version<=$returnhash{'version'};$version++) { |
if ($#parts > 0) { |
$prevattempts.='</tr><tr><th>Attempt '.$version.'</th>'; |
my $data=$parts[-1]; |
map { |
pop(@parts); |
$prevattempts.='<td>'.$returnhash{$version.':'.$_}.'</td>'; |
$prevattempts.='<td>Part '.join('.',@parts).'<br />'.$data.' </td>'; |
} sort(keys %lasthash); |
} else { |
|
if ($#parts == 0) { |
|
$prevattempts.='<th>'.$parts[0].'</th>'; |
|
} else { |
|
$prevattempts.='<th>'.$ign.'</th>'; |
|
} |
|
} |
} |
} |
$prevattempts.='</tr><tr><th>Current</th>'; |
if ($getattempt eq '') { |
map { |
for ($version=1;$version<=$returnhash{'version'};$version++) { |
$prevattempts.='<td>'.$lasthash{$_}.'</td>'; |
$prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Transaction '.$version.'</td>'; |
} sort(keys %lasthash); |
foreach my $key (sort(keys(%lasthash))) { |
$prevattempts.='</tr></table>'; |
my $value; |
|
if ($key =~ /timestamp/) { |
|
$value=scalar(localtime($returnhash{$version.':'.$key})); |
|
} else { |
|
$value=$returnhash{$version.':'.$key}; |
|
} |
|
$prevattempts.='<td>'.&unescape($value).' </td>'; |
|
} |
|
} |
|
} |
|
$prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Current</td>'; |
|
foreach my $key (sort(keys(%lasthash))) { |
|
my $value; |
|
if ($key =~ /timestamp/) { |
|
$value=scalar(localtime($lasthash{$key})); |
|
} else { |
|
$value=$lasthash{$key}; |
|
} |
|
$value=&unescape($value); |
|
if ($key =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)} |
|
$prevattempts.='<td>'.$value.' </td>'; |
|
} |
|
$prevattempts.='</tr></table></td></tr></table>'; |
} else { |
} else { |
$prevattempts='Nothing submitted - no attempts.'; |
$prevattempts='Nothing submitted - no attempts.'; |
} |
} |
Line 48 sub get_previous_attempt {
|
Line 2434 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 my $link (@rlinks) { |
|
unless (($link=~/^http:\/\//i) || |
|
($link=~/^\//) || |
|
($link=~/^javascript:/i) || |
|
($link=~/^mailto:/i) || |
|
($link=~/^\#/)) { |
|
my $newlocation=&Apache::lonnet::hreflocation($thisdir,$link); |
|
$output=~s/(\"|\'|\=\s*)\Q$link\E(\"|\'|\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 { |
|
my ($symb,$username,$domain,$courseid,$target,$moreenv) = @_; |
|
my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb); |
|
my (%form); |
|
my @elements=('symb','courseid','domain','username'); |
|
foreach my $element (@elements) { |
|
$form{'grade_'.$element}=eval '$'.$element #' |
|
} |
|
if (defined($moreenv)) { |
|
%form=(%form,%{$moreenv}); |
|
} |
|
if (defined($target)) { $form{'grade_target'} = $target; } |
|
$feedurl=&Apache::lonnet::clutter($feedurl); |
|
my $userview=&Apache::lonnet::ssi_body($feedurl,%form); |
|
$userview=~s/\<body[^\>]*\>//gi; |
|
$userview=~s/\<\/body\>//gi; |
|
$userview=~s/\<html\>//gi; |
|
$userview=~s/\<\/html\>//gi; |
|
$userview=~s/\<head\>//gi; |
|
$userview=~s/\<\/head\>//gi; |
|
$userview=~s/action\s*\=/would_be_action\=/gi; |
|
$userview=&relative_to_absolute($feedurl,$userview); |
|
return $userview; |
|
} |
|
|
|
=pod |
|
|
|
=item * get_student_answers() |
|
|
|
show a snapshot of how student was answering problem |
|
|
|
=cut |
|
|
|
sub get_student_answers { |
|
my ($symb,$username,$domain,$courseid,%form) = @_; |
|
my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb); |
|
my (%moreenv); |
|
my @elements=('symb','courseid','domain','username'); |
|
foreach my $element (@elements) { |
|
$moreenv{'grade_'.$element}=eval '$'.$element #' |
|
} |
|
$moreenv{'grade_target'}='answer'; |
|
%moreenv=(%form,%moreenv); |
|
my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%moreenv); |
|
return $userview; |
|
} |
|
|
|
=pod |
|
|
|
=item * &submlink() |
|
|
|
Inputs: $text $uname $udom $symb $target |
|
|
|
Returns: A link to grades.pm such as to see the SUBM view of a student |
|
|
|
=cut |
|
|
|
############################################### |
|
sub submlink { |
|
my ($text,$uname,$udom,$symb,$target)=@_; |
|
if (!($uname && $udom)) { |
|
(my $cursymb, my $courseid,$udom,$uname)= |
|
&Apache::lonxml::whichuser($symb); |
|
if (!$symb) { $symb=$cursymb; } |
|
} |
|
if (!$symb) { $symb=&Apache::lonnet::symbread(); } |
|
$symb=&escape($symb); |
|
if ($target) { $target="target=\"$target\""; } |
|
return '<a href="/adm/grades?&command=submission&'. |
|
'symb='.$symb.'&student='.$uname. |
|
'&userdom='.$udom.'" '.$target.'>'.$text.'</a>'; |
|
} |
|
############################################## |
|
|
|
=pod |
|
|
|
=item * &pgrdlink() |
|
|
|
Inputs: $text $uname $udom $symb $target |
|
|
|
Returns: A link to grades.pm such as to see the PGRD view of a student |
|
|
|
=cut |
|
|
|
############################################### |
|
sub pgrdlink { |
|
my $link=&submlink(@_); |
|
$link=~s/(&command=submission)/$1&showgrading=yes/; |
|
return $link; |
|
} |
|
############################################## |
|
|
|
=pod |
|
|
|
=item * &pprmlink() |
|
|
|
Inputs: $text $uname $udom $symb $target |
|
|
|
Returns: A link to parmset.pm such as to see the PPRM view of a |
|
student and a specific resource |
|
|
|
=cut |
|
|
|
############################################### |
|
sub pprmlink { |
|
my ($text,$uname,$udom,$symb,$target)=@_; |
|
if (!($uname && $udom)) { |
|
(my $cursymb, my $courseid,$udom,$uname)= |
|
&Apache::lonxml::whichuser($symb); |
|
if (!$symb) { $symb=$cursymb; } |
|
} |
|
if (!$symb) { $symb=&Apache::lonnet::symbread(); } |
|
$symb=&escape($symb); |
|
if ($target) { $target="target=\"$target\""; } |
|
return '<a href="/adm/parmset?&command=set&'. |
|
'symb='.$symb.'&uname='.$uname. |
|
'&udom='.$udom.'" '.$target.'>'.$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 utc_string { |
|
my ($date)=@_; |
|
return strftime("%Y%m%dT%H%M%SZ",gmtime($date)); |
|
} |
|
|
|
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 ($roles) = @_; |
|
my %roles; |
|
if (ref($roles)) { %roles = map { $_ => 1 } @{$roles}; } |
|
my %courses; |
|
my $now=time; |
|
foreach my $key (keys(%env)) { |
|
if ( $key=~m{^user\.role\.(\w+)\./(\w+)/(\w+)} ) { |
|
my ($role,$domain,$id) = ($1,$2,$3); |
|
next if ($role eq 'ca' || $role eq 'aa'); |
|
next if (%roles && !exists($roles{$role})); |
|
my ($starttime,$endtime)=split(/\./,$env{$key}); |
|
my $active=1; |
|
if ($starttime) { |
|
if ($now<$starttime) { $active=0; } |
|
} |
|
if ($endtime) { |
|
if ($now>$endtime) { $active=0; } |
|
} |
|
if ($active) { $courses{$domain.'_'.$id}=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) |
|
|
|
=item * $customtitle, alternate text to use instead of $title |
|
in the title box that appears, this text |
|
is not auto translated like the $title is |
|
|
|
=item * $notopbar, if true, keep the 'what is this' info but remove the |
|
navigational links |
|
|
|
=item * $bgcolor, used to override the bgcolor on a webpage to a specific value |
|
|
|
=item * $notitle, if true keep the nav controls, but remove the title bar |
|
|
|
=item * $no_inline_link, if true and in remote mode, don't show the |
|
'Switch To Inline Menu' link |
|
|
|
|
|
=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, |
|
$notopbar,$bgcolor,$notitle,$no_inline_link)=@_; |
|
|
|
$title=&mt($title); |
|
|
|
$function = &get_users_function() if (!$function); |
|
my $img = &designparm($function.'.img',$domain); |
|
my $font = &designparm($function.'.font',$domain); |
|
my $pgbg = $bgcolor || &designparm($function.'.pgbg',$domain); |
|
|
|
my %design = ( 'style' => 'margin-top: 0px', |
|
'bgcolor' => $pgbg, |
|
'text' => $font, |
|
'alink' => &designparm($function.'.alink',$domain), |
|
'vlink' => &designparm($function.'.vlink',$domain), |
|
'link' => &designparm($function.'.link',$domain),); |
|
@$addentries{keys(%design)} = @design{keys(%design)}; |
|
|
|
# role and realm |
|
my ($role,$realm) = split(/\./,$env{'request.role'},2); |
|
if ($role eq 'ca') { |
|
my ($rdom,$rname) = ($realm =~ m-^/(\w+)/(\w+)$-); |
|
$realm = &plainname($rname,$rdom).':'.$rdom; |
|
} |
|
# realm |
|
if ($env{'request.course.id'}) { |
|
if ($env{'request.role'} !~ /^cr/) { |
|
$role = &Apache::lonnet::plaintext($role,&course_type()); |
|
} |
|
$realm = $env{'course.'.$env{'request.course.id'}.'.description'}; |
|
} else { |
|
$role = &Apache::lonnet::plaintext($role); |
|
} |
|
if (!$realm) { $realm=' '; } |
|
# Set messages |
|
my $messages=&domainlogo($domain); |
|
# Port for miniserver |
|
my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'}; |
|
if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; } |
|
|
|
my $extra_body_attr = &make_attr_string($forcereg,$addentries); |
|
|
|
# construct main body tag |
|
my $bodytag = "<body $extra_body_attr>". |
|
&Apache::lontexconvert::init_math_support(); |
|
|
|
if ($bodyonly |
|
|| ($env{'request.state'} eq 'construct' |
|
&& $env{'environment.remote'} ne 'off' )) { |
|
return $bodytag; |
|
} elsif ($env{'browser.interface'} eq 'textual') { |
|
# Accessibility |
|
|
|
$bodytag.=&Apache::lonmenu::menubuttons($forcereg,$forcereg); |
|
if (!$notitle) { |
|
$bodytag.='<h1>LON-CAPA: '.$title.'</h1>'; |
|
} |
|
return $bodytag; |
|
} |
|
|
|
|
|
|
|
my $roleinfo=(<<ENDROLE); |
|
<td class="LC_title_bar_who"> |
|
<div class="LC_title_bar_name"> |
|
$env{'environment.firstname'} |
|
$env{'environment.middlename'} |
|
$env{'environment.lastname'} |
|
$env{'environment.generation'} |
|
|
|
</div> |
|
<div class="LC_title_bar_role"> |
|
$role |
|
</div> |
|
<div class="LC_title_bar_realm"> |
|
$realm |
|
</div> |
|
</td> |
|
ENDROLE |
|
|
|
my $titleinfo = '<span class="LC_title_bar_title">'.$title.'</span>'; |
|
if ($customtitle) { |
|
$titleinfo = $customtitle; |
|
} |
|
# |
|
# Extra info if you are the DC |
|
my $dc_info = ''; |
|
if ($env{'user.adv'} && exists($env{'user.role.dc./'. |
|
$env{'course.'.$env{'request.course.id'}. |
|
'.domain'}.'/'})) { |
|
my $cid = $env{'request.course.id'}; |
|
$dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'}; |
|
$dc_info =~ s/\s+$//; |
|
$dc_info = '('.$dc_info.')'; |
|
} |
|
|
|
if ($env{'environment.remote'} eq 'off') { |
|
# No Remote |
|
if ($env{'request.state'} eq 'construct') { |
|
$forcereg=1; |
|
} |
|
|
|
if (!$customtitle && $env{'request.state'} eq 'construct') { |
|
# this is for resources; directories have customtitle, and crumbs |
|
# and select recent are created in lonpubdir.pm |
|
my ($uname,$thisdisfn)= |
|
($env{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|); |
|
my $formaction='/priv/'.$uname.'/'.$thisdisfn; |
|
$formaction=~s/\/+/\//g; |
|
|
|
my $parentpath = ''; |
|
my $lastitem = ''; |
|
if ($thisdisfn =~ m-(.+/)([^/]*)$-) { |
|
$parentpath = $1; |
|
$lastitem = $2; |
|
} else { |
|
$lastitem = $thisdisfn; |
|
} |
|
$titleinfo = |
|
&Apache::loncommon::help_open_menu('','','','',3,'Authoring'). |
|
'<b>Construction Space</b>: '. |
|
'<form name="dirs" method="post" action="'.$formaction |
|
.'" target="_top"><tt><b>' |
|
.&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv','','+1',1)."<font size=\"+1\">$lastitem</font></b></tt><br />" |
|
.&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()') |
|
.'</form>' |
|
.&Apache::lonmenu::constspaceform(); |
|
} |
|
|
|
my $titletable; |
|
if (!$notitle) { |
|
$titletable = |
|
'<table id="LC_title_bar">'. |
|
"<tr><td> $titleinfo $dc_info</td>".$roleinfo. |
|
'</tr></table>'; |
|
} |
|
if ($notopbar) { |
|
$bodytag .= $titletable; |
|
} else { |
|
if ($env{'request.state'} eq 'construct') { |
|
$bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg, |
|
$titletable); |
|
} else { |
|
$bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg). |
|
$titletable; |
|
} |
|
} |
|
return $bodytag; |
|
} |
|
|
|
# |
|
# Top frame rendering, Remote is up |
|
# |
|
|
|
my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'. |
|
$lonhttpdPort.$img.'" alt="'.$function.'" />'; |
|
|
|
# Explicit link to get inline menu |
|
my $menu= ($no_inline_link?'' |
|
:'<br /><a href="/adm/remote?action=collapse">'.&mt('Switch to Inline Menu Mode').'</a>'); |
|
# |
|
if ($notitle) { |
|
return $bodytag; |
|
} |
|
return(<<ENDBODY); |
|
$bodytag |
|
<table id="LC_title_bar" class="LC_with_remote"> |
|
<tr><td class="LC_title_bar_role_logo">$upperleft</td> |
|
<td class="LC_title_bar_domain_logo">$messages </td> |
|
</tr> |
|
<tr><td>$titleinfo $dc_info $menu</td> |
|
$roleinfo |
|
</tr> |
|
</table> |
|
ENDBODY |
|
} |
|
|
|
sub make_attr_string { |
|
my ($register,$attr_ref) = @_; |
|
|
|
if ($attr_ref && !ref($attr_ref)) { |
|
die("addentries Must be a hash ref ". |
|
join(':',caller(1))." ". |
|
join(':',caller(0))." "); |
|
} |
|
|
|
if ($register) { |
|
my ($on_load,$on_unload); |
|
foreach my $key (keys(%{$attr_ref})) { |
|
if (lc($key) eq 'onload') { |
|
$on_load.=$attr_ref->{$key}.';'; |
|
delete($attr_ref->{$key}); |
|
|
|
} elsif (lc($key) eq 'onunload') { |
|
$on_unload.=$attr_ref->{$key}.';'; |
|
delete($attr_ref->{$key}); |
|
} |
|
} |
|
$attr_ref->{'onload'} = |
|
&Apache::lonmenu::loadevents(). $on_load; |
|
$attr_ref->{'onunload'}= |
|
&Apache::lonmenu::unloadevents().$on_unload; |
|
} |
|
|
|
# Accessibility font enhance |
|
if ($env{'browser.fontenhance'} eq 'on') { |
|
my $style; |
|
foreach my $key (keys(%{$attr_ref})) { |
|
if (lc($key) eq 'style') { |
|
$style.=$attr_ref->{$key}.';'; |
|
delete($attr_ref->{$key}); |
|
} |
|
} |
|
$attr_ref->{'style'}=$style.'; font-size: x-large;'; |
|
} |
|
|
|
if ($env{'browser.blackwhite'} eq 'on') { |
|
delete($attr_ref->{'font'}); |
|
delete($attr_ref->{'link'}); |
|
delete($attr_ref->{'alink'}); |
|
delete($attr_ref->{'vlink'}); |
|
delete($attr_ref->{'bgcolor'}); |
|
delete($attr_ref->{'background'}); |
|
} |
|
|
|
my $attr_string; |
|
foreach my $attr (keys(%$attr_ref)) { |
|
$attr_string .= " $attr=\"".$attr_ref->{$attr}.'" '; |
|
} |
|
return $attr_string; |
|
} |
|
|
|
|
|
############################################### |
|
############################################### |
|
|
|
=pod |
|
|
|
=back |
|
|
|
=head1 HTML Helpers |
|
|
|
=over 4 |
|
|
|
=item * &endbodytag() |
|
|
|
Returns a uniform footer for LON-CAPA web pages. |
|
|
|
Inputs: none |
|
|
|
=back |
|
|
|
=cut |
|
|
|
sub endbodytag { |
|
my $endbodytag='</body>'; |
|
$endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag; |
|
if ( exists( $env{'internal.head.redirect'} ) ) { |
|
$endbodytag= |
|
"<br /><a href=\"$env{'internal.head.redirect'}\">". |
|
&mt('Continue').'</a>'. |
|
$endbodytag; |
|
} |
|
return $endbodytag; |
|
} |
|
|
|
=pod |
|
|
|
=over 4 |
|
|
|
=item * &standard_css() |
|
|
|
Returns a style sheet |
|
|
|
Inputs: (all optional) |
|
domain -> force to color decorate a page for a specific |
|
domain |
|
function -> force usage of a specific rolish color scheme |
|
bgcolor -> override the default page bgcolor |
|
|
|
=back |
|
|
|
=cut |
|
|
|
sub standard_css { |
|
my ($function,$domain,$bgcolor) = @_; |
|
$function = &get_users_function() if (!$function); |
|
my $img = &designparm($function.'.img', $domain); |
|
my $tabbg = &designparm($function.'.tabbg', $domain); |
|
my $font = &designparm($function.'.font', $domain); |
|
my $sidebg = &designparm($function.'.sidebg',$domain); |
|
my $pgbg_or_bgcolor = |
|
$bgcolor || |
|
&designparm($function.'.pgbg', $domain); |
|
my $pgbg = &designparm($function.'.pgbg', $domain); |
|
my $alink = &designparm($function.'.alink', $domain); |
|
my $vlink = &designparm($function.'.vlink', $domain); |
|
my $link = &designparm($function.'.link', $domain); |
|
|
|
my $sans = 'Arial,Helvetica,sans-serif'; |
|
my $data_table_head = $tabbg; |
|
my $data_table_light = '#EEEEEE'; |
|
my $data_table_dark = '#DDD'; |
|
my $data_table_highlight = '#FFFF00'; |
|
my $mail_new = '#FFBB77'; |
|
my $mail_new_hover = '#DD9955'; |
|
my $mail_read = '#BBBB77'; |
|
my $mail_read_hover = '#999944'; |
|
my $mail_replied = '#AAAA88'; |
|
my $mail_replied_hover = '#888855'; |
|
my $mail_other = '#99BBBB'; |
|
my $mail_other_hover = '#669999'; |
|
|
|
return <<END; |
|
h1, h2, h3, th { font-family: $sans } |
|
a:focus { color: red; background: yellow } |
|
table.thinborder { border-collapse: collapse; } |
|
table.thinborder tr th, table.thinborder tr td { border-style: solid; border-width: 1px} |
|
form, .inline { display: inline; } |
|
.center { text-align: center; } |
|
.LC_filename {font-family: monospace;} |
|
.LC_error { |
|
color: red; |
|
font-size: larger; |
|
} |
|
.LC_success { |
|
color: green; |
|
} |
|
|
|
table#LC_top_nav, table#LC_menubuttons, table#LC_nav_location { |
|
width: 100%; |
|
background: $pgbg; |
|
border: 0px; |
|
border-spacing: 2px 2px; |
|
padding: 0px; |
|
margin: 0px; |
|
border-collapse: separate; |
|
} |
|
table#LC_title_bar { |
|
width: 100%; |
|
border: 0; |
|
border-spacing: 0px 0px; |
|
padding: 0px 2px 0px 2px; |
|
background: $pgbg; |
|
font-family: $sans; |
|
border-collapse: separate; |
|
} |
|
table#LC_breadcrumbs { |
|
width: 100%; |
|
border: 0; |
|
border-spacing: 0px; |
|
padding: 0px 2px 0px 2px; |
|
background: $pgbg; |
|
font-family: $sans; |
|
border-collapse: separate; |
|
} |
|
table#LC_title_bar.LC_with_remote { |
|
width: 100%; |
|
border: 0; |
|
border-spacing: 0; |
|
background: $pgbg; |
|
font-family: $sans; |
|
border-collapse: collapse; |
|
} |
|
table#LC_title_bar td { |
|
padding: 3px; |
|
background: $tabbg; |
|
} |
|
table#LC_title_bar td.LC_title_bar_who { |
|
background: $tabbg; |
|
color: $font; |
|
font: medium $sans; |
|
text-align: right; |
|
} |
|
span.LC_title_bar_title { |
|
font: bold xx-large $sans; |
|
} |
|
table#LC_title_bar td.LC_title_bar_domain_logo { |
|
background: $sidebg; |
|
text-align: right; |
|
padding: 0px; |
|
} |
|
table#LC_title_bar td.LC_title_bar_role_logo { |
|
background: $sidebg; |
|
padding: 0px; |
|
} |
|
|
|
table#LC_menubuttons_mainmenu { |
|
background: $pgbg; |
|
border: 0px; |
|
border-spacing: 1px; |
|
padding: 0px 1px; |
|
margin: 0px; |
|
border-collapse: separate; |
|
} |
|
table#LC_menubuttons img, table#LC_menubuttons_mainmenu img { |
|
border: 0px; |
|
} |
|
table#LC_top_nav td { |
|
background: $tabbg; |
|
} |
|
table#LC_top_nav td a, div#LC_top_nav a { |
|
color: $font; |
|
font-family: $sans; |
|
} |
|
table#LC_top_nav td.LC_top_nav_logo { |
|
background: $tabbg; |
|
text-align: right; |
|
} |
|
table#LC_breadcrumbs td { |
|
background: $tabbg; |
|
color: $font; |
|
font-family: $sans; |
|
font-size: smaller; |
|
} |
|
table#LC_breadcrumbs td.LC_breadcrumb_component { |
|
background: $tabbg; |
|
color: $font; |
|
font-family: $sans; |
|
font-size: larger; |
|
text-align: right; |
|
} |
|
td.LC_table_cell_checkbox { |
|
text-align: center; |
|
} |
|
|
|
.LC_menubuttons_inline_text { |
|
color: $font; |
|
font-family: $sans; |
|
font-size: smaller; |
|
} |
|
|
|
td.LC_menubuttons_text { |
|
color: $font; |
|
font-family: $sans; |
|
} |
|
td.LC_menubuttons_img { |
|
background: $tabbg; |
|
} |
|
.LC_current_location { |
|
font-family: $sans; |
|
background: $tabbg; |
|
} |
|
.LC_new_mail { |
|
font-family: $sans; |
|
font-weight: bold; |
|
} |
|
|
|
table.LC_data_table, table.LC_mail_list { |
|
border: 1px solid #000000; |
|
border-collapse: seperate; |
|
} |
|
table.LC_data_table tr th, table.LC_calendar tr th, table.LC_mail_list tr th { |
|
font-weight: bold; |
|
background-color: $data_table_head; |
|
} |
|
table.LC_data_table tr td { |
|
background-color: $data_table_light; |
|
} |
|
table.LC_data_table tr.LC_even_row td { |
|
background-color: $data_table_dark; |
|
} |
|
table.LC_data_table tr.LC_empty td { |
|
background-color: #FFFFFF; |
|
} |
|
|
|
table.LC_calendar { |
|
border: 1px solid #000000; |
|
border-collapse: collapse; |
|
} |
|
table.LC_calendar_pickdate { |
|
font-size: xx-small; |
|
} |
|
table.LC_calendar tr td { |
|
border: 1px solid #000000; |
|
vertical-align: top; |
|
} |
|
table.LC_calendar tr td.LC_calendar_day_empty { |
|
background-color: $data_table_dark; |
|
} |
|
table.LC_calendar tr td.LC_calendar_day_current { |
|
background-color: $data_table_highlight; |
|
} |
|
|
|
table.LC_mail_list tr.LC_mail_new { |
|
background-color: $mail_new; |
|
} |
|
table.LC_mail_list tr.LC_mail_new:hover { |
|
background-color: $mail_new_hover; |
|
} |
|
table.LC_mail_list tr.LC_mail_read { |
|
background-color: $mail_read; |
|
} |
|
table.LC_mail_list tr.LC_mail_read:hover { |
|
background-color: $mail_read_hover; |
|
} |
|
table.LC_mail_list tr.LC_mail_replied { |
|
background-color: $mail_replied; |
|
} |
|
table.LC_mail_list tr.LC_mail_replied:hover { |
|
background-color: $mail_replied_hover; |
|
} |
|
table.LC_mail_list tr.LC_mail_other { |
|
background-color: $mail_other; |
|
} |
|
table.LC_mail_list tr.LC_mail_other:hover { |
|
background-color: $mail_other_hover; |
|
} |
|
|
|
|
|
END |
|
} |
|
|
|
=pod |
|
|
|
=over 4 |
|
|
|
=item * &headtag() |
|
|
|
Returns a uniform footer for LON-CAPA web pages. |
|
|
|
Inputs: $title - optional title for the head |
|
$head_extra - optional extra HTML to put inside the <head> |
|
$args - optional arguments |
|
force_register - if is true call registerurl so the remote is |
|
informed |
|
redirect -> array ref of seconds before redirect occurs |
|
url to redirect to |
|
(side effect of setting |
|
$env{'internal.head.redirect'} to the url |
|
redirected too) |
|
domain -> force to color decorate a page for a specific |
|
domain |
|
function -> force usage of a specific rolish color scheme |
|
bgcolor -> override the default page bgcolor |
|
|
|
=back |
|
|
|
=cut |
|
|
|
sub headtag { |
|
my ($title,$head_extra,$args) = @_; |
|
|
|
my $function = $args->{'function'} || &get_users_function(); |
|
my $domain = $args->{'domain'} || &determinedomain(); |
|
my $bgcolor = $args->{'bgcolor'} || &designparm($function.'.pgbg',$domain); |
|
my $url = join(':',$env{'user.name'},$env{'user.domain'}, |
|
$env{'environment.color.timestamp'}, |
|
$function,$domain,$bgcolor); |
|
|
|
$url = '/adm/css/'.&escape($url).'.css'; |
|
|
|
my $result = |
|
'<head>'. |
|
'<link rel="stylesheet" type="text/css" href="'.$url.'" />'. |
|
&font_settings(). |
|
&Apache::lonhtmlcommon::htmlareaheaders(); |
|
|
|
if ($args->{'force_register'}) { |
|
$result .= &Apache::lonmenu::registerurl(1); |
|
} |
|
|
|
if (ref($args->{'redirect'})) { |
|
my ($time,$url) = @{$args->{'redirect'}}; |
|
$url = &Apache::lonenc::check_encrypt($url); |
|
$env{'internal.head.redirect'} = $url; |
|
$result.=<<ADDMETA |
|
<meta http-equiv="pragma" content="no-cache" /> |
|
<meta http-equiv="Refresh" content="$time; url=$url" /> |
|
ADDMETA |
|
} |
|
if (!defined($title)) { |
|
$title = 'The LearningOnline Network with CAPA'; |
|
} |
|
|
|
$result .= '<title> LON-CAPA '.&mt($title).'</title>'.$head_extra; |
|
return $result; |
|
} |
|
|
|
=pod |
|
|
|
=over 4 |
|
|
|
=item * &font_settings() |
|
|
|
Returns neccessary <meta> to set the proper encoding |
|
|
|
Inputs: none |
|
|
|
=back |
|
|
|
=cut |
|
|
|
sub font_settings { |
|
my $headerstring=''; |
|
if (($env{'browser.os'} eq 'mac') && (!$env{'browser.mathml'})) { |
|
$headerstring.= |
|
'<meta Content-Type="text/html; charset=x-mac-roman" />'; |
|
} elsif (!$env{'browser.mathml'} && $env{'browser.unicode'}) { |
|
$headerstring.= |
|
'<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />'; |
|
} |
|
return $headerstring; |
|
} |
|
|
|
=pod |
|
|
|
=over 4 |
|
|
|
=item * &xml_begin() |
|
|
|
Returns the needed doctype and <html> |
|
|
|
Inputs: none |
|
|
|
=back |
|
|
|
=cut |
|
|
|
sub xml_begin { |
|
my $output=''; |
|
|
|
&Apache::lonhtmlcommon::init_htmlareafields(); |
|
|
|
if ($env{'browser.mathml'}) { |
|
$output='<?xml version="1.0"?>' |
|
#.'<?xml-stylesheet type="text/css" href="/adm/MathML/mathml.css"?>'."\n" |
|
# .'<!DOCTYPE html SYSTEM "/adm/MathML/mathml.dtd" ' |
|
|
|
# .'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd" [<!ENTITY mathns "http://www.w3.org/1998/Math/MathML">] >' |
|
.'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1 plus MathML 2.0 plus SVG 1.1//EN" "http://www.w3.org/2002/04/xhtml-math-svg/xhtml-math-svg.dtd">' |
|
.'<html xmlns:math="http://www.w3.org/1998/Math/MathML" ' |
|
.'xmlns="http://www.w3.org/1999/xhtml">'; |
|
} else { |
|
$output='<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"><html>'; |
|
} |
|
return $output; |
|
} |
|
|
|
=pod |
|
|
|
=over 4 |
|
|
|
=item * &endheadtag() |
|
|
|
Returns a uniform </head> for LON-CAPA web pages. |
|
|
|
Inputs: none |
|
|
|
=back |
|
|
|
=cut |
|
|
|
sub endheadtag { |
|
return '</head>'; |
|
} |
|
|
|
=pod |
|
|
|
=over 4 |
|
|
|
=item * &head() |
|
|
|
Returns a uniform complete <head>..</head> section for LON-CAPA web pages. |
|
|
|
Inputs: $title - optional title for the page |
|
$head_extra - optional extra HTML to put inside the <head> |
|
=back |
|
|
|
=cut |
|
|
|
sub head { |
|
my ($title,$head_extra,$args) = @_; |
|
return &headtag($title,$head_extra,$args).&endheadtag(); |
|
} |
|
|
|
=pod |
|
|
|
=over 4 |
|
|
|
=item * &start_page() |
|
|
|
Returns a complete <html> .. <body> section for LON-CAPA web pages. |
|
|
|
Inputs: $title - optional title for the page |
|
$head_extra - optional extra HTML to incude inside the <head> |
|
$args - additional optional args supported are: |
|
only_body -> is true will set &bodytag() onlybodytag |
|
arg on |
|
no_nav_bar -> is true will set &bodytag() notopbar arg on |
|
add_entries -> additional attributes to add to the <body> |
|
domain -> force to color decorate a page for a |
|
specific domain |
|
function -> force usage of a specific rolish color |
|
scheme |
|
redirect -> see &headtag() |
|
bgcolor -> override the default page bg color |
|
js_ready -> return a string ready for being used in |
|
a javascript writeln |
|
html_encode -> return a string ready for being used in |
|
a html attribute |
|
force_register -> if is true will turn on the &bodytag() |
|
$forcereg arg |
|
body_title -> alternate text to use instead of $title |
|
in the title box that appears, this text |
|
is not auto translated like the $title is |
|
frameset -> if true will start with a <frameset> |
|
rather than <body> |
|
no_title -> if true the title bar won't be shown |
|
skip_phases -> hash ref of |
|
head -> skip the <html><head> generation |
|
body -> skip all <body> generation |
|
|
|
no_inline_link -> if true and in remote mode, don't show the |
|
'Switch To Inline Menu' link |
|
|
|
=back |
|
|
|
=cut |
|
|
|
sub start_page { |
|
my ($title,$head_extra,$args) = @_; |
|
#&Apache::lonnet::logthis("start_page ".join(':',caller(0))); |
|
my %head_args; |
|
foreach my $arg ('redirect','force_register','domain','function', |
|
'bgcolor') { |
|
if (defined($args->{$arg})) { |
|
$head_args{$arg} = $args->{$arg}; |
|
} |
|
} |
|
|
|
$env{'internal.start_page'}++; |
|
my $result; |
|
if (! exists($args->{'skip_phases'}{'head'}) ) { |
|
$result.= |
|
&xml_begin(). |
|
&headtag($title,$head_extra,\%head_args).&endheadtag(); |
|
} |
|
|
|
if (! exists($args->{'skip_phases'}{'body'}) ) { |
|
if ($args->{'frameset'}) { |
|
my $attr_string = &make_attr_string($args->{'force_register'}, |
|
$args->{'add_entries'}); |
|
$result .= "\n<frameset $attr_string>\n"; |
|
} else { |
|
$result .= |
|
&bodytag($title, |
|
$args->{'function'}, $args->{'add_entries'}, |
|
$args->{'only_body'}, $args->{'domain'}, |
|
$args->{'force_register'}, $args->{'body_title'}, |
|
$args->{'no_nav_bar'}, $args->{'bgcolor'}, |
|
$args->{'no_title'}, $args->{'no_inline_link'}); |
|
} |
|
} |
|
|
|
if ($args->{'js_ready'}) { |
|
$result = &js_ready($result); |
|
} |
|
if ($args->{'html_encode'}) { |
|
$result = &html_encode($result); |
|
} |
|
return $result; |
|
} |
|
|
|
|
|
=pod |
|
|
|
=over 4 |
|
|
|
=item * &head() |
|
|
|
Returns a complete </body></html> section for LON-CAPA web pages. |
|
|
|
Inputs: $args - additional optional args supported are: |
|
js_ready -> return a string ready for being used in |
|
a javascript writeln |
|
html_encode -> return a string ready for being used in |
|
a html attribute |
|
frameset -> if true will start with a <frameset> |
|
rather than <body> |
|
=back |
|
|
|
=cut |
|
|
|
sub end_page { |
|
my ($args) = @_; |
|
$env{'internal.end_page'}++; |
|
my $result; |
|
if ($args->{'discussion'}) { |
|
my ($target,$parser); |
|
if (ref($args->{'discussion'})) { |
|
($target,$parser) =($args->{'discussion'}{'target'}, |
|
$args->{'discussion'}{'parser'}); |
|
} |
|
$result .= &Apache::lonxml::xmlend($target,$parser); |
|
} |
|
|
|
if ($args->{'frameset'}) { |
|
$result .= '</frameset>'; |
|
} else { |
|
$result .= &endbodytag(); |
|
} |
|
$result .= "\n</html>"; |
|
|
|
if ($args->{'js_ready'}) { |
|
$result = &js_ready($result); |
|
} |
|
|
|
if ($args->{'html_encode'}) { |
|
$result = &html_encode($result); |
|
} |
|
|
|
return $result; |
|
} |
|
|
|
sub html_encode { |
|
my ($result) = @_; |
|
|
|
$result = &HTML::Entities::encode($result,'<>&"'); |
|
|
|
return $result; |
|
} |
|
sub js_ready { |
|
my ($result) = @_; |
|
|
|
$result =~ s/[\n\r]/ /xmsg; |
|
$result =~ s/\\/\\\\/xmsg; |
|
$result =~ s/'/\\'/xmsg; |
|
$result =~ s{</}{<\\/}xmsg; |
|
|
|
return $result; |
|
} |
|
|
|
sub validate_page { |
|
if ( exists($env{'internal.start_page'}) |
|
&& $env{'internal.start_page'} > 1) { |
|
&Apache::lonnet::logthis('start_page called multiple times '. |
|
$env{'internal.start_page'}.' '. |
|
$ENV{'request.filename'}); |
|
} |
|
if ( exists($env{'internal.end_page'}) |
|
&& $env{'internal.end_page'} > 1) { |
|
&Apache::lonnet::logthis('end_page called multiple times '. |
|
$env{'internal.end_page'}.' '. |
|
$env{'request.filename'}); |
|
} |
|
if ( exists($env{'internal.start_page'}) |
|
&& ! exists($env{'internal.end_page'})) { |
|
&Apache::lonnet::logthis('start_page called without end_page '. |
|
$env{'request.filename'}); |
|
} |
|
if ( ! exists($env{'internal.start_page'}) |
|
&& exists($env{'internal.end_page'})) { |
|
&Apache::lonnet::logthis('end_page called without start_page'. |
|
$env{'request.filename'}); |
|
} |
|
} |
|
|
|
sub simple_error_page { |
|
my ($r,$title,$msg) = @_; |
|
my $page = |
|
&Apache::loncommon::start_page($title). |
|
&mt($msg). |
|
&Apache::loncommon::end_page(); |
|
if (ref($r)) { |
|
$r->print($page); |
|
return; |
|
} |
|
return $page; |
|
} |
|
|
|
{ |
|
my $row_count; |
|
sub start_data_table { |
|
undef($row_count); |
|
return '<table class="LC_data_table">'; |
|
} |
|
|
|
sub end_data_table { |
|
undef($row_count); |
|
return '</table>'; |
|
} |
|
|
|
sub start_data_table_row { |
|
$row_count++; |
|
return '<tr '.(($row_count % 2)?'':'class="LC_even_row"').'>'; |
|
} |
|
|
|
sub end_data_table_row { |
|
return '</tr>'; |
|
} |
|
|
|
sub start_data_table_header_row { |
|
return '<tr class="LC_header_row">'; |
|
} |
|
|
|
sub end_data_table_header_row { |
|
return '</tr>'; |
|
} |
|
} |
|
|
|
############################################### |
|
|
|
=pod |
|
|
|
=over 4 |
|
|
|
=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 check_user_status |
|
|
|
Determines current status of supplied role for a |
|
specific user. Roles can be active, previous or future. |
|
|
|
Inputs: |
|
user's domain, user's username, course's domain, |
|
course's number, optional section ID. |
|
|
|
Outputs: |
|
role status: active, previous or future. |
|
|
|
=cut |
|
|
|
sub check_user_status { |
|
my ($udom,$uname,$cdom,$crs,$role,$secgrp) = @_; |
|
my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname); |
|
my @uroles = keys %userinfo; |
|
my $srchstr; |
|
my $active_chk = 'none'; |
|
if (@uroles > 0) { |
|
if (($role eq 'cc') || ($secgrp eq '') || (!defined($secgrp))) { |
|
$srchstr = '/'.$cdom.'/'.$crs.'_'.$role; |
|
} else { |
|
$srchstr = '/'.$cdom.'/'.$crs.'/'.$secgrp.'_'.$role; } |
|
if (grep/^$srchstr$/,@uroles) { |
|
my $role_end = 0; |
|
my $role_start = 0; |
|
$active_chk = 'active'; |
|
if ($userinfo{$srchstr} =~ m/^($role)_(\d+)/) { |
|
$role_end = $2; |
|
if ($userinfo{$srchstr} =~ m/^($role)_($role_end)_(\d+)$/) { |
|
$role_start = $3; |
|
} |
|
} |
|
if ($role_start > 0) { |
|
if (time < $role_start) { |
|
$active_chk = 'future'; |
|
} |
|
} |
|
if ($role_end > 0) { |
|
if (time > $role_end) { |
|
$active_chk = 'previous'; |
|
} |
|
} |
|
} |
|
} |
|
return $active_chk; |
|
} |
|
|
|
############################################### |
|
|
|
=pod |
|
|
|
=item get_sections |
|
|
|
Determines all the sections for a course including |
|
sections with students and sections containing other roles. |
|
Incoming parameters: domain, course number, |
|
reference to array containing roles for which sections should |
|
be gathered (optional). If the third argument is undefined, |
|
sections are gathered for any role. |
|
|
|
Returns section hash (keys are section IDs, values are |
|
number of users in each section), subject to the |
|
optional roles filter. |
|
|
|
=cut |
|
|
|
############################################### |
|
sub get_sections { |
|
my ($cdom,$cnum,$possible_roles) = @_; |
|
if (!defined($cdom) || !defined($cnum)) { |
|
my $cid = $env{'request.course.id'}; |
|
|
|
return if (!defined($cid)); |
|
|
|
$cdom = $env{'course.'.$cid.'.domain'}; |
|
$cnum = $env{'course.'.$cid.'.num'}; |
|
} |
|
|
|
my %sectioncount; |
|
|
|
if (!defined($possible_roles) || (grep(/^st$/,@$possible_roles))) { |
|
my ($classlist) = &Apache::loncoursedata::get_classlist($cdom,$cnum); |
|
my $sec_index = &Apache::loncoursedata::CL_SECTION(); |
|
my $status_index = &Apache::loncoursedata::CL_STATUS(); |
|
while (my ($student,$data) = each(%$classlist)) { |
|
my ($section,$status) = ($data->[$sec_index], |
|
$data->[$status_index]); |
|
unless ($section eq '-1' || $section =~ /^\s*$/) { |
|
$sectioncount{$section}++; |
|
} |
|
} |
|
} |
|
my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum); |
|
foreach my $user (sort(keys(%courseroles))) { |
|
if ($user !~ /^(\w{2})/) { next; } |
|
my ($role) = ($user =~ /^(\w{2})/); |
|
if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; } |
|
my $section; |
|
if ($role eq 'cr' && |
|
$user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) { |
|
$section=$1; |
|
} |
|
if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { $section=$1; } |
|
if (!defined($section) || $section eq '-1') { next; } |
|
$sectioncount{$section}++; |
|
} |
|
return %sectioncount; |
|
} |
|
|
|
############################################### |
|
|
|
=pod |
|
|
|
=item get_course_users |
|
|
|
Retrieves usernames:domains for users in the specified course |
|
with specific role(s), and access status. |
|
|
|
Incoming parameters: |
|
1. course domain |
|
2. course number |
|
3. access status: users must have - either active, |
|
previous, future, or all. |
|
4. reference to array of permissible roles |
|
5. reference to array of section restrictions (optional) |
|
6. reference to results object (hash of hashes). |
|
7. reference to optional userdata hash |
|
Keys of top level hash are roles. |
|
Keys of inner hashes are username:domain, with |
|
values set to access type. |
|
Optional userdata hash returns an array with arguments in the |
|
same order as loncoursedata::get_classlist() for student data. |
|
|
|
Entries for end, start, section and status are blank because |
|
of the possibility of multiple values for non-student roles. |
|
|
|
=cut |
|
|
|
############################################### |
|
|
|
sub get_course_users { |
|
my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata) = @_; |
|
my %idx = (); |
|
|
|
$idx{udom} = &Apache::loncoursedata::CL_SDOM(); |
|
$idx{uname} = &Apache::loncoursedata::CL_SNAME(); |
|
$idx{end} = &Apache::loncoursedata::CL_END(); |
|
$idx{start} = &Apache::loncoursedata::CL_START(); |
|
$idx{id} = &Apache::loncoursedata::CL_ID(); |
|
$idx{section} = &Apache::loncoursedata::CL_SECTION(); |
|
$idx{fullname} = &Apache::loncoursedata::CL_FULLNAME(); |
|
$idx{status} = &Apache::loncoursedata::CL_STATUS(); |
|
|
|
if (grep(/^st$/,@{$roles})) { |
|
my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum); |
|
my $now = time; |
|
foreach my $student (keys(%{$classlist})) { |
|
my $match = 0; |
|
if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) { |
|
unless(grep(/^\Q$$classlist{$student}[$idx{section}]\E$/, |
|
@{$sections})) { |
|
next; |
|
} |
|
} |
|
if (defined($$types{'active'})) { |
|
if ($$classlist{$student}[$idx{status}] eq 'Active') { |
|
push(@{$$users{st}{$student}},'active'); |
|
$match = 1; |
|
} |
|
} |
|
if (defined($$types{'previous'})) { |
|
if ($$classlist{$student}[$idx{end}] <= $now) { |
|
push(@{$$users{st}{$student}},'previous'); |
|
$match = 1; |
|
} |
|
} |
|
if (defined($$types{'future'})) { |
|
if (($$classlist{$student}[$idx{start}] > $now) && ($$classlist{$student}[$idx{end}] > $now) || ($$classlist{$student}[$idx{end}] == 0) || ($$classlist{$student}[$idx{end}] eq '')) { |
|
push(@{$$users{st}{$student}},'future'); |
|
$match = 1; |
|
} |
|
} |
|
if ($match && defined($userdata)) { |
|
$$userdata{$student} = $$classlist{$student}; |
|
} |
|
} |
|
} |
|
if ((@{$roles} > 0) && (@{$roles} ne "st")) { |
|
my @coursepersonnel = &Apache::lonnet::getkeys('nohist_userroles',$cdom,$cnum); |
|
foreach my $person (@coursepersonnel) { |
|
my $match = 0; |
|
my ($role,$user) = ($person =~ /^([^:]*):([^:]+:[^:]+)/); |
|
$user =~ s/:$//; |
|
if (($role) && (grep(/^\Q$role\E$/,@{$roles}))) { |
|
my ($uname,$udom,$usec) = split(/:/,$user); |
|
if ($usec ne '' && (ref($sections) eq 'ARRAY') && |
|
@{$sections} > 0) { |
|
unless(grep(/^\Q$usec\E$/,@{$sections})) { |
|
next; |
|
} |
|
} |
|
if ($uname ne '' && $udom ne '') { |
|
my $status = &check_user_status($udom,$uname,$cdom,$cnum,$role); |
|
foreach my $type (keys(%{$types})) { |
|
if ($status eq $type) { |
|
@{$$users{$role}{$user}} = $type; |
|
$match = 1; |
|
} |
|
} |
|
if ($match && defined($userdata) && |
|
!exists($$userdata{$uname.':'.$udom})) { |
|
&get_user_info($udom,$uname,\%idx,$userdata); |
|
} |
|
} |
|
} |
|
} |
|
if (grep(/^ow$/,@{$roles})) { |
|
if ((defined($cdom)) && (defined($cnum))) { |
|
my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum); |
|
if ( defined($csettings{'internal.courseowner'}) ) { |
|
my $owner = $csettings{'internal.courseowner'}; |
|
@{$$users{'ow'}{$owner.':'.$cdom}} = 'any'; |
|
if (defined($userdata) && |
|
!exists($$userdata{$owner.':'.$cdom})) { |
|
&get_user_info($cdom,$owner,\%idx,$userdata); |
|
} |
|
} |
|
} |
|
} |
|
} |
|
return; |
|
} |
|
|
|
sub get_user_info { |
|
my ($udom,$uname,$idx,$userdata) = @_; |
|
$$userdata{$uname.':'.$udom}[$$idx{fullname}] = |
|
&plainname($uname,$udom,'lastname'); |
|
$$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname; |
|
$$userdata{$uname.':'.$udom}[$$idx{udom}] = $udom; |
|
return; |
|
} |
|
|
|
sub get_secgrprole_info { |
|
my ($cdom,$cnum,$needroles,$type) = @_; |
|
my %sections_count = &get_sections($cdom,$cnum); |
|
my @sections = (sort {$a <=> $b} keys(%sections_count)); |
|
my %curr_groups = &Apache::longroup::coursegroups($cdom,$cnum); |
|
my @groups = sort(keys(%curr_groups)); |
|
my $allroles = []; |
|
my $rolehash; |
|
my $accesshash = { |
|
active => 'Currently has access', |
|
future => 'Will have future access', |
|
previous => 'Previously had access', |
|
}; |
|
if ($needroles) { |
|
$rolehash = {'all' => 'all'}; |
|
my %user_roles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum); |
|
if (&Apache::lonnet::error(%user_roles)) { |
|
undef(%user_roles); |
|
} |
|
foreach my $item (keys(%user_roles)) { |
|
my ($role)=split(/\:/,$item,2); |
|
if ($role eq 'cr') { next; } |
|
if ($role =~ /^cr/) { |
|
$$rolehash{$role} = (split('/',$role))[3]; |
|
} else { |
|
$$rolehash{$role} = &Apache::lonnet::plaintext($role,$type); |
|
} |
|
} |
|
foreach my $key (sort(keys(%{$rolehash}))) { |
|
push(@{$allroles},$key); |
|
} |
|
push (@{$allroles},'st'); |
|
$$rolehash{'st'} = &Apache::lonnet::plaintext('st',$type); |
|
} |
|
return (\@sections,\@groups,$allroles,$rolehash,$accesshash); |
|
} |
|
|
|
=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 { |
|
my ($query,$possible_names)= @_; |
|
# $Apache::lonxml::debug=1; |
|
foreach my $pair (split(/&/,$query)) { |
|
my ($name, $value) = split(/=/,$pair); |
|
$name = &unescape($name); |
|
if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) { |
|
$value =~ tr/+/ /; |
|
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; |
|
unless (defined($env{'form.'.$name})) { &add_to_env('form.'.$name,$value) }; |
|
} |
|
} |
|
} |
|
|
|
=pod |
|
|
|
=item * cacheheader() |
|
|
|
returns cache-controlling header code |
|
|
|
=cut |
|
|
|
sub cacheheader { |
|
unless ($env{'request.method'} eq 'GET') { return ''; } |
|
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="Pragma" CONTENT="no-cache" />'; |
|
return $output; |
|
} |
|
|
|
=pod |
|
|
|
=item * no_cache($r) |
|
|
|
specifies header code to not have cache |
|
|
|
=cut |
|
|
|
sub no_cache { |
|
my ($r) = @_; |
|
if ($ENV{'REQUEST_METHOD'} ne 'GET' && |
|
$env{'request.method'} ne 'GET') { return ''; } |
|
my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time)); |
|
$r->no_cache(1); |
|
$r->header_out("Expires" => $date); |
|
$r->header_out("Pragma" => "no-cache"); |
|
} |
|
|
|
sub content_type { |
|
my ($r,$type,$charset) = @_; |
|
if ($r) { |
|
# Note that printout.pl calls this with undef for $r. |
|
&no_cache($r); |
|
} |
|
if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; } |
|
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"); |
|
} |
|
} |
|
|
|
=pod |
|
|
|
=item * add_to_env($name,$value) |
|
|
|
adds $name to the %env hash with value |
|
$value, if $name already exists, the entry is converted to an array |
|
reference and $value is added to the array. |
|
|
|
=cut |
|
|
|
sub add_to_env { |
|
my ($name,$value)=@_; |
|
if (defined($env{$name})) { |
|
if (ref($env{$name})) { |
|
#already have multiple values |
|
push(@{ $env{$name} },$value); |
|
} else { |
|
#first time seeing multiple values, convert hash entry to an arrayref |
|
my $first=$env{$name}; |
|
undef($env{$name}); |
|
push(@{ $env{$name} },$first,$value); |
|
} |
|
} else { |
|
$env{$name}=$value; |
|
} |
|
} |
|
|
|
=pod |
|
|
|
=item * get_env_multiple($name) |
|
|
|
gets $name from the %env hash, it seemlessly handles the cases where multiple |
|
values may be defined and end up as an array ref. |
|
|
|
returns an array of values |
|
|
|
=cut |
|
|
|
sub get_env_multiple { |
|
my ($name) = @_; |
|
my @values; |
|
if (defined($env{$name})) { |
|
# exists is it an array |
|
if (ref($env{$name})) { |
|
@values=@{ $env{$name} }; |
|
} else { |
|
$values[0]=$env{$name}; |
|
} |
|
} |
|
return(@values); |
|
} |
|
|
|
|
|
=pod |
|
|
|
=back |
|
|
|
=head1 CSV Upload/Handling functions |
|
|
|
=over 4 |
|
|
|
=item * upfile_store($r) |
|
|
|
Store uploaded file, $r should be the HTTP Request object, |
|
needs $env{'form.upfile'} |
|
returns $datatoken to be put into hidden field |
|
|
|
=cut |
|
|
|
sub upfile_store { |
|
my $r=shift; |
|
$env{'form.upfile'}=~s/\r/\n/gs; |
|
$env{'form.upfile'}=~s/\f/\n/gs; |
|
$env{'form.upfile'}=~s/\n+/\n/gs; |
|
$env{'form.upfile'}=~s/\n+$//gs; |
|
|
|
my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}. |
|
'_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$; |
|
{ |
|
my $datafile = $r->dir_config('lonDaemons'). |
|
'/tmp/'.$datatoken.'.tmp'; |
|
if ( open(my $fh,">$datafile") ) { |
|
print $fh $env{'form.upfile'}; |
|
close($fh); |
|
} |
|
} |
|
return $datatoken; |
|
} |
|
|
|
=pod |
|
|
|
=item * load_tmp_file($r) |
|
|
|
Load uploaded file from tmp, $r should be the HTTP Request object, |
|
needs $env{'form.datatoken'}, |
|
sets $env{'form.upfile'} to the contents of the file |
|
|
|
=cut |
|
|
|
sub load_tmp_file { |
|
my $r=shift; |
|
my @studentdata=(); |
|
{ |
|
my $studentfile = $r->dir_config('lonDaemons'). |
|
'/tmp/'.$env{'form.datatoken'}.'.tmp'; |
|
if ( open(my $fh,"<$studentfile") ) { |
|
@studentdata=<$fh>; |
|
close($fh); |
|
} |
|
} |
|
$env{'form.upfile'}=join('',@studentdata); |
|
} |
|
|
|
=pod |
|
|
|
=item * upfile_record_sep() |
|
|
|
Separate uploaded file into records |
|
returns array of records, |
|
needs $env{'form.upfile'} and $env{'form.upfiletype'} |
|
|
|
=cut |
|
|
|
sub upfile_record_sep { |
|
if ($env{'form.upfiletype'} eq 'xml') { |
|
} else { |
|
my @records; |
|
foreach my $line (split(/\n/,$env{'form.upfile'})) { |
|
if ($line=~/^\s*$/) { next; } |
|
push(@records,$line); |
|
} |
|
return @records; |
|
} |
|
} |
|
|
|
=pod |
|
|
|
=item * record_sep($record) |
|
|
|
Separate a record into fields $record should be an item from the upfile_record_sep(), needs $env{'form.upfiletype'} |
|
|
|
=cut |
|
|
|
sub takeleft { |
|
my $index=shift; |
|
return substr('0000'.$index,-4,4); |
|
} |
|
|
|
sub record_sep { |
|
my $record=shift; |
|
my %components=(); |
|
if ($env{'form.upfiletype'} eq 'xml') { |
|
} elsif ($env{'form.upfiletype'} eq 'space') { |
|
my $i=0; |
|
foreach my $field (split(/\s+/,$record)) { |
|
$field=~s/^(\"|\')//; |
|
$field=~s/(\"|\')$//; |
|
$components{&takeleft($i)}=$field; |
|
$i++; |
|
} |
|
} elsif ($env{'form.upfiletype'} eq 'tab') { |
|
my $i=0; |
|
foreach my $field (split(/\t/,$record)) { |
|
$field=~s/^(\"|\')//; |
|
$field=~s/(\"|\')$//; |
|
$components{&takeleft($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{&takeleft($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; |
|
} |
|
|
|
sub get_samples { |
|
my ($records,$toget) = @_; |
|
my @samples=({}); |
|
my $got=0; |
|
foreach my $rec (@$records) { |
|
my %temp = &record_sep($rec); |
|
if (! grep(/\S/, values(%temp))) { next; } |
|
if (%temp) { |
|
$samples[$got]=\%temp; |
|
$got++; |
|
if ($got == $toget) { last; } |
|
} |
|
} |
|
return \@samples; |
|
} |
|
|
|
###################################################### |
|
###################################################### |
|
|
|
=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 $samples = &get_samples($records,3); |
|
|
|
$r->print(&mt('Samples').'<br /><table border="2"><tr>'); |
|
foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) { |
|
$r->print('<th>'.&mt('Column [_1]',($sample+1)).'</th>'); } |
|
$r->print('</tr>'); |
|
foreach my $hash (@$samples) { |
|
$r->print('<tr>'); |
|
foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) { |
|
$r->print('<td>'); |
|
if (defined($$hash{$sample})) { $r->print($$hash{$sample}); } |
|
$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 $samples = &get_samples($records,1); |
|
$r->print(&mt('Associate columns with student attributes.')."\n". |
|
'<table border="2"><tr>'. |
|
'<th>'.&mt('Attribute').'</th>'. |
|
'<th>'.&mt('Column').'</th></tr>'."\n"); |
|
foreach my $array_ref (@$d) { |
|
my ($value,$display,$defaultcol)=@{ $array_ref }; |
|
$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 my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) { |
|
$r->print('<option value="'.$sample.'"'. |
|
($sample eq $defaultcol ? ' selected="selected" ' : ''). |
|
'>Column '.($sample+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 $i=0; |
|
# |
|
my $samples = &get_samples($records,3); |
|
$r->print('<table border=2><tr><th>'. |
|
&mt('Field').'</th><th>'.&mt('Samples').'</th></tr>'); |
|
|
|
foreach my $key (sort(keys(%{ $samples->[0] }))) { |
|
$r->print('<tr><td><select name="f'.$i.'"'. |
|
' onchange="javascript:flip(this.form,'.$i.');">'); |
|
foreach my $option (@$d) { |
|
my ($value,$display,$defaultcol)=@{ $option }; |
|
$r->print('<option value="'.$value.'"'. |
|
($i eq $defaultcol ? ' selected="selected" ':'').'>'. |
|
$display.'</option>'); |
|
} |
|
$r->print('</select></td><td>'); |
|
foreach my $line (0..2) { |
|
if (defined($samples->[$line]{$key})) { |
|
$r->print($samples->[$line]{$key}."<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'. |
|
|
|
Inputs: |
|
|
|
=over 4 |
|
|
|
=item $Title: string, the title of the plot |
|
|
|
=item $xlabel: string, text describing the X-axis of the plot |
|
|
|
=item $ylabel: string, text describing the Y-axis of the plot |
|
|
|
=item $Max: scalar, the maximum Y value to use in the plot |
|
If $Max is < any data point, the graph will not be rendered. |
|
|
|
=item $colors: array ref holding the colors to be used for the data sets when |
|
they are plotted. If undefined, default values will be used. |
|
|
|
=item $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. |
|
|
|
=item If the final element of @Values is a hash reference the key/value |
|
pairs will be added to the graph definition. |
|
|
|
=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'} = &escape($Title); |
|
$ValuesHash{$id.'.xlabel'} = &escape($xlabel); |
|
$ValuesHash{$id.'.ylabel'} = &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' => &escape($Title), |
|
$id.'.xlabel' => &escape($xlabel), |
|
$id.'.ylabel' => &escape($ylabel), |
|
$id.'.y_max_value'=> $Max, |
|
$id.'.labels' => join(',',@$Xlabels), |
|
$id.'.PlotType' => 'XY', |
|
); |
|
# |
|
if (defined($colors) && ref($colors) eq 'ARRAY') { |
|
$ValuesHash{$id.'.Colors'} = join(',',@{$colors}); |
|
} |
|
# |
|
if (! ref($Ydata) || ref($Ydata) ne 'ARRAY') { |
|
return ''; |
|
} |
|
my $NumSets=1; |
|
foreach my $array (@{$Ydata}){ |
|
next if (! ref($array)); |
|
$ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array); |
|
} |
|
$ValuesHash{$id.'.NumSets'} = $NumSets-1; |
|
# |
|
# Deal with other parameters |
|
while (my ($key,$value) = each(%Values)) { |
|
$ValuesHash{$id.'.'.$key} = $value; |
|
} |
|
# |
|
&Apache::lonnet::appenv(%ValuesHash); |
|
return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />'; |
|
} |
|
|
|
############################################################ |
|
############################################################ |
|
|
|
=pod |
|
|
|
=item DrawXYYGraph |
|
|
|
Facilitates the plotting of data in an XY graph with two Y axes. |
|
Puts plot definition data into the users environment in order for |
|
graph.png to plot it. Returns an <img> tag for the plot. |
|
|
|
Inputs: |
|
|
|
=over 4 |
|
|
|
=item $Title: string, the title of the plot |
|
|
|
=item $xlabel: string, text describing the X-axis of the plot |
|
|
|
=item $ylabel: string, text describing the Y-axis of the plot |
|
|
|
=item $colors: Array ref containing the hex color codes for the data to be |
|
plotted in. If undefined, default values will be used. |
|
|
|
=item $Xlabels: Array ref containing the labels to be used for the X-axis. |
|
|
|
=item $Ydata1: The first data set |
|
|
|
=item $Min1: The minimum value of the left Y-axis |
|
|
|
=item $Max1: The maximum value of the left Y-axis |
|
|
|
=item $Ydata2: The second data set |
|
|
|
=item $Min2: The minimum value of the right Y-axis |
|
|
|
=item $Max2: The maximum value of the left Y-axis |
|
|
|
=item %Values: hash indicating or overriding any default values which are |
|
passed to graph.png. |
|
Possible values are: width, xskip, x_ticks, x_tick_offset, among others. |
|
|
|
=back |
|
|
|
Returns: |
|
|
|
An <img> tag which references graph.png and the appropriate identifying |
|
information for the plot. |
|
|
|
=cut |
|
|
|
############################################################ |
|
############################################################ |
|
sub DrawXYYGraph { |
|
my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1, |
|
$Ydata2,$Min2,$Max2,%Values)=@_; |
|
# |
|
# Create the identifier for the graph |
|
my $identifier = &get_cgi_id(); |
|
my $id = 'cgi.'.$identifier; |
|
# |
|
$Title = '' if (! defined($Title)); |
|
$xlabel = '' if (! defined($xlabel)); |
|
$ylabel = '' if (! defined($ylabel)); |
|
my %ValuesHash = |
|
( |
|
$id.'.title' => &escape($Title), |
|
$id.'.xlabel' => &escape($xlabel), |
|
$id.'.ylabel' => &escape($ylabel), |
|
$id.'.labels' => join(',',@$Xlabels), |
|
$id.'.PlotType' => 'XY', |
|
$id.'.NumSets' => 2, |
|
$id.'.two_axes' => 1, |
|
$id.'.y1_max_value' => $Max1, |
|
$id.'.y1_min_value' => $Min1, |
|
$id.'.y2_max_value' => $Max2, |
|
$id.'.y2_min_value' => $Min2, |
|
); |
|
# |
|
if (defined($colors) && ref($colors) eq 'ARRAY') { |
|
$ValuesHash{$id.'.Colors'} = join(',',@{$colors}); |
|
} |
|
# |
|
if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' || |
|
! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){ |
|
return ''; |
|
} |
|
my $NumSets=1; |
|
foreach my $array ($Ydata1,$Ydata2){ |
|
next if (! ref($array)); |
|
$ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array); |
|
} |
|
# |
|
# Deal with other parameters |
|
while (my ($key,$value) = each(%Values)) { |
|
$ValuesHash{$id.'.'.$key} = $value; |
|
} |
|
# |
|
&Apache::lonnet::appenv(%ValuesHash); |
|
return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />'; |
|
} |
|
|
|
############################################################ |
|
############################################################ |
|
|
|
=pod |
|
|
|
=back |
|
|
|
=head1 Statistics helper routines? |
|
|
|
Bad place for them but what the hell. |
|
|
|
=over 4 |
|
|
|
=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 |
|
|
|
=cut |
|
|
|
############################################################ |
|
############################################################ |
|
sub chartlink { |
|
my ($linktext, $sname, $sdomain) = @_; |
|
my $link = '<a href="/adm/statistics?reportSelected=student_assessment'. |
|
'&SelectedStudent='.&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', |
|
'Group' => '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 $udom = $env{'user.domain'}; |
|
my $uname = $env{'user.name'}; |
|
my ($prefix,$Settings) = @_; |
|
my %SaveHash; |
|
my %AppHash; |
|
while (my ($setting,$type) = each(%$Settings)) { |
|
my $basename = join('.','internal',$courseid,$prefix,$setting); |
|
my $envname = 'environment.'.$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 { |
|
&escape($_); |
|
} sort(@{$env{'form.'.$setting}})); |
|
} else { |
|
$stored_form = |
|
&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, |
|
$udom,$uname); |
|
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 = 'environment.internal.'.$courseid.'.'.$prefix. |
|
'.'.$setting; |
|
if (exists($env{$envname})) { |
|
if ($type eq 'scalar') { |
|
$env{'form.'.$setting} = $env{$envname}; |
|
} elsif ($type eq 'array') { |
|
$env{'form.'.$setting} = [ |
|
map { |
|
&unescape($_); |
|
} split(',',$env{$envname}) |
|
]; |
|
} |
|
} |
|
} |
|
} |
|
|
|
############################################################ |
|
############################################################ |
|
|
|
sub course_type { |
|
my ($cid) = @_; |
|
if (!defined($cid)) { |
|
$cid = $env{'request.course.id'}; |
|
} |
|
if (defined($env{'course.'.$cid.'type'})) { |
|
return $env{'course.'.$cid.'type'}; |
|
} else { |
|
return 'Course'; |
|
} |
|
} |
|
|
|
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 &lonhttpdurl($iconname); |
|
} |
|
|
|
sub lonhttpdurl { |
|
my ($url)=@_; |
|
my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'}; |
|
if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; } |
|
return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url; |
|
} |
|
|
|
sub connection_aborted { |
|
my ($r)=@_; |
|
$r->print(" ");$r->rflush(); |
|
my $c = $r->connection; |
|
return $c->aborted(); |
|
} |
|
|
|
# Escapes strings that may have embedded 's that will be put into |
|
# strings as 'strings'. |
|
sub escape_single { |
|
my ($input) = @_; |
|
$input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)> |
|
$input =~ s/\'/\\\'/g; # Esacpe the 's.... |
|
return $input; |
|
} |
|
|
|
# Same as escape_single, but escape's "'s This |
|
# can be used for "strings" |
|
sub escape_double { |
|
my ($input) = @_; |
|
$input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)> |
|
$input =~ s/\"/\\\"/g; # Esacpe the "s.... |
|
return $input; |
|
} |
|
|
|
# Escapes the last element of a full URL. |
|
sub escape_url { |
|
my ($url) = @_; |
|
my @urlslices = split(/\//, $url,-1); |
|
my $lastitem = &escape(pop(@urlslices)); |
|
return join('/',@urlslices).'/'.$lastitem; |
|
} |
|
=pod |
|
|
|
=back |
|
|
|
=cut |
|
|
1; |
1; |
__END__; |
__END__; |
|
|