loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.304 and 1.334

version 1.304, 2005/12/10 00:46:23	version 1.334, 2006/06/24 00:36:23
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;
use IO::File;	use IO::File;
#use Apache::File;	#use Apache::File;
use Symbol;
use POSIX;	use POSIX;
use Crypt::IDEA;	use Crypt::IDEA;
use LWP::UserAgent();	use LWP::UserAgent();
Line 87 my $ConnectionType;	Line 87 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 938 sub EditFile {	Line 939 sub EditFile {
return "ok\n";	return "ok\n";
}	}

#---------------------------------------------------------------
#
# Manipulation of hash based databases (factoring out common code
# for later use as we refactor.
#
# Ties a domain level resource file to a hash.
# If requested a history entry is created in the associated hist file.
#
# Parameters:
# domain - Name of the domain in which the resource file lives.
# namespace - Name of the hash within that domain.
# how - How to tie the hash (e.g. GDBM_WRCREAT()).
# loghead - Optional parameter, if present a log entry is created
# in the associated history file and this is the first part
# of that entry.
# logtail - Goes along with loghead, The actual logentry is of the
# form $loghead:<timestamp>:logtail.
# Returns:
# Reference to a hash bound to the db file or alternatively undef
# if the tie failed.
#
sub tie_domain_hash {
my ($domain,$namespace,$how,$loghead,$logtail) = @_;

# Filter out any whitespace in the domain name:

$domain =~ s/\W//g;

# We have enough to go on to tie the 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.
}
}

#
# Ties a user's resource file to a hash.
# If necessary, an appropriate history
# log file entry is made as well.
# This sub factors out common code from the subs that manipulate
# the various gdbm files that keep keyword value pairs.
# Parameters:
# domain - Name of the domain the user is in.
# user - Name of the 'current user'.
# namespace - Namespace representing the file to tie.
# how - What the tie is done to (e.g. GDBM_WRCREAT().
# loghead - Optional first part of log entry if there may be a
# history file.
# what - Optional tail of log entry if there may be a history
# file.
# Returns:
# hash to which the database is tied. It's up to the caller to untie.
# undef if the has could not be tied.
#
sub tie_user_hash {
my ($domain,$user,$namespace,$how,$loghead,$what) = @_;

$namespace=~s/\//\_/g; # / -> _
$namespace=~s/\W//g; # whitespace eliminated.
my $proname = propath($domain, $user);

# Tie the database.

my %hash;
if(tie(%hash, 'GDBM_File', "$proname/$namespace.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");
if($hfh) {
my $now = time;
print $hfh "$loghead:$now:$what\n";
}
$hfh->close;
}
return \%hash;
} else {
return undef;
}

}

# read_profile	# read_profile
#	#
# Returns a set of specific entries from a user's profile file.	# Returns a set of specific entries from a user's profile file.
Line 1067 sub read_profile {	Line 969 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 1943 sub update_resource_handler {	Line 1845 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");
	unlink("$fname.meta");
} else {	} else {
my $transname="$fname.in.transfer";	my $transname="$fname.in.transfer";
my $remoteurl=&reply("sub:$fname","$clientname");	my $remoteurl=&reply("sub:$fname","$clientname");
Line 1973 sub update_resource_handler {	Line 1877 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 1891 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 2209 sub token_auth_user_file_handler {	Line 2127 sub token_auth_user_file_handler {
my $reply="non_auth\n";	my $reply="non_auth\n";
if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.	if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
$session.'.id')) {	$session.'.id')) {
	flock(ENVIN,LOCK_SH);
while (my $line=<ENVIN>) {	while (my $line=<ENVIN>) {
if ($line=~ m\|userfile\.\Q$fname\E\=\|) { $reply="ok\n"; }	my ($envname)=split(/=/,$line,2);
	$envname=&unescape($envname);
	if ($envname=~ m\|^userfile\.\Q$fname\E\|) { $reply="ok\n"; }
}	}
close(ENVIN);	close(ENVIN);
&Reply($client, $reply, "$cmd:$tail");	&Reply($client, $reply, "$cmd:$tail");
Line 2361 sub put_user_profile_entry {	Line 2282 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 2290 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 2326 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 2345 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 2398 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 2465 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 2516 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 2657 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 2699 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 2760 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 2815 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 2914 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 2994 sub store_handler {	Line 2932 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 3028 sub restore_handler {	Line 3045 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 3064 sub restore_handler {	Line 3079 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 3087 sub send_chat_handler {	Line 3104 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 3096 sub send_chat_handler {	Line 3113 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 3106 sub send_chat_handler {	Line 3123 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 3118 sub retrieve_chat_handler {	Line 3137 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 3270 sub put_course_id_handler {	Line 3289 sub put_course_id_handler {
my @new_items = split(/:/,$courseinfo);	my @new_items = split(/:/,$courseinfo);
my $numnew = scalar(@new_items);	my $numnew = scalar(@new_items);
if ($numcurrent > 0) {	if ($numcurrent > 0) {
if ($numnew == 1) { # flushcourselogs() from 1.1 or earlier	if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2
$courseinfo .= ':'.join(':',@current_items);	for (my $j=$numcurrent-$numnew; $j>=0; $j--) {
} elsif ($numnew == 2) { # flushcourselogs() from 1.2.X	$courseinfo .= ':'.$current_items[$numcurrent-$j-1];
$courseinfo .= ':'.$current_items[$numcurrent-1];	}
}	}
}	}
$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 3333 sub dump_course_id_handler {	Line 3352 sub dump_course_id_handler {

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

my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter) =split(/:/,$tail);	my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
	$typefilter) =split(/:/,$tail);
if (defined($description)) {	if (defined($description)) {
$description=&unescape($description);	$description=&unescape($description);
} else {	} else {
Line 3354 sub dump_course_id_handler {	Line 3374 sub dump_course_id_handler {
} else {	} else {
$coursefilter='.';	$coursefilter='.';
}	}
	if (defined($typefilter)) {
	$typefilter=&unescape($typefilter);
	} else {
	$typefilter='.';
	}

unless (defined($since)) { $since=0; }	unless (defined($since)) { $since=0; }
my $qresult='';	my $qresult='';
my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());	my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
if ($hashref) {	if ($hashref) {
while (my ($key,$value) = each(%$hashref)) {	while (my ($key,$value) = each(%$hashref)) {
my ($descr,$lasttime,$inst_code,$owner);	my ($descr,$lasttime,$inst_code,$owner,$type);
my @courseitems = split(/:/,$value);	my @courseitems = split(/:/,$value);
$lasttime = pop(@courseitems);	$lasttime = pop(@courseitems);
($descr,$inst_code,$owner)=@courseitems;	($descr,$inst_code,$owner,$type)=@courseitems;
if ($lasttime<$since) { next; }	if ($lasttime<$since) { next; }
my $match = 1;	my $match = 1;
unless ($description eq '.') {	unless ($description eq '.') {
Line 3390 sub dump_course_id_handler {	Line 3415 sub dump_course_id_handler {
$match = 0;	$match = 0;
}	}
}	}
	unless ($typefilter eq '.' \|\| !defined($typefilter)) {
	my $unescapeType = &unescape($type);
	if (!defined($type)) {
	if ($typefilter ne 'Course') {
	$match = 0;
	}
	} else {
	unless (eval('$unescapeType=~/^\Q$typefilter\E$/')) {
	$match = 0;
	}
	}
	}
if ($match == 1) {	if ($match == 1) {
$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 3480 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 3529 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 3573 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 3616 sub dump_dcmail_handler {	Line 3653 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 3663 sub put_domainroles_handler {	Line 3700 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 3744 sub dump_domainroles_handler {	Line 3781 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 4239 sub get_institutional_code_format_handle	Line 4276 sub get_institutional_code_format_handle
&register_handler("autoinstcodeformat",	&register_handler("autoinstcodeformat",
\&get_institutional_code_format_handler,0,1,0);	\&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;
	eval {
	local($SIG{__DIE__})='DEFAULT';
	$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);

	#
	# 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);
	return 1;
	}
	&register_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);
	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);

#	#
# Gets a student's photo to exist (in the correct image type) in the user's	# Gets a student's photo to exist (in the correct image type) in the user's
# directory.	# directory.
Line 4251 sub get_institutional_code_format_handle	Line 4365 sub get_institutional_code_format_handle
# $client - The socket open on the client.	# $client - The socket open on the client.
# Returns:	# Returns:
# 1 - continue processing.	# 1 - continue processing.

sub student_photo_handler {	sub student_photo_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;
my ($domain,$uname,$type) = split(/:/, $tail);	my ($domain,$uname,$ext,$type) = split(/:/, $tail);

my $path=&propath($domain,$uname).	my $path=&propath($domain,$uname). '/userfiles/internal/';
'/userfiles/internal/studentphoto.'.$type;	my $filename = 'studentphoto.'.$ext;
if (-e $path) {	if ($type eq 'thumbnail') {
	$filename = 'studentphoto_tn.'.$ext;
	}
	if (-e $path.$filename) {
&Reply($client,"ok\n","$cmd:$tail");	&Reply($client,"ok\n","$cmd:$tail");
return 1;	return 1;
}	}
&mkpath($path);	&mkpath($path);
my $file=&localstudentphoto::fetch($domain,$uname);	my $file;
	if ($type eq 'thumbnail') {
	eval {
	local($SIG{__DIE__})='DEFAULT';
	$file=&localstudentphoto::fetch_thumbnail($domain,$uname);
	};
	} else {
	$file=&localstudentphoto::fetch($domain,$uname);
	}
if (!$file) {	if (!$file) {
&Failure($client,"unavailable\n","$cmd:$tail");	&Failure($client,"unavailable\n","$cmd:$tail");
return 1;	return 1;
}	}
if (!-e $path) { &convert_photo($file,$path); }	if (!-e $path.$filename) { &convert_photo($file,$path.$filename); }
if (-e $path) {	if (-e $path.$filename) {
&Reply($client,"ok\n","$cmd:$tail");	&Reply($client,"ok\n","$cmd:$tail");
return 1;	return 1;
}	}
Line 4329 sub process_request {	Line 4455 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 4683 sub ReadHostTable {	Line 4825 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 4891 sub status {	Line 5034 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 4933 sub reconlonc {	Line 5060 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 4954 sub reply {	Line 5081 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 4981 sub sub_sql_reply {	Line 5108 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"; }
return $answer;	return $answer;
}	}

# -------------------------------------------- Return path to profile directory

sub propath {
my ($udom,$uname)=@_;
$udom=~s/\W//g;
$uname=~s/\W//g;
my $subdir=$uname.'__';
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
return $proname;
}

# --------------------------------------- Is this the home server of an author?	# --------------------------------------- Is this the home server of an author?

sub ishome {	sub ishome {
Line 5260 sub make_new_child {	Line 5375 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 5316 sub is_author {	Line 5431 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 5590 sub addline {	Line 5708 sub addline {
}	}

sub get_chat {	sub get_chat {
my ($cdom,$cname,$udom,$uname)=@_;	my ($cdom,$cname,$udom,$uname,$group)=@_;
my %hash;
my $proname=&propath($cdom,$cname);
my @entries=();	my @entries=();
if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",	my $namespace = 'nohist_chatroom';
&GDBM_READER(),0640)) {	my $namespace_inroom = 'nohist_inchatroom';
@entries=map { $_.':'.$hash{$_} } sort keys %hash;	if (defined($group)) {
untie %hash;	$namespace .= '_'.$group;
	$namespace_inroom .= '_'.$group;
	}
	my $hashref = &tie_user_hash($cdom, $cname, $namespace,
	&GDBM_READER());
	if ($hashref) {
	@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, $namespace_inroom,
&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,$group)=@_;
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 $namespace = 'nohist_chatroom';
&GDBM_WRCREAT(),0640)) {	my $logfile = 'chatroom.log';
@entries=map { $_.':'.$hash{$_} } sort keys %hash;	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));
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 5632 sub chat_add {	Line 5762 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/$logfile")) {
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);
}	}
}	}

Line 5916 sub convert_photo {	Line 6047 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;
Line 6341 to the client, and the connection is clo	Line 6477 to the client, and the connection is clo
IO::Socket	IO::Socket
IO::File	IO::File
Apache::File	Apache::File
Symbol
POSIX	POSIX
Crypt::IDEA	Crypt::IDEA
LWP::UserAgent()	LWP::UserAgent()

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

Removed from v.1.304
changed lines
	Added in v.1.334