loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.376 and 1.394.2.1

version 1.376, 2007/07/25 22:52:07	version 1.394.2.1, 2008/05/30 21:34:27
Line 33 use strict;	Line 33 use strict;
use lib '/home/httpd/lib/perl/';	use lib '/home/httpd/lib/perl/';
use LONCAPA;	use LONCAPA;
use LONCAPA::Configuration;	use LONCAPA::Configuration;
use Apache::lonnet;

use IO::Socket;	use IO::Socket;
use IO::File;	use IO::File;
Line 53 use File::Find;	Line 52 use File::Find;
use LONCAPA::lonlocal;	use LONCAPA::lonlocal;
use LONCAPA::lonssl;	use LONCAPA::lonssl;
use Fcntl qw(:flock);	use Fcntl qw(:flock);
	use Apache::lonnet;

my $DEBUG = 0; # Non zero to enable debug log entries.	my $DEBUG = 0; # Non zero to enable debug log entries.

Line 135 my @adderrors = ("ok",	Line 135 my @adderrors = ("ok",
"lcuseradd Unable to make www member of users's group",	"lcuseradd Unable to make www member of users's group",
"lcuseradd Unable to su to root",	"lcuseradd Unable to su to root",
"lcuseradd Unable to set password",	"lcuseradd Unable to set password",
"lcuseradd Usrname has invalid characters",	"lcuseradd Username has invalid characters",
"lcuseradd Password has an invalid character",	"lcuseradd Password has an invalid character",
"lcuseradd User already exists",	"lcuseradd User already exists",
"lcuseradd Could not add user.",	"lcuseradd Could not add user.",
Line 996 sub ping_handler {	Line 996 sub ping_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;
Debug("$cmd $tail $client .. $currenthostid:");	Debug("$cmd $tail $client .. $currenthostid:");

Reply( $client,"$currenthostid\n","$cmd:$tail");	Reply( $client,\$currenthostid,"$cmd:$tail");

return 1;	return 1;
}	}
Line 1066 sub establish_key_handler {	Line 1066 sub establish_key_handler {
$key=substr($key,0,32);	$key=substr($key,0,32);
my $cipherkey=pack("H32",$key);	my $cipherkey=pack("H32",$key);
$cipher=new IDEA $cipherkey;	$cipher=new IDEA $cipherkey;
&Reply($replyfd, "$buildkey\n", "$cmd:$tail");	&Reply($replyfd, \$buildkey, "$cmd:$tail");

return 1;	return 1;

Line 1103 sub load_handler {	Line 1103 sub load_handler {

my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};	my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};

&Reply( $replyfd, "$loadpercent\n", "$cmd:$tail");	&Reply( $replyfd, \$loadpercent, "$cmd:$tail");

return 1;	return 1;
}	}
Line 1133 sub user_load_handler {	Line 1133 sub user_load_handler {
my ($cmd, $tail, $replyfd) = @_;	my ($cmd, $tail, $replyfd) = @_;

my $userloadpercent=&Apache::lonnet::userload();	my $userloadpercent=&Apache::lonnet::userload();
&Reply($replyfd, "$userloadpercent\n", "$cmd:$tail");	&Reply($replyfd, \$userloadpercent, "$cmd:$tail");

return 1;	return 1;
}	}
Line 1176 sub user_authorization_type {	Line 1176 sub user_authorization_type {
} else {	} else {
$type .= ':';	$type .= ':';
}	}
&Reply( $replyfd, "$type\n", $userinput);	&Reply( $replyfd, \$type, $userinput);
}	}

return 1;	return 1;
Line 1212 sub push_file_handler {	Line 1212 sub push_file_handler {
# process making the request.	# process making the request.

my $reply = &PushFile($userinput);	my $reply = &PushFile($userinput);
&Reply($client, "$reply\n", $userinput);	&Reply($client, \$reply, $userinput);

} else {	} else {
&Failure( $client, "refused\n", $userinput);	&Failure( $client, "refused\n", $userinput);
Line 1264 sub du_handler {	Line 1264 sub du_handler {
chdir($ududir);	chdir($ududir);
find($code,$ududir);	find($code,$ududir);
$total_size=int($total_size/1024);	$total_size=int($total_size/1024);
&Reply($client,"$total_size\n","$cmd:$ududir");	&Reply($client,\$total_size,"$cmd:$ududir");
} else {	} else {
&Failure($client, "bad_directory:$ududir\n","$cmd:$ududir");	&Failure($client, "bad_directory:$ududir\n","$cmd:$ududir");
}	}
Line 1333 sub ls_handler {	Line 1333 sub ls_handler {
$ulsout='no_such_dir';	$ulsout='no_such_dir';
}	}
if ($ulsout eq '') { $ulsout='empty'; }	if ($ulsout eq '') { $ulsout='empty'; }
&Reply($client, "$ulsout\n", $userinput); # This supports debug logging.	&Reply($client, \$ulsout, $userinput); # This supports debug logging.

return 1;	return 1;

Line 1402 sub ls2_handler {	Line 1402 sub ls2_handler {
$ulsout='no_such_dir';	$ulsout='no_such_dir';
}	}
if ($ulsout eq '') { $ulsout='empty'; }	if ($ulsout eq '') { $ulsout='empty'; }
&Reply($client, "$ulsout\n", $userinput); # This supports debug logging.	&Reply($client, \$ulsout, $userinput); # This supports debug logging.
return 1;	return 1;
}	}
&register_handler("ls2", \&ls2_handler, 0, 1, 0);	&register_handler("ls2", \&ls2_handler, 0, 1, 0);
Line 1430 sub reinit_process_handler {	Line 1430 sub reinit_process_handler {
if(&ValidManager($cert)) {	if(&ValidManager($cert)) {
chomp($userinput);	chomp($userinput);
my $reply = &ReinitProcess($userinput);	my $reply = &ReinitProcess($userinput);
&Reply( $client, "$reply\n", $userinput);	&Reply( $client, \$reply, $userinput);
} else {	} else {
&Failure( $client, "refused\n", $userinput);	&Failure( $client, "refused\n", $userinput);
}	}
Line 1605 sub change_password_handler {	Line 1605 sub change_password_handler {
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);
&Reply($client, "$result\n", $userinput);	&Reply($client, \$result, $userinput);
} else {	} else {
# this just means that the current password mode is not	# this just means that the current password mode is not
# one we know how to change (e.g the kerberos auth modes or	# one we know how to change (e.g the kerberos auth modes or
Line 1666 sub add_user_handler {	Line 1666 sub add_user_handler {
}	}
unless ($fperror) {	unless ($fperror) {
my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);	my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);
&Reply($client, $result, $userinput); #BUGBUG - could be fail	&Reply($client,\$result, $userinput); #BUGBUG - could be fail
} else {	} else {
&Failure($client, "$fperror\n", $userinput);	&Failure($client, \$fperror, $userinput);
}	}
}	}
umask($oldumask);	umask($oldumask);
Line 1735 sub change_authentication_handler {	Line 1735 sub change_authentication_handler {
my $result = &change_unix_password($uname, $npass);	my $result = &change_unix_password($uname, $npass);
&logthis("Result of password change for $uname: ".$result);	&logthis("Result of password change for $uname: ".$result);
if ($result eq "ok") {	if ($result eq "ok") {
&Reply($client, "$result\n")	&Reply($client, \$result);
} else {	} else {
&Failure($client, "$result\n");	&Failure($client, \$result);
}	}
} else {	} else {
my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);	my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);
Line 1756 sub change_authentication_handler {	Line 1756 sub change_authentication_handler {
&manage_permissions("/$udom/_au", $udom, $uname, "$umode:");	&manage_permissions("/$udom/_au", $udom, $uname, "$umode:");
}	}
}	}
&Reply($client, $result, $userinput);	&Reply($client, \$result, $userinput);
}	}


Line 2095 sub rename_user_file_handler {	Line 2095 sub rename_user_file_handler {
&register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);	&register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);

#	#
	# Checks if the specified user has an active session on the server
	# return ok if so, not_found if not
	#
	# Parameters:
	# cmd - The request keyword that dispatched to tus.
	# tail - The tail of the request (colon separated parameters).
	# client - Filehandle open on the client.
	# Return:
	# 1.
	sub user_has_session_handler {
	my ($cmd, $tail, $client) = @_;

	my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));

	&logthis("Looking for $udom $uname");
	opendir(DIR,$perlvar{'lonIDsDir'});
	my $filename;
	while ($filename=readdir(DIR)) {
	last if ($filename=~/^\Q$uname\E_\d+_\Q$udom\E_/);
	}
	if ($filename) {
	&Reply($client, "ok\n", "$cmd:$tail");
	} else {
	&Failure($client, "not_found\n", "$cmd:$tail");
	}
	return 1;

	}
	&register_handler("userhassession", \&user_has_session_handler, 0,1,0);

	#
# Authenticate access to a user file by checking that the token the user's	# Authenticate access to a user file by checking that the token the user's
# passed also exists in their session file	# passed also exists in their session file
#	#
Line 2110 sub token_auth_user_file_handler {	Line 2141 sub token_auth_user_file_handler {
my ($fname, $session) = split(/:/, $tail);	my ($fname, $session) = split(/:/, $tail);

chomp($session);	chomp($session);
my $reply="non_auth\n";	my $reply="non_auth";
my $file = $perlvar{'lonIDsDir'}.'/'.$session.'.id';	my $file = $perlvar{'lonIDsDir'}.'/'.$session.'.id';
if (open(ENVIN,"$file")) {	if (open(ENVIN,"$file")) {
flock(ENVIN,LOCK_SH);	flock(ENVIN,LOCK_SH);
tie(my %disk_env,'GDBM_File',"$file",&GDBM_READER(),0640);	tie(my %disk_env,'GDBM_File',"$file",&GDBM_READER(),0640);
if (exists($disk_env{"userfile.$fname"})) {	if (exists($disk_env{"userfile.$fname"})) {
$reply="ok\n";	$reply="ok";
} else {	} else {
foreach my $envname (keys(%disk_env)) {	foreach my $envname (keys(%disk_env)) {
if ($envname=~ m\|^userfile\.\Q$fname\E\|) {	if ($envname=~ m\|^userfile\.\Q$fname\E\|) {
$reply="ok\n";	$reply="ok";
last;	last;
}	}
}	}
}	}
untie(%disk_env);	untie(%disk_env);
close(ENVIN);	close(ENVIN);
&Reply($client, $reply, "$cmd:$tail");	&Reply($client, \$reply, "$cmd:$tail");
} else {	} else {
&Failure($client, "invalid_token\n", "$cmd:$tail");	&Failure($client, "invalid_token\n", "$cmd:$tail");
}	}
Line 2187 sub subscribe_handler {	Line 2218 sub subscribe_handler {
&register_handler("sub", \&subscribe_handler, 0, 1, 0);	&register_handler("sub", \&subscribe_handler, 0, 1, 0);

#	#
# Determine the version of a resource (?) Or is it return	# Determine the latest version of a resource (it looks for the highest
# the top version of the resource? Not yet clear from the	# past version and then returns that +1)
# code in currentversion.
#	#
# Parameters:	# Parameters:
# $cmd - The command that got us here.	# $cmd - The command that got us here.
# $tail - Tail of the command (remaining parameters).	# $tail - Tail of the command (remaining parameters).
	# (Should consist of an absolute path to a file)
# $client - File descriptor connected to client.	# $client - File descriptor connected to client.
# Returns	# Returns
# 0 - Requested to exit, caller should shut down.	# 0 - Requested to exit, caller should shut down.
Line 2551 sub get_profile_entry {	Line 2582 sub get_profile_entry {
my ($udom,$uname,$namespace,$what) = split(/:/,$tail);	my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
chomp($what);	chomp($what);


my $replystring = read_profile($udom, $uname, $namespace, $what);	my $replystring = read_profile($udom, $uname, $namespace, $what);
my ($first) = split(/:/,$replystring);	my ($first) = split(/:/,$replystring);
if($first ne "error") {	if($first ne "error") {
&Reply($client, "$replystring\n", $userinput);	&Reply($client, \$replystring, $userinput);
} else {	} else {
&Failure($client, $replystring." while attempting get\n", $userinput);	&Failure($client, $replystring." while attempting get\n", $userinput);
}	}
Line 2694 sub get_profile_keys {	Line 2726 sub get_profile_keys {
}	}
if (&untie_user_hash($hashref)) {	if (&untie_user_hash($hashref)) {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
&Reply($client, "$qresult\n", $userinput);	&Reply($client, \$qresult, $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting keys\n", $userinput);	"while attempting keys\n", $userinput);
Line 2764 sub dump_profile_database {	Line 2796 sub dump_profile_database {
}	}
}	}
chop($qresult);	chop($qresult);
&Reply($client , "$qresult\n", $userinput);	&Reply($client , \$qresult, $userinput);
} else {	} else {
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting currentdump\n", $userinput);	"while attempting currentdump\n", $userinput);
Line 2847 sub dump_with_regexp {	Line 2879 sub dump_with_regexp {
}	}
if (&untie_user_hash($hashref)) {	if (&untie_user_hash($hashref)) {
chop($qresult);	chop($qresult);
&Reply($client, "$qresult\n", $userinput);	&Reply($client, \$qresult, $userinput);
} else {	} else {
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting dump\n", $userinput);	"while attempting dump\n", $userinput);
Line 3055 sub restore_handler {	Line 3087 sub restore_handler {
}	}
if (&untie_user_hash($hashref)) {	if (&untie_user_hash($hashref)) {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
&Reply( $client, "$qresult\n", $userinput);	&Reply( $client, \$qresult, $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting restore\n", $userinput);	"while attempting restore\n", $userinput);
Line 3136 sub retrieve_chat_handler {	Line 3168 sub retrieve_chat_handler {
$reply.=&escape($_).':';	$reply.=&escape($_).':';
}	}
$reply=~s/\:$//;	$reply=~s/\:$//;
&Reply($client, $reply."\n", $userinput);	&Reply($client, \$reply, $userinput);


return 1;	return 1;
Line 3273 sub put_course_id_handler {	Line 3305 sub put_course_id_handler {
foreach my $pair (@pairs) {	foreach my $pair (@pairs) {
my ($key,$courseinfo) = split(/=/,$pair,2);	my ($key,$courseinfo) = split(/=/,$pair,2);
$courseinfo =~ s/=/:/g;	$courseinfo =~ s/=/:/g;
	if (defined($hashref->{$key})) {
	my $value = &Apache::lonnet::thaw_unescape($hashref->{$key});
	if (ref($value) eq 'HASH') {
	my @items = ('description','inst_code','owner','type');
	my @new_items = split(/:/,$courseinfo,-1);
	my %storehash;
	for (my $i=0; $i<@new_items; $i++) {
	$storehash{$items[$i]} = &unescape($new_items[$i]);
	}
	$hashref->{$key} =
	&Apache::lonnet::freeze_escape(\%storehash);
	my $unesc_key = &unescape($key);
	$hashref->{&escape('lasttime:'.$unesc_key)} = $now;
	next;
	}
	}
my @current_items = split(/:/,$hashref->{$key},-1);	my @current_items = split(/:/,$hashref->{$key},-1);
shift(@current_items); # remove description	shift(@current_items); # remove description
pop(@current_items); # remove last access	pop(@current_items); # remove last access
Line 3289 sub put_course_id_handler {	Line 3337 sub put_course_id_handler {
}	}
}	}
}	}
$hashref->{$key}=$courseinfo.':'.$now;	$hashref->{$key}=$courseinfo.':'.$now;
}	}
if (&untie_domain_hash($hashref)) {	if (&untie_domain_hash($hashref)) {
&Reply( $client, "ok\n", $userinput);	&Reply( $client, "ok\n", $userinput);
Line 3303 sub put_course_id_handler {	Line 3351 sub put_course_id_handler {
." tie(GDBM) Failed ".	." tie(GDBM) Failed ".
"while attempting courseidput\n", $userinput);	"while attempting courseidput\n", $userinput);
}	}


return 1;	return 1;
}	}
&register_handler("courseidput", \&put_course_id_handler, 0, 1, 0);	&register_handler("courseidput", \&put_course_id_handler, 0, 1, 0);

	sub put_course_id_hash_handler {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my ($udom,$mode,$what) = split(/:/, $tail,3);
	chomp($what);
	my $now=time;
	my @pairs=split(/\&/,$what);
	my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
	if ($hashref) {
	foreach my $pair (@pairs) {
	my ($key,$value)=split(/=/,$pair);
	my $unesc_key = &unescape($key);
	if ($mode ne 'timeonly') {
	if (!defined($hashref->{&escape('lasttime:'.$unesc_key)})) {
	my $curritems = &Apache::lonnet::thaw_unescape($key);
	if (ref($curritems) ne 'HASH') {
	my @current_items = split(/:/,$hashref->{$key},-1);
	my $lasttime = pop(@current_items);
	$hashref->{&escape('lasttime:'.$unesc_key)} = $lasttime;
	} else {
	$hashref->{&escape('lasttime:'.$unesc_key)} = '';
	}
	}
	$hashref->{$key} = $value;
	}
	if ($mode ne 'notime') {
	$hashref->{&escape('lasttime:'.$unesc_key)} = $now;
	}
	}
	if (&untie_domain_hash($hashref)) {
	&Reply($client, "ok\n", $userinput);
	} else {
	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
	"while attempting courseidputhash\n", $userinput);
	}
	} else {
	&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
	"while attempting courseidputhash\n", $userinput);
	}
	return 1;
	}
	&register_handler("courseidputhash", \&put_course_id_hash_handler, 0, 1, 0);

# Retrieves the value of a course id resource keyword pattern	# Retrieves the value of a course id resource keyword pattern
# defined since a starting date. Both the starting date and the	# defined since a starting date. Both the starting date and the
# keyword pattern are optional. If the starting date is not supplied it	# keyword pattern are optional. If the starting date is not supplied it
Line 3335 sub put_course_id_handler {	Line 3425 sub put_course_id_handler {
# owner matches the supplied username and/or domain	# owner matches the supplied username and/or domain
# will be returned. Pre-2.2.0 legacy entries from	# will be returned. Pre-2.2.0 legacy entries from
# nohist_courseiddump will only contain usernames.	# nohist_courseiddump will only contain usernames.
	# type - optional parameter for selection
	# regexp_ok - if true, allow the supplied institutional code
	# filter to behave as a regular expression.
	# rtn_as_hash - whether to return the information available for
	# each matched item as a frozen hash of all
	# key, value pairs in the item's hash, or as a
	# colon-separated list of (in order) description,
	# institutional code, and course owner.
	#
# $client - The socket open on the client.	# $client - The socket open on the client.
# Returns:	# Returns:
# 1 - Continue processing.	# 1 - Continue processing.
Line 3342 sub put_course_id_handler {	Line 3441 sub put_course_id_handler {
# a reply is written to $client.	# a reply is written to $client.
sub dump_course_id_handler {	sub dump_course_id_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;

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

my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,	my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
$typefilter,$regexp_ok) =split(/:/,$tail);	$typefilter,$regexp_ok,$rtn_as_hash) =split(/:/,$tail);
if (defined($description)) {	if (defined($description)) {
$description=&unescape($description);	$description=&unescape($description);
} else {	} else {
Line 3386 sub dump_course_id_handler {	Line 3484 sub dump_course_id_handler {
if (defined($regexp_ok)) {	if (defined($regexp_ok)) {
$regexp_ok=&unescape($regexp_ok);	$regexp_ok=&unescape($regexp_ok);
}	}
	my $unpack = 1;
unless (defined($since)) { $since=0; }	if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&
	$typefilter eq '.') {
	$unpack = 0;
	}
	if (!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,$type);	my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val,%unesc_val);
my @courseitems = split(/:/,$value);	$unesc_key = &unescape($key);
$lasttime = pop(@courseitems);	if ($unesc_key =~ /^lasttime:/) {
($descr,$inst_code,$owner,$type)=@courseitems;	next;
if ($lasttime<$since) { next; }	} else {
	$lasttime_key = &escape('lasttime:'.$unesc_key);
	}
	if ($hashref->{$lasttime_key} ne '') {
	$lasttime = $hashref->{$lasttime_key};
	next if ($lasttime<$since);
	}
	my $items = &Apache::lonnet::thaw_unescape($value);
	if (ref($items) eq 'HASH') {
	$is_hash = 1;
	if ($unpack \|\| !$rtn_as_hash) {
	$unesc_val{'descr'} = $items->{'description'};
	$unesc_val{'inst_code'} = $items->{'inst_code'};
	$unesc_val{'owner'} = $items->{'owner'};
	$unesc_val{'type'} = $items->{'type'};
	}
	} else {
	$is_hash = 0;
	my @courseitems = split(/:/,$value);
	$lasttime = pop(@courseitems);
	if ($hashref->{$lasttime_key} eq '') {
	next if ($lasttime<$since);
	}
	($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems;
	}
my $match = 1;	my $match = 1;
unless ($description eq '.') {	if ($description ne '.') {
my $unescapeDescr = &unescape($descr);	if (!$is_hash) {
unless (eval('$unescapeDescr=~/\Q$description\E/i')) {	$unesc_val{'descr'} = &unescape($val{'descr'});
	}
	if (eval{$unesc_val{'descr'} !~ /\Q$description\E/i}) {
$match = 0;	$match = 0;
}	}
}	}
unless ($instcodefilter eq '.' \|\| !defined($instcodefilter)) {	if ($instcodefilter ne '.') {
my $unescapeInstcode = &unescape($inst_code);	if (!$is_hash) {
	$unesc_val{'inst_code'} = &unescape($val{'inst_code'});
	}
if ($regexp_ok) {	if ($regexp_ok) {
unless (eval('$unescapeInstcode=~/$instcodefilter/')) {	if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) {
$match = 0;	$match = 0;
}	}
} else {	} else {
unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) {	if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) {
$match = 0;	$match = 0;
}	}
}	}
}	}
unless ($ownerfilter eq '.' \|\| !defined($ownerfilter)) {	if ($ownerfilter ne '.') {
my $unescapeOwner = &unescape($owner);	if (!$is_hash) {
	$unesc_val{'owner'} = &unescape($val{'owner'});
	}
if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {	if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {
if ($unescapeOwner =~ /:/) {	if ($unesc_val{'owner'} =~ /:/) {
if (eval('$unescapeOwner !~	if (eval{$unesc_val{'owner'} !~
/\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i')) {	/\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i}) {
$match = 0;	$match = 0;
}	}
} else {	} else {
if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) {	if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
$match = 0;	$match = 0;
}	}
}	}
} elsif ($ownerunamefilter ne '') {	} elsif ($ownerunamefilter ne '') {
if ($unescapeOwner =~ /:/) {	if ($unesc_val{'owner'} =~ /:/) {
if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E:[^:]+$/i')) {	if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E:[^:]+$/i}) {
$match = 0;	$match = 0;
}	}
} else {	} else {
if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) {	if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
$match = 0;	$match = 0;
}	}
}	}
} elsif ($ownerdomfilter ne '') {	} elsif ($ownerdomfilter ne '') {
if ($unescapeOwner =~ /:/) {	if ($unesc_val{'owner'} =~ /:/) {
if (eval('$unescapeOwner!~/^[^:]+:\Q$ownerdomfilter\E/')) {	if (eval{$unesc_val{'owner'} !~ /^[^:]+:\Q$ownerdomfilter\E/}) {
$match = 0;	$match = 0;
}	}
} else {	} else {
Line 3451 sub dump_course_id_handler {	Line 3583 sub dump_course_id_handler {
}	}
}	}
}	}
unless ($coursefilter eq '.' \|\| !defined($coursefilter)) {	if ($coursefilter ne '.') {
my $unescapeCourse = &unescape($key);	if (eval{$unesc_key !~ /^$udom(_)\Q$coursefilter\E$/}) {
unless (eval('$unescapeCourse=~/^$udom(_)\Q$coursefilter\E$/')) {
$match = 0;	$match = 0;
}	}
}	}
unless ($typefilter eq '.' \|\| !defined($typefilter)) {	if ($typefilter ne '.') {
my $unescapeType = &unescape($type);	if (!$is_hash) {
if ($type eq '') {	$unesc_val{'type'} = &unescape($val{'type'});
	}
	if ($unesc_val{'type'} eq '') {
if ($typefilter ne 'Course') {	if ($typefilter ne 'Course') {
$match = 0;	$match = 0;
}	}
} else {	} else {
unless (eval('$unescapeType=~/^\Q$typefilter\E$/')) {	if (eval{$unesc_val{'type'} !~ /^\Q$typefilter\E$/}) {
$match = 0;	$match = 0;
}	}
}	}
}	}
if ($match == 1) {	if ($match == 1) {
$qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';	if ($rtn_as_hash) {
	if ($is_hash) {
	$qresult.=$key.'='.$value.'&';
	} else {
	my %rtnhash = ( 'description' => &unescape($val{'descr'}),
	'inst_code' => &unescape($val{'inst_code'}),
	'owner' => &unescape($val{'owner'}),
	'type' => &unescape($val{'type'}),
	);
	my $items = &Apache::lonnet::freeze_escape(\%rtnhash);
	$qresult.=$key.'='.$items.'&';
	}
	} else {
	if ($is_hash) {
	$qresult .= $key.'='.&escape($unesc_val{'descr'}).':'.
	&escape($unesc_val{'inst_code'}).':'.
	&escape($unesc_val{'owner'}).'&';
	} else {
	$qresult .= $key.'='.$val{'descr'}.':'.$val{'inst_code'}.
	':'.$val{'owner'}.'&';
	}
	}
}	}
}	}
if (&untie_domain_hash($hashref)) {	if (&untie_domain_hash($hashref)) {
chop($qresult);	chop($qresult);
&Reply($client, "$qresult\n", $userinput);	&Reply($client, \$qresult, $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting courseiddump\n", $userinput);	"while attempting courseiddump\n", $userinput);
Line 3484 sub dump_course_id_handler {	Line 3638 sub dump_course_id_handler {
&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".	&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
"while attempting courseiddump\n", $userinput);	"while attempting courseiddump\n", $userinput);
}	}


return 1;	return 1;
}	}
&register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);	&register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);
Line 3568 sub get_domain_handler {	Line 3720 sub get_domain_handler {
}	}
if (&untie_domain_hash($hashref)) {	if (&untie_domain_hash($hashref)) {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
&Reply($client, "$qresult\n", $userinput);	&Reply($client, \$qresult, $userinput);
} else {	} else {
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting getdom\n",$userinput);	"while attempting getdom\n",$userinput);
Line 3666 sub get_id_handler {	Line 3818 sub get_id_handler {
}	}
if (&untie_domain_hash($hashref)) {	if (&untie_domain_hash($hashref)) {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
&Reply($client, "$qresult\n", $userinput);	&Reply($client, \$qresult, $userinput);
} else {	} else {
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting idget\n",$userinput);	"while attempting idget\n",$userinput);
Line 3790 sub dump_dcmail_handler {	Line 3942 sub dump_dcmail_handler {
}	}
if (&untie_domain_hash($hashref)) {	if (&untie_domain_hash($hashref)) {
chop($qresult);	chop($qresult);
&Reply($client, "$qresult\n", $userinput);	&Reply($client, \$qresult, $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting dcmaildump\n", $userinput);	"while attempting dcmaildump\n", $userinput);
Line 3908 sub dump_domainroles_handler {	Line 4060 sub dump_domainroles_handler {
}	}
}	}
unless (@roles < 1) {	unless (@roles < 1) {
unless (grep/^$trole$/,@roles) {	unless (grep/^\Q$trole\E$/,@roles) {
$match = 0;	$match = 0;
}	}
}	}
Line 3918 sub dump_domainroles_handler {	Line 4070 sub dump_domainroles_handler {
}	}
if (&untie_domain_hash($hashref)) {	if (&untie_domain_hash($hashref)) {
chop($qresult);	chop($qresult);
&Reply($client, "$qresult\n", $userinput);	&Reply($client, \$qresult, $userinput);
} else {	} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting domrolesdump\n", $userinput);	"while attempting domrolesdump\n", $userinput);
Line 3972 sub tmp_put_handler {	Line 4124 sub tmp_put_handler {
if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {	if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
print $store $record;	print $store $record;
close $store;	close $store;
&Reply($client, "$id\n", $userinput);	&Reply($client, \$id, $userinput);
} else {	} else {
&Failure( $client, "error: ".($!+0)."IO::File->new Failed ".	&Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
"while attempting tmpput\n", $userinput);	"while attempting tmpput\n", $userinput);
Line 4006 sub tmp_get_handler {	Line 4158 sub tmp_get_handler {
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")) {
my $reply=<$store>;	my $reply=<$store>;
&Reply( $client, "$reply\n", $userinput);	&Reply( $client, \$reply, $userinput);
close $store;	close $store;
} else {	} else {
&Failure( $client, "error: ".($!+0)."IO::File->new Failed ".	&Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
Line 4190 sub enrollment_enabled_handler {	Line 4342 sub enrollment_enabled_handler {
my ($cdom) = split(/:/, $tail, 2); # 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, $userinput);

return 1;	return 1;
}	}
Line 4217 sub get_sections_handler {	Line 4369 sub get_sections_handler {
my @secs = &localenroll::get_sections($coursecode,$cdom);	my @secs = &localenroll::get_sections($coursecode,$cdom);
my $seclist = &escape(join(':',@secs));	my $seclist = &escape(join(':',@secs));

&Reply($client, "$seclist\n", $userinput);	&Reply($client, \$seclist, $userinput);


return 1;	return 1;
Line 4246 sub validate_course_owner_handler {	Line 4398 sub validate_course_owner_handler {

$owner = &unescape($owner);	$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, $userinput);



Line 4277 sub validate_course_section_handler {	Line 4429 sub validate_course_section_handler {
my ($inst_course_id, $cdom) = split(/:/, $tail);	my ($inst_course_id, $cdom) = split(/:/, $tail);

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


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

return 1;	return 1;
}	}
Line 4472 sub get_institutional_defaults_handler {	Line 4624 sub get_institutional_defaults_handler {
$result.=&escape($key).'='.&escape($value).'&';	$result.=&escape($key).'='.&escape($value).'&';
}	}
$result .= 'code_order='.&escape(join('&',@code_order));	$result .= 'code_order='.&escape(join('&',@code_order));
&Reply($client,$result."\n",$userinput);	&Reply($client,\$result,$userinput);
} else {	} else {
&Reply($client,"error\n", $userinput);	&Reply($client,"error\n", $userinput);
}	}
Line 4483 sub get_institutional_defaults_handler {	Line 4635 sub get_institutional_defaults_handler {
&register_handler("autoinstcodedefaults",	&register_handler("autoinstcodedefaults",
\&get_institutional_defaults_handler,0,1,0);	\&get_institutional_defaults_handler,0,1,0);

	sub get_institutional_user_rules {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my $dom = &unescape($tail);
	my (%rules_hash,@rules_order);
	my $outcome;
	eval {
	local($SIG{__DIE__})='DEFAULT';
	$outcome = &localenroll::username_rules($dom,\%rules_hash,\@rules_order);
	};
	if (!$@) {
	if ($outcome eq 'ok') {
	my $result;
	foreach my $key (keys(%rules_hash)) {
	$result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
	}
	$result =~ s/\&$//;
	$result .= ':';
	if (@rules_order > 0) {
	foreach my $item (@rules_order) {
	$result .= &escape($item).'&';
	}
	}
	$result =~ s/\&$//;
	&Reply($client,\$result,$userinput);
	} else {
	&Reply($client,"error\n", $userinput);
	}
	} else {
	&Failure($client,"unknown_cmd\n",$userinput);
	}
	}
	&register_handler("instuserrules",\&get_institutional_user_rules,0,1,0);

	sub get_institutional_id_rules {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my $dom = &unescape($tail);
	my (%rules_hash,@rules_order);
	my $outcome;
	eval {
	local($SIG{__DIE__})='DEFAULT';
	$outcome = &localenroll::id_rules($dom,\%rules_hash,\@rules_order);
	};
	if (!$@) {
	if ($outcome eq 'ok') {
	my $result;
	foreach my $key (keys(%rules_hash)) {
	$result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
	}
	$result =~ s/\&$//;
	$result .= ':';
	if (@rules_order > 0) {
	foreach my $item (@rules_order) {
	$result .= &escape($item).'&';
	}
	}
	$result =~ s/\&$//;
	&Reply($client,\$result,$userinput);
	} else {
	&Reply($client,"error\n", $userinput);
	}
	} else {
	&Failure($client,"unknown_cmd\n",$userinput);
	}
	}
	&register_handler("instidrules",\&get_institutional_id_rules,0,1,0);


	sub institutional_username_check {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my %rulecheck;
	my $outcome;
	my ($udom,$uname,@rules) = split(/:/,$tail);
	$udom = &unescape($udom);
	$uname = &unescape($uname);
	@rules = map {&unescape($_);} (@rules);
	eval {
	local($SIG{__DIE__})='DEFAULT';
	$outcome = &localenroll::username_check($udom,$uname,\@rules,\%rulecheck);
	};
	if (!$@) {
	if ($outcome eq 'ok') {
	my $result='';
	foreach my $key (keys(%rulecheck)) {
	$result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
	}
	&Reply($client,\$result,$userinput);
	} else {
	&Reply($client,"error\n", $userinput);
	}
	} else {
	&Failure($client,"unknown_cmd\n",$userinput);
	}
	}
	&register_handler("instrulecheck",\&institutional_username_check,0,1,0);

	sub institutional_id_check {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my %rulecheck;
	my $outcome;
	my ($udom,$id,@rules) = split(/:/,$tail);
	$udom = &unescape($udom);
	$id = &unescape($id);
	@rules = map {&unescape($_);} (@rules);
	eval {
	local($SIG{__DIE__})='DEFAULT';
	$outcome = &localenroll::id_check($udom,$id,\@rules,\%rulecheck);
	};
	if (!$@) {
	if ($outcome eq 'ok') {
	my $result='';
	foreach my $key (keys(%rulecheck)) {
	$result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
	}
	&Reply($client,\$result,$userinput);
	} else {
	&Reply($client,"error\n", $userinput);
	}
	} else {
	&Failure($client,"unknown_cmd\n",$userinput);
	}
	}
	&register_handler("instidrulecheck",\&institutional_id_check,0,1,0);

# Get domain specific conditions for import of student photographs to a course	# Get domain specific conditions for import of student photographs to a course
#	#
Line 4635 sub inst_usertypes_handler {	Line 4913 sub inst_usertypes_handler {
}	}
$res=~s/\&$//;	$res=~s/\&$//;
}	}
&Reply($client, "$res\n", $userinput);	&Reply($client, \$res, $userinput);
return 1;	return 1;
}	}
&register_handler("inst_usertypes", \&inst_usertypes_handler, 0, 1, 0);	&register_handler("inst_usertypes", \&inst_usertypes_handler, 0, 1, 0);

sub inst_dirsrch_handler {
my ($cmd, $tail, $client) = @_;
my ($domain,$srchby,$srchterm,$srchtype) = split(/:/, $tail);
$srchby = &unescape($srchby);
$srchterm = &unescape($srchterm);
my $userinput = $cmd.":".$tail; # For logging purposes.
my (%instusers,%instids,$result,$res);
eval {
local($SIG{__DIE__})='DEFAULT';
$result=&localenroll::get_userinfo($domain,undef,undef,\%instusers,\%instids,undef,$srchby,$srchterm,$srchtype);
};
if ($result eq 'ok') {
if (keys(%instusers) > 0) {
foreach my $key (keys(%instusers)) {
my $usrstr = &Apache::lonnet::hash2str(%{$instusers{$key}});
$res.=&escape($key).'='.&escape($usrstr).'&';
}
}
$res=~s/\&$//;
}
&Reply($client, "$res\n", $userinput);
}
&register_handler("instdirsrch", \&inst_dirsrch_handler, 0, 1, 0);

# mkpath makes all directories for a file, expects an absolute path with a	# mkpath makes all directories for a file, expects an absolute path with a
# file or a trailing / if just a dir is passed	# file or a trailing / if just a dir is passed
# returns 1 on success 0 on failure	# returns 1 on success 0 on failure
Line 5158 sub Debug {	Line 5412 sub Debug {
#	#
sub Reply {	sub Reply {
my ($fd, $reply, $request) = @_;	my ($fd, $reply, $request) = @_;
print $fd $reply;	if (ref($reply)) {
Debug("Request was $request Reply was $reply");	print $fd $$reply;
	print $fd "\n";
	if ($DEBUG) { Debug("Request was $request Reply was $$reply"); }
	} else {
	print $fd $reply;
	if ($DEBUG) { Debug("Request was $request Reply was $reply"); }
	}
$Transactions++;	$Transactions++;
}	}

Line 5789 sub validate_user {	Line 6048 sub validate_user {
my $credentials= &Authen::Krb5::cc_default();	my $credentials= &Authen::Krb5::cc_default();
$credentials->initialize(&Authen::Krb5::parse_name($user.'@'	$credentials->initialize(&Authen::Krb5::parse_name($user.'@'
.$contentpwd));	.$contentpwd));
my $krbreturn = &Authen::Krb5::get_in_tkt_with_password($krbclient,	my $krbreturn;
$krbserver,	if (exists(&Authen::Krb5::get_init_creds_password)) {
$password,	$krbreturn =
$credentials);	&Authen::Krb5::get_init_creds_password($krbclient,$password,
$validated = ($krbreturn == 1);	$krbservice);
	$validated = (ref($krbreturn) eq 'Authen::Krb5::Creds');
	} else {
	$krbreturn =
	&Authen::Krb5::get_in_tkt_with_password($krbclient,$krbserver,
	$password,$credentials);
	$validated = ($krbreturn == 1);
	}
	if (!$validated) {
	&logthis('krb5: '.$user.', '.$contentpwd.', '.
	&Authen::Krb5::error());
	}
} else {	} else {
$validated = 0;	$validated = 0;
}	}
Line 6082 sub change_unix_password {	Line 6352 sub change_unix_password {

sub make_passwd_file {	sub make_passwd_file {
my ($uname, $umode,$npass,$passfilename)=@_;	my ($uname, $umode,$npass,$passfilename)=@_;
my $result="ok\n";	my $result="ok";
if ($umode eq 'krb4' or $umode eq 'krb5') {	if ($umode eq 'krb4' or $umode eq 'krb5') {
{	{
my $pf = IO::File->new(">$passfilename");	my $pf = IO::File->new(">$passfilename");
Line 6150 sub make_passwd_file {	Line 6420 sub make_passwd_file {
if($useraddok > 0) {	if($useraddok > 0) {
my $error_text = &lcuseraddstrerror($useraddok);	my $error_text = &lcuseraddstrerror($useraddok);
&logthis("Failed lcuseradd: $error_text");	&logthis("Failed lcuseradd: $error_text");
$result = "lcuseradd_failed:$error_text\n";	$result = "lcuseradd_failed:$error_text";
} else {	} else {
my $pf = IO::File->new(">$passfilename");	my $pf = IO::File->new(">$passfilename");
if($pf) {	if($pf) {
Line 6174 sub make_passwd_file {	Line 6444 sub make_passwd_file {
}	}
}	}
} else {	} else {
$result="auth_mode_error\n";	$result="auth_mode_error";
}	}
return $result;	return $result;
}	}

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

Removed from v.1.376
changed lines
	Added in v.1.394.2.1