loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.309 and 1.354

version 1.309, 2006/01/31 04:26:41	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 %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 5664 sub chat_add {	Line 5991 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 5948 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 6373 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>

Removed from v.1.309
changed lines
	Added in v.1.354