--- loncom/lonnet/perl/lonnet.pm 2005/06/29 11:57:17 1.644
+++ loncom/lonnet/perl/lonnet.pm 2006/01/10 16:08:10 1.693
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.644 2005/06/29 11:57:17 www Exp $
+# $Id: lonnet.pm,v 1.693 2006/01/10 16:08:10 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -37,11 +37,11 @@ use HTTP::Date;
use vars
qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom
%libserv %pr %prp $memcache %packagetab
- %courselogs %accesshash %userrolehash $processmarker $dumpcount
+ %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf
%domaindescription %domain_auth_def %domain_auth_arg_def
- %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit
- %env);
+ %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary
+ $tmpdir $_64bit %env);
use IO::Socket;
use GDBM_File;
@@ -49,10 +49,11 @@ use Apache::Constants qw(:common :http);
use HTML::LCParser;
use HTML::Parser;
use Fcntl qw(:flock);
-use Apache::lonlocal;
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
use Time::HiRes qw( gettimeofday tv_interval );
use Cache::Memcached;
+use Digest::MD5;
+
my $readit;
my $max_connection_retries = 10; # Or some such value.
@@ -166,7 +167,7 @@ sub reply {
unless (defined($hostname{$server})) { return 'no_such_host'; }
my $answer=subreply($cmd,$server);
if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
- &logthis("<font color=blue>WARNING:".
+ &logthis("<font color=\"blue\">WARNING:".
" $cmd to $server returned $answer</font>");
}
return $answer;
@@ -190,14 +191,14 @@ sub reconlonc {
sleep 5;
if (-e "$peerfile") { return; }
&logthis(
- "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
+ "<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>");
} else {
&logthis(
- "<font color=blue>WARNING:".
+ "<font color=\"blue\">WARNING:".
" lonc at pid $loncpid not responding, giving up</font>");
}
} else {
- &logthis('<font color=blue>WARNING: lonc not running, giving up</font>');
+ &logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
}
}
@@ -206,7 +207,7 @@ sub reconlonc {
sub critical {
my ($cmd,$server)=@_;
unless ($hostname{$server}) {
- &logthis("<font color=blue>WARNING:".
+ &logthis("<font color=\"blue\">WARNING:".
" Critical message to unknown server ($server)</font>");
return 'no_such_host';
}
@@ -240,12 +241,12 @@ sub critical {
}
chomp($wcmd);
if ($wcmd eq $cmd) {
- &logthis("<font color=blue>WARNING: ".
+ &logthis("<font color=\"blue\">WARNING: ".
"Connection buffer $dfilename: $cmd</font>");
&logperm("D:$server:$cmd");
return 'con_delayed';
} else {
- &logthis("<font color=red>CRITICAL:"
+ &logthis("<font color=\"red\">CRITICAL:"
." Critical connection failed: $server $cmd</font>");
&logperm("F:$server:$cmd");
return 'con_failed';
@@ -270,7 +271,7 @@ sub transfer_profile_to_env {
my %Remove;
for ($envi=0;$envi<=$#profile;$envi++) {
chomp($profile[$envi]);
- my ($envname,$envvalue)=split(/=/,$profile[$envi]);
+ my ($envname,$envvalue)=split(/=/,$profile[$envi],2);
$env{$envname} = $envvalue;
if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
if ($time < time-300) {
@@ -288,14 +289,14 @@ sub transfer_profile_to_env {
sub appenv {
my %newenv=@_;
- foreach (keys %newenv) {
- if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
- &logthis("<font color=blue>WARNING: ".
- "Attempt to modify environment ".$_." to ".$newenv{$_}
+ foreach my $key (keys(%newenv)) {
+ if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) {
+ &logthis("<font color=\"blue\">WARNING: ".
+ "Attempt to modify environment ".$key." to ".$newenv{$key}
.'</font>');
- delete($newenv{$_});
+ delete($newenv{$key});
} else {
- $env{$_}=$newenv{$_};
+ $env{$key}=$newenv{$key};
}
}
@@ -304,7 +305,7 @@ sub appenv {
return 'error: '.$!;
}
unless (flock($lockfh,LOCK_EX)) {
- &logthis("<font color=blue>WARNING: ".
+ &logthis("<font color=\"blue\">WARNING: ".
'Could not obtain exclusive lock in appenv: '.$!);
close($lockfh);
return 'error: '.$!;
@@ -322,7 +323,7 @@ sub appenv {
for (my $i=0; $i<=$#oldenv; $i++) {
chomp($oldenv[$i]);
if ($oldenv[$i] ne '') {
- my ($name,$value)=split(/=/,$oldenv[$i]);
+ my ($name,$value)=split(/=/,$oldenv[$i],2);
unless (defined($newenv{$name})) {
$newenv{$name}=$value;
}
@@ -349,7 +350,7 @@ sub delenv {
my $delthis=shift;
my %newenv=();
if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
- &logthis("<font color=blue>WARNING: ".
+ &logthis("<font color=\"blue\">WARNING: ".
"Attempt to delete from environment ".$delthis);
return 'error';
}
@@ -360,7 +361,7 @@ sub delenv {
return 'error';
}
unless (flock($fh,LOCK_SH)) {
- &logthis("<font color=blue>WARNING: ".
+ &logthis("<font color=\"blue\">WARNING: ".
'Could not obtain shared lock in delenv: '.$!);
close($fh);
return 'error: '.$!;
@@ -374,17 +375,17 @@ sub delenv {
return 'error';
}
unless (flock($fh,LOCK_EX)) {
- &logthis("<font color=blue>WARNING: ".
+ &logthis("<font color=\"blue\">WARNING: ".
'Could not obtain exclusive lock in delenv: '.$!);
close($fh);
return 'error: '.$!;
}
- foreach (@oldenv) {
- if ($_=~/^$delthis/) {
- my ($key,undef) = split('=',$_);
+ foreach my $cur_key (@oldenv) {
+ if ($cur_key=~/^$delthis/) {
+ my ($key,undef) = split('=',$cur_key,2);
delete($env{$key});
} else {
- print $fh $_;
+ print $fh $cur_key;
}
}
close($fh);
@@ -443,15 +444,15 @@ sub overloaderror {
# ------------------------------ Find server with least workload from spare.tab
sub spareserver {
- my ($loadpercent,$userloadpercent) = @_;
+ my ($loadpercent,$userloadpercent,$want_server_name) = @_;
my $tryserver;
my $spareserver='';
if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
my $lowestserver=$loadpercent > $userloadpercent?
$loadpercent : $userloadpercent;
- foreach $tryserver (keys %spareid) {
- my $loadans=reply('load',$tryserver);
- my $userloadans=reply('userload',$tryserver);
+ foreach $tryserver (keys(%spareid)) {
+ my $loadans=&reply('load',$tryserver);
+ my $userloadans=&reply('userload',$tryserver);
if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
next; #didn't get a number from the server
}
@@ -468,7 +469,11 @@ sub spareserver {
$answer = $userloadans;
}
if (($answer =~ /\d/) && ($answer<$lowestserver)) {
- $spareserver="http://$hostname{$tryserver}";
+ if ($want_server_name) {
+ $spareserver=$tryserver;
+ } else {
+ $spareserver="http://$hostname{$tryserver}";
+ }
$lowestserver=$answer;
}
}
@@ -767,6 +772,13 @@ sub validate_access_key {
}
# ------------------------------------- Find the section of student in a course
+sub devalidate_getsection_cache {
+ my ($udom,$unam,$courseid)=@_;
+ $courseid=~s/\_/\//g;
+ $courseid=~s/^(\w)/\/$1/;
+ my $hashid="$udom:$unam:$courseid";
+ &devalidate_cache_new('getsection',$hashid);
+}
sub getsection {
my ($udom,$unam,$courseid)=@_;
@@ -1053,7 +1065,7 @@ sub repcopy {
if ($response->is_error()) {
unlink($transname);
my $message=$response->status_line;
- &logthis("<font color=blue>WARNING:"
+ &logthis("<font color=\"blue\">WARNING:"
." LWP get: $message: $filename</font>");
return 'unavailable';
} else {
@@ -1063,7 +1075,7 @@ sub repcopy {
if ($mresponse->is_error()) {
unlink($filename.'.meta');
&logthis(
- "<font color=yellow>INFO: No metadata: $filename</font>");
+ "<font color=\"yellow\">INFO: No metadata: $filename</font>");
}
}
rename($transname,$filename);
@@ -1169,7 +1181,6 @@ sub process_coursefile {
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
$home);
} else {
- my $fetchresult = '';
my $fpath = '';
my $fname = $file;
($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
@@ -1269,8 +1280,15 @@ sub clean_filename {
}
# --------------- Take an uploaded file and put it into the userfiles directory
-# input: name of form element, coursedoc=1 means this is for the course
-# output: url of file in userspace
+# input: $formname - the contents of the file are in $env{"form.$formname"}
+# the desired filenam is in $env{"form.$formname"}
+# $coursedoc - if true up to the current course
+# if false
+# $subdir - directory in userfile to store the file into
+# $parser, $allfiles, $codebase - unknown
+#
+# output: url of file in userspace, or error: <message>
+# or /adm/notfound.html if failure to upload occurse
sub userfileupload {
@@ -1302,7 +1320,7 @@ sub userfileupload {
if ($coursedoc) {
my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
- if ($env{'form.folder'} =~ m/^default/) {
+ if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
return &finishuserfileupload($docuname,$docudom,
$formname,$fname,$parser,$allfiles,
$codebase);
@@ -1368,7 +1386,7 @@ sub finishuserfileupload {
}
sub extract_embedded_items {
- my ($filepath,$file,$allfiles,$codebase) = @_;
+ my ($filepath,$file,$allfiles,$codebase,$content) = @_;
my @state = ();
my %javafiles = (
codebase => '',
@@ -1379,14 +1397,34 @@ sub extract_embedded_items {
src => '',
movie => '',
);
- my $p = HTML::LCParser->new($filepath.'/'.$file);
+ my $p;
+ if ($content) {
+ $p = HTML::LCParser->new($content);
+ } else {
+ $p = HTML::LCParser->new($filepath.'/'.$file);
+ }
while (my $t=$p->get_token()) {
if ($t->[0] eq 'S') {
my ($tagname, $attr) = ($t->[1],$t->[2]);
push (@state, $tagname);
+ if (lc($tagname) eq 'allow') {
+ &add_filetype($allfiles,$attr->{'src'},'src');
+ }
if (lc($tagname) eq 'img') {
&add_filetype($allfiles,$attr->{'src'},'src');
}
+ if (lc($tagname) eq 'script') {
+ if ($attr->{'archive'} =~ /\.jar$/i) {
+ &add_filetype($allfiles,$attr->{'archive'},'archive');
+ } else {
+ &add_filetype($allfiles,$attr->{'src'},'src');
+ }
+ }
+ if (lc($tagname) eq 'link') {
+ if (lc($attr->{'rel'}) eq 'stylesheet') {
+ &add_filetype($allfiles,$attr->{'href'},'href');
+ }
+ }
if (lc($tagname) eq 'object' ||
(lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')) {
foreach my $item (keys(%javafiles)) {
@@ -1512,7 +1550,7 @@ sub flushcourselogs {
} else {
&logthis('Failed to flush log buffer for '.$crsid);
if (length($courselogs{$crsid})>40000) {
- &logthis("<font color=blue>WARNING: Buffer for ".$crsid.
+ &logthis("<font color=\"blue\">WARNING: Buffer for ".$crsid.
" exceeded maximum size, deleting.</font>");
delete $courselogs{$crsid};
}
@@ -1583,6 +1621,31 @@ sub flushcourselogs {
delete $userrolehash{$entry};
}
}
+#
+# Reverse lookup of domain roles (dc, ad, li, sc, au)
+#
+ my %domrolebuffer = ();
+ foreach my $entry (keys %domainrolehash) {
+ my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry;
+ if ($domrolebuffer{$rudom}) {
+ $domrolebuffer{$rudom}.='&'.&escape($entry).
+ '='.&escape($domainrolehash{$entry});
+ } else {
+ $domrolebuffer{$rudom}.=&escape($entry).
+ '='.&escape($domainrolehash{$entry});
+ }
+ delete $domainrolehash{$entry};
+ }
+ foreach my $dom (keys(%domrolebuffer)) {
+ foreach my $tryserver (keys %libserv) {
+ if ($hostdom{$tryserver} eq $dom) {
+ unless (&reply('domroleput:'.$dom.':'.
+ $domrolebuffer{$dom},$tryserver) eq 'ok') {
+ &logthis('Put of domain roles failed for '.$dom.' and '.$tryserver);
+ }
+ }
+ }
+ }
$dumpcount++;
}
@@ -1616,7 +1679,7 @@ sub courseacclog {
my $fnsymb=shift;
unless ($env{'request.course.id'}) { return ''; }
my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};
- if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) {
+ if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) {
$what.=':POST';
# FIXME: Probably ought to escape things....
foreach (keys %env) {
@@ -1658,14 +1721,24 @@ sub linklog {
sub userrolelog {
my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
- if (($trole=~/^ca/) || ($trole=~/^in/) ||
- ($trole=~/^cc/) || ($trole=~/^ep/) ||
- ($trole=~/^cr/) || ($trole=~/^ta/)) {
+ if (($trole=~/^ca/) || ($trole=~/^aa/) ||
+ ($trole=~/^in/) || ($trole=~/^cc/) ||
+ ($trole=~/^ep/) || ($trole=~/^cr/) ||
+ ($trole=~/^ta/)) {
my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
$userrolehash
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
=$tend.':'.$tstart;
- }
+ }
+ if (($trole=~/^dc/) || ($trole=~/^ad/) ||
+ ($trole=~/^li/) || ($trole=~/^li/) ||
+ ($trole=~/^au/) || ($trole=~/^dg/) ||
+ ($trole=~/^sc/)) {
+ my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
+ $domainrolehash
+ {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
+ = $tend.':'.$tstart;
+ }
}
sub get_course_adv_roles {
@@ -1689,7 +1762,11 @@ sub get_course_adv_roles {
if ($username eq '' || $domain eq '') { next; }
if ((&privileged($username,$domain)) &&
(!$nothide{$username.':'.$domain})) { next; }
+ if ($role eq 'cr') { next; }
my $key=&plaintext($role);
+ if ($role =~ /^cr/) {
+ $key=(split('/',$role))[3];
+ }
if ($section) { $key.=' (Sec/Grp '.$section.')'; }
if ($returnhash{$key}) {
$returnhash{$key}.=','.$username.':'.$domain;
@@ -1780,7 +1857,62 @@ sub courseiddump {
return %returnhash;
}
-#
+# ---------------------------------------------------------- DC e-mail
+
+sub dcmailput {
+ my ($domain,$msgid,$message,$server)=@_;
+ my $status = &Apache::lonnet::critical(
+ 'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='.
+ &Apache::lonnet::escape($message),$server);
+ return $status;
+}
+
+sub dcmaildump {
+ my ($dom,$startdate,$enddate,$senders) = @_;
+ my %returnhash=();
+ if (exists($domain_primary{$dom})) {
+ my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
+ &escape($enddate).':';
+ my @esc_senders=map { &escape($_)} @$senders;
+ $cmd.=&escape(join('&',@esc_senders));
+ foreach (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {
+ my ($key,$value) = split(/\=/,$_);
+ if (($key) && ($value)) {
+ $returnhash{&unescape($key)} = &unescape($value);
+ }
+ }
+ }
+ return %returnhash;
+}
+# ---------------------------------------------------------- Domain roles
+
+sub get_domain_roles {
+ my ($dom,$roles,$startdate,$enddate)=@_;
+ if (undef($startdate) || $startdate eq '') {
+ $startdate = '.';
+ }
+ if (undef($enddate) || $enddate eq '') {
+ $enddate = '.';
+ }
+ my $rolelist = join(':',@{$roles});
+ my %personnel = ();
+ foreach my $tryserver (keys(%libserv)) {
+ if ($hostdom{$tryserver} eq $dom) {
+ %{$personnel{$tryserver}}=();
+ foreach (
+ split(/\&/,&reply('domrolesdump:'.$dom.':'.
+ &escape($startdate).':'.&escape($enddate).':'.
+ &escape($rolelist), $tryserver))) {
+ my($key,$value) = split(/\=/,$_);
+ if (($key) && ($value)) {
+ $personnel{$tryserver}{&unescape($key)} = &unescape($value);
+ }
+ }
+ }
+ }
+ return %personnel;
+}
+
# ----------------------------------------------------------- Check out an item
sub get_first_access {
@@ -1826,7 +1958,7 @@ sub checkout {
$now.'&'.$ENV{'REMOTE_ADDR'});
my $token=&reply('tmpput:'.$infostr,$lonhost);
if ($token=~/^error\:/) {
- &logthis("<font color=blue>WARNING: ".
+ &logthis("<font color=\"blue\">WARNING: ".
"Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
"</font>");
return '';
@@ -1842,7 +1974,7 @@ sub checkout {
unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
return '';
} else {
- &logthis("<font color=blue>WARNING: ".
+ &logthis("<font color=\"blue\">WARNING: ".
"Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
"</font>");
}
@@ -1852,7 +1984,7 @@ sub checkout {
$token)) ne 'ok') {
return '';
} else {
- &logthis("<font color=blue>WARNING: ".
+ &logthis("<font color=\"blue\">WARNING: ".
"Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
"</font>");
}
@@ -2447,19 +2579,28 @@ sub rolesinit {
my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
my %allroles=();
+ my %allgroups=();
my $now=time;
my $userroles="user.login.time=$now\n";
+ my $group_privs;
if ($rolesdump ne '') {
foreach (split(/&/,$rolesdump)) {
if ($_!~/^rolesdef_/) {
my ($area,$role)=split(/=/,$_);
$area=~s/\_\w\w$//;
-
- my ($trole,$tend,$tstart);
+ my ($trole,$tend,$tstart,$group_privs);
if ($role=~/^cr/) {
- ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|);
- ($tend,$tstart)=split('_',$trest);
+ if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) {
+ ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|);
+ ($tend,$tstart)=split('_',$trest);
+ } else {
+ $trole=$role;
+ }
+ } elsif ($role =~ m|^gr/|) {
+ ($trole,$tend,$tstart) = split(/_/,$role);
+ ($trole,$group_privs) = split(/\//,$trole);
+ $group_privs = &unescape($group_privs);
} else {
($trole,$tend,$tstart)=split(/_/,$role);
}
@@ -2471,13 +2612,15 @@ sub rolesinit {
my ($tdummy,$tdomain,$trest)=split(/\//,$area);
if ($trole =~ /^cr\//) {
&custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
+ } elsif ($trole eq 'gr') {
+ &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
} else {
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
}
}
- }
+ }
}
- my ($author,$adv) = &set_userprivs(\$userroles,\%allroles);
+ my ($author,$adv) = &set_userprivs(\$userroles,\%allroles,\%allgroups);
$userroles.='user.adv='.$adv."\n".
'user.author='.$author."\n";
$env{'user.adv'}=$adv;
@@ -2519,6 +2662,17 @@ sub custom_roleprivs {
}
}
+sub group_roleprivs {
+ my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
+ my $access = 1;
+ my $now = time;
+ if (($tend!=0) && ($tend<$now)) { $access = 0; }
+ if (($tstart!=0) && ($tstart>$now)) { $access=0; }
+ if ($access) {
+ my ($course,$group) = ($area =~ m|(/\w+/\w+)/([^/]+)$|);
+ $$allgroups{$course}{$group} .=':'.$group_privs;
+ }
+}
sub standard_roleprivs {
my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;
@@ -2539,9 +2693,31 @@ sub standard_roleprivs {
}
sub set_userprivs {
- my ($userroles,$allroles) = @_;
+ my ($userroles,$allroles,$allgroups) = @_;
my $author=0;
my $adv=0;
+ my %grouproles = ();
+ if (keys(%{$allgroups}) > 0) {
+ foreach my $role (keys %{$allroles}) {
+ my ($trole,$area,$sec,$extendedarea);
+ if ($role =~ m|^(\w+)\.(/\w+/\w+)(/?\w*)|) {
+ $trole = $1;
+ $area = $2;
+ $sec = $3;
+ $extendedarea = $area.$sec;
+ if (exists($$allgroups{$area})) {
+ foreach my $group (keys(%{$$allgroups{$area}})) {
+ my $spec = $trole.'.'.$extendedarea;
+ $grouproles{$spec.'.'.$area.'/'.$group} =
+ $$allgroups{$area}{$group};
+ }
+ }
+ }
+ }
+ }
+ foreach (keys(%grouproles)) {
+ $$allroles{$_} = $grouproles{$_};
+ }
foreach (keys %{$allroles}) {
my %thesepriv=();
if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
@@ -2828,6 +3004,37 @@ sub eget {
return %returnhash;
}
+# ------------------------------------------------------------ tmpput interface
+sub tmpput {
+ my ($storehash,$server)=@_;
+ my $items='';
+ foreach (keys(%$storehash)) {
+ $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
+ }
+ $items=~s/\&$//;
+ return &reply("tmpput:$items",$server);
+}
+
+# ------------------------------------------------------------ tmpget interface
+sub tmpget {
+ my ($token,$server)=@_;
+ if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
+ my $rep=&reply("tmpget:$token",$server);
+ my %returnhash;
+ foreach my $item (split(/\&/,$rep)) {
+ my ($key,$value)=split(/=/,$item);
+ $returnhash{&unescape($key)}=&thaw_unescape($value);
+ }
+ return %returnhash;
+}
+
+# ------------------------------------------------------------ tmpget interface
+sub tmpdel {
+ my ($token,$server)=@_;
+ if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
+ return &reply("tmpdel:$token",$server);
+}
+
# ---------------------------------------------- Custom access rule evaluation
sub customaccess {
@@ -2870,8 +3077,6 @@ 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 !~ m|/bulletinboard$|))
@@ -2881,7 +3086,7 @@ sub allowed {
# Free bre access to user's own portfolio contents
my ($space,$domain,$name,$dir)=split('/',$uri);
- if (($space=~/^(uploaded|ediupload)$/) && ($env{'user.name'} eq $name) &&
+ if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&
($env{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {
return 'F';
}
@@ -2918,7 +3123,7 @@ sub allowed {
if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) {
# uri is the requested domain in this case.
# comparison to 'request.role.domain' shows if the user has selected
- # a role of dc for the domain in question.
+ # a role of dc for the domain in question.
return 'F' if ($uri eq $env{'request.role.domain'});
}
@@ -2949,15 +3154,38 @@ sub allowed {
$thisallowed.=$1;
}
-# URI is an uploaded document for this course
+# Group: uri itself is a group
+ my $groupuri=$uri;
+ $groupuri=~s/^([^\/])/\/$1/;
+ if ($env{'user.priv.'.$env{'request.role'}.'.'.$groupuri}
+ =~/\Q$priv\E\&([^\:]*)/) {
+ $thisallowed.=$1;
+ }
+
+# URI is an uploaded document for this course, default permissions don't matter
# not allowing 'edit' access (editupload) to uploaded course docs
if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
- my $refuri=$env{'httpref.'.$orguri};
- if ($refuri) {
- if ($refuri =~ m|^/adm/|) {
- $thisallowed='F';
- }
- }
+ $thisallowed='';
+ my ($match)=&is_on_map($uri);
+ if ($match) {
+ if ($env{'user.priv.'.$env{'request.role'}.'./'}
+ =~/\Q$priv\E\&([^\:]*)/) {
+ $thisallowed.=$1;
+ }
+ } else {
+ my $refuri=$env{'httpref.'.$orguri};
+ if ($refuri) {
+ if ($refuri =~ m|^/adm/|) {
+ $thisallowed='F';
+ } else {
+ $refuri=&declutter($refuri);
+ my ($match) = &is_on_map($refuri);
+ if ($match) {
+ $thisallowed='F';
+ }
+ }
+ }
+ }
}
# Full access at system, domain or course-wide level? Exit.
@@ -3125,17 +3353,21 @@ sub allowed {
my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
=~/\Q$rolecode\E/) {
- &log($env{'user.domain'},$env{'user.name'},$env{'user.host'},
- 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
- $env{'request.course.id'});
+ if ($priv ne 'pch') {
+ &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
+ 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
+ $env{'request.course.id'});
+ }
return '';
}
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
=~/\Q$unamedom\E/) {
- &log($env{'user.domain'},$env{'user.name'},$env{'user.host'},
- 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
- $env{'request.course.id'});
+ if ($priv ne 'pch') {
+ &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
+ 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
+ $env{'request.course.id'});
+ }
return '';
}
}
@@ -3145,9 +3377,11 @@ sub allowed {
if ($thisallowed=~/R/) {
my $rolecode=(split(/\./,$env{'request.role'}))[0];
if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
- &log($env{'user.domain'},$env{'user.name'},$env{'user.host'},
- 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
- return '';
+ if ($priv ne 'pch') {
+ &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
+ 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
+ }
+ return '';
}
}
@@ -3173,8 +3407,7 @@ sub allowed {
# --------------------------------------------------- Is a resource on the map?
sub is_on_map {
- my $uri=&declutter(shift);
- $uri=~s/\.\d+\.(\w+)$/\.$1/;
+ my $uri=&deversion(&declutter(shift));
my @uriparts=split(/\//,$uri);
my $filename=$uriparts[$#uriparts];
my $pathname=$uri;
@@ -3485,11 +3718,102 @@ sub auto_instcode_format {
return $response;
}
+# ------------------------------------------------------- Course Group routines
+
+sub get_coursegroups {
+ my ($cdom,$cnum,$group) = @_;
+ return(&dump('coursegroups',$cdom,$cnum,$group));
+}
+
+sub modify_coursegroup {
+ my ($cdom,$cnum,$groupsettings) = @_;
+ return(&put('coursegroups',$groupsettings,$cdom,$cnum));
+}
+
+sub modify_group_roles {
+ my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
+ my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
+ my $role = 'gr/'.&escape($userprivs);
+ my ($uname,$udom) = split(/:/,$user);
+ my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
+ if ($result eq 'ok') {
+ &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
+ }
+
+ return $result;
+}
+
+sub modify_coursegroup_membership {
+ my ($cdom,$cnum,$membership) = @_;
+ my $result = &put('groupmembership',$membership,$cdom,$cnum);
+ return $result;
+}
+
+sub get_active_groups {
+ my ($udom,$uname,$cdom,$cnum) = @_;
+ my $now = time;
+ my %groups = ();
+ foreach my $key (keys(%env)) {
+ if ($key =~ m-user\.role\.gr\./([^/]+)/([^/]+)/(\w+)$-) {
+ my ($start,$end) = split(/\./,$env{$key});
+ if (($end!=0) && ($end<$now)) { next; }
+ if (($start!=0) && ($start>$now)) { next; }
+ if ($1 eq $cdom && $2 eq $cnum) {
+ $groups{$3} = $env{$key} ;
+ }
+ }
+ }
+ return %groups;
+}
+
+sub get_group_membership {
+ my ($cdom,$cnum,$group) = @_;
+ return(&dump('groupmembership',$cdom,$cnum,$group));
+}
+
+sub get_users_groups {
+ my ($udom,$uname,$courseid) = @_;
+ my $cachetime=1800;
+ $courseid=~s/\_/\//g;
+ $courseid=~s/^(\w)/\/$1/;
+
+ my $hashid="$udom:$uname:$courseid";
+ my ($result,$cached)=&is_cached_new('getgroups',$hashid);
+ if (defined($cached)) { return $result; }
+
+ my %roleshash = &dump('roles',$udom,$uname,$courseid);
+ my ($tmp) = keys(%roleshash);
+ if ($tmp=~/^error:/) {
+ &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);
+ return '';
+ } else {
+ my $grouplist;
+ foreach my $key (keys %roleshash) {
+ if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
+ unless ($roleshash{$key} =~ /_1_1$/) { # deleted membership
+ $grouplist .= $1.':';
+ }
+ }
+ }
+ $grouplist =~ s/:$//;
+ return &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
+ }
+}
+
+sub devalidate_getgroups_cache {
+ my ($udom,$uname,$cdom,$cnum)=@_;
+ my $courseid = $cdom.'_'.$cnum;
+ $courseid=~s/\_/\//g;
+ $courseid=~s/^(\w)/\/$1/;
+ my $hashid="$udom:$uname:$courseid";
+ &devalidate_cache_new('getgroups',$hashid);
+}
+
# ------------------------------------------------------------------ Plain Text
sub plaintext {
my $short=shift;
- return &mt($prp{$short});
+ return &Apache::lonlocal::mt($prp{$short});
}
# ----------------------------------------------------------------- Assign Role
@@ -3507,6 +3831,16 @@ sub assignrole {
return 'refused';
}
$mrole='cr';
+ } elsif ($role =~ /^gr\//) {
+ my $cwogrp=$url;
+ $cwogrp=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
+ unless (&allowed('mdg',$cwogrp)) {
+ &logthis('Refused group assignrole: '.
+ $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
+ $env{'user.name'}.' at '.$env{'user.domain'});
+ return 'refused';
+ }
+ $mrole='gr';
} else {
my $cwosec=$url;
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
@@ -3544,7 +3878,7 @@ sub assignrole {
my $answer=&reply($command,&homeserver($uname,$udom));
# log new user role if status is ok
if ($answer eq 'ok') {
- &userrolelog($mrole,$uname,$udom,$url,$start,$end);
+ &userrolelog($role,$uname,$udom,$url,$start,$end);
}
return $answer;
}
@@ -3667,6 +4001,7 @@ sub modifyuser {
}
my $reply = &put('environment', \%names, $udom,$uname);
if ($reply ne 'ok') { return 'error: '.$reply; }
+ &devalidate_cache_new('namescache',$uname.':'.$udom);
&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.
$last.', '.$gene.' by '.
@@ -3747,6 +4082,8 @@ sub modify_student_enrollment {
$cdom,$cnum);
unless (($reply eq 'ok') || ($reply eq 'delayed')) {
return 'error: '.$reply;
+ } else {
+ &devalidate_getsection_cache($udom,$uname,$cid);
}
# Add student role to user
my $uurl='/'.$cid;
@@ -3805,7 +4142,9 @@ sub createcourse {
return 'refused';
}
# ------------------------------------------------------------------- Create ID
- my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
+ my $uname=int(1+rand(9)).
+ ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
+ substr($$.time,0,5).unpack("H8",pack("I32",time)).
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
# ----------------------------------------------- Make sure that does not exist
my $uhome=&homeserver($uname,$udom,'true');
@@ -4054,28 +4393,25 @@ sub unmark_as_readonly {
my ($tmp)=keys(%current_permissions);
if ($tmp=~/^error:/) { undef(%current_permissions); }
my @readonly_files = &get_marked_as_readonly($domain,$user,$what);
- foreach my $file(@readonly_files){
- my $current_locks = $current_permissions{$file};
+ foreach my $file (@readonly_files) {
+ if (defined($file_name) && ($file_name ne $file)) { next; }
+ my $current_locks = $current_permissions{$file};
my @new_locks;
my @del_keys;
if (ref($current_locks) eq "ARRAY"){
foreach my $locker (@{$current_locks}) {
my $compare=$locker;
if (ref($locker)) { $compare=join('',@{$locker}) };
- if ($compare eq $symb_crs) {
- if (defined($file_name) && ($file_name ne $file)) {
- push(@new_locks, $what);
- }
- } else {
- push(@new_locks, $what);
+ if ($compare ne $symb_crs) {
+ push(@new_locks, $locker);
}
}
- if (@new_locks > 0) {
+ if (scalar(@new_locks) > 0) {
$current_permissions{$file} = \@new_locks;
} else {
push(@del_keys, $file);
&del('file_permissions',\@del_keys, $domain, $user);
- delete $current_permissions{$file};
+ delete($current_permissions{$file});
}
}
}
@@ -4316,7 +4652,7 @@ sub get_userresdata {
}
#error 2 occurs when the .db doesn't exist
if ($tmp!~/error: 2 /) {
- &logthis("<font color=blue>WARNING:".
+ &logthis("<font color=\"blue\">WARNING:".
" Trying to get resource data for ".
$uname." at ".$udom.": ".
$tmp."</font>");
@@ -4403,8 +4739,10 @@ sub EXT {
if ($realm eq 'user') {
# --------------------------------------------------------------- user.resource
if ($space eq 'resource') {
- if (defined($Apache::lonhomework::parsing_a_problem) ||
- defined($Apache::lonhomework::parsing_a_task)) {
+ if ( (defined($Apache::lonhomework::parsing_a_problem)
+ || defined($Apache::lonhomework::parsing_a_task))
+ &&
+ ($symbparm eq &symbread()) ) {
return $Apache::lonhomework::history{$qualifierrest};
} else {
my %restored;
@@ -4468,7 +4806,7 @@ sub EXT {
# ------------------------------------------------------------- request.browser
if ($space eq 'browser') {
if ($qualifier eq 'textremote') {
- if (&mt('textual_remote_display') eq 'on') {
+ if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') {
return 1;
} else {
return 0;
@@ -4485,10 +4823,21 @@ sub EXT {
return $env{'course.'.$courseid.'.'.$spacequalifierrest};
} elsif ($realm eq 'resource') {
- my $section;
if (defined($courseid) && $courseid eq $env{'request.course.id'}) {
if (!$symbparm) { $symbparm=&symbread(); }
}
+
+ if ($space eq 'title') {
+ if (!$symbparm) { $symbparm = $env{'request.filename'}; }
+ return &gettitle($symbparm);
+ }
+
+ if ($space eq 'map') {
+ my ($map) = &decode_symb($symbparm);
+ return &symbread($map);
+ }
+
+ my ($section, $group, @groups);
my ($courselevelm,$courselevel);
if ($symbparm && defined($courseid) &&
$courseid eq $env{'request.course.id'}) {
@@ -4505,12 +4854,20 @@ sub EXT {
if (($env{'user.name'} eq $uname) &&
($env{'user.domain'} eq $udom)) {
$section=$env{'request.course.sec'};
+ @groups=&sort_course_groups($env{'request.course.groups'},$courseid);
+ if (@groups > 0) {
+ @groups = sort(@groups);
+ }
} else {
if (! defined($usection)) {
$section=&getsection($udom,$uname,$courseid);
} else {
$section = $usection;
}
+ my $grouplist = &get_users_groups($udom,$uname,$courseid);
+ if ($grouplist) {
+ @groups=&sort_course_groups($grouplist,$courseid);
+ }
}
my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
@@ -4526,12 +4883,17 @@ sub EXT {
my $userreply=&resdata($uname,$udom,'user',
($courselevelr,$courselevelm,
$courselevel));
-
if (defined($userreply)) { return $userreply; }
# ------------------------------------------------ second, check some of course
+ my $coursereply;
+ if (@groups > 0) {
+ $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
+ $mapparm,$spacequalifierrest);
+ if (defined($coursereply)) { return $coursereply; }
+ }
- my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
+ $coursereply=&resdata($env{'course.'.$courseid.'.num'},
$env{'course.'.$courseid.'.domain'},
'course',
($seclevelr,$seclevelm,$seclevel,
@@ -4606,6 +4968,32 @@ sub EXT {
return '';
}
+sub check_group_parms {
+ my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
+ my @groupitems = ();
+ my $resultitem;
+ my @levels = ($symbparm,$mapparm,$what);
+ foreach my $group (@{$groups}) {
+ foreach my $level (@levels) {
+ my $item = $courseid.'.['.$group.'].'.$level;
+ push(@groupitems,$item);
+ }
+ }
+ my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
+ $env{'course.'.$courseid.'.domain'},
+ 'course',@groupitems);
+ return $coursereply;
+}
+
+sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
+ my ($grouplist,$courseid) = @_;
+ my @groups = split/:/,$grouplist;
+ if (@groups > 1) {
+ @groups = sort(@groups);
+ }
+ return @groups;
+}
+
sub packages_tab_default {
my ($uri,$varname)=@_;
my (undef,$part,$name)=split(/\./,$varname);
@@ -5096,6 +5484,9 @@ sub symbread {
if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {
$targetfn = 'adm/wrapper/'.$thisfn;
}
+ if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {
+ $targetfn=$1;
+ }
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
&GDBM_READER(),0640)) {
$syval=$hash{$targetfn};
@@ -5209,8 +5600,37 @@ sub numval3 {
return $total;
}
+sub digest {
+ my ($data)=@_;
+ my $digest=&Digest::MD5::md5($data);
+ my ($a,$b,$c,$d)=unpack("iiii",$digest);
+ my ($e,$f);
+ {
+ use integer;
+ $e=($a+$b);
+ $f=($c+$d);
+ if ($_64bit) {
+ $e=(($e<<32)>>32);
+ $f=(($f<<32)>>32);
+ }
+ }
+ if (wantarray) {
+ return ($e,$f);
+ } else {
+ my $g;
+ {
+ use integer;
+ $g=($e+$f);
+ if ($_64bit) {
+ $g=(($g<<32)>>32);
+ }
+ }
+ return $g;
+ }
+}
+
sub latest_rnd_algorithm_id {
- return '64bit4';
+ return '64bit5';
}
sub get_rand_alg {
@@ -5250,11 +5670,15 @@ sub rndseed {
if (!$username) { $username=$wusername }
my $which=&get_rand_alg();
if (defined(&getCODE())) {
- if ($which eq '64bit4') {
+ if ($which eq '64bit5') {
+ return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
+ } elsif ($which eq '64bit4') {
return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);
} else {
return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
}
+ } elsif ($which eq '64bit5') {
+ return &rndseed_64bit5($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit4') {
return &rndseed_64bit4($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit3') {
@@ -5377,6 +5801,12 @@ sub rndseed_64bit4 {
}
}
+sub rndseed_64bit5 {
+ my ($symb,$courseid,$domain,$username)=@_;
+ my ($num1,$num2)=&digest("$symb,$courseid,$domain,$username");
+ return "$num1:$num2";
+}
+
sub rndseed_CODE_64bit {
my ($symb,$courseid,$domain,$username)=@_;
{
@@ -5415,6 +5845,13 @@ sub rndseed_CODE_64bit4 {
}
}
+sub rndseed_CODE_64bit5 {
+ my ($symb,$courseid,$domain,$username)=@_;
+ my $code = &getCODE();
+ my ($num1,$num2)=&digest("$symb,$courseid,$code");
+ return "$num1:$num2";
+}
+
sub setup_random_from_rndseed {
my ($rndseed)=@_;
if ($rndseed =~/([,:])/) {
@@ -5624,6 +6061,9 @@ sub filelocation {
if ($file=~m:^/~:) { # is a contruction space reference
$location = $file;
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
+ } elsif ($file=~m:^/home/[^/]*/public_html/:) {
+ # is a correct contruction space reference
+ $location = $file;
} elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
my ($udom,$uname,$filename)=
($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-);
@@ -5656,14 +6096,15 @@ sub filelocation {
sub hreflocation {
my ($dir,$file)=@_;
unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
- my $finalpath=filelocation($dir,$file);
- $finalpath=~s-^/home/httpd/html--;
- $finalpath=~s-^/home/(\w+)/public_html/-/~$1/-;
- return $finalpath;
- } elsif ($file=~m-^/home-) {
- $file=~s-^/home/httpd/html--;
+ $file=filelocation($dir,$file);
+ }
+ if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
+ $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
+ } elsif ($file=~m-/home/(\w+)/public_html/-) {
$file=~s-^/home/(\w+)/public_html/-/~$1/-;
- return $file;
+ } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
+ $file=~s-^/home/httpd/lonUsers/([^/]*)/./././([^/]*)/userfiles/
+ -/uploaded/$1/$2/-x;
}
return $file;
}
@@ -5749,13 +6190,6 @@ sub thaw_unescape {
return &unescape($value);
}
-sub mod_perl_version {
- return 1;
- if (defined($perlvar{'MODPERL2'})) {
- return 2;
- }
-}
-
sub correct_line_ends {
my ($result)=@_;
$$result =~s/\r\n/\n/mg;
@@ -5826,7 +6260,7 @@ BEGIN {
# next if /^\#/;
chomp;
my ($domain, $domain_description, $def_auth, $def_auth_arg,
- $def_lang, $city, $longi, $lati) = split(/:/,$_);
+ $def_lang, $city, $longi, $lati, $primary) = split(/:/,$_);
$domain_auth_def{$domain}=$def_auth;
$domain_auth_arg_def{$domain}=$def_auth_arg;
$domaindescription{$domain}=$domain_description;
@@ -5834,6 +6268,7 @@ BEGIN {
$domain_city{$domain}=$city;
$domain_longi{$domain}=$longi;
$domain_lati{$domain}=$lati;
+ $domain_primary{$domain}=$primary;
# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
@@ -5865,14 +6300,21 @@ BEGIN {
sub get_iphost {
if (%iphost) { return %iphost; }
+ my %name_to_ip;
foreach my $id (keys(%hostname)) {
my $name=$hostname{$id};
- my $ip = gethostbyname($name);
- if (!$ip || length($ip) ne 4) {
- &logthis("Skipping host $id name $name no IP found\n");
- next;
+ my $ip;
+ if (!exists($name_to_ip{$name})) {
+ $ip = gethostbyname($name);
+ if (!$ip || length($ip) ne 4) {
+ &logthis("Skipping host $id name $name no IP found\n");
+ next;
+ }
+ $ip=inet_ntoa($ip);
+ $name_to_ip{$name} = $ip;
+ } else {
+ $ip = $name_to_ip{$name};
}
- $ip=inet_ntoa($ip);
push(@{$iphost{$ip}},$id);
}
return %iphost;
@@ -5947,7 +6389,7 @@ $processmarker='_'.time.'_'.$perlvar{'lo
$dumpcount=0;
&logtouch();
-&logthis('<font color=yellow>INFO: Read configuration</font>');
+&logthis('<font color="yellow">INFO: Read configuration</font>');
$readit=1;
{
use integer;