loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.333 and 1.368

version 1.333, 2006/06/07 01:49:43	version 1.368, 2007/04/03 00:49:55
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 40 use IO::File;	Line 41 use IO::File;
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;
use lib '/home/httpd/lib/perl/';
use localauth;	use localauth;
use localenroll;	use localenroll;
use localstudentphoto;	use localstudentphoto;
use File::Copy;	use File::Copy;
use File::Find;	use File::Find;
use LONCAPA::ConfigFileEdit;
use LONCAPA::lonlocal;	use LONCAPA::lonlocal;
use LONCAPA::lonssl;	use LONCAPA::lonssl;
use Fcntl qw(:flock);	use Fcntl qw(:flock);
Line 85 my $tmpsnum = 0; # Id of tmpputs.	Line 85 my $tmpsnum = 0; # Id of tmpputs.

my $ConnectionType;	my $ConnectionType;

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

my %managers; # Ip -> manager names	my %managers; # Ip -> manager names

my %perlvar; # Will have the apache conf defined perl vars.	my %perlvar; # Will have the apache conf defined perl vars.
Line 424 sub ReadManagerTable {	Line 418 sub ReadManagerTable {
if ($host =~ "^#") { # Comment line.	if ($host =~ "^#") { # Comment line.
next;	next;
}	}
if (!defined $hostip{$host}) { # This is a non cluster member	if (!defined &Apache::lonnet::get_host_ip($host)) { # This is a non cluster member
# The entry is of the form:	# The entry is of the form:
# cluname:hostname	# cluname:hostname
# cluname - A 'cluster hostname' is needed in order to negotiate	# cluname - A 'cluster hostname' is needed in order to negotiate
Line 442 sub ReadManagerTable {	Line 436 sub ReadManagerTable {
}	}
} else {	} else {
logthis('<font color="green"> existing host'." $host</font>\n");	logthis('<font color="green"> existing host'." $host</font>\n");
$managers{$hostip{$host}} = $host; # Use info from cluster tab if clumemeber	$managers{&Apache::lonnet::get_host_ip($host)} = $host; # Use info from cluster tab if clumemeber
}	}
}	}
}	}
Line 503 sub AdjustHostContents {	Line 497 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 829 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 882 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 1034 sub ping_handler {	Line 1026 sub ping_handler {
sub pong_handler {	sub pong_handler {
my ($cmd, $tail, $replyfd) = @_;	my ($cmd, $tail, $replyfd) = @_;

my $reply=&reply("ping",$clientname);	my $reply=&Apache::lonnet::reply("ping",$clientname);
&Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail");	&Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail");
return 1;	return 1;
}	}
Line 1144 sub load_handler {	Line 1136 sub load_handler {
sub user_load_handler {	sub user_load_handler {
my ($cmd, $tail, $replyfd) = @_;	my ($cmd, $tail, $replyfd) = @_;

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

return 1;	return 1;
Line 1252 sub push_file_handler {	Line 1244 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 1270 sub du_handler {	Line 1262 sub du_handler {
my $code=sub {	my $code=sub {
if ($_=~/\.\d+\./) { return;}	if ($_=~/\.\d+\./) { return;}
if ($_=~/\.meta$/) { return;}	if ($_=~/\.meta$/) { return;}
	if (-d $_) { return;}
$total_size+=(stat($_))[7];	$total_size+=(stat($_))[7];
};	};
chdir($ududir);	chdir($ududir);
Line 1576 sub change_password_handler {	Line 1569 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 1605 sub change_password_handler {	Line 1605 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 1844 sub update_resource_handler {	Line 1844 sub update_resource_handler {
my $now=time;	my $now=time;
my $since=$now-$atime;	my $since=$now-$atime;
if ($since>$perlvar{'lonExpire'}) {	if ($since>$perlvar{'lonExpire'}) {
my $reply=&reply("unsub:$fname","$clientname");	my $reply=&Apache::lonnet::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=&Apache::lonnet::reply("sub:$fname","$clientname");
my $response;	my $response;
alarm(120);	alarm(120);
{	{
Line 1894 sub devalidate_meta_cache {	Line 1895 sub devalidate_meta_cache {
my ($url) = @_;	my ($url) = @_;
use Cache::Memcached;	use Cache::Memcached;
my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});	my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
$url = &declutter($url);	$url = &Apache::lonnet::declutter($url);
$url =~ s-\.meta$--;	$url =~ s-\.meta$--;
my $id = &escape('meta:'.$url);	my $id = &escape('meta:'.$url);
$memcache->delete($id);	$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 2124 sub token_auth_user_file_handler {	Line 2115 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")) {
flock(ENVIN,LOCK_SH);	flock(ENVIN,LOCK_SH);
while (my $line=<ENVIN>) {	tie(my %disk_env,'GDBM_File',"$file",&GDBM_READER(),0640);
my ($envname)=split(/=/,$line,2);	if (exists($disk_env{"userfile.$fname"})) {
$envname=&unescape($envname);	$reply="ok\n";
if ($envname=~ m\|^userfile\.\Q$fname\E\|) { $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 2594 sub get_profile_entry_encrypted {	Line 2592 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 3039 sub restore_handler {	Line 3037 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 3215 sub reply_query_handler {	Line 3213 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 3279 sub put_course_id_handler {	Line 3277 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;
	my @current_items = split(/:/,$hashref->{$key},-1);
my @current_items = split(/:/,$hashref->{$key});
shift(@current_items); # remove description	shift(@current_items); # remove description
pop(@current_items); # remove last access	pop(@current_items); # remove last access
my $numcurrent = scalar(@current_items);	my $numcurrent = scalar(@current_items);
	if ($numcurrent > 3) {
my @new_items = split(/:/,$courseinfo);	$numcurrent = 3;
	}
	my @new_items = split(/:/,$courseinfo,-1);
my $numnew = scalar(@new_items);	my $numnew = scalar(@new_items);
if ($numcurrent > 0) {	if ($numcurrent > 0) {
if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2	if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2
Line 3335 sub put_course_id_handler {	Line 3334 sub put_course_id_handler {
# institutional code - optional supplied code to filter	# institutional code - optional supplied code to filter
# the dump. Only courses with an institutional code	# the dump. Only courses with an institutional code
# that match the supplied code will be returned.	# that match the supplied code will be returned.
# owner - optional supplied username of owner to filter	# owner - optional supplied username and domain of owner to
# the dump. Only courses for which the course	# filter the dump. Only courses for which the course
# owner matches the supplied username will be	# owner matches the supplied username and/or domain
# returned. Implicit assumption that owner	# will be returned. Pre-2.2.0 legacy entries from
# is a user in the domain in which the	# nohist_courseiddump will only contain usernames.
# course database is defined.
# $client - The socket open on the client.	# $client - The socket open on the client.
# Returns:	# Returns:
# 1 - Continue processing.	# 1 - Continue processing.
Line 3352 sub dump_course_id_handler {	Line 3350 sub dump_course_id_handler {
my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";

my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,	my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
$typefilter) =split(/:/,$tail);	$typefilter,$regexp_ok) =split(/:/,$tail);
if (defined($description)) {	if (defined($description)) {
$description=&unescape($description);	$description=&unescape($description);
} else {	} else {
Line 3363 sub dump_course_id_handler {	Line 3361 sub dump_course_id_handler {
} else {	} else {
$instcodefilter='.';	$instcodefilter='.';
}	}
	my ($ownerunamefilter,$ownerdomfilter);
if (defined($ownerfilter)) {	if (defined($ownerfilter)) {
$ownerfilter=&unescape($ownerfilter);	$ownerfilter=&unescape($ownerfilter);
	if ($ownerfilter ne '.' && defined($ownerfilter)) {
	if ($ownerfilter =~ /^([^:]):([^:])$/) {
	$ownerunamefilter = $1;
	$ownerdomfilter = $2;
	} else {
	$ownerunamefilter = $ownerfilter;
	$ownerdomfilter = '';
	}
	}
} else {	} else {
$ownerfilter='.';	$ownerfilter='.';
}	}

if (defined($coursefilter)) {	if (defined($coursefilter)) {
$coursefilter=&unescape($coursefilter);	$coursefilter=&unescape($coursefilter);
} else {	} else {
Line 3378 sub dump_course_id_handler {	Line 3387 sub dump_course_id_handler {
} else {	} else {
$typefilter='.';	$typefilter='.';
}	}
	if (defined($regexp_ok)) {
	$regexp_ok=&unescape($regexp_ok);
	}

unless (defined($since)) { $since=0; }	unless (defined($since)) { $since=0; }
my $qresult='';	my $qresult='';
Line 3398 sub dump_course_id_handler {	Line 3410 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 3416 sub dump_course_id_handler {	Line 3463 sub dump_course_id_handler {
}	}
unless ($typefilter eq '.' \|\| !defined($typefilter)) {	unless ($typefilter eq '.' \|\| !defined($typefilter)) {
my $unescapeType = &unescape($type);	my $unescapeType = &unescape($type);
if (!defined($type)) {	if ($type eq '') {
if ($typefilter ne 'Course') {	if ($typefilter ne 'Course') {
$match = 0;	$match = 0;
}	}
Line 3448 sub dump_course_id_handler {	Line 3495 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_domain_handler, 0, 1, 0);


	#
# Puts an id to a domains id database.	# Puts an id to a domains id database.
#	#
# Parameters:	# Parameters:
Line 3818 sub tmp_put_handler {	Line 3958 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 4043 sub enrollment_enabled_handler {	Line 4191 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 4099 sub validate_course_owner_handler {	Line 4248 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 4139 sub validate_course_section_handler {	Line 4289 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:	# 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??).	# $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:
	# $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:
	# $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 4255 sub get_institutional_code_format_handle	Line 4436 sub get_institutional_code_format_handle
\%cat_titles,	\%cat_titles,
\%cat_order);	\%cat_order);
if ($formatreply eq 'ok') {	if ($formatreply eq 'ok') {
my $codes_str = &hash2str(%codes);	my $codes_str = &Apache::lonnet::hash2str(%codes);
my $codetitles_str = &array2str(@codetitles);	my $codetitles_str = &Apache::lonnet::array2str(@codetitles);
my $cat_titles_str = &hash2str(%cat_titles);	my $cat_titles_str = &Apache::lonnet::hash2str(%cat_titles);
my $cat_order_str = &hash2str(%cat_order);	my $cat_order_str = &Apache::lonnet::hash2str(%cat_order);
&Reply($client,	&Reply($client,
$codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'	$codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'
.$cat_order_str."\n",	.$cat_order_str."\n",
Line 4275 sub get_institutional_code_format_handle	Line 4456 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	# Get domain specific conditions for import of student photographs to a course
#	#
# Retrieves information from photo_permission subroutine in localenroll.	# Retrieves information from photo_permission subroutine in localenroll.
Line 4402 sub student_photo_handler {	Line 4615 sub student_photo_handler {
}	}
&register_handler("studentphoto", \&student_photo_handler, 0, 1, 0);	&register_handler("studentphoto", \&student_photo_handler, 0, 1, 0);

	sub inst_usertypes_handler {
	my ($cmd, $domain, $client) = @_;
	my $res;
	my $userinput = $cmd.":".$domain; # For logging purposes.
	my (%typeshash,@order);
	if (&localenroll::inst_usertypes($domain,\%typeshash,\@order) eq 'ok') {
	if (keys(%typeshash) > 0) {
	foreach my $key (keys(%typeshash)) {
	$res.=&escape($key).'='.&escape($typeshash{$key}).'&';
	}
	}
	$res=~s/\&$//;
	$res .= ':';
	if (@order > 0) {
	foreach my $item (@order) {
	$res .= &escape($item).'&';
	}
	}
	$res=~s/\&$//;
	}
	&Reply($client, "$res\n", $userinput);
	return 1;
	}
	&register_handler("inst_usertypes", \&inst_usertypes_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 4776 sub HUPSMAN { # sig	Line 5014 sub HUPSMAN { # sig
}	}

#	#
# Kill off hashes that describe the host table prior to re-reading it.
# Hashes affected are:
# %hostid, %hostdom %hostip %hostdns.
#
sub KillHostHashes {
foreach my $key (keys %hostid) {
delete $hostid{$key};
}
foreach my $key (keys %hostdom) {
delete $hostdom{$key};
}
foreach my $key (keys %hostip) {
delete $hostip{$key};
}
foreach my $key (keys %hostdns) {
delete $hostdns{$key};
}
}
#
# Read in the host table from file and distribute it into the various hashes:
#
# - %hostid - Indexed by IP, the loncapa hostname.
# - %hostdom - Indexed by loncapa hostname, the domain.
# - %hostip - Indexed by hostid, the Ip address of the host.
sub ReadHostTable {

open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") \|\| die "Can't read host file";
my $myloncapaname = $perlvar{'lonHostID'};
Debug("My loncapa name is : $myloncapaname");
my %name_to_ip;
while (my $configline=<CONFIG>) {
if ($configline !~ /^\s\#/ && $configline !~ /^\s$/ ) {
my ($id,$domain,$role,$name)=split(/:/,$configline);
$name=~s/\s//g;
my $ip;
if (!exists($name_to_ip{$name})) {
$ip = gethostbyname($name);
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};
}
$hostid{$ip}=$id; # LonCAPA name of host by IP.
$hostdom{$id}=$domain; # LonCAPA domain name of host.
$hostname{$id}=$name; # LonCAPA name -> DNS name
$hostip{$id}=$ip; # IP address of host.
$hostdns{$name} = $id; # LonCAPA name of host by DNS.

if ($id eq $perlvar{'lonHostID'}) {
Debug("Found me in the host table: $name");
$thisserver=$name;
}
}
}
close(CONFIG);
}
#
# Reload the Apache daemon's state.	# Reload the Apache daemon's state.
# This is done by invoking /home/httpd/perl/apachereload	# This is done by invoking /home/httpd/perl/apachereload
# a setuid perl script that can be root for us to do this job.	# a setuid perl script that can be root for us to do this job.
Line 4867 sub UpdateHosts {	Line 5044 sub UpdateHosts {
# either dropped or changed hosts. Note that the re-read of the table	# either dropped or changed hosts. Note that the re-read of the table
# will take care of new and changed hosts as connections come into being.	# will take care of new and changed hosts as connections come into being.

	#FIXME need a way to tell lonnet that it needs to reset host
	#cached host info

KillHostHashes;	foreach my $child (keys(%children)) {
ReadHostTable;

foreach my $child (keys %children) {
my $childip = $children{$child};	my $childip = $children{$child};
if(!$hostid{$childip}) {	if (defined(&Apache::lonnet::get_hosts_from_ip($childip))) {
logthis('<font color="blue"> UpdateHosts killing child '	logthis('<font color="blue"> UpdateHosts killing child '
." $child for ip $childip </font>");	." $child for ip $childip </font>");
kill('INT', $child);	kill('INT', $child);
Line 5033 sub status {	Line 5209 sub status {
$0='lond: '.$what.' '.$local;	$0='lond: '.$what.' '.$local;
}	}

# ----------------------------------------------------------- Send USR1 to lonc

sub reconlonc {
my $peerfile=shift;
&logthis("Trying to reconnect for $peerfile");
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
if (my $fh=IO::File->new("$loncfile")) {
my $loncpid=<$fh>;
chomp($loncpid);
if (kill 0 => $loncpid) {
&logthis("lonc at pid $loncpid responding, sending USR1");
kill USR1 => $loncpid;
} else {
&logthis(
"<font color='red'>CRITICAL: "
."lonc at pid $loncpid not responding, giving up</font>");
}
} else {
&logthis('<font color="red">CRITICAL: lonc not running, giving up</font>');
}
}

# -------------------------------------------------- Non-critical communication

sub subreply {
my ($cmd,$server)=@_;
my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
Type => SOCK_STREAM,
Timeout => 10)
or return "con_lost";
print $sclient "sethost:$server:$cmd\n";
my $answer=<$sclient>;
chomp($answer);
if (!$answer) { $answer="con_lost"; }
return $answer;
}

sub reply {
my ($cmd,$server)=@_;
my $answer;
if ($server ne $currenthostid) {
$answer=subreply($cmd,$server);
if ($answer eq 'con_lost') {
$answer=subreply("ping",$server);
if ($answer ne $server) {
&logthis("sub reply: answer != server answer is $answer, server is $server");
&reconlonc("$perlvar{'lonSockDir'}/".$hostname{$server});
}
$answer=subreply($cmd,$server);
}
} else {
$answer='self_reply';
}
return $answer;
}

# -------------------------------------------------------------- Talk to lonsql	# -------------------------------------------------------------- Talk to lonsql

sub sql_reply {	sub sql_reply {
Line 5158 $SIG{USR1} = \&checkchildren;	Line 5277 $SIG{USR1} = \&checkchildren;
$SIG{USR2} = \&UpdateHosts;	$SIG{USR2} = \&UpdateHosts;

# Read the host hashes:	# Read the host hashes:
	&Apache::lonnet::load_hosts_tab();
ReadHostTable;

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

Line 5238 sub make_new_child {	Line 5356 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 'fedora6') \|\| ($dist eq 'suse9.3')) {
&Authen::Krb5::init_ets();	&Authen::Krb5::init_ets();
}	}

Line 5252 sub make_new_child {	Line 5371 sub make_new_child {

my $outsideip=$clientip;	my $outsideip=$clientip;
if ($clientip eq '127.0.0.1') {	if ($clientip eq '127.0.0.1') {
$outsideip=$hostip{$perlvar{'lonHostID'}};	$outsideip=&Apache::lonnet::get_host_ip($perlvar{'lonHostID'});
}	}

my $clientrec=($hostid{$outsideip} ne undef);	my $clientrec=defined(&Apache::lonnet::get_hosts_from_ip($outsideip));
my $ismanager=($managers{$outsideip} ne undef);	my $ismanager=($managers{$outsideip} ne undef);
$clientname = "[unknonwn]";	$clientname = "[unknonwn]";
if($clientrec) { # Establish client type.	if($clientrec) { # Establish client type.
$ConnectionType = "client";	$ConnectionType = "client";
$clientname = $hostid{$outsideip};	$clientname = (&Apache::lonnet::get_hosts_from_ip($outsideip))[-1];
if($ismanager) {	if($ismanager) {
$ConnectionType = "both";	$ConnectionType = "both";
}	}
Line 5279 sub make_new_child {	Line 5398 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 5367 sub make_new_child {	Line 5486 sub make_new_child {

if ($clientok) {	if ($clientok) {
# ---------------- New known client connecting, could mean machine online again	# ---------------- New known client connecting, could mean machine online again
	if (&Apache::lonnet::get_host_ip($currenthostid) ne $clientip
foreach my $id (keys(%hostip)) {	&& $clientip ne '127.0.0.1') {
if ($hostip{$id} ne $clientip \|\|	&Apache::lonnet::reconlonc();
$hostip{$currenthostid} eq $clientip) {
# no need to try to do recon's to myself
next;
}
&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 5651 sub validate_user {	Line 5765 sub validate_user {
my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;	my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
my $krbserver = &Authen::Krb5::parse_name($krbservice);	my $krbserver = &Authen::Krb5::parse_name($krbservice);
my $credentials= &Authen::Krb5::cc_default();	my $credentials= &Authen::Krb5::cc_default();
$credentials->initialize($krbclient);	$credentials->initialize(&Authen::Krb5::parse_name($user.'@'
	.$contentpwd));
my $krbreturn = &Authen::Krb5::get_in_tkt_with_password($krbclient,	my $krbreturn = &Authen::Krb5::get_in_tkt_with_password($krbclient,
$krbserver,	$krbserver,
$password,	$password,
Line 5664 sub validate_user {	Line 5779 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);
	if ($validated < 0) {
	&logthis("localauth for $contentpwd $user:$domain returned a $validated");
	$validated = 0;
	}
} else { # Unrecognized auth is also bad.	} else { # Unrecognized auth is also bad.
$validated = 0;	$validated = 0;
}	}
Line 5690 sub addline {	Line 5810 sub addline {
my ($fname,$hostid,$ip,$newline)=@_;	my ($fname,$hostid,$ip,$newline)=@_;
my $contents;	my $contents;
my $found=0;	my $found=0;
my $expr='^'.$hostid.':'.$ip.':';	my $expr='^'.quotemeta($hostid).':'.quotemeta($ip).':';
$expr =~ s/\./\\\./g;
my $sh;	my $sh;
if ($sh=IO::File->new("$fname.subscription")) {	if ($sh=IO::File->new("$fname.subscription")) {
while (my $subline=<$sh>) {	while (my $subline=<$sh>) {
Line 5712 sub get_chat {	Line 5831 sub get_chat {
my @entries=();	my @entries=();
my $namespace = 'nohist_chatroom';	my $namespace = 'nohist_chatroom';
my $namespace_inroom = 'nohist_inchatroom';	my $namespace_inroom = 'nohist_inchatroom';
if (defined($group)) {	if ($group ne '') {
$namespace .= '_'.$group;	$namespace .= '_'.$group;
$namespace_inroom .= '_'.$group;	$namespace_inroom .= '_'.$group;
}	}
Line 5744 sub chat_add {	Line 5863 sub chat_add {
my $time=time;	my $time=time;
my $namespace = 'nohist_chatroom';	my $namespace = 'nohist_chatroom';
my $logfile = 'chatroom.log';	my $logfile = 'chatroom.log';
if (defined($group)) {	if ($group ne '') {
$namespace .= '_'.$group;	$namespace .= '_'.$group;
$logfile = 'chatroom_'.$group.'.log';	$logfile = 'chatroom_'.$group.'.log';
}	}
Line 6052 sub sethost {	Line 6171 sub sethost {
}	}

if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }	if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {	if (&Apache::lonnet::get_host_ip($perlvar{'lonHostID'})
	eq &Apache::lonnet::get_host_ip($hostid)) {
$currenthostid =$hostid;	$currenthostid =$hostid;
$currentdomainid=$hostdom{$hostid};	$currentdomainid=&Apache::lonnet::domain($hostid);
&logthis("Setting hostid to $hostid, and domain to $currentdomainid");	&logthis("Setting hostid to $hostid, and domain to $currentdomainid");
} else {	} else {
&logthis("Requested host id $hostid not an alias of ".	&logthis("Requested host id $hostid not an alias of ".
Line 6070 sub version {	Line 6190 sub version {
return "version:$VERSION";	return "version:$VERSION";
}	}

#There is a copy of this in lonnet.pm
sub userload {
my $numusers=0;
{
opendir(LONIDS,$perlvar{'lonIDsDir'});
my $filename;
my $curtime=time;
while ($filename=readdir(LONIDS)) {
if ($filename eq '.' \|\| $filename eq '..') {next;}
my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
if ($curtime-$mtime < 1800) { $numusers++; }
}
closedir(LONIDS);
}
my $userloadpercent=0;
my $maxuserload=$perlvar{'lonUserLoadLim'};
if ($maxuserload) {
$userloadpercent=100*$numusers/$maxuserload;
}
$userloadpercent=sprintf("%.2f",$userloadpercent);
return $userloadpercent;
}

# Routines for serializing arrays and hashes (copies from lonnet)

sub array2str {
my (@array) = @_;
my $result=&arrayref2str(\@array);
$result=~s/^__ARRAY_REF__//;
$result=~s/__END_ARRAY_REF__$//;
return $result;
}

sub arrayref2str {
my ($arrayref) = @_;
my $result='__ARRAY_REF__';
foreach my $elem (@$arrayref) {
if(ref($elem) eq 'ARRAY') {
$result.=&arrayref2str($elem).'&';
} elsif(ref($elem) eq 'HASH') {
$result.=&hashref2str($elem).'&';
} elsif(ref($elem)) {
#print("Got a ref of ".(ref($elem))." skipping.");
} else {
$result.=&escape($elem).'&';
}
}
$result=~s/\&$//;
$result .= '__END_ARRAY_REF__';
return $result;
}

sub hash2str {
my (%hash) = @_;
my $result=&hashref2str(\%hash);
$result=~s/^__HASH_REF__//;
$result=~s/__END_HASH_REF__$//;
return $result;
}

sub hashref2str {
my ($hashref)=@_;
my $result='__HASH_REF__';
foreach (sort(keys(%$hashref))) {
if (ref($_) eq 'ARRAY') {
$result.=&arrayref2str($_).'=';
} elsif (ref($_) eq 'HASH') {
$result.=&hashref2str($_).'=';
} elsif (ref($_)) {
$result.='=';
#print("Got a ref of ".(ref($_))." skipping.");
} else {
if ($_) {$result.=&escape($_).'=';} else { last; }
}

if(ref($hashref->{$_}) eq 'ARRAY') {
$result.=&arrayref2str($hashref->{$_}).'&';
} elsif(ref($hashref->{$_}) eq 'HASH') {
$result.=&hashref2str($hashref->{$_}).'&';
} elsif(ref($hashref->{$_})) {
$result.='&';
#print("Got a ref of ".(ref($hashref->{$_}))." skipping.");
} else {
$result.=&escape($hashref->{$_}).'&';
}
}
$result=~s/\&$//;
$result .= '__END_HASH_REF__';
return $result;
}

# ----------------------------------- POD (plain old documentation, CPAN style)	# ----------------------------------- POD (plain old documentation, CPAN style)

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

Removed from v.1.333
changed lines
	Added in v.1.368