--- loncom/interface/loncommon.pm 2006/12/11 21:16:32 1.491
+++ loncom/interface/loncommon.pm 2007/04/20 21:39:39 1.531
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# a pile of common routines
#
-# $Id: loncommon.pm,v 1.491 2006/12/11 21:16:32 albertel Exp $
+# $Id: loncommon.pm,v 1.531 2007/04/20 21:39:39 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -59,6 +59,7 @@ use Apache::lonnet;
use GDBM_File;
use POSIX qw(strftime mktime);
use Apache::lonmenu();
+use Apache::lonenc();
use Apache::lonlocal;
use HTML::Entities;
use Apache::lonhtmlcommon();
@@ -67,8 +68,12 @@ use Apache::lontexconvert();
use Apache::lonclonecourse();
use LONCAPA qw(:DEFAULT :match);
+# ---------------------------------------------- Designs
+use vars qw(%defaultdesign);
+
my $readit;
+
##
## Global Variables
##
@@ -81,10 +86,6 @@ my %scprtag;
my %fe; my %fd; my %fm;
my %category_extensions;
-# ---------------------------------------------- Designs
-
-my %designhash;
-
# ---------------------------------------------- Thesaurus variables
#
# %Keywords:
@@ -150,30 +151,18 @@ BEGIN {
}
}
-# -------------------------------------------------------------- domain designs
-
- my $filename;
+# -------------------------------------------------------------- default domain designs
my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
- opendir(DIR,$designdir);
- while ($filename=readdir(DIR)) {
- if ($filename!~/\.tab$/) { next; }
- my ($domain)=($filename=~/^($match_domain)\./);
- {
- 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);
- }
- }
-
+ my $designfile = $designdir.'/default.tab';
+ if ( open (my $fh,"<$designfile") ) {
+ while (my $line = <$fh>) {
+ next if ($line =~ /^\#/);
+ chomp($line);
+ my ($key,$val)=(split(/\=/,$line));
+ if ($val) { $defaultdesign{$key}=$val; }
+ }
+ close($fh);
}
- closedir(DIR);
-
# ------------------------------------------------------------- file categories
{
@@ -251,7 +240,7 @@ Inputs: formname, elementname
formname and elementname specify the name of the html form and the name
of the element the selection from the search results will be placed in.
-
+=back
=cut
sub browser_and_searcher_javascript {
@@ -515,8 +504,8 @@ function setSect(sectionlist) {
sub selectcourse_link {
my ($form,$unameele,$udomele,$desc,$extra_element,$multflag,$selecttype)=@_;
- return "".&mt('Select [_1]',$selecttype)." ";
+ return "".&mt('Select Course')." ";
}
sub check_uncheck_jscript {
@@ -1264,37 +1253,13 @@ sub create_text_file {
## Home server list generating code ##
###############################################################
-=pod
-
-=head1 Home Server option list generating code
-
-=over 4
-
-=item * get_domains()
-
-Returns an array containing each of the domains listed in the hosts.tab
-file.
-
-=cut
-
-#-------------------------------------------
-sub get_domains {
- # The code below was stolen from "The Perl Cookbook", p 102, 1st ed.
- my @domains;
- my %seen;
- foreach my $dom (sort(values(%Apache::lonnet::hostdom))) {
- push(@domains,$dom) unless $seen{$dom}++;
- }
- return @domains;
-}
-
# ------------------------------------------
sub domain_select {
my ($name,$value,$multiple)=@_;
my %domains=map {
- $_ => $_.' '.$Apache::lonnet::domaindescription{$_}
- } &get_domains;
+ $_ => $_.' '. &Apache::lonnet::domain($_,'description')
+ } &Apache::lonnet::all_domains();
if ($multiple) {
$domains{''}=&mt('Any domain');
return &multiple_select_form($name,$value,4,\%domains);
@@ -1307,6 +1272,12 @@ sub domain_select {
=pod
+=head1 Routines for form select boxes
+
+=over 4
+
+=cut
+
=item * multiple_select_form($name,$value,$size,$hash,$order)
Returns a string containing a element int multiple mode
@@ -1314,11 +1285,11 @@ Returns a string containing a e
Args:
$name - name of the element
- $value - sclara or array ref of values that should already be selected
+ $value - scalar 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
+ $order - (optional) array ref of the order to show the elements in
=cut
@@ -1334,8 +1305,16 @@ sub multiple_select_form {
}
}
$output.="\n";
- my @order = ref($order) ? @$order
- : sort(keys(%$hash));
+ my @order;
+ if (ref($order) eq 'ARRAY') {
+ @order = @{$order};
+ } else {
+ @order = sort(keys(%$hash));
+ }
+ if (exists($$hash{'select_form_order'})) {
+ @order = @{$$hash{'select_form_order'}};
+ }
+
foreach my $key (@order) {
$output.='&').'" ';
$output.='selected="selected" ' if ($selected{$key});
@@ -1450,7 +1429,7 @@ selected");
#-------------------------------------------
sub select_dom_form {
my ($defdom,$name,$includeempty) = @_;
- my @domains = get_domains();
+ my @domains = sort(&Apache::lonnet::all_domains());
if ($includeempty) { @domains=('',@domains); }
my $selectdomain = "\n";
foreach my $dom (@domains) {
@@ -1466,30 +1445,6 @@ sub select_dom_form {
=pod
-=item * get_library_servers($domain)
-
-Returns a hash which contains keys like '103l3' and values like
-'kirk.lite.msu.edu'. All of the keys will be for machines in the
-given $domain.
-
-=cut
-
-#-------------------------------------------
-sub get_library_servers {
- my $domain = shift;
- my %library_servers;
- foreach my $hostid (keys(%Apache::lonnet::libserv)) {
- if ($Apache::lonnet::hostdom{$hostid} eq $domain) {
- $library_servers{$hostid} = $Apache::lonnet::hostname{$hostid};
- }
- }
- return %library_servers;
-}
-
-#-------------------------------------------
-
-=pod
-
=item * home_server_option_list($domain)
returns a string which contains an list to be used in a
@@ -1500,7 +1455,7 @@ returns a string which contains an ';
+ } else {
+ return '';
+ }
+}
+
=pod
=back
@@ -2473,19 +2441,21 @@ sub preferred_languages {
if ($browser) {
@languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$browser));
}
- if ($Apache::lonnet::domain_lang_def{$env{'user.domain'}}) {
+ if (&Apache::lonnet::domain($env{'user.domain'},'lang_def')) {
@languages=(@languages,
- $Apache::lonnet::domain_lang_def{$env{'user.domain'}});
+ &Apache::lonnet::domain($env{'user.domain'},
+ 'lang_def'));
}
- if ($Apache::lonnet::domain_lang_def{$env{'request.role.domain'}}) {
+ if (&Apache::lonnet::domain($env{'request.role.domain'},'lang_def')) {
@languages=(@languages,
- $Apache::lonnet::domain_lang_def{$env{'request.role.domain'}});
+ &Apache::lonnet::domain($env{'request.role.domain'},
+ 'lang_def'));
}
- if ($Apache::lonnet::domain_lang_def{
- $Apache::lonnet::perlvar{'lonDefDomain'}}) {
+ if (&Apache::lonnet::domain($Apache::lonnet::perlvar{'lonDefDomain'},
+ 'lang_def')) {
@languages=(@languages,
- $Apache::lonnet::domain_lang_def{
- $Apache::lonnet::perlvar{'lonDefDomain'}});
+ &Apache::lonnet::domain($Apache::lonnet::perlvar{'lonDefDomain'},
+ 'lang_def'));
}
# turn "en-ca" into "en-ca,en"
my @genlanguages;
@@ -2690,7 +2660,9 @@ sub get_student_answers {
}
$moreenv{'grade_target'}='answer';
%moreenv=(%form,%moreenv);
- my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%moreenv);
+ $feedurl = &Apache::lonnet::clutter($feedurl);
+ &Apache::lonenc::check_encrypt(\$feedurl);
+ my $userview=&Apache::lonnet::ssi($feedurl,%moreenv);
return $userview;
}
@@ -2893,16 +2865,16 @@ sub blockcheck {
$uname = $env{'user.name'};
}
- my ($startblock,$endblock);
-
# If uname and udom are for a course, check for blocks in the course.
if (&Apache::lonnet::is_course($udom,$uname)) {
my %records = &Apache::lonnet::dump('comm_block',$udom,$uname);
- ($startblock,$endblock)=&get_blocks($setters,$activity,$udom,$uname);
+ my ($startblock,$endblock)=&get_blocks($setters,$activity,$udom,$uname);
return ($startblock,$endblock);
}
+ my $startblock = 0;
+ my $endblock = 0;
my %live_courses = &findallcourses(undef,$uname,$udom);
# If uname is for a user, and activity is course-specific, i.e.,
@@ -2963,8 +2935,6 @@ sub blockcheck {
if ($sec ne 'none') {
$checkrole .= '/'.$sec;
}
- # Resource belongs to user other than current user.
- # Assemble privs for that user, and check for 'evb' priv.
if ($otheruser) {
# Resource belongs to user other than current user.
# Assemble privs for that user, and check for 'evb' priv.
@@ -3014,8 +2984,16 @@ sub blockcheck {
# Retrieve blocking times and identity of blocker for course
# of specified user, unless user has 'evb' privilege.
-
- ($startblock,$endblock)=&get_blocks($setters,$activity,$cdom,$cnum);
+
+ my ($start,$end)=&get_blocks($setters,$activity,$cdom,$cnum);
+ if (($start != 0) &&
+ (($startblock == 0) || ($startblock > $start))) {
+ $startblock = $start;
+ }
+ if (($end != 0) &&
+ (($endblock == 0) || ($endblock < $end))) {
+ $endblock = $end;
+ }
}
return ($startblock,$endblock);
}
@@ -3187,7 +3165,7 @@ Returns: Determines which domain should
###############################################
sub determinedomain {
my $domain=shift;
- if (! $domain) {
+ if (! $domain) {
# Determine domain if we have not been given one
$domain = $Apache::lonnet::perlvar{'lonDefDomain'};
if ($env{'user.domain'}) { $domain=$env{'user.domain'}; }
@@ -3198,6 +3176,60 @@ sub determinedomain {
return $domain;
}
###############################################
+
+sub devalidate_domconfig_cache {
+ my ($udom)=@_;
+ &Apache::lonnet::devalidate_cache_new('domainconfig',$udom);
+}
+
+# ---------------------- Get domain configuration for a domain
+sub get_domainconf {
+ my ($udom) = @_;
+ my $cachetime=1800;
+ my ($result,$cached)=&Apache::lonnet::is_cached_new('domainconfig',$udom);
+ if (defined($cached)) { return %{$result}; }
+
+ my %domconfig = &Apache::lonnet::get_dom('configuration',
+ ['login','rolecolors'],$udom);
+ my %designhash;
+ if (keys(%domconfig) > 0) {
+ if (ref($domconfig{'login'}) eq 'HASH') {
+ foreach my $key (keys(%{$domconfig{'login'}})) {
+ $designhash{$udom.'.login.'.$key}=$domconfig{'login'}{$key};
+ }
+ }
+ if (ref($domconfig{'rolecolors'}) eq 'HASH') {
+ foreach my $role (keys(%{$domconfig{'rolecolors'}})) {
+ if (ref($domconfig{'rolecolors'}{$role}) eq 'HASH') {
+ foreach my $item (keys(%{$domconfig{'rolecolors'}{$role}})) {
+ $designhash{$udom.'.'.$role.'.'.$item}=$domconfig{'rolecolors'}{$role}{$item};
+ }
+ }
+ }
+ }
+ } else {
+ my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
+ my $designfile = $designdir.'/'.$udom.'.tab';
+ if (-e $designfile) {
+ if ( open (my $fh,"<$designfile") ) {
+ while (my $line = <$fh>) {
+ next if ($line =~ /^\#/);
+ chomp($line);
+ my ($key,$val)=(split(/\=/,$line));
+ if ($val) { $designhash{$udom.'.'.$key}=$val; }
+ }
+ close($fh);
+ }
+ }
+ if (-e '/home/httpd/html/adm/lonDomLogos/'.$udom.'.gif') {
+ $designhash{$udom.'.login.domlogo'} = "/adm/lonDomLogos/$udom.gif";
+ }
+ }
+ &Apache::lonnet::do_cache_new('domainconfig',$udom,\%designhash,
+ $cachetime);
+ return %designhash;
+}
+
=pod
=item * &domainlogo()
@@ -3211,13 +3243,17 @@ If the domain logo does not exist, a des
###############################################
sub domainlogo {
- my $domain = &determinedomain(shift);
- # See if there is a logo
- if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') {
- my $logo=&lonhttpdurl("/adm/lonDomLogos/$domain.gif");
- return ' ';
- } elsif(exists($Apache::lonnet::domaindescription{$domain})) {
- return $Apache::lonnet::domaindescription{$domain};
+ my $domain = &determinedomain(shift);
+ my %designhash = &get_domainconf($domain);
+ # See if there is a logo
+ if ($designhash{$domain.'.login.domlogo'} ne '') {
+ my $imgsrc = $designhash{$domain.'.login.domlogo'};
+ if ($imgsrc =~ /^\/(adm|res)/) {
+ $imgsrc = &lonhttpdurl($imgsrc);
+ }
+ return ' ';
+ } elsif (defined(&Apache::lonnet::domain($domain,'description'))) {
+ return &Apache::lonnet::domain($domain,'description');
} else {
return '';
}
@@ -3253,11 +3289,20 @@ sub designparm {
return $env{'environment.color.'.$which};
}
$domain=&determinedomain($domain);
- if (exists($designhash{$domain.'.'.$which})) {
- return $designhash{$domain.'.'.$which};
+ my %domdesign = &get_domainconf($domain);
+ my $output;
+ if ($domdesign{$domain.'.'.$which} ne '') {
+ $output = $domdesign{$domain.'.'.$which};
} else {
- return $designhash{'default.'.$which};
+ $output = $defaultdesign{$which};
}
+ if (($which =~ /^(student|coordinator|author|admin)\.img$/) ||
+ ($which =~ /login\.(img|logo|domlogo)/)) {
+ if ($output =~ /^\/(adm|res)\//) {
+ $output = &lonhttpdurl($output);
+ }
+ }
+ return $output;
}
###############################################
@@ -3330,7 +3375,7 @@ sub bodytag {
my $pgbg = $bgcolor || &designparm($function.'.pgbg',$domain);
my %design = ( 'style' => 'margin-top: 0px',
- 'bgcolor' => $pgbg,
+ 'bgcolor' => '#ffffff',
'text' => $font,
'alink' => &designparm($function.'.alink',$domain),
'vlink' => &designparm($function.'.vlink',$domain),
@@ -3341,7 +3386,7 @@ sub bodytag {
my ($role,$realm) = split(/\./,$env{'request.role'},2);
if ($role eq 'ca') {
my ($rdom,$rname) = ($realm =~ m{^/($match_domain)/($match_username)$});
- $realm = &plainname($rname,$rdom).':'.$rdom;
+ $realm = &plainname($rname,$rdom);
}
# realm
if ($env{'request.course.id'}) {
@@ -3366,9 +3411,7 @@ sub bodytag {
my $bodytag = "".
&Apache::lontexconvert::init_math_support();
- if ($bodyonly
- || ($env{'request.state'} eq 'construct'
- && $env{'environment.remote'} ne 'off' )) {
+ if ($bodyonly) {
return $bodytag;
} elsif ($env{'browser.interface'} eq 'textual') {
# Accessibility
@@ -3476,8 +3519,11 @@ ENDROLE
# Top frame rendering, Remote is up
#
- my $upperleft=' ';
+ my $imgsrc = $img;
+ if ($img =~ /^\/adm/) {
+ $imgsrc = 'http://'.$ENV{'HTTP_HOST'}.':'.$lonhttpdPort.$img;
+ }
+ my $upperleft=' ';
# Explicit link to get inline menu
my $menu= ($no_inline_link?''
@@ -3642,12 +3688,21 @@ sub standard_css {
my $border = ($env{'browser.type'} eq 'explorer') ? '0px 2px 0px 2px'
: '0px 3px 0px 4px';
+
return < if true will start with a
rather than
+ dicsussion -> if true will get discussion from
+ lonxml::xmlend
+ (you can pass the target and parser arguments
+ through optional 'target' and 'parser' args
+ to this routine)
=cut
@@ -4926,7 +5144,7 @@ sub get_course_users {
$usec = 'none';
}
if ($uname ne '' && $udom ne '') {
- if ($end < $now) {
+ if ($end > 0 && $end < $now) {
$status = 'previous';
} elsif ($start > $now) {
$status = 'future';
@@ -5368,9 +5586,9 @@ sub record_sep {
} else {
my @allfields;
if ($env{'form.upfiletype'} eq 'semisv') {
- @allfields=split(/;/,$record);
+ @allfields=split(/;/,$record,-1);
} else {
- @allfields=split(/\,/,$record);
+ @allfields=split(/\,/,$record,-1);
}
my $i=0;
my $j;
@@ -6064,16 +6282,19 @@ Returns: both routines return nothing
#######################################################
#######################################################
sub store_course_settings {
+ return &store_settings($env{'request.course.id'},@_);
+}
+
+sub store_settings {
# save to the environment
# appenv the same items, just to be safe
- my $courseid = $env{'request.course.id'};
my $udom = $env{'user.domain'};
my $uname = $env{'user.name'};
- my ($prefix,$Settings) = @_;
+ my ($context,$prefix,$Settings) = @_;
my %SaveHash;
my %AppHash;
while (my ($setting,$type) = each(%$Settings)) {
- my $basename = join('.','internal',$courseid,$prefix,$setting);
+ my $basename = join('.','internal',$context,$prefix,$setting);
my $envname = 'environment.'.$basename;
if (exists($env{'form.'.$setting})) {
# Save this value away
@@ -6113,11 +6334,14 @@ sub store_course_settings {
}
sub restore_course_settings {
- my $courseid = $env{'request.course.id'};
- my ($prefix,$Settings) = @_;
+ return &restore_settings($env{'request.course.id'},@_);
+}
+
+sub restore_settings {
+ my ($context,$prefix,$Settings) = @_;
while (my ($setting,$type) = each(%$Settings)) {
next if (exists($env{'form.'.$setting}));
- my $envname = 'environment.internal.'.$courseid.'.'.$prefix.
+ my $envname = 'environment.internal.'.$context.'.'.$prefix.
'.'.$setting;
if (exists($env{$envname})) {
if ($type eq 'scalar') {
@@ -6532,7 +6756,7 @@ sub group_term {
sub icon {
my ($file)=@_;
- my $curfext = (split(/\./,$file))[-1];
+ my $curfext = lc((split(/\./,$file))[-1]);
my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif';
my $embstyle = &Apache::loncommon::fileembstyle($curfext);
if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) {