--- loncom/interface/loncommon.pm 2003/08/20 18:18:45 1.112
+++ loncom/interface/loncommon.pm 2006/04/20 02:24:08 1.344
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# a pile of common routines
#
-# $Id: loncommon.pm,v 1.112 2003/08/20 18:18:45 bowersj2 Exp $
+# $Id: loncommon.pm,v 1.344 2006/04/20 02:24:08 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
@@ -62,23 +55,27 @@ redundancy from other modules and increa
package Apache::loncommon;
use strict;
-use Apache::lonnet();
+use Apache::lonnet;
use GDBM_File;
use POSIX qw(strftime mktime);
-use Apache::Constants qw(:common :http :methods);
-use Apache::lonmsg();
use Apache::lonmenu();
-my $readit;
-
-=pod
+use Apache::lonlocal;
+use HTML::Entities;
+use Apache::lonhtmlcommon();
+use Apache::loncoursedata();
+use Apache::lontexconvert();
-=head1 Global Variables
+my $readit;
-=cut
+##
+## Global Variables
+##
# ----------------------------------------------- Filetypes/Languages/Copyright
my %language;
+my %supported_language;
my %cprtag;
+my %scprtag;
my %fe; my %fd;
my %category_extensions;
@@ -87,50 +84,19 @@ my %category_extensions;
my %designhash;
# ---------------------------------------------- Thesaurus variables
-
-# FIXME: I don't think it's necessary to document these things;
-# they're privately used - Jeremy
-
-=pod
-
-=over 4
-
-=item * %Keywords
-
-A hash used by &keyword to determine if a word is considered a keyword.
-
-=item * $thesaurus_db_file
-
-Scalar containing the full path to the thesaurus database.
-
-=back
-
-=cut
+#
+# %Keywords:
+# A hash used by &keyword to determine if a word is considered a keyword.
+# $thesaurus_db_file
+# Scalar containing the full path to the thesaurus database.
my %Keywords;
my $thesaurus_db_file;
-# ----------------------------------------------------------------------- BEGIN
-
-# FIXME: I don't think this needs to be documented, it prepares
-# private data structures - Jeremy
-=pod
-
-=head1 General Subroutines
-
-=over 4
-
-=item * BEGIN()
-
-Initialize values from language.tab, copyright.tab, filetypes.tab,
-thesaurus.tab, and filecategories.tab.
-
-=back
-
-=cut
-
-# ----------------------------------------------------------------------- BEGIN
-
+#
+# Initialize values from language.tab, copyright.tab, filetypes.tab,
+# thesaurus.tab, and filecategories.tab.
+#
BEGIN {
# Variable initialization
$thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db";
@@ -138,29 +104,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)=(split(/\t/,$_));
- $language{$key}=$val.' - '.$enc;
- }
- }
+ 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
@@ -169,18 +154,20 @@ BEGIN {
my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
opendir(DIR,$designdir);
while ($filename=readdir(DIR)) {
+ if ($filename!~/\.tab$/) { next; }
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);
}
}
- }
}
closedir(DIR);
@@ -188,32 +175,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(
"INFO: Read file types");
@@ -239,8 +229,6 @@ containing javascript with two functions
C. Returned string does not contain EscriptE
tags.
-=over 4
-
=item * openbrowser(formname,elementname,only,omit) [javascript]
inputs: formname, elementname, only, omit
@@ -249,10 +237,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]
@@ -261,43 +249,59 @@ 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
}
+sub lastresurl {
+ if ($env{'environment.lastresurl'}) {
+ return $env{'environment.lastresurl'}
+ } else {
+ return '/res';
+ }
+}
+
+sub storeresurl {
+ my $resurl=&Apache::lonnet::clutter(shift);
+ unless ($resurl=~/^\/res/) { return 0; }
+ $resurl=~s/\/$//;
+ &Apache::lonnet::put('environment',{'lastresurl' => $resurl});
+ &Apache::lonnet::appenv('environment.lastresurl' => $resurl);
+ return 1;
+}
+
sub studentbrowser_javascript {
unless (
- (($ENV{'request.course.id'}) &&
- (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})))
- || ($ENV{'request.role'}=~/^(au|dc|su)/)
+ (($env{'request.course.id'}) &&
+ (&Apache::lonnet::allowed('srm',$env{'request.course.id'})
+ || &Apache::lonnet::allowed('srm',$env{'request.course.id'}.
+ '/'.$env{'request.course.sec'})
+ ))
+ || ($env{'request.role'}=~/^(au|dc|su)/)
) { return ''; }
return (<<'ENDSTDBRW');
+
+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='
';
+ }
+ }
+ if ($text ne '') { $template.='' };
+ 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 .=
+ "
".
+ "
$text";
+ }
+
+ # Add the graphic
+ my $title = &mt('Report a Bug');
+ my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif");
+ $template .= <<"ENDTEMPLATE";
+
+ENDTEMPLATE
+ if ($text ne '') { $template.='
' };
+ 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 .=
+ "
".
+ "
$text";
+ }
+
+ # Add the graphic
+ my $title = &mt('View the FAQ');
+ my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif");
+ $template .= <<"ENDTEMPLATE";
+
+ENDTEMPLATE
+ if ($text ne '') { $template.='
' };
+ return $template;
+
+}
+
+###############################################################
+###############################################################
+
=pod
-=item * csv_translate($text)
+=item * change_content_javascript():
-Translate $text to allow it to be output as a 'comma seperated values'
-format.
+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 EscriptE 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, and
+the new content you want to put in there, will put the content into
+that area.
+
+B: 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 to check your
+code in Netscape 4. This feature in Netscape 4 is B 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 (<. $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 "$origContent";
+ } else {
+ return "$origContent";
+ }
+}
+
+=pod
=back
+=head1 Excel and CSV file utility routines
+
+=over 4
+
+=cut
+
+###############################################################
+###############################################################
+
+=pod
+
+=item * csv_translate($text)
+
+Translate $text to allow it to be output as a 'comma separated values'
+format.
+
=cut
+###############################################################
+###############################################################
sub csv_translate {
my $text = shift;
$text =~ s/\"/\"\"/g;
- $text =~ s/\n//g;
+ $text =~ s/\n/ /g;
return $text;
}
###############################################################
+###############################################################
+
+=pod
+
+=item * define_excel_formats
+
+Define some commonly used Excel cell formats.
+
+Currently supported formats:
+
+=over 4
+
+=item header
+
+=item bold
+
+=item h1
+
+=item h2
+
+=item h3
+
+=item h4
+
+=item i
+
+=item date
+
+=back
+
+Inputs: $workbook
+
+Returns: $format, a hash reference.
+
+=cut
+
+###############################################################
+###############################################################
+sub define_excel_formats {
+ my ($workbook) = @_;
+ my $format;
+ $format->{'header'} = $workbook->add_format(bold => 1,
+ bottom => 1,
+ align => 'center');
+ $format->{'bold'} = $workbook->add_format(bold=>1);
+ $format->{'h1'} = $workbook->add_format(bold=>1, size=>18);
+ $format->{'h2'} = $workbook->add_format(bold=>1, size=>16);
+ $format->{'h3'} = $workbook->add_format(bold=>1, size=>14);
+ $format->{'h4'} = $workbook->add_format(bold=>1, size=>12);
+ $format->{'i'} = $workbook->add_format(italic=>1);
+ $format->{'date'} = $workbook->add_format(num_format=>
+ 'mm/dd/yyyy hh:mm:ss');
+ return $format;
+}
+
+###############################################################
+###############################################################
+
+=pod
+
+=item * create_workbook
+
+Create an Excel worksheet. If it fails, output message on the
+request object and return undefs.
+
+Inputs: Apache request object
+
+Returns (undef) on failure,
+ Excel worksheet object, scalar with filename, and formats
+ from &Apache::loncommon::define_excel_formats on success
+
+=cut
+
+###############################################################
+###############################################################
+sub create_workbook {
+ my ($r) = @_;
+ #
+ # Create the excel spreadsheet
+ my $filename = '/prtspool/'.
+ $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
+ time.'_'.rand(1000000000).'.xls';
+ my $workbook = Spreadsheet::WriteExcel->new('/home/httpd'.$filename);
+ if (! defined($workbook)) {
+ $r->log_error("Error creating excel spreadsheet $filename: $!");
+ $r->print('
'.&mt("Unable to create new Excel file. ".
+ "This error has been logged. ".
+ "Please alert your LON-CAPA administrator").
+ '
');
+ return (undef);
+ }
+ #
+ $workbook->set_tempdir('/home/httpd/perl/tmp');
+ #
+ my $format = &Apache::loncommon::define_excel_formats($workbook);
+ return ($workbook,$filename,$format);
+}
+
+###############################################################
+###############################################################
+
+=pod
+
+=item * create_text_file
+
+Create a file to write to and eventually make available to the usre.
+If file creation fails, outputs an error message on the request object and
+return undefs.
+
+Inputs: Apache request object, and file suffix
+
+Returns (undef) on failure,
+ Filehandle and filename on success.
+
+=cut
+
+###############################################################
+###############################################################
+sub create_text_file {
+ my ($r,$suffix) = @_;
+ if (! defined($suffix)) { $suffix = 'txt'; };
+ my $fh;
+ my $filename = '/prtspool/'.
+ $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
+ time.'_'.rand(1000000000).'.'.$suffix;
+ $fh = Apache::File->new('>/home/httpd'.$filename);
+ if (! defined($fh)) {
+ $r->log_error("Couldn't open $filename for output $!");
+ $r->print("Problems occured in creating the output file. ".
+ "This error has been logged. ".
+ "Please alert your LON-CAPA administrator.");
+ }
+ return ($fh,$filename)
+}
+
+
+=pod
+
+=back
+
+=cut
+
+###############################################################
## Home server \n";
}
$selectform.="";
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 = "";
+ return $selectform;
+}
#-------------------------------------------
@@ -712,7 +1306,7 @@ sub select_dom_form {
my $selectdomain = "";
@@ -804,14 +1398,18 @@ Outputs:
=back
+=back
+
=cut
###############################################################
###############################################################
sub decode_user_agent {
+ my ($r)=@_;
my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});
my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});
my $httpbrowser=$ENV{"HTTP_USER_AGENT"};
+ if (!$httpbrowser && $r) { $httpbrowser=$r->header_in('User-Agent'); }
my $clientbrowser='unknown';
my $clientversion='0';
my $clientmathml='';
@@ -842,12 +1440,6 @@ sub decode_user_agent {
$clientunicode,$clientos,);
}
-=pod
-
-=back
-
-=cut
-
###############################################################
## Authentication changing form generation subroutines ##
###############################################################
@@ -888,6 +1480,8 @@ See loncreateuser.pm for invocation and
=back
+=back
+
=cut
#-------------------------------------------
@@ -915,10 +1509,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';
@@ -978,10 +1592,10 @@ END
sub authform_authorwarning{
my $result='';
- $result=<<"END";
-As a general rule, only authors or co-authors should be filesystem
-authenticated (which allows access to the server filesystem).
-END
+ $result=''.
+ &mt('As a general rule, only authors or co-authors should be '.
+ 'filesystem authenticated '.
+ '(which allows access to the server filesystem).')."\n";
return $result;
}
@@ -991,12 +1605,11 @@ sub authform_nochange{
kerb_def_dom => 'MSU.EDU',
@_,
);
- my $result='';
- $result.=<<"END";
-
-Do not change login data
-END
+ my $result = '';
return $result;
}
@@ -1007,24 +1620,36 @@ sub authform_kerberos{
kerb_def_auth => 'krb4',
@_,
);
- my $result='';
- my $check4;
- my $check5;
+ my ($check4,$check5,$krbarg);
if ($in{'kerb_def_auth'} eq 'krb5') {
$check5 = " checked=\"on\"";
} else {
$check4 = " checked=\"on\"";
}
- $result.=<<"END";
-
-Kerberos authenticated with domain
-
-Version 4
-Version 5
-END
+ $krbarg = $in{'kerb_def_dom'};
+
+ my $krbcheck = "";
+ if ( grep/^curr_authtype$/,(keys %in) ) {
+ if ($in{'curr_authtype'} =~ m/^krb/) {
+ $krbcheck = " checked=\"on\"";
+ if ( grep/^curr_autharg$/,(keys %in) ) {
+ $krbarg = $in{'curr_autharg'};
+ }
+ }
+ }
+
+ my $jscall = "javascript:changed_radio('krb',$in{'formname'});";
+ my $result .= &mt
+ ('[_1] Kerberos authenticated with domain [_2] '.
+ '[_3] Version 4 [_4] Version 5 [_5]',
+ '',
+ '');
return $result;
}
@@ -1034,15 +1659,25 @@ sub authform_internal{
kerb_def_dom => 'MSU.EDU',
@_,
);
- my $result='';
- $result.=<<"END";
-
-Internally authenticated (with initial password
-)
-END
+
+ 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])',
+ '');
return $result;
}
@@ -1052,15 +1687,24 @@ sub authform_local{
kerb_def_dom => 'MSU.EDU',
@_,
);
- my $result='';
- $result.=<<"END";
-
-Local Authentication with argument
-
-END
+
+ my $loccheck = "";
+ my $locarg = 'value=""';
+ if ( grep/^curr_authtype$/,(keys %in) ) {
+ if ($in{'curr_authtype'} eq 'loc') {
+ $loccheck = " checked=\"on\"";
+ if ( grep/^curr_autharg$/,(keys %in) ) {
+ $locarg = "value=\"$in{'curr_autharg'}\"";
+ }
+ }
+ }
+
+ my $jscall = "javascript:changed_radio('loc',$in{'formname'});";
+ my $result.=&mt('[_1] Local Authentication with argument [_2]',
+ '');
return $result;
}
@@ -1070,24 +1714,16 @@ sub authform_filesystem{
kerb_def_dom => 'MSU.EDU',
@_,
);
- my $result='';
- $result.=<<"END";
-
-Filesystem authenticated (with initial password
-)
-END
+ my $jscall = "javascript:changed_radio('fsys',$in{'formname'});";
+ my $result.= &mt
+ ('[_1] Filesystem Authenticated (with initial password [_2])',
+ '');
return $result;
}
-=pod
-
-=back
-
-=cut
-
###############################################################
## Get Authentication Defaults for Domain ##
###############################################################
@@ -1242,7 +1878,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.
@@ -1290,23 +1926,28 @@ 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 %names=&Apache::lonnet::get('environment',
- ['firstname','middlename','lastname','generation'],
- $udom,$uname);
- my $name=$names{'firstname'}.' '.$names{'middlename'}.' '.
- $names{'lastname'}.' '.$names{'generation'};
+ my ($uname,$udom,$first)=@_;
+ my %names=&getnames($uname,$udom);
+ my $name=&Apache::lonnet::format_name($names{'firstname'},
+ $names{'middlename'},
+ $names{'lastname'},
+ $names{'generation'},$first);
+ $name=~s/^\s+//;
$name=~s/\s+$//;
$name=~s/\s+/ /g;
+ if ($name !~ /\S/) { $name=$uname.'@'.$udom; }
return $name;
}
@@ -1329,8 +1970,7 @@ 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=&getnames($uname,$udom);
my $name=$names{'nickname'};
if ($name) {
$name='"'.$name.'"';
@@ -1343,6 +1983,20 @@ sub nickname {
return $name;
}
+sub getnames {
+ my ($uname,$udom)=@_;
+ my $id=$uname.':'.$udom;
+ my ($names,$cached)=&Apache::lonnet::is_cached_new('namescache',$id);
+ if ($cached) {
+ return %{$names};
+ } else {
+ my %loadnames=&Apache::lonnet::get('environment',
+ ['firstname','middlename','lastname','generation','nickname'],
+ $udom,$uname);
+ &Apache::lonnet::do_cache_new('namescache',$id,\%loadnames);
+ return %loadnames;
+ }
+}
# ------------------------------------------------------------------ Screenname
@@ -1356,17 +2010,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
-"$link";
+ ''.$link.'';
}
# --------------------------------------------------------------- Notes Wrapper
@@ -1378,8 +2036,9 @@ sub noteswrapper {
# ------------------------------------------------------------- Aboutme Wrapper
sub aboutmewrapper {
- my ($link,$username,$domain)=@_;
- return "$link";
+ my ($link,$username,$domain,$target)=@_;
+ return ''.$link.'';
}
# ------------------------------------------------------------ Syllabus Wrapper
@@ -1390,7 +2049,25 @@ sub syllabuswrapper {
if ($fontcolor) {
$linktext=''.$linktext.'';
}
- return "$linktext";
+ return qq{$linktext};
+}
+
+sub track_student_link {
+ my ($linktext,$sname,$sdom,$target,$start) = @_;
+ my $link ="/adm/trackstudent?";
+ my $title = 'View recent activity';
+ if (defined($sname) && $sname !~ /^\s*$/ &&
+ defined($sdom) && $sdom !~ /^\s*$/) {
+ $link .= "selected_student=$sname:$sdom";
+ $title .= ' of this student';
+ }
+ if (defined($target) && $target !~ /^\s*$/) {
+ $target = qq{target="$target"};
+ } else {
+ $target = '';
+ }
+ if ($start) { $link.='&start='.$start; }
+ return qq{$linktext};
}
=pod
@@ -1420,7 +2097,20 @@ returns description of a specified langu
=cut
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};
}
=pod
@@ -1444,7 +2134,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
@@ -1484,6 +2198,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()
@@ -1493,7 +2215,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
@@ -1507,7 +2231,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
@@ -1528,26 +2254,57 @@ sub fileextensions {
sub display_languages {
my %languages=();
- if ($ENV{'environment.languages'}) {
- foreach (split(/\s*(\,|\;|\:)\s*/,$ENV{'environment.languages'})) {
- $languages{$_}=1;
- }
- }
- if ($ENV{'course.'.$ENV{'request.course.id'}.'.languages'}) {
- foreach (split(/\s*(\,|\;|\:)\s*/,
- $ENV{'course.'.$ENV{'request.course.id'}.'.languages'})) {
- $languages{$_}=1;
- }
+ foreach (&preferred_languages()) {
+ $languages{$_}=1;
}
&get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
- if ($ENV{'form.displaylanguage'}) {
- foreach (split(/\s*(\,|\;|\:)\s*/,$ENV{'form.displaylanguage'})) {
+ if ($env{'form.displaylanguage'}) {
+ foreach (split(/\s*(\,|\;|\:)\s*/,$env{'form.displaylanguage'})) {
$languages{$_}=1;
}
}
return %languages;
}
+sub preferred_languages {
+ my @languages=();
+ if ($env{'course.'.$env{'request.course.id'}.'.languages'}) {
+ @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,
+ $env{'course.'.$env{'request.course.id'}.'.languages'}));
+ }
+ if ($env{'environment.languages'}) {
+ @languages=split(/\s*(\,|\;|\:)\s*/,$env{'environment.languages'});
+ }
+ my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0];
+ if ($browser) {
+ @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$browser));
+ }
+ if ($Apache::lonnet::domain_lang_def{$env{'user.domain'}}) {
+ @languages=(@languages,
+ $Apache::lonnet::domain_lang_def{$env{'user.domain'}});
+ }
+ if ($Apache::lonnet::domain_lang_def{$env{'request.role.domain'}}) {
+ @languages=(@languages,
+ $Apache::lonnet::domain_lang_def{$env{'request.role.domain'}});
+ }
+ if ($Apache::lonnet::domain_lang_def{
+ $Apache::lonnet::perlvar{'lonDefDomain'}}) {
+ @languages=(@languages,
+ $Apache::lonnet::domain_lang_def{
+ $Apache::lonnet::perlvar{'lonDefDomain'}});
+ }
+# turn "en-ca" into "en-ca,en"
+ my @genlanguages;
+ foreach (@languages) {
+ unless ($_=~/\w/) { next; }
+ push (@genlanguages,$_);
+ if ($_=~/(\-|\_)/) {
+ push (@genlanguages,(split(/(\-|\_)/,$_))[0]);
+ }
+ }
+ return @genlanguages;
+}
+
###############################################################
## Student Answer Attempts ##
###############################################################
@@ -1628,7 +2385,7 @@ sub get_previous_attempt {
} else {
$value=$returnhash{$version.':'.$_};
}
- $prevattempts.='
';
}
@@ -1696,22 +2454,19 @@ show a snapshot of what student was look
=cut
sub get_student_view {
- my ($symb,$username,$domain,$courseid,$target) = @_;
- my ($map,$id,$feedurl) = split(/___/,$symb);
- my (%old,%moreenv);
+ my ($symb,$username,$domain,$courseid,$target,$moreenv) = @_;
+ my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
+ my (%form);
my @elements=('symb','courseid','domain','username');
foreach my $element (@elements) {
- $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 (defined($target)) { $form{'grade_target'} = $target; }
+ $feedurl=&Apache::lonnet::clutter($feedurl);
+ my $userview=&Apache::lonnet::ssi_body($feedurl,%form);
$userview=~s/\]*\>//gi;
$userview=~s/\<\/body\>//gi;
$userview=~s/\//gi;
@@ -1733,25 +2488,93 @@ show a snapshot of how student was answe
sub get_student_answers {
my ($symb,$username,$domain,$courseid,%form) = @_;
- my ($map,$id,$feedurl) = split(/___/,$symb);
- my (%old,%moreenv);
+ my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
+ 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;
}
=pod
+=item * &submlink()
+
+Inputs: $text $uname $udom $symb $target
+
+Returns: A link to grades.pm such as to see the SUBM view of a student
+
+=cut
+
+###############################################
+sub submlink {
+ my ($text,$uname,$udom,$symb,$target)=@_;
+ if (!($uname && $udom)) {
+ (my $cursymb, my $courseid,$udom,$uname)=
+ &Apache::lonxml::whichuser($symb);
+ if (!$symb) { $symb=$cursymb; }
+ }
+ if (!$symb) { $symb=&Apache::lonnet::symbread(); }
+ $symb=&Apache::lonnet::escape($symb);
+ if ($target) { $target="target=\"$target\""; }
+ return ''.$text.'';
+}
+##############################################
+
+=pod
+
+=item * &pgrdlink()
+
+Inputs: $text $uname $udom $symb $target
+
+Returns: A link to grades.pm such as to see the PGRD view of a student
+
+=cut
+
+###############################################
+sub pgrdlink {
+ my $link=&submlink(@_);
+ $link=~s/(&command=submission)/$1&showgrading=yes/;
+ return $link;
+}
+##############################################
+
+=pod
+
+=item * &pprmlink()
+
+Inputs: $text $uname $udom $symb $target
+
+Returns: A link to parmset.pm such as to see the PPRM view of a
+student and a specific resource
+
+=cut
+
+###############################################
+sub pprmlink {
+ my ($text,$uname,$udom,$symb,$target)=@_;
+ if (!($uname && $udom)) {
+ (my $cursymb, my $courseid,$udom,$uname)=
+ &Apache::lonxml::whichuser($symb);
+ if (!$symb) { $symb=$cursymb; }
+ }
+ if (!$symb) { $symb=&Apache::lonnet::symbread(); }
+ $symb=&Apache::lonnet::escape($symb);
+ if ($target) { $target="target=\"$target\""; }
+ return ''.$text.'';
+}
+##############################################
+
+=pod
+
=back
=cut
@@ -1776,22 +2599,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));
}
#########################################
@@ -1799,9 +2607,9 @@ sub unsqltime {
sub findallcourses {
my %courses=();
my $now=time;
- foreach (keys %ENV) {
+ foreach (keys %env) {
if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) {
- my ($starttime,$endtime)=$ENV{$_};
+ my ($starttime,$endtime)=$env{$_};
my $active=1;
if ($starttime) {
if ($now<$starttime) { $active=0; }
@@ -1838,9 +2646,9 @@ sub determinedomain {
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'};
+ if ($env{'user.domain'}) { $domain=$env{'user.domain'}; }
+ if ($env{'request.role.domain'}) {
+ $domain=$env{'request.role.domain'};
}
}
return $domain;
@@ -1862,10 +2670,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 '';
+ my $logo=&lonhttpdurl("/adm/lonDomLogos/$domain.gif");
+ return '';
} elsif(exists($Apache::lonnet::domaindescription{$domain})) {
return $Apache::lonnet::domaindescription{$domain};
} else {
@@ -1887,7 +2693,7 @@ Returns: value of designparamter $which
##############################################
sub designparm {
my ($which,$domain)=@_;
- if ($ENV{'browser.blackwhite'} eq 'on') {
+ if ($env{'browser.blackwhite'} eq 'on') {
if ($which=~/\.(font|alink|vlink|link)$/) {
return '#000000';
}
@@ -1898,8 +2704,8 @@ sub designparm {
return '#CCCCCC';
}
}
- if ($ENV{'environment.color.'.$which}) {
- return $ENV{'environment.color.'.$which};
+ if ($env{'environment.color.'.$which}) {
+ return $env{'environment.color.'.$which};
}
$domain=&determinedomain($domain);
if ($designhash{$domain.'.'.$which}) {
@@ -1941,6 +2747,18 @@ Inputs:
=item * $forcereg, if page should register as content page (relevant for
text interface only)
+=item * $customtitle, alternate text to use instead of $title
+ in the title box that appears, this text
+ is not auto translated like the $title is
+
+=item * $notopbar, if true, keep the 'what is this' info but remove the
+ navigational links
+
+=item * $bgcolor, used to override the bgcolor on a webpage to a specific value
+
+=item * $notitle, if true keep the nav controls, but remove the title bar
+
+
=back
Returns: A uniform header for LON-CAPA web pages.
@@ -1951,40 +2769,33 @@ other decorations will be returned.
=cut
sub bodytag {
- my ($title,$function,$addentries,$bodyonly,$domain,$forcereg)=@_;
- 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=''; }
- if ($ENV{'browser.fontenhance'} eq 'on') {
- $addentries.=' style="font-size: x-large"';
- }
+ my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle,
+ $notopbar,$bgcolor,$notitle)=@_;
+
+ $title=&mt($title);
+
+ $function = &get_users_function() if (!$function);
+ my $img = &designparm($function.'.img',$domain);
+ my $tabbg = &designparm($function.'.tabbg',$domain);
+ my $font = &designparm($function.'.font',$domain);
+ my $sidebg = &designparm($function.'.sidebg',$domain);
+ my $pgbg = $bgcolor || &designparm($function.'.pgbg',$domain);
+
+ my %design = ( 'style' => 'margin-top: 0px',
+ 'bgcolor' => $pgbg,
+ 'text' => $font,
+ 'alink' => &designparm($function.'.alink',$domain),
+ 'vlink' => &designparm($function.'.vlink',$domain),
+ 'link' => &designparm($function.'.link',$domain),);
+ @$addentries{keys(%design)} = @design{keys(%design)};
+
# role and realm
my ($role,$realm)
- =&Apache::lonnet::plaintext((split(/\./,$ENV{'request.role'}))[0]);
+ =&Apache::lonnet::plaintext((split(/\./,$env{'request.role'}))[0]);
# realm
- if ($ENV{'request.course.id'}) {
+ if ($env{'request.course.id'}) {
$realm=
- $ENV{'course.'.$ENV{'request.course.id'}.'.description'};
+ $env{'course.'.$env{'request.course.id'}.'.description'};
}
unless ($realm) { $realm=' '; }
# Set messages
@@ -1992,31 +2803,127 @@ sub bodytag {
# Port for miniserver
my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
+
+ my $extra_body_attr = &make_attr_string($forcereg,$addentries);
+
# construct main body tag
my $bodytag = <
+
END
+
+ $bodytag .= &Apache::lontexconvert::init_math_support();
+
my $upperleft='';
- if ($bodyonly) {
+ $lonhttpdPort.$img.'" alt="'.$function.'" />';
+ if ($bodyonly
+ || ($env{'request.state'} eq 'construct'
+ && $env{'environment.remote'} ne 'off' )) {
return $bodytag;
- } elsif ($ENV{'browser.interface'} eq 'textual') {
+ } elsif ($env{'browser.interface'} eq 'textual') {
# Accessibility
- return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',
- $forcereg).
- '