--- loncom/lond 2006/03/04 00:59:59 1.323
+++ loncom/lond 2006/05/18 17:55:49 1.329
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.323 2006/03/04 00:59:59 albertel Exp $
+# $Id: lond,v 1.329 2006/05/18 17:55:49 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -31,12 +31,12 @@
use strict;
use lib '/home/httpd/lib/perl/';
+use LONCAPA;
use LONCAPA::Configuration;
use IO::Socket;
use IO::File;
#use Apache::File;
-use Symbol;
use POSIX;
use Crypt::IDEA;
use LWP::UserAgent();
@@ -53,7 +53,6 @@ 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.
@@ -61,7 +60,7 @@ my $status='';
my $lastlog='';
my $lond_max_wait_time = 13;
-my $VERSION='$Revision: 1.323 $'; #' stupid emacs
+my $VERSION='$Revision: 1.329 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid="default";
my $currentdomainid;
@@ -1049,49 +1048,70 @@ sub _do_hash_untie {
sub _locking_hash_tie {
my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
+ my $lock_type=LOCK_SH;
+# Are we reading or writing?
+ if ($how eq &GDBM_READER()) {
+# We are reading
+ if (!open($sym,"$file_prefix.db.lock")) {
+# We don't have a lock file. This could mean
+# - that there is no such db-file
+# - that it does not have a lock file yet
+ if ((! -e "$file_prefix.db") && (! -e "$file_prefix.db.gz")) {
+# No such file. Forget it.
+ $! = 2;
+ return undef;
+ }
+# Apparently just no lock file yet. Make one
+ open($sym,">>$file_prefix.db.lock");
+ }
+# Do a shared lock
+ if (!&flock_sym(LOCK_SH)) { return undef; }
+# If this is compressed, we will actually need an exclusive lock
+ if (-e "$file_prefix.db.gz") {
+ if (!&flock_sym(LOCK_EX)) { return undef; }
+ }
+ } elsif ($how eq &GDBM_WRCREAT()) {
+# We are writing
+ open($sym,">>$file_prefix.db.lock");
+# Writing needs exclusive lock
+ if (!&flock_sym(LOCK_EX)) { return undef; }
+ } else {
+ &logthis("Unknown method $how for $file_prefix");
+ die();
+ }
+# The file is ours!
+# If it is archived, un-archive it now
+ if (-e "$file_prefix.db.gz") {
+ system("gunzip $file_prefix.db.gz");
+ if (-e "$file_prefix.hist.gz") {
+ system("gunzip $file_prefix.hist.gz");
+ }
+ }
+# Change access mode to non-blocking
+ $how=$how|&GDBM_NOLOCK();
+# Go ahead and tie the hash
+ return &_do_hash_tie($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");
+ sub flock_sym {
+ my ($lock_type)=@_;
my $failed=0;
eval {
local $SIG{__DIE__}='DEFAULT';
- local $SIG{ALRM}=sub {
+ local $SIG{ALRM}=sub {
$failed=1;
die("failed lock");
};
alarm($lond_max_wait_time);
- flock($sym,$lock);
+ flock($sym,$lock_type);
alarm(0);
};
if ($failed) {
$! = 100; # throwing error # 100
return undef;
+ } else {
+ return 1;
}
- return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
}
sub _locking_hash_untie {
@@ -3240,15 +3260,17 @@ sub restore_handler {
®ister_handler("restore", \&restore_handler, 0,1,0);
#
-# Add a chat message to to a discussion board.
+# Add a chat message to a synchronous discussion board.
#
# Parameters:
# $cmd - Request keyword.
# $tail - Tail of the command. A colon separated list
# containing:
# cdom - Domain on which the chat board lives
-# cnum - Identifier of the discussion group.
-# post - Body of the posting.
+# cnum - Course containing the chat board.
+# newpost - Body of the posting.
+# group - Optional group, if chat board is only
+# accessible in a group within the course
# $client - Socket open on the client.
# Returns:
# 1 - Indicating caller should keep on processing.
@@ -3263,8 +3285,8 @@ sub send_chat_handler {
my $userinput = "$cmd:$tail";
- my ($cdom,$cnum,$newpost)=split(/\:/,$tail);
- &chat_add($cdom,$cnum,$newpost);
+ my ($cdom,$cnum,$newpost,$group)=split(/\:/,$tail);
+ &chat_add($cdom,$cnum,$newpost,$group);
&Reply($client, "ok\n", $userinput);
return 1;
@@ -3272,7 +3294,7 @@ sub send_chat_handler {
®ister_handler("chatsend", \&send_chat_handler, 0, 1, 0);
#
-# Retrieve the set of chat messagss from a discussion board.
+# Retrieve the set of chat messages from a discussion board.
#
# Parameters:
# $cmd - Command keyword that initiated the request.
@@ -3282,6 +3304,8 @@ sub send_chat_handler {
# chat id - Discussion thread(?)
# domain/user - Authentication domain and username
# of the requesting person.
+# group - Optional course group containing
+# the board.
# $client - Socket open on the client program.
# Returns:
# 1 - continue processing
@@ -3294,9 +3318,9 @@ sub retrieve_chat_handler {
my $userinput = "$cmd:$tail";
- my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail);
+ my ($cdom,$cnum,$udom,$uname,$group)=split(/\:/,$tail);
my $reply='';
- foreach (&get_chat($cdom,$cnum,$udom,$uname)) {
+ foreach (&get_chat($cdom,$cnum,$udom,$uname,$group)) {
$reply.=&escape($_).':';
}
$reply=~s/\:$//;
@@ -5173,22 +5197,6 @@ sub status {
$0='lond: '.$what.' '.$local;
}
-# -------------------------------------------------------- Escape Special Chars
-
-sub escape {
- my $str=shift;
- $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
- return $str;
-}
-
-# ----------------------------------------------------- Un-Escape Special Chars
-
-sub unescape {
- my $str=shift;
- $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
- return $str;
-}
-
# ----------------------------------------------------------- Send USR1 to lonc
sub reconlonc {
@@ -5875,10 +5883,16 @@ sub addline {
}
sub get_chat {
- my ($cdom,$cname,$udom,$uname)=@_;
+ my ($cdom,$cname,$udom,$uname,$group)=@_;
my @entries=();
- my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom',
+ my $namespace = 'nohist_chatroom';
+ my $namespace_inroom = 'nohist_inchatroom';
+ if (defined($group)) {
+ $namespace .= '_'.$group;
+ $namespace_inroom .= '_'.$group;
+ }
+ my $hashref = &tie_user_hash($cdom, $cname, $namespace,
&GDBM_READER());
if ($hashref) {
@entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
@@ -5886,7 +5900,7 @@ sub get_chat {
}
my @participants=();
my $cutoff=time-60;
- $hashref = &tie_user_hash($cdom, $cname, 'nohist_inchatroom',
+ $hashref = &tie_user_hash($cdom, $cname, $namespace_inroom,
&GDBM_WRCREAT());
if ($hashref) {
$hashref->{$uname.':'.$udom}=time;
@@ -5901,10 +5915,16 @@ sub get_chat {
}
sub chat_add {
- my ($cdom,$cname,$newchat)=@_;
+ my ($cdom,$cname,$newchat,$group)=@_;
my @entries=();
my $time=time;
- my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom',
+ my $namespace = 'nohist_chatroom';
+ my $logfile = 'chatroom.log';
+ if (defined($group)) {
+ $namespace .= '_'.$group;
+ $logfile = 'chatroom_'.$group.'.log';
+ }
+ my $hashref = &tie_user_hash($cdom, $cname, $namespace,
&GDBM_WRCREAT());
if ($hashref) {
@entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
@@ -5927,7 +5947,7 @@ sub chat_add {
}
{
my $proname=&propath($cdom,$cname);
- if (open(CHATLOG,">>$proname/chatroom.log")) {
+ if (open(CHATLOG,">>$proname/$logfile")) {
print CHATLOG ("$time:".&unescape($newchat)."\n");
}
close(CHATLOG);
@@ -6632,7 +6652,6 @@ to the client, and the connection is clo
IO::Socket
IO::File
Apache::File
-Symbol
POSIX
Crypt::IDEA
LWP::UserAgent()