--- loncom/interface/loncommon.pm 2004/02/02 19:32:11 1.178
+++ loncom/interface/loncommon.pm 2006/06/26 22:06:19 1.398
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# a pile of common routines
#
-# $Id: loncommon.pm,v 1.178 2004/02/02 19:32:11 matthew Exp $
+# $Id: loncommon.pm,v 1.398 2006/06/26 22:06:19 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -55,14 +55,16 @@ 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();
use Apache::lonlocal;
use HTML::Entities;
+use Apache::lonhtmlcommon();
+use Apache::loncoursedata();
+use Apache::lontexconvert();
+use LONCAPA;
my $readit;
@@ -74,7 +76,8 @@ my $readit;
my %language;
my %supported_language;
my %cprtag;
-my %fe; my %fd;
+my %scprtag;
+my %fe; my %fd; my %fm;
my %category_extensions;
# ---------------------------------------------- Designs
@@ -105,10 +108,10 @@ BEGIN {
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/,$_));
+ while (my $line = <$fh>) {
+ next if ($line=~/^\#/);
+ chomp($line);
+ my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$line));
$language{$key}=$val.' - '.$enc;
if ($sup) {
$supported_language{$key}=$sup;
@@ -122,15 +125,29 @@ BEGIN {
my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
'/copyright.tab';
if ( open (my $fh,"<$copyrightfile") ) {
- while (<$fh>) {
- next if /^\#/;
- chomp;
- my ($key,$val)=(split(/\s+/,$_,2));
+ while (my $line = <$fh>) {
+ next if ($line=~/^\#/);
+ chomp($line);
+ my ($key,$val)=(split(/\s+/,$line,2));
$cprtag{$key}=$val;
}
close($fh);
}
}
+# ----------------------------------------------------------- source copyrights
+ {
+ my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
+ '/source_copyright.tab';
+ if ( open (my $fh,"<$sourcecopyrightfile") ) {
+ while (my $line = <$fh>) {
+ next if ($line =~ /^\#/);
+ chomp($line);
+ my ($key,$val)=(split(/\s+/,$line,2));
+ $scprtag{$key}=$val;
+ }
+ close($fh);
+ }
+ }
# -------------------------------------------------------------- domain designs
@@ -138,19 +155,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 $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);
- }
- }
+ {
+ my $designfile = $designdir.'/'.$filename;
+ if ( open (my $fh,"<$designfile") ) {
+ while (my $line = <$fh>) {
+ next if ($line =~ /^\#/);
+ chomp($line);
+ my ($key,$val)=(split(/\=/,$line));
+ if ($val) { $designhash{$domain.'.'.$key}=$val; }
+ }
+ close($fh);
+ }
+ }
}
closedir(DIR);
@@ -161,10 +179,10 @@ BEGIN {
my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.
'/filecategories.tab';
if ( open (my $fh,"<$categoryfile") ) {
- while (<$fh>) {
- next if /^\#/;
- chomp;
- my ($extension,$category)=(split(/\s+/,$_,2));
+ while (my $line = <$fh>) {
+ next if ($line =~ /^\#/);
+ chomp($line);
+ my ($extension,$category)=(split(/\s+/,$line,2));
push @{$category_extensions{lc($category)}},$extension;
}
close($fh);
@@ -176,13 +194,14 @@ BEGIN {
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);
+ while (my $line = <$fh>) {
+ next if ($line =~ /^\#/);
+ chomp($line);
+ my ($ending,$emb,$mime,$descr)=split(/\s+/,$line,4);
if ($descr ne '') {
$fe{$ending}=lc($emb);
$fd{$ending}=$descr;
+ if ($mime ne 'unk') { $fm{$ending}=$mime; }
}
}
close($fh);
@@ -220,10 +239,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]
@@ -235,8 +254,11 @@ of the element the selection from the se
=cut
sub browser_and_searcher_javascript {
+ my ($mode)=@_;
+ if (!defined($mode)) { $mode='edit'; }
my $resurl=&lastresurl();
return <<END;
+// <!-- BEGIN LON-CAPA Internal
var editbrowser = null;
function openbrowser(formname,elementname,only,omit,titleelement) {
var url = '$resurl/?';
@@ -244,20 +266,26 @@ sub browser_and_searcher_javascript {
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();
@@ -269,11 +297,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';
@@ -281,12 +311,13 @@ 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'}
+ if ($env{'environment.lastresurl'}) {
+ return $env{'environment.lastresurl'}
} else {
return '/res';
}
@@ -303,9 +334,12 @@ sub storeresurl {
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');
<script type="text/javascript" language="Javascript" >
@@ -334,14 +368,16 @@ ENDSTDBRW
sub selectstudent_link {
my ($form,$unameele,$udomele)=@_;
- if ($ENV{'request.course.id'}) {
- unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) {
+ if ($env{'request.course.id'}) {
+ if (!&Apache::lonnet::allowed('srm',$env{'request.course.id'})
+ && !&Apache::lonnet::allowed('srm',$env{'request.course.id'}.
+ '/'.$env{'request.course.sec'})) {
return '';
}
return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
'","'.$udomele.'");'."'>".&mt('Select User')."</a>";
}
- if ($ENV{'request.role'}=~/^(au|dc|su)/) {
+ if ($env{'request.role'}=~/^(au|dc|su)/) {
return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
'","'.$udomele.'",1);'."'>".&mt('Select User')."</a>";
}
@@ -350,10 +386,11 @@ sub selectstudent_link {
sub coursebrowser_javascript {
my ($domainfilter)=@_;
+ my $crs_or_grp_alert = &mt('Please select the type of LON-CAPA entity - Course or Group - for which you wish to add/modify a user role');
return (<<ENDSTDBRW);
<script type="text/javascript" language="Javascript" >
var stdeditbrowser;
- function opencrsbrowser(formname,uname,udom) {
+ function opencrsbrowser(formname,uname,udom,desc,extra_element,multflag,crstype) {
var url = '/adm/pickcourse?';
var filter;
if (filter != null) {
@@ -368,7 +405,29 @@ sub coursebrowser_javascript {
}
}
url += 'form=' + formname + '&cnumelement='+uname+
- '&cdomelement='+udom;
+ '&cdomelement='+udom+
+ '&cnameelement='+desc;
+ if (extra_element !=null && extra_element != '' && formname == 'rolechoice') {
+ url += '&roleelement='+extra_element;
+ if (domainfilter == null || domainfilter == '') {
+ url += '&domainfilter='+extra_element;
+ }
+ }
+ if (multflag !=null && multflag != '') {
+ url += '&multiple='+multflag;
+ }
+ if (crstype == 'Course/Group') {
+ if (formname == 'cu') {
+ crstype = document.cu.crstype.options[document.cu.crstype.selectedIndex].value;
+ if (crstype == "") {
+ alert("$crs_or_grp_alert");
+ return;
+ }
+ }
+ }
+ if (crstype !=null && crstype != '') {
+ url += '&type='+crstype;
+ }
var title = 'Course_Browser';
var options = 'scrollbars=1,resizable=1,menubar=0';
options += ',width=700,height=600';
@@ -380,11 +439,36 @@ ENDSTDBRW
}
sub selectcourse_link {
- my ($form,$unameele,$udomele)=@_;
+ my ($form,$unameele,$udomele,$desc,$extra_element,$multflag,$selecttype)=@_;
return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.
- '","'.$udomele.'");'."'>".&mt('Select Course')."</a>";
+ '","'.$udomele.'","'.$desc.'","'.$extra_element.'","'.$multflag.'","'.$selecttype.'");'."'>".&mt('Select [_1]',$selecttype)."</a>";
}
+sub check_uncheck_jscript {
+ my $jscript = <<"ENDSCRT";
+function checkAll(field) {
+ if (field.length > 0) {
+ for (i = 0; i < field.length; i++) {
+ field[i].checked = true ;
+ }
+ } else {
+ field.checked = true
+ }
+}
+
+function uncheckAll(field) {
+ if (field.length > 0) {
+ for (i = 0; i < field.length; i++) {
+ field[i].checked = false ;
+ } } else {
+ field.checked = false ;
+ }
+}
+ENDSCRT
+ return $jscript;
+}
+
+
=pod
=item * linked_select_forms(...)
@@ -465,7 +549,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 = '';
@@ -514,7 +598,7 @@ END
$result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
foreach my $value (sort(keys(%$hashref))) {
$result.=" <option value=\"$value\" ";
- $result.=" selected=\"true\" " if ($value eq $firstdefault);
+ $result.=" selected=\"selected\" " if ($value eq $firstdefault);
$result.=">".&mt($hashref->{$value}->{'text'})."</option>\n";
}
$result .= "</select>\n";
@@ -524,7 +608,7 @@ END
my $seconddefault = $hashref->{$firstdefault}->{'default'};
foreach my $value (sort(keys(%select2))) {
$result.=" <option value=\"$value\" ";
- $result.=" selected=\"true\" " if ($value eq $seconddefault);
+ $result.=" selected=\"selected\" " if ($value eq $seconddefault);
$result.=">".&mt($select2{$value})."</option>\n";
}
$result .= "</select>\n";
@@ -560,8 +644,8 @@ sub help_open_topic {
my ($topic, $text, $stayOnPage, $width, $height) = @_;
$text = "" if (not defined $text);
$stayOnPage = 0 if (not defined $stayOnPage);
- if ($ENV{'browser.interface'} eq 'textual' ||
- $ENV{'environment.remote'} eq 'off' ) {
+ if ($env{'browser.interface'} eq 'textual' ||
+ $env{'environment.remote'} eq 'off' ) {
$stayOnPage=1;
}
$width = 350 if (not defined $width);
@@ -592,8 +676,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" title="Online Help"><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;
@@ -620,24 +706,118 @@ 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 my $datum (\$color,\$function,\$topic,\$component_help,\$faq,
+ \$bug,\$origurl) {
+ $$datum = &escape($$datum);
+ }
+ if (!$stayOnPage) {
+ $link = "javascript:helpMenu('open')";
+ } else {
+ $link = "javascript:helpMenu('display')";
+ }
+ my $banner_link = "/adm/helpmenu?page=banner&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&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp";
+ my $template;
+ if ($text ne "") {
+ $template .=
+ "<table bgcolor='#CC3300' cellspacing='1' cellpadding='1' border='0'><tr>".
+ "<td bgcolor='#CC6600'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
+ }
+ my $nothing=&Apache::lonhtmlcommon::javascript_nothing();
+ my $helpicon=&lonhttpdurl("/adm/lonIcons/helpgateway.gif");
+ my $start_page =
+ &Apache::loncommon::start_page('Help Menu', undef,
+ {'frameset' => 1,
+ 'js_ready' => 1,
+ 'add_entries' => {
+ 'border' => '0',
+ 'rows' => "105,*",},});
+ my $end_page =
+ &Apache::loncommon::end_page({'frameset' => 1,
+ 'js_ready' => 1,});
+
+ $template .= <<"ENDTEMPLATE";
+ <script type="text/javascript">
+// <!-- BEGIN LON-CAPA Internal
+// <![CDATA[
+function helpMenu(target) {
+ var caller = this;
+ if (target == 'open') {
+ var newWindow = null;
+ try {
+ newWindow = window.open($nothing,"helpmenu","HEIGHT=$height,WIDTH=$width,resizable=yes,scrollbars=yes" )
+ }
+ catch(error) {
+ writeHelp(caller);
+ return;
+ }
+ if (newWindow) {
+ caller = newWindow;
+ }
+ }
+ writeHelp(caller);
+ return;
+}
+function writeHelp(caller) {
+ caller.document.writeln('$start_page<frame name="bannerframe" src="$banner_link" /><frame name="bodyframe" src="$details_link" /> $end_page')
+ caller.document.close()
+ caller.focus()
+}
+// ]]>
+// END LON-CAPA Internal -->
+ </script>
+ <a href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help Menu)" /></a>
+ENDTEMPLATE
+ if ($component_help) {
+ if (!$text) {
+ $template=&help_open_topic($component_help,undef,$stayOnPage,
+ $width,$height).' '.$template;
+ } else {
+ my $help_text;
+ $help_text=&unescape($topic);
+ $template='<table><tr><td>'.
+ &help_open_topic($component_help,$help_text,$stayOnPage,
+ $width,$height).'</td><td>'.$template.
+ '</td></tr></table>';
+ }
+ }
+ if ($text ne '') { $template.='</td></tr></table>' };
+ return $template;
+}
+
sub help_open_bug {
my ($topic, $text, $stayOnPage, $width, $height) = @_;
- unless ($ENV{'user.adv'}) { return ''; }
+ unless ($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' ) {
+ 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);
+ $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;
+ my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='.
+ &escape($ENV{'REQUEST_URI'}).'&component='.$topic;
if (!$stayOnPage)
{
$link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
@@ -655,8 +835,10 @@ sub help_open_bug {
}
# Add the graphic
+ my $title = &mt('Report a Bug');
+ my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif");
$template .= <<"ENDTEMPLATE";
- <a href="$link" title="Report a Bug"><image src="/adm/lonMisc/smallBug.gif" border="0" alt="(Bug: $topic)" /></a>
+ <a href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a>
ENDTEMPLATE
if ($text ne '') { $template.='</td></tr></table>' };
return $template;
@@ -665,12 +847,12 @@ ENDTEMPLATE
sub help_open_faq {
my ($topic, $text, $stayOnPage, $width, $height) = @_;
- unless ($ENV{'user.adv'}) { return ''; }
+ 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' ) {
+ if ($env{'browser.interface'} eq 'textual' ||
+ $env{'environment.remote'} eq 'off' ) {
$stayOnPage=1;
}
$width = 350 if (not defined $width);
@@ -698,29 +880,18 @@ sub help_open_faq {
}
# Add the graphic
+ my $title = &mt('View the FAQ');
+ my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif");
$template .= <<"ENDTEMPLATE";
- <a href="$link" title="View the FAQ"><image src="/adm/lonMisc/smallFAQ.gif" border="0" alt="(FAQ: $topic)" /></a>
+ <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'
-format.
-
-=cut
-
-sub csv_translate {
- my $text = shift;
- $text =~ s/\"/\"\"/g;
- $text =~ s/\n//g;
- return $text;
-}
+###############################################################
+###############################################################
=pod
@@ -754,8 +925,8 @@ pretty much any HTML.
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\./) {
+ if ($env{'browser.type'} eq 'netscape' &&
+ $env{'browser.version'} =~ /^4\./) {
return (<<NETSCAPE4);
function change(name, content) {
doc = document.layers[name+"___escape"].layers[0].document;
@@ -792,8 +963,8 @@ the area will originally contain, which
sub changable_area {
my ($name, $origContent) = @_;
- if ($ENV{'browser.type'} eq 'netscape' &&
- $ENV{'browser.version'} =~ /^4\./) {
+ 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 {
@@ -805,6 +976,174 @@ sub changable_area {
=back
+=head1 Excel and CSV file utility routines
+
+=over 4
+
+=cut
+
+###############################################################
+###############################################################
+
+=pod
+
+=item * csv_translate($text)
+
+Translate $text to allow it to be output as a 'comma separated values'
+format.
+
+=cut
+
+###############################################################
+###############################################################
+sub csv_translate {
+ my $text = shift;
+ $text =~ s/\"/\"\"/g;
+ $text =~ s/\n/ /g;
+ return $text;
+}
+
+###############################################################
+###############################################################
+
+=pod
+
+=item * define_excel_formats
+
+Define some commonly used Excel cell formats.
+
+Currently supported formats:
+
+=over 4
+
+=item header
+
+=item bold
+
+=item h1
+
+=item h2
+
+=item h3
+
+=item h4
+
+=item i
+
+=item date
+
+=back
+
+Inputs: $workbook
+
+Returns: $format, a hash reference.
+
+=cut
+
+###############################################################
+###############################################################
+sub define_excel_formats {
+ my ($workbook) = @_;
+ my $format;
+ $format->{'header'} = $workbook->add_format(bold => 1,
+ bottom => 1,
+ align => 'center');
+ $format->{'bold'} = $workbook->add_format(bold=>1);
+ $format->{'h1'} = $workbook->add_format(bold=>1, size=>18);
+ $format->{'h2'} = $workbook->add_format(bold=>1, size=>16);
+ $format->{'h3'} = $workbook->add_format(bold=>1, size=>14);
+ $format->{'h4'} = $workbook->add_format(bold=>1, size=>12);
+ $format->{'i'} = $workbook->add_format(italic=>1);
+ $format->{'date'} = $workbook->add_format(num_format=>
+ 'mm/dd/yyyy hh:mm:ss');
+ return $format;
+}
+
+###############################################################
+###############################################################
+
+=pod
+
+=item * create_workbook
+
+Create an Excel worksheet. If it fails, output message on the
+request object and return undefs.
+
+Inputs: Apache request object
+
+Returns (undef) on failure,
+ Excel worksheet object, scalar with filename, and formats
+ from &Apache::loncommon::define_excel_formats on success
+
+=cut
+
+###############################################################
+###############################################################
+sub create_workbook {
+ my ($r) = @_;
+ #
+ # Create the excel spreadsheet
+ my $filename = '/prtspool/'.
+ $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
+ time.'_'.rand(1000000000).'.xls';
+ my $workbook = Spreadsheet::WriteExcel->new('/home/httpd'.$filename);
+ if (! defined($workbook)) {
+ $r->log_error("Error creating excel spreadsheet $filename: $!");
+ $r->print('<p>'.&mt("Unable to create new Excel file. ".
+ "This error has been logged. ".
+ "Please alert your LON-CAPA administrator").
+ '</p>');
+ return (undef);
+ }
+ #
+ $workbook->set_tempdir('/home/httpd/perl/tmp');
+ #
+ my $format = &Apache::loncommon::define_excel_formats($workbook);
+ return ($workbook,$filename,$format);
+}
+
+###############################################################
+###############################################################
+
+=pod
+
+=item * create_text_file
+
+Create a file to write to and eventually make available to the usre.
+If file creation fails, outputs an error message on the request object and
+return undefs.
+
+Inputs: Apache request object, and file suffix
+
+Returns (undef) on failure,
+ Filehandle and filename on success.
+
+=cut
+
+###############################################################
+###############################################################
+sub create_text_file {
+ my ($r,$suffix) = @_;
+ if (! defined($suffix)) { $suffix = 'txt'; };
+ my $fh;
+ my $filename = '/prtspool/'.
+ $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
+ time.'_'.rand(1000000000).'.'.$suffix;
+ $fh = Apache::File->new('>/home/httpd'.$filename);
+ if (! defined($fh)) {
+ $r->log_error("Couldn't open $filename for output $!");
+ $r->print("Problems occured in creating the output file. ".
+ "This error has been logged. ".
+ "Please alert your LON-CAPA administrator.");
+ }
+ return ($fh,$filename)
+}
+
+
+=pod
+
+=back
+
=cut
###############################################################
@@ -829,8 +1168,8 @@ sub get_domains {
# The code below was stolen from "The Perl Cookbook", p 102, 1st ed.
my @domains;
my %seen;
- foreach (sort values(%Apache::lonnet::hostdom)) {
- push (@domains,$_) unless $seen{$_}++;
+ foreach my $dom (sort(values(%Apache::lonnet::hostdom))) {
+ push(@domains,$dom) unless $seen{$dom}++;
}
return @domains;
}
@@ -844,21 +1183,49 @@ sub domain_select {
} &get_domains;
if ($multiple) {
$domains{''}=&mt('Any domain');
- return &multiple_select_form($name,$value,%domains);
+ return &multiple_select_form($name,$value,4,\%domains);
} else {
return &select_form($name,$value,%domains);
}
}
+#-------------------------------------------
+
+=pod
+
+=item * multiple_select_form($name,$value,$size,$hash,$order)
+
+Returns a string containing a <select> element int multiple mode
+
+
+Args:
+ $name - name of the <select> element
+ $value - sclara or array ref of values that should already be selected
+ $size - number of rows long the select element is
+ $hash - the elements should be 'option' => 'shown text'
+ (shown text should already have been &mt())
+ $order - (optional) array ref of the order to show the elments in
+
+=cut
+
+#-------------------------------------------
sub multiple_select_form {
- my ($name,$value,%hash)=@_;
+ my ($name,$value,$size,$hash,$order)=@_;
my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);
my $output='';
- my $size =(scalar keys %hash<4?scalar keys %hash:4);
+ 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 name='$_'".
- ($selected{$_}?' selected="1"' :'').">$hash{$_}</option>\n";
+ my @order = ref($order) ? @$order
+ : sort(keys(%$hash));
+ foreach my $key (@order) {
+ $output.='<option value="'.&HTML::Entities::encode($key,'"<>&').'" ';
+ $output.='selected="selected" ' if ($selected{$key});
+ $output.='>'.$hash->{$key}."</option>\n";
}
$output.="</select>\n";
return $output;
@@ -886,10 +1253,11 @@ sub select_form {
} else {
@keys=sort(keys(%hash));
}
- foreach (@keys) {
- $selectform.="<option value=\"$_\" ".
- ($_ eq $def ? 'selected' : '').
- ">".&mt($hash{$_})."</option>\n";
+ foreach my $key (@keys) {
+ $selectform.=
+ '<option value="'.&HTML::Entities::encode($key,'"<>&').'" '.
+ ($key eq $def ? 'selected="selected" ' : '').
+ ">".&mt($hash{$key})."</option>\n";
}
$selectform.="</select>";
return $selectform;
@@ -925,7 +1293,7 @@ sub select_level_form {
my $selectform = "<select name=\"$name\" size=\"1\">\n";
for (my $i=0; $i<=18; $i++) {
$selectform.="<option value=\"$i\" ".
- ($i==$deflevel ? 'selected' : '').
+ ($i==$deflevel ? 'selected="selected" ' : '').
">".&gradeleveldescription($i)."</option>\n";
}
$selectform.="</select>";
@@ -953,10 +1321,10 @@ sub select_dom_form {
my @domains = get_domains();
if ($includeempty) { @domains=('',@domains); }
my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
- foreach (@domains) {
- $selectdomain.="<option value=\"$_\" ".
- ($_ eq $defdom ? 'selected' : '').
- ">$_</option>\n";
+ foreach my $dom (@domains) {
+ $selectdomain.="<option value=\"$dom\" ".
+ ($dom eq $defdom ? 'selected="selected" ' : '').
+ ">$dom</option>\n";
}
$selectdomain.="</select>";
return $selectdomain;
@@ -978,9 +1346,9 @@ given $domain.
sub get_library_servers {
my $domain = shift;
my %library_servers;
- foreach (keys(%Apache::lonnet::libserv)) {
- if ($Apache::lonnet::hostdom{$_} eq $domain) {
- $library_servers{$_} = $Apache::lonnet::hostname{$_};
+ foreach my $hostid (keys(%Apache::lonnet::libserv)) {
+ if ($Apache::lonnet::hostdom{$hostid} eq $domain) {
+ $library_servers{$hostid} = $Apache::lonnet::hostname{$hostid};
}
}
return %library_servers;
@@ -1002,9 +1370,10 @@ sub home_server_option_list {
my $domain = shift;
my %servers = &get_library_servers($domain);
my $result = '';
- foreach (sort keys(%servers)) {
+ foreach my $hostid (sort(keys(%servers))) {
$result.=
- '<option value="'.$_.'">'.$_.' '.$servers{$_}."</option>\n";
+ '<option value="'.$hostid.'">'.
+ $hostid.' '.$servers{$hostid}."</option>\n";
}
return $result;
}
@@ -1054,9 +1423,11 @@ Outputs:
###############################################################
###############################################################
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='';
@@ -1252,10 +1623,11 @@ sub authform_nochange{
kerb_def_dom => 'MSU.EDU',
@_,
);
- my $result = &mt('[_1] Do not change login data',
+ my $result = '<label>'.&mt('[_1] Do not change login data',
'<input type="radio" name="login" value="nochange" '.
'checked="checked" onclick="'.
- "javascript:changed_radio('nochange',$in{'formname'});".'" />');
+ "javascript:changed_radio('nochange',$in{'formname'});".'" />').
+ '</label>';
return $result;
}
@@ -1287,14 +1659,15 @@ sub authform_kerberos{
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" '.
+ '[_3] Version 4 [_4] Version 5 [_5]',
+ '<label><input type="radio" name="login" value="krb" '.
'onclick="'.$jscall.'" onchange="'.$jscall.'"'.$krbcheck.' />',
- '<input type="text" size="10" name="krbarg" '.
+ '</label><input type="text" size="10" name="krbarg" '.
'value="'.$krbarg.'" '.
'onchange="'.$jscall.'" />',
- '<input type="radio" name="krbver" value="4" '.$check4.' />',
- '<input type="radio" name="krbver" value="5" '.$check5.' />');
+ '<label><input type="radio" name="krbver" value="4" '.$check4.' />',
+ '</label><label><input type="radio" name="krbver" value="5" '.$check5.' />',
+ '</label>');
return $result;
}
@@ -1319,9 +1692,9 @@ sub authform_internal{
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" '.$intcheck.
+ '<label><input type="radio" name="login" value="int" '.$intcheck.
' onchange="'.$jscall.'" onclick="'.$jscall.'" />',
- '<input type="text" size="10" name="intarg" '.$intarg.
+ '</label><input type="text" size="10" name="intarg" '.$intarg.
' onchange="'.$jscall.'" />');
return $result;
}
@@ -1346,9 +1719,9 @@ sub authform_local{
my $jscall = "javascript:changed_radio('loc',$in{'formname'});";
my $result.=&mt('[_1] Local Authentication with argument [_2]',
- '<input type="radio" name="login" value="loc" '.$loccheck.
+ '<label><input type="radio" name="login" value="loc" '.$loccheck.
' onchange="'.$jscall.'" onclick="'.$jscall.'" />',
- '<input type="text" size="10" name="locarg" '.$locarg.
+ '</label><input type="text" size="10" name="locarg" '.$locarg.
' onchange="'.$jscall.'" />');
return $result;
}
@@ -1362,9 +1735,9 @@ sub authform_filesystem{
my $jscall = "javascript:changed_radio('fsys',$in{'formname'});";
my $result.= &mt
('[_1] Filesystem Authenticated (with initial password [_2])',
- '<input type="radio" name="login" value="fsys" '.
+ '<label><input type="radio" name="login" value="fsys" '.
'onchange="'.$jscall.'" onclick="'.$jscall.'" />',
- '<input type="text" size="10" name="fsysarg" value="" '.
+ '</label><input type="text" size="10" name="fsysarg" value="" '.
'onchange="'.$jscall.'" />');
return $result;
}
@@ -1490,8 +1863,8 @@ sub initialize_keywords {
}
untie %thesaurus_db;
# Remove special values from %Keywords.
- foreach ('total.count','average.count') {
- delete($Keywords{$_}) if (exists($Keywords{$_}));
+ foreach my $value ('total.count','average.count') {
+ delete($Keywords{$value}) if (exists($Keywords{$value}));
}
return 1;
}
@@ -1547,11 +1920,11 @@ sub get_related_words {
}
my @Words=();
if (exists($thesaurus_db{$keyword})) {
- $_ = $thesaurus_db{$keyword};
- (undef,@Words) = split/:/; # The first element is the number of times
- # the word appears. We do not need it now.
+ # The first element is the number of times
+ # the word appears. We do not need it now.
+ (undef,@Words) = (split(/:/,$thesaurus_db{$keyword}));
for (my $i=0;$i<=$#Words;$i++) {
- ($Words[$i],undef)= split/\,/,$Words[$i];
+ ($Words[$i],undef)= split(/\,/,$Words[$i]);
}
}
untie %thesaurus_db;
@@ -1571,23 +1944,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;
}
@@ -1610,8 +1988,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.'"';
@@ -1624,6 +2001,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
@@ -1637,17 +2028,22 @@ 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,$subject,$text)=@_;
return
-"<a href='/adm/email?compose=individual&recname=$un&recdom=$do'>$link</a>";
+ '<a href="/adm/email?compose=individual&'.
+ 'recname='.$username.'&recdom='.$domain.
+ '&subject='.&escape($subject).'&text='.&escape($text).'" '.
+ 'title="'.&mt('Send message').'">'.$link.'</a>';
}
# --------------------------------------------------------------- Notes Wrapper
@@ -1660,8 +2056,8 @@ sub noteswrapper {
sub aboutmewrapper {
my ($link,$username,$domain,$target)=@_;
- return "<a href='/adm/$domain/$username/aboutme'".
- ($target?" target='$target'":'').">$link</a>";
+ return '<a href="/adm/'.$domain.'/'.$username.'/aboutme"'.
+ ($target?' target="$target"':'').' title="'.&mt('View this users personal page').'">'.$link.'</a>';
}
# ------------------------------------------------------------ Syllabus Wrapper
@@ -1672,7 +2068,25 @@ 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,$start) = @_;
+ my $link ="/adm/trackstudent?";
+ my $title = 'View recent activity';
+ if (defined($sname) && $sname !~ /^\s*$/ &&
+ defined($sdom) && $sdom !~ /^\s*$/) {
+ $link .= "selected_student=$sname:$sdom";
+ $title .= ' of this student';
+ }
+ if (defined($target) && $target !~ /^\s*$/) {
+ $target = qq{target="$target"};
+ } else {
+ $target = '';
+ }
+ if ($start) { $link.='&start='.$start; }
+ return qq{<a href="$link" title="$title" $target>$linktext</a>};
}
=pod
@@ -1744,6 +2158,30 @@ sub copyrightdescription {
=pod
+=item * source_copyrightids()
+
+returns list of all source copyrights
+
+=cut
+
+sub source_copyrightids {
+ return sort(keys(%scprtag));
+}
+
+=pod
+
+=item * source_copyrightdescription()
+
+returns description of a specified source copyright id
+
+=cut
+
+sub source_copyrightdescription {
+ return &mt($scprtag{shift(@_)});
+}
+
+=pod
+
=item * filecategories()
returns list of all file categories
@@ -1764,7 +2202,8 @@ category
=cut
sub filecategorytypes {
- return @{$category_extensions{lc($_[0])}};
+ my ($cat) = @_;
+ return @{$category_extensions{lc($cat)}};
}
=pod
@@ -1779,10 +2218,14 @@ sub fileembstyle {
return $fe{lc(shift(@_))};
}
+sub filemimetype {
+ return $fm{lc(shift(@_))};
+}
+
sub filecategoryselect {
my ($name,$value)=@_;
- return &select_form($name,$value,
+ return &select_form($value,$name,
'' => &mt('Any category'),
map { $_,$_ } sort(keys(%category_extensions)));
}
@@ -1796,7 +2239,9 @@ returns description for a specified file
=cut
sub filedescription {
- return &mt($fd{lc(shift(@_))});
+ my $file_description = $fd{lc(shift())};
+ $file_description =~ s:([\[\]]):~$1:g;
+ return &mt($file_description);
}
=pod
@@ -1810,7 +2255,9 @@ extra formatting
sub filedescriptionex {
my $ex=shift;
- return '.'.$ex.' '.&mt($fd{lc($ex)});
+ my $file_description = $fd{lc($ex)};
+ $file_description =~ s:([\[\]]):~$1:g;
+ return '.'.$ex.' '.&mt($file_description);
}
# End of .tab access
@@ -1831,13 +2278,13 @@ sub fileextensions {
sub display_languages {
my %languages=();
- foreach (&preferred_languages()) {
- $languages{$_}=1;
+ foreach my $lang (&preferred_languages()) {
+ $languages{$lang}=1;
}
&get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
- if ($ENV{'form.displaylanguage'}) {
- foreach (split(/\s*(\,|\;|\:)\s*/,$ENV{'form.displaylanguage'})) {
- $languages{$_}=1;
+ if ($env{'form.displaylanguage'}) {
+ foreach my $lang (split(/\s*(\,|\;|\:)\s*/,$env{'form.displaylanguage'})) {
+ $languages{$lang}=1;
}
}
return %languages;
@@ -1845,24 +2292,24 @@ sub display_languages {
sub preferred_languages {
my @languages=();
- if ($ENV{'course.'.$ENV{'request.course.id'}.'.languages'}) {
+ if ($env{'course.'.$env{'request.course.id'}.'.languages'}) {
@languages=(@languages,split(/\s*(\,|\;|\:)\s*/,
- $ENV{'course.'.$ENV{'request.course.id'}.'.languages'}));
+ $env{'course.'.$env{'request.course.id'}.'.languages'}));
}
- if ($ENV{'environment.languages'}) {
- @languages=split(/\s*(\,|\;|\:)\s*/,$ENV{'environment.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'}}) {
+ if ($Apache::lonnet::domain_lang_def{$env{'user.domain'}}) {
@languages=(@languages,
- $Apache::lonnet::domain_lang_def{$ENV{'user.domain'}});
+ $Apache::lonnet::domain_lang_def{$env{'user.domain'}});
}
- if ($Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}}) {
+ if ($Apache::lonnet::domain_lang_def{$env{'request.role.domain'}}) {
@languages=(@languages,
- $Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}});
+ $Apache::lonnet::domain_lang_def{$env{'request.role.domain'}});
}
if ($Apache::lonnet::domain_lang_def{
$Apache::lonnet::perlvar{'lonDefDomain'}}) {
@@ -1872,11 +2319,11 @@ sub preferred_languages {
}
# turn "en-ca" into "en-ca,en"
my @genlanguages;
- foreach (@languages) {
- unless ($_=~/\w/) { next; }
- push (@genlanguages,$_);
- if ($_=~/(\-|\_)/) {
- push (@genlanguages,(split(/(\-|\_)/,$_))[0]);
+ foreach my $lang (@languages) {
+ unless ($lang=~/\w/) { next; }
+ push (@genlanguages,$lang);
+ if ($lang=~/(\-|\_)/) {
+ push(@genlanguages,(split(/(\-|\_)/,$lang))[0]);
}
}
return @genlanguages;
@@ -1932,14 +2379,14 @@ sub get_previous_attempt {
my %lasthash=();
my $version;
for ($version=1;$version<=$returnhash{'version'};$version++) {
- foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) {
- $lasthash{$_}=$returnhash{$version.':'.$_};
+ foreach my $key (sort(split(/\:/,$returnhash{$version.':keys'}))) {
+ $lasthash{$key}=$returnhash{$version.':'.$key};
}
}
$prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">';
$prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>';
- foreach (sort(keys %lasthash)) {
- my ($ign,@parts) = split(/\./,$_);
+ foreach my $key (sort(keys(%lasthash))) {
+ my ($ign,@parts) = split(/\./,$key);
if ($#parts > 0) {
my $data=$parts[-1];
pop(@parts);
@@ -1955,27 +2402,27 @@ sub get_previous_attempt {
if ($getattempt eq '') {
for ($version=1;$version<=$returnhash{'version'};$version++) {
$prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Transaction '.$version.'</td>';
- foreach (sort(keys %lasthash)) {
+ foreach my $key (sort(keys(%lasthash))) {
my $value;
- if ($_ =~ /timestamp/) {
- $value=scalar(localtime($returnhash{$version.':'.$_}));
+ if ($key =~ /timestamp/) {
+ $value=scalar(localtime($returnhash{$version.':'.$key}));
} else {
- $value=$returnhash{$version.':'.$_};
+ $value=$returnhash{$version.':'.$key};
}
- $prevattempts.='<td>'.&Apache::lonnet::unescape($value).' </td>';
+ $prevattempts.='<td>'.&unescape($value).' </td>';
}
}
}
$prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Current</td>';
- foreach (sort(keys %lasthash)) {
+ foreach my $key (sort(keys(%lasthash))) {
my $value;
- if ($_ =~ /timestamp/) {
- $value=scalar(localtime($lasthash{$_}));
+ if ($key =~ /timestamp/) {
+ $value=scalar(localtime($lasthash{$key}));
} else {
- $value=$lasthash{$_};
+ $value=$lasthash{$key};
}
- $value=&Apache::lonnet::unescape($value);
- if ($_ =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}
+ $value=&unescape($value);
+ if ($key =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}
$prevattempts.='<td>'.$value.' </td>';
}
$prevattempts.='</tr></table></td></tr></table>';
@@ -2007,14 +2454,14 @@ sub relative_to_absolute {
}
}
$thisdir=~s-/[^/]*$--;
- foreach (@rlinks) {
- unless (($_=~/^http:\/\//i) ||
- ($_=~/^\//) ||
- ($_=~/^javascript:/i) ||
- ($_=~/^mailto:/i) ||
- ($_=~/^\#/)) {
- my $newlocation=&Apache::lonnet::hreflocation($thisdir,$_);
- $output=~s/(\"|\'|\=\s*)$_(\"|\'|\s|\>)/$1$newlocation$2/;
+ foreach my $link (@rlinks) {
+ unless (($link=~/^http:\/\//i) ||
+ ($link=~/^\//) ||
+ ($link=~/^javascript:/i) ||
+ ($link=~/^mailto:/i) ||
+ ($link=~/^\#/)) {
+ my $newlocation=&Apache::lonnet::hreflocation($thisdir,$link);
+ $output=~s/(\"|\'|\=\s*)\Q$link\E(\"|\'|\s|\>)/$1$newlocation$2/;
}
}
# -------------------------------------------------- Deal with Applet codebases
@@ -2031,22 +2478,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 (defined($target)) { $form{'grade_target'} = $target; }
+ $feedurl=&Apache::lonnet::clutter($feedurl);
+ my $userview=&Apache::lonnet::ssi_body($feedurl,%form);
$userview=~s/\<body[^\>]*\>//gi;
$userview=~s/\<\/body\>//gi;
$userview=~s/\<html\>//gi;
@@ -2069,19 +2513,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;
}
@@ -2089,7 +2528,7 @@ sub get_student_answers {
=item * &submlink()
-Inputs: $text $uname $udom $symb
+Inputs: $text $uname $udom $symb $target
Returns: A link to grades.pm such as to see the SUBM view of a student
@@ -2097,15 +2536,64 @@ Returns: A link to grades.pm such as to
###############################################
sub submlink {
- my ($text,$uname,$udom,$symb)=@_;
+ my ($text,$uname,$udom,$symb,$target)=@_;
+ if (!($uname && $udom)) {
+ (my $cursymb, my $courseid,$udom,$uname)=
+ &Apache::lonxml::whichuser($symb);
+ if (!$symb) { $symb=$cursymb; }
+ }
+ if (!$symb) { $symb=&Apache::lonnet::symbread(); }
+ $symb=&escape($symb);
+ if ($target) { $target="target=\"$target\""; }
+ return '<a href="/adm/grades?&command=submission&'.
+ 'symb='.$symb.'&student='.$uname.
+ '&userdom='.$udom.'" '.$target.'>'.$text.'</a>';
+}
+##############################################
+
+=pod
+
+=item * &pgrdlink()
+
+Inputs: $text $uname $udom $symb $target
+
+Returns: A link to grades.pm such as to see the PGRD view of a student
+
+=cut
+
+###############################################
+sub pgrdlink {
+ my $link=&submlink(@_);
+ $link=~s/(&command=submission)/$1&showgrading=yes/;
+ return $link;
+}
+##############################################
+
+=pod
+
+=item * &pprmlink()
+
+Inputs: $text $uname $udom $symb $target
+
+Returns: A link to parmset.pm such as to see the PPRM view of a
+student and a specific resource
+
+=cut
+
+###############################################
+sub pprmlink {
+ my ($text,$uname,$udom,$symb,$target)=@_;
if (!($uname && $udom)) {
(my $cursymb, my $courseid,$udom,$uname)=
&Apache::lonxml::whichuser($symb);
if (!$symb) { $symb=$cursymb; }
}
- if (!$symb) { $symb=&symbread(); }
- return '<a href="/adm/grades?symb='.$symb.'&student='.$uname.
- '&userdom='.$udom.'&command=submission">'.$text.'</a>';
+ if (!$symb) { $symb=&Apache::lonnet::symbread(); }
+ $symb=&escape($symb);
+ if ($target) { $target="target=\"$target\""; }
+ return '<a href="/adm/parmset?&command=set&'.
+ 'symb='.$symb.'&uname='.$uname.
+ '&udom='.$udom.'" '.$target.'>'.$text.'</a>';
}
##############################################
@@ -2131,21 +2619,32 @@ sub timehash {
'dlsav' => $ltime[8] );
}
+sub utc_string {
+ my ($date)=@_;
+ return strftime("%Y%m%dT%H%M%SZ",gmtime($date));
+}
+
sub maketime {
my %th=@_;
return POSIX::mktime(
($th{'seconds'},$th{'minutes'},$th{'hours'},
- $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,$th{'dlsav'}));
+ $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1));
}
#########################################
sub findallcourses {
- my %courses=();
+ my ($roles) = @_;
+ my %roles;
+ if (ref($roles)) { %roles = map { $_ => 1 } @{$roles}; }
+ my %courses;
my $now=time;
- foreach (keys %ENV) {
- if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) {
- my ($starttime,$endtime)=$ENV{$_};
+ foreach my $key (keys(%env)) {
+ if ( $key=~m{^user\.role\.(\w+)\./(\w+)/(\w+)} ) {
+ my ($role,$domain,$id) = ($1,$2,$3);
+ next if ($role eq 'ca' || $role eq 'aa');
+ next if (%roles && !exists($roles{$role}));
+ my ($starttime,$endtime)=split(/\./,$env{$key});
my $active=1;
if ($starttime) {
if ($now<$starttime) { $active=0; }
@@ -2153,10 +2652,10 @@ sub findallcourses {
if ($endtime) {
if ($now>$endtime) { $active=0; }
}
- if ($active) { $courses{$1.'_'.$2}=1; }
+ if ($active) { $courses{$domain.'_'.$id}=1; }
}
}
- return keys %courses;
+ return keys(%courses);
}
###############################################
@@ -2182,9 +2681,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;
@@ -2206,10 +2705,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 {
@@ -2228,10 +2725,19 @@ Returns: value of designparamter $which
=cut
-##############################################
+
sub designparm {
my ($which,$domain)=@_;
- if ($ENV{'browser.blackwhite'} eq 'on') {
+ my $result = &designparm_real(@_);
+ &Apache::lonnet::logthis(" $which $domain reulted in $result");
+ return $result;
+}
+
+
+##############################################
+sub designparm_real {
+ my ($which,$domain)=@_;
+ if ($env{'browser.blackwhite'} eq 'on') {
if ($which=~/\.(font|alink|vlink|link)$/) {
return '#000000';
}
@@ -2242,11 +2748,11 @@ sub designparm {
return '#CCCCCC';
}
}
- if ($ENV{'environment.color.'.$which}) {
- return $ENV{'environment.color.'.$which};
+ if (exists($env{'environment.color.'.$which})) {
+ return $env{'environment.color.'.$which};
}
$domain=&determinedomain($domain);
- if ($designhash{$domain.'.'.$which}) {
+ if (exists($designhash{$domain.'.'.$which})) {
return $designhash{$domain.'.'.$which};
} else {
return $designhash{'default.'.$which};
@@ -2285,6 +2791,21 @@ 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
+
+=item * $no_inline_link, if true and in remote mode, don't show the
+ 'Switch To Inline Menu' link
+
+
=back
Returns: A uniform header for LON-CAPA web pages.
@@ -2295,203 +2816,1375 @@ other decorations will be returned.
=cut
sub bodytag {
- my ($title,$function,$addentries,$bodyonly,$domain,$forcereg)=@_;
+ my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle,
+ $notopbar,$bgcolor,$notitle,$no_inline_link)=@_;
+
$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;';
- }
+
+ $function = &get_users_function() if (!$function);
+ my $img = &designparm($function.'.img',$domain);
+ my $font = &designparm($function.'.font',$domain);
+ my $pgbg = $bgcolor || &designparm($function.'.pgbg',$domain);
+
+ my %design = ( 'style' => 'margin-top: 0px',
+ 'bgcolor' => $pgbg,
+ 'text' => $font,
+ 'alink' => &designparm($function.'.alink',$domain),
+ 'vlink' => &designparm($function.'.vlink',$domain),
+ 'link' => &designparm($function.'.link',$domain),);
+ @$addentries{keys(%design)} = @design{keys(%design)};
+
# role and realm
- my ($role,$realm)
- =&Apache::lonnet::plaintext((split(/\./,$ENV{'request.role'}))[0]);
+ my ($role,$realm) = split(/\./,$env{'request.role'},2);
+ if ($role eq 'ca') {
+ my ($rdom,$rname) = ($realm =~ m-^/(\w+)/(\w+)$-);
+ $realm = &plainname($rname,$rdom).':'.$rdom;
+ }
# realm
- if ($ENV{'request.course.id'}) {
- $realm=
- $ENV{'course.'.$ENV{'request.course.id'}.'.description'};
+ if ($env{'request.course.id'}) {
+ if ($env{'request.role'} !~ /^cr/) {
+ $role = &Apache::lonnet::plaintext($role,&course_type());
+ }
+ $realm = $env{'course.'.$env{'request.course.id'}.'.description'};
+ } else {
+ $role = &Apache::lonnet::plaintext($role);
}
- unless ($realm) { $realm=' '; }
+ if (!$realm) { $realm=' '; }
# Set messages
my $messages=&domainlogo($domain);
# Port for miniserver
my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
+
+ my $extra_body_attr = &make_attr_string($forcereg,$addentries);
+
# construct main body tag
- my $bodytag = <<END;
-<style>
-h1, h2, h3, th { font-family: Arial, Helvetica, sans-serif }
-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) {
+ my $bodytag = "<body $extra_body_attr>".
+ &Apache::lontexconvert::init_math_support();
+
+ if ($bodyonly
+ || ($env{'request.state'} eq 'construct'
+ && $env{'environment.remote'} ne 'off' )) {
return $bodytag;
- } elsif ($ENV{'browser.interface'} eq 'textual') {
+ } 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>';
+
+ $bodytag.=&Apache::lonmenu::menubuttons($forcereg,$forcereg);
+ if (!$notitle) {
+ $bodytag.='<h1>LON-CAPA: '.$title.'</h1>';
+ }
+ return $bodytag;
+ }
+
+
+
+ my $roleinfo=(<<ENDROLE);
+<td class="LC_title_bar_who">
+<div class="LC_title_bar_name">
+ $env{'environment.firstname'}
+ $env{'environment.middlename'}
+ $env{'environment.lastname'}
+ $env{'environment.generation'}
+
+</div>
+<div class="LC_title_bar_role">
+$role
+</div>
+<div class="LC_title_bar_realm">
+$realm
+</div>
+</td>
+ENDROLE
+
+ my $titleinfo = '<span class="LC_title_bar_title">'.$title.'</span>';
+ if ($customtitle) {
+ $titleinfo = $customtitle;
+ }
+ #
+ # Extra info if you are the DC
+ my $dc_info = '';
+ if ($env{'user.adv'} && exists($env{'user.role.dc./'.
+ $env{'course.'.$env{'request.course.id'}.
+ '.domain'}.'/'})) {
+ my $cid = $env{'request.course.id'};
+ $dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'};
+ $dc_info =~ s/\s+$//;
+ $dc_info = '('.$dc_info.')';
+ }
+
+ if ($env{'environment.remote'} eq 'off') {
+ # No Remote
+ if ($env{'request.state'} eq 'construct') {
+ $forcereg=1;
+ }
+
+ if (!$customtitle && $env{'request.state'} eq 'construct') {
+ # this is for resources; directories have customtitle, and crumbs
+ # and select recent are created in lonpubdir.pm
+ my ($uname,$thisdisfn)=
+ ($env{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|);
+ my $formaction='/priv/'.$uname.'/'.$thisdisfn;
+ $formaction=~s/\/+/\//g;
+
+ my $parentpath = '';
+ my $lastitem = '';
+ if ($thisdisfn =~ m-(.+/)([^/]*)$-) {
+ $parentpath = $1;
+ $lastitem = $2;
+ } else {
+ $lastitem = $thisdisfn;
+ }
+ $titleinfo =
+ &Apache::loncommon::help_open_menu('','','','',3,'Authoring').
+ '<b>Construction Space</b>: '.
+ '<form name="dirs" method="post" action="'.$formaction
+ .'" target="_top"><tt><b>'
+ .&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv','','+1',1)."<font size=\"+1\">$lastitem</font></b></tt><br />"
+ .&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()')
+ .'</form>'
+ .&Apache::lonmenu::constspaceform();
+ }
+
+ my $titletable;
+ if (!$notitle) {
+ $titletable =
+ '<table id="LC_title_bar">'.
+ "<tr><td> $titleinfo $dc_info</td>".$roleinfo.
+ '</tr></table>';
+ }
+ if ($notopbar) {
+ $bodytag .= $titletable;
+ } else {
+ if ($env{'request.state'} eq 'construct') {
+ $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg,
+ $titletable);
+ } else {
+ $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg).
+ $titletable;
+ }
+ }
+ return $bodytag;
}
#
# Top frame rendering, Remote is up
#
+
+ my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'.
+ $lonhttpdPort.$img.'" alt="'.$function.'" />';
+
+ # Explicit link to get inline menu
+ my $menu= ($no_inline_link?''
+ :'<br /><a href="/adm/remote?action=collapse">'.&mt('Switch to Inline Menu Mode').'</a>');
+ #
+ if ($notitle) {
+ return $bodytag;
+ }
return(<<ENDBODY);
$bodytag
-<table width="100%" cellspacing="0" border="0" cellpadding="0">
-<tr><td bgcolor="$sidebg">
-$upperleft</td>
-<td bgcolor="$sidebg" align="right">$messages </td>
+<table id="LC_title_bar" class="LC_with_remote">
+<tr><td class="LC_title_bar_role_logo">$upperleft</td>
+ <td class="LC_title_bar_domain_logo">$messages </td>
</tr>
-<tr>
-<td 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><td>$titleinfo $dc_info $menu</td>
+$roleinfo
</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>
+</table>
ENDBODY
}
+sub make_attr_string {
+ my ($register,$attr_ref) = @_;
+
+ if ($attr_ref && !ref($attr_ref)) {
+ die("addentries Must be a hash ref ".
+ join(':',caller(1))." ".
+ join(':',caller(0))." ");
+ }
+
+ if ($register) {
+ my ($on_load,$on_unload);
+ foreach my $key (keys(%{$attr_ref})) {
+ if (lc($key) eq 'onload') {
+ $on_load.=$attr_ref->{$key}.';';
+ delete($attr_ref->{$key});
+
+ } elsif (lc($key) eq 'onunload') {
+ $on_unload.=$attr_ref->{$key}.';';
+ delete($attr_ref->{$key});
+ }
+ }
+ $attr_ref->{'onload'} =
+ &Apache::lonmenu::loadevents(). $on_load;
+ $attr_ref->{'onunload'}=
+ &Apache::lonmenu::unloadevents().$on_unload;
+ }
+
+# Accessibility font enhance
+ if ($env{'browser.fontenhance'} eq 'on') {
+ my $style;
+ foreach my $key (keys(%{$attr_ref})) {
+ if (lc($key) eq 'style') {
+ $style.=$attr_ref->{$key}.';';
+ delete($attr_ref->{$key});
+ }
+ }
+ $attr_ref->{'style'}=$style.'; font-size: x-large;';
+ }
+
+ if ($env{'browser.blackwhite'} eq 'on') {
+ delete($attr_ref->{'font'});
+ delete($attr_ref->{'link'});
+ delete($attr_ref->{'alink'});
+ delete($attr_ref->{'vlink'});
+ delete($attr_ref->{'bgcolor'});
+ delete($attr_ref->{'background'});
+ }
+
+ my $attr_string;
+ foreach my $attr (keys(%$attr_ref)) {
+ $attr_string .= " $attr=\"".$attr_ref->{$attr}.'" ';
+ }
+ return $attr_string;
+}
+
+
+###############################################
###############################################
-sub get_posted_cgi {
- my $r=shift;
+=pod
+
+=back
+
+=head1 HTML Helpers
+
+=over 4
+
+=item * &endbodytag()
+
+Returns a uniform footer for LON-CAPA web pages.
+
+Inputs: none
+
+=back
+
+=cut
+
+sub endbodytag {
+ my $endbodytag='</body>';
+ $endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag;
+ if ( exists( $env{'internal.head.redirect'} ) ) {
+ $endbodytag=
+ "<br /><a href=\"$env{'internal.head.redirect'}\">".
+ &mt('Continue').'</a>'.
+ $endbodytag;
+ }
+ return $endbodytag;
+}
+
+=pod
+
+=over 4
+
+=item * &standard_css()
+
+Returns a style sheet
+
+Inputs: (all optional)
+ domain -> force to color decorate a page for a specific
+ domain
+ function -> force usage of a specific rolish color scheme
+ bgcolor -> override the default page bgcolor
+
+=back
+
+=cut
+
+sub standard_css {
+ my ($function,$domain,$bgcolor) = @_;
+ $function = &get_users_function() if (!$function);
+ my $img = &designparm($function.'.img', $domain);
+ my $tabbg = &designparm($function.'.tabbg', $domain);
+ my $font = &designparm($function.'.font', $domain);
+ my $sidebg = &designparm($function.'.sidebg',$domain);
+ my $pgbg_or_bgcolor =
+ $bgcolor ||
+ &designparm($function.'.pgbg', $domain);
+ my $pgbg = &designparm($function.'.pgbg', $domain);
+ my $alink = &designparm($function.'.alink', $domain);
+ my $vlink = &designparm($function.'.vlink', $domain);
+ my $link = &designparm($function.'.link', $domain);
+
+ my $sans = 'Arial,Helvetica,sans-serif';
+ my $mono = 'monospace';
+ my $data_table_head = $tabbg;
+ my $data_table_light = '#EEEEEE';
+ my $data_table_dark = '#DDD';
+ my $data_table_highlight = '#FFFF00';
+ my $mail_new = '#FFBB77';
+ my $mail_new_hover = '#DD9955';
+ my $mail_read = '#BBBB77';
+ my $mail_read_hover = '#999944';
+ my $mail_replied = '#AAAA88';
+ my $mail_replied_hover = '#888855';
+ my $mail_other = '#99BBBB';
+ my $mail_other_hover = '#669999';
+ my $table_header = '#DDDDDD';
+
+ my $border = ($env{'browser.type'} eq 'explorer') ? '0px 2px 0px 2px'
+ : '0px 3px 0px 4px';
+ return <<END;
+h1, h2, h3, th { font-family: $sans }
+a:focus { color: red; background: yellow }
+table.thinborder { border-collapse: collapse; }
+table.thinborder tr th, table.thinborder tr td { border-style: solid; border-width: 1px}
+form, .inline { display: inline; }
+.center { text-align: center; }
+.LC_filename {font-family: $mono;}
+.LC_error {
+ color: red;
+ font-size: larger;
+}
+.LC_warning {
+ color: red;
+}
+.LC_success {
+ color: green;
+}
+
+table#LC_top_nav, table#LC_menubuttons {
+ width: 100%;
+ background: $pgbg;
+ border: 2px;
+ border-collapse: seperate;
+}
+
+table#LC_title_bar, table#LC_breadcrumbs, table#LC_nav_location,
+table#LC_title_bar.LC_with_remote {
+ width: 100%;
+ border-color: $pgbg;
+ border-style: solid;
+ border-width: $border;
+
+ background: $pgbg;
+ font-family: $sans;
+ border-collapse: collapse;
+}
+
+table#LC_title_bar td {
+ padding: 3px;
+ background: $tabbg;
+}
+table#LC_title_bar td.LC_title_bar_who {
+ background: $tabbg;
+ color: $font;
+ font: medium $sans;
+ text-align: right;
+}
+span.LC_title_bar_title {
+ font: bold xx-large $sans;
+}
+table#LC_title_bar td.LC_title_bar_domain_logo {
+ background: $sidebg;
+ text-align: right;
+ padding: 0px;
+}
+table#LC_title_bar td.LC_title_bar_role_logo {
+ background: $sidebg;
+ padding: 0px;
+}
+
+table#LC_menubuttons_mainmenu {
+ background: $pgbg;
+ border: 0px;
+ border-spacing: 1px;
+ padding: 0px 1px;
+ margin: 0px;
+ border-collapse: separate;
+}
+table#LC_menubuttons img, table#LC_menubuttons_mainmenu img {
+ border: 0px;
+}
+table#LC_top_nav td {
+ background: $tabbg;
+ border: 0px;
+}
+table#LC_top_nav td a, div#LC_top_nav a {
+ color: $font;
+ font-family: $sans;
+}
+table#LC_top_nav td.LC_top_nav_logo {
+ background: $tabbg;
+ text-align: right;
+}
+table#LC_breadcrumbs td {
+ background: $tabbg;
+ color: $font;
+ font-family: $sans;
+ font-size: smaller;
+}
+table#LC_breadcrumbs td.LC_breadcrumb_component {
+ background: $tabbg;
+ color: $font;
+ font-family: $sans;
+ font-size: larger;
+ text-align: right;
+}
+td.LC_table_cell_checkbox {
+ text-align: center;
+}
+
+.LC_menubuttons_inline_text {
+ color: $font;
+ font-family: $sans;
+ font-size: smaller;
+}
+
+td.LC_menubuttons_text {
+ color: $font;
+ font-family: $sans;
+}
+td.LC_menubuttons_img {
+ background: $tabbg;
+}
+.LC_current_location {
+ font-family: $sans;
+ background: $tabbg;
+}
+.LC_new_mail {
+ font-family: $sans;
+ font-weight: bold;
+}
+
+table.LC_data_table, table.LC_mail_list {
+ border: 1px solid #000000;
+ border-collapse: seperate;
+}
+table.LC_data_table tr th, table.LC_calendar tr th, table.LC_mail_list tr th {
+ font-weight: bold;
+ background-color: $data_table_head;
+}
+table.LC_data_table tr td {
+ background-color: $data_table_light;
+}
+table.LC_data_table tr.LC_even_row td {
+ background-color: $data_table_dark;
+}
+table.LC_data_table tr.LC_empty td {
+ background-color: #FFFFFF;
+}
+
+table.LC_calendar {
+ border: 1px solid #000000;
+ border-collapse: collapse;
+}
+table.LC_calendar_pickdate {
+ font-size: xx-small;
+}
+table.LC_calendar tr td {
+ border: 1px solid #000000;
+ vertical-align: top;
+}
+table.LC_calendar tr td.LC_calendar_day_empty {
+ background-color: $data_table_dark;
+}
+table.LC_calendar tr td.LC_calendar_day_current {
+ background-color: $data_table_highlight;
+}
+
+table.LC_mail_list tr.LC_mail_new {
+ background-color: $mail_new;
+}
+table.LC_mail_list tr.LC_mail_new:hover {
+ background-color: $mail_new_hover;
+}
+table.LC_mail_list tr.LC_mail_read {
+ background-color: $mail_read;
+}
+table.LC_mail_list tr.LC_mail_read:hover {
+ background-color: $mail_read_hover;
+}
+table.LC_mail_list tr.LC_mail_replied {
+ background-color: $mail_replied;
+}
+table.LC_mail_list tr.LC_mail_replied:hover {
+ background-color: $mail_replied_hover;
+}
+table.LC_mail_list tr.LC_mail_other {
+ background-color: $mail_other;
+}
+table.LC_mail_list tr.LC_mail_other:hover {
+ background-color: $mail_other_hover;
+}
+
+table#LC_portfolio_actions {
+ width: auto;
+ background: $pgbg;
+ border: 0px;
+ border-spacing: 2px 2px;
+ padding: 0px;
+ margin: 0px;
+ border-collapse: separate;
+}
+table#LC_portfolio_actions td.LC_label {
+ background: $tabbg;
+ text-align: right;
+}
+table#LC_portfolio_actions td.LC_value {
+ background: $tabbg;
+}
+
+table#LC_cstr_controls {
+ width: 100%;
+ border-collapse: collapse;
+}
+table#LC_cstr_controls tr td {
+ border: 4px solid $pgbg;
+ padding: 4px;
+ text-align: center;
+ background: $tabbg;
+}
+table#LC_cstr_controls tr th {
+ border: 4px solid $pgbg;
+ background: $table_header;
+ text-align: center;
+ font-family: $sans;
+ font-size: smaller;
+}
+
+table#LC_browser {
+
+}
+table#LC_browser tr th {
+ background: $table_header;
+}
+table#LC_browser tr td {
+ padding: 2px;
+}
+table#LC_browser tr.LC_browser_file,
+table#LC_browser tr.LC_browser_file_published {
+ background: #CCFF88;
+}
+table#LC_browser tr.LC_browser_file_locked,
+table#LC_browser tr.LC_browser_file_unpublished {
+ background: #FFAA99;
+}
+table#LC_browser tr.LC_browser_file_obsolete {
+ background: #AAAAAA;
+}
+table#LC_browser tr.LC_browser_file_modified {
+ background: #FFFF77;
+}
+table#LC_browser tr.LC_browser_folder {
+ background: #CCCCFF;
+}
+span.LC_current_location {
+ font-size: x-large;
+ background: $pgbg;
+}
+
+span.LC_parm_menu_item {
+ font-size: larger;
+ font-family: $sans;
+}
+span.LC_parm_scope_all {
+ color: red;
+}
+span.LC_parm_scope_folder {
+ color: green;
+}
+span.LC_parm_scope_resource {
+ color: orange;
+}
+span.LC_parm_part {
+ color: blue;
+}
+span.LC_parm_folder, span.LC_parm_symb {
+ font-size: x-small;
+ font-family: $mono;
+ color: #AAAAAA;
+}
+
+td.LC_parm_overview_level_menu, td.LC_parm_overview_map_menu,
+td.LC_parm_overview_parm_selectors, td.LC_parm_overview_parm_restrictions {
+ border: 1px solid black;
+ border-collapse: collapse;
+}
+table.LC_parm_overview_restrictions td {
+ border-width: 1px 4px 1px 4px;
+ border-style: solid;
+ border-color: $pgbg;
+ text-align: center;
+}
+table.LC_parm_overview_restrictions th {
+ background: $tabbg;
+ border-width: 1px 4px 1px 4px;
+ border-style: solid;
+ border-color: $pgbg;
+}
+table#LC_helpmenu {
+ border: 0px;
+ height: 55px;
+ border-spacing: 0px;
+}
+
+table#LC_helpmenu fieldset legend {
+ font-size: larger;
+ font-weight: bold;
+}
+table#LC_helpmenu_links {
+ width: 100%;
+ border: 1px solid black;
+ background: $pgbg;
+ padding: 0px;
+ border-spacing: 1px;
+}
+table#LC_helpmenu_links tr td {
+ padding: 1px;
+ background: $tabbg;
+}
+
+table#LC_helpmenu_links a:link, table#LC_helpmenu_links a:visited,
+table#LC_helpmenu_links a:active {
+ text-decoration: none;
+ color: $font;
+}
+table#LC_helpmenu_links a:hover {
+ text-decoration: underline;
+ color: $vlink;
+}
- my $buffer;
+END
+}
+
+=pod
+
+=over 4
+
+=item * &headtag()
+
+Returns a uniform footer for LON-CAPA web pages.
+
+Inputs: $title - optional title for the head
+ $head_extra - optional extra HTML to put inside the <head>
+ $args - optional arguments
+ force_register - if is true call registerurl so the remote is
+ informed
+ redirect -> array ref of seconds before redirect occurs
+ url to redirect to
+ (side effect of setting
+ $env{'internal.head.redirect'} to the url
+ redirected too)
+ domain -> force to color decorate a page for a specific
+ domain
+ function -> force usage of a specific rolish color scheme
+ bgcolor -> override the default page bgcolor
+
+=back
+
+=cut
+
+sub headtag {
+ my ($title,$head_extra,$args) = @_;
- $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);
+ my $function = $args->{'function'} || &get_users_function();
+ my $domain = $args->{'domain'} || &determinedomain();
+ my $bgcolor = $args->{'bgcolor'} || &designparm($function.'.pgbg',$domain);
+ my $url = join(':',$env{'user.name'},$env{'user.domain'},time(),
+ #$env{'environment.color.timestamp'},
+ $function,$domain,$bgcolor);
+
+ $url = '/adm/css/'.&escape($url).'.css';
+
+ my $result =
+ '<head>'.
+ '<link rel="stylesheet" type="text/css" href="'.$url.'" />'.
+ &font_settings().
+ &Apache::lonhtmlcommon::htmlareaheaders();
+
+ if ($args->{'force_register'}) {
+ $result .= &Apache::lonmenu::registerurl(1);
+ }
+
+ if (ref($args->{'redirect'})) {
+ my ($time,$url) = @{$args->{'redirect'}};
+ $url = &Apache::lonenc::check_encrypt($url);
+ $env{'internal.head.redirect'} = $url;
+ $result.=<<ADDMETA
+<meta http-equiv="pragma" content="no-cache" />
+<meta http-equiv="Refresh" content="$time; url=$url" />
+ADDMETA
+ }
+ if (!defined($title)) {
+ $title = 'The LearningOnline Network with CAPA';
+ }
+
+ $result .= '<title> LON-CAPA '.&mt($title).'</title>'.$head_extra;
+ return $result;
+}
+
+=pod
+
+=over 4
+
+=item * &font_settings()
+
+Returns neccessary <meta> to set the proper encoding
+
+Inputs: none
+
+=back
+
+=cut
+
+sub font_settings {
+ my $headerstring='';
+ if (($env{'browser.os'} eq 'mac') && (!$env{'browser.mathml'})) {
+ $headerstring.=
+ '<meta Content-Type="text/html; charset=x-mac-roman" />';
+ } elsif (!$env{'browser.mathml'} && $env{'browser.unicode'}) {
+ $headerstring.=
+ '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />';
+ }
+ return $headerstring;
+}
+
+=pod
+
+=over 4
+
+=item * &xml_begin()
+
+Returns the needed doctype and <html>
+
+Inputs: none
+
+=back
+
+=cut
+
+sub xml_begin {
+ my $output='';
+
+ &Apache::lonhtmlcommon::init_htmlareafields();
+
+ if ($env{'browser.mathml'}) {
+ $output='<?xml version="1.0"?>'
+ #.'<?xml-stylesheet type="text/css" href="/adm/MathML/mathml.css"?>'."\n"
+# .'<!DOCTYPE html SYSTEM "/adm/MathML/mathml.dtd" '
+
+# .'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd" [<!ENTITY mathns "http://www.w3.org/1998/Math/MathML">] >'
+ .'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1 plus MathML 2.0 plus SVG 1.1//EN" "http://www.w3.org/2002/04/xhtml-math-svg/xhtml-math-svg.dtd">'
+ .'<html xmlns:math="http://www.w3.org/1998/Math/MathML" '
+ .'xmlns="http://www.w3.org/1999/xhtml">';
+ } else {
+ $output='<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"><html>';
+ }
+ return $output;
+}
+
+=pod
+
+=over 4
+
+=item * &endheadtag()
+
+Returns a uniform </head> for LON-CAPA web pages.
+
+Inputs: none
+
+=back
+
+=cut
+
+sub endheadtag {
+ return '</head>';
+}
+
+=pod
+
+=over 4
+
+=item * &head()
+
+Returns a uniform complete <head>..</head> section for LON-CAPA web pages.
+
+Inputs: $title - optional title for the page
+ $head_extra - optional extra HTML to put inside the <head>
+=back
+
+=cut
+
+sub head {
+ my ($title,$head_extra,$args) = @_;
+ return &headtag($title,$head_extra,$args).&endheadtag();
+}
+
+=pod
+
+=over 4
+
+=item * &start_page()
+
+Returns a complete <html> .. <body> section for LON-CAPA web pages.
+
+Inputs: $title - optional title for the page
+ $head_extra - optional extra HTML to incude inside the <head>
+ $args - additional optional args supported are:
+ only_body -> is true will set &bodytag() onlybodytag
+ arg on
+ no_nav_bar -> is true will set &bodytag() notopbar arg on
+ add_entries -> additional attributes to add to the <body>
+ domain -> force to color decorate a page for a
+ specific domain
+ function -> force usage of a specific rolish color
+ scheme
+ redirect -> see &headtag()
+ bgcolor -> override the default page bg color
+ js_ready -> return a string ready for being used in
+ a javascript writeln
+ html_encode -> return a string ready for being used in
+ a html attribute
+ force_register -> if is true will turn on the &bodytag()
+ $forcereg arg
+ body_title -> alternate text to use instead of $title
+ in the title box that appears, this text
+ is not auto translated like the $title is
+ frameset -> if true will start with a <frameset>
+ rather than <body>
+ no_title -> if true the title bar won't be shown
+ skip_phases -> hash ref of
+ head -> skip the <html><head> generation
+ body -> skip all <body> generation
+
+ no_inline_link -> if true and in remote mode, don't show the
+ 'Switch To Inline Menu' link
+
+=back
+
+=cut
+
+sub start_page {
+ my ($title,$head_extra,$args) = @_;
+ #&Apache::lonnet::logthis("start_page ".join(':',caller(0)));
+ my %head_args;
+ foreach my $arg ('redirect','force_register','domain','function',
+ 'bgcolor') {
+ if (defined($args->{$arg})) {
+ $head_args{$arg} = $args->{$arg};
+ }
+ }
+
+ $env{'internal.start_page'}++;
+ my $result;
+ if (! exists($args->{'skip_phases'}{'head'}) ) {
+ $result.=
+ &xml_begin().
+ &headtag($title,$head_extra,\%head_args).&endheadtag();
+ }
+
+ if (! exists($args->{'skip_phases'}{'body'}) ) {
+ if ($args->{'frameset'}) {
+ my $attr_string = &make_attr_string($args->{'force_register'},
+ $args->{'add_entries'});
+ $result .= "\n<frameset $attr_string>\n";
+ } else {
+ $result .=
+ &bodytag($title,
+ $args->{'function'}, $args->{'add_entries'},
+ $args->{'only_body'}, $args->{'domain'},
+ $args->{'force_register'}, $args->{'body_title'},
+ $args->{'no_nav_bar'}, $args->{'bgcolor'},
+ $args->{'no_title'}, $args->{'no_inline_link'});
+ }
+ }
+
+ if ($args->{'js_ready'}) {
+ $result = &js_ready($result);
+ }
+ if ($args->{'html_encode'}) {
+ $result = &html_encode($result);
+ }
+ return $result;
+}
+
+
+=pod
+
+=over 4
+
+=item * &head()
+
+Returns a complete </body></html> section for LON-CAPA web pages.
+
+Inputs: $args - additional optional args supported are:
+ js_ready -> return a string ready for being used in
+ a javascript writeln
+ html_encode -> return a string ready for being used in
+ a html attribute
+ frameset -> if true will start with a <frameset>
+ rather than <body>
+=back
+
+=cut
+
+sub end_page {
+ my ($args) = @_;
+ $env{'internal.end_page'}++;
+ my $result;
+ if ($args->{'discussion'}) {
+ my ($target,$parser);
+ if (ref($args->{'discussion'})) {
+ ($target,$parser) =($args->{'discussion'}{'target'},
+ $args->{'discussion'}{'parser'});
+ }
+ $result .= &Apache::lonxml::xmlend($target,$parser);
+ }
+
+ if ($args->{'frameset'}) {
+ $result .= '</frameset>';
+ } else {
+ $result .= &endbodytag();
+ }
+ $result .= "\n</html>";
+
+ if ($args->{'js_ready'}) {
+ $result = &js_ready($result);
+ }
+
+ if ($args->{'html_encode'}) {
+ $result = &html_encode($result);
+ }
+
+ return $result;
+}
+
+sub html_encode {
+ my ($result) = @_;
+
+ $result = &HTML::Entities::encode($result,'<>&"');
+
+ return $result;
+}
+sub js_ready {
+ my ($result) = @_;
+
+ $result =~ s/[\n\r]/ /xmsg;
+ $result =~ s/\\/\\\\/xmsg;
+ $result =~ s/'/\\'/xmsg;
+ $result =~ s{</}{<\\/}xmsg;
+
+ return $result;
+}
+
+sub validate_page {
+ if ( exists($env{'internal.start_page'})
+ && $env{'internal.start_page'} > 1) {
+ &Apache::lonnet::logthis('start_page called multiple times '.
+ $env{'internal.start_page'}.' '.
+ $ENV{'request.filename'});
+ }
+ if ( exists($env{'internal.end_page'})
+ && $env{'internal.end_page'} > 1) {
+ &Apache::lonnet::logthis('end_page called multiple times '.
+ $env{'internal.end_page'}.' '.
+ $env{'request.filename'});
+ }
+ if ( exists($env{'internal.start_page'})
+ && ! exists($env{'internal.end_page'})) {
+ &Apache::lonnet::logthis('start_page called without end_page '.
+ $env{'request.filename'});
+ }
+ if ( ! exists($env{'internal.start_page'})
+ && exists($env{'internal.end_page'})) {
+ &Apache::lonnet::logthis('end_page called without start_page'.
+ $env{'request.filename'});
+ }
+}
+
+sub simple_error_page {
+ my ($r,$title,$msg) = @_;
+ my $page =
+ &Apache::loncommon::start_page($title).
+ &mt($msg).
+ &Apache::loncommon::end_page();
+ if (ref($r)) {
+ $r->print($page);
+ return;
+ }
+ return $page;
+}
+
+{
+ my $row_count;
+ sub start_data_table {
+ undef($row_count);
+ return '<table class="LC_data_table">'."\n";
+ }
+
+ sub end_data_table {
+ undef($row_count);
+ return '</table>'."\n";;
+ }
+
+ sub start_data_table_row {
+ $row_count++;
+ return '<tr '.(($row_count % 2)?'':'class="LC_even_row"').'>'."\n";;
+ }
+
+ sub end_data_table_row {
+ return '</tr>'."\n";;
+ }
+
+ sub start_data_table_header_row {
+ return '<tr class="LC_header_row">'."\n";;
+ }
+
+ sub end_data_table_header_row {
+ return '</tr>'."\n";;
+ }
+}
+
+###############################################
+
+=pod
+
+=over 4
+
+=item get_users_function
+
+Used by &bodytag to determine the current users primary role.
+Returns either 'student','coordinator','admin', or 'author'.
+
+=cut
+
+###############################################
+sub get_users_function {
+ my $function = 'student';
+ if ($env{'request.role'}=~/^(cc|in|ta|ep)/) {
+ $function='coordinator';
+ }
+ if ($env{'request.role'}=~/^(su|dc|ad|li)/) {
+ $function='admin';
+ }
+ if (($env{'request.role'}=~/^(au|ca)/) ||
+ ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
+ $function='author';
+ }
+ return $function;
+}
+
+###############################################
+
+=pod
+
+=item check_user_status
+
+Determines current status of supplied role for a
+specific user. Roles can be active, previous or future.
+
+Inputs:
+user's domain, user's username, course's domain,
+course's number, optional section ID.
+
+Outputs:
+role status: active, previous or future.
+
+=cut
+
+sub check_user_status {
+ my ($udom,$uname,$cdom,$crs,$role,$secgrp) = @_;
+ my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname);
+ my @uroles = keys %userinfo;
+ my $srchstr;
+ my $active_chk = 'none';
+ if (@uroles > 0) {
+ if (($role eq 'cc') || ($secgrp eq '') || (!defined($secgrp))) {
+ $srchstr = '/'.$cdom.'/'.$crs.'_'.$role;
+ } else {
+ $srchstr = '/'.$cdom.'/'.$crs.'/'.$secgrp.'_'.$role; }
+ if (grep/^$srchstr$/,@uroles) {
+ my $role_end = 0;
+ my $role_start = 0;
+ $active_chk = 'active';
+ if ($userinfo{$srchstr} =~ m/^($role)_(\d+)/) {
+ $role_end = $2;
+ if ($userinfo{$srchstr} =~ m/^($role)_($role_end)_(\d+)$/) {
+ $role_start = $3;
+ }
+ }
+ if ($role_start > 0) {
+ if (time < $role_start) {
+ $active_chk = 'future';
+ }
+ }
+ if ($role_end > 0) {
+ if (time > $role_end) {
+ $active_chk = 'previous';
+ }
+ }
+ }
+ }
+ return $active_chk;
+}
+
+###############################################
+
+=pod
+
+=item get_sections
+
+Determines all the sections for a course including
+sections with students and sections containing other roles.
+Incoming parameters: domain, course number,
+reference to array containing roles for which sections should
+be gathered (optional). If the third argument is undefined,
+sections are gathered for any role.
+
+Returns section hash (keys are section IDs, values are
+number of users in each section), subject to the
+optional roles filter.
+
+=cut
+
+###############################################
+sub get_sections {
+ my ($cdom,$cnum,$possible_roles) = @_;
+ if (!defined($cdom) || !defined($cnum)) {
+ my $cid = $env{'request.course.id'};
+
+ return if (!defined($cid));
+
+ $cdom = $env{'course.'.$cid.'.domain'};
+ $cnum = $env{'course.'.$cid.'.num'};
+ }
+
+ my %sectioncount;
+
+ if (!defined($possible_roles) || (grep(/^st$/,@$possible_roles))) {
+ my ($classlist) = &Apache::loncoursedata::get_classlist($cdom,$cnum);
+ my $sec_index = &Apache::loncoursedata::CL_SECTION();
+ my $status_index = &Apache::loncoursedata::CL_STATUS();
+ while (my ($student,$data) = each(%$classlist)) {
+ my ($section,$status) = ($data->[$sec_index],
+ $data->[$status_index]);
+ unless ($section eq '-1' || $section =~ /^\s*$/) {
+ $sectioncount{$section}++;
+ }
+ }
+ }
+ my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
+ foreach my $user (sort(keys(%courseroles))) {
+ if ($user !~ /^(\w{2})/) { next; }
+ my ($role) = ($user =~ /^(\w{2})/);
+ if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; }
+ my $section;
+ if ($role eq 'cr' &&
+ $user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) {
+ $section=$1;
+ }
+ if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { $section=$1; }
+ if (!defined($section) || $section eq '-1') { next; }
+ $sectioncount{$section}++;
+ }
+ return %sectioncount;
+}
+
+###############################################
+
+=pod
+
+=item get_course_users
+
+Retrieves usernames:domains for users in the specified course
+with specific role(s), and access status.
+
+Incoming parameters:
+1. course domain
+2. course number
+3. access status: users must have - either active,
+previous, future, or all.
+4. reference to array of permissible roles
+5. reference to array of section restrictions (optional)
+6. reference to results object (hash of hashes).
+7. reference to optional userdata hash
+Keys of top level hash are roles.
+Keys of inner hashes are username:domain, with
+values set to access type.
+Optional userdata hash returns an array with arguments in the
+same order as loncoursedata::get_classlist() for student data.
+
+Entries for end, start, section and status are blank because
+of the possibility of multiple values for non-student roles.
+
+=cut
+
+###############################################
+
+sub get_course_users {
+ my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata) = @_;
+ my %idx = ();
+
+ $idx{udom} = &Apache::loncoursedata::CL_SDOM();
+ $idx{uname} = &Apache::loncoursedata::CL_SNAME();
+ $idx{end} = &Apache::loncoursedata::CL_END();
+ $idx{start} = &Apache::loncoursedata::CL_START();
+ $idx{id} = &Apache::loncoursedata::CL_ID();
+ $idx{section} = &Apache::loncoursedata::CL_SECTION();
+ $idx{fullname} = &Apache::loncoursedata::CL_FULLNAME();
+ $idx{status} = &Apache::loncoursedata::CL_STATUS();
+
+ if (grep(/^st$/,@{$roles})) {
+ my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum);
+ my $now = time;
+ foreach my $student (keys(%{$classlist})) {
+ my $match = 0;
+ if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
+ unless(grep(/^\Q$$classlist{$student}[$idx{section}]\E$/,
+ @{$sections})) {
+ next;
}
- if ($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='';
+ }
+ if (defined($$types{'active'})) {
+ if ($$classlist{$student}[$idx{status}] eq 'Active') {
+ push(@{$$users{st}{$student}},'active');
+ $match = 1;
+ }
+ }
+ if (defined($$types{'previous'})) {
+ if ($$classlist{$student}[$idx{end}] <= $now) {
+ push(@{$$users{st}{$student}},'previous');
+ $match = 1;
+ }
+ }
+ if (defined($$types{'future'})) {
+ if (($$classlist{$student}[$idx{start}] > $now) && ($$classlist{$student}[$idx{end}] > $now) || ($$classlist{$student}[$idx{end}] == 0) || ($$classlist{$student}[$idx{end}] eq '')) {
+ push(@{$$users{st}{$student}},'future');
+ $match = 1;
+ }
+ }
+ if ($match && defined($userdata)) {
+ $$userdata{$student} = $$classlist{$student};
+ }
+ }
+ }
+ if ((@{$roles} > 0) && (@{$roles} ne "st")) {
+ my @coursepersonnel = &Apache::lonnet::getkeys('nohist_userroles',$cdom,$cnum);
+ foreach my $person (@coursepersonnel) {
+ my $match = 0;
+ my ($role,$user) = ($person =~ /^([^:]*):([^:]+:[^:]+)/);
+ $user =~ s/:$//;
+ if (($role) && (grep(/^\Q$role\E$/,@{$roles}))) {
+ my ($uname,$udom,$usec) = split(/:/,$user);
+ if ($usec ne '' && (ref($sections) eq 'ARRAY') &&
+ @{$sections} > 0) {
+ unless(grep(/^\Q$usec\E$/,@{$sections})) {
+ next;
}
- $i++;
- }
- } else {
- $value.=$lines[$i]."\n";
- }
+ }
+ if ($uname ne '' && $udom ne '') {
+ my $status = &check_user_status($udom,$uname,$cdom,$cnum,$role);
+ foreach my $type (keys(%{$types})) {
+ if ($status eq $type) {
+ @{$$users{$role}{$user}} = $type;
+ $match = 1;
+ }
+ }
+ if ($match && defined($userdata) &&
+ !exists($$userdata{$uname.':'.$udom})) {
+ &get_user_info($udom,$uname,\%idx,$userdata);
+ }
+ }
+ }
+ }
+ if (grep(/^ow$/,@{$roles})) {
+ if ((defined($cdom)) && (defined($cnum))) {
+ my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum);
+ if ( defined($csettings{'internal.courseowner'}) ) {
+ my $owner = $csettings{'internal.courseowner'};
+ @{$$users{'ow'}{$owner.':'.$cdom}} = 'any';
+ if (defined($userdata) &&
+ !exists($$userdata{$owner.':'.$cdom})) {
+ &get_user_info($cdom,$owner,\%idx,$userdata);
+ }
+ }
+ }
+ }
+ }
+ return;
+}
+
+sub get_user_info {
+ my ($udom,$uname,$idx,$userdata) = @_;
+ $$userdata{$uname.':'.$udom}[$$idx{fullname}] =
+ &plainname($uname,$udom,'lastname');
+ $$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname;
+ $$userdata{$uname.':'.$udom}[$$idx{udom}] = $udom;
+ return;
+}
+
+sub get_secgrprole_info {
+ my ($cdom,$cnum,$needroles,$type) = @_;
+ my %sections_count = &get_sections($cdom,$cnum);
+ my @sections = (sort {$a <=> $b} keys(%sections_count));
+ my %curr_groups = &Apache::longroup::coursegroups($cdom,$cnum);
+ my @groups = sort(keys(%curr_groups));
+ my $allroles = [];
+ my $rolehash;
+ my $accesshash = {
+ active => 'Currently has access',
+ future => 'Will have future access',
+ previous => 'Previously had access',
+ };
+ if ($needroles) {
+ $rolehash = {'all' => 'all'};
+ my %user_roles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
+ if (&Apache::lonnet::error(%user_roles)) {
+ undef(%user_roles);
}
+ foreach my $item (keys(%user_roles)) {
+ my ($role)=split(/\:/,$item,2);
+ if ($role eq 'cr') { next; }
+ if ($role =~ /^cr/) {
+ $$rolehash{$role} = (split('/',$role))[3];
+ } else {
+ $$rolehash{$role} = &Apache::lonnet::plaintext($role,$type);
+ }
+ }
+ foreach my $key (sort(keys(%{$rolehash}))) {
+ push(@{$allroles},$key);
+ }
+ push (@{$allroles},'st');
+ $$rolehash{'st'} = &Apache::lonnet::plaintext('st',$type);
}
- $ENV{'request.method'}=$ENV{'REQUEST_METHOD'};
- $r->method_number(M_GET);
- $r->method('GET');
- $r->headers_in->unset('Content-length');
+ return (\@sections,\@groups,$allroles,$rolehash,$accesshash);
}
=pod
=item * get_unprocessed_cgi($query,$possible_names)
-Modify the %ENV hash to contain unprocessed CGI form parameters held in
+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.
+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.
+will result in $env{'form.uname'} and $env{'form.udom'} being set.
=cut
sub get_unprocessed_cgi {
my ($query,$possible_names)= @_;
# $Apache::lonxml::debug=1;
- foreach (split(/&/,$query)) {
- my ($name, $value) = split(/=/,$_);
- $name = &Apache::lonnet::unescape($name);
+ foreach my $pair (split(/&/,$query)) {
+ my ($name, $value) = split(/=/,$pair);
+ $name = &unescape($name);
if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
- &Apache::lonxml::debug("Seting :$name: to :$value:");
- unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
+ unless (defined($env{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
}
}
}
@@ -2505,12 +4198,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
@@ -2522,27 +4215,38 @@ 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) = @_;
+ if ($r) {
+ # Note that printout.pl calls this with undef for $r.
+ &no_cache($r);
+ }
+ if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; }
+ unless ($charset) {
+ $charset=&Apache::lonlocal::current_encoding;
+ }
+ if ($charset) { $type.='; charset='.$charset; }
+ if ($r) {
+ $r->content_type($type);
+ } else {
+ print("Content-type: $type\n\n");
+ }
}
=pod
=item * add_to_env($name,$value)
-adds $name to the %ENV hash with value
+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.
@@ -2550,18 +4254,18 @@ reference and $value is added to the arr
sub add_to_env {
my ($name,$value)=@_;
- if (defined($ENV{$name})) {
- if (ref($ENV{$name})) {
+ if (defined($env{$name})) {
+ if (ref($env{$name})) {
#already have multiple values
- push(@{ $ENV{$name} },$value);
+ push(@{ $env{$name} },$value);
} else {
#first time seeing multiple values, convert hash entry to an arrayref
- my $first=$ENV{$name};
- undef($ENV{$name});
- push(@{ $ENV{$name} },$first,$value);
+ my $first=$env{$name};
+ undef($env{$name});
+ push(@{ $env{$name} },$first,$value);
}
} else {
- $ENV{$name}=$value;
+ $env{$name}=$value;
}
}
@@ -2569,7 +4273,7 @@ sub add_to_env {
=item * get_env_multiple($name)
-gets $name from the %ENV hash, it seemlessly handles the cases where multiple
+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
@@ -2579,12 +4283,12 @@ returns an array of values
sub get_env_multiple {
my ($name) = @_;
my @values;
- if (defined($ENV{$name})) {
+ if (defined($env{$name})) {
# exists is it an array
- if (ref($ENV{$name})) {
- @values=@{ $ENV{$name} };
+ if (ref($env{$name})) {
+ @values=@{ $env{$name} };
} else {
- $values[0]=$ENV{$name};
+ $values[0]=$env{$name};
}
}
return(@values);
@@ -2602,25 +4306,25 @@ sub get_env_multiple {
=item * upfile_store($r)
Store uploaded file, $r should be the HTTP Request object,
-needs $ENV{'form.upfile'}
+needs $env{'form.upfile'}
returns $datatoken to be put into hidden field
=cut
sub upfile_store {
my $r=shift;
- $ENV{'form.upfile'}=~s/\r/\n/gs;
- $ENV{'form.upfile'}=~s/\f/\n/gs;
- $ENV{'form.upfile'}=~s/\n+/\n/gs;
- $ENV{'form.upfile'}=~s/\n+$//gs;
+ $env{'form.upfile'}=~s/\r/\n/gs;
+ $env{'form.upfile'}=~s/\f/\n/gs;
+ $env{'form.upfile'}=~s/\n+/\n/gs;
+ $env{'form.upfile'}=~s/\n+$//gs;
- my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
- '_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$;
+ my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.
+ '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;
{
my $datafile = $r->dir_config('lonDaemons').
'/tmp/'.$datatoken.'.tmp';
if ( open(my $fh,">$datafile") ) {
- print $fh $ENV{'form.upfile'};
+ print $fh $env{'form.upfile'};
close($fh);
}
}
@@ -2632,8 +4336,8 @@ sub upfile_store {
=item * load_tmp_file($r)
Load uploaded file from tmp, $r should be the HTTP Request object,
-needs $ENV{'form.datatoken'},
-sets $ENV{'form.upfile'} to the contents of the file
+needs $env{'form.datatoken'},
+sets $env{'form.upfile'} to the contents of the file
=cut
@@ -2642,13 +4346,13 @@ sub load_tmp_file {
my @studentdata=();
{
my $studentfile = $r->dir_config('lonDaemons').
- '/tmp/'.$ENV{'form.datatoken'}.'.tmp';
+ '/tmp/'.$env{'form.datatoken'}.'.tmp';
if ( open(my $fh,"<$studentfile") ) {
@studentdata=<$fh>;
close($fh);
}
}
- $ENV{'form.upfile'}=join('',@studentdata);
+ $env{'form.upfile'}=join('',@studentdata);
}
=pod
@@ -2657,14 +4361,19 @@ sub load_tmp_file {
Separate uploaded file into records
returns array of records,
-needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'}
+needs $env{'form.upfile'} and $env{'form.upfiletype'}
=cut
sub upfile_record_sep {
- if ($ENV{'form.upfiletype'} eq 'xml') {
+ if ($env{'form.upfiletype'} eq 'xml') {
} else {
- return split(/\n/,$ENV{'form.upfile'});
+ my @records;
+ foreach my $line (split(/\n/,$env{'form.upfile'})) {
+ if ($line=~/^\s*$/) { next; }
+ push(@records,$line);
+ }
+ return @records;
}
}
@@ -2672,30 +4381,33 @@ sub upfile_record_sep {
=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'}
=cut
+sub takeleft {
+ my $index=shift;
+ return substr('0000'.$index,-4,4);
+}
+
sub record_sep {
my $record=shift;
my %components=();
- if ($ENV{'form.upfiletype'} eq 'xml') {
- } elsif ($ENV{'form.upfiletype'} eq 'space') {
+ if ($env{'form.upfiletype'} eq 'xml') {
+ } elsif ($env{'form.upfiletype'} eq 'space') {
my $i=0;
- foreach (split(/\s+/,$record)) {
- my $field=$_;
+ foreach my $field (split(/\s+/,$record)) {
$field=~s/^(\"|\')//;
$field=~s/(\"|\')$//;
- $components{$i}=$field;
+ $components{&takeleft($i)}=$field;
$i++;
}
- } elsif ($ENV{'form.upfiletype'} eq 'tab') {
+ } elsif ($env{'form.upfiletype'} eq 'tab') {
my $i=0;
- foreach (split(/\t/,$record)) {
- my $field=$_;
+ foreach my $field (split(/\t/,$record)) {
$field=~s/^(\"|\')//;
$field=~s/(\"|\')$//;
- $components{$i}=$field;
+ $components{&takeleft($i)}=$field;
$i++;
}
} else {
@@ -2713,7 +4425,7 @@ sub record_sep {
$field=~s/^\s*$delimiter//;
$field=~s/$delimiter\s*$//;
}
- $components{$i}=$field;
+ $components{&takeleft($i)}=$field;
$i++;
}
}
@@ -2750,6 +4462,22 @@ sub upfile_select_html {
return $Str;
}
+sub get_samples {
+ my ($records,$toget) = @_;
+ my @samples=({});
+ my $got=0;
+ foreach my $rec (@$records) {
+ my %temp = &record_sep($rec);
+ if (! grep(/\S/, values(%temp))) { next; }
+ if (%temp) {
+ $samples[$got]=\%temp;
+ $got++;
+ if ($got == $toget) { last; }
+ }
+ }
+ return \@samples;
+}
+
######################################################
######################################################
@@ -2767,20 +4495,17 @@ Apache Request ref, $records is an array
######################################################
sub csv_print_samples {
my ($r,$records) = @_;
- my (%sone,%stwo,%sthree);
- %sone=&record_sep($$records[0]);
- if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
- if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
- #
+ my $samples = &get_samples($records,3);
+
$r->print(&mt('Samples').'<br /><table border="2"><tr>');
- foreach (sort({$a <=> $b} keys(%sone))) {
- $r->print('<th>'.&mt('Column [_1]',($_+1)).'</th>'); }
+ foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
+ $r->print('<th>'.&mt('Column [_1]',($sample+1)).'</th>'); }
$r->print('</tr>');
- foreach my $hash (\%sone,\%stwo,\%sthree) {
+ foreach my $hash (@$samples) {
$r->print('<tr>');
- foreach (sort({$a <=> $b} keys(%sone))) {
+ foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
$r->print('<td>');
- if (defined($$hash{$_})) { $r->print($$hash{$_}); }
+ if (defined($$hash{$sample})) { $r->print($$hash{$sample}); }
$r->print('</td>');
}
$r->print('</tr>');
@@ -2807,23 +4532,23 @@ $d is an array of 2 element arrays (inte
######################################################
sub csv_print_select_table {
my ($r,$records,$d) = @_;
- my $i=0;my %sone;
- %sone=&record_sep($$records[0]);
+ my $i=0;
+ my $samples = &get_samples($records,1);
$r->print(&mt('Associate columns with student attributes.')."\n".
'<table border="2"><tr>'.
'<th>'.&mt('Attribute').'</th>'.
'<th>'.&mt('Column').'</th></tr>'."\n");
- foreach (@$d) {
- my ($value,$display,$defaultcol)=@{ $_ };
+ foreach my $array_ref (@$d) {
+ my ($value,$display,$defaultcol)=@{ $array_ref };
$r->print('<tr><td>'.$display.'</td>');
$r->print('<td><select name=f'.$i.
' onchange="javascript:flip(this.form,'.$i.');">');
$r->print('<option value="none"></option>');
- foreach (sort({$a <=> $b} keys(%sone))) {
- $r->print('<option value="'.$_.'"'.
- ($_ eq $defaultcol ? ' selected ' : '').
- '>Column '.($_+1).'</option>');
+ foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
+ $r->print('<option value="'.$sample.'"'.
+ ($sample eq $defaultcol ? ' selected="selected" ' : '').
+ '>Column '.($sample+1).'</option>');
}
$r->print('</select></td></tr>'."\n");
$i++;
@@ -2851,28 +4576,27 @@ $d is an array of 2 element arrays (inte
######################################################
sub csv_samples_select_table {
my ($r,$records,$d) = @_;
- my %sone; my %stwo; my %sthree;
my $i=0;
#
+ my $samples = &get_samples($records,3);
$r->print('<table border=2><tr><th>'.
&mt('Field').'</th><th>'.&mt('Samples').'</th></tr>');
- %sone=&record_sep($$records[0]);
- if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
- if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
- #
- foreach (sort keys %sone) {
+
+ foreach my $key (sort(keys(%{ $samples->[0] }))) {
$r->print('<tr><td><select name="f'.$i.'"'.
' onchange="javascript:flip(this.form,'.$i.');">');
- foreach (@$d) {
- my ($value,$display,$defaultcol)=@{ $_ };
+ foreach my $option (@$d) {
+ my ($value,$display,$defaultcol)=@{ $option };
$r->print('<option value="'.$value.'"'.
- ($i eq $defaultcol ? ' selected ':'').'>'.
+ ($i eq $defaultcol ? ' selected="selected" ':'').'>'.
$display.'</option>');
}
$r->print('</select></td><td>');
- if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); }
- if (defined($stwo{$_})) { $r->print($stwo{$_}."</br>\n"); }
- if (defined($sthree{$_})) { $r->print($sthree{$_}."</br>\n"); }
+ foreach my $line (0..2) {
+ if (defined($samples->[$line]{$key})) {
+ $r->print($samples->[$line]{$key}."<br />\n");
+ }
+ }
$r->print('</td></tr>');
$i++;
}
@@ -2961,7 +4685,7 @@ the routine &Apache::lonnet::transfer_pr
my $uniq=0;
sub get_cgi_id {
$uniq=($uniq+1)%100000;
- return (time.'_'.$uniq);
+ return (time.'_'.$$.'_'.$uniq);
}
############################################################
@@ -2997,6 +4721,9 @@ they are plotted. If undefined, default
=item @Values: An array of array references. Each array reference holds data
to be plotted in a stacked bar chart.
+=item If the final element of @Values is a hash reference the key/value
+pairs will be added to the graph definition.
+
=back
Returns:
@@ -3017,13 +4744,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) {
@@ -3033,7 +4775,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;
@@ -3051,15 +4801,6 @@ sub DrawBarGraph {
$bar_width = 4;
}
#
- my @Labels;
- if (defined($labels)) {
- @Labels = @$labels;
- } else {
- for (my $i=0;$i<@{$Values[0]};$i++) {
- push (@Labels,$i+1);
- }
- }
- #
$Max = 1 if ($Max < 1);
if ( int($Max) < $Max ) {
$Max++;
@@ -3068,9 +4809,9 @@ sub DrawBarGraph {
$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.'.title'} = &escape($Title);
+ $ValuesHash{$id.'.xlabel'} = &escape($xlabel);
+ $ValuesHash{$id.'.ylabel'} = &escape($ylabel);
$ValuesHash{$id.'.y_max_value'} = $Max;
$ValuesHash{$id.'.NumBars'} = $NumBars;
$ValuesHash{$id.'.NumSets'} = $NumSets;
@@ -3082,6 +4823,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" />';
}
@@ -3116,7 +4862,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.
@@ -3145,9 +4891,9 @@ sub DrawXYGraph {
$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.'.title' => &escape($Title),
+ $id.'.xlabel' => &escape($xlabel),
+ $id.'.ylabel' => &escape($ylabel),
$id.'.y_max_value'=> $Max,
$id.'.labels' => join(',',@$Xlabels),
$id.'.PlotType' => 'XY',
@@ -3242,9 +4988,9 @@ sub DrawXYYGraph {
$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.'.title' => &escape($Title),
+ $id.'.xlabel' => &escape($xlabel),
+ $id.'.ylabel' => &escape($ylabel),
$id.'.labels' => join(',',@$Xlabels),
$id.'.PlotType' => 'XY',
$id.'.NumSets' => 2,
@@ -3316,8 +5062,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='.&escape($sname.':'.$sdomain).
+ '&chartoutputmode='.HTML::Entities::encode('html, with all links').
'">'.$linktext.'</a>';
}
@@ -3346,6 +5092,7 @@ a hash ref describing the data to be sto
'chartoutputmode' => 'scalar',
'chartoutputdata' => 'scalar',
'Section' => 'array',
+ 'Group' => 'array',
'StudentData' => 'array',
'Maps' => 'array');
@@ -3358,34 +5105,35 @@ Returns: both routines return nothing
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 $courseid = $env{'request.course.id'};
+ my $udom = $env{'user.domain'};
+ my $uname = $env{'user.name'};
my ($prefix,$Settings) = @_;
my %SaveHash;
my %AppHash;
while (my ($setting,$type) = each(%$Settings)) {
- my $basename = 'internal.'.$prefix.'.'.$setting;
- my $envname = 'course.'.$courseid.'.'.$basename;
- if (exists($ENV{'form.'.$setting})) {
+ my $basename = join('.','internal',$courseid,$prefix,$setting);
+ my $envname = 'environment.'.$basename;
+ if (exists($env{'form.'.$setting})) {
# Save this value away
if ($type eq 'scalar' &&
- (! exists($ENV{$envname}) ||
- $ENV{$envname} ne $ENV{'form.'.$setting})) {
- $SaveHash{$basename} = $ENV{'form.'.$setting};
- $AppHash{$envname} = $ENV{'form.'.$setting};
+ (! 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})) {
+ if (ref($env{'form.'.$setting})) {
$stored_form = join(',',
map {
- &Apache::lonnet::escape($_);
- } sort(@{$ENV{'form.'.$setting}}));
+ &escape($_);
+ } sort(@{$env{'form.'.$setting}}));
} else {
$stored_form =
- &Apache::lonnet::escape($ENV{'form.'.$setting});
+ &escape($env{'form.'.$setting});
}
# Determine if the array contents are the same.
- if ($stored_form ne $ENV{$envname}) {
+ if ($stored_form ne $env{$envname}) {
$SaveHash{$basename} = $stored_form;
$AppHash{$envname} = $stored_form;
}
@@ -3393,8 +5141,7 @@ sub store_course_settings {
}
}
my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
- $coursedom,
- $ENV{'course.'.$courseid.'.num'});
+ $udom,$uname);
if ($put_result !~ /^(ok|delayed)/) {
&Apache::lonnet::logthis('unable to save form parameters, '.
'got error:'.$put_result);
@@ -3405,20 +5152,20 @@ sub store_course_settings {
}
sub restore_course_settings {
- my $courseid = $ENV{'request.course.id'};
+ 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.'.internal.'.$prefix.
+ next if (exists($env{'form.'.$setting}));
+ my $envname = 'environment.internal.'.$courseid.'.'.$prefix.
'.'.$setting;
- if (exists($ENV{$envname})) {
+ if (exists($env{$envname})) {
if ($type eq 'scalar') {
- $ENV{'form.'.$setting} = $ENV{$envname};
+ $env{'form.'.$setting} = $env{$envname};
} elsif ($type eq 'array') {
- $ENV{'form.'.$setting} = [
+ $env{'form.'.$setting} = [
map {
- &Apache::lonnet::unescape($_);
- } split(',',$ENV{$envname})
+ &unescape($_);
+ } split(',',$env{$envname})
];
}
}
@@ -3428,15 +5175,17 @@ sub restore_course_settings {
############################################################
############################################################
-sub propath {
- my ($udom,$uname)=@_;
- $udom=~s/\W//g;
- $uname=~s/\W//g;
- my $subdir=$uname.'__';
- $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
- my $proname="$Apache::lonnet::perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
- return $proname;
-}
+sub course_type {
+ my ($cid) = @_;
+ if (!defined($cid)) {
+ $cid = $env{'request.course.id'};
+ }
+ if (defined($env{'course.'.$cid.'type'})) {
+ return $env{'course.'.$cid.'type'};
+ } else {
+ return 'Course';
+ }
+}
sub icon {
my ($file)=@_;
@@ -3451,9 +5200,48 @@ sub icon {
$curfext.".gif";
}
}
- return $iconname;
+ return &lonhttpdurl($iconname);
}
+sub lonhttpdurl {
+ my ($url)=@_;
+ my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'};
+ if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; }
+ return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url;
+}
+
+sub connection_aborted {
+ my ($r)=@_;
+ $r->print(" ");$r->rflush();
+ my $c = $r->connection;
+ return $c->aborted();
+}
+
+# Escapes strings that may have embedded 's that will be put into
+# strings as 'strings'.
+sub escape_single {
+ my ($input) = @_;
+ $input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)>
+ $input =~ s/\'/\\\'/g; # Esacpe the 's....
+ return $input;
+}
+
+# Same as escape_single, but escape's "'s This
+# can be used for "strings"
+sub escape_double {
+ my ($input) = @_;
+ $input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)>
+ $input =~ s/\"/\\\"/g; # Esacpe the "s....
+ return $input;
+}
+
+# Escapes the last element of a full URL.
+sub escape_url {
+ my ($url) = @_;
+ my @urlslices = split(/\//, $url,-1);
+ my $lastitem = &escape(pop(@urlslices));
+ return join('/',@urlslices).'/'.$lastitem;
+}
=pod
=back