Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.310 and 1.354

version 1.310, 2006/01/31 04:40:12	version 1.354, 2007/01/10 19:18:12
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();
	use Digest::MD5 qw(md5_hex);
use GDBM_File;	use GDBM_File;
use Authen::Krb4;	use Authen::Krb4;
use Authen::Krb5;	use Authen::Krb5;
Line 503 sub AdjustHostContents {	Line 504 sub AdjustHostContents {
my $adjusted;	my $adjusted;
my $me = $perlvar{'lonHostID'};	my $me = $perlvar{'lonHostID'};

foreach my $line (split(/\n/,$contents)) {	foreach my $line (split(/\n/,$contents)) {
if(!(($line eq "") \|\| ($line =~ /^ \#/) \|\| ($line =~ /^ $/))) {	if(!(($line eq "") \|\| ($line =~ /^ \#/) \|\| ($line =~ /^ $/))) {
chomp($line);	chomp($line);
my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);	my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
if ($id eq $me) {	if ($id eq $me) {
my $ip = gethostbyname($name);	my $ip = gethostbyname($name);
my $ipnew = inet_ntoa($ip);	my $ipnew = inet_ntoa($ip);
$ip = $ipnew;	$ip = $ipnew;
# Reconstruct the host line and append to adjusted:	# Reconstruct the host line and append to adjusted:

my $newline = "$id:$domain:$role:$name:$ip";	my $newline = "$id:$domain:$role:$name:$ip";
if($maxcon ne "") { # Not all hosts have loncnew tuning params	if($maxcon ne "") { # Not all hosts have loncnew tuning params
$newline .= ":$maxcon:$idleto:$mincon";	$newline .= ":$maxcon:$idleto:$mincon";
}	}
$adjusted .= $newline."\n";	$adjusted .= $newline."\n";

} else { # Not me, pass unmodified.	} else { # Not me, pass unmodified.
$adjusted .= $line."\n";	$adjusted .= $line."\n";
}	}
} else { # Blank or comment never re-written.	} else { # Blank or comment never re-written.
$adjusted .= $line."\n"; # Pass blanks and comments as is.	$adjusted .= $line."\n"; # Pass blanks and comments as is.
}	}
}	}
return $adjusted;	return $adjusted;
}	}
#	#
# InstallFile: Called to install an administrative file:	# InstallFile: Called to install an administrative file:
Line 835 sub AdjustOurHost {	Line 836 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 890 sub EditFile {	Line 889 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 939 sub EditFile {	Line 938 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 1068 sub read_profile {	Line 968 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 1351 sub push_file_handler {	Line 1251 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 1675 sub change_password_handler {	Line 1575 sub change_password_handler {
# uname - Username.	# uname - Username.
# upass - Current password.	# upass - Current password.
# npass - New password.	# npass - New password.
	# context - Context in which this was called
	# (preferences or reset_by_email).

my ($udom,$uname,$upass,$npass)=split(/:/,$tail);	my ($udom,$uname,$upass,$npass,$context)=split(/:/,$tail);

$upass=&unescape($upass);	$upass=&unescape($upass);
$npass=&unescape($npass);	$npass=&unescape($npass);
&Debug("Trying to change password for $uname");	&Debug("Trying to change password for $uname");

# First require that the user can be authenticated with their	# First require that the user can be authenticated with their
# old password:	# old password unless context was 'reset_by_email':

my $validated = &validate_user($udom, $uname, $upass);	my $validated;
	if ($context eq 'reset_by_email') {
	$validated = 1;
	} else {
	$validated = &validate_user($udom, $uname, $upass);
	}
if($validated) {	if($validated) {
my $realpasswd = &get_auth_type($udom, $uname); # Defined since authd.	my $realpasswd = &get_auth_type($udom, $uname); # Defined since authd.

Line 1704 sub change_password_handler {	Line 1611 sub change_password_handler {
."to change password");	."to change password");
&Failure( $client, "non_authorized\n",$userinput);	&Failure( $client, "non_authorized\n",$userinput);
}	}
} elsif ($howpwd eq 'unix') {	} elsif ($howpwd eq 'unix' && $context ne 'reset_by_email') {
my $result = &change_unix_password($uname, $npass);	my $result = &change_unix_password($uname, $npass);
&logthis("Result of password change for $uname: ".	&logthis("Result of password change for $uname: ".
$result);	$result);
Line 1946 sub update_resource_handler {	Line 1853 sub update_resource_handler {
my $reply=&reply("unsub:$fname","$clientname");	my $reply=&reply("unsub:$fname","$clientname");
&devalidate_meta_cache($fname);	&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 2223 sub token_auth_user_file_handler {	Line 2131 sub token_auth_user_file_handler {

chomp($session);	chomp($session);
my $reply="non_auth\n";	my $reply="non_auth\n";
if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.	my $file = $perlvar{'lonIDsDir'}.'/'.$session.'.id';
$session.'.id')) {	if (open(ENVIN,"$file")) {
while (my $line=<ENVIN>) {	flock(ENVIN,LOCK_SH);
if ($line=~ m\|userfile\.\Q$fname\E\=\|) { $reply="ok\n"; }	tie(my %disk_env,'GDBM_File',"$file",&GDBM_READER(),0640);
	if (exists($disk_env{"userfile.$fname"})) {
	$reply="ok\n";
	} else {
	foreach my $envname (keys(%disk_env)) {
	if ($envname=~ m\|^userfile\.\Q$fname\E\|) {
	$reply="ok\n";
	last;
	}
	}
}	}
	untie(%disk_env);
close(ENVIN);	close(ENVIN);
&Reply($client, $reply, "$cmd:$tail");	&Reply($client, $reply, "$cmd:$tail");
} else {	} else {
Line 2377 sub put_user_profile_entry {	Line 2295 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 2385 sub put_user_profile_entry {	Line 2303 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 2421 sub newput_user_profile_entry {	Line 2339 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 2440 sub newput_user_profile_entry {	Line 2358 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 2493 sub increment_user_value_handler {	Line 2411 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 2560 sub roles_put_handler {	Line 2478 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 2611 sub roles_delete_handler {	Line 2529 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 2690 sub get_profile_entry_encrypted {	Line 2608 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 2752 sub delete_profile_entry {	Line 2670 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 2794 sub get_profile_keys {	Line 2712 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 2855 sub dump_profile_database {	Line 2773 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 2947 sub dump_with_regexp {	Line 2865 sub dump_with_regexp {
}	}
}	}
}	}
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 3009 sub store_handler {	Line 2927 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 3027 sub store_handler {	Line 2945 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 3056 sub restore_handler {	Line 3053 sub restore_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;

my $userinput = "$cmd:$tail"; # Only used for logging purposes.	my $userinput = "$cmd:$tail"; # Only used for logging purposes.
	my ($udom,$uname,$namespace,$rid) = split(/:/,$tail);
my ($cmd,$udom,$uname,$namespace,$rid) = split(/:/,$userinput);
$namespace=~s/\//\_/g;	$namespace=~s/\//\_/g;
$namespace=~s/\W//g;	$namespace = &LONCAPA::clean_username($namespace);

chomp($rid);	chomp($rid);
my $qresult='';	my $qresult='';
my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER());	my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER());
Line 3076 sub restore_handler {	Line 3073 sub restore_handler {
$qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&";	$qresult.="$scope:$key=".$hashref->{"$scope:$rid:$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 3095 sub restore_handler {	Line 3092 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 3118 sub send_chat_handler {	Line 3117 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 3127 sub send_chat_handler {	Line 3126 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 3137 sub send_chat_handler {	Line 3136 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 3149 sub retrieve_chat_handler {	Line 3150 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 3228 sub reply_query_handler {	Line 3229 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 3301 sub put_course_id_handler {	Line 3302 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 3348 sub put_course_id_handler {	Line 3349 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 3364 sub dump_course_id_handler {	Line 3364 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,$regexp_ok) =split(/:/,$tail);
if (defined($description)) {	if (defined($description)) {
$description=&unescape($description);	$description=&unescape($description);
} else {	} else {
Line 3375 sub dump_course_id_handler {	Line 3376 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='.';
	}
	if (defined($regexp_ok)) {
	$regexp_ok=&unescape($regexp_ok);
	}

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 3405 sub dump_course_id_handler {	Line 3425 sub dump_course_id_handler {
}	}
unless ($instcodefilter eq '.' \|\| !defined($instcodefilter)) {	unless ($instcodefilter eq '.' \|\| !defined($instcodefilter)) {
my $unescapeInstcode = &unescape($inst_code);	my $unescapeInstcode = &unescape($inst_code);
unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) {	if ($regexp_ok) {
$match = 0;	unless (eval('$unescapeInstcode=~/$instcodefilter/')) {
	$match = 0;
	}
	} else {
	unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) {
	$match = 0;
	}
}	}
}	}
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 3421 sub dump_course_id_handler {	Line 3476 sub dump_course_id_handler {
$match = 0;	$match = 0;
}	}
}	}
	unless ($typefilter eq '.' \|\| !defined($typefilter)) {
	my $unescapeType = &unescape($type);
	if ($type eq '') {
	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 dump_course_id_handler {	Line 3510 sub dump_course_id_handler {
&register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);	&register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);

#	#
	# Puts an unencrypted entry in a namespace db file at the domain level
	#
	# Parameters:
	# $cmd - The command that got us here.
	# $tail - Tail of the command (remaining parameters).
	# $client - File descriptor connected to client.
	# Returns
	# 0 - Requested to exit, caller should shut down.
	# 1 - Continue processing.
	# Side effects:
	# reply is written to $client.
	#
	sub put_domain_handler {
	my ($cmd,$tail,$client) = @_;

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

	my ($udom,$namespace,$what) =split(/:/,$tail,3);
	chomp($what);
	my @pairs=split(/\&/,$what);
	my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_WRCREAT(),
	"P", $what);
	if ($hashref) {
	foreach my $pair (@pairs) {
	my ($key,$value)=split(/=/,$pair);
	$hashref->{$key}=$value;
	}
	if (&untie_domain_hash($hashref)) {
	&Reply($client, "ok\n", $userinput);
	} else {
	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
	"while attempting putdom\n", $userinput);
	}
	} else {
	&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
	"while attempting putdom\n", $userinput);
	}

	return 1;
	}
	&register_handler("putdom", \&put_domain_handler, 0, 1, 0);

	# Unencrypted get from the namespace database file at the domain level.
	# This function retrieves a keyed item from a specific named database in the
	# domain directory.
	#
	# Parameters:
	# $cmd - Command request keyword (get).
	# $tail - Tail of the command. This is a colon separated list
	# consisting of the domain and the 'namespace'
	# which selects the gdbm file to do the lookup in,
	# & separated list of keys to lookup. Note that
	# the values are returned as an & separated list too.
	# $client - File descriptor open on the client.
	# Returns:
	# 1 - Continue processing.
	# 0 - Exit.
	# Side effects:
	# reply is written to $client.
	#

	sub get_domain_handler {
	my ($cmd, $tail, $client) = @_;

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

	my ($udom,$namespace,$what)=split(/:/,$tail,3);
	chomp($what);
	my @queries=split(/\&/,$what);
	my $qresult='';
	my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_READER());
	if ($hashref) {
	for (my $i=0;$i<=$#queries;$i++) {
	$qresult.="$hashref->{$queries[$i]}&";
	}
	if (&untie_domain_hash($hashref)) {
	$qresult=~s/\&$//;
	&Reply($client, "$qresult\n", $userinput);
	} else {
	&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
	"while attempting getdom\n",$userinput);
	}
	} else {
	&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
	"while attempting getdom\n",$userinput);
	}

	return 1;
	}
	&register_handler("getdom", \&get_id_handler, 0, 1, 0);


	#
# Puts an id to a domains id database.	# Puts an id to a domains id database.
#	#
# Parameters:	# Parameters:
Line 3474 sub put_id_handler {	Line 3634 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 3523 sub get_id_handler {	Line 3683 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 3567 sub put_dcmail_handler {	Line 3727 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 3647 sub dump_dcmail_handler {	Line 3807 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 3694 sub put_domainroles_handler {	Line 3854 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 3775 sub dump_domainroles_handler {	Line 3935 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 3813 sub tmp_put_handler {	Line 3973 sub tmp_put_handler {

my $userinput = "$cmd:$what"; # Reconstruct for logging.	my $userinput = "$cmd:$what"; # Reconstruct for logging.

	my ($record,$context) = split(/:/,$what);
my $store;	if ($context ne '') {
	chomp($context);
	$context = &unescape($context);
	}
	my ($id,$store);
$tmpsnum++;	$tmpsnum++;
my $id=$$.'_'.$clientip.'_'.$tmpsnum;	if ($context eq 'resetpw') {
	$id = &md5_hex(&md5_hex(time.{}.rand().$$));
	} else {
	$id = $$.'_'.$clientip.'_'.$tmpsnum;
	}
$id=~s/\W/\_/g;	$id=~s/\W/\_/g;
$what=~s/\n//g;	$record=~s/\n//g;
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {	if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
print $store $what;	print $store $record;
close $store;	close $store;
&Reply($client, "$id\n", $userinput);	&Reply($client, "$id\n", $userinput);
} else {	} else {
Line 4038 sub enrollment_enabled_handler {	Line 4206 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 4094 sub validate_course_owner_handler {	Line 4263 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 4134 sub validate_course_section_handler {	Line 4304 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 4270 sub get_institutional_code_format_handle	Line 4471 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);

	sub get_institutional_defaults_handler {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";

	my $dom = $tail;
	my %defaults_hash;
	my @code_order;
	my $outcome;
	eval {
	local($SIG{__DIE__})='DEFAULT';
	$outcome = &localenroll::instcode_defaults($dom,\%defaults_hash,
	\@code_order);
	};
	if (!$@) {
	if ($outcome eq 'ok') {
	my $result='';
	while (my ($key,$value) = each(%defaults_hash)) {
	$result.=&escape($key).'='.&escape($value).'&';
	}
	$result .= 'code_order='.&escape(join('&',@code_order));
	&Reply($client,$result."\n",$userinput);
	} else {
	&Reply($client,"error\n", $userinput);
	}
	} else {
	&Failure($client,"unknown_cmd\n",$userinput);
	}
	}
	&register_handler("autoinstcodedefaults",
	\&get_institutional_defaults_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 4282 sub get_institutional_code_format_handle	Line 4592 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 4360 sub process_request {	Line 4682 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 4923 sub status {	Line 5261 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 5013 sub sub_sql_reply {	Line 5335 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 5156 sub make_new_child {	Line 5466 sub make_new_child {
# my $tmpsnum=0; # Now global	# my $tmpsnum=0; # Now global
#---------------------------------------------------- kerberos 5 initialization	#---------------------------------------------------- kerberos 5 initialization
&Authen::Krb5::init_context();	&Authen::Krb5::init_context();
unless (($dist eq 'fedora4') \|\| ($dist eq 'suse9.3')) {	unless (($dist eq 'fedora5') \|\| ($dist eq 'fedora4')
	\|\| ($dist eq 'suse9.3')) {
&Authen::Krb5::init_ets();	&Authen::Krb5::init_ets();
}	}

Line 5197 sub make_new_child {	Line 5508 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 5348 sub is_author {	Line 5659 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 5579 sub validate_user {	Line 5893 sub validate_user {
# Authenticate via installation specific authentcation method:	# Authenticate via installation specific authentcation method:
$validated = &localauth::localauth($user,	$validated = &localauth::localauth($user,
$password,	$password,
$contentpwd);	$contentpwd,
	$domain);
} else { # Unrecognized auth is also bad.	} else { # Unrecognized auth is also bad.
$validated = 0;	$validated = 0;
}	}
Line 5622 sub addline {	Line 5937 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 ($group ne '') {
	$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));
untie(%$hashref);	&untie_user_hash($hashref);
}	}
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 5642 sub get_chat {	Line 5963 sub get_chat {
push(@participants, 'active_participant:'.$user);	push(@participants, 'active_participant:'.$user);
}	}
}	}
untie(%$hashref);	&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 @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 ($group ne '') {
	$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 5674 sub chat_add {	Line 6001 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);
}	}
untie(%$hashref);	&untie_user_hash($hashref);
}	}
}	}

Line 5949 sub convert_photo {	Line 6276 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 6374 to the client, and the connection is clo	Line 6706 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.310
changed lines
	Added in v.1.354