--- loncom/lonnet/perl/lonnet.pm 2003/07/25 01:18:04 1.394 +++ loncom/lonnet/perl/lonnet.pm 2003/08/25 17:20:09 1.405 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.394 2003/07/25 01:18:04 bowersj2 Exp $ +# $Id: lonnet.pm,v 1.405 2003/08/25 17:20:09 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -76,7 +76,9 @@ qw(%perlvar %hostname %homecache %badSer %libserv %pr %prp %metacache %packagetab %titlecache %courselogs %accesshash %userrolehash $processmarker $dumpcount %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache - %domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir); + %domaindescription %domain_auth_def %domain_auth_arg_def + %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir); + use IO::Socket; use GDBM_File; use Apache::Constants qw(:common :http); @@ -243,6 +245,16 @@ sub critical { } return $answer; } + +# -------------- Remove all key from the env that start witha lowercase letter +# (Which is alweways a lon-capa value) +sub cleanenv { + foreach my $key (keys(%ENV)) { + if ($key =~ /^[a-z]/) { + delete($ENV{$key}); + } + } +} # ------------------------------------------- Transfer profile into environment @@ -377,8 +389,8 @@ sub userload { my $curtime=time; while ($filename=readdir(LONIDS)) { if ($filename eq '.' || $filename eq '..') {next;} - my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8]; - if ($curtime-$atime < 3600) { $numusers++; } + my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; + if ($curtime-$mtime < 3600) { $numusers++; } } closedir(LONIDS); } @@ -1284,6 +1296,53 @@ sub get_course_adv_roles { return %returnhash; } +sub get_my_roles { + my ($uname,$udom)=@_; + unless (defined($uname)) { $uname=$ENV{'user.name'}; } + unless (defined($udom)) { $udom=$ENV{'user.domain'}; } + my %dumphash= + &dump('nohist_userroles',$udom,$uname); + my %returnhash=(); + my $now=time; + foreach (keys %dumphash) { + my ($tend,$tstart)=split(/\:/,$dumphash{$_}); + if (($tstart) && ($tstart<0)) { next; } + if (($tend) && ($tend<$now)) { next; } + if (($tstart) && ($now<$tstart)) { next; } + my ($role,$username,$domain,$section)=split(/\:/,$_); + $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; + } + return %returnhash; +} + +# ----------------------------------------------------- Frontpage Announcements +# +# + +sub postannounce { + my ($server,$text)=@_; + unless (&allowed('psa',$hostdom{$server})) { return 'refused'; } + unless ($text=~/\w/) { $text=''; } + return &reply('setannounce:'.&escape($text),$server); +} + +sub getannounce { + if (my $fh=Apache::File->new($perlvar{'lonDocRoot'}.'/announcement.txt')) { + my $announcement=''; + while (<$fh>) { $announcement .=$_; } + $fh->close(); + if ($announcement=~/\w/) { + return + ''. + '
'.$announcement.'
'; + } else { + return ''; + } + } else { + return ''; + } +} + # ---------------------------------------------------------- Course ID routines # Deal with domain's nohist_courseid.db files # @@ -2209,6 +2268,9 @@ sub customaccess { $access=($effect eq 'allow'); last; } + if ($realm eq '' && $role eq '') { + $access=($effect eq 'allow'); + } } return $access; } @@ -2221,6 +2283,7 @@ sub allowed { my $orguri=$uri; $uri=&declutter($uri); + if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } # Free bre access to adm and meta resources if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { @@ -3070,7 +3133,7 @@ sub dirlist { } my $alldomstr=''; foreach (sort keys %alldom) { - $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:'; + $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:'; } $alldomstr=~s/:$//; return split(/:/,$alldomstr); @@ -3222,7 +3285,7 @@ sub EXT_cache_set { # --------------------------------------------------------- Value of a Variable sub EXT { - my ($varname,$symbparm,$udom,$uname,$usection)=@_; + my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_; unless ($varname) { return ''; } #get real user name/domain, courseid and symb @@ -3323,6 +3386,7 @@ sub EXT { return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; } elsif ($realm eq 'resource') { + my $section; if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; @@ -3335,7 +3399,6 @@ sub EXT { my $symbparm=$symbp.'.'.$spacequalifierrest; my $mapparm=$mapp.'___(all).'.$spacequalifierrest; - my $section; if (($ENV{'user.name'} eq $uname) && ($ENV{'user.domain'} eq $udom)) { $section=$ENV{'request.course.sec'}; @@ -3426,9 +3489,12 @@ sub EXT { my $part=join('_',@parts); if ($part eq '') { $part='0'; } my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, - $symbparm,$udom,$uname); + $symbparm,$udom,$uname,$section,1); if (defined($partgeneral)) { return $partgeneral; } } + if ($recurse) { return undef; } + my $pack_def=&packages_tab_default($filename,$varname); + if (defined($pack_def)) { return $pack_def; } # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { @@ -3449,6 +3515,19 @@ sub EXT { return ''; } +sub packages_tab_default { + my ($uri,$varname)=@_; + my (undef,$part,$name)=split(/\./,$varname); + my $packages=&metadata($uri,'packages'); + foreach my $package (split(/,/,$packages)) { + my ($pack_type,$pack_part)=split(/_/,$package,2); + if ($pack_part eq $part) { + return $packagetab{"$pack_type&$name&default"}; + } + } + return undef; +} + sub add_prefix_and_part { my ($prefix,$part)=@_; my $keyroot; @@ -3490,14 +3569,15 @@ sub metadata { if ($liburi) { $liburi=&declutter($liburi); $filename=$liburi; - } + } else { + delete($metacache{$uri.':packages'}); + } my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring=&getfile(&filelocation('',&clutter($filename))); my $parser=HTML::LCParser->new(\$metastring); my $token; undef %metathesekeys; - delete($metacache{$uri.':packages'}); while ($token=$parser->get_token) { if ($token->[0] eq 'S') { if (defined($token->[2]->{'package'})) { @@ -3517,6 +3597,9 @@ sub metadata { foreach (keys %packagetab) { if ($_=~/^$package\&/) { my ($pack,$name,$subp)=split(/\&/,$_); + # ignore package.tab specified default values + # here &package_tab_default() will fetch those + if ($subp eq 'default') { next; } my $value=$packagetab{$_}; my $part=$keyroot; $part=~s/^\_//; @@ -3524,13 +3607,8 @@ sub metadata { $value.=' [Part: '.$part.']'; } my $unikey='parameter'.$keyroot.'_'.$name; - if ($subp eq 'default') { - $unikey='parameter_0_'.$name; - $metacache{$uri.':'.$unikey.'.part'}='0'; - } else { - $metacache{$uri.':'.$unikey.'.part'}=$part; - $metathesekeys{$unikey}=1; - } + $metacache{$uri.':'.$unikey.'.part'}=$part; + $metathesekeys{$unikey}=1; unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { $metacache{$uri.':'.$unikey.'.'.$subp}=$value; } @@ -4105,11 +4183,16 @@ BEGIN { next if (/^(\#|\s*$)/); # next if /^\#/; chomp; - my ($domain, $domain_description, $def_auth, $def_auth_arg) - = split(/:/,$_,4); - $domain_auth_def{$domain}=$def_auth; + my ($domain, $domain_description, $def_auth, $def_auth_arg, + $def_lang, $city, $longi, $lati) = split(/:/,$_); + $domain_auth_def{$domain}=$def_auth; $domain_auth_arg_def{$domain}=$def_auth_arg; - $domaindescription{$domain}=$domain_description; + $domaindescription{$domain}=$domain_description; + $domain_lang_def{$domain}=$def_lang; + $domain_city{$domain}=$city; + $domain_longi{$domain}=$longi; + $domain_lati{$domain}=$lati; + # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); # &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); }