version 1.44, 2002/07/05 16:12:31
|
version 1.154, 2003/11/12 21:37:07
|
Line 27
|
Line 27
|
# |
# |
# YEAR=2001 |
# YEAR=2001 |
# 2/13-12/7 Guy Albertelli |
# 2/13-12/7 Guy Albertelli |
# 12/11,12/12,12/17 Scott Harrison |
|
# 12/21 Gerd Kortemeyer |
# 12/21 Gerd Kortemeyer |
# 12/21 Scott Harrison |
|
# 12/25,12/28 Gerd Kortemeyer |
# 12/25,12/28 Gerd Kortemeyer |
# YEAR=2002 |
# YEAR=2002 |
# 1/4 Gerd Kortemeyer |
# 1/4 Gerd Kortemeyer |
Line 41
|
Line 39
|
|
|
# POD header: |
# POD header: |
|
|
|
=pod |
|
|
=head1 NAME |
=head1 NAME |
|
|
Apache::loncommon - pile of common routines |
Apache::loncommon - pile of common routines |
|
|
=head1 SYNOPSIS |
=head1 SYNOPSIS |
|
|
Referenced by other mod_perl Apache modules. |
Common routines for manipulating connections, student answers, |
|
domains, common Javascript fragments, etc. |
|
|
Invocation: |
=head1 OVERVIEW |
&Apache::loncommon::SUBROUTINENAME(ARGUMENTS); |
|
|
|
=head1 INTRODUCTION |
A collection of commonly used subroutines that don't have a natural |
|
home anywhere else. This collection helps remove |
Common collection of used subroutines. This collection helps remove |
|
redundancy from other modules and increase efficiency of memory usage. |
redundancy from other modules and increase efficiency of memory usage. |
|
|
Current things done: |
|
|
|
Makes a table out of the previous homework attempts |
|
Inputs result_from_symbread, user, domain, course_id |
|
Reads in non-network-related .tab files |
|
|
|
This is part of the LearningOnline Network with CAPA project |
|
described at http://www.lon-capa.org. |
|
|
|
=head2 General Subroutines |
|
|
|
=over 4 |
|
|
|
=cut |
=cut |
|
|
# End of POD header |
# End of POD header |
Line 77 package Apache::loncommon;
|
Line 63 package Apache::loncommon;
|
|
|
use strict; |
use strict; |
use Apache::lonnet(); |
use Apache::lonnet(); |
use POSIX qw(strftime); |
use GDBM_File; |
use Apache::Constants qw(:common); |
use POSIX qw(strftime mktime); |
|
use Apache::Constants qw(:common :http :methods); |
use Apache::lonmsg(); |
use Apache::lonmsg(); |
|
use Apache::lonmenu(); |
|
use Apache::lonlocal; |
|
use HTML::Entities; |
|
|
my $readit; |
my $readit; |
|
|
|
=pod |
|
|
|
=head1 Global Variables |
|
|
|
=cut |
|
|
# ----------------------------------------------- Filetypes/Languages/Copyright |
# ----------------------------------------------- Filetypes/Languages/Copyright |
my %language; |
my %language; |
|
my %supported_language; |
my %cprtag; |
my %cprtag; |
my %fe; my %fd; |
my %fe; my %fd; |
my %category_extensions; |
my %category_extensions; |
|
|
# -------------------------------------------------------------- Thesaurus data |
# ---------------------------------------------- Designs |
my @therelated; |
|
my @theword; |
|
my @thecount; |
|
my %theindex; |
|
my $thetotalcount; |
|
my $thefuzzy=2; |
|
my $thethreshold=0.1/$thefuzzy; |
|
my $theavecount; |
|
|
|
# ----------------------------------------------------------------------- BEGIN |
|
|
|
=pod |
|
|
|
=item BEGIN() |
my %designhash; |
|
|
Initialize values from language.tab, copyright.tab, filetypes.tab, |
# ---------------------------------------------- Thesaurus variables |
and filecategories.tab. |
# |
|
# %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. |
|
|
=cut |
my %Keywords; |
# ----------------------------------------------------------------------- BEGIN |
my $thesaurus_db_file; |
|
|
|
# |
|
# Initialize values from language.tab, copyright.tab, filetypes.tab, |
|
# thesaurus.tab, and filecategories.tab. |
|
# |
BEGIN { |
BEGIN { |
|
# Variable initialization |
|
$thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db"; |
|
# |
unless ($readit) { |
unless ($readit) { |
# ------------------------------------------------------------------- languages |
# ------------------------------------------------------------------- languages |
{ |
{ |
Line 121 BEGIN {
|
Line 117 BEGIN {
|
while (<$fh>) { |
while (<$fh>) { |
next if /^\#/; |
next if /^\#/; |
chomp; |
chomp; |
my ($key,$val)=(split(/\s+/,$_,2)); |
my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$_)); |
$language{$key}=$val; |
$language{$key}=$val.' - '.$enc; |
|
if ($sup) { |
|
$supported_language{$key}=$sup; |
|
} |
} |
} |
} |
} |
} |
} |
Line 139 BEGIN {
|
Line 138 BEGIN {
|
} |
} |
} |
} |
} |
} |
|
|
|
# -------------------------------------------------------------- domain designs |
|
|
|
my $filename; |
|
my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; |
|
opendir(DIR,$designdir); |
|
while ($filename=readdir(DIR)) { |
|
my ($domain)=($filename=~/^(\w+)\./); |
|
{ |
|
my $fh=Apache::File->new($designdir.'/'.$filename); |
|
if ($fh) { |
|
while (<$fh>) { |
|
next if /^\#/; |
|
chomp; |
|
my ($key,$val)=(split(/\=/,$_)); |
|
if ($val) { $designhash{$domain.'.'.$key}=$val; } |
|
} |
|
} |
|
} |
|
|
|
} |
|
closedir(DIR); |
|
|
|
|
# ------------------------------------------------------------- file categories |
# ------------------------------------------------------------- file categories |
{ |
{ |
my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. |
my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. |
Line 168 BEGIN {
|
Line 191 BEGIN {
|
} |
} |
} |
} |
} |
} |
# -------------------------------------------------------------- Thesaurus data |
|
{ |
|
my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. |
|
'/thesaurus.dat'); |
|
if ($fh) { |
|
while (<$fh>) { |
|
my ($tword,$tindex,$tcount,$trelated)=split(/\@/,$_); |
|
$theindex{$tword}=$tindex; |
|
$theword[$tindex]=$tword; |
|
$thecount[$tindex]=$tcount; |
|
$thetotalcount+=$tcount; |
|
$therelated[$tindex]=$trelated; |
|
} |
|
} |
|
$theavecount=$thetotalcount/$#thecount; |
|
} |
|
&Apache::lonnet::logthis( |
&Apache::lonnet::logthis( |
"<font color=yellow>INFO: Read file types and thesaurus</font>"); |
"<font color=yellow>INFO: Read file types</font>"); |
$readit=1; |
$readit=1; |
} |
} # end of unless($readit) |
|
|
} |
} |
# ============================================================= END BEGIN BLOCK |
|
############################################################### |
############################################################### |
## HTML and Javascript Helper Functions ## |
## HTML and Javascript Helper Functions ## |
############################################################### |
############################################################### |
|
|
=pod |
=pod |
|
|
=item browser_and_searcher_javascript |
=head1 General Subroutines |
|
|
|
=over 4 |
|
|
|
=head1 HTML and Javascript Functions |
|
|
|
=over 4 |
|
|
|
=item * browser_and_searcher_javascript () |
|
|
Returns scalar containing javascript to open a browser window |
X<browsing, javascript>X<searching, javascript>Returns a string |
or a searcher window. Also creates |
containing javascript with two functions, C<openbrowser> and |
|
C<opensearcher>. Returned string does not contain E<lt>scriptE<gt> |
|
tags. |
|
|
=over 4 |
=over 4 |
|
|
=item openbrowser(formname,elementname,only,omit) [javascript] |
=item * openbrowser(formname,elementname,only,omit) [javascript] |
|
|
inputs: formname, elementname, only, omit |
inputs: formname, elementname, only, omit |
|
|
Line 217 with the given extension. Can be a comm
|
Line 234 with the given extension. Can be a comm
|
Specifying 'omit' will restrict the browser to NOT displaying files |
Specifying 'omit' will restrict the browser to NOT displaying files |
with the given extension. Can be a comma seperated list. |
with the given extension. Can be a comma seperated list. |
|
|
=item opensearcher(formname, elementname) [javascript] |
=item * opensearcher(formname, elementname) [javascript] |
|
|
Inputs: formname, elementname |
Inputs: formname, elementname |
|
|
Line 228 of the element the selection from the se
|
Line 245 of the element the selection from the se
|
|
|
=cut |
=cut |
|
|
############################################################### |
|
sub browser_and_searcher_javascript { |
sub browser_and_searcher_javascript { |
return <<END; |
return <<END; |
var editbrowser; |
var editbrowser = null; |
function openbrowser(formname,elementname,only,omit) { |
function openbrowser(formname,elementname,only,omit,titleelement) { |
var url = '/res/?'; |
var url = '/res/?'; |
if (editbrowser == null) { |
if (editbrowser == null) { |
url += 'launch=1&'; |
url += 'launch=1&'; |
Line 246 sub browser_and_searcher_javascript {
|
Line 262 sub browser_and_searcher_javascript {
|
if (omit != null) { |
if (omit != null) { |
url += 'omit=' + omit + '&'; |
url += 'omit=' + omit + '&'; |
} |
} |
|
if (titleelement != null) { |
|
url += 'titleelement=' + titleelement + '&'; |
|
} |
url += 'element=' + elementname + ''; |
url += 'element=' + elementname + ''; |
var title = 'Browser'; |
var title = 'Browser'; |
var options = 'scrollbars=1,resizable=1,menubar=0'; |
var options = 'scrollbars=1,resizable=1,menubar=0'; |
Line 254 sub browser_and_searcher_javascript {
|
Line 273 sub browser_and_searcher_javascript {
|
editbrowser.focus(); |
editbrowser.focus(); |
} |
} |
var editsearcher; |
var editsearcher; |
function opensearcher(formname,elementname) { |
function opensearcher(formname,elementname,titleelement) { |
var url = '/adm/searchcat?'; |
var url = '/adm/searchcat?'; |
if (editsearcher == null) { |
if (editsearcher == null) { |
url += 'launch=1&'; |
url += 'launch=1&'; |
Line 262 sub browser_and_searcher_javascript {
|
Line 281 sub browser_and_searcher_javascript {
|
url += 'catalogmode=interactive&'; |
url += 'catalogmode=interactive&'; |
url += 'mode=edit&'; |
url += 'mode=edit&'; |
url += 'form=' + formname + '&'; |
url += 'form=' + formname + '&'; |
|
if (titleelement != null) { |
|
url += 'titleelement=' + titleelement + '&'; |
|
} |
url += 'element=' + elementname + ''; |
url += 'element=' + elementname + ''; |
var title = 'Search'; |
var title = 'Search'; |
var options = 'scrollbars=1,resizable=1,menubar=0'; |
var options = 'scrollbars=1,resizable=1,menubar=0'; |
Line 272 sub browser_and_searcher_javascript {
|
Line 294 sub browser_and_searcher_javascript {
|
END |
END |
} |
} |
|
|
|
sub studentbrowser_javascript { |
|
unless ( |
|
(($ENV{'request.course.id'}) && |
|
(&Apache::lonnet::allowed('srm',$ENV{'request.course.id'}))) |
|
|| ($ENV{'request.role'}=~/^(au|dc|su)/) |
|
) { return ''; } |
|
return (<<'ENDSTDBRW'); |
|
<script type="text/javascript" language="Javascript" > |
|
var stdeditbrowser; |
|
function openstdbrowser(formname,uname,udom,roleflag) { |
|
var url = '/adm/pickstudent?'; |
|
var filter; |
|
eval('filter=document.'+formname+'.'+uname+'.value;'); |
|
if (filter != null) { |
|
if (filter != '') { |
|
url += 'filter='+filter+'&'; |
|
} |
|
} |
|
url += 'form=' + formname + '&unameelement='+uname+ |
|
'&udomelement='+udom; |
|
if (roleflag) { url+="&roles=1"; } |
|
var title = 'Student_Browser'; |
|
var options = 'scrollbars=1,resizable=1,menubar=0'; |
|
options += ',width=700,height=600'; |
|
stdeditbrowser = open(url,title,options,'1'); |
|
stdeditbrowser.focus(); |
|
} |
|
</script> |
|
ENDSTDBRW |
|
} |
|
|
|
sub selectstudent_link { |
|
my ($form,$unameele,$udomele)=@_; |
|
if ($ENV{'request.course.id'}) { |
|
unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) { |
|
return ''; |
|
} |
|
return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele. |
|
'","'.$udomele.'");'."'>".&mt('Select User')."</a>"; |
|
} |
|
if ($ENV{'request.role'}=~/^(au|dc|su)/) { |
|
return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele. |
|
'","'.$udomele.'",1);'."'>".&mt('Select User')."</a>"; |
|
} |
|
return ''; |
|
} |
|
|
|
sub coursebrowser_javascript { |
|
my ($domainfilter)=@_; |
|
return (<<ENDSTDBRW); |
|
<script type="text/javascript" language="Javascript" > |
|
var stdeditbrowser; |
|
function opencrsbrowser(formname,uname,udom) { |
|
var url = '/adm/pickcourse?'; |
|
var filter; |
|
if (filter != null) { |
|
if (filter != '') { |
|
url += 'filter='+filter+'&'; |
|
} |
|
} |
|
var domainfilter='$domainfilter'; |
|
if (domainfilter != null) { |
|
if (domainfilter != '') { |
|
url += 'domainfilter='+domainfilter+'&'; |
|
} |
|
} |
|
url += 'form=' + formname + '&cnumelement='+uname+ |
|
'&cdomelement='+udom; |
|
var title = 'Course_Browser'; |
|
var options = 'scrollbars=1,resizable=1,menubar=0'; |
|
options += ',width=700,height=600'; |
|
stdeditbrowser = open(url,title,options,'1'); |
|
stdeditbrowser.focus(); |
|
} |
|
</script> |
|
ENDSTDBRW |
|
} |
|
|
############################################################### |
sub selectcourse_link { |
|
my ($form,$unameele,$udomele)=@_; |
|
return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele. |
|
'","'.$udomele.'");'."'>".&mt('Select Course')."</a>"; |
|
} |
|
|
=pod |
=pod |
|
|
=item linked_select_forms(...) |
=item * linked_select_forms(...) |
|
|
linked_select_forms returns a string containing a <script></script> block |
linked_select_forms returns a string containing a <script></script> block |
and html for two <select> menus. The select menus will be linked in that |
and html for two <select> menus. The select menus will be linked in that |
Line 290 linked_select_forms takes the following
|
Line 392 linked_select_forms takes the following
|
|
|
=over 4 |
=over 4 |
|
|
=item $formname, the name of the <form> tag |
=item * $formname, the name of the <form> tag |
|
|
=item $middletext, the text which appears between the <select> tags |
=item * $middletext, the text which appears between the <select> tags |
|
|
=item $firstdefault, the default value for the first menu |
=item * $firstdefault, the default value for the first menu |
|
|
=item $firstselectname, the name of the first <select> tag |
=item * $firstselectname, the name of the first <select> tag |
|
|
=item $secondselectname, the name of the second <select> tag |
=item * $secondselectname, the name of the second <select> tag |
|
|
=item $hashref, a reference to a hash containing the data for the menus. |
=item * $hashref, a reference to a hash containing the data for the menus. |
|
|
=back |
=back |
|
|
Line 311 first menu value is given in $menu{$choi
|
Line 413 first menu value is given in $menu{$choi
|
and text for the second menu are given in the hash pointed to by |
and text for the second menu are given in the hash pointed to by |
$menu{$choice1}->{'select2'}. |
$menu{$choice1}->{'select2'}. |
|
|
my %menu = ( A1 => { text =>"Choice A1" , |
my %menu = ( A1 => { text =>"Choice A1" , |
default => "B3", |
default => "B3", |
select2 => { |
select2 => { |
B1 => "Choice B1", |
B1 => "Choice B1", |
B2 => "Choice B2", |
B2 => "Choice B2", |
B3 => "Choice B3", |
B3 => "Choice B3", |
B4 => "Choice B4" |
B4 => "Choice B4" |
} |
} |
}, |
}, |
A2 => { text =>"Choice A2" , |
A2 => { text =>"Choice A2" , |
default => "C2", |
default => "C2", |
select2 => { |
select2 => { |
C1 => "Choice C1", |
C1 => "Choice C1", |
C2 => "Choice C2", |
C2 => "Choice C2", |
C3 => "Choice C3" |
C3 => "Choice C3" |
} |
} |
}, |
}, |
A3 => { text =>"Choice A3" , |
A3 => { text =>"Choice A3" , |
default => "D6", |
default => "D6", |
select2 => { |
select2 => { |
D1 => "Choice D1", |
D1 => "Choice D1", |
D2 => "Choice D2", |
D2 => "Choice D2", |
D3 => "Choice D3", |
D3 => "Choice D3", |
D4 => "Choice D4", |
D4 => "Choice D4", |
D5 => "Choice D5", |
D5 => "Choice D5", |
D6 => "Choice D6", |
D6 => "Choice D6", |
D7 => "Choice D7" |
D7 => "Choice D7" |
} |
} |
} |
} |
); |
); |
|
|
=back |
|
|
|
=cut |
=cut |
|
|
# ------------------------------------------------ |
|
|
|
sub linked_select_forms { |
sub linked_select_forms { |
my ($formname, |
my ($formname, |
$middletext, |
$middletext, |
Line 396 function select1_changed() {
|
Line 494 function select1_changed() {
|
// in with the nuclear |
// in with the nuclear |
for (i=0;i<values.length; i++) { |
for (i=0;i<values.length; i++) { |
$second.options[i] = new Option(values[i]); |
$second.options[i] = new Option(values[i]); |
|
$second.options[i].value = values[i]; |
$second.options[i].text = texts[i]; |
$second.options[i].text = texts[i]; |
if (values[i] == select2def) { |
if (values[i] == select2def) { |
$second.options[i].selected = true; |
$second.options[i].selected = true; |
Line 409 END
|
Line 508 END
|
foreach my $value (sort(keys(%$hashref))) { |
foreach my $value (sort(keys(%$hashref))) { |
$result.=" <option value=\"$value\" "; |
$result.=" <option value=\"$value\" "; |
$result.=" selected=\"true\" " if ($value eq $firstdefault); |
$result.=" selected=\"true\" " if ($value eq $firstdefault); |
$result.=">$hashref->{$value}->{'text'}</option>\n"; |
$result.=">".&mt($hashref->{$value}->{'text'})."</option>\n"; |
} |
} |
$result .= "</select>\n"; |
$result .= "</select>\n"; |
my %select2 = %{$hashref->{$firstdefault}->{'select2'}}; |
my %select2 = %{$hashref->{$firstdefault}->{'select2'}}; |
Line 419 END
|
Line 518 END
|
foreach my $value (sort(keys(%select2))) { |
foreach my $value (sort(keys(%select2))) { |
$result.=" <option value=\"$value\" "; |
$result.=" <option value=\"$value\" "; |
$result.=" selected=\"true\" " if ($value eq $seconddefault); |
$result.=" selected=\"true\" " if ($value eq $seconddefault); |
$result.=">$select2{$value}</option>\n"; |
$result.=">".&mt($select2{$value})."</option>\n"; |
} |
} |
$result .= "</select>\n"; |
$result .= "</select>\n"; |
# return $debug; |
# return $debug; |
return $result; |
return $result; |
} # end of sub linked_select_forms { |
} # end of sub linked_select_forms { |
|
|
############################################################### |
=pod |
|
|
|
|
=item help_open_topic($topic, $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. |
|
|
|
$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.) |
=item * help_open_topic($topic, $text, $stayOnPage, $width, $height) |
|
|
$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. |
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 |
=cut |
|
|
sub help_open_topic { |
sub help_open_topic { |
my ($topic, $stayOnPage, $width, $height) = @_; |
my ($topic, $text, $stayOnPage, $width, $height) = @_; |
|
$text = "" if (not defined $text); |
$stayOnPage = 0 if (not defined $stayOnPage); |
$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); |
$width = 350 if (not defined $width); |
$height = 400 if (not defined $height); |
$height = 400 if (not defined $height); |
my $filename = $topic; |
my $filename = $topic; |
$filename =~ s/ /_/g; |
$filename =~ s/ /_/g; |
|
|
my $template; |
my $template = ""; |
|
my $link; |
|
|
if (!$stayOnPage) |
if (!$stayOnPage) |
{ |
{ |
$template = <<"ENDTEMPLATE"; |
$link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; |
<a href="javascript:void(open('/adm/help/${filename}.hlp', 'Help for $topic', 'menubar=0,s |
|
crollbars=1,width=$width,height=$height'))"><image |
|
src="/adm/help/gif/smallHelp.gif" |
|
border="0" alt="(Help: $topic)"></a> |
|
ENDTEMPLATE |
|
} |
} |
else |
else |
{ |
{ |
$template = <<"ENDTEMPLATE"; |
$link = "/adm/help/${filename}.hlp"; |
<a href="/adm/help/${filename}.hlp"><image |
|
src="/adm/help/gif/smallHelp.gif" |
|
border="0" alt="(Help: $topic)"></a> |
|
ENDTEMPLATE |
|
} |
} |
|
|
|
# Add the text |
|
if ($text ne "") |
|
{ |
|
$template .= |
|
"<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>". |
|
"<td bgcolor='#5555FF'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>"; |
|
} |
|
|
|
# Add the graphic |
|
$template .= <<"ENDTEMPLATE"; |
|
<a href="$link"><image src="/adm/help/gif/smallHelp.gif" border="0" alt="(Help: $topic)" /></a> |
|
ENDTEMPLATE |
|
if ($text ne '') { $template.='</td></tr></table>' }; |
return $template; |
return $template; |
|
|
} |
} |
|
|
=item csv_translate($text) |
# This is a quicky function for Latex cheatsheet editing, since it |
|
# appears in at least four places |
|
sub helpLatexCheatsheet { |
|
my $other = shift; |
|
my $addOther = ''; |
|
if ($other) { |
|
$addOther = Apache::loncommon::help_open_topic($other, shift, |
|
undef, undef, 600) . |
|
'</td><td>'; |
|
} |
|
return '<table><tr><td>'. |
|
$addOther . |
|
&Apache::loncommon::help_open_topic("Greek_Symbols",'Greek Symbols', |
|
undef,undef,600) |
|
.'</td><td>'. |
|
&Apache::loncommon::help_open_topic("Other_Symbols",'Other Symbols', |
|
undef,undef,600) |
|
.'</td></tr></table>'; |
|
} |
|
|
|
=pod |
|
|
|
=item * csv_translate($text) |
|
|
Translate $text to allow it to be output as a 'comma seperated values' |
Translate $text to allow it to be output as a 'comma seperated values' |
format. |
format. |
Line 485 sub csv_translate {
|
Line 627 sub csv_translate {
|
return $text; |
return $text; |
} |
} |
|
|
############################################################### |
=pod |
|
|
|
=item * change_content_javascript(): |
|
|
|
This and the next function allow you to create small sections of an |
|
otherwise static HTML page that you can update on the fly with |
|
Javascript, even in Netscape 4. |
|
|
|
The Javascript fragment returned by this function (no E<lt>scriptE<gt> tag) |
|
must be written to the HTML page once. It will prove the Javascript |
|
function "change(name, content)". Calling the change function with the |
|
name of the section |
|
you want to update, matching the name passed to C<changable_area>, and |
|
the new content you want to put in there, will put the content into |
|
that area. |
|
|
|
B<Note>: Netscape 4 only reserves enough space for the changable area |
|
to contain room for the original contents. You need to "make space" |
|
for whatever changes you wish to make, and be B<sure> to check your |
|
code in Netscape 4. This feature in Netscape 4 is B<not> powerful; |
|
it's adequate for updating a one-line status display, but little more. |
|
This script will set the space to 100% width, so you only need to |
|
worry about height in Netscape 4. |
|
|
|
Modern browsers are much less limiting, and if you can commit to the |
|
user not using Netscape 4, this feature may be used freely with |
|
pretty much any HTML. |
|
|
|
=cut |
|
|
|
sub change_content_javascript { |
|
# If we're on Netscape 4, we need to use Layer-based code |
|
if ($ENV{'browser.type'} eq 'netscape' && |
|
$ENV{'browser.version'} =~ /^4\./) { |
|
return (<<NETSCAPE4); |
|
function change(name, content) { |
|
doc = document.layers[name+"___escape"].layers[0].document; |
|
doc.open(); |
|
doc.write(content); |
|
doc.close(); |
|
} |
|
NETSCAPE4 |
|
} else { |
|
# Otherwise, we need to use semi-standards-compliant code |
|
# (technically, "innerHTML" isn't standard but the equivalent |
|
# is really scary, and every useful browser supports it |
|
return (<<DOMBASED); |
|
function change(name, content) { |
|
element = document.getElementById(name); |
|
element.innerHTML = content; |
|
} |
|
DOMBASED |
|
} |
|
} |
|
|
|
=pod |
|
|
|
=item * changable_area($name, $origContent): |
|
|
|
This provides a "changable area" that can be modified on the fly via |
|
the Javascript code provided in C<change_content_javascript>. $name is |
|
the name you will use to reference the area later; do not repeat the |
|
same name on a given HTML page more then once. $origContent is what |
|
the area will originally contain, which can be left blank. |
|
|
|
=cut |
|
|
|
sub changable_area { |
|
my ($name, $origContent) = @_; |
|
|
|
if ($ENV{'browser.type'} eq 'netscape' && |
|
$ENV{'browser.version'} =~ /^4\./) { |
|
# If this is netscape 4, we need to use the Layer tag |
|
return "<ilayer width='100%' id='${name}___escape' overflow='none'><layer width='100%' id='$name' overflow='none'>$origContent</layer></ilayer>"; |
|
} else { |
|
return "<span id='$name'>$origContent</span>"; |
|
} |
|
} |
|
|
|
=pod |
|
|
|
=back |
|
|
|
=cut |
|
|
############################################################### |
############################################################### |
## Home server <option> list generating code ## |
## Home server <option> list generating code ## |
############################################################### |
############################################################### |
#------------------------------------------- |
|
|
|
=item get_domains() |
=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 |
Returns an array containing each of the domains listed in the hosts.tab |
file. |
file. |
Line 512 sub get_domains {
|
Line 742 sub get_domains {
|
|
|
#------------------------------------------- |
#------------------------------------------- |
|
|
=item select_dom_form($defdom,$name) |
=pod |
|
|
|
=item * select_form($defdom,$name,%hash) |
|
|
|
Returns a string containing a <select name='$name' size='1'> form to |
|
allow a user to select options from a hash option_name => displayed text. |
|
See lonrights.pm for an example invocation and use. |
|
|
|
=cut |
|
|
|
#------------------------------------------- |
|
sub select_form { |
|
my ($def,$name,%hash) = @_; |
|
my $selectform = "<select name=\"$name\" size=\"1\">\n"; |
|
my @keys; |
|
if (exists($hash{'select_form_order'})) { |
|
@keys=@{$hash{'select_form_order'}}; |
|
} else { |
|
@keys=sort(keys(%hash)); |
|
} |
|
foreach (@keys) { |
|
$selectform.="<option value=\"$_\" ". |
|
($_ eq $def ? 'selected' : ''). |
|
">".&mt($hash{$_})."</option>\n"; |
|
} |
|
$selectform.="</select>"; |
|
return $selectform; |
|
} |
|
|
|
|
|
#------------------------------------------- |
|
|
|
=pod |
|
|
|
=item * select_dom_form($defdom,$name,$includeempty) |
|
|
Returns a string containing a <select name='$name' size='1'> form to |
Returns a string containing a <select name='$name' size='1'> form to |
allow a user to select the domain to preform an operation in. |
allow a user to select the domain to preform an operation in. |
See loncreateuser.pm for an example invocation and use. |
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 |
=cut |
|
|
#------------------------------------------- |
#------------------------------------------- |
sub select_dom_form { |
sub select_dom_form { |
my ($defdom,$name) = @_; |
my ($defdom,$name,$includeempty) = @_; |
my @domains = get_domains(); |
my @domains = get_domains(); |
|
if ($includeempty) { @domains=('',@domains); } |
my $selectdomain = "<select name=\"$name\" size=\"1\">\n"; |
my $selectdomain = "<select name=\"$name\" size=\"1\">\n"; |
foreach (@domains) { |
foreach (@domains) { |
$selectdomain.="<option value=\"$_\" ". |
$selectdomain.="<option value=\"$_\" ". |
Line 536 sub select_dom_form {
|
Line 804 sub select_dom_form {
|
|
|
#------------------------------------------- |
#------------------------------------------- |
|
|
=item get_home_servers($domain) |
=pod |
|
|
|
=item * get_library_servers($domain) |
|
|
Returns a hash which contains keys like '103l3' and values like |
Returns a hash which contains keys like '103l3' and values like |
'kirk.lite.msu.edu'. All of the keys will be for machines in the |
'kirk.lite.msu.edu'. All of the keys will be for machines in the |
Line 545 given $domain.
|
Line 815 given $domain.
|
=cut |
=cut |
|
|
#------------------------------------------- |
#------------------------------------------- |
sub get_home_servers { |
sub get_library_servers { |
my $domain = shift; |
my $domain = shift; |
my %home_servers; |
my %library_servers; |
foreach (keys(%Apache::lonnet::libserv)) { |
foreach (keys(%Apache::lonnet::libserv)) { |
if ($Apache::lonnet::hostdom{$_} eq $domain) { |
if ($Apache::lonnet::hostdom{$_} eq $domain) { |
$home_servers{$_} = $Apache::lonnet::hostname{$_}; |
$library_servers{$_} = $Apache::lonnet::hostname{$_}; |
} |
} |
} |
} |
return %home_servers; |
return %library_servers; |
} |
} |
|
|
#------------------------------------------- |
#------------------------------------------- |
|
|
=item home_server_option_list($domain) |
=pod |
|
|
|
=item * home_server_option_list($domain) |
|
|
returns a string which contains an <option> list to be used in a |
returns a string which contains an <option> list to be used in a |
<select> form input. See loncreateuser.pm for an example. |
<select> form input. See loncreateuser.pm for an example. |
Line 568 returns a string which contains an <opti
|
Line 840 returns a string which contains an <opti
|
#------------------------------------------- |
#------------------------------------------- |
sub home_server_option_list { |
sub home_server_option_list { |
my $domain = shift; |
my $domain = shift; |
my %servers = &get_home_servers($domain); |
my %servers = &get_library_servers($domain); |
my $result = ''; |
my $result = ''; |
foreach (sort keys(%servers)) { |
foreach (sort keys(%servers)) { |
$result.= |
$result.= |
Line 576 sub home_server_option_list {
|
Line 848 sub home_server_option_list {
|
} |
} |
return $result; |
return $result; |
} |
} |
|
|
|
=pod |
|
|
|
=back |
|
|
|
=cut |
|
|
|
############################################################### |
|
## Decoding User Agent ## |
|
############################################################### |
|
|
|
=pod |
|
|
|
=head1 Decoding the User Agent |
|
|
|
=over 4 |
|
|
|
=item * &decode_user_agent() |
|
|
|
Inputs: $r |
|
|
|
Outputs: |
|
|
|
=over 4 |
|
|
|
=item * $httpbrowser |
|
|
|
=item * $clientbrowser |
|
|
|
=item * $clientversion |
|
|
|
=item * $clientmathml |
|
|
|
=item * $clientunicode |
|
|
|
=item * $clientos |
|
|
|
=back |
|
|
|
=cut |
|
|
############################################################### |
############################################################### |
## End of home server <option> list generating code ## |
|
############################################################### |
############################################################### |
|
sub decode_user_agent { |
|
my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"}); |
|
my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"}); |
|
my $httpbrowser=$ENV{"HTTP_USER_AGENT"}; |
|
my $clientbrowser='unknown'; |
|
my $clientversion='0'; |
|
my $clientmathml=''; |
|
my $clientunicode='0'; |
|
for (my $i=0;$i<=$#browsertype;$i++) { |
|
my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]); |
|
if (($httpbrowser=~/$match/i) && ($httpbrowser!~/$notmatch/i)) { |
|
$clientbrowser=$bname; |
|
$httpbrowser=~/$vreg/i; |
|
$clientversion=$1; |
|
$clientmathml=($clientversion>=$minv); |
|
$clientunicode=($clientversion>=$univ); |
|
} |
|
} |
|
my $clientos='unknown'; |
|
if (($httpbrowser=~/linux/i) || |
|
($httpbrowser=~/unix/i) || |
|
($httpbrowser=~/ux/i) || |
|
($httpbrowser=~/solaris/i)) { $clientos='unix'; } |
|
if (($httpbrowser=~/vax/i) || |
|
($httpbrowser=~/vms/i)) { $clientos='vms'; } |
|
if ($httpbrowser=~/next/i) { $clientos='next'; } |
|
if (($httpbrowser=~/mac/i) || |
|
($httpbrowser=~/powerpc/i)) { $clientos='mac'; } |
|
if ($httpbrowser=~/win/i) { $clientos='win'; } |
|
if ($httpbrowser=~/embed/i) { $clientos='pda'; } |
|
return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml, |
|
$clientunicode,$clientos,); |
|
} |
|
|
|
=pod |
|
|
|
=back |
|
|
|
=cut |
|
|
############################################################### |
############################################################### |
## Authentication changing form generation subroutines ## |
## Authentication changing form generation subroutines ## |
Line 590 sub home_server_option_list {
|
Line 941 sub home_server_option_list {
|
## formname = the name given in the <form> tag. |
## formname = the name given in the <form> tag. |
#------------------------------------------- |
#------------------------------------------- |
|
|
=item authform_xxxxxx |
=pod |
|
|
|
=head1 Authentication Routines |
|
|
|
=over 4 |
|
|
|
=item * authform_xxxxxx |
|
|
The authform_xxxxxx subroutines provide javascript and html forms which |
The authform_xxxxxx subroutines provide javascript and html forms which |
handle some of the conveniences required for authentication forms. |
handle some of the conveniences required for authentication forms. |
Line 600 See loncreateuser.pm for invocation and
|
Line 957 See loncreateuser.pm for invocation and
|
|
|
=over 4 |
=over 4 |
|
|
=item authform_header |
=item * authform_header |
|
|
=item authform_authorwarning |
=item * authform_authorwarning |
|
|
=item authform_nochange |
=item * authform_nochange |
|
|
=item authform_kerberos |
=item * authform_kerberos |
|
|
=item authform_internal |
=item * authform_internal |
|
|
=item authform_filesystem |
=item * authform_filesystem |
|
|
=back |
=back |
|
|
Line 620 See loncreateuser.pm for invocation and
|
Line 977 See loncreateuser.pm for invocation and
|
sub authform_header{ |
sub authform_header{ |
my %in = ( |
my %in = ( |
formname => 'cu', |
formname => 'cu', |
kerb_def_dom => 'MSU.EDU', |
kerb_def_dom => '', |
@_, |
@_, |
); |
); |
$in{'formname'} = 'document.' . $in{'formname'}; |
$in{'formname'} = 'document.' . $in{'formname'}; |
my $result=''; |
my $result=''; |
|
|
|
#---------------------------------------------- Code for upper case translation |
|
my $Javascript_toUpperCase; |
|
unless ($in{kerb_def_dom}) { |
|
$Javascript_toUpperCase =<<"END"; |
|
switch (choice) { |
|
case 'krb': currentform.elements[choicearg].value = |
|
currentform.elements[choicearg].value.toUpperCase(); |
|
break; |
|
default: |
|
} |
|
END |
|
} else { |
|
$Javascript_toUpperCase = ""; |
|
} |
|
|
$result.=<<"END"; |
$result.=<<"END"; |
var current = new Object(); |
var current = new Object(); |
current.radiovalue = 'nochange'; |
current.radiovalue = 'nochange'; |
Line 658 function changed_radio(choice,currentfor
|
Line 1031 function changed_radio(choice,currentfor
|
function changed_text(choice,currentform) { |
function changed_text(choice,currentform) { |
var choicearg = choice + 'arg'; |
var choicearg = choice + 'arg'; |
if (currentform.elements[choicearg].value !='') { |
if (currentform.elements[choicearg].value !='') { |
switch (choice) { |
$Javascript_toUpperCase |
case 'krb': currentform.elements[choicearg].value = |
|
currentform.elements[choicearg].value.toUpperCase(); |
|
break; |
|
default: |
|
} |
|
// clear old field |
// clear old field |
if ((current.argfield != choicearg) && (current.argfield != null)) { |
if ((current.argfield != choicearg) && (current.argfield != null)) { |
currentform.elements[current.argfield].value = ''; |
currentform.elements[current.argfield].value = ''; |
Line 693 END
|
Line 1061 END
|
|
|
sub authform_authorwarning{ |
sub authform_authorwarning{ |
my $result=''; |
my $result=''; |
$result=<<"END"; |
$result='<i>'. |
<i>As a general rule, only authors or co-authors should be filesystem |
&mt('As a general rule, only authors or co-authors should be '. |
authenticated (which allows access to the server filesystem).</i> |
'filesystem authenticated '. |
END |
'(which allows access to the server filesystem).')."</i>\n"; |
return $result; |
return $result; |
} |
} |
|
|
Line 706 sub authform_nochange{
|
Line 1074 sub authform_nochange{
|
kerb_def_dom => 'MSU.EDU', |
kerb_def_dom => 'MSU.EDU', |
@_, |
@_, |
); |
); |
my $result=''; |
my $result = &mt('[_1] Do not change login data', |
$result.=<<"END"; |
'<input type="radio" name="login" value="nochange" '. |
<input type="radio" name="login" value="nochange" checked="checked" |
'checked="checked" onclick="'. |
onclick="javascript:changed_radio('nochange',$in{'formname'});"> |
"javascript:changed_radio('nochange',$in{'formname'});".'" />'); |
Do not change login data |
|
END |
|
return $result; |
return $result; |
} |
} |
|
|
Line 719 sub authform_kerberos{
|
Line 1085 sub authform_kerberos{
|
my %in = ( |
my %in = ( |
formname => 'document.cu', |
formname => 'document.cu', |
kerb_def_dom => 'MSU.EDU', |
kerb_def_dom => 'MSU.EDU', |
|
kerb_def_auth => 'krb4', |
@_, |
@_, |
); |
); |
my $result=''; |
my ($check4,$check5); |
$result.=<<"END"; |
if ($in{'kerb_def_auth'} eq 'krb5') { |
<input type="radio" name="login" value="krb" |
$check5 = " checked=\"on\""; |
onclick="javascript:changed_radio('krb',$in{'formname'});" |
} else { |
onchange="javascript:changed_radio('krb',$in{'formname'});"> |
$check4 = " checked=\"on\""; |
Kerberos authenticated with domain |
} |
<input type="text" size="10" name="krbarg" value="" |
my $jscall = "javascript:changed_radio('krb',$in{'formname'});"; |
onchange="javascript:changed_text('krb',$in{'formname'});"> |
my $result .= &mt |
END |
('[_1] Kerberos authenticated with domain [_2] '. |
|
'[_3] Version 4 [_4] Version 5', |
|
'<input type="radio" name="login" value="krb" '. |
|
'onclick="'.$jscall.'" onchange="'.$jscall.'" />', |
|
'<input type="text" size="10" name="krbarg" '. |
|
'value="'.$in{'kerb_def_dom'}.'" '. |
|
'onchange="'.$jscall.'" />', |
|
'<input type="radio" name="krbver" value="4" '.$check4.' />', |
|
'<input type="radio" name="krbver" value="5" '.$check5.' />'); |
return $result; |
return $result; |
} |
} |
|
|
Line 739 sub authform_internal{
|
Line 1114 sub authform_internal{
|
kerb_def_dom => 'MSU.EDU', |
kerb_def_dom => 'MSU.EDU', |
@_, |
@_, |
); |
); |
my $result=''; |
my $jscall = "javascript:changed_radio('int',$args{'formname'});"; |
$result.=<<"END"; |
my $result.=&mt |
<input type="radio" name="login" value="int" |
('[_1] Internally authenticated (with initial password [_2])', |
onchange="javascript:changed_radio('int',$args{'formname'});" |
'<input type="radio" name="login" value="int" '. |
onclick="javascript:changed_radio('int',$args{'formname'});"> |
'onchange="'.$jscall.'" onclick="'.$jscall.'" />', |
Internally authenticated (with initial password |
'<input type="text" size="10" name="intarg" value="" '. |
<input type="text" size="10" name="intarg" value="" |
'onchange="'.$jscall.'" />'); |
onchange="javascript:changed_text('int',$args{'formname'});"> |
|
END |
|
return $result; |
return $result; |
} |
} |
|
|
Line 757 sub authform_local{
|
Line 1130 sub authform_local{
|
kerb_def_dom => 'MSU.EDU', |
kerb_def_dom => 'MSU.EDU', |
@_, |
@_, |
); |
); |
my $result=''; |
my $jscall = "javascript:changed_radio('loc',$in{'formname'});"; |
$result.=<<"END"; |
my $result.=&mt('[_1] Local Authentication with arguement [_2]', |
<input type="radio" name="login" value="loc" |
'<input type="radio" name="login" value="loc" '. |
onchange="javascript:changed_radio('loc',$in{'formname'});" |
'onchange="'.$jscall.'" onclick="'.$jscall.'" />', |
onclick="javascript:changed_radio('loc',$in{'formname'});"> |
'<input type="text" size="10" name="locarg" value="" '. |
Local Authentication with argument |
'onchange="'.$jscall.'" />'); |
<input type="text" size="10" name="locarg" value="" |
|
onchange="javascript:changed_text('loc',$in{'formname'});"> |
|
END |
|
return $result; |
return $result; |
} |
} |
|
|
Line 775 sub authform_filesystem{
|
Line 1145 sub authform_filesystem{
|
kerb_def_dom => 'MSU.EDU', |
kerb_def_dom => 'MSU.EDU', |
@_, |
@_, |
); |
); |
my $result=''; |
my $jscall = "javascript:changed_radio('fsys',$in{'formname'});"; |
$result.=<<"END"; |
my $result.= &mt |
<input type="radio" name="login" value="fsys" |
('[_1] Filesystem Authenticated (with initial password [_2])', |
onchange="javascript:changed_radio('fsys',$in{'formname'});" |
'<input type="radio" name="login" value="fsys" '. |
onclick="javascript:changed_radio('fsys',$in{'formname'});"> |
'onchange="'.$jscall.'" onclick="'.$jscall.'" />', |
Filesystem authenticated (with initial password |
'<input type="text" size="10" name="fsysarg" value="" '. |
<input type="text" size="10" name="fsysarg" value="" |
'onchange="'.$jscall.'" />'); |
onchange="javascript:changed_text('fsys',$in{'formname'});"> |
|
END |
|
return $result; |
return $result; |
} |
} |
|
|
|
=pod |
|
|
|
=back |
|
|
|
=cut |
|
|
############################################################### |
############################################################### |
## End Authentication changing form generation functions ## |
## 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); |
|
|
# ---------------------------------------------------------- Is this a keyword? |
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 { |
sub keyword { |
my $newword=shift; |
return if (!&initialize_keywords()); |
$newword=~s/\W//g; |
my $word=lc(shift()); |
$newword=~tr/A-Z/a-z/; |
$word=~s/\W//g; |
my $tindex=$theindex{$newword}; |
return exists($Keywords{$word}); |
if ($tindex) { |
} |
if ($thecount[$tindex]>$theavecount) { |
|
return 1; |
############################################################### |
} |
|
} |
=pod |
return 0; |
|
} |
=item * get_related_words |
# -------------------------------------------------------- Return related words |
|
|
Look up a word in the thesaurus. Takes a scalar arguement and returns |
sub related { |
an array of words. If the keyword is not in the thesaurus, an empty array |
my $newword=shift; |
will be returned. The order of the words returned is determined by the |
$newword=~s/\W//g; |
database which holds them. |
$newword=~tr/A-Z/a-z/; |
|
my $tindex=$theindex{$newword}; |
Uses global $thesaurus_db_file. |
if ($tindex) { |
|
my %found=(); |
=cut |
foreach (split(/\,/,$therelated[$tindex])) { |
|
# - Related word found |
############################################################### |
my ($ridx,$rcount)=split(/\:/,$_); |
sub get_related_words { |
# - Direct relation index |
my $keyword = shift; |
my $directrel=$rcount/$thecount[$tindex]; |
my %thesaurus_db; |
if ($directrel>$thethreshold) { |
if (! -e $thesaurus_db_file) { |
foreach (split(/\,/,$therelated[$ridx])) { |
&Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ". |
my ($rridx,$rrcount)=split(/\:/,$_); |
"failed because the file does not exist"); |
if ($rridx==$tindex) { |
return (); |
# - Determine reverse relation index |
} |
my $revrel=$rrcount/$thecount[$ridx]; |
if (! tie(%thesaurus_db,'GDBM_File', |
# - Calculate full index |
$thesaurus_db_file,&GDBM_READER(),0640)){ |
$found{$ridx}=$directrel*$revrel; |
return (); |
if ($found{$ridx}>$thethreshold) { |
} |
foreach (split(/\,/,$therelated[$ridx])) { |
my @Words=(); |
my ($rrridx,$rrrcount)=split(/\:/,$_); |
if (exists($thesaurus_db{$keyword})) { |
unless ($found{$rrridx}) { |
$_ = $thesaurus_db{$keyword}; |
my $revrevrel=$rrrcount/$thecount[$ridx]; |
(undef,@Words) = split/:/; # The first element is the number of times |
if ( |
# the word appears. We do not need it now. |
$directrel*$revrel*$revrevrel>$thethreshold |
for (my $i=0;$i<=$#Words;$i++) { |
) { |
($Words[$i],undef)= split/\,/,$Words[$i]; |
$found{$rrridx}= |
|
$directrel*$revrel*$revrevrel; |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
} |
} |
} |
return (); |
untie %thesaurus_db; |
|
return @Words; |
|
} |
|
|
|
=pod |
|
|
|
=back |
|
|
|
=cut |
|
|
|
# -------------------------------------------------------------- Plaintext name |
|
=pod |
|
|
|
=head1 User Name Functions |
|
|
|
=over 4 |
|
|
|
=item * plainname($uname,$udom) |
|
|
|
Takes a users logon name and returns it as a string in |
|
"first middle last generation" form |
|
|
|
=cut |
|
|
|
############################################################### |
|
sub plainname { |
|
my ($uname,$udom)=@_; |
|
my %names=&Apache::lonnet::get('environment', |
|
['firstname','middlename','lastname','generation'], |
|
$udom,$uname); |
|
my $name=$names{'firstname'}.' '.$names{'middlename'}.' '. |
|
$names{'lastname'}.' '.$names{'generation'}; |
|
$name=~s/\s+$//; |
|
$name=~s/\s+/ /g; |
|
return $name; |
|
} |
|
|
|
# -------------------------------------------------------------------- Nickname |
|
=pod |
|
|
|
=item * nickname($uname,$udom) |
|
|
|
Gets a users name and returns it as a string as |
|
|
|
""nickname"" |
|
|
|
if the user has a nickname or |
|
|
|
"first middle last generation" |
|
|
|
if the user does not |
|
|
|
=cut |
|
|
|
sub nickname { |
|
my ($uname,$udom)=@_; |
|
my %names=&Apache::lonnet::get('environment', |
|
['nickname','firstname','middlename','lastname','generation'],$udom,$uname); |
|
my $name=$names{'nickname'}; |
|
if ($name) { |
|
$name='"'.$name.'"'; |
|
} else { |
|
$name=$names{'firstname'}.' '.$names{'middlename'}.' '. |
|
$names{'lastname'}.' '.$names{'generation'}; |
|
$name=~s/\s+$//; |
|
$name=~s/\s+/ /g; |
|
} |
|
return $name; |
} |
} |
|
|
# ---------------------------------------------------------------- Language IDs |
|
|
# ------------------------------------------------------------------ Screenname |
|
|
|
=pod |
|
|
|
=item * screenname($uname,$udom) |
|
|
|
Gets a users screenname and returns it as a string |
|
|
|
=cut |
|
|
|
sub screenname { |
|
my ($uname,$udom)=@_; |
|
my %names= |
|
&Apache::lonnet::get('environment',['screenname'],$udom,$uname); |
|
return $names{'screenname'}; |
|
} |
|
|
|
# ------------------------------------------------------------- Message Wrapper |
|
|
|
sub messagewrapper { |
|
my ($link,$un,$do)=@_; |
|
return |
|
"<a href='/adm/email?compose=individual&recname=$un&recdom=$do'>$link</a>"; |
|
} |
|
# --------------------------------------------------------------- Notes Wrapper |
|
|
|
sub noteswrapper { |
|
my ($link,$un,$do)=@_; |
|
return |
|
"<a href='/adm/email?recordftf=retrieve&recname=$un&recdom=$do'>$link</a>"; |
|
} |
|
# ------------------------------------------------------------- Aboutme Wrapper |
|
|
|
sub aboutmewrapper { |
|
my ($link,$username,$domain)=@_; |
|
return "<a href='/adm/$domain/$username/aboutme'>$link</a>"; |
|
} |
|
|
|
# ------------------------------------------------------------ Syllabus Wrapper |
|
|
|
|
|
sub syllabuswrapper { |
|
my ($linktext,$coursedir,$domain,$fontcolor)=@_; |
|
if ($fontcolor) { |
|
$linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>'; |
|
} |
|
return "<a href='/public/$domain/$coursedir/syllabus'>$linktext</a>"; |
|
} |
|
|
|
=pod |
|
|
|
=back |
|
|
|
=head1 Access .tab File Data |
|
|
|
=over 4 |
|
|
|
=item * languageids() |
|
|
|
returns list of all language ids |
|
|
|
=cut |
|
|
sub languageids { |
sub languageids { |
return sort(keys(%language)); |
return sort(keys(%language)); |
} |
} |
|
|
# -------------------------------------------------------- Language Description |
=pod |
|
|
|
=item * languagedescription() |
|
|
|
returns description of a specified language id |
|
|
|
=cut |
|
|
sub languagedescription { |
sub languagedescription { |
return $language{shift(@_)}; |
my $code=shift; |
|
return ($supported_language{$code}?'* ':''). |
|
$language{$code}. |
|
($supported_language{$code}?' ('.&mt('interface available').')':''); |
|
} |
|
|
|
sub plainlanguagedescription { |
|
my $code=shift; |
|
return $language{$code}; |
|
} |
|
|
|
sub supportedlanguagecode { |
|
my $code=shift; |
|
return $supported_language{$code}; |
} |
} |
|
|
# --------------------------------------------------------------- Copyright IDs |
=pod |
|
|
|
=item * copyrightids() |
|
|
|
returns list of all copyrights |
|
|
|
=cut |
|
|
sub copyrightids { |
sub copyrightids { |
return sort(keys(%cprtag)); |
return sort(keys(%cprtag)); |
} |
} |
|
|
# ------------------------------------------------------- Copyright Description |
=pod |
|
|
|
=item * copyrightdescription() |
|
|
|
returns description of a specified copyright id |
|
|
|
=cut |
|
|
sub copyrightdescription { |
sub copyrightdescription { |
return $cprtag{shift(@_)}; |
return $cprtag{shift(@_)}; |
} |
} |
|
|
# ------------------------------------------------------------- File Categories |
=pod |
|
|
|
=item * filecategories() |
|
|
|
returns list of all file categories |
|
|
|
=cut |
|
|
sub filecategories { |
sub filecategories { |
return sort(keys(%category_extensions)); |
return sort(keys(%category_extensions)); |
} |
} |
|
|
# -------------------------------------- File Types within a specified category |
=pod |
|
|
|
=item * filecategorytypes() |
|
|
|
returns list of file types belonging to a given file |
|
category |
|
|
|
=cut |
|
|
sub filecategorytypes { |
sub filecategorytypes { |
return @{$category_extensions{lc($_[0])}}; |
return @{$category_extensions{lc($_[0])}}; |
} |
} |
|
|
# ------------------------------------------------------------------ File Types |
=pod |
sub fileextensions { |
|
return sort(keys(%fe)); |
=item * fileembstyle() |
} |
|
|
returns embedding style for a specified file type |
|
|
|
=cut |
|
|
# ------------------------------------------------------------- Embedding Style |
|
sub fileembstyle { |
sub fileembstyle { |
return $fe{lc(shift(@_))}; |
return $fe{lc(shift(@_))}; |
} |
} |
|
|
# ------------------------------------------------------------ Description Text |
=pod |
|
|
|
=item * filedescription() |
|
|
|
returns description for a specified file type |
|
|
|
=cut |
|
|
sub filedescription { |
sub filedescription { |
return $fd{lc(shift(@_))}; |
return $fd{lc(shift(@_))}; |
} |
} |
|
|
# ------------------------------------------------------------ Description Text |
=pod |
|
|
|
=item * filedescriptionex() |
|
|
|
returns description for a specified file type with |
|
extra formatting |
|
|
|
=cut |
|
|
sub filedescriptionex { |
sub filedescriptionex { |
my $ex=shift; |
my $ex=shift; |
return '.'.$ex.' '.$fd{lc($ex)}; |
return '.'.$ex.' '.$fd{lc($ex)}; |
} |
} |
|
|
# ---- Retrieve attempts by students |
# End of .tab access |
# input |
=pod |
# $symb - problem including path |
|
# $username,$domain - that of the student |
=back |
# $course - course name |
|
# $getattempt - leave blank if want all attempts, else put something. |
=cut |
# $regexp - regular expression. If string matches regexp send to |
|
# $gradesub - routine that process the string if it matches regexp |
# ------------------------------------------------------------------ File Types |
# |
sub fileextensions { |
# output |
return sort(keys(%fe)); |
# formatted as a table all the attempts, if any. |
} |
|
|
|
# ----------------------------------------------------------- Display Languages |
|
# returns a hash with all desired display languages |
# |
# |
|
|
|
sub display_languages { |
|
my %languages=(); |
|
foreach (&preferred_languages()) { |
|
$languages{$_}=1; |
|
} |
|
&get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']); |
|
if ($ENV{'form.displaylanguage'}) { |
|
foreach (split(/\s*(\,|\;|\:)\s*/,$ENV{'form.displaylanguage'})) { |
|
$languages{$_}=1; |
|
} |
|
} |
|
return %languages; |
|
} |
|
|
|
sub preferred_languages { |
|
my @languages=(); |
|
if ($ENV{'environment.languages'}) { |
|
@languages=split(/\s*(\,|\;|\:)\s*/,$ENV{'environment.languages'}); |
|
} |
|
if ($ENV{'course.'.$ENV{'request.course.id'}.'.languages'}) { |
|
@languages=(@languages,split(/\s*(\,|\;|\:)\s*/, |
|
$ENV{'course.'.$ENV{'request.course.id'}.'.languages'})); |
|
} |
|
my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0]; |
|
if ($browser) { |
|
@languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$browser)); |
|
} |
|
if ($Apache::lonnet::domain_lang_def{$ENV{'user.domain'}}) { |
|
@languages=(@languages, |
|
$Apache::lonnet::domain_lang_def{$ENV{'user.domain'}}); |
|
} |
|
if ($Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}}) { |
|
@languages=(@languages, |
|
$Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}}); |
|
} |
|
if ($Apache::lonnet::domain_lang_def{ |
|
$Apache::lonnet::perlvar{'lonDefDomain'}}) { |
|
@languages=(@languages, |
|
$Apache::lonnet::domain_lang_def{ |
|
$Apache::lonnet::perlvar{'lonDefDomain'}}); |
|
} |
|
# turn "en-ca" into "en-ca,en" |
|
my @genlanguages; |
|
foreach (@languages) { |
|
unless ($_=~/\w/) { next; } |
|
push (@genlanguages,$_); |
|
if ($_=~/(\-|\_)/) { |
|
push (@genlanguages,(split(/(\-|\_)/,$_))[0]); |
|
} |
|
} |
|
return @genlanguages; |
|
} |
|
|
|
############################################################### |
|
## Student Answer Attempts ## |
|
############################################################### |
|
|
|
=pod |
|
|
|
=head1 Alternate Problem Views |
|
|
|
=over 4 |
|
|
|
=item * get_previous_attempt($symb, $username, $domain, $course, |
|
$getattempt, $regexp, $gradesub) |
|
|
|
Return string with previous attempt on problem. Arguments: |
|
|
|
=over 4 |
|
|
|
=item * $symb: Problem, including path |
|
|
|
=item * $username: username of the desired student |
|
|
|
=item * $domain: domain of the desired student |
|
|
|
=item * $course: Course ID |
|
|
|
=item * $getattempt: Leave blank for all attempts, otherwise put |
|
something |
|
|
|
=item * $regexp: if string matches this regexp, the string will be |
|
sent to $gradesub |
|
|
|
=item * $gradesub: routine that processes the string if it matches $regexp |
|
|
|
=back |
|
|
|
The output string is a table containing all desired attempts, if any. |
|
|
|
=cut |
|
|
sub get_previous_attempt { |
sub get_previous_attempt { |
my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_; |
my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_; |
my $prevattempts=''; |
my $prevattempts=''; |
Line 955 sub get_previous_attempt {
|
Line 1745 sub get_previous_attempt {
|
} else { |
} else { |
$value=$returnhash{$version.':'.$_}; |
$value=$returnhash{$version.':'.$_}; |
} |
} |
$prevattempts.='<td>'.$value.' </td>'; |
$prevattempts.='<td>'.&Apache::lonnet::unescape($value).' </td>'; |
} |
} |
} |
} |
} |
} |
Line 967 sub get_previous_attempt {
|
Line 1757 sub get_previous_attempt {
|
} else { |
} else { |
$value=$lasthash{$_}; |
$value=$lasthash{$_}; |
} |
} |
if ($_ =~/$regexp$/) {$value = &$gradesub($value)} |
$value=&Apache::lonnet::unescape($value); |
|
if ($_ =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)} |
$prevattempts.='<td>'.$value.' </td>'; |
$prevattempts.='<td>'.$value.' </td>'; |
} |
} |
$prevattempts.='</tr></table></td></tr></table>'; |
$prevattempts.='</tr></table></td></tr></table>'; |
Line 979 sub get_previous_attempt {
|
Line 1770 sub get_previous_attempt {
|
} |
} |
} |
} |
|
|
|
sub relative_to_absolute { |
|
my ($url,$output)=@_; |
|
my $parser=HTML::TokeParser->new(\$output); |
|
my $token; |
|
my $thisdir=$url; |
|
my @rlinks=(); |
|
while ($token=$parser->get_token) { |
|
if ($token->[0] eq 'S') { |
|
if ($token->[1] eq 'a') { |
|
if ($token->[2]->{'href'}) { |
|
$rlinks[$#rlinks+1]=$token->[2]->{'href'}; |
|
} |
|
} elsif ($token->[1] eq 'img' || $token->[1] eq 'embed' ) { |
|
$rlinks[$#rlinks+1]=$token->[2]->{'src'}; |
|
} elsif ($token->[1] eq 'base') { |
|
$thisdir=$token->[2]->{'href'}; |
|
} |
|
} |
|
} |
|
$thisdir=~s-/[^/]*$--; |
|
foreach (@rlinks) { |
|
unless (($_=~/^http:\/\//i) || |
|
($_=~/^\//) || |
|
($_=~/^javascript:/i) || |
|
($_=~/^mailto:/i) || |
|
($_=~/^\#/)) { |
|
my $newlocation=&Apache::lonnet::hreflocation($thisdir,$_); |
|
$output=~s/(\"|\'|\=\s*)$_(\"|\'|\s|\>)/$1$newlocation$2/; |
|
} |
|
} |
|
# -------------------------------------------------- Deal with Applet codebases |
|
$output=~s/(\<applet[^\>]+)(codebase\=[^\S\>]+)*([^\>]*)\>/$1.($2?$2:' codebase="'.$thisdir.'"').$3.'>'/gei; |
|
return $output; |
|
} |
|
|
|
=pod |
|
|
|
=item * get_student_view |
|
|
|
show a snapshot of what student was looking at |
|
|
|
=cut |
|
|
sub get_student_view { |
sub get_student_view { |
my ($symb,$username,$domain,$courseid) = @_; |
my ($symb,$username,$domain,$courseid,$target) = @_; |
my ($map,$id,$feedurl) = split(/___/,$symb); |
my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb); |
my (%old,%moreenv); |
my (%old,%moreenv); |
my @elements=('symb','courseid','domain','username'); |
my @elements=('symb','courseid','domain','username'); |
foreach my $element (@elements) { |
foreach my $element (@elements) { |
$old{$element}=$ENV{'form.grade_'.$element}; |
$old{$element}=$ENV{'form.grade_'.$element}; |
$moreenv{'form.grade_'.$element}=eval '$'.$element #' |
$moreenv{'form.grade_'.$element}=eval '$'.$element #' |
} |
} |
|
if ($target eq 'tex') {$moreenv{'form.grade_target'} = 'tex';} |
&Apache::lonnet::appenv(%moreenv); |
&Apache::lonnet::appenv(%moreenv); |
my $userview=&Apache::lonnet::ssi('/res/'.$feedurl); |
$feedurl=&Apache::lonnet::clutter($feedurl); |
|
my $userview=&Apache::lonnet::ssi_body($feedurl); |
&Apache::lonnet::delenv('form.grade_'); |
&Apache::lonnet::delenv('form.grade_'); |
foreach my $element (@elements) { |
foreach my $element (@elements) { |
$ENV{'form.grade_'.$element}=$old{$element}; |
$ENV{'form.grade_'.$element}=$old{$element}; |
Line 1001 sub get_student_view {
|
Line 1837 sub get_student_view {
|
$userview=~s/\<head\>//gi; |
$userview=~s/\<head\>//gi; |
$userview=~s/\<\/head\>//gi; |
$userview=~s/\<\/head\>//gi; |
$userview=~s/action\s*\=/would_be_action\=/gi; |
$userview=~s/action\s*\=/would_be_action\=/gi; |
|
$userview=&relative_to_absolute($feedurl,$userview); |
return $userview; |
return $userview; |
} |
} |
|
|
|
=pod |
|
|
|
=item * get_student_answers() |
|
|
|
show a snapshot of how student was answering problem |
|
|
|
=cut |
|
|
sub get_student_answers { |
sub get_student_answers { |
my ($symb,$username,$domain,$courseid) = @_; |
my ($symb,$username,$domain,$courseid,%form) = @_; |
my ($map,$id,$feedurl) = split(/___/,$symb); |
my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb); |
my (%old,%moreenv); |
my (%old,%moreenv); |
my @elements=('symb','courseid','domain','username'); |
my @elements=('symb','courseid','domain','username'); |
foreach my $element (@elements) { |
foreach my $element (@elements) { |
Line 1015 sub get_student_answers {
|
Line 1860 sub get_student_answers {
|
} |
} |
$moreenv{'form.grade_target'}='answer'; |
$moreenv{'form.grade_target'}='answer'; |
&Apache::lonnet::appenv(%moreenv); |
&Apache::lonnet::appenv(%moreenv); |
my $userview=&Apache::lonnet::ssi('/res/'.$feedurl); |
my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%form); |
&Apache::lonnet::delenv('form.grade_'); |
&Apache::lonnet::delenv('form.grade_'); |
foreach my $element (@elements) { |
foreach my $element (@elements) { |
$ENV{'form.grade_'.$element}=$old{$element}; |
$ENV{'form.grade_'.$element}=$old{$element}; |
Line 1023 sub get_student_answers {
|
Line 1868 sub get_student_answers {
|
return $userview; |
return $userview; |
} |
} |
|
|
|
=pod |
|
|
|
=item * &submlink() |
|
|
|
Inputs: $text $uname $udom $symb |
|
|
|
Returns: A link to grades.pm such as to see the SUBM view of a student |
|
|
|
=cut |
|
|
############################################### |
############################################### |
|
sub submlink { |
|
my ($text,$uname,$udom,$symb)=@_; |
|
if (!($uname && $udom)) { |
|
(my $cursymb, my $courseid,$udom,$uname)= |
|
&Apache::lonxml::whichuser($symb); |
|
if (!$symb) { $symb=$cursymb; } |
|
} |
|
if (!$symb) { $symb=&symbread(); } |
|
return '<a href="/adm/grades?symb='.$symb.'&student='.$uname. |
|
'&userdom='.$udom.'&command=submission">'.$text.'</a>'; |
|
} |
|
############################################## |
|
|
|
=pod |
|
|
|
=back |
|
|
|
=cut |
|
|
############################################### |
############################################### |
|
|
|
|
|
sub timehash { |
|
my @ltime=localtime(shift); |
|
return ( 'seconds' => $ltime[0], |
|
'minutes' => $ltime[1], |
|
'hours' => $ltime[2], |
|
'day' => $ltime[3], |
|
'month' => $ltime[4]+1, |
|
'year' => $ltime[5]+1900, |
|
'weekday' => $ltime[6], |
|
'dayyear' => $ltime[7]+1, |
|
'dlsav' => $ltime[8] ); |
|
} |
|
|
|
sub maketime { |
|
my %th=@_; |
|
return POSIX::mktime( |
|
($th{'seconds'},$th{'minutes'},$th{'hours'}, |
|
$th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,$th{'dlsav'})); |
|
} |
|
|
|
|
|
######################################### |
|
# |
|
# Retro-fixing of un-backward-compatible time format |
|
|
|
sub unsqltime { |
|
my $timestamp=shift; |
|
if ($timestamp=~/^(\d+)\-(\d+)\-(\d+)\s+(\d+)\:(\d+)\:(\d+)$/) { |
|
$timestamp=&maketime( |
|
'year'=>$1,'month'=>$2,'day'=>$3, |
|
'hours'=>$4,'minutes'=>$5,'seconds'=>$6); |
|
} |
|
return $timestamp; |
|
} |
|
|
|
######################################### |
|
|
|
sub findallcourses { |
|
my %courses=(); |
|
my $now=time; |
|
foreach (keys %ENV) { |
|
if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) { |
|
my ($starttime,$endtime)=$ENV{$_}; |
|
my $active=1; |
|
if ($starttime) { |
|
if ($now<$starttime) { $active=0; } |
|
} |
|
if ($endtime) { |
|
if ($now>$endtime) { $active=0; } |
|
} |
|
if ($active) { $courses{$1.'_'.$2}=1; } |
|
} |
|
} |
|
return keys %courses; |
|
} |
|
|
|
############################################### |
|
############################################### |
|
|
|
=pod |
|
|
|
=head1 Domain Template Functions |
|
|
|
=over 4 |
|
|
|
=item * &determinedomain() |
|
|
|
Inputs: $domain (usually will be undef) |
|
|
|
Returns: Determines which domain should be used for designs |
|
|
|
=cut |
|
|
|
############################################### |
|
sub determinedomain { |
|
my $domain=shift; |
|
if (! $domain) { |
|
# Determine domain if we have not been given one |
|
$domain = $Apache::lonnet::perlvar{'lonDefDomain'}; |
|
if ($ENV{'user.domain'}) { $domain=$ENV{'user.domain'}; } |
|
if ($ENV{'request.role.domain'}) { |
|
$domain=$ENV{'request.role.domain'}; |
|
} |
|
} |
|
return $domain; |
|
} |
|
############################################### |
|
=pod |
|
|
|
=item * &domainlogo() |
|
|
|
Inputs: $domain (usually will be undef) |
|
|
|
Returns: A link to a domain logo, if the domain logo exists. |
|
If the domain logo does not exist, a description of the domain. |
|
|
|
=cut |
|
|
|
############################################### |
|
sub domainlogo { |
|
my $domain = &determinedomain(shift); |
|
# See if there is a logo |
|
if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') { |
|
my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'}; |
|
if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; } |
|
return '<img src="http://'.$ENV{'HTTP_HOST'}.':'.$lonhttpdPort. |
|
'/adm/lonDomLogos/'.$domain.'.gif" alt="'.$domain.'" />'; |
|
} elsif(exists($Apache::lonnet::domaindescription{$domain})) { |
|
return $Apache::lonnet::domaindescription{$domain}; |
|
} else { |
|
return ''; |
|
} |
|
} |
|
############################################## |
|
|
|
=pod |
|
|
|
=item * &designparm() |
|
|
|
Inputs: $which parameter; $domain (usually will be undef) |
|
|
|
Returns: value of designparamter $which |
|
|
|
=cut |
|
|
|
############################################## |
|
sub designparm { |
|
my ($which,$domain)=@_; |
|
if ($ENV{'browser.blackwhite'} eq 'on') { |
|
if ($which=~/\.(font|alink|vlink|link)$/) { |
|
return '#000000'; |
|
} |
|
if ($which=~/\.(pgbg|sidebg)$/) { |
|
return '#FFFFFF'; |
|
} |
|
if ($which=~/\.tabbg$/) { |
|
return '#CCCCCC'; |
|
} |
|
} |
|
if ($ENV{'environment.color.'.$which}) { |
|
return $ENV{'environment.color.'.$which}; |
|
} |
|
$domain=&determinedomain($domain); |
|
if ($designhash{$domain.'.'.$which}) { |
|
return $designhash{$domain.'.'.$which}; |
|
} else { |
|
return $designhash{'default.'.$which}; |
|
} |
|
} |
|
|
|
############################################### |
|
############################################### |
|
|
|
=pod |
|
|
|
=back |
|
|
|
=head1 HTTP Helpers |
|
|
|
=over 4 |
|
|
|
=item * &bodytag() |
|
|
|
Returns a uniform header for LON-CAPA web pages. |
|
|
|
Inputs: |
|
|
|
=over 4 |
|
|
|
=item * $title, A title to be displayed on the page. |
|
|
|
=item * $function, the current role (can be undef). |
|
|
|
=item * $addentries, extra parameters for the <body> tag. |
|
|
|
=item * $bodyonly, if defined, only return the <body> tag. |
|
|
|
=item * $domain, if defined, force a given domain. |
|
|
|
=item * $forcereg, if page should register as content page (relevant for |
|
text interface only) |
|
|
|
=back |
|
|
|
Returns: A uniform header for LON-CAPA web pages. |
|
If $bodyonly is nonzero, a string containing a <body> tag will be returned. |
|
If $bodyonly is undef or zero, an html string containing a <body> tag and |
|
other decorations will be returned. |
|
|
|
=cut |
|
|
|
sub bodytag { |
|
my ($title,$function,$addentries,$bodyonly,$domain,$forcereg)=@_; |
|
$title=&mt($title); |
|
unless ($function) { |
|
$function='student'; |
|
if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) { |
|
$function='coordinator'; |
|
} |
|
if ($ENV{'request.role'}=~/^(su|dc|ad|li)/) { |
|
$function='admin'; |
|
} |
|
if (($ENV{'request.role'}=~/^(au|ca)/) || |
|
($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) { |
|
$function='author'; |
|
} |
|
} |
|
my $img=&designparm($function.'.img',$domain); |
|
my $pgbg=&designparm($function.'.pgbg',$domain); |
|
my $tabbg=&designparm($function.'.tabbg',$domain); |
|
my $font=&designparm($function.'.font',$domain); |
|
my $link=&designparm($function.'.link',$domain); |
|
my $alink=&designparm($function.'.alink',$domain); |
|
my $vlink=&designparm($function.'.vlink',$domain); |
|
my $sidebg=&designparm($function.'.sidebg',$domain); |
|
# Accessibility font enhance |
|
unless ($addentries) { $addentries=''; } |
|
my $addstyle=''; |
|
if ($ENV{'browser.fontenhance'} eq 'on') { |
|
$addstyle=' font-size: x-large;'; |
|
} |
|
# role and realm |
|
my ($role,$realm) |
|
=&Apache::lonnet::plaintext((split(/\./,$ENV{'request.role'}))[0]); |
|
# realm |
|
if ($ENV{'request.course.id'}) { |
|
$realm= |
|
$ENV{'course.'.$ENV{'request.course.id'}.'.description'}; |
|
} |
|
unless ($realm) { $realm=' '; } |
|
# Set messages |
|
my $messages=&domainlogo($domain); |
|
# Port for miniserver |
|
my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'}; |
|
if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; } |
|
# construct main body tag |
|
my $bodytag = <<END; |
|
<style> |
|
h1, h2, h3, th { font-family: Arial, Helvetica, sans-serif } |
|
a:hover { color: black; background: yellow } |
|
a:focus { color: red; background: yellow } |
|
</style> |
|
<body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link" |
|
style="margin-top: 0px;$addstyle" $addentries> |
|
END |
|
my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'. |
|
$lonhttpdPort.$img.'" alt="'.$function.'" />'; |
|
if ($bodyonly) { |
|
return $bodytag; |
|
} elsif ($ENV{'browser.interface'} eq 'textual') { |
|
# Accessibility |
|
return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web', |
|
$forcereg). |
|
'<h1>LON-CAPA: '.$title.'</h1>'; |
|
} elsif ($ENV{'environment.remote'} eq 'off') { |
|
# No Remote |
|
return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web', |
|
$forcereg). |
|
'<table bgcolor="'.$pgbg.'" width="100%" border="0" cellspacing="3" cellpadding="3"><tr><td bgcolor="'.$tabbg.'"><font face="Arial, Helvetica, sans-serif" size="+3" color="'.$font.'"><b>'.$title. |
|
'</b></font></td></tr></table>'; |
|
} |
|
|
|
# |
|
# Top frame rendering, Remote is up |
|
# |
|
return(<<ENDBODY); |
|
$bodytag |
|
<table width="100%" cellspacing="0" border="0" cellpadding="0"> |
|
<tr><td bgcolor="$sidebg"> |
|
$upperleft</td> |
|
<td bgcolor="$sidebg" align="right">$messages </td> |
|
</tr> |
|
<tr> |
|
<td rowspan="3" bgcolor="$tabbg"> |
|
<font size="5" face="Arial, Helvetica, sans-serif"><b>$title</b></font> |
|
<td bgcolor="$tabbg" align="right"> |
|
<font size="2" face="Arial, Helvetica, sans-serif"> |
|
$ENV{'environment.firstname'} |
|
$ENV{'environment.middlename'} |
|
$ENV{'environment.lastname'} |
|
$ENV{'environment.generation'} |
|
</font> |
|
</td> |
|
</tr> |
|
<tr><td bgcolor="$tabbg" align="right"> |
|
<font size="2" face="Arial, Helvetica, sans-serif">$role</font> |
|
</td></tr> |
|
<tr> |
|
<td bgcolor="$tabbg" align="right"><font size="2" face="Arial, Helvetica, sans-serif">$realm</font> </td></tr> |
|
</table><br> |
|
ENDBODY |
|
} |
|
|
|
############################################### |
|
|
|
sub get_posted_cgi { |
|
my $r=shift; |
|
|
|
my $buffer; |
|
|
|
$r->read($buffer,$r->header_in('Content-length'),0); |
|
unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) { |
|
my @pairs=split(/&/,$buffer); |
|
my $pair; |
|
foreach $pair (@pairs) { |
|
my ($name,$value) = split(/=/,$pair); |
|
$value =~ tr/+/ /; |
|
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; |
|
$name =~ tr/+/ /; |
|
$name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; |
|
&add_to_env("form.$name",$value); |
|
} |
|
} else { |
|
my $contentsep=$1; |
|
my @lines = split (/\n/,$buffer); |
|
my $name=''; |
|
my $value=''; |
|
my $fname=''; |
|
my $fmime=''; |
|
my $i; |
|
for ($i=0;$i<=$#lines;$i++) { |
|
if ($lines[$i]=~/^$contentsep/) { |
|
if ($name) { |
|
chomp($value); |
|
if ($fname) { |
|
$ENV{"form.$name.filename"}=$fname; |
|
$ENV{"form.$name.mimetype"}=$fmime; |
|
} else { |
|
$value=~s/\s+$//s; |
|
} |
|
&add_to_env("form.$name",$value); |
|
} |
|
if ($i<$#lines) { |
|
$i++; |
|
$lines[$i]=~ |
|
/Content\-Disposition\:\s*form\-data\;\s*name\=\"([^\"]+)\"/i; |
|
$name=$1; |
|
$value=''; |
|
if ($lines[$i]=~/filename\=\"([^\"]+)\"/i) { |
|
$fname=$1; |
|
if |
|
($lines[$i+1]=~/Content\-Type\:\s*([\w\-\/]+)/i) { |
|
$fmime=$1; |
|
$i++; |
|
} else { |
|
$fmime=''; |
|
} |
|
} else { |
|
$fname=''; |
|
$fmime=''; |
|
} |
|
$i++; |
|
} |
|
} else { |
|
$value.=$lines[$i]."\n"; |
|
} |
|
} |
|
} |
|
$ENV{'request.method'}=$ENV{'REQUEST_METHOD'}; |
|
$r->method_number(M_GET); |
|
$r->method('GET'); |
|
$r->headers_in->unset('Content-length'); |
|
} |
|
|
|
=pod |
|
|
|
=item * get_unprocessed_cgi($query,$possible_names) |
|
|
|
Modify the %ENV hash to contain unprocessed CGI form parameters held in |
|
$query. The parameters listed in $possible_names (an array reference), |
|
will be set in $ENV{'form.name'} if they do not already exist. |
|
|
|
Typically called with $ENV{'QUERY_STRING'} as the first parameter. |
|
$possible_names is an ref to an array of form element names. As an example: |
|
get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']); |
|
will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set. |
|
|
|
=cut |
|
|
sub get_unprocessed_cgi { |
sub get_unprocessed_cgi { |
my ($query,$possible_names)= @_; |
my ($query,$possible_names)= @_; |
# $Apache::lonxml::debug=1; |
# $Apache::lonxml::debug=1; |
Line 1042 sub get_unprocessed_cgi {
|
Line 2295 sub get_unprocessed_cgi {
|
} |
} |
} |
} |
|
|
|
=pod |
|
|
|
=item * cacheheader() |
|
|
|
returns cache-controlling header code |
|
|
|
=cut |
|
|
sub cacheheader { |
sub cacheheader { |
unless ($ENV{'request.method'} eq 'GET') { return ''; } |
unless ($ENV{'request.method'} eq 'GET') { return ''; } |
my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); |
my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); |
Line 1051 sub cacheheader {
|
Line 2312 sub cacheheader {
|
return $output; |
return $output; |
} |
} |
|
|
|
=pod |
|
|
|
=item * no_cache($r) |
|
|
|
specifies header code to not have cache |
|
|
|
=cut |
|
|
sub no_cache { |
sub no_cache { |
my ($r) = @_; |
my ($r) = @_; |
unless ($ENV{'request.method'} eq 'GET') { return ''; } |
unless ($ENV{'request.method'} eq 'GET') { return ''; } |
Line 1060 sub no_cache {
|
Line 2329 sub no_cache {
|
#$r->header_out("Expires" => $date); |
#$r->header_out("Expires" => $date); |
} |
} |
|
|
|
sub content_type { |
|
my ($r,$type,$charset) = @_; |
|
unless ($charset) { |
|
$charset=&Apache::lonlocal::current_encoding; |
|
} |
|
$r->content_type($type.($charset?'; charset='.$charset:'')); |
|
} |
|
|
|
=pod |
|
|
|
=item * add_to_env($name,$value) |
|
|
|
adds $name to the %ENV hash with value |
|
$value, if $name already exists, the entry is converted to an array |
|
reference and $value is added to the array. |
|
|
|
=cut |
|
|
sub add_to_env { |
sub add_to_env { |
my ($name,$value)=@_; |
my ($name,$value)=@_; |
if (defined($ENV{$name})) { |
if (defined($ENV{$name})) { |
Line 1079 sub add_to_env {
|
Line 2366 sub add_to_env {
|
|
|
=pod |
=pod |
|
|
=head2 CSV Upload/Handling functions |
=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 |
=over 4 |
|
|
=item upfile_store($r) |
=item * upfile_store($r) |
|
|
Store uploaded file, $r should be the HTTP Request object, |
Store uploaded file, $r should be the HTTP Request object, |
needs $ENV{'form.upfile'} |
needs $ENV{'form.upfile'} |
Line 1108 sub upfile_store {
|
Line 2423 sub upfile_store {
|
return $datatoken; |
return $datatoken; |
} |
} |
|
|
=item load_tmp_file($r) |
=pod |
|
|
|
=item * load_tmp_file($r) |
|
|
Load uploaded file from tmp, $r should be the HTTP Request object, |
Load uploaded file from tmp, $r should be the HTTP Request object, |
needs $ENV{'form.datatoken'}, |
needs $ENV{'form.datatoken'}, |
Line 1129 sub load_tmp_file {
|
Line 2446 sub load_tmp_file {
|
$ENV{'form.upfile'}=join('',@studentdata); |
$ENV{'form.upfile'}=join('',@studentdata); |
} |
} |
|
|
=item upfile_record_sep() |
=pod |
|
|
|
=item * upfile_record_sep() |
|
|
Separate uploaded file into records |
Separate uploaded file into records |
returns array of records, |
returns array of records, |
Line 1144 sub upfile_record_sep {
|
Line 2463 sub upfile_record_sep {
|
} |
} |
} |
} |
|
|
=item record_sep($record) |
=pod |
|
|
|
=item * record_sep($record) |
|
|
Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'} |
Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'} |
|
|
Line 1194 sub record_sep {
|
Line 2515 sub record_sep {
|
return %components; |
return %components; |
} |
} |
|
|
=item upfile_select_html() |
###################################################### |
|
###################################################### |
|
|
|
=pod |
|
|
|
=item * upfile_select_html() |
|
|
return HTML code to select file and specify its type |
Return HTML code to select a file from the users machine and specify |
|
the file type. |
|
|
=cut |
=cut |
|
|
|
###################################################### |
|
###################################################### |
sub upfile_select_html { |
sub upfile_select_html { |
return (<<'ENDUPFORM'); |
my %Types = ( |
<input type="file" name="upfile" size="50"> |
csv => &mt('CSV (comma separated values, spreadsheet)'), |
<br />Type: <select name="upfiletype"> |
space => &mt('Space separated'), |
<option value="csv">CSV (comma separated values, spreadsheet)</option> |
tab => &mt('Tabulator separated'), |
<option value="space">Space separated</option> |
# xml => &mt('HTML/XML'), |
<option value="tab">Tabulator separated</option> |
); |
<option value="xml">HTML/XML</option> |
my $Str = '<input type="file" name="upfile" size="50" />'. |
</select> |
'<br />Type: <select name="upfiletype">'; |
ENDUPFORM |
foreach my $type (sort(keys(%Types))) { |
|
$Str .= '<option value="'.$type.'" >'.$Types{$type}."</option>\n"; |
|
} |
|
$Str .= "</select>\n"; |
|
return $Str; |
} |
} |
|
|
=item csv_print_samples($r,$records) |
###################################################### |
|
###################################################### |
|
|
|
=pod |
|
|
|
=item * csv_print_samples($r,$records) |
|
|
Prints a table of sample values from each column uploaded $r is an |
Prints a table of sample values from each column uploaded $r is an |
Apache Request ref, $records is an arrayref from |
Apache Request ref, $records is an arrayref from |
Line 1220 Apache Request ref, $records is an array
|
Line 2558 Apache Request ref, $records is an array
|
|
|
=cut |
=cut |
|
|
|
###################################################### |
|
###################################################### |
sub csv_print_samples { |
sub csv_print_samples { |
my ($r,$records) = @_; |
my ($r,$records) = @_; |
my (%sone,%stwo,%sthree); |
my (%sone,%stwo,%sthree); |
%sone=&record_sep($$records[0]); |
%sone=&record_sep($$records[0]); |
if (defined($$records[1])) {%stwo=&record_sep($$records[1]);} |
if (defined($$records[1])) {%stwo=&record_sep($$records[1]);} |
if (defined($$records[2])) {%sthree=&record_sep($$records[2]);} |
if (defined($$records[2])) {%sthree=&record_sep($$records[2]);} |
|
# |
$r->print('Samples<br /><table border="2"><tr>'); |
$r->print(&mt('Samples').'<br /><table border="2"><tr>'); |
foreach (sort({$a <=> $b} keys(%sone))) { $r->print('<th>Column '.($_+1).'</th>'); } |
foreach (sort({$a <=> $b} keys(%sone))) { |
|
$r->print('<th>'.&mt('Column [_1]',($_+1)).'</th>'); } |
$r->print('</tr>'); |
$r->print('</tr>'); |
foreach my $hash (\%sone,\%stwo,\%sthree) { |
foreach my $hash (\%sone,\%stwo,\%sthree) { |
$r->print('<tr>'); |
$r->print('<tr>'); |
Line 1242 sub csv_print_samples {
|
Line 2583 sub csv_print_samples {
|
$r->print('</tr></table><br />'."\n"); |
$r->print('</tr></table><br />'."\n"); |
} |
} |
|
|
=item csv_print_select_table($r,$records,$d) |
###################################################### |
|
###################################################### |
|
|
|
=pod |
|
|
|
=item * csv_print_select_table($r,$records,$d) |
|
|
Prints a table to create associations between values and table columns. |
Prints a table to create associations between values and table columns. |
|
|
$r is an Apache Request ref, |
$r is an Apache Request ref, |
$records is an arrayref from &Apache::loncommon::upfile_record_sep, |
$records is an arrayref from &Apache::loncommon::upfile_record_sep, |
$d is an array of 2 element arrays (internal name, displayed name) |
$d is an array of 2 element arrays (internal name, displayed name) |
|
|
=cut |
=cut |
|
|
|
###################################################### |
|
###################################################### |
sub csv_print_select_table { |
sub csv_print_select_table { |
my ($r,$records,$d) = @_; |
my ($r,$records,$d) = @_; |
my $i=0;my %sone; |
my $i=0;my %sone; |
%sone=&record_sep($$records[0]); |
%sone=&record_sep($$records[0]); |
$r->print('Associate columns with student attributes.'."\n". |
$r->print(&mt('Associate columns with student attributes.')."\n". |
'<table border="2"><tr><th>Attribute</th><th>Column</th></tr>'."\n"); |
'<table border="2"><tr>'. |
|
'<th>'.&mt('Attribute').'</th>'. |
|
'<th>'.&mt('Column').'</th></tr>'."\n"); |
foreach (@$d) { |
foreach (@$d) { |
my ($value,$display)=@{ $_ }; |
my ($value,$display)=@{ $_ }; |
$r->print('<tr><td>'.$display.'</td>'); |
$r->print('<tr><td>'.$display.'</td>'); |
Line 1274 sub csv_print_select_table {
|
Line 2625 sub csv_print_select_table {
|
return $i; |
return $i; |
} |
} |
|
|
=item csv_samples_select_table($r,$records,$d) |
###################################################### |
|
###################################################### |
|
|
|
=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. |
Prints a table of sample values from the upload and can make associate samples to internal names. |
|
|
Line 1284 $d is an array of 2 element arrays (inte
|
Line 2640 $d is an array of 2 element arrays (inte
|
|
|
=cut |
=cut |
|
|
|
###################################################### |
|
###################################################### |
sub csv_samples_select_table { |
sub csv_samples_select_table { |
my ($r,$records,$d) = @_; |
my ($r,$records,$d) = @_; |
my %sone; my %stwo; my %sthree; |
my %sone; my %stwo; my %sthree; |
my $i=0; |
my $i=0; |
|
# |
$r->print('<table border=2><tr><th>Field</th><th>Samples</th></tr>'); |
$r->print('<table border=2><tr><th>'. |
|
&mt('Field').'</th><th>'.&mt('Samples').'</th></tr>'); |
%sone=&record_sep($$records[0]); |
%sone=&record_sep($$records[0]); |
if (defined($$records[1])) {%stwo=&record_sep($$records[1]);} |
if (defined($$records[1])) {%stwo=&record_sep($$records[1]);} |
if (defined($$records[2])) {%sthree=&record_sep($$records[2]);} |
if (defined($$records[2])) {%sthree=&record_sep($$records[2]);} |
|
# |
foreach (sort keys %sone) { |
foreach (sort keys %sone) { |
$r->print('<tr><td><select name=f'.$i. |
$r->print('<tr><td><select name="f'.$i.'"'. |
' onchange="javascript:flip(this.form,'.$i.');">'); |
' onchange="javascript:flip(this.form,'.$i.');">'); |
foreach (@$d) { |
foreach (@$d) { |
my ($value,$display)=@{ $_ }; |
my ($value,$display)=@{ $_ }; |
$r->print('<option value='.$value.'>'.$display.'</option>'); |
$r->print('<option value="'.$value.'">'.$display.'</option>'); |
} |
} |
$r->print('</select></td><td>'); |
$r->print('</select></td><td>'); |
if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); } |
if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); } |
Line 1311 sub csv_samples_select_table {
|
Line 2670 sub csv_samples_select_table {
|
$i--; |
$i--; |
return($i); |
return($i); |
} |
} |
1; |
|
__END__; |
###################################################### |
|
###################################################### |
|
|
=pod |
=pod |
|
|
=back |
=item clean_excel_name($name) |
|
|
|
Returns a replacement for $name which does not contain any illegal characters. |
|
|
|
=cut |
|
|
|
###################################################### |
|
###################################################### |
|
sub clean_excel_name { |
|
my ($name) = @_; |
|
$name =~ s/[:\*\?\/\\]//g; |
|
if (length($name) > 31) { |
|
$name = substr($name,0,31); |
|
} |
|
return $name; |
|
} |
|
|
|
=pod |
|
|
|
=item * check_if_partid_hidden($id,$symb,$udom,$uname) |
|
|
|
Returns either 1 or undef |
|
|
|
1 if the part is to be hidden, undef if it is to be shown |
|
|
|
Arguments are: |
|
|
|
$id the id of the part to be checked |
|
$symb, optional the symb of the resource to check |
|
$udom, optional the domain of the user to check for |
|
$uname, optional the username of the user to check for |
|
|
|
=cut |
|
|
|
sub check_if_partid_hidden { |
|
my ($id,$symb,$udom,$uname) = @_; |
|
my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts', |
|
$symb,$udom,$uname); |
|
my $truth=1; |
|
#if the string starts with !, then the list is the list to show not hide |
|
if ($hiddenparts=~s/^\s*!//) { $truth=undef; } |
|
my @hiddenlist=split(/,/,$hiddenparts); |
|
foreach my $checkid (@hiddenlist) { |
|
if ($checkid =~ /^\s*\Q$id\E\s*$/) { return $truth; } |
|
} |
|
return !$truth; |
|
} |
|
|
|
|
|
############################################################ |
|
############################################################ |
|
|
|
=pod |
|
|
|
=head1 cgi-bin script and graphing routines |
|
|
|
=item get_cgi_id |
|
|
|
Inputs: none |
|
|
|
Returns an id which can be used to pass environment variables |
|
to various cgi-bin scripts. These environment variables will |
|
be removed from the users environment after a given time by |
|
the routine &Apache::lonnet::transfer_profile_to_env. |
|
|
|
=cut |
|
|
|
############################################################ |
|
############################################################ |
|
my $uniq=0; |
|
sub get_cgi_id { |
|
$uniq=($uniq+1)%100000; |
|
return (time.'_'.$uniq); |
|
} |
|
|
=head2 Access .tab File Data |
############################################################ |
|
############################################################ |
|
|
|
=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 |
=over 4 |
|
|
=item languageids() |
=item $Title: string, the title of the plot |
|
|
returns list of all language ids |
=item $xlabel: string, text describing the X-axis of the plot |
|
|
=item languagedescription() |
=item $ylabel: string, text describing the Y-axis of the plot |
|
|
returns description of a specified language id |
=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 copyrightids() |
=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. |
|
|
returns list of all copyrights |
=item @Values: An array of array references. Each array reference holds data |
|
to be plotted in a stacked bar chart. |
|
|
=item copyrightdescription() |
=back |
|
|
returns description of a specified copyright id |
Returns: |
|
|
=item filecategories() |
An <img> tag which references graph.png and the appropriate identifying |
|
information for the plot. |
|
|
returns list of all file categories |
=cut |
|
|
=item filecategorytypes() |
############################################################ |
|
############################################################ |
|
sub DrawBarGraph { |
|
my ($Title,$xlabel,$ylabel,$Max,$colors,@Values)=@_; |
|
# |
|
if (! defined($colors)) { |
|
$colors = ['#33ff00', |
|
'#0033cc', '#990000', '#aaaa66', '#663399', '#ff9933', |
|
'#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66', |
|
]; |
|
} |
|
# |
|
my $identifier = &get_cgi_id(); |
|
my $id = 'cgi.'.$identifier; |
|
if (! @Values || ref($Values[0]) ne 'ARRAY') { |
|
return ''; |
|
} |
|
my $NumBars = scalar(@{$Values[0]}); |
|
my %ValuesHash; |
|
my $NumSets=1; |
|
foreach my $array (@Values) { |
|
next if (! ref($array)); |
|
$ValuesHash{$id.'.data.'.$NumSets++} = |
|
join(',',@$array); |
|
} |
|
# |
|
my ($height,$width,$xskip,$bar_width) = (200,120,1,15); |
|
if ($NumBars < 10) { |
|
$width = 120+$NumBars*15; |
|
$xskip = 1; |
|
$bar_width = 15; |
|
} elsif ($NumBars <= 25) { |
|
$width = 120+$NumBars*11; |
|
$xskip = 5; |
|
$bar_width = 8; |
|
} elsif ($NumBars <= 50) { |
|
$width = 120+$NumBars*8; |
|
$xskip = 5; |
|
$bar_width = 4; |
|
} else { |
|
$width = 120+$NumBars*8; |
|
$xskip = 5; |
|
$bar_width = 4; |
|
} |
|
# |
|
my @Labels; |
|
for (my $i=0;$i<@{$Values[0]};$i++) { |
|
push (@Labels,$i+1); |
|
} |
|
# |
|
$Max = 1 if ($Max < 1); |
|
if ( int($Max) < $Max ) { |
|
$Max++; |
|
$Max = int($Max); |
|
} |
|
$Title = '' if (! defined($Title)); |
|
$xlabel = '' if (! defined($xlabel)); |
|
$ylabel = '' if (! defined($ylabel)); |
|
$ValuesHash{$id.'.title'} = &Apache::lonnet::escape($Title); |
|
$ValuesHash{$id.'.xlabel'} = &Apache::lonnet::escape($xlabel); |
|
$ValuesHash{$id.'.ylabel'} = &Apache::lonnet::escape($ylabel); |
|
$ValuesHash{$id.'.y_max_value'} = $Max; |
|
$ValuesHash{$id.'.NumBars'} = $NumBars; |
|
$ValuesHash{$id.'.NumSets'} = $NumSets; |
|
$ValuesHash{$id.'.PlotType'} = 'bar'; |
|
$ValuesHash{$id.'.Colors'} = join(',',@{$colors}); |
|
$ValuesHash{$id.'.height'} = $height; |
|
$ValuesHash{$id.'.width'} = $width; |
|
$ValuesHash{$id.'.xskip'} = $xskip; |
|
$ValuesHash{$id.'.bar_width'} = $bar_width; |
|
$ValuesHash{$id.'.labels'} = join(',',@Labels); |
|
# |
|
&Apache::lonnet::appenv(%ValuesHash); |
|
return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />'; |
|
} |
|
|
returns list of file types belonging to a given file |
############################################################ |
category |
############################################################ |
|
|
=item fileembstyle() |
=pod |
|
|
returns embedding style for a specified file type |
=item DrawXYGraph |
|
|
=item filedescription() |
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. |
|
|
returns description for a specified file type |
Inputs: |
|
|
=item filedescriptionex() |
=over 4 |
|
|
returns description for a specified file type with |
=item $Title: string, the title of the plot |
extra formatting |
|
|
=item $xlabel: string, text describing the X-axis of the plot |
|
|
|
=item $ylabel: string, text describing the Y-axis of the plot |
|
|
|
=item $Max: scalar, the maximum Y value to use in the plot |
|
If $Max is < any data point, the graph will not be rendered. |
|
|
|
=item $colors: Array ref containing the hex color codes for the data to be |
|
plotted in. If undefined, default values will be used. |
|
|
|
=item $Xlabels: Array ref containing the labels to be used for the X-axis. |
|
|
|
=item $Ydata: Array ref containing Array refs. |
|
Each of the contained arrays will be plotted as a seperate curve. |
|
|
|
=item %Values: hash indicating or overriding any default values which are |
|
passed to graph.png. |
|
Possible values are: width, xskip, x_ticks, x_tick_offset, among others. |
|
|
=back |
=back |
|
|
=head2 Alternate Problem Views |
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 |
=over 4 |
|
|
=item get_previous_attempt() |
=item $Title: string, the title of the plot |
|
|
return string with previous attempt on problem |
=item $xlabel: string, text describing the X-axis of the plot |
|
|
=item get_student_view() |
=item $ylabel: string, text describing the Y-axis of the plot |
|
|
show a snapshot of what student was looking at |
=item $colors: Array ref containing the hex color codes for the data to be |
|
plotted in. If undefined, default values will be used. |
|
|
=item get_student_answers() |
=item $Xlabels: Array ref containing the labels to be used for the X-axis. |
|
|
show a snapshot of how student was answering problem |
=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 |
=back |
|
|
=head2 HTTP Helper |
Returns: |
|
|
|
An <img> tag which references graph.png and the appropriate identifying |
|
information for the plot. |
|
|
|
=cut |
|
|
|
############################################################ |
|
############################################################ |
|
sub DrawXYYGraph { |
|
my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1, |
|
$Ydata2,$Min2,$Max2,%Values)=@_; |
|
# |
|
# Create the identifier for the graph |
|
my $identifier = &get_cgi_id(); |
|
my $id = 'cgi.'.$identifier; |
|
# |
|
$Title = '' if (! defined($Title)); |
|
$xlabel = '' if (! defined($xlabel)); |
|
$ylabel = '' if (! defined($ylabel)); |
|
my %ValuesHash = |
|
( |
|
$id.'.title' => &Apache::lonnet::escape($Title), |
|
$id.'.xlabel' => &Apache::lonnet::escape($xlabel), |
|
$id.'.ylabel' => &Apache::lonnet::escape($ylabel), |
|
$id.'.labels' => join(',',@$Xlabels), |
|
$id.'.PlotType' => 'XY', |
|
$id.'.NumSets' => 2, |
|
$id.'.two_axes' => 1, |
|
$id.'.y1_max_value' => $Max1, |
|
$id.'.y1_min_value' => $Min1, |
|
$id.'.y2_max_value' => $Max2, |
|
$id.'.y2_min_value' => $Min2, |
|
); |
|
# |
|
if (defined($colors) && ref($colors) eq 'ARRAY') { |
|
$ValuesHash{$id.'.Colors'} = join(',',@{$colors}); |
|
} |
|
# |
|
if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' || |
|
! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){ |
|
return ''; |
|
} |
|
my $NumSets=1; |
|
foreach my $array ($Ydata1,$Ydata2){ |
|
next if (! ref($array)); |
|
$ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array); |
|
} |
|
# |
|
# Deal with other parameters |
|
while (my ($key,$value) = each(%Values)) { |
|
$ValuesHash{$id.'.'.$key} = $value; |
|
} |
|
# |
|
&Apache::lonnet::appenv(%ValuesHash); |
|
return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />'; |
|
} |
|
|
|
############################################################ |
|
############################################################ |
|
|
|
=pod |
|
|
|
=head1 Statistics helper routines? |
|
|
|
Bad place for them but what the hell. |
|
|
|
=item &chartlink |
|
|
|
Returns a link to the chart for a specific student. |
|
|
|
Inputs: |
|
|
=over 4 |
=over 4 |
|
|
=item get_unprocessed_cgi($query,$possible_names) |
=item $linktext: The text of the link |
|
|
Modify the %ENV hash to contain unprocessed CGI form parameters held in |
=item $sname: The students username |
$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. |
=item $sdomain: The students domain |
$possible_names is an ref to an array of form element names. As an example: |
|
get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']); |
|
will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set. |
|
|
|
=item cacheheader() |
=back |
|
|
returns cache-controlling header code |
=cut |
|
|
=item nocache() |
############################################################ |
|
############################################################ |
|
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>'; |
|
} |
|
|
specifies header code to not have cache |
####################################################### |
|
####################################################### |
|
|
=item add_to_env($name,$value) |
=pod |
|
|
adds $name to the %ENV hash with value |
=head1 Course Environment Routines |
$value, if $name already exists, the entry is converted to an array |
|
reference and $value is added to the array. |
=item &restore_course_settings |
|
|
|
=item &store_course_settings |
|
|
|
Restores/Store indicated form parameters from the course environment. |
|
Will not overwrite existing values of the form parameters. |
|
|
|
Inputs: |
|
a scalar describing the data (e.g. 'chart', 'problem_analysis') |
|
|
|
a hash ref describing the data to be stored. For example: |
|
|
|
%Save_Parameters = ('Status' => 'scalar', |
|
'chartoutputmode' => 'scalar', |
|
'chartoutputdata' => 'scalar', |
|
'Section' => 'array', |
|
'StudentData' => 'array', |
|
'Maps' => 'array'); |
|
|
|
Returns: both routines return nothing |
|
|
|
=cut |
|
|
|
####################################################### |
|
####################################################### |
|
sub store_course_settings { |
|
# save to the environment |
|
# appenv the same items, just to be safe |
|
my $courseid = $ENV{'request.course.id'}; |
|
my $coursedom = $ENV{'course.'.$courseid.'.domain'}; |
|
my ($prefix,$Settings) = @_; |
|
my %SaveHash; |
|
my %AppHash; |
|
while (my ($setting,$type) = each(%$Settings)) { |
|
my $basename = 'env.internal.'.$prefix.'.'.$setting; |
|
my $envname = 'course.'.$courseid.'.'.$basename; |
|
if (exists($ENV{'form.'.$setting})) { |
|
# Save this value away |
|
if ($type eq 'scalar' && |
|
(! exists($ENV{$envname}) || |
|
$ENV{$envname} ne $ENV{'form.'.$setting})) { |
|
$SaveHash{$basename} = $ENV{'form.'.$setting}; |
|
$AppHash{$envname} = $ENV{'form.'.$setting}; |
|
} elsif ($type eq 'array') { |
|
my $stored_form; |
|
if (ref($ENV{'form.'.$setting})) { |
|
$stored_form = join(',', |
|
map { |
|
&Apache::lonnet::escape($_); |
|
} sort(@{$ENV{'form.'.$setting}})); |
|
} else { |
|
$stored_form = |
|
&Apache::lonnet::escape($ENV{'form.'.$setting}); |
|
} |
|
# Determine if the array contents are the same. |
|
if ($stored_form ne $ENV{$envname}) { |
|
$SaveHash{$basename} = $stored_form; |
|
$AppHash{$envname} = $stored_form; |
|
} |
|
} |
|
} |
|
} |
|
my $put_result = &Apache::lonnet::put('environment',\%SaveHash, |
|
$coursedom, |
|
$ENV{'course.'.$courseid.'.num'}); |
|
if ($put_result !~ /^(ok|delayed)/) { |
|
&Apache::lonnet::logthis('unable to save form parameters, '. |
|
'got error:'.$put_result); |
|
} |
|
# Make sure these settings stick around in this session, too |
|
&Apache::lonnet::appenv(%AppHash); |
|
return; |
|
} |
|
|
|
sub restore_course_settings { |
|
my $courseid = $ENV{'request.course.id'}; |
|
my ($prefix,$Settings) = @_; |
|
while (my ($setting,$type) = each(%$Settings)) { |
|
next if (exists($ENV{'form.'.$setting})); |
|
my $envname = 'course.'.$courseid.'.env.internal.'.$prefix. |
|
'.'.$setting; |
|
if (exists($ENV{$envname})) { |
|
if ($type eq 'scalar') { |
|
$ENV{'form.'.$setting} = $ENV{$envname}; |
|
} elsif ($type eq 'array') { |
|
$ENV{'form.'.$setting} = [ |
|
map { |
|
&Apache::lonnet::unescape($_); |
|
} split(',',$ENV{$envname}) |
|
]; |
|
} |
|
} |
|
} |
|
} |
|
|
|
############################################################ |
|
############################################################ |
|
|
|
sub propath { |
|
my ($udom,$uname)=@_; |
|
$udom=~s/\W//g; |
|
$uname=~s/\W//g; |
|
my $subdir=$uname.'__'; |
|
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
|
my $proname="$Apache::lonnet::perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; |
|
return $proname; |
|
} |
|
|
|
=pod |
|
|
=back |
=back |
|
|
=cut |
=cut |
|
|
|
1; |
|
__END__; |
|
|