--- loncom/lonnet/perl/lonnet.pm 2008/12/08 23:00:47 1.976 +++ loncom/lonnet/perl/lonnet.pm 2009/09/16 20:02:48 1.976.4.1 @@ -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 @@ sub create_connection { 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 @@ sub appenv { # ----------------------------------------------------- Delete from Environment sub delenv { - my $delthis=shift; + my ($delthis,$regexp) = @_; if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { &logthis("WARNING: ". "Attempt to delete from environment ".$delthis); @@ -521,10 +535,17 @@ sub delenv { 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 inst_userrules { 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 @@ sub get_domain_defaults { $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 @@ sub ssi_body { } my $output=''; my $response; - if ($filelink=~/^http\:/) { + if ($filelink=~/^https?\:/) { ($output,$response)=&externalssi($filelink); } else { ($output,$response)=&ssi($filelink,%form); @@ -2602,6 +2624,9 @@ sub courserolelog { $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 @@ sub get_course_adv_roles { 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 @@ sub get_course_adv_roles { 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 @@ sub get_my_roles { } my %returnhash=(); my $now=time; + my %privileged; foreach my $entry (keys(%dumphash)) { my ($role,$tend,$tstart); if ($context eq 'userroles') { @@ -2724,9 +2764,32 @@ sub get_my_roles { } } 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 is_portfolio_file { } sub usertools_access { - my ($uname,$udom,$tool) = @_; + my ($uname,$udom,$tool,$action) = @_; my $access; my %tools = ( aboutme => 1, @@ -4389,10 +4452,10 @@ sub usertools_access { $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 @@ sub usertools_access { } else { $access = 0; } - &do_cache_new('usertools.'.$tool,$hashid,$access,600); return $access; } @@ -4426,7 +4488,6 @@ sub usertools_access { } else { $access = 0; } - &do_cache_new('usertools.'.$tool,$hashid,$access,600); return $access; } } @@ -4447,7 +4508,6 @@ sub usertools_access { } elsif ($hasnoaccess) { $access = 0; } - &do_cache_new('usertools.'.$tool,$hashid,$access,600); return $access; } } else { @@ -4457,13 +4517,11 @@ sub usertools_access { } 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 @@ sub repcopy_userfile { 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 repcopy_userfile { sub tokenwrapper { my $uri=shift; - $uri=~s|^http\://([^/]+)||; + $uri=~s|^https?\://([^/]+)||; $uri=~s|^/||; $env{'user.environment'}=~/\/([^\/]+)\.id/; my $token=$1; @@ -8329,7 +8390,10 @@ sub tokenwrapper { 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 tokenwrapper { 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 filelocation { 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 @@ sub get_dns { 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 @@ in the user's environment.db and in %env =item * X -B: 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: 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)