[LON-CAPA-cvs] cvs: loncom(GCI_1) /lonnet/perl lonnet.pm
raeburn
raeburn@source.lon-capa.org
Wed, 16 Sep 2009 20:02:48 -0000
This is a MIME encoded message
--raeburn1253131368
Content-Type: text/plain
raeburn Wed Sep 16 20:02:48 2009 EDT
Modified files: (Branch: GCI_1)
/loncom/lonnet/perl lonnet.pm
Log:
- lonnet.pm for GCI_1 updated to 2.8.X
- Backport 1.978, 1.980, 1.981, 1.982, 1.983.
--raeburn1253131368
Content-Type: text/plain
Content-Disposition: attachment; filename="raeburn-20090916200248.txt"
Index: loncom/lonnet/perl/lonnet.pm
diff -u loncom/lonnet/perl/lonnet.pm:1.976 loncom/lonnet/perl/lonnet.pm:1.976.4.1
--- loncom/lonnet/perl/lonnet.pm:1.976 Mon Dec 8 23:00:47 2008
+++ loncom/lonnet/perl/lonnet.pm Wed Sep 16 20:02:48 2009
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.976 2008/12/08 23:00:47 raeburn Exp $
+# $Id: lonnet.pm,v 1.976.4.1 2009/09/16 20:02:48 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -177,6 +177,20 @@
return 0;
}
+sub get_server_timezone {
+ my ($cnum,$cdom) = @_;
+ my $home=&homeserver($cnum,$cdom);
+ if ($home ne 'no_host') {
+ my $cachetime = 24*3600;
+ my ($timezone,$cached)=&is_cached_new('servertimezone',$home);
+ if (defined($cached)) {
+ return $timezone;
+ } else {
+ my $timezone = &reply('servertimezone',$home);
+ return &do_cache_new('servertimezone',$home,$timezone,$cachetime);
+ }
+ }
+}
# -------------------------------------------------- Non-critical communication
sub subreply {
@@ -508,7 +522,7 @@
# ----------------------------------------------------- Delete from Environment
sub delenv {
- my $delthis=shift;
+ my ($delthis,$regexp) = @_;
if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
&logthis("<font color=\"blue\">WARNING: ".
"Attempt to delete from environment ".$delthis);
@@ -521,10 +535,17 @@
tie(my %disk_env,'GDBM_File',$env{'user.environment'},
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
foreach my $key (keys(%disk_env)) {
- if ($key=~/^$delthis/) {
- delete($env{$key});
- delete($disk_env{$key});
- }
+ if ($regexp) {
+ if ($key=~/^$delthis/) {
+ delete($env{$key});
+ delete($disk_env{$key});
+ }
+ } else {
+ if ($key=~/^\Q$delthis\E/) {
+ delete($env{$key});
+ delete($disk_env{$key});
+ }
+ }
}
untie(%disk_env);
}
@@ -1227,7 +1248,6 @@
sub get_domain_defaults {
my ($domain) = @_;
my $cachetime = 60*60*24;
- my ($defauthtype,$defautharg,$deflang,%deftools);
my ($result,$cached)=&is_cached_new('domdefaults',$domain);
if (defined($cached)) {
if (ref($result) eq 'HASH') {
@@ -1241,6 +1261,8 @@
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
$domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
+ $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
+ $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
} else {
$domdefaults{'lang_def'} = &domain($domain,'lang_def');
$domdefaults{'auth_def'} = &domain($domain,'auth_def');
@@ -1787,7 +1809,7 @@
}
my $output='';
my $response;
- if ($filelink=~/^http\:/) {
+ if ($filelink=~/^https?\:/) {
($output,$response)=&externalssi($filelink);
} else {
($output,$response)=&ssi($filelink,%form);
@@ -2602,6 +2624,9 @@
$storehash{'section'} = $sec;
}
&instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);
+ if (($trole ne 'st') || ($sec ne '')) {
+ &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);
+ }
}
}
return;
@@ -2623,6 +2648,7 @@
my %dumphash=
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
my $now=time;
+ my %privileged;
foreach my $entry (keys %dumphash) {
my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
if (($tstart) && ($tstart<0)) { next; }
@@ -2630,8 +2656,21 @@
if (($tstart) && ($now<$tstart)) { next; }
my ($role,$username,$domain,$section)=split(/\:/,$entry);
if ($username eq '' || $domain eq '') { next; }
- if ((&privileged($username,$domain)) &&
- (!$nothide{$username.':'.$domain})) { next; }
+ unless (ref($privileged{$domain}) eq 'HASH') {
+ my %dompersonnel =
+ &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
+ $privileged{$domain} = {};
+ foreach my $server (keys(%dompersonnel)) {
+ if (ref($dompersonnel{$server}) eq 'HASH') {
+ foreach my $user (keys(%{$dompersonnel{$server}})) {
+ my ($trole,$uname,$udom) = split(/:/,$user);
+ $privileged{$udom}{$uname} = 1;
+ }
+ }
+ }
+ }
+ if ((exists($privileged{$domain}{$username})) &&
+ (!$nothide{$username.':'.$domain})) { next; }
if ($role eq 'cr') { next; }
if ($codes) {
if ($section) { $role .= ':'.$section; }
@@ -2676,6 +2715,7 @@
}
my %returnhash=();
my $now=time;
+ my %privileged;
foreach my $entry (keys(%dumphash)) {
my ($role,$tend,$tstart);
if ($context eq 'userroles') {
@@ -2724,9 +2764,32 @@
}
}
if ($hidepriv) {
- if ((&privileged($username,$domain)) &&
- (!$nothide{$username.':'.$domain})) {
- next;
+ if ($context eq 'userroles') {
+ if ((&privileged($username,$domain)) &&
+ (!$nothide{$username.':'.$domain})) {
+ next;
+ }
+ } else {
+ unless (ref($privileged{$domain}) eq 'HASH') {
+ my %dompersonnel =
+ &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
+ $privileged{$domain} = {};
+ if (keys(%dompersonnel)) {
+ foreach my $server (keys(%dompersonnel)) {
+ if (ref($dompersonnel{$server}) eq 'HASH') {
+ foreach my $user (keys(%{$dompersonnel{$server}})) {
+ my ($trole,$uname,$udom) = split(/:/,$user);
+ $privileged{$udom}{$uname} = $trole;
+ }
+ }
+ }
+ }
+ }
+ if (exists($privileged{$domain}{$username})) {
+ if (!$nothide{$username.':'.$domain}) {
+ next;
+ }
+ }
}
}
if ($withsec) {
@@ -4375,7 +4438,7 @@
}
sub usertools_access {
- my ($uname,$udom,$tool) = @_;
+ my ($uname,$udom,$tool,$action) = @_;
my $access;
my %tools = (
aboutme => 1,
@@ -4389,10 +4452,10 @@
$uname = $env{'user.name'};
}
- my $hashid=$uname.':'.$udom;
- my ($result,$cached) = &is_cached_new('usertools.'.$tool,$hashid);
- if (defined($cached)) {
- return $result;
+ if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
+ if ($action ne 'reload') {
+ return $env{'environment.availabletools.'.$tool};
+ }
}
my ($toolstatus,$inststatus);
@@ -4412,7 +4475,6 @@
} else {
$access = 0;
}
- &do_cache_new('usertools.'.$tool,$hashid,$access,600);
return $access;
}
@@ -4426,7 +4488,6 @@
} else {
$access = 0;
}
- &do_cache_new('usertools.'.$tool,$hashid,$access,600);
return $access;
}
}
@@ -4447,7 +4508,6 @@
} elsif ($hasnoaccess) {
$access = 0;
}
- &do_cache_new('usertools.'.$tool,$hashid,$access,600);
return $access;
}
} else {
@@ -4457,13 +4517,11 @@
} elsif ($domdef{$tool}{'default'} == 0) {
$access = 0;
}
- &do_cache_new('usertools.'.$tool,$hashid,$access,600);
return $access;
}
}
} else {
$access = 1;
- &do_cache_new('usertools.'.$tool,$hashid,$access,600);
return $access;
}
}
@@ -8306,7 +8364,10 @@
if (-e $transferfile) { return 'ok'; }
my $request;
$uri=~s/^\///;
- $request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);
+ my $homeserver = &homeserver($cnum,$cdom);
+ my $protocol = $protocol{$homeserver};
+ $protocol = 'http' if ($protocol ne 'https');
+ $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri);
my $response=$ua->request($request,$transferfile);
# did it work?
if ($response->is_error()) {
@@ -8321,7 +8382,7 @@
sub tokenwrapper {
my $uri=shift;
- $uri=~s|^http\://([^/]+)||;
+ $uri=~s|^https?\://([^/]+)||;
$uri=~s|^/||;
$env{'user.environment'}=~/\/([^\/]+)\.id/;
my $token=$1;
@@ -8329,7 +8390,10 @@
if ($udom && $uname && $file) {
$file=~s|(\?\.*)*$||;
&appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
- return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.
+ my $homeserver = &homeserver($uname,$udom);
+ my $protocol = $protocol{$homeserver};
+ $protocol = 'http' if ($protocol ne 'https');
+ return $protocol.'://'.&hostname($homeserver).'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};
} else {
@@ -8344,7 +8408,10 @@
sub getuploaded {
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
$uri=~s/^\///;
- $uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri;
+ my $homeserver = &homeserver($cnum,$cdom);
+ my $protocol = $protocol{$homeserver};
+ $protocol = 'http' if ($protocol ne 'https');
+ $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;
my $ua=new LWP::UserAgent;
my $request=new HTTP::Request($reqtype,$uri);
my $response=$ua->request($request);
@@ -8426,7 +8493,7 @@
sub hreflocation {
my ($dir,$file)=@_;
- unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
+ unless (($file=~m-^https?\://-i) || ($file=~m-^/-)) {
$file=filelocation($dir,$file);
} elsif ($file=~m-^/adm/-) {
$file=~s-^/adm/wrapper/-/-;
@@ -8622,14 +8689,19 @@
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
foreach my $dns (<$config>) {
next if ($dns !~ /^\^(\S*)/x);
- $alldns{$1} = 1;
+ my $line = $1;
+ my ($host,$protocol) = split(/:/,$line);
+ if ($protocol ne 'https') {
+ $protocol = 'http';
+ }
+ $alldns{$host} = $protocol;
}
while (%alldns) {
my ($dns) = keys(%alldns);
- delete($alldns{$dns});
my $ua=new LWP::UserAgent;
- my $request=new HTTP::Request('GET',"http://$dns$url");
+ my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
my $response=$ua->request($request);
+ delete($alldns{$dns});
next if ($response->is_error());
my @content = split("\n",$response->content);
&Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60);
@@ -9204,9 +9276,11 @@
=item *
X<delenv()>
-B<delenv($regexp)>: removes all items from the session
-environment file that matches the regular expression in $regexp. The
-values are also delted from the current processes %env.
+B<delenv($delthis,$regexp)>: removes all items from the session
+environment file that begin with $delthis. If the
+optional second arg - $regexp - is true, $delthis is treated as a
+regular expression, otherwise \Q$delthis\E is used.
+The values are also deleted from the current processes %env.
=item * get_env_multiple($name)
--raeburn1253131368--