loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.284 and 1.311

version 1.284, 2005/06/03 18:23:19	version 1.311, 2006/01/31 15:37:41
Line 48 use localauth;	Line 48 use localauth;
use localenroll;	use localenroll;
use localstudentphoto;	use localstudentphoto;
use File::Copy;	use File::Copy;
	use File::Find;
use LONCAPA::ConfigFileEdit;	use LONCAPA::ConfigFileEdit;
use LONCAPA::lonlocal;	use LONCAPA::lonlocal;
use LONCAPA::lonssl;	use LONCAPA::lonssl;
Line 86 my $ConnectionType;	Line 87 my $ConnectionType;

my %hostid; # ID's for hosts in cluster by ip.	my %hostid; # ID's for hosts in cluster by ip.
my %hostdom; # LonCAPA domain for hosts in cluster.	my %hostdom; # LonCAPA domain for hosts in cluster.
	my %hostname; # DNSname -> ID's mapping.
my %hostip; # IPs for hosts in cluster.	my %hostip; # IPs for hosts in cluster.
my %hostdns; # ID's of hosts looked up by DNS name.	my %hostdns; # ID's of hosts looked up by DNS name.

Line 112 my %Dispatcher;	Line 114 my %Dispatcher;
#	#
my $lastpwderror = 13; # Largest error number from lcpasswd.	my $lastpwderror = 13; # Largest error number from lcpasswd.
my @passwderrors = ("ok",	my @passwderrors = ("ok",
"lcpasswd must be run as user 'www'",	"pwchange_failure - lcpasswd must be run as user 'www'",
"lcpasswd got incorrect number of arguments",	"pwchange_failure - lcpasswd got incorrect number of arguments",
"lcpasswd did not get the right nubmer of input text lines",	"pwchange_failure - lcpasswd did not get the right nubmer of input text lines",
"lcpasswd too many simultaneous pwd changes in progress",	"pwchange_failure - lcpasswd too many simultaneous pwd changes in progress",
"lcpasswd User does not exist.",	"pwchange_failure - lcpasswd User does not exist.",
"lcpasswd Incorrect current passwd",	"pwchange_failure - lcpasswd Incorrect current passwd",
"lcpasswd Unable to su to root.",	"pwchange_failure - lcpasswd Unable to su to root.",
"lcpasswd Cannot set new passwd.",	"pwchange_failure - lcpasswd Cannot set new passwd.",
"lcpasswd Username has invalid characters",	"pwchange_failure - lcpasswd Username has invalid characters",
"lcpasswd Invalid characters in password",	"pwchange_failure - lcpasswd Invalid characters in password",
"lcpasswd User already exists",	"pwchange_failure - lcpasswd User already exists",
"lcpasswd Something went wrong with user addition.",	"pwchange_failure - lcpasswd Something went wrong with user addition.",
"lcpasswd Password mismatch",	"pwchange_failure - lcpasswd Password mismatch",
"lcpasswd Error filename is invalid");	"pwchange_failure - lcpasswd Error filename is invalid");


# The array below are lcuseradd error strings.:	# The array below are lcuseradd error strings.:
Line 986 sub tie_domain_hash {	Line 988 sub tie_domain_hash {
}	}
}	}

	sub untie_domain_hash {
	my ($hashref) = @_;
	untie(%$hashref);
	}
#	#
# Ties a user's resource file to a hash.	# Ties a user's resource file to a hash.
# If necessary, an appropriate history	# If necessary, an appropriate history
Line 1036 sub tie_user_hash {	Line 1042 sub tie_user_hash {

}	}

	sub untie_user_hash {
	my ($hashref) = @_;
	my $result = untie(%$hashref);
	return $result;
	}
# 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 1066 sub read_profile {	Line 1077 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 1363 sub du_handler {	Line 1374 sub du_handler {
# etc.	# etc.
#	#
if (-d $ududir) {	if (-d $ududir) {
# And as Shakespeare would say to make	my $total_size=0;
# assurance double sure,	my $code=sub {
# use execute_command to ensure that the command is not executed in	if ($_=~/\.\d+\./) { return;}
# a shell that can screw us up.	if ($_=~/\.meta$/) { return;}
	$total_size+=(stat($_))[7];
my $duout = execute_command("du -ks $ududir");	};
$duout=~s/[^\d]//g; #preserve only the numbers	chdir($ududir);
&Reply($client,"$duout\n","$cmd:$ududir");	find($code,$ududir);
	$total_size=int($total_size/1024);
	&Reply($client,"$total_size\n","$cmd:$ududir");
} else {	} else {

&Failure($client, "bad_directory:$ududir\n","$cmd:$ududir");	&Failure($client, "bad_directory:$ududir\n","$cmd:$ududir");

}	}
return 1;	return 1;
}	}
Line 1413 sub ls_handler {	Line 1424 sub ls_handler {
if(-d $ulsdir) {	if(-d $ulsdir) {
if (opendir(LSDIR,$ulsdir)) {	if (opendir(LSDIR,$ulsdir)) {
while ($ulsfn=readdir(LSDIR)) {	while ($ulsfn=readdir(LSDIR)) {
undef $obs, $rights;	undef($obs);
	undef($rights);
my @ulsstats=stat($ulsdir.'/'.$ulsfn);	my @ulsstats=stat($ulsdir.'/'.$ulsfn);
#We do some obsolete checking here	#We do some obsolete checking here
if(-e $ulsdir.'/'.$ulsfn.".meta") {	if(-e $ulsdir.'/'.$ulsfn.".meta") {
open(FILE, $ulsdir.'/'.$ulsfn.".meta");	open(FILE, $ulsdir.'/'.$ulsfn.".meta");
my @obsolete=<FILE>;	my @obsolete=<FILE>;
foreach my $obsolete (@obsolete) {	foreach my $obsolete (@obsolete) {
if($obsolete =~ m\|(<obsolete>)(on)\|) { $obs = 1; }	if($obsolete =~ m/(<obsolete>)(on\|1)/) { $obs = 1; }
if($obsolete =~ m\|(<copyright>)(default)\|) { $rights = 1; }	if($obsolete =~ m\|(<copyright>)(default)\|) { $rights = 1; }
}	}
}	}
Line 1480 sub ls2_handler {	Line 1492 sub ls2_handler {
if(-d $ulsdir) {	if(-d $ulsdir) {
if (opendir(LSDIR,$ulsdir)) {	if (opendir(LSDIR,$ulsdir)) {
while ($ulsfn=readdir(LSDIR)) {	while ($ulsfn=readdir(LSDIR)) {
undef $obs, $rights;	undef($obs);
	undef($rights);
my @ulsstats=stat($ulsdir.'/'.$ulsfn);	my @ulsstats=stat($ulsdir.'/'.$ulsfn);
#We do some obsolete checking here	#We do some obsolete checking here
if(-e $ulsdir.'/'.$ulsfn.".meta") {	if(-e $ulsdir.'/'.$ulsfn.".meta") {
open(FILE, $ulsdir.'/'.$ulsfn.".meta");	open(FILE, $ulsdir.'/'.$ulsfn.".meta");
my @obsolete=<FILE>;	my @obsolete=<FILE>;
foreach my $obsolete (@obsolete) {	foreach my $obsolete (@obsolete) {
if($obsolete =~ m\|(<obsolete>)(on)\|) { $obs = 1; }	if($obsolete =~ m/(<obsolete>)(on\|1)/) { $obs = 1; }
if($obsolete =~ m\|(<copyright>)(default)\|) {	if($obsolete =~ m\|(<copyright>)(default)\|) {
$rights = 1;	$rights = 1;
}	}
Line 1701 sub change_password_handler {	Line 1714 sub change_password_handler {
&Failure( $client, "non_authorized\n",$userinput);	&Failure( $client, "non_authorized\n",$userinput);
}	}
} elsif ($howpwd eq 'unix') {	} elsif ($howpwd eq 'unix') {
# Unix means we have to access /etc/password	my $result = &change_unix_password($uname, $npass);
&Debug("auth is unix");
my $execdir=$perlvar{'lonDaemons'};
&Debug("Opening lcpasswd pipeline");
my $pf = IO::File->new("\|$execdir/lcpasswd > "
."$perlvar{'lonDaemons'}"
."/logs/lcpasswd.log");
print $pf "$uname\n$npass\n$npass\n";
close $pf;
my $err = $?;
my $result = ($err>0 ? 'pwchange_failure' : 'ok');
&logthis("Result of password change for $uname: ".	&logthis("Result of password change for $uname: ".
&lcpasswdstrerror($?));	$result);
&Reply($client, "$result\n", $userinput);	&Reply($client, "$result\n", $userinput);
} else {	} else {
# this just means that the current password mode is not	# this just means that the current password mode is not
Line 1812 sub add_user_handler {	Line 1815 sub add_user_handler {
# Implicit inputs:	# Implicit inputs:
# The authentication systems describe above have their own forms of implicit	# The authentication systems describe above have their own forms of implicit
# input into the authentication process that are described above.	# input into the authentication process that are described above.
	# NOTE:
	# This is also used to change the authentication credential values (e.g. passwd).
	#
#	#
sub change_authentication_handler {	sub change_authentication_handler {

Line 1831 sub change_authentication_handler {	Line 1837 sub change_authentication_handler {
my $oldauth = &get_auth_type($udom, $uname); # Get old auth info.	my $oldauth = &get_auth_type($udom, $uname); # Get old auth info.
my $passfilename = &password_path($udom, $uname);	my $passfilename = &password_path($udom, $uname);
if ($passfilename) { # Not allowed to create a new user!!	if ($passfilename) { # Not allowed to create a new user!!
my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);	# If just changing the unix passwd. need to arrange to run
#	# passwd since otherwise make_passwd_file will run
# If the current auth mode is internal, and the old auth mode was	# lcuseradd which fails if an account already exists
# unix, or krb*, and the user is an author for this domain,	# (to prevent an unscrupulous LONCAPA admin from stealing
# re-run manage_permissions for that role in order to be able	# an existing account by overwriting it as a LonCAPA account).
# to take ownership of the construction space back to www:www
#	if(($oldauth =~/^unix/) && ($umode eq "unix")) {
	my $result = &change_unix_password($uname, $npass);
if( (($oldauth =~ /^unix/) && ($umode eq "internal")) \|\|	&logthis("Result of password change for $uname: ".$result);
(($oldauth =~ /^internal/) && ($umode eq "unix")) ) {	if ($result eq "ok") {
if(&is_author($udom, $uname)) {	&Reply($client, "$result\n")
&Debug(" Need to manage author permissions...");	} else {
&manage_permissions("/$udom/_au", $udom, $uname, "$umode:");	&Failure($client, "$result\n");
}	}
	} else {
	my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);
	#
	# If the current auth mode is internal, and the old auth mode was
	# unix, or krb*, and the user is an author for this domain,
	# re-run manage_permissions for that role in order to be able
	# to take ownership of the construction space back to www:www
	#


	if( (($oldauth =~ /^unix/) && ($umode eq "internal")) \|\|
	(($oldauth =~ /^internal/) && ($umode eq "unix")) ) {
	if(&is_author($udom, $uname)) {
	&Debug(" Need to manage author permissions...");
	&manage_permissions("/$udom/_au", $udom, $uname, "$umode:");
	}
	}
	&Reply($client, $result, $userinput);
}	}


&Reply($client, $result, $userinput);
} else {	} else {
&Failure($client, "non_authorized\n", $userinput); # Fail the user now.	&Failure($client, "non_authorized\n", $userinput); # Fail the user now.
}	}
Line 1930 sub update_resource_handler {	Line 1953 sub update_resource_handler {
my $since=$now-$atime;	my $since=$now-$atime;
if ($since>$perlvar{'lonExpire'}) {	if ($since>$perlvar{'lonExpire'}) {
my $reply=&reply("unsub:$fname","$clientname");	my $reply=&reply("unsub:$fname","$clientname");
	&devalidate_meta_cache($fname);
unlink("$fname");	unlink("$fname");
} else {	} else {
my $transname="$fname.in.transfer";	my $transname="$fname.in.transfer";
Line 1960 sub update_resource_handler {	Line 1984 sub update_resource_handler {
alarm(0);	alarm(0);
}	}
rename($transname,$fname);	rename($transname,$fname);
	&devalidate_meta_cache($fname);
}	}
}	}
&Reply( $client, "ok\n", $userinput);	&Reply( $client, "ok\n", $userinput);
Line 1973 sub update_resource_handler {	Line 1998 sub update_resource_handler {
}	}
&register_handler("update", \&update_resource_handler, 0 ,1, 0);	&register_handler("update", \&update_resource_handler, 0 ,1, 0);

	sub devalidate_meta_cache {
	my ($url) = @_;
	use Cache::Memcached;
	my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
	$url = &declutter($url);
	$url =~ s-\.meta$--;
	my $id = &escape('meta:'.$url);
	$memcache->delete($id);
	}

	sub declutter {
	my $thisfn=shift;
	$thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
	$thisfn=~s/^\///;
	$thisfn=~s\|^adm/wrapper/\|\|;
	$thisfn=~s\|^adm/coursedocs/showdoc/\|\|;
	$thisfn=~s/^res\///;
	$thisfn=~s/\?.+$//;
	return $thisfn;
	}
#	#
# Fetch a user file from a remote server to the user's home directory	# Fetch a user file from a remote server to the user's home directory
# userfiles subdir.	# userfiles subdir.
Line 2341 sub put_user_profile_entry {	Line 2386 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 2404 sub newput_user_profile_entry {	Line 2449 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 2457 sub increment_user_value_handler {	Line 2502 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 2524 sub roles_put_handler {	Line 2569 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 2575 sub roles_delete_handler {	Line 2620 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 2716 sub delete_profile_entry {	Line 2761 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 2758 sub get_profile_keys {	Line 2803 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 2819 sub dump_profile_database {	Line 2864 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 2874 sub dump_with_regexp {	Line 2919 sub dump_with_regexp {

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

my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail);	my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail);
if (defined($regexp)) {	if (defined($regexp)) {
$regexp=&unescape($regexp);	$regexp=&unescape($regexp);
} else {	} else {
$regexp='.';	$regexp='.';
}	}
	my ($start,$end);
	if (defined($range)) {
	if ($range =~/^(\d+)\-(\d+)$/) {
	($start,$end) = ($1,$2);
	} elsif ($range =~/^(\d+)$/) {
	($start,$end) = (0,$1);
	} else {
	undef($range);
	}
	}
my $hashref = &tie_user_hash($udom, $uname, $namespace,	my $hashref = &tie_user_hash($udom, $uname, $namespace,
&GDBM_READER());	&GDBM_READER());
if ($hashref) {	if ($hashref) {
my $qresult='';	my $qresult='';
	my $count=0;
while (my ($key,$value) = each(%$hashref)) {	while (my ($key,$value) = each(%$hashref)) {
if ($regexp eq '.') {	if ($regexp eq '.') {
	$count++;
	if (defined($range) && $count >= $end) { last; }
	if (defined($range) && $count < $start) { next; }
$qresult.=$key.'='.$value.'&';	$qresult.=$key.'='.$value.'&';
} else {	} else {
my $unescapeKey = &unescape($key);	my $unescapeKey = &unescape($key);
if (eval('$unescapeKey=~/$regexp/')) {	if (eval('$unescapeKey=~/$regexp/')) {
	$count++;
	if (defined($range) && $count >= $end) { last; }
	if (defined($range) && $count < $start) { next; }
$qresult.="$key=$value&";	$qresult.="$key=$value&";
}	}
}	}
}	}
if (untie(%$hashref)) {	if (&untie_user_hash($hashref)) {
chop($qresult);	chop($qresult);
&Reply($client, "$qresult\n", $userinput);	&Reply($client, "$qresult\n", $userinput);
} else {	} else {
Line 2956 sub store_handler {	Line 3018 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 3008 sub restore_handler {	Line 3070 sub restore_handler {
$namespace=~s/\//\_/g;	$namespace=~s/\//\_/g;
$namespace=~s/\W//g;	$namespace=~s/\W//g;
chomp($rid);	chomp($rid);
my $proname=&propath($udom,$uname);
my $qresult='';	my $qresult='';
my %hash;	my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER());
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",	if ($hashref) {
&GDBM_READER(),0640)) {	my $version=$hashref->{"version:$rid"};
my $version=$hash{"version:$rid"};
$qresult.="version=$version&";	$qresult.="version=$version&";
my $scope;	my $scope;
for ($scope=1;$scope<=$version;$scope++) {	for ($scope=1;$scope<=$version;$scope++) {
my $vkeys=$hash{"$scope:keys:$rid"};	my $vkeys=$hashref->{"$scope:keys:$rid"};
my @keys=split(/:/,$vkeys);	my @keys=split(/:/,$vkeys);
my $key;	my $key;
$qresult.="$scope:keys=$vkeys&";	$qresult.="$scope:keys=$vkeys&";
foreach $key (@keys) {	foreach $key (@keys) {
$qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";	$qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&";
}	}
}	}
if (untie(%hash)) {	if (&untie_user_hash($hashref)) {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
&Reply( $client, "$qresult\n", $userinput);	&Reply( $client, "$qresult\n", $userinput);
} else {	} else {
Line 3258 sub put_course_id_handler {	Line 3318 sub put_course_id_handler {
}	}
$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 3374 sub dump_course_id_handler {	Line 3434 sub dump_course_id_handler {
$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 3423 sub put_id_handler {	Line 3483 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 3472 sub get_id_handler {	Line 3532 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 3489 sub get_id_handler {	Line 3549 sub get_id_handler {
&register_handler("idget", \&get_id_handler, 0, 1, 0);	&register_handler("idget", \&get_id_handler, 0, 1, 0);

#	#
	# Puts broadcast e-mail sent by Domain Coordinator in nohist_dcmail database
	#
	# Parameters
	# $cmd - Command keyword that caused us to be dispatched.
	# $tail - Tail of the command. Consists of a colon separated:
	# domain - the domain whose dcmail we are recording
	# email Consists of key=value pair
	# where key is unique msgid
	# and value is message (in XML)
	# $client - Socket open on the client.
	#
	# Returns:
	# 1 - indicating processing should continue.
	# Side effects
	# reply is written to $client.
	#
	sub put_dcmail_handler {
	my ($cmd,$tail,$client) = @_;
	my $userinput = "$cmd:$tail";

	my ($udom,$what)=split(/:/,$tail);
	chomp($what);
	my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
	if ($hashref) {
	my ($key,$value)=split(/=/,$what);
	$hashref->{$key}=$value;
	}
	if (&untie_domain_hash($hashref)) {
	&Reply($client, "ok\n", $userinput);
	} else {
	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
	"while attempting dcmailput\n", $userinput);
	}
	return 1;
	}
	&register_handler("dcmailput", \&put_dcmail_handler, 0, 1, 0);

	#
	# Retrieves broadcast e-mail from nohist_dcmail database
	# Returns to client an & separated list of key=value pairs,
	# where key is msgid and value is message information.
	#
	# Parameters
	# $cmd - Command keyword that caused us to be dispatched.
	# $tail - Tail of the command. Consists of a colon separated:
	# domain - the domain whose dcmail table we dump
	# startfilter - beginning of time window
	# endfilter - end of time window
	# sendersfilter - & separated list of username:domain
	# for senders to search for.
	# $client - Socket open on the client.
	#
	# Returns:
	# 1 - indicating processing should continue.
	# Side effects
	# reply (& separated list of msgid=messageinfo pairs) is
	# written to $client.
	#
	sub dump_dcmail_handler {
	my ($cmd, $tail, $client) = @_;

	my $userinput = "$cmd:$tail";
	my ($udom,$startfilter,$endfilter,$sendersfilter) = split(/:/,$tail);
	chomp($sendersfilter);
	my @senders = ();
	if (defined($startfilter)) {
	$startfilter=&unescape($startfilter);
	} else {
	$startfilter='.';
	}
	if (defined($endfilter)) {
	$endfilter=&unescape($endfilter);
	} else {
	$endfilter='.';
	}
	if (defined($sendersfilter)) {
	$sendersfilter=&unescape($sendersfilter);
	@senders = map { &unescape($_) } split(/\&/,$sendersfilter);
	}

	my $qresult='';
	my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
	if ($hashref) {
	while (my ($key,$value) = each(%$hashref)) {
	my $match = 1;
	my ($timestamp,$subj,$uname,$udom) =
	split(/:/,&unescape(&unescape($key)),5); # yes, twice really
	$subj = &unescape($subj);
	unless ($startfilter eq '.' \|\| !defined($startfilter)) {
	if ($timestamp < $startfilter) {
	$match = 0;
	}
	}
	unless ($endfilter eq '.' \|\| !defined($endfilter)) {
	if ($timestamp > $endfilter) {
	$match = 0;
	}
	}
	unless (@senders < 1) {
	unless (grep/^$uname:$udom$/,@senders) {
	$match = 0;
	}
	}
	if ($match == 1) {
	$qresult.=$key.'='.$value.'&';
	}
	}
	if (&untie_domain_hash($hashref)) {
	chop($qresult);
	&Reply($client, "$qresult\n", $userinput);
	} else {
	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
	"while attempting dcmaildump\n", $userinput);
	}
	} else {
	&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
	"while attempting dcmaildump\n", $userinput);
	}
	return 1;
	}

	&register_handler("dcmaildump", \&dump_dcmail_handler, 0, 1, 0);

	#
	# Puts domain roles in nohist_domainroles database
	#
	# Parameters
	# $cmd - Command keyword that caused us to be dispatched.
	# $tail - Tail of the command. Consists of a colon separated:
	# domain - the domain whose roles we are recording
	# role - Consists of key=value pair
	# where key is unique role
	# and value is start/end date information
	# $client - Socket open on the client.
	#
	# Returns:
	# 1 - indicating processing should continue.
	# Side effects
	# reply is written to $client.
	#

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

	my $userinput = "$cmd:$tail";
	my ($udom,$what)=split(/:/,$tail);
	chomp($what);
	my @pairs=split(/\&/,$what);
	my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
	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 domroleput\n", $userinput);
	}
	} else {
	&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
	"while attempting domroleput\n", $userinput);
	}

	return 1;
	}

	&register_handler("domroleput", \&put_domainroles_handler, 0, 1, 0);

	#
	# Retrieves domain roles from nohist_domainroles database
	# Returns to client an & separated list of key=value pairs,
	# where key is role and value is start and end date information.
	#
	# Parameters
	# $cmd - Command keyword that caused us to be dispatched.
	# $tail - Tail of the command. Consists of a colon separated:
	# domain - the domain whose domain roles table we dump
	# $client - Socket open on the client.
	#
	# Returns:
	# 1 - indicating processing should continue.
	# Side effects
	# reply (& separated list of role=start/end info pairs) is
	# written to $client.
	#
	sub dump_domainroles_handler {
	my ($cmd, $tail, $client) = @_;

	my $userinput = "$cmd:$tail";
	my ($udom,$startfilter,$endfilter,$rolesfilter) = split(/:/,$tail);
	chomp($rolesfilter);
	my @roles = ();
	if (defined($startfilter)) {
	$startfilter=&unescape($startfilter);
	} else {
	$startfilter='.';
	}
	if (defined($endfilter)) {
	$endfilter=&unescape($endfilter);
	} else {
	$endfilter='.';
	}
	if (defined($rolesfilter)) {
	$rolesfilter=&unescape($rolesfilter);
	@roles = split(/\&/,$rolesfilter);
	}

	my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
	if ($hashref) {
	my $qresult = '';
	while (my ($key,$value) = each(%$hashref)) {
	my $match = 1;
	my ($start,$end) = split(/:/,&unescape($value));
	my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key));
	unless ($startfilter eq '.' \|\| !defined($startfilter)) {
	if ($start >= $startfilter) {
	$match = 0;
	}
	}
	unless ($endfilter eq '.' \|\| !defined($endfilter)) {
	if ($end <= $endfilter) {
	$match = 0;
	}
	}
	unless (@roles < 1) {
	unless (grep/^$trole$/,@roles) {
	$match = 0;
	}
	}
	if ($match == 1) {
	$qresult.=$key.'='.$value.'&';
	}
	}
	if (&untie_domain_hash($hashref)) {
	chop($qresult);
	&Reply($client, "$qresult\n", $userinput);
	} else {
	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
	"while attempting domrolesdump\n", $userinput);
	}
	} else {
	&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
	"while attempting domrolesdump\n", $userinput);
	}
	return 1;
	}

	&register_handler("domrolesdump", \&dump_domainroles_handler, 0, 1, 0);


# Process the tmpput command I'm not sure what this does.. Seems to	# Process the tmpput command I'm not sure what this does.. Seems to
# create a file in the lonDaemons/tmp directory of the form $id.tmp	# create a file in the lonDaemons/tmp directory of the form $id.tmp
# where Id is the client's ip concatenated with a sequence number.	# where Id is the client's ip concatenated with a sequence number.
Line 4392 sub ReadHostTable {	Line 4704 sub ReadHostTable {
open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") \|\| die "Can't read host file";	open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") \|\| die "Can't read host file";
my $myloncapaname = $perlvar{'lonHostID'};	my $myloncapaname = $perlvar{'lonHostID'};
Debug("My loncapa name is : $myloncapaname");	Debug("My loncapa name is : $myloncapaname");
	my %name_to_ip;
while (my $configline=<CONFIG>) {	while (my $configline=<CONFIG>) {
if ($configline !~ /^\s\#/ && $configline !~ /^\s$/ ) {	if ($configline !~ /^\s\#/ && $configline !~ /^\s$/ ) {
my ($id,$domain,$role,$name)=split(/:/,$configline);	my ($id,$domain,$role,$name)=split(/:/,$configline);
$name=~s/\s//g;	$name=~s/\s//g;
my $ip = gethostbyname($name);	my $ip;
if (length($ip) ne 4) {	if (!exists($name_to_ip{$name})) {
&logthis("Skipping host $id name $name no IP $ip found\n");	$ip = gethostbyname($name);
next;	if (!$ip \|\| length($ip) ne 4) {
	&logthis("Skipping host $id name $name no IP found\n");
	next;
	}
	$ip=inet_ntoa($ip);
	$name_to_ip{$name} = $ip;
	} else {
	$ip = $name_to_ip{$name};
}	}
$ip=inet_ntoa($ip);
$hostid{$ip}=$id; # LonCAPA name of host by IP.	$hostid{$ip}=$id; # LonCAPA name of host by IP.
$hostdom{$id}=$domain; # LonCAPA domain name of host.	$hostdom{$id}=$domain; # LonCAPA domain name of host.
	$hostname{$id}=$name; # LonCAPA name -> DNS name
$hostip{$id}=$ip; # IP address of host.	$hostip{$id}=$ip; # IP address of host.
$hostdns{$name} = $id; # LonCAPA name of host by DNS.	$hostdns{$name} = $id; # LonCAPA name of host by DNS.

Line 4654 sub reconlonc {	Line 4974 sub reconlonc {

sub subreply {	sub subreply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
my $peerfile="$perlvar{'lonSockDir'}/$server";	my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",	my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
Type => SOCK_STREAM,	Type => SOCK_STREAM,
Timeout => 10)	Timeout => 10)
or return "con_lost";	or return "con_lost";
print $sclient "$cmd\n";	print $sclient "sethost:$server:$cmd\n";
my $answer=<$sclient>;	my $answer=<$sclient>;
chomp($answer);	chomp($answer);
if (!$answer) { $answer="con_lost"; }	if (!$answer) { $answer="con_lost"; }
Line 4675 sub reply {	Line 4995 sub reply {
$answer=subreply("ping",$server);	$answer=subreply("ping",$server);
if ($answer ne $server) {	if ($answer ne $server) {
&logthis("sub reply: answer != server answer is $answer, server is $server");	&logthis("sub reply: answer != server answer is $answer, server is $server");
&reconlonc("$perlvar{'lonSockDir'}/$server");	&reconlonc("$perlvar{'lonSockDir'}/".$hostname{$server});
}	}
$answer=subreply($cmd,$server);	$answer=subreply($cmd,$server);
}	}
Line 4768 $SIG{USR2} = \&UpdateHosts;	Line 5088 $SIG{USR2} = \&UpdateHosts;

ReadHostTable;	ReadHostTable;

	my $dist=`$perlvar{'lonDaemons'}/distprobe`;

# --------------------------------------------------------------	# --------------------------------------------------------------
# Accept connections. When a connection comes in, it is validated	# Accept connections. When a connection comes in, it is validated
# and if good, a child process is created to process transactions	# and if good, a child process is created to process transactions
Line 4843 sub make_new_child {	Line 5165 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();
&Authen::Krb5::init_ets();	unless (($dist eq 'fedora4') \|\| ($dist eq 'suse9.3')) {
	&Authen::Krb5::init_ets();
	}

&status('Accepted connection');	&status('Accepted connection');
# =============================================================================	# =============================================================================
Line 4977 sub make_new_child {	Line 5301 sub make_new_child {
# no need to try to do recon's to myself	# no need to try to do recon's to myself
next;	next;
}	}
&reconlonc("$perlvar{'lonSockDir'}/$id");	&reconlonc("$perlvar{'lonSockDir'}/".$hostname{$id});
}	}
&logthis("<font color='green'>Established connection: $clientname</font>");	&logthis("<font color='green'>Established connection: $clientname</font>");
&status('Will listen to '.$clientname);	&status('Will listen to '.$clientname);
Line 5053 sub is_author {	Line 5377 sub is_author {
# user - Name of the user for which the role is being put.	# user - Name of the user for which the role is being put.
# authtype - The authentication type associated with the user.	# authtype - The authentication type associated with the user.
#	#
sub manage_permissions	sub manage_permissions {
{


my ($request, $domain, $user, $authtype) = @_;	my ($request, $domain, $user, $authtype) = @_;

&Debug("manage_permissions: $request $domain $user $authtype");	&Debug("manage_permissions: $request $domain $user $authtype");

# See if the request is of the form /$domain/_au	# See if the request is of the form /$domain/_au
if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...	if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput...
my $execdir = $perlvar{'lonDaemons'};	my $execdir = $perlvar{'lonDaemons'};
my $userhome= "/home/$user" ;	my $userhome= "/home/$user" ;
&logthis("system $execdir/lchtmldir $userhome $user $authtype");	&logthis("system $execdir/lchtmldir $userhome $user $authtype");
Line 5311 sub addline {	Line 5632 sub addline {

sub get_chat {	sub get_chat {
my ($cdom,$cname,$udom,$uname)=@_;	my ($cdom,$cname,$udom,$uname)=@_;
my %hash;
my $proname=&propath($cdom,$cname);
my @entries=();	my @entries=();
if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",	my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom',
&GDBM_READER(),0640)) {	&GDBM_READER());
@entries=map { $_.':'.$hash{$_} } sort keys %hash;	if ($hashref) {
untie %hash;	@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, 'nohist_inchatroom',
&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)=@_;
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 $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom',
&GDBM_WRCREAT(),0640)) {	&GDBM_WRCREAT());
@entries=map { $_.':'.$hash{$_} } sort keys %hash;	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 5352 sub chat_add {	Line 5673 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/chatroom.log")) {
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 5455 sub thisversion {	Line 5777 sub thisversion {
sub subscribe {	sub subscribe {
my ($userinput,$clientip)=@_;	my ($userinput,$clientip)=@_;
my $result;	my $result;
my ($cmd,$fname)=split(/:/,$userinput);	my ($cmd,$fname)=split(/:/,$userinput,2);
my $ownership=&ishome($fname);	my $ownership=&ishome($fname);
if ($ownership eq 'owner') {	if ($ownership eq 'owner') {
# explitly asking for the current version?	# explitly asking for the current version?
Line 5499 sub subscribe {	Line 5821 sub subscribe {
}	}
return $result;	return $result;
}	}
	# Change the passwd of a unix user. The caller must have
	# first verified that the user is a loncapa user.
	#
	# Parameters:
	# user - Unix user name to change.
	# pass - New password for the user.
	# Returns:
	# ok - if success
	# other - Some meaningfule error message string.
	# NOTE:
	# invokes a setuid script to change the passwd.
	sub change_unix_password {
	my ($user, $pass) = @_;

	&Debug("change_unix_password");
	my $execdir=$perlvar{'lonDaemons'};
	&Debug("Opening lcpasswd pipeline");
	my $pf = IO::File->new("\|$execdir/lcpasswd > "
	."$perlvar{'lonDaemons'}"
	."/logs/lcpasswd.log");
	print $pf "$user\n$pass\n$pass\n";
	close $pf;
	my $err = $?;
	return ($err < @passwderrors) ? $passwderrors[$err] :
	"pwchange_falure - unknown error";


	}


sub make_passwd_file {	sub make_passwd_file {
my ($uname, $umode,$npass,$passfilename)=@_;	my ($uname, $umode,$npass,$passfilename)=@_;
Line 5558 sub make_passwd_file {	Line 5909 sub make_passwd_file {
print $se "$npass\n";	print $se "$npass\n";
print $se "$lc_error_file\n"; # Status -> unique file.	print $se "$lc_error_file\n"; # Status -> unique file.
}	}
my $error = IO::File->new("< $lc_error_file");	if (-r $lc_error_file) {
my $useraddok = <$error>;	&Debug("Opening error file: $lc_error_file");
$error->close;	my $error = IO::File->new("< $lc_error_file");
unlink($lc_error_file);	my $useraddok = <$error>;
	$error->close;
chomp $useraddok;	unlink($lc_error_file);

if($useraddok > 0) {	chomp $useraddok;
my $error_text = &lcuseraddstrerror($useraddok);
&logthis("Failed lcuseradd: $error_text");	if($useraddok > 0) {
$result = "lcuseradd_failed:$error_text\n";	my $error_text = &lcuseraddstrerror($useraddok);
} else {	&logthis("Failed lcuseradd: $error_text");
my $pf = IO::File->new(">$passfilename");	$result = "lcuseradd_failed:$error_text\n";
if($pf) {	} else {
print $pf "unix:\n";	my $pf = IO::File->new(">$passfilename");
} else {	if($pf) {
$result = "pass_file_failed_error";	print $pf "unix:\n";
	} else {
	$result = "pass_file_failed_error";
	}
}	}
	} else {
	&Debug("Could not locate lcuseradd error: $lc_error_file");
	$result="bug_lcuseradd_no_output_file";
}	}
}	}
} elsif ($umode eq 'none') {	} elsif ($umode eq 'none') {

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

Removed from v.1.284
changed lines
	Added in v.1.311