|
version 1.4, 2001/07/30 22:24:34
|
version 1.344, 2006/04/20 02:24:08
|
|
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(); |
| |
|
| |
my $readit; |
| |
|
| |
## |
| |
## Global Variables |
| |
## |
| |
|
| |
# ----------------------------------------------- Filetypes/Languages/Copyright |
| |
my %language; |
| |
my %supported_language; |
| |
my %cprtag; |
| |
my %scprtag; |
| |
my %fe; my %fd; |
| |
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 (<$fh>) { |
| |
next if /^\#/; |
| |
chomp; |
| |
my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$_)); |
| |
$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 (<$fh>) { |
| |
next if /^\#/; |
| |
chomp; |
| |
my ($key,$val)=(split(/\s+/,$_,2)); |
| |
$cprtag{$key}=$val; |
| |
} |
| |
close($fh); |
| |
} |
| |
} |
| |
# ------------------------------------------------------------------ source copyrights |
| |
{ |
| |
my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. |
| |
'/source_copyright.tab'; |
| |
if ( open (my $fh,"<$sourcecopyrightfile") ) { |
| |
while (<$fh>) { |
| |
next if /^\#/; |
| |
chomp; |
| |
my ($key,$val)=(split(/\s+/,$_,2)); |
| |
$scprtag{$key}=$val; |
| |
} |
| |
close($fh); |
| |
} |
| |
} |
| |
|
| |
# -------------------------------------------------------------- domain designs |
| |
|
| |
my $filename; |
| |
my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; |
| |
opendir(DIR,$designdir); |
| |
while ($filename=readdir(DIR)) { |
| |
if ($filename!~/\.tab$/) { next; } |
| |
my ($domain)=($filename=~/^(\w+)\./); |
| |
{ |
| |
my $designfile = $designdir.'/'.$filename; |
| |
if ( open (my $fh,"<$designfile") ) { |
| |
while (<$fh>) { |
| |
next if /^\#/; |
| |
chomp; |
| |
my ($key,$val)=(split(/\=/,$_)); |
| |
if ($val) { $designhash{$domain.'.'.$key}=$val; } |
| |
} |
| |
close($fh); |
| |
} |
| |
} |
| |
|
| |
} |
| |
closedir(DIR); |
| |
|
| |
|
| |
# ------------------------------------------------------------- file categories |
| |
{ |
| |
my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}. |
| |
'/filecategories.tab'; |
| |
if ( open (my $fh,"<$categoryfile") ) { |
| |
while (<$fh>) { |
| |
next if /^\#/; |
| |
chomp; |
| |
my ($extension,$category)=(split(/\s+/,$_,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 (<$fh>) { |
| |
next if (/^\#/); |
| |
chomp; |
| |
my ($ending,$emb,$descr)=split(/\s+/,$_,3); |
| |
if ($descr ne '') { |
| |
$fe{$ending}=lc($emb); |
| |
$fd{$ending}=$descr; |
| |
} |
| |
} |
| |
close($fh); |
| |
} |
| |
} |
| |
&Apache::lonnet::logthis( |
| |
"<font color=yellow>INFO: Read file types</font>"); |
| |
$readit=1; |
| |
} # end of unless($readit) |
| |
|
| |
} |
| |
|
| |
############################################################### |
| |
## HTML and Javascript Helper Functions ## |
| |
############################################################### |
| |
|
| |
=pod |
| |
|
| |
=head1 HTML and Javascript Functions |
| |
|
| |
=over 4 |
| |
|
| |
=item * browser_and_searcher_javascript () |
| |
|
| |
X<browsing, javascript>X<searching, javascript>Returns a string |
| |
containing javascript with two functions, C<openbrowser> and |
| |
C<opensearcher>. Returned string does not contain E<lt>scriptE<gt> |
| |
tags. |
| |
|
| |
=item * openbrowser(formname,elementname,only,omit) [javascript] |
| |
|
| |
inputs: formname, elementname, only, omit |
| |
|
| |
formname and elementname indicate the name of the html form and name of |
| |
the element that the results of the browsing selection are to be placed in. |
| |
|
| |
Specifying 'only' will restrict the browser to displaying only files |
| |
with the given extension. Can be a comma separated list. |
| |
|
| |
Specifying 'omit' will restrict the browser to NOT displaying files |
| |
with the given extension. Can be a comma separated list. |
| |
|
| |
=item * opensearcher(formname, elementname) [javascript] |
| |
|
| |
Inputs: formname, elementname |
| |
|
| |
formname and elementname specify the name of the html form and the name |
| |
of the element the selection from the search results will be placed in. |
| |
|
| |
=cut |
| |
|
| |
sub browser_and_searcher_javascript { |
| |
my ($mode)=@_; |
| |
if (!defined($mode)) { $mode='edit'; } |
| |
my $resurl=&lastresurl(); |
| |
return <<END; |
| |
// <!-- BEGIN LON-CAPA Internal |
| |
var editbrowser = null; |
| |
function openbrowser(formname,elementname,only,omit,titleelement) { |
| |
var url = '$resurl/?'; |
| |
if (editbrowser == null) { |
| |
url += 'launch=1&'; |
| |
} |
| |
url += 'catalogmode=interactive&'; |
| |
url += 'mode=$mode&'; |
| |
url += 'form=' + formname + '&'; |
| |
if (only != null) { |
| |
url += 'only=' + only + '&'; |
| |
} else { |
| |
url += 'only=&'; |
| |
} |
| |
if (omit != null) { |
| |
url += 'omit=' + omit + '&'; |
| |
} else { |
| |
url += 'omit=&'; |
| |
} |
| |
if (titleelement != null) { |
| |
url += 'titleelement=' + titleelement + '&'; |
| |
} else { |
| |
url += 'titleelement=&'; |
| |
} |
| |
url += 'element=' + elementname + ''; |
| |
var title = 'Browser'; |
| |
var options = 'scrollbars=1,resizable=1,menubar=1,location=1'; |
| |
options += ',width=700,height=600'; |
| |
editbrowser = open(url,title,options,'1'); |
| |
editbrowser.focus(); |
| |
} |
| |
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)=@_; |
| |
return (<<ENDSTDBRW); |
| |
<script type="text/javascript" language="Javascript" > |
| |
var stdeditbrowser; |
| |
function opencrsbrowser(formname,uname,udom,desc,extra_element,multflag) { |
| |
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; |
| |
} |
| |
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)=@_; |
| |
return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele. |
| |
'","'.$udomele.'","'.$desc.'","'.$extra_element.'","'.$multflag.'");'."'>".&mt('Select Course')."</a>"; |
| |
} |
| |
|
| |
sub check_uncheck_jscript { |
| |
my $jscript = <<"ENDSCRT"; |
| |
function checkAll(field) { |
| |
if (field.length > 0) { |
| |
for (i = 0; i < field.length; i++) { |
| |
field[i].checked = true ; |
| |
} |
| |
} else { |
| |
field.checked = true |
| |
} |
| |
} |
| |
|
| |
function uncheckAll(field) { |
| |
if (field.length > 0) { |
| |
for (i = 0; i < field.length; i++) { |
| |
field[i].checked = false ; |
| |
} } else { |
| |
field.checked = false ; |
| |
} |
| |
} |
| |
ENDSCRT |
| |
return $jscript; |
| |
} |
| |
|
| |
|
| |
=pod |
| |
|
| |
=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 (\$color,\$function,\$topic,\$component_help,\$faq,\$bug,\$origurl) { |
| |
$$_ = &Apache::lonnet::escape($$_); |
| |
} |
| |
if (!$stayOnPage) { |
| |
$link = "javascript:helpMenu('open')"; |
| |
} else { |
| |
$link = "javascript:helpMenu('display')"; |
| |
} |
| |
my $banner_link = "/adm/helpmenu?page=banner&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp&stayonpage=$stayOnPage"; |
| |
my $details_link = "/adm/helpmenu?page=body&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp"; |
| |
my $template; |
| |
if ($text ne "") { |
| |
$template .= |
| |
"<table bgcolor='#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=&Apache::lonnet::unescape($topic); |
| |
$template='<table><tr><td>'. |
| |
&help_open_topic($component_help,$help_text,$stayOnPage, |
| |
$width,$height).'</td><td>'.$template. |
| |
'</td></tr></table>'; |
| |
} |
| |
} |
| |
if ($text ne '') { $template.='</td></tr></table>' }; |
| |
return $template; |
| |
} |
| |
|
| |
sub help_open_bug { |
| |
my ($topic, $text, $stayOnPage, $width, $height) = @_; |
| |
unless ($env{'user.adv'}) { return ''; } |
| |
unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; } |
| |
$text = "" if (not defined $text); |
| |
$stayOnPage = 0 if (not defined $stayOnPage); |
| |
if ($env{'browser.interface'} eq 'textual' || |
| |
$env{'environment.remote'} eq 'off' ) { |
| |
$stayOnPage=1; |
| |
} |
| |
$width = 600 if (not defined $width); |
| |
$height = 600 if (not defined $height); |
| |
|
| |
$topic=~s/\W+/\+/g; |
| |
my $link=''; |
| |
my $template=''; |
| |
my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='. |
| |
&Apache::lonnet::escape($ENV{'REQUEST_URI'}).'&component='.$topic; |
| |
if (!$stayOnPage) |
| |
{ |
| |
$link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; |
| |
} |
| |
else |
| |
{ |
| |
$link = $url; |
| |
} |
| |
# Add the text |
| |
if ($text ne "") |
| |
{ |
| |
$template .= |
| |
"<table bgcolor='#AA3333' cellspacing='1' cellpadding='1' border='0'><tr>". |
| |
"<td bgcolor='#FF5555'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>"; |
| |
} |
| |
|
| |
# Add the graphic |
| |
my $title = &mt('Report a Bug'); |
| |
my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif"); |
| |
$template .= <<"ENDTEMPLATE"; |
| |
<a href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a> |
| |
ENDTEMPLATE |
| |
if ($text ne '') { $template.='</td></tr></table>' }; |
| |
return $template; |
| |
|
| |
} |
| |
|
| |
sub help_open_faq { |
| |
my ($topic, $text, $stayOnPage, $width, $height) = @_; |
| |
unless ($env{'user.adv'}) { return ''; } |
| |
unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; } |
| |
$text = "" if (not defined $text); |
| |
$stayOnPage = 0 if (not defined $stayOnPage); |
| |
if ($env{'browser.interface'} eq 'textual' || |
| |
$env{'environment.remote'} eq 'off' ) { |
| |
$stayOnPage=1; |
| |
} |
| |
$width = 350 if (not defined $width); |
| |
$height = 400 if (not defined $height); |
| |
|
| |
$topic=~s/\W+/\+/g; |
| |
my $link=''; |
| |
my $template=''; |
| |
my $url=$Apache::lonnet::perlvar{'FAQHost'}.'/fom/cache/'.$topic.'.html'; |
| |
if (!$stayOnPage) |
| |
{ |
| |
$link = "javascript:void(open('$url', 'FAQ-O-Matic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; |
| |
} |
| |
else |
| |
{ |
| |
$link = $url; |
| |
} |
| |
|
| |
# Add the text |
| |
if ($text ne "") |
| |
{ |
| |
$template .= |
| |
"<table bgcolor='#337733' cellspacing='1' cellpadding='1' border='0'><tr>". |
| |
"<td bgcolor='#448844'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>"; |
| |
} |
| |
|
| |
# Add the graphic |
| |
my $title = &mt('View the FAQ'); |
| |
my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif"); |
| |
$template .= <<"ENDTEMPLATE"; |
| |
<a href="$link" title="$title"><img src="$faqicon" border="0" alt="(FAQ: $topic)" /></a> |
| |
ENDTEMPLATE |
| |
if ($text ne '') { $template.='</td></tr></table>' }; |
| |
return $template; |
| |
|
| |
} |
| |
|
| |
############################################################### |
| |
############################################################### |
| |
|
| |
=pod |
| |
|
| |
=item * 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 (sort values(%Apache::lonnet::hostdom)) { |
| |
push (@domains,$_) unless $seen{$_}++; |
| |
} |
| |
return @domains; |
| |
} |
| |
|
| |
# ------------------------------------------ |
| |
|
| |
sub domain_select { |
| |
my ($name,$value,$multiple)=@_; |
| |
my %domains=map { |
| |
$_ => $_.' '.$Apache::lonnet::domaindescription{$_} |
| |
} &get_domains; |
| |
if ($multiple) { |
| |
$domains{''}=&mt('Any domain'); |
| |
return &multiple_select_form($name,$value,4,\%domains); |
| |
} else { |
| |
return &select_form($name,$value,%domains); |
| |
} |
| |
} |
| |
|
| |
#------------------------------------------- |
| |
|
| |
=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="'.$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 (@keys) { |
| |
$selectform.="<option value=\"$_\" ". |
| |
($_ eq $def ? 'selected="selected" ' : ''). |
| |
">".&mt($hash{$_})."</option>\n"; |
| |
} |
| |
$selectform.="</select>"; |
| |
return $selectform; |
| |
} |
| |
|
| |
sub gradeleveldescription { |
| |
my $gradelevel=shift; |
| |
my %gradelevels=(0 => 'Not specified', |
| |
1 => 'Grade 1', |
| |
2 => 'Grade 2', |
| |
3 => 'Grade 3', |
| |
4 => 'Grade 4', |
| |
5 => 'Grade 5', |
| |
6 => 'Grade 6', |
| |
7 => 'Grade 7', |
| |
8 => 'Grade 8', |
| |
9 => 'Grade 9', |
| |
10 => 'Grade 10', |
| |
11 => 'Grade 11', |
| |
12 => 'Grade 12', |
| |
13 => 'Grade 13', |
| |
14 => '100 Level', |
| |
15 => '200 Level', |
| |
16 => '300 Level', |
| |
17 => '400 Level', |
| |
18 => 'Graduate Level'); |
| |
return &mt($gradelevels{$gradelevel}); |
| |
} |
| |
|
| |
sub select_level_form { |
| |
my ($deflevel,$name)=@_; |
| |
unless ($deflevel) { $deflevel=0; } |
| |
my $selectform = "<select name=\"$name\" size=\"1\">\n"; |
| |
for (my $i=0; $i<=18; $i++) { |
| |
$selectform.="<option value=\"$i\" ". |
| |
($i==$deflevel ? 'selected="selected" ' : ''). |
| |
">".&gradeleveldescription($i)."</option>\n"; |
| |
} |
| |
$selectform.="</select>"; |
| |
return $selectform; |
| |
} |
| |
|
| |
#------------------------------------------- |
| |
|
| |
=pod |
| |
|
| |
=item * select_dom_form($defdom,$name,$includeempty) |
| |
|
| |
Returns a string containing a <select name='$name' size='1'> form to |
| |
allow a user to select the domain to preform an operation in. |
| |
See loncreateuser.pm for an example invocation and use. |
| |
|
| |
If the $includeempty flag is set, it also includes an empty choice ("no domain |
| |
selected"); |
| |
|
| |
=cut |
| |
|
| |
#------------------------------------------- |
| |
sub select_dom_form { |
| |
my ($defdom,$name,$includeempty) = @_; |
| |
my @domains = get_domains(); |
| |
if ($includeempty) { @domains=('',@domains); } |
| |
my $selectdomain = "<select name=\"$name\" size=\"1\">\n"; |
| |
foreach (@domains) { |
| |
$selectdomain.="<option value=\"$_\" ". |
| |
($_ eq $defdom ? 'selected="selected" ' : ''). |
| |
">$_</option>\n"; |
| |
} |
| |
$selectdomain.="</select>"; |
| |
return $selectdomain; |
| |
} |
| |
|
| |
#------------------------------------------- |
| |
|
| |
=pod |
| |
|
| |
=item * get_library_servers($domain) |
| |
|
| |
Returns a hash which contains keys like '103l3' and values like |
| |
'kirk.lite.msu.edu'. All of the keys will be for machines in the |
| |
given $domain. |
| |
|
| |
=cut |
| |
|
| |
#------------------------------------------- |
| |
sub get_library_servers { |
| |
my $domain = shift; |
| |
my %library_servers; |
| |
foreach (keys(%Apache::lonnet::libserv)) { |
| |
if ($Apache::lonnet::hostdom{$_} eq $domain) { |
| |
$library_servers{$_} = $Apache::lonnet::hostname{$_}; |
| |
} |
| |
} |
| |
return %library_servers; |
| |
} |
| |
|
| |
#------------------------------------------- |
| |
|
| |
=pod |
| |
|
| |
=item * home_server_option_list($domain) |
| |
|
| |
returns a string which contains an <option> list to be used in a |
| |
<select> form input. See loncreateuser.pm for an example. |
| |
|
| |
=cut |
| |
|
| |
#------------------------------------------- |
| |
sub home_server_option_list { |
| |
my $domain = shift; |
| |
my %servers = &get_library_servers($domain); |
| |
my $result = ''; |
| |
foreach (sort keys(%servers)) { |
| |
$result.= |
| |
'<option value="'.$_.'">'.$_.' '.$servers{$_}."</option>\n"; |
| |
} |
| |
return $result; |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=back |
| |
|
| |
=cut |
| |
|
| |
############################################################### |
| |
## Decoding User Agent ## |
| |
############################################################### |
| |
|
| |
=pod |
| |
|
| |
=head1 Decoding the User Agent |
| |
|
| |
=over 4 |
| |
|
| |
=item * &decode_user_agent() |
| |
|
| |
Inputs: $r |
| |
|
| |
Outputs: |
| |
|
| |
=over 4 |
| |
|
| |
=item * $httpbrowser |
| |
|
| |
=item * $clientbrowser |
| |
|
| |
=item * $clientversion |
| |
|
| |
=item * $clientmathml |
| |
|
| |
=item * $clientunicode |
| |
|
| |
=item * $clientos |
| |
|
| |
=back |
| |
|
| |
=back |
| |
|
| |
=cut |
| |
|
| |
############################################################### |
| |
############################################################### |
| |
sub decode_user_agent { |
| |
my ($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 ('total.count','average.count') { |
| |
delete($Keywords{$_}) if (exists($Keywords{$_})); |
| |
} |
| |
return 1; |
| |
} |
| |
|
| |
################################################### |
| |
|
| |
=pod |
| |
|
| |
=item * keyword($word) |
| |
|
| |
Returns true if $word is a keyword. A keyword is a word that appears more |
| |
than the average number of times in the thesaurus database. Calls |
| |
&initialize_keywords |
| |
|
| |
=cut |
| |
|
| |
################################################### |
| |
|
| |
sub keyword { |
| |
return if (!&initialize_keywords()); |
| |
my $word=lc(shift()); |
| |
$word=~s/\W//g; |
| |
return exists($Keywords{$word}); |
| |
} |
| |
|
| |
############################################################### |
| |
|
| |
=pod |
| |
|
| |
=item * get_related_words |
| |
|
| |
Look up a word in the thesaurus. Takes a scalar argument and returns |
| |
an array of words. If the keyword is not in the thesaurus, an empty array |
| |
will be returned. The order of the words returned is determined by the |
| |
database which holds them. |
| |
|
| |
Uses global $thesaurus_db_file. |
| |
|
| |
=cut |
| |
|
| |
############################################################### |
| |
sub get_related_words { |
| |
my $keyword = shift; |
| |
my %thesaurus_db; |
| |
if (! -e $thesaurus_db_file) { |
| |
&Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ". |
| |
"failed because the file does not exist"); |
| |
return (); |
| |
} |
| |
if (! tie(%thesaurus_db,'GDBM_File', |
| |
$thesaurus_db_file,&GDBM_READER(),0640)){ |
| |
return (); |
| |
} |
| |
my @Words=(); |
| |
if (exists($thesaurus_db{$keyword})) { |
| |
$_ = $thesaurus_db{$keyword}; |
| |
(undef,@Words) = split/:/; # The first element is the number of times |
| |
# the word appears. We do not need it now. |
| |
for (my $i=0;$i<=$#Words;$i++) { |
| |
($Words[$i],undef)= split/\,/,$Words[$i]; |
| |
} |
| |
} |
| |
untie %thesaurus_db; |
| |
return @Words; |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=back |
| |
|
| |
=cut |
| |
|
| |
# -------------------------------------------------------------- Plaintext name |
| |
=pod |
| |
|
| |
=head1 User Name Functions |
| |
|
| |
=over 4 |
| |
|
| |
=item * plainname($uname,$udom,$first) |
| |
|
| |
Takes a users logon name and returns it as a string in |
| |
"first middle last generation" form |
| |
if $first is set to 'lastname' then it returns it as |
| |
'lastname generation, firstname middlename' if their is a lastname |
| |
|
| |
=cut |
| |
|
| |
|
| |
############################################################### |
| |
sub plainname { |
| |
my ($uname,$udom,$first)=@_; |
| |
my %names=&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)=@_; |
| |
return |
| |
'<a href="/adm/email?compose=individual&'. |
| |
'recname='.$username.'&recdom='.$domain.'" '. |
| |
'title="'.&mt('Send message').'">'.$link.'</a>'; |
| |
} |
| |
# --------------------------------------------------------------- Notes Wrapper |
| |
|
| |
sub noteswrapper { |
| |
my ($link,$un,$do)=@_; |
| |
return |
| |
"<a href='/adm/email?recordftf=retrieve&recname=$un&recdom=$do'>$link</a>"; |
| |
} |
| |
# ------------------------------------------------------------- Aboutme Wrapper |
| |
|
| |
sub aboutmewrapper { |
| |
my ($link,$username,$domain,$target)=@_; |
| |
return '<a href="/adm/'.$domain.'/'.$username.'/aboutme"'. |
| |
($target?' target="$target"':'').' title="'.&mt('View this users personal page').'">'.$link.'</a>'; |
| |
} |
| |
|
| |
# ------------------------------------------------------------ Syllabus Wrapper |
| |
|
| |
|
| |
sub syllabuswrapper { |
| |
my ($linktext,$coursedir,$domain,$fontcolor)=@_; |
| |
if ($fontcolor) { |
| |
$linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>'; |
| |
} |
| |
return qq{<a href="/public/$domain/$coursedir/syllabus">$linktext</a>}; |
| |
} |
| |
|
| |
sub track_student_link { |
| |
my ($linktext,$sname,$sdom,$target,$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 { |
| |
return @{$category_extensions{lc($_[0])}}; |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=item * fileembstyle() |
| |
|
| |
returns embedding style for a specified file type |
| |
|
| |
=cut |
| |
|
| |
sub fileembstyle { |
| |
return $fe{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 (&preferred_languages()) { |
| |
$languages{$_}=1; |
| |
} |
| |
&get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']); |
| |
if ($env{'form.displaylanguage'}) { |
| |
foreach (split(/\s*(\,|\;|\:)\s*/,$env{'form.displaylanguage'})) { |
| |
$languages{$_}=1; |
| |
} |
| |
} |
| |
return %languages; |
| |
} |
| |
|
| |
sub preferred_languages { |
| |
my @languages=(); |
| |
if ($env{'course.'.$env{'request.course.id'}.'.languages'}) { |
| |
@languages=(@languages,split(/\s*(\,|\;|\:)\s*/, |
| |
$env{'course.'.$env{'request.course.id'}.'.languages'})); |
| |
} |
| |
if ($env{'environment.languages'}) { |
| |
@languages=split(/\s*(\,|\;|\:)\s*/,$env{'environment.languages'}); |
| |
} |
| |
my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0]; |
| |
if ($browser) { |
| |
@languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$browser)); |
| |
} |
| |
if ($Apache::lonnet::domain_lang_def{$env{'user.domain'}}) { |
| |
@languages=(@languages, |
| |
$Apache::lonnet::domain_lang_def{$env{'user.domain'}}); |
| |
} |
| |
if ($Apache::lonnet::domain_lang_def{$env{'request.role.domain'}}) { |
| |
@languages=(@languages, |
| |
$Apache::lonnet::domain_lang_def{$env{'request.role.domain'}}); |
| |
} |
| |
if ($Apache::lonnet::domain_lang_def{ |
| |
$Apache::lonnet::perlvar{'lonDefDomain'}}) { |
| |
@languages=(@languages, |
| |
$Apache::lonnet::domain_lang_def{ |
| |
$Apache::lonnet::perlvar{'lonDefDomain'}}); |
| |
} |
| |
# turn "en-ca" into "en-ca,en" |
| |
my @genlanguages; |
| |
foreach (@languages) { |
| |
unless ($_=~/\w/) { next; } |
| |
push (@genlanguages,$_); |
| |
if ($_=~/(\-|\_)/) { |
| |
push (@genlanguages,(split(/(\-|\_)/,$_))[0]); |
| |
} |
| |
} |
| |
return @genlanguages; |
| |
} |
| |
|
| |
############################################################### |
| |
## Student Answer Attempts ## |
| |
############################################################### |
| |
|
| |
=pod |
| |
|
| |
=head1 Alternate Problem Views |
| |
|
| |
=over 4 |
| |
|
| |
=item * get_previous_attempt($symb, $username, $domain, $course, |
| |
$getattempt, $regexp, $gradesub) |
| |
|
| |
Return string with previous attempt on problem. Arguments: |
| |
|
| |
=over 4 |
| |
|
| |
=item * $symb: Problem, including path |
| |
|
| |
=item * $username: username of the desired student |
| |
|
| |
=item * $domain: domain of the desired student |
| |
|
| |
=item * $course: Course ID |
| |
|
| |
=item * $getattempt: Leave blank for all attempts, otherwise put |
| |
something |
| |
|
| |
=item * $regexp: if string matches this regexp, the string will be |
| |
sent to $gradesub |
| |
|
| |
=item * $gradesub: routine that processes the string if it matches $regexp |
| |
|
| |
=back |
| |
|
| |
The output string is a table containing all desired attempts, if any. |
| |
|
| |
=cut |
| |
|
| sub get_previous_attempt { |
sub get_previous_attempt { |
| my ($symb,$username,$domain,$course)=@_; |
my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_; |
| my $prevattempts=''; |
my $prevattempts=''; |
| |
no strict 'refs'; |
| if ($symb) { |
if ($symb) { |
| my (%returnhash)= |
my (%returnhash)= |
| &Apache::lonnet::restore($symb,$course,$domain,$username); |
&Apache::lonnet::restore($symb,$course,$domain,$username); |
|
Line 21 sub get_previous_attempt {
|
Line 2355 sub get_previous_attempt {
|
| my %lasthash=(); |
my %lasthash=(); |
| my $version; |
my $version; |
| for ($version=1;$version<=$returnhash{'version'};$version++) { |
for ($version=1;$version<=$returnhash{'version'};$version++) { |
| map { |
foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) { |
| $lasthash{$_}=$returnhash{$version.':'.$_}; |
$lasthash{$_}=$returnhash{$version.':'.$_}; |
| } sort(split(/\:/,$returnhash{$version.':keys'})); |
} |
| } |
} |
| $prevattempts='<table border=2></tr><th>History</th>'; |
$prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">'; |
| map { |
$prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>'; |
| $prevattempts.='<th>'.$_.'</th>'; |
foreach (sort(keys %lasthash)) { |
| } sort(keys %lasthash); |
my ($ign,@parts) = split(/\./,$_); |
| for ($version=1;$version<=$returnhash{'version'};$version++) { |
if ($#parts > 0) { |
| $prevattempts.='</tr><tr><th>Attempt '.$version.'</th>'; |
my $data=$parts[-1]; |
| map { |
pop(@parts); |
| $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>'; |
| |
} |
| |
} |
| |
} |
| |
if ($getattempt eq '') { |
| |
for ($version=1;$version<=$returnhash{'version'};$version++) { |
| |
$prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Transaction '.$version.'</td>'; |
| |
foreach (sort(keys %lasthash)) { |
| |
my $value; |
| |
if ($_ =~ /timestamp/) { |
| |
$value=scalar(localtime($returnhash{$version.':'.$_})); |
| |
} else { |
| |
$value=$returnhash{$version.':'.$_}; |
| |
} |
| |
$prevattempts.='<td>'.&Apache::lonnet::unescape($value).' </td>'; |
| |
} |
| |
} |
| } |
} |
| $prevattempts.='</tr><tr><th>Current</th>'; |
$prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Current</td>'; |
| map { |
foreach (sort(keys %lasthash)) { |
| $prevattempts.='<td>'.$lasthash{$_}.'</td>'; |
my $value; |
| } sort(keys %lasthash); |
if ($_ =~ /timestamp/) { |
| $prevattempts.='</tr></table>'; |
$value=scalar(localtime($lasthash{$_})); |
| |
} else { |
| |
$value=$lasthash{$_}; |
| |
} |
| |
$value=&Apache::lonnet::unescape($value); |
| |
if ($_ =~/$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 2410 sub get_previous_attempt {
|
| } |
} |
| } |
} |
| |
|
| |
sub relative_to_absolute { |
| |
my ($url,$output)=@_; |
| |
my $parser=HTML::TokeParser->new(\$output); |
| |
my $token; |
| |
my $thisdir=$url; |
| |
my @rlinks=(); |
| |
while ($token=$parser->get_token) { |
| |
if ($token->[0] eq 'S') { |
| |
if ($token->[1] eq 'a') { |
| |
if ($token->[2]->{'href'}) { |
| |
$rlinks[$#rlinks+1]=$token->[2]->{'href'}; |
| |
} |
| |
} elsif ($token->[1] eq 'img' || $token->[1] eq 'embed' ) { |
| |
$rlinks[$#rlinks+1]=$token->[2]->{'src'}; |
| |
} elsif ($token->[1] eq 'base') { |
| |
$thisdir=$token->[2]->{'href'}; |
| |
} |
| |
} |
| |
} |
| |
$thisdir=~s-/[^/]*$--; |
| |
foreach (@rlinks) { |
| |
unless (($_=~/^http:\/\//i) || |
| |
($_=~/^\//) || |
| |
($_=~/^javascript:/i) || |
| |
($_=~/^mailto:/i) || |
| |
($_=~/^\#/)) { |
| |
my $newlocation=&Apache::lonnet::hreflocation($thisdir,$_); |
| |
$output=~s/(\"|\'|\=\s*)$_(\"|\'|\s|\>)/$1$newlocation$2/; |
| |
} |
| |
} |
| |
# -------------------------------------------------- Deal with Applet codebases |
| |
$output=~s/(\<applet[^\>]+)(codebase\=[^\S\>]+)*([^\>]*)\>/$1.($2?$2:' codebase="'.$thisdir.'"').$3.'>'/gei; |
| |
return $output; |
| |
} |
| |
|
| |
=pod |
| |
|
| |
=item * get_student_view |
| |
|
| |
show a snapshot of what student was looking at |
| |
|
| |
=cut |
| |
|
| |
sub get_student_view { |
| |
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=&Apache::lonnet::escape($symb); |
| |
if ($target) { $target="target=\"$target\""; } |
| |
return '<a href="/adm/grades?&command=submission&'. |
| |
'symb='.$symb.'&student='.$uname. |
| |
'&userdom='.$udom.'" '.$target.'>'.$text.'</a>'; |
| |
} |
| |
############################################## |
| |
|
| |
=pod |
| |
|
| |
=item * &pgrdlink() |
| |
|
| |
Inputs: $text $uname $udom $symb $target |
| |
|
| |
Returns: A link to grades.pm such as to see the PGRD view of a student |
| |
|
| |
=cut |
| |
|
| |
############################################### |
| |
sub pgrdlink { |
| |
my $link=&submlink(@_); |
| |
$link=~s/(&command=submission)/$1&showgrading=yes/; |
| |
return $link; |
| |
} |
| |
############################################## |
| |
|
| |
=pod |
| |
|
| |
=item * &pprmlink() |
| |
|
| |
Inputs: $text $uname $udom $symb $target |
| |
|
| |
Returns: A link to parmset.pm such as to see the PPRM view of a |
| |
student and a specific resource |
| |
|
| |
=cut |
| |
|
| |
############################################### |
| |
sub pprmlink { |
| |
my ($text,$uname,$udom,$symb,$target)=@_; |
| |
if (!($uname && $udom)) { |
| |
(my $cursymb, my $courseid,$udom,$uname)= |
| |
&Apache::lonxml::whichuser($symb); |
| |
if (!$symb) { $symb=$cursymb; } |
| |
} |
| |
if (!$symb) { $symb=&Apache::lonnet::symbread(); } |
| |
$symb=&Apache::lonnet::escape($symb); |
| |
if ($target) { $target="target=\"$target\""; } |
| |
return '<a href="/adm/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 maketime { |
| |
my %th=@_; |
| |
return POSIX::mktime( |
| |
($th{'seconds'},$th{'minutes'},$th{'hours'}, |
| |
$th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1)); |
| |
} |
| |
|
| |
######################################### |
| |
|
| |
sub findallcourses { |
| |
my %courses=(); |
| |
my $now=time; |
| |
foreach (keys %env) { |
| |
if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) { |
| |
my ($starttime,$endtime)=$env{$_}; |
| |
my $active=1; |
| |
if ($starttime) { |
| |
if ($now<$starttime) { $active=0; } |
| |
} |
| |
if ($endtime) { |
| |
if ($now>$endtime) { $active=0; } |
| |
} |
| |
if ($active) { $courses{$1.'_'.$2}=1; } |
| |
} |
| |
} |
| |
return keys %courses; |
| |
} |
| |
|
| |
############################################### |
| |
############################################### |
| |
|
| |
=pod |
| |
|
| |
=head1 Domain Template Functions |
| |
|
| |
=over 4 |
| |
|
| |
=item * &determinedomain() |
| |
|
| |
Inputs: $domain (usually will be undef) |
| |
|
| |
Returns: Determines which domain should be used for designs |
| |
|
| |
=cut |
| |
|
| |
############################################### |
| |
sub determinedomain { |
| |
my $domain=shift; |
| |
if (! $domain) { |
| |
# Determine domain if we have not been given one |
| |
$domain = $Apache::lonnet::perlvar{'lonDefDomain'}; |
| |
if ($env{'user.domain'}) { $domain=$env{'user.domain'}; } |
| |
if ($env{'request.role.domain'}) { |
| |
$domain=$env{'request.role.domain'}; |
| |
} |
| |
} |
| |
return $domain; |
| |
} |
| |
############################################### |
| |
=pod |
| |
|
| |
=item * &domainlogo() |
| |
|
| |
Inputs: $domain (usually will be undef) |
| |
|
| |
Returns: A link to a domain logo, if the domain logo exists. |
| |
If the domain logo does not exist, a description of the domain. |
| |
|
| |
=cut |
| |
|
| |
############################################### |
| |
sub domainlogo { |
| |
my $domain = &determinedomain(shift); |
| |
# See if there is a logo |
| |
if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') { |
| |
my $logo=&lonhttpdurl("/adm/lonDomLogos/$domain.gif"); |
| |
return '<img src="'.$logo.'" alt="'.$domain.'" />'; |
| |
} elsif(exists($Apache::lonnet::domaindescription{$domain})) { |
| |
return $Apache::lonnet::domaindescription{$domain}; |
| |
} else { |
| |
return ''; |
| |
} |
| |
} |
| |
############################################## |
| |
|
| |
=pod |
| |
|
| |
=item * &designparm() |
| |
|
| |
Inputs: $which parameter; $domain (usually will be undef) |
| |
|
| |
Returns: value of designparamter $which |
| |
|
| |
=cut |
| |
|
| |
############################################## |
| |
sub designparm { |
| |
my ($which,$domain)=@_; |
| |
if ($env{'browser.blackwhite'} eq 'on') { |
| |
if ($which=~/\.(font|alink|vlink|link)$/) { |
| |
return '#000000'; |
| |
} |
| |
if ($which=~/\.(pgbg|sidebg)$/) { |
| |
return '#FFFFFF'; |
| |
} |
| |
if ($which=~/\.tabbg$/) { |
| |
return '#CCCCCC'; |
| |
} |
| |
} |
| |
if ($env{'environment.color.'.$which}) { |
| |
return $env{'environment.color.'.$which}; |
| |
} |
| |
$domain=&determinedomain($domain); |
| |
if ($designhash{$domain.'.'.$which}) { |
| |
return $designhash{$domain.'.'.$which}; |
| |
} else { |
| |
return $designhash{'default.'.$which}; |
| |
} |
| |
} |
| |
|
| |
############################################### |
| |
############################################### |
| |
|
| |
=pod |
| |
|
| |
=back |
| |
|
| |
=head1 HTTP Helpers |
| |
|
| |
=over 4 |
| |
|
| |
=item * &bodytag() |
| |
|
| |
Returns a uniform header for LON-CAPA web pages. |
| |
|
| |
Inputs: |
| |
|
| |
=over 4 |
| |
|
| |
=item * $title, A title to be displayed on the page. |
| |
|
| |
=item * $function, the current role (can be undef). |
| |
|
| |
=item * $addentries, extra parameters for the <body> tag. |
| |
|
| |
=item * $bodyonly, if defined, only return the <body> tag. |
| |
|
| |
=item * $domain, if defined, force a given domain. |
| |
|
| |
=item * $forcereg, if page should register as content page (relevant for |
| |
text interface only) |
| |
|
| |
=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 |
| |
|
| |
|
| |
=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)=@_; |
| |
|
| |
$title=&mt($title); |
| |
|
| |
$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 = $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) |
| |
=&Apache::lonnet::plaintext((split(/\./,$env{'request.role'}))[0]); |
| |
# realm |
| |
if ($env{'request.course.id'}) { |
| |
$realm= |
| |
$env{'course.'.$env{'request.course.id'}.'.description'}; |
| |
} |
| |
unless ($realm) { $realm=' '; } |
| |
# Set messages |
| |
my $messages=&domainlogo($domain); |
| |
# Port for miniserver |
| |
my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'}; |
| |
if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; } |
| |
|
| |
my $extra_body_attr = &make_attr_string($forcereg,$addentries); |
| |
|
| |
# construct main body tag |
| |
my $bodytag = <<END; |
| |
<body $extra_body_attr> |
| |
END |
| |
|
| |
$bodytag .= &Apache::lontexconvert::init_math_support(); |
| |
|
| |
my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'. |
| |
$lonhttpdPort.$img.'" alt="'.$function.'" />'; |
| |
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; |
| |
} elsif ($env{'environment.remote'} eq 'off') { |
| |
# No Remote |
| |
my $roleinfo=(<<ENDROLE); |
| |
<td bgcolor="$tabbg" align="right"> |
| |
<font size="2" face="Arial, Helvetica, sans-serif"> |
| |
$env{'environment.firstname'} |
| |
$env{'environment.middlename'} |
| |
$env{'environment.lastname'} |
| |
$env{'environment.generation'} |
| |
</font> |
| |
<br /> |
| |
<font size="2" face="Arial, Helvetica, sans-serif">$role</font> |
| |
<br /> |
| |
<font size="2" face="Arial, Helvetica, sans-serif">$realm</font> |
| |
</td> |
| |
ENDROLE |
| |
my $titleinfo = '<font face="Arial, Helvetica, sans-serif" size="+3" color="'. |
| |
$font.'"><b>'.$title.'</b></font>'; |
| |
if ($customtitle) { |
| |
$titleinfo = $customtitle; |
| |
} |
| |
|
| |
if ($env{'request.state'} eq 'construct') { |
| |
my ($uname,$thisdisfn)= |
| |
($env{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|); |
| |
my $formaction='/priv/'.$uname.'/'.$thisdisfn; |
| |
$formaction=~s/\/+/\//g; |
| |
unless ($customtitle) { #this is for resources; directories have customtitle, and crumbs and select recent are created in lonpubdir.pm |
| |
my $parentpath = ''; |
| |
my $lastitem = ''; |
| |
if ($thisdisfn =~ m-(.+/)([^/]*)$-) { |
| |
$parentpath = $1; |
| |
$lastitem = $2; |
| |
} else { |
| |
$lastitem = $thisdisfn; |
| |
} |
| |
$titleinfo = &Apache::loncommon::help_open_menu('','','','',3,'Authoring'). |
| |
'<font face="Arial, Helvetica, sans-serif"><b>Construction Space</b>:</font> '. |
| |
'<form name="dirs" method="post" action="'.$formaction |
| |
.'" target="_top"><tt><b>' |
| |
.&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv','','+1',1)."<font size=\"+1\">$lastitem</font></b></tt><br />" |
| |
.&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()') |
| |
.'</form>' |
| |
.&Apache::lonmenu::constspaceform(); |
| |
|
| |
} |
| |
$forcereg=1; |
| |
} |
| |
my $titletable; |
| |
if (!$notitle) { |
| |
$titletable = |
| |
'<table bgcolor="'.$pgbg.'" width="100%" border="0" '. |
| |
'cellspacing="3" cellpadding="3">'. |
| |
'<tr><td bgcolor="'.$tabbg.'">'. |
| |
$titleinfo.'</td>'.$roleinfo.'</tr></table>'; |
| |
} |
| |
if ($env{'request.state'} eq 'construct') { |
| |
if ($notopbar) { |
| |
$bodytag .= $titletable; |
| |
} else { |
| |
$bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg, |
| |
$titletable); |
| |
} |
| |
} else { |
| |
if ($notopbar) { |
| |
$bodytag .= $titletable; |
| |
} else { |
| |
$bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg). |
| |
$titletable; |
| |
} |
| |
} |
| |
return $bodytag; |
| |
} |
| |
|
| |
# |
| |
# Top frame rendering, Remote is up |
| |
# |
| |
my $titleinfo = ' <font size="5" face="Arial, Helvetica, sans-serif"><b>'.$title.'</b></font>'; |
| |
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 = '('.$dc_info.')'; |
| |
} |
| |
# Explicit link to get inline menu |
| |
my $menu='<br /><font size="2" face="Arial, Helvetica, sans-serif"> <a href="/adm/remote?action=collapse">'.&mt('Switch to Inline Menu Mode').'</a></font>'; |
| |
# |
| |
if ($notitle) { |
| |
return $bodytag; |
| |
} |
| |
return(<<ENDBODY); |
| |
$bodytag |
| |
<table width="100%" cellspacing="0" border="0" cellpadding="0"> |
| |
<tr><td bgcolor="$sidebg"> |
| |
$upperleft</td> |
| |
<td bgcolor="$sidebg" align="right">$messages </td> |
| |
</tr> |
| |
<tr> |
| |
<td rowspan="3" bgcolor="$tabbg"> |
| |
$titleinfo $dc_info $menu |
| |
</td><td bgcolor="$tabbg" align="right"> |
| |
<font size="2" face="Arial, Helvetica, sans-serif"> |
| |
$env{'environment.firstname'} |
| |
$env{'environment.middlename'} |
| |
$env{'environment.lastname'} |
| |
$env{'environment.generation'} |
| |
</font> |
| |
</td> |
| |
</tr> |
| |
<tr><td bgcolor="$tabbg" align="right"> |
| |
<font size="2" face="Arial, Helvetica, sans-serif">$role</font> |
| |
</td></tr> |
| |
<tr> |
| |
<td bgcolor="$tabbg" align="right"><font size="2" face="Arial, Helvetica, sans-serif">$realm</font> </td></tr> |
| |
</table><br /> |
| |
ENDBODY |
| |
} |
| |
|
| |
sub 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; |
| |
} |
| |
|
| |
sub standard_css { |
| |
return <<END; |
| |
<style type="text/css"> |
| |
h1, h2, h3, th { font-family: Arial, Helvetica, sans-serif } |
| |
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; } |
| |
.filename {font-family: monospace;} |
| |
</style> |
| |
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) |
| |
=back |
| |
|
| |
=cut |
| |
|
| |
sub headtag { |
| |
my ($title,$head_extra,$args) = @_; |
| |
|
| |
my $result = |
| |
'<head>'. |
| |
&standard_css(). |
| |
&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 |
| |
|
| |
=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') { |
| |
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'}); |
| |
} |
| |
} |
| |
|
| |
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) = @_; |
| |
#&Apache::lonnet::logthis("end_page ".join(':',caller(0))); |
| |
$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{</script>}{</scrip'+'t>}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; |
| |
} |
| |
############################################### |
| |
|
| |
=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/group. |
| |
|
| |
Outputs: |
| |
role status: active, previous or future. |
| |
|
| |
=cut |
| |
|
| |
sub check_user_status { |
| |
my ($udom,$uname,$cdom,$crs,$role,$secgrp) = @_; |
| |
my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname); |
| |
my @uroles = keys %userinfo; |
| |
my $srchstr; |
| |
my $active_chk = 'none'; |
| |
if (@uroles > 0) { |
| |
if (($role eq 'cc') || ($secgrp eq '') || (!defined($secgrp))) { |
| |
$srchstr = '/'.$cdom.'/'.$crs.'_'.$role; |
| |
} else { |
| |
$srchstr = '/'.$cdom.'/'.$crs.'/'.$secgrp.'_'.$role; } |
| |
if (grep/^$srchstr$/,@uroles) { |
| |
my $role_end = 0; |
| |
my $role_start = 0; |
| |
$active_chk = 'active'; |
| |
if ($userinfo{$srchstr} =~ m/^($role)_(\d+)/) { |
| |
$role_end = $2; |
| |
if ($userinfo{$srchstr} =~ m/^($role)_($role_end)_(\d+)$/) { |
| |
$role_start = $3; |
| |
} |
| |
} |
| |
if ($role_start > 0) { |
| |
if (time < $role_start) { |
| |
$active_chk = 'future'; |
| |
} |
| |
} |
| |
if ($role_end > 0) { |
| |
if (time > $role_end) { |
| |
$active_chk = 'previous'; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return $active_chk; |
| |
} |
| |
|
| |
############################################### |
| |
|
| |
=pod |
| |
|
| |
=item get_sections |
| |
|
| |
Determines all the sections for a course including |
| |
sections with students and sections containing other roles. |
| |
Incoming parameters: domain, course number, reference to |
| |
section hash (keys to be section/group IDs), reference to |
| |
array containing roles for which sections should be gathered |
| |
(optional). If the fourth argument is undefined, sections |
| |
are gathered for any role. |
| |
|
| |
Returns number of sections. |
| |
|
| |
=cut |
| |
|
| |
############################################### |
| |
sub get_sections { |
| |
my ($cdom,$cnum,$sectioncount,$possible_roles) = @_; |
| |
if (!($cdom && $cnum)) { return 0; } |
| |
my $numsections = 0; |
| |
|
| |
if (!defined($possible_roles) || (grep/^st$/,@$possible_roles)) { |
| |
my ($classlist) = &Apache::loncoursedata::get_classlist($cdom,$cnum); |
| |
my $sec_index = &Apache::loncoursedata::CL_SECTION(); |
| |
my $status_index = &Apache::loncoursedata::CL_STATUS(); |
| |
while (my ($student,$data) = each %$classlist) { |
| |
my ($section,$status) = ($data->[$sec_index], |
| |
$data->[$status_index]); |
| |
unless ($section eq '-1' || $section =~ /^\s*$/) { |
| |
if (!defined($$sectioncount{$section})) { $numsections++; } |
| |
$$sectioncount{$section}++; |
| |
} |
| |
} |
| |
} |
| |
my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum); |
| |
foreach my $user (sort(keys(%courseroles))) { |
| |
if ($user !~ /^(\w{2})/) { next; } |
| |
my ($role) = ($user =~ /^(\w{2})/); |
| |
if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; } |
| |
my $section; |
| |
if ($role eq 'cr' && |
| |
$user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) { |
| |
$section=$1; |
| |
} |
| |
if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { $section=$1; } |
| |
if (!defined($section) || $section eq '-1') { next; } |
| |
if (!defined($$sectioncount{$section})) { $numsections++; } |
| |
$$sectioncount{$section}++; |
| |
} |
| |
return $numsections; |
| |
} |
| |
|
| |
############################################### |
| |
|
| |
=pod |
| |
|
| |
=item coursegroups |
| |
|
| |
Retrieve information about groups in a course, |
| |
|
| |
Input: |
| |
1. Reference to hash to populate with group information. |
| |
2. Optional course domain |
| |
3. Optional course number |
| |
4. Optional group name |
| |
|
| |
Course domain and number will be taken from user's |
| |
environment if not supplied. Optional group name will' |
| |
be passed to lonnet::get_coursegroups() as a regexp to |
| |
use in the call to the dump function. |
| |
|
| |
Output |
| |
Returns number of groups in the course (subject to the |
| |
optional group name filter). |
| |
|
| |
Side effects: |
| |
Populates the referenced curr_groups hash, with key, |
| |
value pairs. Keys are group names, corresponding values |
| |
are scalars containing group information in XML. This |
| |
can be sent to &get_group_settings() to be parsed. |
| |
|
| |
=cut |
| |
|
| |
############################################### |
| |
|
| |
sub coursegroups { |
| |
my ($curr_groups,$cdom,$cnum,$group) = @_; |
| |
my $numgroups; |
| |
if (!defined($cdom) || !defined($cnum)) { |
| |
my $cid = $env{'request.course.id'}; |
| |
$cdom = $env{'course.'.$cid.'.domain'}; |
| |
$cnum = $env{'course.'.$cid.'.num'}; |
| |
} |
| |
%{$curr_groups} = &Apache::lonnet::get_coursegroups($cdom,$cnum,$group); |
| |
my ($tmp) = keys(%{$curr_groups}); |
| |
if ($tmp=~/^error:/) { |
| |
unless ($tmp eq 'error: 2 tie(GDBM) Failed while attempting dump') { |
| |
&logthis('Error retrieving groups: '.$tmp.' in '.$cnum.':'. |
| |
$cdom); |
| |
} |
| |
$numgroups = 0; |
| |
} else { |
| |
$numgroups = keys(%{$curr_groups}); |
| |
} |
| |
return $numgroups; |
| |
} |
| |
|
| |
############################################### |
| |
|
| |
=pod |
| |
|
| |
=item get_group_settings |
| |
|
| |
Uses TokeParser to extract group information from the |
| |
XML used to describe course groups. |
| |
|
| |
Input: |
| |
Scalar containing XML - as retrieved from &coursegroups(). |
| |
|
| |
Output: |
| |
Hash containing group information as key=values for (a), and |
| |
hash of hashes for (b) |
| |
|
| |
Keys (in two categories): |
| |
(a) groupname, creator, creation, modified, startdate,enddate. |
| |
Corresponding values are name of the group, creator of the group |
| |
(username:domain), UNIX time for date group was created, and |
| |
settings were last modified, and default start and end access |
| |
times for group members. |
| |
|
| |
(b) functions returned in hash of hashes. |
| |
Outer hash key is functions. |
| |
Inner hash keys are chat,discussion,email,files,homepage,roster. |
| |
Corresponding values are either on or off, depending on |
| |
whether this type of functionality is available for the group. |
| |
|
| |
=cut |
| |
|
| |
############################################### |
| |
|
| |
sub get_group_settings { |
| |
my ($groupinfo)=@_; |
| |
my $parser=HTML::TokeParser->new(\$groupinfo); |
| |
my $token; |
| |
my $tool = ''; |
| |
my $role = ''; |
| |
my %content=(); |
| |
while ($token=$parser->get_token) { |
| |
if ($token->[0] eq 'S') { |
| |
my $entry=$token->[1]; |
| |
if ($entry eq 'functions' || $entry eq 'autosec') { |
| |
%{$content{$entry}} = (); |
| |
$tool = $entry; |
| |
} elsif ($entry eq 'role') { |
| |
if ($tool eq 'autosec') { |
| |
$role = $token->[2]{id}; |
| |
} |
| |
} else { |
| |
my $value=$parser->get_text('/'.$entry); |
| |
if ($entry eq 'name') { |
| |
if ($tool eq 'functions') { |
| |
my $function = $token->[2]{id}; |
| |
$content{$tool}{$function} = $value; |
| |
} |
| |
} elsif ($entry eq 'groupname') { |
| |
$content{$entry}=&Apache::lonnet::unescape($value); |
| |
} elsif (($entry eq 'roles') || ($entry eq 'types') || |
| |
($entry eq 'sectionpick') || ($entry eq 'defpriv')) { |
| |
push(@{$content{$entry}},$value); |
| |
} elsif ($entry eq 'section') { |
| |
if ($tool eq 'autosec' && $role ne '') { |
| |
push(@{$content{$tool}{$role}},$value); |
| |
} |
| |
} else { |
| |
$content{$entry}=$value; |
| |
} |
| |
} |
| |
} elsif ($token->[0] eq 'E') { |
| |
if ($token->[1] eq 'functions' || $token->[1] eq 'autosec') { |
| |
$tool = ''; |
| |
} elsif ($token->[1] eq 'role') { |
| |
$role = ''; |
| |
} |
| |
|
| |
} |
| |
} |
| |
return %content; |
| |
} |
| |
|
| |
sub check_group_access { |
| |
my ($group) = @_; |
| |
my $access = 1; |
| |
my $now = time; |
| |
my ($start,$end) = split(/\./,$env{'user.role.gr/'.$env{'request.course,id'}.'/'.$group}); |
| |
if (($end!=0) && ($end<$now)) { $access = 0; } |
| |
if (($start!=0) && ($start>$now)) { $access=0; } |
| |
return $access; |
| |
} |
| |
|
| |
############################################### |
| |
|
| |
=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; |
| |
} |
| |
|
| |
=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 (split(/&/,$query)) { |
| |
my ($name, $value) = split(/=/,$_); |
| |
$name = &Apache::lonnet::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 (split(/\s+/,$record)) { |
| |
my $field=$_; |
| |
$field=~s/^(\"|\')//; |
| |
$field=~s/(\"|\')$//; |
| |
$components{&takeleft($i)}=$field; |
| |
$i++; |
| |
} |
| |
} elsif ($env{'form.upfiletype'} eq 'tab') { |
| |
my $i=0; |
| |
foreach (split(/\t/,$record)) { |
| |
my $field=$_; |
| |
$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 (sort({$a <=> $b} keys(%{ $samples->[0] }))) { |
| |
$r->print('<th>'.&mt('Column [_1]',($_+1)).'</th>'); } |
| |
$r->print('</tr>'); |
| |
foreach my $hash (@$samples) { |
| |
$r->print('<tr>'); |
| |
foreach (sort({$a <=> $b} keys(%{ $samples->[0] }))) { |
| |
$r->print('<td>'); |
| |
if (defined($$hash{$_})) { $r->print($$hash{$_}); } |
| |
$r->print('</td>'); |
| |
} |
| |
$r->print('</tr>'); |
| |
} |
| |
$r->print('</tr></table><br />'."\n"); |
| |
} |
| |
|
| |
###################################################### |
| |
###################################################### |
| |
|
| |
=pod |
| |
|
| |
=item * csv_print_select_table($r,$records,$d) |
| |
|
| |
Prints a table to create associations between values and table columns. |
| |
|
| |
$r is an Apache Request ref, |
| |
$records is an arrayref from &Apache::loncommon::upfile_record_sep, |
| |
$d is an array of 2 element arrays (internal name, displayed name,defaultcol) |
| |
|
| |
=cut |
| |
|
| |
###################################################### |
| |
###################################################### |
| |
sub csv_print_select_table { |
| |
my ($r,$records,$d) = @_; |
| |
my $i=0; |
| |
my $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 (@$d) { |
| |
my ($value,$display,$defaultcol)=@{ $_ }; |
| |
$r->print('<tr><td>'.$display.'</td>'); |
| |
|
| |
$r->print('<td><select name=f'.$i. |
| |
' onchange="javascript:flip(this.form,'.$i.');">'); |
| |
$r->print('<option value="none"></option>'); |
| |
foreach (sort({$a <=> $b} keys(%{ $samples->[0] }))) { |
| |
$r->print('<option value="'.$_.'"'. |
| |
($_ eq $defaultcol ? ' selected="selected" ' : ''). |
| |
'>Column '.($_+1).'</option>'); |
| |
} |
| |
$r->print('</select></td></tr>'."\n"); |
| |
$i++; |
| |
} |
| |
$i--; |
| |
return $i; |
| |
} |
| |
|
| |
###################################################### |
| |
###################################################### |
| |
|
| |
=pod |
| |
|
| |
=item * csv_samples_select_table($r,$records,$d) |
| |
|
| |
Prints a table of sample values from the upload and can make associate samples to internal names. |
| |
|
| |
$r is an Apache Request ref, |
| |
$records is an arrayref from &Apache::loncommon::upfile_record_sep, |
| |
$d is an array of 2 element arrays (internal name, displayed name) |
| |
|
| |
=cut |
| |
|
| |
###################################################### |
| |
###################################################### |
| |
sub csv_samples_select_table { |
| |
my ($r,$records,$d) = @_; |
| |
my $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'} = &Apache::lonnet::escape($Title); |
| |
$ValuesHash{$id.'.xlabel'} = &Apache::lonnet::escape($xlabel); |
| |
$ValuesHash{$id.'.ylabel'} = &Apache::lonnet::escape($ylabel); |
| |
$ValuesHash{$id.'.y_max_value'} = $Max; |
| |
$ValuesHash{$id.'.NumBars'} = $NumBars; |
| |
$ValuesHash{$id.'.NumSets'} = $NumSets; |
| |
$ValuesHash{$id.'.PlotType'} = 'bar'; |
| |
$ValuesHash{$id.'.Colors'} = join(',',@{$colors}); |
| |
$ValuesHash{$id.'.height'} = $height; |
| |
$ValuesHash{$id.'.width'} = $width; |
| |
$ValuesHash{$id.'.xskip'} = $xskip; |
| |
$ValuesHash{$id.'.bar_width'} = $bar_width; |
| |
$ValuesHash{$id.'.labels'} = join(',',@Labels); |
| |
# |
| |
# Deal with other parameters |
| |
while (my ($key,$value) = each(%$extra_settings)) { |
| |
$ValuesHash{$id.'.'.$key} = $value; |
| |
} |
| |
# |
| |
&Apache::lonnet::appenv(%ValuesHash); |
| |
return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />'; |
| |
} |
| |
|
| |
############################################################ |
| |
############################################################ |
| |
|
| |
=pod |
| |
|
| |
=item DrawXYGraph |
| |
|
| |
Facilitates the plotting of data in an XY graph. |
| |
Puts plot definition data into the users environment in order for |
| |
graph.png to plot it. Returns an <img> tag for the plot. |
| |
|
| |
Inputs: |
| |
|
| |
=over 4 |
| |
|
| |
=item $Title: string, the title of the plot |
| |
|
| |
=item $xlabel: string, text describing the X-axis of the plot |
| |
|
| |
=item $ylabel: string, text describing the Y-axis of the plot |
| |
|
| |
=item $Max: scalar, the maximum Y value to use in the plot |
| |
If $Max is < any data point, the graph will not be rendered. |
| |
|
| |
=item $colors: Array ref containing the hex color codes for the data to be |
| |
plotted in. If undefined, default values will be used. |
| |
|
| |
=item $Xlabels: Array ref containing the labels to be used for the X-axis. |
| |
|
| |
=item $Ydata: Array ref containing Array refs. |
| |
Each of the contained arrays will be plotted as a separate curve. |
| |
|
| |
=item %Values: hash indicating or overriding any default values which are |
| |
passed to graph.png. |
| |
Possible values are: width, xskip, x_ticks, x_tick_offset, among others. |
| |
|
| |
=back |
| |
|
| |
Returns: |
| |
|
| |
An <img> tag which references graph.png and the appropriate identifying |
| |
information for the plot. |
| |
|
| |
=cut |
| |
|
| |
############################################################ |
| |
############################################################ |
| |
sub DrawXYGraph { |
| |
my ($Title,$xlabel,$ylabel,$Max,$colors,$Xlabels,$Ydata,%Values)=@_; |
| |
# |
| |
# Create the identifier for the graph |
| |
my $identifier = &get_cgi_id(); |
| |
my $id = 'cgi.'.$identifier; |
| |
# |
| |
$Title = '' if (! defined($Title)); |
| |
$xlabel = '' if (! defined($xlabel)); |
| |
$ylabel = '' if (! defined($ylabel)); |
| |
my %ValuesHash = |
| |
( |
| |
$id.'.title' => &Apache::lonnet::escape($Title), |
| |
$id.'.xlabel' => &Apache::lonnet::escape($xlabel), |
| |
$id.'.ylabel' => &Apache::lonnet::escape($ylabel), |
| |
$id.'.y_max_value'=> $Max, |
| |
$id.'.labels' => join(',',@$Xlabels), |
| |
$id.'.PlotType' => 'XY', |
| |
); |
| |
# |
| |
if (defined($colors) && ref($colors) eq 'ARRAY') { |
| |
$ValuesHash{$id.'.Colors'} = join(',',@{$colors}); |
| |
} |
| |
# |
| |
if (! ref($Ydata) || ref($Ydata) ne 'ARRAY') { |
| |
return ''; |
| |
} |
| |
my $NumSets=1; |
| |
foreach my $array (@{$Ydata}){ |
| |
next if (! ref($array)); |
| |
$ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array); |
| |
} |
| |
$ValuesHash{$id.'.NumSets'} = $NumSets-1; |
| |
# |
| |
# Deal with other parameters |
| |
while (my ($key,$value) = each(%Values)) { |
| |
$ValuesHash{$id.'.'.$key} = $value; |
| |
} |
| |
# |
| |
&Apache::lonnet::appenv(%ValuesHash); |
| |
return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />'; |
| |
} |
| |
|
| |
############################################################ |
| |
############################################################ |
| |
|
| |
=pod |
| |
|
| |
=item DrawXYYGraph |
| |
|
| |
Facilitates the plotting of data in an XY graph with two Y axes. |
| |
Puts plot definition data into the users environment in order for |
| |
graph.png to plot it. Returns an <img> tag for the plot. |
| |
|
| |
Inputs: |
| |
|
| |
=over 4 |
| |
|
| |
=item $Title: string, the title of the plot |
| |
|
| |
=item $xlabel: string, text describing the X-axis of the plot |
| |
|
| |
=item $ylabel: string, text describing the Y-axis of the plot |
| |
|
| |
=item $colors: Array ref containing the hex color codes for the data to be |
| |
plotted in. If undefined, default values will be used. |
| |
|
| |
=item $Xlabels: Array ref containing the labels to be used for the X-axis. |
| |
|
| |
=item $Ydata1: The first data set |
| |
|
| |
=item $Min1: The minimum value of the left Y-axis |
| |
|
| |
=item $Max1: The maximum value of the left Y-axis |
| |
|
| |
=item $Ydata2: The second data set |
| |
|
| |
=item $Min2: The minimum value of the right Y-axis |
| |
|
| |
=item $Max2: The maximum value of the left Y-axis |
| |
|
| |
=item %Values: hash indicating or overriding any default values which are |
| |
passed to graph.png. |
| |
Possible values are: width, xskip, x_ticks, x_tick_offset, among others. |
| |
|
| |
=back |
| |
|
| |
Returns: |
| |
|
| |
An <img> tag which references graph.png and the appropriate identifying |
| |
information for the plot. |
| |
|
| |
=cut |
| |
|
| |
############################################################ |
| |
############################################################ |
| |
sub DrawXYYGraph { |
| |
my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1, |
| |
$Ydata2,$Min2,$Max2,%Values)=@_; |
| |
# |
| |
# Create the identifier for the graph |
| |
my $identifier = &get_cgi_id(); |
| |
my $id = 'cgi.'.$identifier; |
| |
# |
| |
$Title = '' if (! defined($Title)); |
| |
$xlabel = '' if (! defined($xlabel)); |
| |
$ylabel = '' if (! defined($ylabel)); |
| |
my %ValuesHash = |
| |
( |
| |
$id.'.title' => &Apache::lonnet::escape($Title), |
| |
$id.'.xlabel' => &Apache::lonnet::escape($xlabel), |
| |
$id.'.ylabel' => &Apache::lonnet::escape($ylabel), |
| |
$id.'.labels' => join(',',@$Xlabels), |
| |
$id.'.PlotType' => 'XY', |
| |
$id.'.NumSets' => 2, |
| |
$id.'.two_axes' => 1, |
| |
$id.'.y1_max_value' => $Max1, |
| |
$id.'.y1_min_value' => $Min1, |
| |
$id.'.y2_max_value' => $Max2, |
| |
$id.'.y2_min_value' => $Min2, |
| |
); |
| |
# |
| |
if (defined($colors) && ref($colors) eq 'ARRAY') { |
| |
$ValuesHash{$id.'.Colors'} = join(',',@{$colors}); |
| |
} |
| |
# |
| |
if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' || |
| |
! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){ |
| |
return ''; |
| |
} |
| |
my $NumSets=1; |
| |
foreach my $array ($Ydata1,$Ydata2){ |
| |
next if (! ref($array)); |
| |
$ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array); |
| |
} |
| |
# |
| |
# Deal with other parameters |
| |
while (my ($key,$value) = each(%Values)) { |
| |
$ValuesHash{$id.'.'.$key} = $value; |
| |
} |
| |
# |
| |
&Apache::lonnet::appenv(%ValuesHash); |
| |
return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />'; |
| |
} |
| |
|
| |
############################################################ |
| |
############################################################ |
| |
|
| |
=pod |
| |
|
| |
=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='.&Apache::lonnet::escape($sname.':'.$sdomain). |
| |
'&chartoutputmode='.HTML::Entities::encode('html, with all links'). |
| |
'">'.$linktext.'</a>'; |
| |
} |
| |
|
| |
####################################################### |
| |
####################################################### |
| |
|
| |
=pod |
| |
|
| |
=head1 Course Environment Routines |
| |
|
| |
=over 4 |
| |
|
| |
=item &restore_course_settings |
| |
|
| |
=item &store_course_settings |
| |
|
| |
Restores/Store indicated form parameters from the course environment. |
| |
Will not overwrite existing values of the form parameters. |
| |
|
| |
Inputs: |
| |
a scalar describing the data (e.g. 'chart', 'problem_analysis') |
| |
|
| |
a hash ref describing the data to be stored. For example: |
| |
|
| |
%Save_Parameters = ('Status' => 'scalar', |
| |
'chartoutputmode' => 'scalar', |
| |
'chartoutputdata' => 'scalar', |
| |
'Section' => 'array', |
| |
'StudentData' => 'array', |
| |
'Maps' => 'array'); |
| |
|
| |
Returns: both routines return nothing |
| |
|
| |
=cut |
| |
|
| |
####################################################### |
| |
####################################################### |
| |
sub store_course_settings { |
| |
# save to the environment |
| |
# appenv the same items, just to be safe |
| |
my $courseid = $env{'request.course.id'}; |
| |
my $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 { |
| |
&Apache::lonnet::escape($_); |
| |
} sort(@{$env{'form.'.$setting}})); |
| |
} else { |
| |
$stored_form = |
| |
&Apache::lonnet::escape($env{'form.'.$setting}); |
| |
} |
| |
# Determine if the array contents are the same. |
| |
if ($stored_form ne $env{$envname}) { |
| |
$SaveHash{$basename} = $stored_form; |
| |
$AppHash{$envname} = $stored_form; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
my $put_result = &Apache::lonnet::put('environment',\%SaveHash, |
| |
$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 { |
| |
&Apache::lonnet::unescape($_); |
| |
} split(',',$env{$envname}) |
| |
]; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
|
| |
############################################################ |
| |
############################################################ |
| |
|
| |
sub propath { |
| |
my ($udom,$uname)=@_; |
| |
$udom=~s/\W//g; |
| |
$uname=~s/\W//g; |
| |
my $subdir=$uname.'__'; |
| |
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
| |
my $proname="$Apache::lonnet::perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; |
| |
return $proname; |
| |
} |
| |
|
| |
sub icon { |
| |
my ($file)=@_; |
| |
my $curfext = (split(/\./,$file))[-1]; |
| |
my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif'; |
| |
my $embstyle = &Apache::loncommon::fileembstyle($curfext); |
| |
if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) { |
| |
if (-e $Apache::lonnet::perlvar{'lonDocRoot'}.'/'. |
| |
$Apache::lonnet::perlvar{'lonIconsURL'}.'/'. |
| |
$curfext.".gif") { |
| |
$iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'. |
| |
$curfext.".gif"; |
| |
} |
| |
} |
| |
return &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 = &Apache::lonnet::escape(pop(@urlslices)); |
| |
return join('/',@urlslices).'/'.$lastitem; |
| |
} |
| |
=pod |
| |
|
| |
=back |
| |
|
| |
=cut |
| |
|
| 1; |
1; |
| __END__; |
__END__; |
| |
|
![[BACK]](/icons/back.gif){kind=icon}
Return to loncommon.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / interface