loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.317 and 1.326

version 1.317, 2006/02/07 05:08:27	version 1.326, 2006/05/13 01:31:15
Line 31	Line 31

use strict;	use strict;
use lib '/home/httpd/lib/perl/';	use lib '/home/httpd/lib/perl/';
	use LONCAPA;
use LONCAPA::Configuration;	use LONCAPA::Configuration;

use IO::Socket;	use IO::Socket;
Line 1050 sub _do_hash_untie {	Line 1051 sub _do_hash_untie {
sub _locking_hash_tie {	sub _locking_hash_tie {
my ($file_prefix,$namespace,$how,$loghead,$what) = @_;	my ($file_prefix,$namespace,$how,$loghead,$what) = @_;

	# is this locked by an external program?

	if (-e "$file_prefix.db.lock") {
	my $failed=0;
	eval {
	local $SIG{__DIE__}='DEFAULT';
	local $SIG{ALRM}=sub {
	$failed=1;
	die("failed lock");
	};
	alarm(2*$lond_max_wait_time);
	while (-e "$file_prefix.db.lock") {}
	alarm(0);
	};
	if ($failed) {
	$! = 100; # throwing error # 100
	return undef;
	}
	}

	# is this archived?

	if (-e "$file_prefix.db.gz") {
	# lock immediately
	open(TOUCH,">>$file_prefix.db.lock");
	close(TOUCH);
	system("gunzip $file_prefix.db.gz");
	if (-e "$file_prefix.hist.gz") {
	system("gunzip $file_prefix.hist.gz");
	}
	# all set, unlock
	unlink("$file_prefix.db.lock");
	}


my ($lock);	my ($lock);

if ($how eq &GDBM_READER()) {	if ($how eq &GDBM_READER()) {
Line 3093 sub store_handler {	Line 3129 sub store_handler {
}	}
&register_handler("store", \&store_handler, 0, 1, 0);	&register_handler("store", \&store_handler, 0, 1, 0);

	# Modify a set of key=value pairs associated with a versioned name.
	#
	# Parameters:
	# $cmd - Request command keyword.
	# $tail - Tail of the request. This is a colon
	# separated list containing:
	# domain/user - User and authentication domain.
	# namespace - Name of the database being modified
	# rid - Resource keyword to modify.
	# v - Version item to modify
	# what - new value associated with rid.
	#
	# $client - Socket open on the client.
	#
	#
	# Returns:
	# 1 (keep on processing).
	# Side-Effects:
	# Writes to the client
	sub putstore_handler {
	my ($cmd, $tail, $client) = @_;

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

	my ($udom,$uname,$namespace,$rid,$v,$what) =split(/:/,$tail);
	if ($namespace ne 'roles') {

	chomp($what);
	my $hashref = &tie_user_hash($udom, $uname, $namespace,
	&GDBM_WRCREAT(), "M",
	"$rid:$v:$what");
	if ($hashref) {
	my $now = time;
	my %data = &hash_extract($what);
	my @allkeys;
	while (my($key,$value) = each(%data)) {
	push(@allkeys,$key);
	$hashref->{"$v:$rid:$key"} = $value;
	}
	my $allkeys = join(':',@allkeys);
	$hashref->{"$v:keys:$rid"}=$allkeys;

	if (&untie_user_hash($hashref)) {
	&Reply($client, "ok\n", $userinput);
	} else {
	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
	"while attempting store\n", $userinput);
	}
	} else {
	&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
	"while attempting store\n", $userinput);
	}
	} else {
	&Failure($client, "refused\n", $userinput);
	}

	return 1;
	}
	&register_handler("putstore", \&putstore_handler, 0, 1, 0);

	sub hash_extract {
	my ($str)=@_;
	my %hash;
	foreach my $pair (split(/\&/,$str)) {
	my ($key,$value)=split(/=/,$pair);
	$hash{$key}=$value;
	}
	return (%hash);
	}
	sub hash_to_str {
	my ($hash_ref)=@_;
	my $str;
	foreach my $key (keys(%$hash_ref)) {
	$str.=$key.'='.$hash_ref->{$key}.'&';
	}
	$str=~s/\&$//;
	return $str;
	}

#	#
# Dump out all versions of a resource that has key=value pairs associated	# Dump out all versions of a resource that has key=value pairs associated
# with it for each version. These resources are built up via the store	# with it for each version. These resources are built up via the store
Line 3161 sub restore_handler {	Line 3276 sub restore_handler {
&register_handler("restore", \&restore_handler, 0,1,0);	&register_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:	# Parameters:
# $cmd - Request keyword.	# $cmd - Request keyword.
# $tail - Tail of the command. A colon separated list	# $tail - Tail of the command. A colon separated list
# containing:	# containing:
# cdom - Domain on which the chat board lives	# cdom - Domain on which the chat board lives
# cnum - Identifier of the discussion group.	# cnum - Course containing the chat board.
# post - Body of the posting.	# 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.	# $client - Socket open on the client.
# Returns:	# Returns:
# 1 - Indicating caller should keep on processing.	# 1 - Indicating caller should keep on processing.
Line 3184 sub send_chat_handler {	Line 3301 sub send_chat_handler {

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

my ($cdom,$cnum,$newpost)=split(/\:/,$tail);	my ($cdom,$cnum,$newpost,$group)=split(/\:/,$tail);
&chat_add($cdom,$cnum,$newpost);	&chat_add($cdom,$cnum,$newpost,$group);
&Reply($client, "ok\n", $userinput);	&Reply($client, "ok\n", $userinput);

return 1;	return 1;
Line 3193 sub send_chat_handler {	Line 3310 sub send_chat_handler {
&register_handler("chatsend", \&send_chat_handler, 0, 1, 0);	&register_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:	# Parameters:
# $cmd - Command keyword that initiated the request.	# $cmd - Command keyword that initiated the request.
Line 3203 sub send_chat_handler {	Line 3320 sub send_chat_handler {
# chat id - Discussion thread(?)	# chat id - Discussion thread(?)
# domain/user - Authentication domain and username	# domain/user - Authentication domain and username
# of the requesting person.	# of the requesting person.
	# group - Optional course group containing
	# the board.
# $client - Socket open on the client program.	# $client - Socket open on the client program.
# Returns:	# Returns:
# 1 - continue processing	# 1 - continue processing
Line 3215 sub retrieve_chat_handler {	Line 3334 sub retrieve_chat_handler {

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

my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail);	my ($cdom,$cnum,$udom,$uname,$group)=split(/\:/,$tail);
my $reply='';	my $reply='';
foreach (&get_chat($cdom,$cnum,$udom,$uname)) {	foreach (&get_chat($cdom,$cnum,$udom,$uname,$group)) {
$reply.=&escape($_).':';	$reply.=&escape($_).':';
}	}
$reply=~s/\:$//;	$reply=~s/\:$//;
Line 4348 sub photo_permission_handler {	Line 4467 sub photo_permission_handler {
my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";
my $cdom = $tail;	my $cdom = $tail;
my ($perm_reqd,$conditions);	my ($perm_reqd,$conditions);
my $outcome = &localenroll::photo_permission($cdom,\$perm_reqd,	my $outcome;
\$conditions);	eval {
&Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n",	local($SIG{__DIE__})='DEFAULT';
$userinput);	$outcome = &localenroll::photo_permission($cdom,\$perm_reqd,
	\$conditions);
	};
	if (!$@) {
	&Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n",
	$userinput);
	} else {
	&Failure($client,"unknown_cmd\n",$userinput);
	}
	return 1;
}	}
&register_handler("autophotopermission",\&photo_permission_handler,0,1,0);	&register_handler("autophotopermission",\&photo_permission_handler,0,1,0);

Line 4376 sub photo_check_handler {	Line 4504 sub photo_check_handler {
my $result = &localstudentphoto::fetch($udom,$uname,$pid,\$response);	my $result = &localstudentphoto::fetch($udom,$uname,$pid,\$response);
$result .= ':'.$response;	$result .= ':'.$response;
&Reply($client, &escape($result)."\n",$userinput);	&Reply($client, &escape($result)."\n",$userinput);
	return 1;
}	}
&register_handler("autophotocheck",\&photo_check_handler,0,1,0);	&register_handler("autophotocheck",\&photo_check_handler,0,1,0);

Line 4389 sub photo_choice_handler {	Line 4518 sub photo_choice_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;
my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";
my $cdom = &unescape($tail);	my $cdom = &unescape($tail);
my ($update,$comment) = &localenroll::manager_photo_update($cdom);	my ($update,$comment);
&Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput);	eval {
	local($SIG{__DIE__})='DEFAULT';
	($update,$comment) = &localenroll::manager_photo_update($cdom);
	};
	if (!$@) {
	&Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput);
	} else {
	&Failure($client,"unknown_cmd\n",$userinput);
	}
	return 1;
}	}
&register_handler("autophotochoice",\&photo_choice_handler,0,1,0);	&register_handler("autophotochoice",\&photo_choice_handler,0,1,0);

Line 4423 sub student_photo_handler {	Line 4561 sub student_photo_handler {
&mkpath($path);	&mkpath($path);
my $file;	my $file;
if ($type eq 'thumbnail') {	if ($type eq 'thumbnail') {
$file=&localstudentphoto::fetch_thumbnail($domain,$uname);	eval {
	local($SIG{__DIE__})='DEFAULT';
	$file=&localstudentphoto::fetch_thumbnail($domain,$uname);
	};
} else {	} else {
$file=&localstudentphoto::fetch($domain,$uname);	$file=&localstudentphoto::fetch($domain,$uname);
}	}
Line 4493 sub process_request {	Line 4634 sub process_request {
# fix all the userinput -> user_input.	# fix all the userinput -> user_input.
my $wasenc = 0; # True if request was encrypted.	my $wasenc = 0; # True if request was encrypted.
# ------------------------------------------------------------ See if encrypted	# ------------------------------------------------------------ See if encrypted
	# for command
	# sethost:<server>
	# <command>:<args>
	# we just send it to the processor
	# for
	# sethost:<server>:<command>:<args>
	# we do the implict set host and then do the command
	if ($userinput =~ /^sethost:/) {
	(my $cmd,my $newid,$userinput) = split(':',$userinput,3);
	if (defined($userinput)) {
	&sethost("$cmd:$newid");
	} else {
	$userinput = "$cmd:$newid";
	}
	}

if ($userinput =~ /^enc/) {	if ($userinput =~ /^enc/) {
$userinput = decipher($userinput);	$userinput = decipher($userinput);
$wasenc=1;	$wasenc=1;
Line 5056 sub status {	Line 5213 sub status {
$0='lond: '.$what.' '.$local;	$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	# ----------------------------------------------------------- Send USR1 to lonc

sub reconlonc {	sub reconlonc {
Line 5146 sub sub_sql_reply {	Line 5287 sub sub_sql_reply {
Type => SOCK_STREAM,	Type => SOCK_STREAM,
Timeout => 10)	Timeout => 10)
or return "con_lost";	or return "con_lost";
print $sclient "$cmd\n";	print $sclient "$cmd:$currentdomainid\n";
my $answer=<$sclient>;	my $answer=<$sclient>;
chomp($answer);	chomp($answer);
if (!$answer) { $answer="con_lost"; }	if (!$answer) { $answer="con_lost"; }
Line 5481 sub is_author {	Line 5622 sub is_author {

# Author role should show up as a key /domain/_au	# Author role should show up as a key /domain/_au

my $key = "/$domain/_au";	my $key = "/$domain/_au";
my $value = $hashref->{$key};	my $value;
	if (defined($hashref)) {
	$value = $hashref->{$key};
	}

if(defined($value)) {	if(defined($value)) {
&Debug("$user @ $domain is an author");	&Debug("$user @ $domain is an author");
Line 5755 sub addline {	Line 5899 sub addline {
}	}

sub get_chat {	sub get_chat {
my ($cdom,$cname,$udom,$uname)=@_;	my ($cdom,$cname,$udom,$uname,$group)=@_;

my @entries=();	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());	&GDBM_READER());
if ($hashref) {	if ($hashref) {
@entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));	@entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
Line 5766 sub get_chat {	Line 5916 sub get_chat {
}	}
my @participants=();	my @participants=();
my $cutoff=time-60;	my $cutoff=time-60;
$hashref = &tie_user_hash($cdom, $cname, 'nohist_inchatroom',	$hashref = &tie_user_hash($cdom, $cname, $namespace_inroom,
&GDBM_WRCREAT());	&GDBM_WRCREAT());
if ($hashref) {	if ($hashref) {
$hashref->{$uname.':'.$udom}=time;	$hashref->{$uname.':'.$udom}=time;
Line 5781 sub get_chat {	Line 5931 sub get_chat {
}	}

sub chat_add {	sub chat_add {
my ($cdom,$cname,$newchat)=@_;	my ($cdom,$cname,$newchat,$group)=@_;
my @entries=();	my @entries=();
my $time=time;	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());	&GDBM_WRCREAT());
if ($hashref) {	if ($hashref) {
@entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));	@entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
Line 5807 sub chat_add {	Line 5963 sub chat_add {
}	}
{	{
my $proname=&propath($cdom,$cname);	my $proname=&propath($cdom,$cname);
if (open(CHATLOG,">>$proname/chatroom.log")) {	if (open(CHATLOG,">>$proname/$logfile")) {
print CHATLOG ("$time:".&unescape($newchat)."\n");	print CHATLOG ("$time:".&unescape($newchat)."\n");
}	}
close(CHATLOG);	close(CHATLOG);
Line 6082 sub convert_photo {	Line 6238 sub convert_photo {
sub sethost {	sub sethost {
my ($remotereq) = @_;	my ($remotereq) = @_;
my (undef,$hostid)=split(/:/,$remotereq);	my (undef,$hostid)=split(/:/,$remotereq);
	# ignore sethost if we are already correct
	if ($hostid eq $currenthostid) {
	return 'ok';
	}

if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }	if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {	if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
$currenthostid =$hostid;	$currenthostid =$hostid;

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

Removed from v.1.317
changed lines
	Added in v.1.326