--- loncom/interface/loncommon.pm 2003/11/17 15:14:48 1.155
+++ loncom/interface/loncommon.pm 2004/11/13 21:06:27 1.231
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# a pile of common routines
#
-# $Id: loncommon.pm,v 1.155 2003/11/17 15:14:48 www Exp $
+# $Id: loncommon.pm,v 1.231 2004/11/13 21:06:27 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -25,13 +25,6 @@
#
# http://www.lon-capa.org/
#
-# YEAR=2001
-# 2/13-12/7 Guy Albertelli
-# 12/21 Gerd Kortemeyer
-# 12/25,12/28 Gerd Kortemeyer
-# YEAR=2002
-# 1/4 Gerd Kortemeyer
-# 6/24,7/2 H. K. Ng
# Makes a table out of the previous attempts
# Inputs result_from_symbread, user, domain, course_id
@@ -66,23 +59,21 @@ use Apache::lonnet();
use GDBM_File;
use POSIX qw(strftime mktime);
use Apache::Constants qw(:common :http :methods);
-use Apache::lonmsg();
use Apache::lonmenu();
use Apache::lonlocal;
use HTML::Entities;
my $readit;
-=pod
-
-=head1 Global Variables
-
-=cut
+##
+## Global Variables
+##
# ----------------------------------------------- Filetypes/Languages/Copyright
my %language;
my %supported_language;
my %cprtag;
+my %scprtag;
my %fe; my %fd;
my %category_extensions;
@@ -111,32 +102,48 @@ BEGIN {
unless ($readit) {
# ------------------------------------------------------------------- languages
{
- my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
- '/language.tab');
- if ($fh) {
- while (<$fh>) {
- next if /^\#/;
- chomp;
- my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$_));
- $language{$key}=$val.' - '.$enc;
- if ($sup) {
- $supported_language{$key}=$sup;
- }
- }
- }
+ my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.
+ '/language.tab';
+ if ( open(my $fh,"<$langtabfile") ) {
+ while (<$fh>) {
+ next if /^\#/;
+ chomp;
+ my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$_));
+ $language{$key}=$val.' - '.$enc;
+ if ($sup) {
+ $supported_language{$key}=$sup;
+ }
+ }
+ close($fh);
+ }
}
# ------------------------------------------------------------------ copyrights
{
- my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonIncludes'}.
- '/copyright.tab');
- if ($fh) {
- while (<$fh>) {
- next if /^\#/;
- chomp;
- my ($key,$val)=(split(/\s+/,$_,2));
- $cprtag{$key}=$val;
- }
- }
+ my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
+ '/copyright.tab';
+ if ( open (my $fh,"<$copyrightfile") ) {
+ while (<$fh>) {
+ next if /^\#/;
+ chomp;
+ my ($key,$val)=(split(/\s+/,$_,2));
+ $cprtag{$key}=$val;
+ }
+ close($fh);
+ }
+ }
+# ------------------------------------------------------------------ source copyrights
+ {
+ my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
+ '/source_copyright.tab';
+ if ( open (my $fh,"<$sourcecopyrightfile") ) {
+ while (<$fh>) {
+ next if /^\#/;
+ chomp;
+ my ($key,$val)=(split(/\s+/,$_,2));
+ $scprtag{$key}=$val;
+ }
+ close($fh);
+ }
}
# -------------------------------------------------------------- domain designs
@@ -147,15 +154,16 @@ BEGIN {
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; }
- }
- }
+ my $designfile = $designdir.'/'.$filename;
+ if ( open (my $fh,"<$designfile") ) {
+ while (<$fh>) {
+ next if /^\#/;
+ chomp;
+ my ($key,$val)=(split(/\=/,$_));
+ if ($val) { $designhash{$domain.'.'.$key}=$val; }
+ }
+ close($fh);
+ }
}
}
@@ -164,32 +172,35 @@ BEGIN {
# ------------------------------------------------------------- file categories
{
- my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
- '/filecategories.tab');
- if ($fh) {
- while (<$fh>) {
- next if /^\#/;
- chomp;
- my ($extension,$category)=(split(/\s+/,$_,2));
- push @{$category_extensions{lc($category)}},$extension;
- }
- }
+ my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.
+ '/filecategories.tab';
+ if ( open (my $fh,"<$categoryfile") ) {
+ while (<$fh>) {
+ next if /^\#/;
+ chomp;
+ my ($extension,$category)=(split(/\s+/,$_,2));
+ push @{$category_extensions{lc($category)}},$extension;
+ }
+ close($fh);
+ }
+
}
# ------------------------------------------------------------------ file types
{
- my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
- '/filetypes.tab');
- if ($fh) {
+ my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.
+ '/filetypes.tab';
+ if ( open (my $fh,"<$typesfile") ) {
while (<$fh>) {
- next if (/^\#/);
- chomp;
- my ($ending,$emb,$descr)=split(/\s+/,$_,3);
- if ($descr ne '') {
- $fe{$ending}=lc($emb);
- $fd{$ending}=$descr;
- }
- }
- }
+ next if (/^\#/);
+ chomp;
+ my ($ending,$emb,$descr)=split(/\s+/,$_,3);
+ if ($descr ne '') {
+ $fe{$ending}=lc($emb);
+ $fd{$ending}=$descr;
+ }
+ }
+ close($fh);
+ }
}
&Apache::lonnet::logthis(
"<font color=yellow>INFO: Read file types</font>");
@@ -204,10 +215,6 @@ BEGIN {
=pod
-=head1 General Subroutines
-
-=over 4
-
=head1 HTML and Javascript Functions
=over 4
@@ -219,8 +226,6 @@ containing javascript with two functions
C<opensearcher>. Returned string does not contain E<lt>scriptE<gt>
tags.
-=over 4
-
=item * openbrowser(formname,elementname,only,omit) [javascript]
inputs: formname, elementname, only, omit
@@ -229,10 +234,10 @@ formname and elementname indicate the na
the element that the results of the browsing selection are to be placed in.
Specifying 'only' will restrict the browser to displaying only files
-with the given extension. Can be a comma seperated list.
+with the given extension. Can be a comma separated list.
Specifying 'omit' will restrict the browser to NOT displaying files
-with the given extension. Can be a comma seperated list.
+with the given extension. Can be a comma separated list.
=item * opensearcher(formname, elementname) [javascript]
@@ -241,33 +246,41 @@ Inputs: formname, elementname
formname and elementname specify the name of the html form and the name
of the element the selection from the search results will be placed in.
-=back
-
=cut
sub browser_and_searcher_javascript {
+ my ($mode)=@_;
+ if (!defined($mode)) { $mode='edit'; }
+ my $resurl=&lastresurl();
return <<END;
+// <!-- BEGIN LON-CAPA Internal
var editbrowser = null;
function openbrowser(formname,elementname,only,omit,titleelement) {
- var url = '/res/?';
+ var url = '$resurl/?';
if (editbrowser == null) {
url += 'launch=1&';
}
url += 'catalogmode=interactive&';
- url += 'mode=edit&';
+ url += 'mode=$mode&';
url += 'form=' + formname + '&';
if (only != null) {
url += 'only=' + only + '&';
- }
+ } else {
+ url += 'only=&';
+ }
if (omit != null) {
url += 'omit=' + omit + '&';
- }
+ } else {
+ url += 'omit=&';
+ }
if (titleelement != null) {
url += 'titleelement=' + titleelement + '&';
- }
+ } else {
+ url += 'titleelement=&';
+ }
url += 'element=' + elementname + '';
var title = 'Browser';
- var options = 'scrollbars=1,resizable=1,menubar=0';
+ var options = 'scrollbars=1,resizable=1,menubar=1,location=1';
options += ',width=700,height=600';
editbrowser = open(url,title,options,'1');
editbrowser.focus();
@@ -279,11 +292,13 @@ sub browser_and_searcher_javascript {
url += 'launch=1&';
}
url += 'catalogmode=interactive&';
- url += 'mode=edit&';
+ url += 'mode=$mode&';
url += 'form=' + formname + '&';
if (titleelement != null) {
url += 'titleelement=' + titleelement + '&';
- }
+ } else {
+ url += 'titleelement=&';
+ }
url += 'element=' + elementname + '';
var title = 'Search';
var options = 'scrollbars=1,resizable=1,menubar=0';
@@ -291,9 +306,27 @@ sub browser_and_searcher_javascript {
editsearcher = open(url,title,options,'1');
editsearcher.focus();
}
+// END LON-CAPA Internal -->
END
}
+sub lastresurl {
+ if ($ENV{'environment.lastresurl'}) {
+ return $ENV{'environment.lastresurl'}
+ } else {
+ return '/res';
+ }
+}
+
+sub storeresurl {
+ my $resurl=&Apache::lonnet::clutter(shift);
+ unless ($resurl=~/^\/res/) { return 0; }
+ $resurl=~s/\/$//;
+ &Apache::lonnet::put('environment',{'lastresurl' => $resurl});
+ &Apache::lonnet::appenv('environment.lastresurl' => $resurl);
+ return 1;
+}
+
sub studentbrowser_javascript {
unless (
(($ENV{'request.course.id'}) &&
@@ -342,11 +375,12 @@ sub selectstudent_link {
}
sub coursebrowser_javascript {
- my ($domainfilter)=@_;
+ my ($domainfilter,$roleelement)=@_;
return (<<ENDSTDBRW);
<script type="text/javascript" language="Javascript" >
+ var extra_element = "$roleelement"
var stdeditbrowser;
- function opencrsbrowser(formname,uname,udom) {
+ function opencrsbrowser(formname,uname,udom,desc) {
var url = '/adm/pickcourse?';
var filter;
if (filter != null) {
@@ -361,7 +395,11 @@ sub coursebrowser_javascript {
}
}
url += 'form=' + formname + '&cnumelement='+uname+
- '&cdomelement='+udom;
+ '&cdomelement='+udom+
+ '&cnameelement='+desc;
+ if (extra_element != '') {
+ url += '&roleelement=$roleelement';
+ }
var title = 'Course_Browser';
var options = 'scrollbars=1,resizable=1,menubar=0';
options += ',width=700,height=600';
@@ -373,9 +411,9 @@ ENDSTDBRW
}
sub selectcourse_link {
- my ($form,$unameele,$udomele)=@_;
+ my ($form,$unameele,$udomele,$desc)=@_;
return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.
- '","'.$udomele.'");'."'>".&mt('Select Course')."</a>";
+ '","'.$udomele.'","'.$desc.'");'."'>".&mt('Select Course')."</a>";
}
=pod
@@ -458,7 +496,7 @@ sub linked_select_forms {
my $first = "document.$formname.$firstselectname";
# output the javascript to do the changing
my $result = '';
- $result.="<script>\n";
+ $result.="<script type=\"text/javascript\">\n";
$result.="var select2data = new Object();\n";
$" = '","';
my $debug = '';
@@ -565,6 +603,8 @@ sub help_open_topic {
my $template = "";
my $link;
+ $topic=~s/\W/\_/g;
+
if (!$stayOnPage)
{
$link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
@@ -583,8 +623,10 @@ sub help_open_topic {
}
# Add the graphic
+ my $title = &mt('Online Help');
+ my $helpicon=&lonhttpdurl("/adm/help/gif/smallHelp.gif");
$template .= <<"ENDTEMPLATE";
- <a href="$link"><image src="/adm/help/gif/smallHelp.gif" border="0" alt="(Help: $topic)" /></a>
+ <a href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help: $topic)" /></a>
ENDTEMPLATE
if ($text ne '') { $template.='</td></tr></table>' };
return $template;
@@ -611,22 +653,243 @@ sub helpLatexCheatsheet {
.'</td></tr></table>';
}
+sub help_open_menu {
+ my ($color,$topic,$component_help,$function,$faq,$bug,$stayOnPage,$width,$height,$text) = @_;
+ $text = "" if (not defined $text);
+ $stayOnPage = 0 if (not defined $stayOnPage);
+ if ($ENV{'browser.interface'} eq 'textual' ||
+ $ENV{'environment.remote'} eq 'off' ) {
+ $stayOnPage=1;
+ }
+ $width = 620 if (not defined $width);
+ $height = 600 if (not defined $height);
+ my $link='';
+ my $title = &mt('Get help');
+ my $origurl = $ENV{'REQUEST_URI'};
+ $origurl=~s|^/~|/priv/|;
+ my $timestamp = time;
+ foreach (\$color,\$function,\$topic,\$component_help,\$faq,\$bug,\$origurl) {
+ $$_ = &Apache::lonnet::escape($$_);
+ }
+
+ if (!$stayOnPage) {
+ $link = "javascript:helpMenu('open')";
+ } else {
+ $link = "javascript:helpMenu('display')";
+ }
+ my $banner_link = "/adm/helpmenu?page=banner&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp&stayonpage=$stayOnPage";
+ my $details_link = "/adm/helpmenu?page=body&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp";
+ my $template;
+ if ($text ne "") {
+ $template .=
+ "<table bgcolor='#773311' cellspacing='1' cellpadding='1' border='0'><tr>".
+ "<td bgcolor='#886622'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
+ }
+ my $helpicon=&lonhttpdurl("/adm/lonIcons/helpgateway.gif");
+ $template .= <<"ENDTEMPLATE";
+ <script type="text/javascript">
+//<!-- BEGIN LON-CAPA Internal
+function helpMenu(caller) {
+ if (caller == 'open') {
+ newWindow = window.open("","helpmenu","HEIGHT=$height,WIDTH=$width,resize=yes,scrollbars=yes" )
+ caller = newWindow.document
+ } else {
+ caller = this.document
+ }
+ caller.write("<html><head><title>LON-CAPA Help Menu</title><meta http-equiv='pragma' content='no-cache'></head>")
+ caller.write("<frameset rows='105,*' border='0'><frame name='bannerframe' src='$banner_link'><frame name='bodyframe' src='$details_link'></frameset>")
+ caller.write("</html>")
+ caller.close()
+ if (caller == newWindow.document) {
+ caller.focus()
+ }
+}
+// END LON-CAPA Internal -->
+ </script>
+ <a href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help Menu)" /></a>
+ENDTEMPLATE
+ if ($component_help) {
+ if (!$text) {
+ $template=&help_open_topic($component_help,undef,$stayOnPage,
+ $width,$height).' '.$template;
+ } else {
+ my $help_text;
+ $help_text=&Apache::lonnet::unescape($topic);
+ $template='<table><tr><td>'.
+ &help_open_topic($component_help,$help_text,$stayOnPage,
+ $width,$height).'</td><td>'.$template.
+ '</td></tr></table>';
+ }
+ }
+ if ($text ne '') { $template.='</td></tr></table>' };
+ return $template;
+}
+
+sub help_open_bug {
+ my ($topic, $text, $stayOnPage, $width, $height) = @_;
+ unless ($ENV{'user.adv'}) { return ''; }
+ unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; }
+ $text = "" if (not defined $text);
+ $stayOnPage = 0 if (not defined $stayOnPage);
+ if ($ENV{'browser.interface'} eq 'textual' ||
+ $ENV{'environment.remote'} eq 'off' ) {
+ $stayOnPage=1;
+ }
+ $width = 600 if (not defined $width);
+ $height = 600 if (not defined $height);
+
+ $topic=~s/\W+/\+/g;
+ my $link='';
+ my $template='';
+ my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='.
+ &Apache::lonnet::escape($ENV{'REQUEST_URI'}).'&component='.$topic;
+ if (!$stayOnPage)
+ {
+ $link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
+ }
+ else
+ {
+ $link = $url;
+ }
+ # Add the text
+ if ($text ne "")
+ {
+ $template .=
+ "<table bgcolor='#AA3333' cellspacing='1' cellpadding='1' border='0'><tr>".
+ "<td bgcolor='#FF5555'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
+ }
+
+ # Add the graphic
+ my $title = &mt('Report a Bug');
+ my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif");
+ $template .= <<"ENDTEMPLATE";
+ <a href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a>
+ENDTEMPLATE
+ if ($text ne '') { $template.='</td></tr></table>' };
+ return $template;
+
+}
+
+sub help_open_faq {
+ my ($topic, $text, $stayOnPage, $width, $height) = @_;
+ unless ($ENV{'user.adv'}) { return ''; }
+ unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; }
+ $text = "" if (not defined $text);
+ $stayOnPage = 0 if (not defined $stayOnPage);
+ if ($ENV{'browser.interface'} eq 'textual' ||
+ $ENV{'environment.remote'} eq 'off' ) {
+ $stayOnPage=1;
+ }
+ $width = 350 if (not defined $width);
+ $height = 400 if (not defined $height);
+
+ $topic=~s/\W+/\+/g;
+ my $link='';
+ my $template='';
+ my $url=$Apache::lonnet::perlvar{'FAQHost'}.'/fom/cache/'.$topic.'.html';
+ if (!$stayOnPage)
+ {
+ $link = "javascript:void(open('$url', 'FAQ-O-Matic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
+ }
+ else
+ {
+ $link = $url;
+ }
+
+ # Add the text
+ if ($text ne "")
+ {
+ $template .=
+ "<table bgcolor='#337733' cellspacing='1' cellpadding='1' border='0'><tr>".
+ "<td bgcolor='#448844'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
+ }
+
+ # Add the graphic
+ my $title = &mt('View the FAQ');
+ my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif");
+ $template .= <<"ENDTEMPLATE";
+ <a href="$link" title="$title"><img src="$faqicon" border="0" alt="(FAQ: $topic)" /></a>
+ENDTEMPLATE
+ if ($text ne '') { $template.='</td></tr></table>' };
+ return $template;
+
+}
+
+###############################################################
+###############################################################
+
=pod
=item * csv_translate($text)
-Translate $text to allow it to be output as a 'comma seperated values'
+Translate $text to allow it to be output as a 'comma separated values'
format.
=cut
+###############################################################
+###############################################################
sub csv_translate {
my $text = shift;
$text =~ s/\"/\"\"/g;
- $text =~ s/\n//g;
+ $text =~ s/\n/ /g;
return $text;
}
+
+###############################################################
+###############################################################
+
+=pod
+
+=item * define_excel_formats
+
+Define some commonly used Excel cell formats.
+
+Currently supported formats:
+
+=over 4
+
+=item header
+
+=item bold
+
+=item h1
+
+=item h2
+
+=item h3
+
+=item date
+
+=back
+
+Inputs: $workbook
+
+Returns: $format, a hash reference.
+
+=cut
+
+###############################################################
+###############################################################
+sub define_excel_formats {
+ my ($workbook) = @_;
+ my $format;
+ $format->{'header'} = $workbook->add_format(bold => 1,
+ bottom => 1,
+ align => 'center');
+ $format->{'bold'} = $workbook->add_format(bold=>1);
+ $format->{'h1'} = $workbook->add_format(bold=>1, size=>18);
+ $format->{'h2'} = $workbook->add_format(bold=>1, size=>16);
+ $format->{'h3'} = $workbook->add_format(bold=>1, size=>14);
+ $format->{'date'} = $workbook->add_format(num_format=>
+ 'mm/dd/yyyy hh:mm:ss');
+ return $format;
+}
+
+###############################################################
+###############################################################
+
=pod
=item * change_content_javascript():
@@ -735,11 +998,46 @@ sub get_domains {
my @domains;
my %seen;
foreach (sort values(%Apache::lonnet::hostdom)) {
- push (@domains,$_) unless $seen{$_}++;
+ push (@domains,$_) unless $seen{$_}++;
}
return @domains;
}
+# ------------------------------------------
+
+sub domain_select {
+ my ($name,$value,$multiple)=@_;
+ my %domains=map {
+ $_ => $_.' '.$Apache::lonnet::domaindescription{$_}
+ } &get_domains;
+ if ($multiple) {
+ $domains{''}=&mt('Any domain');
+ return &multiple_select_form($name,$value,4,%domains);
+ } else {
+ return &select_form($name,$value,%domains);
+ }
+}
+
+sub multiple_select_form {
+ my ($name,$value,$size,%hash)=@_;
+ my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);
+ my $output='';
+ if (! defined($size)) {
+ $size = 4;
+ if (scalar(keys(%hash))<4) {
+ $size = scalar(keys(%hash));
+ }
+ }
+ $output.="\n<select name='$name' size='$size' multiple='1'>";
+ foreach (sort(keys(%hash))) {
+ $output.='<option value="'.$_.'" ';
+ $output.='selected ' if ($selected{$_});
+ $output.='>'.$hash{$_}."</option>\n";
+ }
+ $output.="</select>\n";
+ return $output;
+}
+
#-------------------------------------------
=pod
@@ -771,6 +1069,42 @@ sub select_form {
return $selectform;
}
+sub gradeleveldescription {
+ my $gradelevel=shift;
+ my %gradelevels=(0 => 'Not specified',
+ 1 => 'Grade 1',
+ 2 => 'Grade 2',
+ 3 => 'Grade 3',
+ 4 => 'Grade 4',
+ 5 => 'Grade 5',
+ 6 => 'Grade 6',
+ 7 => 'Grade 7',
+ 8 => 'Grade 8',
+ 9 => 'Grade 9',
+ 10 => 'Grade 10',
+ 11 => 'Grade 11',
+ 12 => 'Grade 12',
+ 13 => 'Grade 13',
+ 14 => '100 Level',
+ 15 => '200 Level',
+ 16 => '300 Level',
+ 17 => '400 Level',
+ 18 => 'Graduate Level');
+ return &mt($gradelevels{$gradelevel});
+}
+
+sub select_level_form {
+ my ($deflevel,$name)=@_;
+ unless ($deflevel) { $deflevel=0; }
+ my $selectform = "<select name=\"$name\" size=\"1\">\n";
+ for (my $i=0; $i<=18; $i++) {
+ $selectform.="<option value=\"$i\" ".
+ ($i==$deflevel ? 'selected' : '').
+ ">".&gradeleveldescription($i)."</option>\n";
+ }
+ $selectform.="</select>";
+ return $selectform;
+}
#-------------------------------------------
@@ -887,6 +1221,8 @@ Outputs:
=back
+=back
+
=cut
###############################################################
@@ -925,12 +1261,6 @@ sub decode_user_agent {
$clientunicode,$clientos,);
}
-=pod
-
-=back
-
-=cut
-
###############################################################
## Authentication changing form generation subroutines ##
###############################################################
@@ -971,6 +1301,8 @@ See loncreateuser.pm for invocation and
=back
+=back
+
=cut
#-------------------------------------------
@@ -998,10 +1330,30 @@ END
$Javascript_toUpperCase = "";
}
+ my $radioval = "'nochange'";
+ if (exists($in{'curr_authtype'}) &&
+ defined($in{'curr_authtype'}) &&
+ $in{'curr_authtype'} ne '') {
+ $radioval = "'$in{'curr_authtype'}arg'";
+ }
+ my $argfield = 'null';
+ if ( grep/^mode$/,(keys %in) ) {
+ if ($in{'mode'} eq 'modifycourse') {
+ if ( grep/^curr_authtype$/,(keys %in) ) {
+ $radioval = "'$in{'curr_authtype'}'";
+ }
+ if ( grep/^curr_autharg$/,(keys %in) ) {
+ unless ($in{'curr_autharg'} eq '') {
+ $argfield = "'$in{'curr_autharg'}'";
+ }
+ }
+ }
+ }
+
$result.=<<"END";
var current = new Object();
-current.radiovalue = 'nochange';
-current.argfield = null;
+current.radiovalue = $radioval;
+current.argfield = $argfield;
function changed_radio(choice,currentform) {
var choicearg = choice + 'arg';
@@ -1088,20 +1440,32 @@ sub authform_kerberos{
kerb_def_auth => 'krb4',
@_,
);
- my ($check4,$check5);
+ my ($check4,$check5,$krbarg);
if ($in{'kerb_def_auth'} eq 'krb5') {
$check5 = " checked=\"on\"";
} else {
$check4 = " checked=\"on\"";
}
+ $krbarg = $in{'kerb_def_dom'};
+
+ my $krbcheck = "";
+ if ( grep/^curr_authtype$/,(keys %in) ) {
+ if ($in{'curr_authtype'} =~ m/^krb/) {
+ $krbcheck = " checked=\"on\"";
+ if ( grep/^curr_autharg$/,(keys %in) ) {
+ $krbarg = $in{'curr_autharg'};
+ }
+ }
+ }
+
my $jscall = "javascript:changed_radio('krb',$in{'formname'});";
my $result .= &mt
('[_1] Kerberos authenticated with domain [_2] '.
'[_3] Version 4 [_4] Version 5',
'<input type="radio" name="login" value="krb" '.
- 'onclick="'.$jscall.'" onchange="'.$jscall.'" />',
+ 'onclick="'.$jscall.'" onchange="'.$jscall.'"'.$krbcheck.' />',
'<input type="text" size="10" name="krbarg" '.
- 'value="'.$in{'kerb_def_dom'}.'" '.
+ 'value="'.$krbarg.'" '.
'onchange="'.$jscall.'" />',
'<input type="radio" name="krbver" value="4" '.$check4.' />',
'<input type="radio" name="krbver" value="5" '.$check5.' />');
@@ -1114,13 +1478,25 @@ sub authform_internal{
kerb_def_dom => 'MSU.EDU',
@_,
);
+
+ my $intcheck = "";
+ my $intarg = 'value=""';
+ if ( grep/^curr_authtype$/,(keys %args) ) {
+ if ($args{'curr_authtype'} eq 'int') {
+ $intcheck = " checked=\"on\"";
+ if ( grep/^curr_autharg$/,(keys %args) ) {
+ $intarg = "value=\"$args{'curr_autharg'}\"";
+ }
+ }
+ }
+
my $jscall = "javascript:changed_radio('int',$args{'formname'});";
my $result.=&mt
('[_1] Internally authenticated (with initial password [_2])',
- '<input type="radio" name="login" value="int" '.
- 'onchange="'.$jscall.'" onclick="'.$jscall.'" />',
- '<input type="text" size="10" name="intarg" value="" '.
- 'onchange="'.$jscall.'" />');
+ '<input type="radio" name="login" value="int" '.$intcheck.
+ ' onchange="'.$jscall.'" onclick="'.$jscall.'" />',
+ '<input type="text" size="10" name="intarg" '.$intarg.
+ ' onchange="'.$jscall.'" />');
return $result;
}
@@ -1130,12 +1506,24 @@ sub authform_local{
kerb_def_dom => 'MSU.EDU',
@_,
);
+
+ my $loccheck = "";
+ my $locarg = 'value=""';
+ if ( grep/^curr_authtype$/,(keys %in) ) {
+ if ($in{'curr_authtype'} eq 'loc') {
+ $loccheck = " checked=\"on\"";
+ if ( grep/^curr_autharg$/,(keys %in) ) {
+ $locarg = "value=\"$in{'curr_autharg'}\"";
+ }
+ }
+ }
+
my $jscall = "javascript:changed_radio('loc',$in{'formname'});";
- my $result.=&mt('[_1] Local Authentication with arguement [_2]',
- '<input type="radio" name="login" value="loc" '.
- 'onchange="'.$jscall.'" onclick="'.$jscall.'" />',
- '<input type="text" size="10" name="locarg" value="" '.
- 'onchange="'.$jscall.'" />');
+ my $result.=&mt('[_1] Local Authentication with argument [_2]',
+ '<input type="radio" name="login" value="loc" '.$loccheck.
+ ' onchange="'.$jscall.'" onclick="'.$jscall.'" />',
+ '<input type="text" size="10" name="locarg" '.$locarg.
+ ' onchange="'.$jscall.'" />');
return $result;
}
@@ -1155,12 +1543,6 @@ sub authform_filesystem{
return $result;
}
-=pod
-
-=back
-
-=cut
-
###############################################################
## Get Authentication Defaults for Domain ##
###############################################################
@@ -1315,7 +1697,7 @@ sub keyword {
=item * get_related_words
-Look up a word in the thesaurus. Takes a scalar arguement and returns
+Look up a word in the thesaurus. Takes a scalar argument and returns
an array of words. If the keyword is not in the thesaurus, an empty array
will be returned. The order of the words returned is determined by the
database which holds them.
@@ -1363,23 +1745,29 @@ sub get_related_words {
=over 4
-=item * plainname($uname,$udom)
+=item * plainname($uname,$udom,$first)
Takes a users logon name and returns it as a string in
-"first middle last generation" form
+"first middle last generation" form
+if $first is set to 'lastname' then it returns it as
+'lastname generation, firstname middlename' if their is a lastname
=cut
###############################################################
sub plainname {
- my ($uname,$udom)=@_;
+ my ($uname,$udom,$first)=@_;
my %names=&Apache::lonnet::get('environment',
['firstname','middlename','lastname','generation'],
$udom,$uname);
- my $name=$names{'firstname'}.' '.$names{'middlename'}.' '.
- $names{'lastname'}.' '.$names{'generation'};
+ my $name=&Apache::lonnet::format_name($names{'firstname'},
+ $names{'middlename'},
+ $names{'lastname'},
+ $names{'generation'},$first);
+ $name=~s/^\s+//;
$name=~s/\s+$//;
$name=~s/\s+/ /g;
+ if ($name !~ /\S/) { $name=$uname.'@'.$udom; }
return $name;
}
@@ -1402,8 +1790,19 @@ if the user does not
sub nickname {
my ($uname,$udom)=@_;
- my %names=&Apache::lonnet::get('environment',
- ['nickname','firstname','middlename','lastname','generation'],$udom,$uname);
+ my %names;
+ if ($uname eq $ENV{'user.name'} &&
+ $udom eq $ENV{'user.domain'}) {
+ %names=('nickname' => $ENV{'environment.nickname'} ,
+ 'firstname' => $ENV{'environment.firstname'} ,
+ 'middlename' => $ENV{'environment.middlename'},
+ 'lastname' => $ENV{'environment.lastname'} ,
+ 'generation' => $ENV{'environment.generation'});
+ } else {
+ %names=&Apache::lonnet::get('environment',
+ ['nickname','firstname','middlename',
+ 'lastname','generation'],$udom,$uname);
+ }
my $name=$names{'nickname'};
if ($name) {
$name='"'.$name.'"';
@@ -1429,17 +1828,21 @@ Gets a users screenname and returns it a
sub screenname {
my ($uname,$udom)=@_;
- my %names=
- &Apache::lonnet::get('environment',['screenname'],$udom,$uname);
+ if ($uname eq $ENV{'user.name'} &&
+ $udom eq $ENV{'user.domain'}) {return $ENV{'environment.screenname'};}
+ my %names=&Apache::lonnet::get('environment',['screenname'],$udom,$uname);
return $names{'screenname'};
}
+
# ------------------------------------------------------------- Message Wrapper
sub messagewrapper {
- my ($link,$un,$do)=@_;
+ my ($link,$username,$domain)=@_;
return
-"<a href='/adm/email?compose=individual&recname=$un&recdom=$do'>$link</a>";
+ '<a href="/adm/email?compose=individual&'.
+ 'recname='.$username.'&recdom='.$domain.'" '.
+ 'title="'.&mt('Send message').'">'.$link.'</a>';
}
# --------------------------------------------------------------- Notes Wrapper
@@ -1451,8 +1854,9 @@ sub noteswrapper {
# ------------------------------------------------------------- Aboutme Wrapper
sub aboutmewrapper {
- my ($link,$username,$domain)=@_;
- return "<a href='/adm/$domain/$username/aboutme'>$link</a>";
+ my ($link,$username,$domain,$target)=@_;
+ return '<a href="/adm/'.$domain.'/'.$username.'/aboutme"'.
+ ($target?' target="$target"':'').' title="'.&mt('View this users personal page').'">'.$link.'</a>';
}
# ------------------------------------------------------------ Syllabus Wrapper
@@ -1463,9 +1867,28 @@ sub syllabuswrapper {
if ($fontcolor) {
$linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>';
}
- return "<a href='/public/$domain/$coursedir/syllabus'>$linktext</a>";
+ return qq{<a href="/public/$domain/$coursedir/syllabus">$linktext</a>};
}
+sub track_student_link {
+ my ($linktext,$sname,$sdom,$target) = @_;
+ my $link ="/adm/trackstudent";
+ my $title = 'View recent activity';
+ if (defined($sname) && $sname !~ /^\s*$/ &&
+ defined($sdom) && $sdom !~ /^\s*$/) {
+ $link .= "?selected_student=$sname:$sdom";
+ $title .= ' of this student';
+ }
+ if (defined($target) && $target !~ /^\s*$/) {
+ $target = qq{target="$target"};
+ } else {
+ $target = '';
+ }
+ return qq{<a href="$link" title="$title" $target>$linktext</a>};
+}
+
+
+
=pod
=back
@@ -1530,7 +1953,31 @@ returns description of a specified copyr
=cut
sub copyrightdescription {
- return $cprtag{shift(@_)};
+ return &mt($cprtag{shift(@_)});
+}
+
+=pod
+
+=item * source_copyrightids()
+
+returns list of all source copyrights
+
+=cut
+
+sub source_copyrightids {
+ return sort(keys(%scprtag));
+}
+
+=pod
+
+=item * source_copyrightdescription()
+
+returns description of a specified source copyright id
+
+=cut
+
+sub source_copyrightdescription {
+ return &mt($scprtag{shift(@_)});
}
=pod
@@ -1570,6 +2017,14 @@ sub fileembstyle {
return $fe{lc(shift(@_))};
}
+
+sub filecategoryselect {
+ my ($name,$value)=@_;
+ return &select_form($value,$name,
+ '' => &mt('Any category'),
+ map { $_,$_ } sort(keys(%category_extensions)));
+}
+
=pod
=item * filedescription()
@@ -1579,7 +2034,9 @@ returns description for a specified file
=cut
sub filedescription {
- return $fd{lc(shift(@_))};
+ my $file_description = $fd{lc(shift())};
+ $file_description =~ s:([\[\]]):~$1:g;
+ return &mt($file_description);
}
=pod
@@ -1593,7 +2050,9 @@ extra formatting
sub filedescriptionex {
my $ex=shift;
- return '.'.$ex.' '.$fd{lc($ex)};
+ my $file_description = $fd{lc($ex)};
+ $file_description =~ s:([\[\]]):~$1:g;
+ return '.'.$ex.' '.&mt($file_description);
}
# End of .tab access
@@ -1628,13 +2087,13 @@ sub display_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'}));
}
+ if ($ENV{'environment.languages'}) {
+ @languages=split(/\s*(\,|\;|\:)\s*/,$ENV{'environment.languages'});
+ }
my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0];
if ($browser) {
@languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$browser));
@@ -1814,22 +2273,19 @@ show a snapshot of what student was look
=cut
sub get_student_view {
- my ($symb,$username,$domain,$courseid,$target) = @_;
+ my ($symb,$username,$domain,$courseid,$target,$moreenv) = @_;
my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
- my (%old,%moreenv);
+ my (%form);
my @elements=('symb','courseid','domain','username');
foreach my $element (@elements) {
- $old{$element}=$ENV{'form.grade_'.$element};
- $moreenv{'form.grade_'.$element}=eval '$'.$element #'
+ $form{'grade_'.$element}=eval '$'.$element #'
}
- if ($target eq 'tex') {$moreenv{'form.grade_target'} = 'tex';}
- &Apache::lonnet::appenv(%moreenv);
- $feedurl=&Apache::lonnet::clutter($feedurl);
- my $userview=&Apache::lonnet::ssi_body($feedurl);
- &Apache::lonnet::delenv('form.grade_');
- foreach my $element (@elements) {
- $ENV{'form.grade_'.$element}=$old{$element};
+ if (defined($moreenv)) {
+ %form=(%form,%{$moreenv});
}
+ if ($target eq 'tex') {$form{'grade_target'} = 'tex';}
+ $feedurl=&Apache::lonnet::clutter($feedurl);
+ my $userview=&Apache::lonnet::ssi_body($feedurl,%form);
$userview=~s/\<body[^\>]*\>//gi;
$userview=~s/\<\/body\>//gi;
$userview=~s/\<html\>//gi;
@@ -1852,19 +2308,14 @@ show a snapshot of how student was answe
sub get_student_answers {
my ($symb,$username,$domain,$courseid,%form) = @_;
my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
- my (%old,%moreenv);
+ my (%moreenv);
my @elements=('symb','courseid','domain','username');
foreach my $element (@elements) {
- $old{$element}=$ENV{'form.grade_'.$element};
- $moreenv{'form.grade_'.$element}=eval '$'.$element #'
- }
- $moreenv{'form.grade_target'}='answer';
- &Apache::lonnet::appenv(%moreenv);
- my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%form);
- &Apache::lonnet::delenv('form.grade_');
- foreach my $element (@elements) {
- $ENV{'form.grade_'.$element}=$old{$element};
+ $moreenv{'grade_'.$element}=eval '$'.$element #'
}
+ $moreenv{'grade_target'}='answer';
+ %moreenv=(%form,%moreenv);
+ my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%moreenv);
return $userview;
}
@@ -1918,22 +2369,7 @@ 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;
+ $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1));
}
#########################################
@@ -2004,10 +2440,8 @@ 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.'" />';
+ my $logo=&lonhttpdurl("/adm/lonDomLogos/$domain.gif");
+ return '<img src="'.$logo.'" alt="'.$domain.'" />';
} elsif(exists($Apache::lonnet::domaindescription{$domain})) {
return $Apache::lonnet::domaindescription{$domain};
} else {
@@ -2093,21 +2527,9 @@ other decorations will be returned.
=cut
sub bodytag {
- my ($title,$function,$addentries,$bodyonly,$domain,$forcereg)=@_;
+ my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle)=@_;
$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';
- }
- }
+ $function = &get_users_function() if (!$function);
my $img=&designparm($function.'.img',$domain);
my $pgbg=&designparm($function.'.pgbg',$domain);
my $tabbg=&designparm($function.'.tabbg',$domain);
@@ -2138,7 +2560,7 @@ sub bodytag {
if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
# construct main body tag
my $bodytag = <<END;
-<style>
+<style type="text/css">
h1, h2, h3, th { font-family: Arial, Helvetica, sans-serif }
a:focus { color: red; background: yellow }
</style>
@@ -2151,20 +2573,60 @@ END
return $bodytag;
} elsif ($ENV{'browser.interface'} eq 'textual') {
# Accessibility
+
return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',
$forcereg).
'<h1>LON-CAPA: '.$title.'</h1>';
} elsif ($ENV{'environment.remote'} eq 'off') {
# No Remote
+ my $roleinfo=(<<ENDROLE);
+<td bgcolor="$tabbg" align="right">
+<font size="2" face="Arial, Helvetica, sans-serif">
+ $ENV{'environment.firstname'}
+ $ENV{'environment.middlename'}
+ $ENV{'environment.lastname'}
+ $ENV{'environment.generation'}
+ </font>
+<br />
+<font size="2" face="Arial, Helvetica, sans-serif">$role</font>
+<br />
+<font size="2" face="Arial, Helvetica, sans-serif">$realm</font>
+</td>
+ENDROLE
+ my $titleinfo = '<font face="Arial, Helvetica, sans-serif" size="+3" color="'.
+ $font.'"><b>'.$title.'</b></font>';
+ if ($customtitle) {
+ $titleinfo = $customtitle;
+ }
+ if ($ENV{'request.state'} eq 'construct') {
+ my ($uname,$thisdisfn)=
+ ($ENV{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|);
+ my $formaction='/priv/'.$uname.'/'.$thisdisfn;
+ $formaction=~s/\/+/\//g;
+ $titleinfo = '<form name="dirs" method="post" action="'.$formaction
+ .'" target="_top">'
+ .&Apache::lonhtmlcommon::crumbs($uname.'/'.$thisdisfn,'_top','/priv','',-1,1)."<br />"
+ .&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()')
+ .'</form>'
+ .&Apache::lonmenu::constspaceform();
+
+ &Apache::lonhtmlcommon::store_recent('construct',$formaction,$formaction);
+ if ($thisdisfn!~m|/$|) { $forcereg=1; }
+ }
+
+ &Apache::lonnet::logthis("hrrm");
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>';
+ '<table bgcolor="'.$pgbg.'" width="100%" border="0" cellspacing="3" cellpadding="3"><tr><td rowspan="3" bgcolor="'.$tabbg.'">'.$titleinfo.'</td>'.$roleinfo.'</tr></table>';
}
#
# Top frame rendering, Remote is up
#
+ my $titleinfo = ' <font size="5" face="Arial, Helvetica, sans-serif"><b>'.$title.'</b></font>';
+ if ($customtitle) {
+ $titleinfo = $customtitle;
+ }
return(<<ENDBODY);
$bodytag
<table width="100%" cellspacing="0" border="0" cellpadding="0">
@@ -2174,7 +2636,7 @@ $upperleft</td>
</tr>
<tr>
<td rowspan="3" bgcolor="$tabbg">
- <font size="5" face="Arial, Helvetica, sans-serif"><b>$title</b></font>
+$titleinfo
<td bgcolor="$tabbg" align="right">
<font size="2" face="Arial, Helvetica, sans-serif">
$ENV{'environment.firstname'}
@@ -2189,12 +2651,39 @@ $upperleft</td>
</td></tr>
<tr>
<td bgcolor="$tabbg" align="right"><font size="2" face="Arial, Helvetica, sans-serif">$realm</font> </td></tr>
-</table><br>
+</table><br />
ENDBODY
}
###############################################
+=pod
+
+=item get_users_function
+
+Used by &bodytag to determine the current users primary role.
+Returns either 'student','coordinator','admin', or 'author'.
+
+=cut
+
+###############################################
+sub get_users_function {
+ my $function = 'student';
+ if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) {
+ $function='coordinator';
+ }
+ if ($ENV{'request.role'}=~/^(su|dc|ad|li)/) {
+ $function='admin';
+ }
+ if (($ENV{'request.role'}=~/^(au|ca)/) ||
+ ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
+ $function='author';
+ }
+ return $function;
+}
+
+###############################################
+
sub get_posted_cgi {
my $r=shift;
@@ -2303,12 +2792,12 @@ returns cache-controlling header code
=cut
sub cacheheader {
- unless ($ENV{'request.method'} eq 'GET') { return ''; }
- my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
- my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
+ unless ($ENV{'request.method'} eq 'GET') { return ''; }
+ my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
+ my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
<meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
<meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
- return $output;
+ return $output;
}
=pod
@@ -2320,20 +2809,26 @@ specifies header code to not have cache
=cut
sub no_cache {
- my ($r) = @_;
- unless ($ENV{'request.method'} eq 'GET') { return ''; }
- #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
- $r->no_cache(1);
- $r->header_out("Pragma" => "no-cache");
- #$r->header_out("Expires" => $date);
+ my ($r) = @_;
+ if ($ENV{'REQUEST_METHOD'} ne 'GET' &&
+ $ENV{'request.method'} ne 'GET') { return ''; }
+ my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time));
+ $r->no_cache(1);
+ $r->header_out("Expires" => $date);
+ $r->header_out("Pragma" => "no-cache");
}
sub content_type {
- my ($r,$type,$charset) = @_;
- unless ($charset) {
- $charset=&Apache::lonlocal::current_encoding;
- }
- $r->content_type($type.($charset?'; charset='.$charset:''));
+ my ($r,$type,$charset) = @_;
+ unless ($charset) {
+ $charset=&Apache::lonlocal::current_encoding;
+ }
+ if ($charset) { $type.='; charset='.$charset; }
+ if ($r) {
+ $r->content_type($type);
+ } else {
+ print("Content-type: $type\n\n");
+ }
}
=pod
@@ -2415,9 +2910,12 @@ sub upfile_store {
my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
'_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$;
{
- my $fh=Apache::File->new('>'.$r->dir_config('lonDaemons').
- '/tmp/'.$datatoken.'.tmp');
- print $fh $ENV{'form.upfile'};
+ my $datafile = $r->dir_config('lonDaemons').
+ '/tmp/'.$datatoken.'.tmp';
+ if ( open(my $fh,">$datafile") ) {
+ print $fh $ENV{'form.upfile'};
+ close($fh);
+ }
}
return $datatoken;
}
@@ -2436,11 +2934,12 @@ sub load_tmp_file {
my $r=shift;
my @studentdata=();
{
- my $fh;
- if ($fh=Apache::File->new($r->dir_config('lonDaemons').
- '/tmp/'.$ENV{'form.datatoken'}.'.tmp')) {
- @studentdata=<$fh>;
- }
+ my $studentfile = $r->dir_config('lonDaemons').
+ '/tmp/'.$ENV{'form.datatoken'}.'.tmp';
+ if ( open(my $fh,"<$studentfile") ) {
+ @studentdata=<$fh>;
+ close($fh);
+ }
}
$ENV{'form.upfile'}=join('',@studentdata);
}
@@ -2485,7 +2984,7 @@ sub record_sep {
}
} elsif ($ENV{'form.upfiletype'} eq 'tab') {
my $i=0;
- foreach (split(/\t+/,$record)) {
+ foreach (split(/\t/,$record)) {
my $field=$_;
$field=~s/^(\"|\')//;
$field=~s/(\"|\')$//;
@@ -2593,7 +3092,7 @@ Prints a table to create associations be
$r is an Apache Request ref,
$records is an arrayref from &Apache::loncommon::upfile_record_sep,
-$d is an array of 2 element arrays (internal name, displayed name)
+$d is an array of 2 element arrays (internal name, displayed name,defaultcol)
=cut
@@ -2608,14 +3107,16 @@ sub csv_print_select_table {
'<th>'.&mt('Attribute').'</th>'.
'<th>'.&mt('Column').'</th></tr>'."\n");
foreach (@$d) {
- my ($value,$display)=@{ $_ };
+ my ($value,$display,$defaultcol)=@{ $_ };
$r->print('<tr><td>'.$display.'</td>');
$r->print('<td><select name=f'.$i.
' onchange="javascript:flip(this.form,'.$i.');">');
$r->print('<option value="none"></option>');
foreach (sort({$a <=> $b} keys(%sone))) {
- $r->print('<option value="'.$_.'">Column '.($_+1).'</option>');
+ $r->print('<option value="'.$_.'"'.
+ ($_ eq $defaultcol ? ' selected ' : '').
+ '>Column '.($_+1).'</option>');
}
$r->print('</select></td></tr>'."\n");
$i++;
@@ -2656,8 +3157,10 @@ sub csv_samples_select_table {
$r->print('<tr><td><select name="f'.$i.'"'.
' onchange="javascript:flip(this.form,'.$i.');">');
foreach (@$d) {
- my ($value,$display)=@{ $_ };
- $r->print('<option value="'.$value.'">'.$display.'</option>');
+ my ($value,$display,$defaultcol)=@{ $_ };
+ $r->print('<option value="'.$value.'"'.
+ ($i eq $defaultcol ? ' selected ':'').'>'.
+ $display.'</option>');
}
$r->print('</select></td><td>');
if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); }
@@ -2729,8 +3232,12 @@ sub check_if_partid_hidden {
=pod
+=back
+
=head1 cgi-bin script and graphing routines
+=over 4
+
=item get_cgi_id
Inputs: none
@@ -2778,6 +3285,8 @@ If $Max is < any data point, the graph w
=item $colors: array ref holding the colors to be used for the data sets when
they are plotted. If undefined, default values will be used.
+=item $labels: array ref holding the labels to use on the x-axis for the bars.
+
=item @Values: An array of array references. Each array reference holds data
to be plotted in a stacked bar chart.
@@ -2793,7 +3302,7 @@ information for the plot.
############################################################
############################################################
sub DrawBarGraph {
- my ($Title,$xlabel,$ylabel,$Max,$colors,@Values)=@_;
+ my ($Title,$xlabel,$ylabel,$Max,$colors,$labels,@Values)=@_;
#
if (! defined($colors)) {
$colors = ['#33ff00',
@@ -2801,13 +3310,28 @@ sub DrawBarGraph {
'#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66',
];
}
+ my $extra_settings = {};
+ if (ref($Values[-1]) eq 'HASH') {
+ $extra_settings = pop(@Values);
+ }
#
my $identifier = &get_cgi_id();
my $id = 'cgi.'.$identifier;
if (! @Values || ref($Values[0]) ne 'ARRAY') {
return '';
}
+ #
+ my @Labels;
+ if (defined($labels)) {
+ @Labels = @$labels;
+ } else {
+ for (my $i=0;$i<@{$Values[0]};$i++) {
+ push (@Labels,$i+1);
+ }
+ }
+ #
my $NumBars = scalar(@{$Values[0]});
+ if ($NumBars < scalar(@Labels)) { $NumBars = scalar(@Labels); }
my %ValuesHash;
my $NumSets=1;
foreach my $array (@Values) {
@@ -2817,7 +3341,15 @@ sub DrawBarGraph {
}
#
my ($height,$width,$xskip,$bar_width) = (200,120,1,15);
- if ($NumBars < 10) {
+ if ($NumBars < 3) {
+ $width = 120+$NumBars*32;
+ $xskip = 1;
+ $bar_width = 30;
+ } elsif ($NumBars < 5) {
+ $width = 120+$NumBars*20;
+ $xskip = 1;
+ $bar_width = 20;
+ } elsif ($NumBars < 10) {
$width = 120+$NumBars*15;
$xskip = 1;
$bar_width = 15;
@@ -2835,11 +3367,6 @@ sub DrawBarGraph {
$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++;
@@ -2862,6 +3389,11 @@ sub DrawBarGraph {
$ValuesHash{$id.'.bar_width'} = $bar_width;
$ValuesHash{$id.'.labels'} = join(',',@Labels);
#
+ # Deal with other parameters
+ while (my ($key,$value) = each(%$extra_settings)) {
+ $ValuesHash{$id.'.'.$key} = $value;
+ }
+ #
&Apache::lonnet::appenv(%ValuesHash);
return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
}
@@ -2896,7 +3428,7 @@ plotted in. If undefined, default value
=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.
+Each of the contained arrays will be plotted as a separate curve.
=item %Values: hash indicating or overriding any default values which are
passed to graph.png.
@@ -3063,10 +3595,14 @@ sub DrawXYYGraph {
=pod
+=back
+
=head1 Statistics helper routines?
Bad place for them but what the hell.
+=over 4
+
=item &chartlink
Returns a link to the chart for a specific student.
@@ -3083,6 +3619,8 @@ Inputs:
=back
+=back
+
=cut
############################################################
@@ -3090,8 +3628,8 @@ Inputs:
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').
+ '&SelectedStudent='.&Apache::lonnet::escape($sname.':'.$sdomain).
+ '&chartoutputmode='.HTML::Entities::encode('html, with all links').
'">'.$linktext.'</a>';
}
@@ -3102,6 +3640,8 @@ sub chartlink {
=head1 Course Environment Routines
+=over 4
+
=item &restore_course_settings
=item &store_course_settings
@@ -3136,7 +3676,7 @@ sub store_course_settings {
my %SaveHash;
my %AppHash;
while (my ($setting,$type) = each(%$Settings)) {
- my $basename = 'env.internal.'.$prefix.'.'.$setting;
+ my $basename = 'internal.'.$prefix.'.'.$setting;
my $envname = 'course.'.$courseid.'.'.$basename;
if (exists($ENV{'form.'.$setting})) {
# Save this value away
@@ -3181,7 +3721,7 @@ sub restore_course_settings {
my ($prefix,$Settings) = @_;
while (my ($setting,$type) = each(%$Settings)) {
next if (exists($ENV{'form.'.$setting}));
- my $envname = 'course.'.$courseid.'.env.internal.'.$prefix.
+ my $envname = 'course.'.$courseid.'.internal.'.$prefix.
'.'.$setting;
if (exists($ENV{$envname})) {
if ($type eq 'scalar') {
@@ -3210,6 +3750,61 @@ sub propath {
return $proname;
}
+sub icon {
+ my ($file)=@_;
+ my $curfext = (split(/\./,$file))[-1];
+ my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif';
+ my $embstyle = &Apache::loncommon::fileembstyle($curfext);
+ if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) {
+ if (-e $Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
+ $Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
+ $curfext.".gif") {
+ $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
+ $curfext.".gif";
+ }
+ }
+ return $iconname;
+}
+
+sub lonhttpdurl {
+ my ($url)=@_;
+ my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'};
+ if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; }
+ return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url;
+}
+
+sub connection_aborted {
+ my ($r)=@_;
+ $r->print(" ");$r->rflush();
+ my $c = $r->connection;
+ return $c->aborted();
+}
+
+# Escapes strings that may have embedded 's that will be put into
+# strings as 'strings'.
+sub escape_single {
+ my ($input) = @_;
+ $input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)>
+ $input =~ s/\'/\\\'/g; # Esacpe the 's....
+ return $input;
+}
+
+# Same as escape_single, but escape's "'s This
+# can be used for "strings"
+sub escape_double {
+ my ($input) = @_;
+ $input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)>
+ $input =~ s/\"/\\\"/g; # Esacpe the "s....
+ return $input;
+}
+
+# Escapes the last element of a full URL.
+sub escape_url {
+ my ($url) = @_;
+ my @urlslices = split(/\//, $url);
+ my $lastitem = &Apache::lonnet::escape(pop(@urlslices));
+ return join('/',@urlslices).'/'.$lastitem;
+}
=pod
=back