Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.300 and 1.316

version 1.300, 2005/10/14 19:08:31	version 1.316, 2006/02/01 22:08:48
Line 53 use LONCAPA::ConfigFileEdit;	Line 53 use LONCAPA::ConfigFileEdit;
use LONCAPA::lonlocal;	use LONCAPA::lonlocal;
use LONCAPA::lonssl;	use LONCAPA::lonssl;
use Fcntl qw(:flock);	use Fcntl qw(:flock);
	use Symbol;

my $DEBUG = 0; # Non zero to enable debug log entries.	my $DEBUG = 0; # Non zero to enable debug log entries.

my $status='';	my $status='';
my $lastlog='';	my $lastlog='';
	my $lond_max_wait_time = 13;

my $VERSION='$Revision$'; #' stupid emacs	my $VERSION='$Revision$'; #' stupid emacs
my $remoteVERSION;	my $remoteVERSION;
Line 87 my $ConnectionType;	Line 89 my $ConnectionType;

my %hostid; # ID's for hosts in cluster by ip.	my %hostid; # ID's for hosts in cluster by ip.
my %hostdom; # LonCAPA domain for hosts in cluster.	my %hostdom; # LonCAPA domain for hosts in cluster.
	my %hostname; # DNSname -> ID's mapping.
my %hostip; # IPs for hosts in cluster.	my %hostip; # IPs for hosts in cluster.
my %hostdns; # ID's of hosts looked up by DNS name.	my %hostdns; # ID's of hosts looked up by DNS name.

Line 970 sub tie_domain_hash {	Line 973 sub tie_domain_hash {

my $user_top_dir = $perlvar{'lonUsersDir'};	my $user_top_dir = $perlvar{'lonUsersDir'};
my $domain_dir = $user_top_dir."/$domain";	my $domain_dir = $user_top_dir."/$domain";
my $resource_file = $domain_dir."/$namespace.db";	my $resource_file = $domain_dir."/$namespace";
my %hash;	return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail);
if(tie(%hash, 'GDBM_File', $resource_file, $how, 0640)) {
if (defined($loghead)) { # Need to log the operation.
my $logFh = IO::File->new(">>$domain_dir/$namespace.hist");
if($logFh) {
my $timestamp = time;
print $logFh "$loghead:$timestamp:$logtail\n";
}
$logFh->close;
}
return \%hash; # Return the tied hash.
} else {
return undef; # Tie failed.
}
}	}

	sub untie_domain_hash {
	return &_locking_hash_untie(@_);
	}
#	#
# Ties a user's resource file to a hash.	# Ties a user's resource file to a hash.
# If necessary, an appropriate history	# If necessary, an appropriate history
Line 1012 sub tie_user_hash {	Line 1005 sub tie_user_hash {
$namespace=~s/\//\_/g; # / -> _	$namespace=~s/\//\_/g; # / -> _
$namespace=~s/\W//g; # whitespace eliminated.	$namespace=~s/\W//g; # whitespace eliminated.
my $proname = propath($domain, $user);	my $proname = propath($domain, $user);

# Tie the database.	my $file_prefix="$proname/$namespace";
	return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
	}

	sub untie_user_hash {
	return &_locking_hash_untie(@_);
	}

	# internal routines that handle the actual tieing and untieing process

	sub _do_hash_tie {
	my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
my %hash;	my %hash;
if(tie(%hash, 'GDBM_File', "$proname/$namespace.db",	if(tie(%hash, 'GDBM_File', "$file_prefix.db", $how, 0640)) {
$how, 0640)) {
# If this is a namespace for which a history is kept,	# If this is a namespace for which a history is kept,
# make the history log entry:	# make the history log entry:
if (($namespace !~/^nohist\_/) && (defined($loghead))) {	if (($namespace !~/^nohist\_/) && (defined($loghead))) {
my $args = scalar @_;	my $args = scalar @_;
Debug(" Opening history: $namespace $args");	Debug(" Opening history: $file_prefix $args");
my $hfh = IO::File->new(">>$proname/$namespace.hist");	my $hfh = IO::File->new(">>$file_prefix.hist");
if($hfh) {	if($hfh) {
my $now = time;	my $now = time;
print $hfh "$loghead:$now:$what\n";	print $hfh "$loghead:$now:$what\n";
Line 1034 sub tie_user_hash {	Line 1036 sub tie_user_hash {
} else {	} else {
return undef;	return undef;
}	}
	}

	sub _do_hash_untie {
	my ($hashref) = @_;
	my $result = untie(%$hashref);
	return $result;
	}

	{
	my $sym;

	sub _locking_hash_tie {
	my ($file_prefix,$namespace,$how,$loghead,$what) = @_;

	my ($lock);

	if ($how eq &GDBM_READER()) {
	$lock=LOCK_SH;
	$how=$how\|&GDBM_NOLOCK();
	#if the db doesn't exist we can't read from it
	if (! -e "$file_prefix.db") {
	$! = 2;
	return undef;
	}
	} elsif ($how eq &GDBM_WRCREAT()) {
	$lock=LOCK_EX;
	$how=$how\|&GDBM_NOLOCK();
	if (! -e "$file_prefix.db") {
	# doesn't exist but we need it to in order to successfully
	# lock it so bring it into existance
	open(TOUCH,">>$file_prefix.db");
	close(TOUCH);
	}
	} else {
	&logthis("Unknown method $how for $file_prefix");
	die();
	}

	$sym=&Symbol::gensym();
	open($sym,"$file_prefix.db");
	my $failed=0;
	eval {
	local $SIG{__DIE__}='DEFAULT';
	local $SIG{ALRM}=sub {
	$failed=1;
	die("failed lock");
	};
	alarm($lond_max_wait_time);
	flock($sym,$lock);
	alarm(0);
	};
	if ($failed) {
	$! = 100; # throwing error # 100
	return undef;
	}
	return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
	}

	sub _locking_hash_untie {
	my ($hashref) = @_;
	my $result = untie(%$hashref);
	flock($sym,LOCK_UN);
	close($sym);
	undef($sym);
	return $result;
	}
}	}

# read_profile	# read_profile
Line 1067 sub read_profile {	Line 1134 sub read_profile {
$qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string.	$qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string.
}	}
$qresult=~s/\&$//; # Remove trailing & from last lookup.	$qresult=~s/\&$//; # Remove trailing & from last lookup.
if (untie %$hashref) {	if (&untie_user_hash($hashref)) {
return $qresult;	return $qresult;
} else {	} else {
return "error: ".($!+0)." untie (GDBM) Failed";	return "error: ".($!+0)." untie (GDBM) Failed";
Line 1422 sub ls_handler {	Line 1489 sub ls_handler {
open(FILE, $ulsdir.'/'.$ulsfn.".meta");	open(FILE, $ulsdir.'/'.$ulsfn.".meta");
my @obsolete=<FILE>;	my @obsolete=<FILE>;
foreach my $obsolete (@obsolete) {	foreach my $obsolete (@obsolete) {
if($obsolete =~ m\|(<obsolete>)(on)\|) { $obs = 1; }	if($obsolete =~ m/(<obsolete>)(on\|1)/) { $obs = 1; }
if($obsolete =~ m\|(<copyright>)(default)\|) { $rights = 1; }	if($obsolete =~ m\|(<copyright>)(default)\|) { $rights = 1; }
}	}
}	}
Line 1490 sub ls2_handler {	Line 1557 sub ls2_handler {
open(FILE, $ulsdir.'/'.$ulsfn.".meta");	open(FILE, $ulsdir.'/'.$ulsfn.".meta");
my @obsolete=<FILE>;	my @obsolete=<FILE>;
foreach my $obsolete (@obsolete) {	foreach my $obsolete (@obsolete) {
if($obsolete =~ m\|(<obsolete>)(on)\|) { $obs = 1; }	if($obsolete =~ m/(<obsolete>)(on\|1)/) { $obs = 1; }
if($obsolete =~ m\|(<copyright>)(default)\|) {	if($obsolete =~ m\|(<copyright>)(default)\|) {
$rights = 1;	$rights = 1;
}	}
Line 1943 sub update_resource_handler {	Line 2010 sub update_resource_handler {
my $since=$now-$atime;	my $since=$now-$atime;
if ($since>$perlvar{'lonExpire'}) {	if ($since>$perlvar{'lonExpire'}) {
my $reply=&reply("unsub:$fname","$clientname");	my $reply=&reply("unsub:$fname","$clientname");
	&devalidate_meta_cache($fname);
unlink("$fname");	unlink("$fname");
} else {	} else {
my $transname="$fname.in.transfer";	my $transname="$fname.in.transfer";
Line 1973 sub update_resource_handler {	Line 2041 sub update_resource_handler {
alarm(0);	alarm(0);
}	}
rename($transname,$fname);	rename($transname,$fname);
use Cache::Memcached;	&devalidate_meta_cache($fname);
my $memcache=
new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
my $url=$fname;
$url=~s-^/home/httpd/html--;
my $id=&escape('meta:'.$url);
$memcache->delete($id);
}	}
}	}
&Reply( $client, "ok\n", $userinput);	&Reply( $client, "ok\n", $userinput);
Line 1993 sub update_resource_handler {	Line 2055 sub update_resource_handler {
}	}
&register_handler("update", \&update_resource_handler, 0 ,1, 0);	&register_handler("update", \&update_resource_handler, 0 ,1, 0);

	sub devalidate_meta_cache {
	my ($url) = @_;
	use Cache::Memcached;
	my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
	$url = &declutter($url);
	$url =~ s-\.meta$--;
	my $id = &escape('meta:'.$url);
	$memcache->delete($id);
	}

	sub declutter {
	my $thisfn=shift;
	$thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
	$thisfn=~s/^\///;
	$thisfn=~s\|^adm/wrapper/\|\|;
	$thisfn=~s\|^adm/coursedocs/showdoc/\|\|;
	$thisfn=~s/^res\///;
	$thisfn=~s/\?.+$//;
	return $thisfn;
	}
#	#
# Fetch a user file from a remote server to the user's home directory	# Fetch a user file from a remote server to the user's home directory
# userfiles subdir.	# userfiles subdir.
Line 2361 sub put_user_profile_entry {	Line 2443 sub put_user_profile_entry {
my ($key,$value)=split(/=/,$pair);	my ($key,$value)=split(/=/,$pair);
$hashref->{$key}=$value;	$hashref->{$key}=$value;
}	}
if (untie(%$hashref)) {	if (&untie_user_hash($hashref)) {
&Reply( $client, "ok\n", $userinput);	&Reply( $client, "ok\n", $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) failed ".	&Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
Line 2369 sub put_user_profile_entry {	Line 2451 sub put_user_profile_entry {
$userinput);	$userinput);
}	}
} else {	} else {
&Failure( $client, "error: ".($!)." tie(GDBM) Failed ".	&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
"while attempting put\n", $userinput);	"while attempting put\n", $userinput);
}	}
} else {	} else {
Line 2405 sub newput_user_profile_entry {	Line 2487 sub newput_user_profile_entry {
my $hashref = &tie_user_hash($udom, $uname, $namespace,	my $hashref = &tie_user_hash($udom, $uname, $namespace,
&GDBM_WRCREAT(),"N",$what);	&GDBM_WRCREAT(),"N",$what);
if(!$hashref) {	if(!$hashref) {
&Failure( $client, "error: ".($!)." tie(GDBM) Failed ".	&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
"while attempting put\n", $userinput);	"while attempting put\n", $userinput);
return 1;	return 1;
}	}
Line 2424 sub newput_user_profile_entry {	Line 2506 sub newput_user_profile_entry {
$hashref->{$key}=$value;	$hashref->{$key}=$value;
}	}

if (untie(%$hashref)) {	if (&untie_user_hash($hashref)) {
&Reply( $client, "ok\n", $userinput);	&Reply( $client, "ok\n", $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) failed ".	&Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
Line 2477 sub increment_user_value_handler {	Line 2559 sub increment_user_value_handler {
}	}
}	}
}	}
if (untie(%$hashref)) {	if (&untie_user_hash($hashref)) {
&Reply( $client, "ok\n", $userinput);	&Reply( $client, "ok\n", $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) failed ".	&Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
Line 2544 sub roles_put_handler {	Line 2626 sub roles_put_handler {
$auth_type);	$auth_type);
$hashref->{$key}=$value;	$hashref->{$key}=$value;
}	}
if (untie($hashref)) {	if (&untie_user_hash($hashref)) {
&Reply($client, "ok\n", $userinput);	&Reply($client, "ok\n", $userinput);
} else {	} else {
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
Line 2595 sub roles_delete_handler {	Line 2677 sub roles_delete_handler {
foreach my $key (@rolekeys) {	foreach my $key (@rolekeys) {
delete $hashref->{$key};	delete $hashref->{$key};
}	}
if (untie(%$hashref)) {	if (&untie_user_hash($hashref)) {
&Reply($client, "ok\n", $userinput);	&Reply($client, "ok\n", $userinput);
} else {	} else {
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
Line 2736 sub delete_profile_entry {	Line 2818 sub delete_profile_entry {
foreach my $key (@keys) {	foreach my $key (@keys) {
delete($hashref->{$key});	delete($hashref->{$key});
}	}
if (untie(%$hashref)) {	if (&untie_user_hash($hashref)) {
&Reply($client, "ok\n", $userinput);	&Reply($client, "ok\n", $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
Line 2778 sub get_profile_keys {	Line 2860 sub get_profile_keys {
foreach my $key (keys %$hashref) {	foreach my $key (keys %$hashref) {
$qresult.="$key&";	$qresult.="$key&";
}	}
if (untie(%$hashref)) {	if (&untie_user_hash($hashref)) {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
&Reply($client, "$qresult\n", $userinput);	&Reply($client, "$qresult\n", $userinput);
} else {	} else {
Line 2839 sub dump_profile_database {	Line 2921 sub dump_profile_database {
$data{$symb}->{$param}=$value;	$data{$symb}->{$param}=$value;
$data{$symb}->{'v.'.$param}=$v;	$data{$symb}->{'v.'.$param}=$v;
}	}
if (untie(%$hashref)) {	if (&untie_user_hash($hashref)) {
while (my ($symb,$param_hash) = each(%data)) {	while (my ($symb,$param_hash) = each(%data)) {
while(my ($param,$value) = each (%$param_hash)){	while(my ($param,$value) = each (%$param_hash)){
next if ($param =~ /^v\./); # Ignore versions...	next if ($param =~ /^v\./); # Ignore versions...
Line 2894 sub dump_with_regexp {	Line 2976 sub dump_with_regexp {

my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";

my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail);	my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail);
if (defined($regexp)) {	if (defined($regexp)) {
$regexp=&unescape($regexp);	$regexp=&unescape($regexp);
} else {	} else {
$regexp='.';	$regexp='.';
}	}
	my ($start,$end);
	if (defined($range)) {
	if ($range =~/^(\d+)\-(\d+)$/) {
	($start,$end) = ($1,$2);
	} elsif ($range =~/^(\d+)$/) {
	($start,$end) = (0,$1);
	} else {
	undef($range);
	}
	}
my $hashref = &tie_user_hash($udom, $uname, $namespace,	my $hashref = &tie_user_hash($udom, $uname, $namespace,
&GDBM_READER());	&GDBM_READER());
if ($hashref) {	if ($hashref) {
my $qresult='';	my $qresult='';
	my $count=0;
while (my ($key,$value) = each(%$hashref)) {	while (my ($key,$value) = each(%$hashref)) {
if ($regexp eq '.') {	if ($regexp eq '.') {
	$count++;
	if (defined($range) && $count >= $end) { last; }
	if (defined($range) && $count < $start) { next; }
$qresult.=$key.'='.$value.'&';	$qresult.=$key.'='.$value.'&';
} else {	} else {
my $unescapeKey = &unescape($key);	my $unescapeKey = &unescape($key);
if (eval('$unescapeKey=~/$regexp/')) {	if (eval('$unescapeKey=~/$regexp/')) {
	$count++;
	if (defined($range) && $count >= $end) { last; }
	if (defined($range) && $count < $start) { next; }
$qresult.="$key=$value&";	$qresult.="$key=$value&";
}	}
}	}
}	}
if (untie(%$hashref)) {	if (&untie_user_hash($hashref)) {
chop($qresult);	chop($qresult);
&Reply($client, "$qresult\n", $userinput);	&Reply($client, "$qresult\n", $userinput);
} else {	} else {
Line 2976 sub store_handler {	Line 3075 sub store_handler {
$hashref->{"$version:$rid:timestamp"}=$now;	$hashref->{"$version:$rid:timestamp"}=$now;
$allkeys.='timestamp';	$allkeys.='timestamp';
$hashref->{"$version:keys:$rid"}=$allkeys;	$hashref->{"$version:keys:$rid"}=$allkeys;
if (untie($hashref)) {	if (&untie_user_hash($hashref)) {
&Reply($client, "ok\n", $userinput);	&Reply($client, "ok\n", $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
Line 3028 sub restore_handler {	Line 3127 sub restore_handler {
$namespace=~s/\//\_/g;	$namespace=~s/\//\_/g;
$namespace=~s/\W//g;	$namespace=~s/\W//g;
chomp($rid);	chomp($rid);
my $proname=&propath($udom,$uname);
my $qresult='';	my $qresult='';
my %hash;	my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER());
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",	if ($hashref) {
&GDBM_READER(),0640)) {	my $version=$hashref->{"version:$rid"};
my $version=$hash{"version:$rid"};
$qresult.="version=$version&";	$qresult.="version=$version&";
my $scope;	my $scope;
for ($scope=1;$scope<=$version;$scope++) {	for ($scope=1;$scope<=$version;$scope++) {
my $vkeys=$hash{"$scope:keys:$rid"};	my $vkeys=$hashref->{"$scope:keys:$rid"};
my @keys=split(/:/,$vkeys);	my @keys=split(/:/,$vkeys);
my $key;	my $key;
$qresult.="$scope:keys=$vkeys&";	$qresult.="$scope:keys=$vkeys&";
foreach $key (@keys) {	foreach $key (@keys) {
$qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";	$qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&";
}	}
}	}
if (untie(%hash)) {	if (&untie_user_hash($hashref)) {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
&Reply( $client, "$qresult\n", $userinput);	&Reply( $client, "$qresult\n", $userinput);
} else {	} else {
Line 3278 sub put_course_id_handler {	Line 3375 sub put_course_id_handler {
}	}
$hashref->{$key}=$courseinfo.':'.$now;	$hashref->{$key}=$courseinfo.':'.$now;
}	}
if (untie(%$hashref)) {	if (&untie_domain_hash($hashref)) {
&Reply( $client, "ok\n", $userinput);	&Reply( $client, "ok\n", $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)	&Failure($client, "error: ".($!+0)
Line 3394 sub dump_course_id_handler {	Line 3491 sub dump_course_id_handler {
$qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';	$qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';
}	}
}	}
if (untie(%$hashref)) {	if (&untie_domain_hash($hashref)) {
chop($qresult);	chop($qresult);
&Reply($client, "$qresult\n", $userinput);	&Reply($client, "$qresult\n", $userinput);
} else {	} else {
Line 3443 sub put_id_handler {	Line 3540 sub put_id_handler {
my ($key,$value)=split(/=/,$pair);	my ($key,$value)=split(/=/,$pair);
$hashref->{$key}=$value;	$hashref->{$key}=$value;
}	}
if (untie(%$hashref)) {	if (&untie_domain_hash($hashref)) {
&Reply($client, "ok\n", $userinput);	&Reply($client, "ok\n", $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
Line 3492 sub get_id_handler {	Line 3589 sub get_id_handler {
for (my $i=0;$i<=$#queries;$i++) {	for (my $i=0;$i<=$#queries;$i++) {
$qresult.="$hashref->{$queries[$i]}&";	$qresult.="$hashref->{$queries[$i]}&";
}	}
if (untie(%$hashref)) {	if (&untie_domain_hash($hashref)) {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
&Reply($client, "$qresult\n", $userinput);	&Reply($client, "$qresult\n", $userinput);
} else {	} else {
Line 3536 sub put_dcmail_handler {	Line 3633 sub put_dcmail_handler {
my ($key,$value)=split(/=/,$what);	my ($key,$value)=split(/=/,$what);
$hashref->{$key}=$value;	$hashref->{$key}=$value;
}	}
if (untie(%$hashref)) {	if (&untie_domain_hash($hashref)) {
&Reply($client, "ok\n", $userinput);	&Reply($client, "ok\n", $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
Line 3594 sub dump_dcmail_handler {	Line 3691 sub dump_dcmail_handler {
if ($hashref) {	if ($hashref) {
while (my ($key,$value) = each(%$hashref)) {	while (my ($key,$value) = each(%$hashref)) {
my $match = 1;	my $match = 1;
my ($timestamp,$subj,$uname,$udom) = split(/:/,&unescape($key),5);	my ($timestamp,$subj,$uname,$udom) =
$timestamp = &unescape($timestamp);	split(/:/,&unescape(&unescape($key)),5); # yes, twice really
$subj = &unescape($subj);	$subj = &unescape($subj);
$uname = &unescape($uname);
$udom = &unescape($udom);
unless ($startfilter eq '.' \|\| !defined($startfilter)) {	unless ($startfilter eq '.' \|\| !defined($startfilter)) {
if ($timestamp < $startfilter) {	if ($timestamp < $startfilter) {
$match = 0;	$match = 0;
Line 3618 sub dump_dcmail_handler {	Line 3713 sub dump_dcmail_handler {
$qresult.=$key.'='.$value.'&';	$qresult.=$key.'='.$value.'&';
}	}
}	}
if (untie(%$hashref)) {	if (&untie_domain_hash($hashref)) {
chop($qresult);	chop($qresult);
&Reply($client, "$qresult\n", $userinput);	&Reply($client, "$qresult\n", $userinput);
} else {	} else {
Line 3665 sub put_domainroles_handler {	Line 3760 sub put_domainroles_handler {
my ($key,$value)=split(/=/,$pair);	my ($key,$value)=split(/=/,$pair);
$hashref->{$key}=$value;	$hashref->{$key}=$value;
}	}
if (untie(%$hashref)) {	if (&untie_domain_hash($hashref)) {
&Reply($client, "ok\n", $userinput);	&Reply($client, "ok\n", $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
Line 3746 sub dump_domainroles_handler {	Line 3841 sub dump_domainroles_handler {
$qresult.=$key.'='.$value.'&';	$qresult.=$key.'='.$value.'&';
}	}
}	}
if (untie(%$hashref)) {	if (&untie_domain_hash($hashref)) {
chop($qresult);	chop($qresult);
&Reply($client, "$qresult\n", $userinput);	&Reply($client, "$qresult\n", $userinput);
} else {	} else {
Line 4685 sub ReadHostTable {	Line 4780 sub ReadHostTable {
}	}
$hostid{$ip}=$id; # LonCAPA name of host by IP.	$hostid{$ip}=$id; # LonCAPA name of host by IP.
$hostdom{$id}=$domain; # LonCAPA domain name of host.	$hostdom{$id}=$domain; # LonCAPA domain name of host.
	$hostname{$id}=$name; # LonCAPA name -> DNS name
$hostip{$id}=$ip; # IP address of host.	$hostip{$id}=$ip; # IP address of host.
$hostdns{$name} = $id; # LonCAPA name of host by DNS.	$hostdns{$name} = $id; # LonCAPA name of host by DNS.

Line 4935 sub reconlonc {	Line 5031 sub reconlonc {

sub subreply {	sub subreply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
my $peerfile="$perlvar{'lonSockDir'}/$server";	my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",	my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
Type => SOCK_STREAM,	Type => SOCK_STREAM,
Timeout => 10)	Timeout => 10)
or return "con_lost";	or return "con_lost";
print $sclient "$cmd\n";	print $sclient "sethost:$server:$cmd\n";
my $answer=<$sclient>;	my $answer=<$sclient>;
chomp($answer);	chomp($answer);
if (!$answer) { $answer="con_lost"; }	if (!$answer) { $answer="con_lost"; }
Line 4956 sub reply {	Line 5052 sub reply {
$answer=subreply("ping",$server);	$answer=subreply("ping",$server);
if ($answer ne $server) {	if ($answer ne $server) {
&logthis("sub reply: answer != server answer is $answer, server is $server");	&logthis("sub reply: answer != server answer is $answer, server is $server");
&reconlonc("$perlvar{'lonSockDir'}/$server");	&reconlonc("$perlvar{'lonSockDir'}/".$hostname{$server});
}	}
$answer=subreply($cmd,$server);	$answer=subreply($cmd,$server);
}	}
Line 5262 sub make_new_child {	Line 5358 sub make_new_child {
# no need to try to do recon's to myself	# no need to try to do recon's to myself
next;	next;
}	}
&reconlonc("$perlvar{'lonSockDir'}/$id");	&reconlonc("$perlvar{'lonSockDir'}/".$hostname{$id});
}	}
&logthis("<font color='green'>Established connection: $clientname</font>");	&logthis("<font color='green'>Established connection: $clientname</font>");
&status('Will listen to '.$clientname);	&status('Will listen to '.$clientname);
Line 5593 sub addline {	Line 5689 sub addline {

sub get_chat {	sub get_chat {
my ($cdom,$cname,$udom,$uname)=@_;	my ($cdom,$cname,$udom,$uname)=@_;
my %hash;
my $proname=&propath($cdom,$cname);
my @entries=();	my @entries=();
if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",	my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom',
&GDBM_READER(),0640)) {	&GDBM_READER());
@entries=map { $_.':'.$hash{$_} } sort keys %hash;	if ($hashref) {
untie %hash;	@entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
	&untie_user_hash($hashref);
}	}
my @participants=();	my @participants=();
my $cutoff=time-60;	my $cutoff=time-60;
if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",	$hashref = &tie_user_hash($cdom, $cname, 'nohist_inchatroom',
&GDBM_WRCREAT(),0640)) {	&GDBM_WRCREAT());
$hash{$uname.':'.$udom}=time;	if ($hashref) {
foreach (sort keys %hash) {	$hashref->{$uname.':'.$udom}=time;
if ($hash{$_}>$cutoff) {	foreach my $user (sort(keys(%$hashref))) {
$participants[$#participants+1]='active_participant:'.$_;	if ($hashref->{$user}>$cutoff) {
	push(@participants, 'active_participant:'.$user);
}	}
}	}
untie %hash;	&untie_user_hash($hashref);
}	}
return (@participants,@entries);	return (@participants,@entries);
}	}

sub chat_add {	sub chat_add {
my ($cdom,$cname,$newchat)=@_;	my ($cdom,$cname,$newchat)=@_;
my %hash;
my $proname=&propath($cdom,$cname);
my @entries=();	my @entries=();
my $time=time;	my $time=time;
if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",	my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom',
&GDBM_WRCREAT(),0640)) {	&GDBM_WRCREAT());
@entries=map { $_.':'.$hash{$_} } sort keys %hash;	if ($hashref) {
	@entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);	my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
my ($thentime,$idnum)=split(/\_/,$lastid);	my ($thentime,$idnum)=split(/\_/,$lastid);
my $newid=$time.'_000000';	my $newid=$time.'_000000';
Line 5634 sub chat_add {	Line 5730 sub chat_add {
$idnum=substr('000000'.$idnum,-6,6);	$idnum=substr('000000'.$idnum,-6,6);
$newid=$time.'_'.$idnum;	$newid=$time.'_'.$idnum;
}	}
$hash{$newid}=$newchat;	$hashref->{$newid}=$newchat;
my $expired=$time-3600;	my $expired=$time-3600;
foreach (keys %hash) {	foreach my $comment (keys(%$hashref)) {
my ($thistime)=($_=~/(\d+)\_/);	my ($thistime) = ($comment=~/(\d+)\_/);
if ($thistime<$expired) {	if ($thistime<$expired) {
delete $hash{$_};	delete $hashref->{$comment};
}	}
}	}
untie %hash;	{
}	my $proname=&propath($cdom,$cname);
{	if (open(CHATLOG,">>$proname/chatroom.log")) {
my $hfh;	print CHATLOG ("$time:".&unescape($newchat)."\n");
if ($hfh=IO::File->new(">>$proname/chatroom.log")) {	}
print $hfh "$time:".&unescape($newchat)."\n";	close(CHATLOG);
}	}
	&untie_user_hash($hashref);
}	}
}	}

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.

Removed from v.1.300
changed lines
	Added in v.1.316