--- loncom/lonnet/perl/lonnet.pm 2011/03/06 21:17:18 1.1105
+++ loncom/lonnet/perl/lonnet.pm 2011/08/01 15:25:04 1.1122
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1105 2011/03/06 21:17:18 raeburn Exp $
+# $Id: lonnet.pm,v 1.1122 2011/08/01 15:25:04 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -95,6 +95,7 @@ use Math::Random;
use File::MMagic;
use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;
+
use File::Copy;
my $readit;
@@ -196,6 +197,29 @@ sub get_server_timezone {
}
}
+sub get_server_distarch {
+ my ($lonhost,$ignore_cache) = @_;
+ if (defined($lonhost)) {
+ if (!defined(&hostname($lonhost))) {
+ return;
+ }
+ my $cachetime = 12*3600;
+ if (!$ignore_cache) {
+ my ($distarch,$cached)=&is_cached_new('serverdistarch',$lonhost);
+ if (defined($cached)) {
+ return $distarch;
+ }
+ }
+ my $rep = &reply('serverdistarch',$lonhost);
+ unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' ||
+ $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||
+ $rep eq '') {
+ return &do_cache_new('serverdistarch',$lonhost,$rep,$cachetime);
+ }
+ }
+ return;
+}
+
sub get_server_loncaparev {
my ($dom,$lonhost,$ignore_cache,$caller) = @_;
if (defined($lonhost)) {
@@ -282,6 +306,44 @@ sub get_server_homeID {
return &do_cache_new('serverhomeID',$hostname,$serverhomeID,$cachetime);
}
+sub get_remote_globals {
+ my ($lonhost,$whathash,$ignore_cache) = @_;
+ my (%returnhash,%whatneeded);
+ if (ref($whathash) eq 'ARRAY') {
+ foreach my $what (sort(keys(%{$whathash}))) {
+ my $type = $whathash->{$what};
+ my $hashid = $lonhost.'-'.$what;
+ my ($result,$cached);
+ unless ($ignore_cache) {
+ ($result,$cached)=&is_cached_new('lonnetglobal',$hashid);
+ $returnhash{$what} = $result;
+ }
+ if (defined($cached)) {
+ $returnhash{$what} = $result;
+ } else {
+ $whatneeded{$what} = $type;
+ }
+ }
+ if (keys(%whatneeded) > 0) {
+ my $requested = &freeze_escape(\%whatneeded);
+ my $rep=&reply('readlonnetglobal:'.$requested,$lonhost);
+ unless (($rep=~/^refused/) || ($rep=~/^rejected/) || ($rep eq 'con_lost')) {
+ my @pairs=split(/\&/,$rep);
+ if ($rep !~ /^error/) {
+ foreach my $item (@pairs) {
+ my ($key,$value)=split(/=/,$item,2);
+ my $what = &unescape($key);
+ my $hashid = $lonhost.'-'.$what;
+ $returnhash{$what}=&thaw_unescape($value);
+ &do_cache_new('lonnetglobal',$hashid,$returnhash{$what},600);
+ }
+ }
+ }
+ }
+ }
+ return %returnhash;
+}
+
# -------------------------------------------------- Non-critical communication
sub subreply {
my ($cmd,$server)=@_;
@@ -793,7 +855,7 @@ sub compare_server_load {
my $userloadans = &reply('userload',$try_server);
if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
- return; #didn't get a number from the server
+ return ($spare_server, $lowest_load); #didn't get a number from the server
}
my $load;
@@ -839,22 +901,38 @@ sub has_user_session {
# --------- determine least loaded server in a user's domain which allows login
sub choose_server {
- my ($udom) = @_;
+ my ($udom,$checkloginvia) = @_;
my %domconfhash = &Apache::loncommon::get_domainconf($udom);
my %servers = &get_servers($udom);
my $lowest_load = 30000;
- my ($login_host,$hostname);
+ my ($login_host,$hostname,$portal_path);
foreach my $lonhost (keys(%servers)) {
- my $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
- if ($loginvia eq '') {
+ my $loginvia;
+ if ($checkloginvia) {
+ $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
+ if ($loginvia) {
+ my ($server,$path) = split(/:/,$loginvia);
+ ($login_host, $lowest_load) =
+ &compare_server_load($server, $login_host, $lowest_load);
+ if ($login_host eq $server) {
+ $portal_path = $path;
+ }
+ } else {
+ ($login_host, $lowest_load) =
+ &compare_server_load($lonhost, $login_host, $lowest_load);
+ if ($login_host eq $lonhost) {
+ $portal_path = '';
+ }
+ }
+ } else {
($login_host, $lowest_load) =
- &compare_server_load($lonhost, $login_host, $lowest_load);
+ &compare_server_load($lonhost, $login_host, $lowest_load);
}
}
if ($login_host ne '') {
- $hostname = $servers{$login_host};
+ $hostname = &hostname($login_host);
}
- return ($login_host,$hostname);
+ return ($login_host,$hostname,$portal_path);
}
# --------------------------------------------- Try to change a user's password
@@ -995,15 +1073,19 @@ sub can_host_session {
}
if ($canhost) {
if (ref($hostedsessions) eq 'HASH') {
+ my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
+ my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {
- if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'excludedomain'}})) {
+ if (($uint_dom ne '') &&
+ (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) {
$canhost = 0;
} else {
$canhost = 1;
}
}
if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') {
- if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'includedomain'}})) {
+ if (($uint_dom ne '') &&
+ (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'includedomain'}}))) {
$canhost = 1;
} else {
$canhost = 0;
@@ -1976,20 +2058,29 @@ sub getversion {
sub currentversion {
my $fname=shift;
- my ($result,$cached)=&is_cached_new('resversion',$fname);
- if (defined($cached)) { return $result; }
my $author=$fname;
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
my ($udom,$uname)=split(/\//,$author);
- my $home=homeserver($uname,$udom);
+ my $home=&homeserver($uname,$udom);
if ($home eq 'no_host') {
return -1;
}
- my $answer=reply("currentversion:$fname",$home);
+ my $answer=&reply("currentversion:$fname",$home);
if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
return -1;
}
- return &do_cache_new('resversion',$fname,$answer,600);
+ return $answer;
+}
+
+#
+# Return special version number of resource if set by override, empty otherwise
+#
+sub usedversion {
+ my $fname=shift;
+ unless ($fname) { $fname=$env{'request.uri'}; }
+ my ($urlversion)=($fname=~/\.(\d+)\.\w+$/);
+ if ($urlversion) { return $urlversion; }
+ return '';
}
# ----------------------------- Subscribe to a resource, return URL if possible
@@ -2525,7 +2616,7 @@ sub finishuserfileupload {
return '/adm/notfound.html';
}
if ($context eq 'overwrite') {
- my $source = $perlvar{'lonDaemons'}.'/tmp/overwrites/'.$docudom.'/'.$docuname.'/'.$fname;
+ my $source = LONCAPA::tempdir().'/overwrites/'.$docudom.'/'.$docuname.'/'.$fname;
my $target = $filepath.'/'.$file;
if (-e $source) {
my @info = stat($source);
@@ -3727,7 +3818,7 @@ sub tmpreset {
if ($domain eq 'public' && $stuname eq 'public') {
$stuname=$ENV{'REMOTE_ADDR'};
}
- my $path=$perlvar{'lonDaemons'}.'/tmp';
+ my $path=LONCAPA::tempdir();
my %hash;
if (tie(%hash,'GDBM_File',
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
@@ -3766,7 +3857,7 @@ sub tmpstore {
}
my $now=time;
my %hash;
- my $path=$perlvar{'lonDaemons'}.'/tmp';
+ my $path=LONCAPA::tempdir();
if (tie(%hash,'GDBM_File',
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
&GDBM_WRCREAT(),0640)) {
@@ -3812,7 +3903,7 @@ sub tmprestore {
$namespace=~s/\//\_/g;
$namespace=~s/\W//g;
my %hash;
- my $path=$perlvar{'lonDaemons'}.'/tmp';
+ my $path=LONCAPA::tempdir();
if (tie(%hash,'GDBM_File',
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
&GDBM_READER(),0640)) {
@@ -3949,6 +4040,8 @@ sub restore {
}
# ---------------------------------------------------------- Course Description
+#
+#
sub coursedescription {
my ($courseid,$args)=@_;
@@ -3978,7 +4071,8 @@ sub coursedescription {
return %returnhash;
}
- # get the data agin
+ # get the data again
+
if (!$args->{'one_time'}) {
$envhash{'course.'.$normalid.'.last_cache'}=time;
}
@@ -3986,6 +4080,10 @@ sub coursedescription {
if ($chome ne 'no_host') {
%returnhash=&dump('environment',$cdomain,$cnum);
if (!exists($returnhash{'con_lost'})) {
+ my $username = $env{'user.name'}; # Defult username
+ if(defined $args->{'user'}) {
+ $username = $args->{'user'};
+ }
$returnhash{'home'}= $chome;
$returnhash{'domain'} = $cdomain;
$returnhash{'num'} = $cnum;
@@ -3996,8 +4094,8 @@ sub coursedescription {
$envhash{'course.'.$normalid.'.'.$name}=$value;
}
$returnhash{'url'}=&clutter($returnhash{'url'});
- $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
- $env{'user.name'}.'_'.$cdomain.'_'.$cnum;
+ $returnhash{'fn'}=LONCAPA::tempdir() .
+ $username.'_'.$cdomain.'_'.$cnum;
$envhash{'course.'.$normalid.'.home'}=$chome;
$envhash{'course.'.$normalid.'.domain'}=$cdomain;
$envhash{'course.'.$normalid.'.num'}=$cnum;
@@ -4780,7 +4878,7 @@ sub tmpget {
return %returnhash;
}
-# ------------------------------------------------------------ tmpget interface
+# ------------------------------------------------------------ tmpdel interface
sub tmpdel {
my ($token,$server)=@_;
if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
@@ -5947,7 +6045,7 @@ sub fetch_enrollment_query {
$$replyref{$key} = $value;
}
} else {
- my $pathname = $perlvar{'lonDaemons'}.'/tmp';
+ my $pathname = LONCAPA::tempdir();
foreach my $line (@responses) {
my ($key,$value) = split(/=/,$line);
$$replyref{$key} = $value;
@@ -5977,7 +6075,7 @@ sub fetch_enrollment_query {
sub get_query_reply {
my $queryid=shift;
- my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;
+ my $replyfile=LONCAPA::tempdir().$queryid;
my $reply='';
for (1..100) {
sleep 2;
@@ -7414,7 +7512,7 @@ sub save_selected_files {
sub clear_selected_files {
my ($user) = @_;
my $filename = $user."savedfiles";
- open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
+ open (OUT, '>'.LONCAPA::tempdir().$filename);
print (OUT undef);
close (OUT);
return ("ok");
@@ -7424,7 +7522,7 @@ sub files_in_path {
my ($user, $path) = @_;
my $filename = $user."savedfiles";
my %return_files;
- open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
+ open (IN, '<'.LONCAPA::tempdir().$filename);
while (my $line_in = <IN>) {
chomp ($line_in);
my @paths_and_file = split (m!/!, $line_in);
@@ -7446,7 +7544,7 @@ sub files_not_in_path {
my $filename = $user."savedfiles";
my @return_files;
my $path_part;
- open(IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
+ open(IN, '<'.LONCAPA::.$filename);
while (my $line = <IN>) {
#ok, I know it's clunky, but I want it to work
my @paths_and_file = split(m|/|, $line);
@@ -8521,7 +8619,7 @@ sub metadata {
if (($uri eq '') ||
(($uri =~ m|^/*adm/|) &&
($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
- ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$}) || ($uri =~ m{^/*uploaded/$match_domain/$match_courseid/docs/})) {
+ ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
return undef;
}
if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/})
@@ -8567,7 +8665,8 @@ sub metadata {
&Apache::lonnet::ssi_body($which,
('grade_target' => 'meta'));
$cachetime = 1; # only want this cached in the child not long term
- } elsif ($uri !~ m -^(editupload)/-) {
+ } elsif (($uri !~ m -^(editupload)/-) &&
+ ($uri !~ m{^/*uploaded/$match_domain/$match_courseid/docs/})) {
my $file=&filelocation('',&clutter($filename));
#push(@{$metaentry{$uri.'.file'}},$file);
$metastring=&getfile($file);
@@ -9739,7 +9838,7 @@ sub filelocation {
my @ids=¤t_machine_ids();
foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
if ($is_me) {
- $location=&propath($udom,$uname).'/userfiles/'.$filename;
+ $location=propath($udom,$uname).'/userfiles/'.$filename;
} else {
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
$udom.'/'.$uname.'/'.$filename;
@@ -10061,13 +10160,19 @@ sub get_dns {
my $loaded;
my %name_to_host;
my %internetdom;
+ my %LC_dns_serv;
sub parse_hosts_tab {
my ($file) = @_;
foreach my $configline (@$file) {
next if ($configline =~ /^(\#|\s*$ )/x);
- next if ($configline =~ /^\^/);
- chomp($configline);
+ chomp($configline);
+ if ($configline =~ /^\^/) {
+ if ($configline =~ /^\^([\w.\-]+)/) {
+ $LC_dns_serv{$1} = 1;
+ }
+ next;
+ }
my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);
$name=~s/\s//g;
if ($id && $domain && $role && $name) {
@@ -10203,6 +10308,14 @@ sub get_dns {
my ($lonid) = @_;
return $internetdom{$lonid};
}
+
+ sub is_LC_dns {
+ &load_hosts_tab() if (!$loaded);
+
+ my ($hostname) = @_;
+ return exists($LC_dns_serv{$hostname});
+ }
+
}
{
@@ -10480,7 +10593,7 @@ BEGIN {
# ------------- set up temporary directory
{
- $tmpdir = $perlvar{'lonDaemons'}.'/tmp/';
+ $tmpdir = LONCAPA::tempdir();
}
@@ -10974,11 +11087,32 @@ revokecustomrole($udom,$uname,$url,$role
=item *
-coursedescription($courseid) : returns a hash of information about the
+coursedescription($courseid,$options) : returns a hash of information about the
specified course id, including all environment settings for the
course, the description of the course will be in the hash under the
key 'description'
+$options is an optional parameter that if supplied is a hash reference that controls
+what how this function works. It has the following key/values:
+
+=over 4
+
+=item freshen_cache
+
+If defined, and the environment cache for the course is valid, it is
+returned in the returned hash.
+
+=item one_time
+
+If defined, the last cache time is set to _now_
+
+=item user
+
+If defined, the supplied username is used instead of the current user.
+
+
+=back
+
=item *
resdata($name,$domain,$type,@which) : request for current parameter
@@ -11371,11 +11505,12 @@ splitting on '&', supports elements that
=head2 Logging Routines
-=over 4
These routines allow one to make log messages in the lonnet.log and
lonnet.perm logfiles.
+=over 4
+
=item *
logtouch() : make sure the logfile, lonnet.log, exists
@@ -11391,6 +11526,7 @@ logperm() : append a permanent message t
file never gets deleted by any automated portion of the system, only
messages of critical importance should go in here.
+
=back
=head2 General File Helper Routines