Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.301 and 1.341

version 1.301, 2005/10/17 20:09:01	version 1.341, 2006/08/31 13:00:50
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 834 sub AdjustOurHost {	Line 835 sub AdjustOurHost {
# Use the config line to get my hostname.	# Use the config line to get my hostname.
# Use gethostbyname to translate that into an IP address.	# Use gethostbyname to translate that into an IP address.
#	#
my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine);	my ($id,$domain,$role,$name,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine);
my $BinaryIp = gethostbyname($name);
my $ip = inet_ntoa($ip);
#	#
# Reassemble the config line from the elements in the list.	# Reassemble the config line from the elements in the list.
# Note that if the loncnew items were not present before, they will	# Note that if the loncnew items were not present before, they will
# be now even if they would be empty	# be now even if they would be empty
#	#
my $newConfigLine = $id;	my $newConfigLine = $id;
foreach my $item ($domain, $role, $name, $ip, $maxcon, $idleto, $mincon) {	foreach my $item ($domain, $role, $name, $maxcon, $idleto, $mincon) {
$newConfigLine .= ":".$item;	$newConfigLine .= ":".$item;
}	}
# Replace the line:	# Replace the line:
Line 889 sub EditFile {	Line 888 sub EditFile {

# Split the command into it's pieces: edit:filetype:script	# Split the command into it's pieces: edit:filetype:script

my ($request, $filetype, $script) = split(/:/, $request,3); # : in script	my ($cmd, $filetype, $script) = split(/:/, $request,3); # : in script

# Check the pre-coditions for success:	# Check the pre-coditions for success:

if($request != "edit") { # Something is amiss afoot alack.	if($cmd != "edit") { # Something is amiss afoot alack.
return "error:edit request detected, but request != 'edit'\n";	return "error:edit request detected, but request != 'edit'\n";
}	}
if( ($filetype ne "hosts") &&	if( ($filetype ne "hosts") &&
Line 938 sub EditFile {	Line 937 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 967 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 1350 sub push_file_handler {	Line 1250 sub push_file_handler {
#	#
sub du_handler {	sub du_handler {
my ($cmd, $ududir, $client) = @_;	my ($cmd, $ududir, $client) = @_;
my ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier.	($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier.
my $userinput = "$cmd:$ududir";	my $userinput = "$cmd:$ududir";

if ($ududir=~/\.\./ \|\| $ududir!~m\|^/home/httpd/\|) {	if ($ududir=~/\.\./ \|\| $ududir!~m\|^/home/httpd/\|) {
Line 1943 sub update_resource_handler {	Line 1843 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 1875 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 1889 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 2125 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 2280 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 2288 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 2324 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 2343 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 2396 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 2463 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 2514 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 2674 sub get_profile_entry_encrypted {	Line 2593 sub get_profile_entry_encrypted {

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

my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput);	my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
chomp($what);	chomp($what);
my $qresult = read_profile($udom, $uname, $namespace, $what);	my $qresult = read_profile($udom, $uname, $namespace, $what);
my ($first) = split(/:/, $qresult);	my ($first) = split(/:/, $qresult);
Line 2736 sub delete_profile_entry {	Line 2655 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 2697 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 2758 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 2813 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 2912 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 2930 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 3024 sub restore_handler {	Line 3039 sub restore_handler {

my $userinput = "$cmd:$tail"; # Only used for logging purposes.	my $userinput = "$cmd:$tail"; # Only used for logging purposes.

my ($cmd,$udom,$uname,$namespace,$rid) = split(/:/,$userinput);	my ($udom,$uname,$namespace,$rid) = split(/:/,$tail);
$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 3077 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 3102 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 3111 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 3121 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 3135 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 3197 sub reply_query_handler {	Line 3214 sub reply_query_handler {

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

my ($cmd,$id,$reply)=split(/:/,$userinput);	my ($id,$reply)=split(/:/,$tail);
my $store;	my $store;
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
if ($store=IO::File->new(">$execdir/tmp/$id")) {	if ($store=IO::File->new(">$execdir/tmp/$id")) {
Line 3270 sub put_course_id_handler {	Line 3287 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 3317 sub put_course_id_handler {	Line 3334 sub put_course_id_handler {
# institutional code - optional supplied code to filter	# institutional code - optional supplied code to filter
# the dump. Only courses with an institutional code	# the dump. Only courses with an institutional code
# that match the supplied code will be returned.	# that match the supplied code will be returned.
# owner - optional supplied username of owner to filter	# owner - optional supplied username and domain of owner to
# the dump. Only courses for which the course	# filter the dump. Only courses for which the course
# owner matches the supplied username will be	# owner matches the supplied username and/or domain
# returned. Implicit assumption that owner	# will be returned. Pre-2.2.0 legacy entries from
# is a user in the domain in which the	# nohist_courseiddump will only contain usernames.
# course database is defined.
# $client - The socket open on the client.	# $client - The socket open on the client.
# Returns:	# Returns:
# 1 - Continue processing.	# 1 - Continue processing.
Line 3333 sub dump_course_id_handler {	Line 3349 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 3344 sub dump_course_id_handler {	Line 3361 sub dump_course_id_handler {
} else {	} else {
$instcodefilter='.';	$instcodefilter='.';
}	}
	my ($ownerunamefilter,$ownerdomfilter);
if (defined($ownerfilter)) {	if (defined($ownerfilter)) {
$ownerfilter=&unescape($ownerfilter);	$ownerfilter=&unescape($ownerfilter);
	if ($ownerfilter ne '.' && defined($ownerfilter)) {
	if ($ownerfilter =~ /^([^:]):([^:])$/) {
	$ownerunamefilter = $1;
	$ownerdomfilter = $2;
	} else {
	$ownerunamefilter = $ownerfilter;
	$ownerdomfilter = '';
	}
	}
} else {	} else {
$ownerfilter='.';	$ownerfilter='.';
}	}

if (defined($coursefilter)) {	if (defined($coursefilter)) {
$coursefilter=&unescape($coursefilter);	$coursefilter=&unescape($coursefilter);
} 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 3380 sub dump_course_id_handler {	Line 3413 sub dump_course_id_handler {
}	}
unless ($ownerfilter eq '.' \|\| !defined($ownerfilter)) {	unless ($ownerfilter eq '.' \|\| !defined($ownerfilter)) {
my $unescapeOwner = &unescape($owner);	my $unescapeOwner = &unescape($owner);
unless (eval('$unescapeOwner=~/\Q$ownerfilter\E/i')) {	if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {
$match = 0;	if ($unescapeOwner =~ /:/) {
	if (eval('$unescapeOwner !~
	/\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i')) {
	$match = 0;
	}
	} else {
	if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) {
	$match = 0;
	}
	}
	} elsif ($ownerunamefilter ne '') {
	if ($unescapeOwner =~ /:/) {
	if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E:[^:]+$/i')) {
	$match = 0;
	}
	} else {
	if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) {
	$match = 0;
	}
	}
	} elsif ($ownerdomfilter ne '') {
	if ($unescapeOwner =~ /:/) {
	if (eval('$unescapeOwner!~/^[^:]+:\Q$ownerdomfilter\E/')) {
	$match = 0;
	}
	} else {
	if ($ownerdomfilter ne $udom) {
	$match = 0;
	}
	}
}	}
}	}
unless ($coursefilter eq '.' \|\| !defined($coursefilter)) {	unless ($coursefilter eq '.' \|\| !defined($coursefilter)) {
Line 3390 sub dump_course_id_handler {	Line 3452 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 3517 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 3566 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 3610 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 3668 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 3690 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 3737 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 3818 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 4009 sub enrollment_enabled_handler {	Line 4081 sub enrollment_enabled_handler {
my $userinput = $cmd.":".$tail; # For logging purposes.	my $userinput = $cmd.":".$tail; # For logging purposes.


my $cdom = split(/:/, $tail); # Domain we're asking about.	my ($cdom) = split(/:/, $tail, 2); # Domain we're asking about.

my $outcome = &localenroll::run($cdom);	my $outcome = &localenroll::run($cdom);
&Reply($client, "$outcome\n", $userinput);	&Reply($client, "$outcome\n", $userinput);

Line 4065 sub validate_course_owner_handler {	Line 4138 sub validate_course_owner_handler {
my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";
my ($inst_course_id, $owner, $cdom) = split(/:/, $tail);	my ($inst_course_id, $owner, $cdom) = split(/:/, $tail);

	$owner = &unescape($owner);
my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);	my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
&Reply($client, "$outcome\n", $userinput);	&Reply($client, "$outcome\n", $userinput);

Line 4105 sub validate_course_section_handler {	Line 4179 sub validate_course_section_handler {
&register_handler("autovalidatecourse", \&validate_course_section_handler, 0, 1, 0);	&register_handler("autovalidatecourse", \&validate_course_section_handler, 0, 1, 0);

#	#
# Create a password for a new auto-enrollment user.	# Validate course owner's access to enrollment data for specific class section.
# I think/guess, this password allows access to the institutions	#
# AIS class list server/services. Stuart can correct this comment	#
# when he finds out how wrong I am.	# Formal Parameters:
	# $cmd - The command request that got us dispatched.
	# $tail - The tail of the command. In this case this is a colon separated
	# set of words that will be split into:
	# $inst_class - Institutional code for the specific class section
	# $courseowner - The escaped username:domain of the course owner
	# $cdom - The domain of the course from the institution's
	# point of view.
	# $client - The socket open on the client.
	# Returns:
	# 1 - continue processing.
	#

	sub validate_class_access_handler {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my ($inst_class,$courseowner,$cdom) = split(/:/, $tail);
	$courseowner = &unescape($courseowner);
	my $outcome;
	eval {
	local($SIG{__DIE__})='DEFAULT';
	$outcome=&localenroll::check_section($inst_class,$courseowner,$cdom);
	};
	&Reply($client,"$outcome\n", $userinput);

	return 1;
	}
	&register_handler("autovalidateclass_sec", \&validate_class_access_handler, 0, 1, 0);

	#
	# Create a password for a new LON-CAPA user added by auto-enrollment.
	# Only used for case where authentication method for new user is localauth
#	#
# Formal Parameters:	# Formal Parameters:
# $cmd - The command request that got us dispatched.	# $cmd - The command request that got us dispatched.
# $tail - The tail of the command. In this case this is a colon separated	# $tail - The tail of the command. In this case this is a colon separated
# set of words that will be split into:	# set of words that will be split into:
# $authparam - An authentication parameter (username??).	# $authparam - An authentication parameter (localauth parameter).
# $cdom - The domain of the course from the institution's	# $cdom - The domain of the course from the institution's
# point of view.	# point of view.
# $client - The socket open on the client.	# $client - The socket open on the client.
Line 4241 sub get_institutional_code_format_handle	Line 4346 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 4253 sub get_institutional_code_format_handle	Line 4435 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 4331 sub process_request {	Line 4525 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 4685 sub ReadHostTable {	Line 4895 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 4893 sub status {	Line 5104 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 4935 sub reconlonc {	Line 5130 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 5151 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 4983 sub sub_sql_reply {	Line 5178 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 5167 sub make_new_child {	Line 5350 sub make_new_child {
my $remotereq=<$client>;	my $remotereq=<$client>;
chomp($remotereq);	chomp($remotereq);
Debug("Got init: $remotereq");	Debug("Got init: $remotereq");
my $inikeyword = split(/:/, $remotereq);
if ($remotereq =~ /^init/) {	if ($remotereq =~ /^init/) {
&sethost("sethost:$perlvar{'lonHostID'}");	&sethost("sethost:$perlvar{'lonHostID'}");
#	#
Line 5262 sub make_new_child {	Line 5445 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 5318 sub is_author {	Line 5501 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 5592 sub addline {	Line 5778 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 ($group ne '') {
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 ($group ne '') {
	$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 5634 sub chat_add {	Line 5832 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 5918 sub convert_photo {	Line 6117 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 6343 to the client, and the connection is clo	Line 6547 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>

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.301
changed lines
	Added in v.1.341