--- loncom/lond 2005/12/10 00:46:23 1.304
+++ loncom/lond 2006/02/07 05:08:27 1.317
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.304 2005/12/10 00:46:23 raeburn Exp $
+# $Id: lond,v 1.317 2006/02/07 05:08:27 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -53,13 +53,15 @@ use LONCAPA::ConfigFileEdit;
use LONCAPA::lonlocal;
use LONCAPA::lonssl;
use Fcntl qw(:flock);
+use Symbol;
my $DEBUG = 0; # Non zero to enable debug log entries.
my $status='';
my $lastlog='';
+my $lond_max_wait_time = 13;
-my $VERSION='$Revision: 1.304 $'; #' stupid emacs
+my $VERSION='$Revision: 1.317 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid="default";
my $currentdomainid;
@@ -87,6 +89,7 @@ my $ConnectionType;
my %hostid; # ID's for hosts in cluster by ip.
my %hostdom; # LonCAPA domain for hosts in cluster.
+my %hostname; # DNSname -> ID's mapping.
my %hostip; # IPs for hosts in cluster.
my %hostdns; # ID's of hosts looked up by DNS name.
@@ -970,23 +973,13 @@ sub tie_domain_hash {
my $user_top_dir = $perlvar{'lonUsersDir'};
my $domain_dir = $user_top_dir."/$domain";
- my $resource_file = $domain_dir."/$namespace.db";
- my %hash;
- 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.
- }
+ my $resource_file = $domain_dir."/$namespace";
+ return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail);
}
+sub untie_domain_hash {
+ return &_locking_hash_untie(@_);
+}
#
# Ties a user's resource file to a hash.
# If necessary, an appropriate history
@@ -1012,18 +1005,27 @@ sub tie_user_hash {
$namespace=~s/\//\_/g; # / -> _
$namespace=~s/\W//g; # whitespace eliminated.
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;
- if(tie(%hash, 'GDBM_File', "$proname/$namespace.db",
- $how, 0640)) {
+ if(tie(%hash, 'GDBM_File', "$file_prefix.db", $how, 0640)) {
# If this is a namespace for which a history is kept,
# make the history log entry:
if (($namespace !~/^nohist\_/) && (defined($loghead))) {
my $args = scalar @_;
- Debug(" Opening history: $namespace $args");
- my $hfh = IO::File->new(">>$proname/$namespace.hist");
+ Debug(" Opening history: $file_prefix $args");
+ my $hfh = IO::File->new(">>$file_prefix.hist");
if($hfh) {
my $now = time;
print $hfh "$loghead:$now:$what\n";
@@ -1034,7 +1036,72 @@ sub tie_user_hash {
} else {
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
@@ -1067,7 +1134,7 @@ sub read_profile {
$qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string.
}
$qresult=~s/\&$//; # Remove trailing & from last lookup.
- if (untie %$hashref) {
+ if (&untie_user_hash($hashref)) {
return $qresult;
} else {
return "error: ".($!+0)." untie (GDBM) Failed";
@@ -1943,6 +2010,7 @@ sub update_resource_handler {
my $since=$now-$atime;
if ($since>$perlvar{'lonExpire'}) {
my $reply=&reply("unsub:$fname","$clientname");
+ &devalidate_meta_cache($fname);
unlink("$fname");
} else {
my $transname="$fname.in.transfer";
@@ -1973,13 +2041,7 @@ sub update_resource_handler {
alarm(0);
}
rename($transname,$fname);
- use Cache::Memcached;
- 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);
+ &devalidate_meta_cache($fname);
}
}
&Reply( $client, "ok\n", $userinput);
@@ -1993,6 +2055,26 @@ sub update_resource_handler {
}
®ister_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
# userfiles subdir.
@@ -2361,7 +2443,7 @@ sub put_user_profile_entry {
my ($key,$value)=split(/=/,$pair);
$hashref->{$key}=$value;
}
- if (untie(%$hashref)) {
+ if (&untie_user_hash($hashref)) {
&Reply( $client, "ok\n", $userinput);
} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
@@ -2369,7 +2451,7 @@ sub put_user_profile_entry {
$userinput);
}
} else {
- &Failure( $client, "error: ".($!)." tie(GDBM) Failed ".
+ &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
"while attempting put\n", $userinput);
}
} else {
@@ -2405,7 +2487,7 @@ sub newput_user_profile_entry {
my $hashref = &tie_user_hash($udom, $uname, $namespace,
&GDBM_WRCREAT(),"N",$what);
if(!$hashref) {
- &Failure( $client, "error: ".($!)." tie(GDBM) Failed ".
+ &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
"while attempting put\n", $userinput);
return 1;
}
@@ -2424,7 +2506,7 @@ sub newput_user_profile_entry {
$hashref->{$key}=$value;
}
- if (untie(%$hashref)) {
+ if (&untie_user_hash($hashref)) {
&Reply( $client, "ok\n", $userinput);
} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
@@ -2477,7 +2559,7 @@ sub increment_user_value_handler {
}
}
}
- if (untie(%$hashref)) {
+ if (&untie_user_hash($hashref)) {
&Reply( $client, "ok\n", $userinput);
} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
@@ -2544,7 +2626,7 @@ sub roles_put_handler {
$auth_type);
$hashref->{$key}=$value;
}
- if (untie($hashref)) {
+ if (&untie_user_hash($hashref)) {
&Reply($client, "ok\n", $userinput);
} else {
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
@@ -2595,7 +2677,7 @@ sub roles_delete_handler {
foreach my $key (@rolekeys) {
delete $hashref->{$key};
}
- if (untie(%$hashref)) {
+ if (&untie_user_hash($hashref)) {
&Reply($client, "ok\n", $userinput);
} else {
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
@@ -2736,7 +2818,7 @@ sub delete_profile_entry {
foreach my $key (@keys) {
delete($hashref->{$key});
}
- if (untie(%$hashref)) {
+ if (&untie_user_hash($hashref)) {
&Reply($client, "ok\n", $userinput);
} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
@@ -2778,7 +2860,7 @@ sub get_profile_keys {
foreach my $key (keys %$hashref) {
$qresult.="$key&";
}
- if (untie(%$hashref)) {
+ if (&untie_user_hash($hashref)) {
$qresult=~s/\&$//;
&Reply($client, "$qresult\n", $userinput);
} else {
@@ -2839,7 +2921,7 @@ sub dump_profile_database {
$data{$symb}->{$param}=$value;
$data{$symb}->{'v.'.$param}=$v;
}
- if (untie(%$hashref)) {
+ if (&untie_user_hash($hashref)) {
while (my ($symb,$param_hash) = each(%data)) {
while(my ($param,$value) = each (%$param_hash)){
next if ($param =~ /^v\./); # Ignore versions...
@@ -2894,27 +2976,44 @@ sub dump_with_regexp {
my $userinput = "$cmd:$tail";
- my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail);
+ my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail);
if (defined($regexp)) {
$regexp=&unescape($regexp);
} else {
$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,
&GDBM_READER());
if ($hashref) {
my $qresult='';
+ my $count=0;
while (my ($key,$value) = each(%$hashref)) {
if ($regexp eq '.') {
+ $count++;
+ if (defined($range) && $count >= $end) { last; }
+ if (defined($range) && $count < $start) { next; }
$qresult.=$key.'='.$value.'&';
} else {
my $unescapeKey = &unescape($key);
if (eval('$unescapeKey=~/$regexp/')) {
+ $count++;
+ if (defined($range) && $count >= $end) { last; }
+ if (defined($range) && $count < $start) { next; }
$qresult.="$key=$value&";
}
}
}
- if (untie(%$hashref)) {
+ if (&untie_user_hash($hashref)) {
chop($qresult);
&Reply($client, "$qresult\n", $userinput);
} else {
@@ -2976,7 +3075,7 @@ sub store_handler {
$hashref->{"$version:$rid:timestamp"}=$now;
$allkeys.='timestamp';
$hashref->{"$version:keys:$rid"}=$allkeys;
- if (untie($hashref)) {
+ if (&untie_user_hash($hashref)) {
&Reply($client, "ok\n", $userinput);
} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
@@ -3028,24 +3127,22 @@ sub restore_handler {
$namespace=~s/\//\_/g;
$namespace=~s/\W//g;
chomp($rid);
- my $proname=&propath($udom,$uname);
my $qresult='';
- my %hash;
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",
- &GDBM_READER(),0640)) {
- my $version=$hash{"version:$rid"};
+ my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER());
+ if ($hashref) {
+ my $version=$hashref->{"version:$rid"};
$qresult.="version=$version&";
my $scope;
for ($scope=1;$scope<=$version;$scope++) {
- my $vkeys=$hash{"$scope:keys:$rid"};
+ my $vkeys=$hashref->{"$scope:keys:$rid"};
my @keys=split(/:/,$vkeys);
my $key;
$qresult.="$scope:keys=$vkeys&";
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/\&$//;
&Reply( $client, "$qresult\n", $userinput);
} else {
@@ -3278,7 +3375,7 @@ sub put_course_id_handler {
}
$hashref->{$key}=$courseinfo.':'.$now;
}
- if (untie(%$hashref)) {
+ if (&untie_domain_hash($hashref)) {
&Reply( $client, "ok\n", $userinput);
} else {
&Failure($client, "error: ".($!+0)
@@ -3394,7 +3491,7 @@ sub dump_course_id_handler {
$qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';
}
}
- if (untie(%$hashref)) {
+ if (&untie_domain_hash($hashref)) {
chop($qresult);
&Reply($client, "$qresult\n", $userinput);
} else {
@@ -3443,7 +3540,7 @@ sub put_id_handler {
my ($key,$value)=split(/=/,$pair);
$hashref->{$key}=$value;
}
- if (untie(%$hashref)) {
+ if (&untie_domain_hash($hashref)) {
&Reply($client, "ok\n", $userinput);
} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
@@ -3492,7 +3589,7 @@ sub get_id_handler {
for (my $i=0;$i<=$#queries;$i++) {
$qresult.="$hashref->{$queries[$i]}&";
}
- if (untie(%$hashref)) {
+ if (&untie_domain_hash($hashref)) {
$qresult=~s/\&$//;
&Reply($client, "$qresult\n", $userinput);
} else {
@@ -3536,7 +3633,7 @@ sub put_dcmail_handler {
my ($key,$value)=split(/=/,$what);
$hashref->{$key}=$value;
}
- if (untie(%$hashref)) {
+ if (&untie_domain_hash($hashref)) {
&Reply($client, "ok\n", $userinput);
} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
@@ -3616,7 +3713,7 @@ sub dump_dcmail_handler {
$qresult.=$key.'='.$value.'&';
}
}
- if (untie(%$hashref)) {
+ if (&untie_domain_hash($hashref)) {
chop($qresult);
&Reply($client, "$qresult\n", $userinput);
} else {
@@ -3663,7 +3760,7 @@ sub put_domainroles_handler {
my ($key,$value)=split(/=/,$pair);
$hashref->{$key}=$value;
}
- if (untie(%$hashref)) {
+ if (&untie_domain_hash($hashref)) {
&Reply($client, "ok\n", $userinput);
} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
@@ -3744,7 +3841,7 @@ sub dump_domainroles_handler {
$qresult.=$key.'='.$value.'&';
}
}
- if (untie(%$hashref)) {
+ if (&untie_domain_hash($hashref)) {
chop($qresult);
&Reply($client, "$qresult\n", $userinput);
} else {
@@ -4239,6 +4336,64 @@ sub get_institutional_code_format_handle
®ister_handler("autoinstcodeformat",
\&get_institutional_code_format_handler,0,1,0);
+# Get domain specific conditions for import of student photographs to a course
+#
+# Retrieves information from photo_permission subroutine in localenroll.
+# Returns outcome (ok) if no processing errors, and whether course owner is
+# required to accept conditions of use (yes/no).
+#
+#
+sub photo_permission_handler {
+ my ($cmd, $tail, $client) = @_;
+ my $userinput = "$cmd:$tail";
+ my $cdom = $tail;
+ my ($perm_reqd,$conditions);
+ my $outcome = &localenroll::photo_permission($cdom,\$perm_reqd,
+ \$conditions);
+ &Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n",
+ $userinput);
+}
+®ister_handler("autophotopermission",\&photo_permission_handler,0,1,0);
+
+#
+# Checks if student photo is available for a user in the domain, in the user's
+# directory (in /userfiles/internal/studentphoto.jpg).
+# Uses localstudentphoto:fetch() to ensure there is an up to date copy of
+# the student's photo.
+
+sub photo_check_handler {
+ my ($cmd, $tail, $client) = @_;
+ my $userinput = "$cmd:$tail";
+ my ($udom,$uname,$pid) = split(/:/,$tail);
+ $udom = &unescape($udom);
+ $uname = &unescape($uname);
+ $pid = &unescape($pid);
+ my $path=&propath($udom,$uname).'/userfiles/internal/';
+ if (!-e $path) {
+ &mkpath($path);
+ }
+ my $response;
+ my $result = &localstudentphoto::fetch($udom,$uname,$pid,\$response);
+ $result .= ':'.$response;
+ &Reply($client, &escape($result)."\n",$userinput);
+}
+®ister_handler("autophotocheck",\&photo_check_handler,0,1,0);
+
+#
+# Retrieve information from localenroll about whether to provide a button
+# for users who have enbled import of student photos to initiate an
+# update of photo files for registered students. Also include
+# comment to display alongside button.
+
+sub photo_choice_handler {
+ my ($cmd, $tail, $client) = @_;
+ my $userinput = "$cmd:$tail";
+ my $cdom = &unescape($tail);
+ my ($update,$comment) = &localenroll::manager_photo_update($cdom);
+ &Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput);
+}
+®ister_handler("autophotochoice",\&photo_choice_handler,0,1,0);
+
#
# Gets a student's photo to exist (in the correct image type) in the user's
# directory.
@@ -4251,24 +4406,33 @@ sub get_institutional_code_format_handle
# $client - The socket open on the client.
# Returns:
# 1 - continue processing.
+
sub student_photo_handler {
my ($cmd, $tail, $client) = @_;
- my ($domain,$uname,$type) = split(/:/, $tail);
+ my ($domain,$uname,$ext,$type) = split(/:/, $tail);
- my $path=&propath($domain,$uname).
- '/userfiles/internal/studentphoto.'.$type;
- if (-e $path) {
+ my $path=&propath($domain,$uname). '/userfiles/internal/';
+ my $filename = 'studentphoto.'.$ext;
+ if ($type eq 'thumbnail') {
+ $filename = 'studentphoto_tn.'.$ext;
+ }
+ if (-e $path.$filename) {
&Reply($client,"ok\n","$cmd:$tail");
return 1;
}
&mkpath($path);
- my $file=&localstudentphoto::fetch($domain,$uname);
+ my $file;
+ if ($type eq 'thumbnail') {
+ $file=&localstudentphoto::fetch_thumbnail($domain,$uname);
+ } else {
+ $file=&localstudentphoto::fetch($domain,$uname);
+ }
if (!$file) {
&Failure($client,"unavailable\n","$cmd:$tail");
return 1;
}
- if (!-e $path) { &convert_photo($file,$path); }
- if (-e $path) {
+ if (!-e $path.$filename) { &convert_photo($file,$path.$filename); }
+ if (-e $path.$filename) {
&Reply($client,"ok\n","$cmd:$tail");
return 1;
}
@@ -4683,6 +4847,7 @@ sub ReadHostTable {
}
$hostid{$ip}=$id; # LonCAPA name of host by IP.
$hostdom{$id}=$domain; # LonCAPA domain name of host.
+ $hostname{$id}=$name; # LonCAPA name -> DNS name
$hostip{$id}=$ip; # IP address of host.
$hostdns{$name} = $id; # LonCAPA name of host by DNS.
@@ -4933,12 +5098,12 @@ sub reconlonc {
sub subreply {
my ($cmd,$server)=@_;
- my $peerfile="$perlvar{'lonSockDir'}/$server";
+ my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
Type => SOCK_STREAM,
Timeout => 10)
or return "con_lost";
- print $sclient "$cmd\n";
+ print $sclient "sethost:$server:$cmd\n";
my $answer=<$sclient>;
chomp($answer);
if (!$answer) { $answer="con_lost"; }
@@ -4954,7 +5119,7 @@ sub reply {
$answer=subreply("ping",$server);
if ($answer ne $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);
}
@@ -5260,7 +5425,7 @@ sub make_new_child {
# no need to try to do recon's to myself
next;
}
- &reconlonc("$perlvar{'lonSockDir'}/$id");
+ &reconlonc("$perlvar{'lonSockDir'}/".$hostname{$id});
}
&logthis("<font color='green'>Established connection: $clientname</font>");
&status('Will listen to '.$clientname);
@@ -5591,38 +5756,38 @@ sub addline {
sub get_chat {
my ($cdom,$cname,$udom,$uname)=@_;
- my %hash;
- my $proname=&propath($cdom,$cname);
+
my @entries=();
- if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
- &GDBM_READER(),0640)) {
- @entries=map { $_.':'.$hash{$_} } sort keys %hash;
- untie %hash;
+ my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom',
+ &GDBM_READER());
+ if ($hashref) {
+ @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
+ &untie_user_hash($hashref);
}
my @participants=();
my $cutoff=time-60;
- if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
- &GDBM_WRCREAT(),0640)) {
- $hash{$uname.':'.$udom}=time;
- foreach (sort keys %hash) {
- if ($hash{$_}>$cutoff) {
- $participants[$#participants+1]='active_participant:'.$_;
+ $hashref = &tie_user_hash($cdom, $cname, 'nohist_inchatroom',
+ &GDBM_WRCREAT());
+ if ($hashref) {
+ $hashref->{$uname.':'.$udom}=time;
+ foreach my $user (sort(keys(%$hashref))) {
+ if ($hashref->{$user}>$cutoff) {
+ push(@participants, 'active_participant:'.$user);
}
}
- untie %hash;
+ &untie_user_hash($hashref);
}
return (@participants,@entries);
}
sub chat_add {
my ($cdom,$cname,$newchat)=@_;
- my %hash;
- my $proname=&propath($cdom,$cname);
my @entries=();
my $time=time;
- if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
- &GDBM_WRCREAT(),0640)) {
- @entries=map { $_.':'.$hash{$_} } sort keys %hash;
+ my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom',
+ &GDBM_WRCREAT());
+ if ($hashref) {
+ @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
my ($thentime,$idnum)=split(/\_/,$lastid);
my $newid=$time.'_000000';
@@ -5632,21 +5797,22 @@ sub chat_add {
$idnum=substr('000000'.$idnum,-6,6);
$newid=$time.'_'.$idnum;
}
- $hash{$newid}=$newchat;
+ $hashref->{$newid}=$newchat;
my $expired=$time-3600;
- foreach (keys %hash) {
- my ($thistime)=($_=~/(\d+)\_/);
+ foreach my $comment (keys(%$hashref)) {
+ my ($thistime) = ($comment=~/(\d+)\_/);
if ($thistime<$expired) {
- delete $hash{$_};
+ delete $hashref->{$comment};
}
}
- untie %hash;
- }
- {
- my $hfh;
- if ($hfh=IO::File->new(">>$proname/chatroom.log")) {
- print $hfh "$time:".&unescape($newchat)."\n";
+ {
+ my $proname=&propath($cdom,$cname);
+ if (open(CHATLOG,">>$proname/chatroom.log")) {
+ print CHATLOG ("$time:".&unescape($newchat)."\n");
+ }
+ close(CHATLOG);
}
+ &untie_user_hash($hashref);
}
}