[LON-CAPA-cvs] cvs: loncom / lond
albertel
lon-capa-cvs-allow@mail.lon-capa.org
Mon, 08 Oct 2007 21:13:57 -0000
This is a MIME encoded message
--albertel1191878037
Content-Type: text/plain
albertel Mon Oct 8 17:13:57 2007 EDT
Modified files:
/loncom lond
Log:
- preventing lond from ballooning in size on large dumps/restores other commands
- passing very long strings apparently causes perl to make internal
allocations of temps that when finished with while freed, aren't
released back to the OS, this should pass the very long strings
by reference now
--albertel1191878037
Content-Type: text/plain
Content-Disposition: attachment; filename="albertel-20071008171357.txt"
Index: loncom/lond
diff -u loncom/lond:1.386 loncom/lond:1.387
--- loncom/lond:1.386 Mon Oct 8 17:05:49 2007
+++ loncom/lond Mon Oct 8 17:13:52 2007
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.386 2007/10/08 21:05:49 albertel Exp $
+# $Id: lond,v 1.387 2007/10/08 21:13:52 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -59,7 +59,7 @@
my $status='';
my $lastlog='';
-my $VERSION='$Revision: 1.386 $'; #' stupid emacs
+my $VERSION='$Revision: 1.387 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid="default";
my $currentdomainid;
@@ -996,7 +996,7 @@
my ($cmd, $tail, $client) = @_;
Debug("$cmd $tail $client .. $currenthostid:");
- Reply( $client,"$currenthostid\n","$cmd:$tail");
+ Reply( $client,\$currenthostid,"$cmd:$tail");
return 1;
}
@@ -1066,7 +1066,7 @@
$key=substr($key,0,32);
my $cipherkey=pack("H32",$key);
$cipher=new IDEA $cipherkey;
- &Reply($replyfd, "$buildkey\n", "$cmd:$tail");
+ &Reply($replyfd, \$buildkey, "$cmd:$tail");
return 1;
@@ -1103,7 +1103,7 @@
my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
- &Reply( $replyfd, "$loadpercent\n", "$cmd:$tail");
+ &Reply( $replyfd, \$loadpercent, "$cmd:$tail");
return 1;
}
@@ -1133,7 +1133,7 @@
my ($cmd, $tail, $replyfd) = @_;
my $userloadpercent=&Apache::lonnet::userload();
- &Reply($replyfd, "$userloadpercent\n", "$cmd:$tail");
+ &Reply($replyfd, \$userloadpercent, "$cmd:$tail");
return 1;
}
@@ -1176,7 +1176,7 @@
} else {
$type .= ':';
}
- &Reply( $replyfd, "$type\n", $userinput);
+ &Reply( $replyfd, \$type, $userinput);
}
return 1;
@@ -1212,7 +1212,7 @@
# process making the request.
my $reply = &PushFile($userinput);
- &Reply($client, "$reply\n", $userinput);
+ &Reply($client, \$reply, $userinput);
} else {
&Failure( $client, "refused\n", $userinput);
@@ -1264,7 +1264,7 @@
chdir($ududir);
find($code,$ududir);
$total_size=int($total_size/1024);
- &Reply($client,"$total_size\n","$cmd:$ududir");
+ &Reply($client,\$total_size,"$cmd:$ududir");
} else {
&Failure($client, "bad_directory:$ududir\n","$cmd:$ududir");
}
@@ -1333,7 +1333,7 @@
$ulsout='no_such_dir';
}
if ($ulsout eq '') { $ulsout='empty'; }
- &Reply($client, "$ulsout\n", $userinput); # This supports debug logging.
+ &Reply($client, \$ulsout, $userinput); # This supports debug logging.
return 1;
@@ -1402,7 +1402,7 @@
$ulsout='no_such_dir';
}
if ($ulsout eq '') { $ulsout='empty'; }
- &Reply($client, "$ulsout\n", $userinput); # This supports debug logging.
+ &Reply($client, \$ulsout, $userinput); # This supports debug logging.
return 1;
}
®ister_handler("ls2", \&ls2_handler, 0, 1, 0);
@@ -1430,7 +1430,7 @@
if(&ValidManager($cert)) {
chomp($userinput);
my $reply = &ReinitProcess($userinput);
- &Reply( $client, "$reply\n", $userinput);
+ &Reply( $client, \$reply, $userinput);
} else {
&Failure( $client, "refused\n", $userinput);
}
@@ -1605,7 +1605,7 @@
my $result = &change_unix_password($uname, $npass);
&logthis("Result of password change for $uname: ".
$result);
- &Reply($client, "$result\n", $userinput);
+ &Reply($client, \$result, $userinput);
} else {
# this just means that the current password mode is not
# one we know how to change (e.g the kerberos auth modes or
@@ -1668,7 +1668,7 @@
my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);
&Reply($client, $result, $userinput); #BUGBUG - could be fail
} else {
- &Failure($client, "$fperror\n", $userinput);
+ &Failure($client, \$fperror, $userinput);
}
}
umask($oldumask);
@@ -1735,9 +1735,9 @@
my $result = &change_unix_password($uname, $npass);
&logthis("Result of password change for $uname: ".$result);
if ($result eq "ok") {
- &Reply($client, "$result\n")
+ &Reply($client, \$result)
} else {
- &Failure($client, "$result\n");
+ &Failure($client, \$result);
}
} else {
my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);
@@ -1756,7 +1756,7 @@
&manage_permissions("/$udom/_au", $udom, $uname, "$umode:");
}
}
- &Reply($client, $result, $userinput);
+ &Reply($client, \$result, $userinput);
}
@@ -2158,7 +2158,7 @@
}
untie(%disk_env);
close(ENVIN);
- &Reply($client, $reply, "$cmd:$tail");
+ &Reply($client, \$reply, "$cmd:$tail");
} else {
&Failure($client, "invalid_token\n", "$cmd:$tail");
}
@@ -2585,7 +2585,7 @@
my $replystring = read_profile($udom, $uname, $namespace, $what);
my ($first) = split(/:/,$replystring);
if($first ne "error") {
- &Reply($client, "$replystring\n", $userinput);
+ &Reply($client, \$replystring, $userinput);
} else {
&Failure($client, $replystring." while attempting get\n", $userinput);
}
@@ -2725,7 +2725,7 @@
}
if (&untie_user_hash($hashref)) {
$qresult=~s/\&$//;
- &Reply($client, "$qresult\n", $userinput);
+ &Reply($client, \$qresult, $userinput);
} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting keys\n", $userinput);
@@ -2795,7 +2795,7 @@
}
}
chop($qresult);
- &Reply($client , "$qresult\n", $userinput);
+ &Reply($client , \$qresult, $userinput);
} else {
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting currentdump\n", $userinput);
@@ -2878,7 +2878,7 @@
}
if (&untie_user_hash($hashref)) {
chop($qresult);
- &Reply($client, "$qresult\n", $userinput);
+ &Reply($client, \$qresult, $userinput);
} else {
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting dump\n", $userinput);
@@ -3086,7 +3086,7 @@
}
if (&untie_user_hash($hashref)) {
$qresult=~s/\&$//;
- &Reply( $client, "$qresult\n", $userinput);
+ &Reply( $client, \$qresult, $userinput);
} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting restore\n", $userinput);
@@ -3167,7 +3167,7 @@
$reply.=&escape($_).':';
}
$reply=~s/\:$//;
- &Reply($client, $reply."\n", $userinput);
+ &Reply($client, \$reply, $userinput);
return 1;
@@ -3626,7 +3626,7 @@
}
if (&untie_domain_hash($hashref)) {
chop($qresult);
- &Reply($client, "$qresult\n", $userinput);
+ &Reply($client, \$qresult, $userinput);
} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting courseiddump\n", $userinput);
@@ -3717,7 +3717,7 @@
}
if (&untie_domain_hash($hashref)) {
$qresult=~s/\&$//;
- &Reply($client, "$qresult\n", $userinput);
+ &Reply($client, \$qresult, $userinput);
} else {
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting getdom\n",$userinput);
@@ -3815,7 +3815,7 @@
}
if (&untie_domain_hash($hashref)) {
$qresult=~s/\&$//;
- &Reply($client, "$qresult\n", $userinput);
+ &Reply($client, \$qresult, $userinput);
} else {
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting idget\n",$userinput);
@@ -3939,7 +3939,7 @@
}
if (&untie_domain_hash($hashref)) {
chop($qresult);
- &Reply($client, "$qresult\n", $userinput);
+ &Reply($client, \$qresult, $userinput);
} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting dcmaildump\n", $userinput);
@@ -4067,7 +4067,7 @@
}
if (&untie_domain_hash($hashref)) {
chop($qresult);
- &Reply($client, "$qresult\n", $userinput);
+ &Reply($client, \$qresult, $userinput);
} else {
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting domrolesdump\n", $userinput);
@@ -4121,7 +4121,7 @@
if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
print $store $record;
close $store;
- &Reply($client, "$id\n", $userinput);
+ &Reply($client, \$id, $userinput);
} else {
&Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
"while attempting tmpput\n", $userinput);
@@ -4155,7 +4155,7 @@
my $execdir=$perlvar{'lonDaemons'};
if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
my $reply=<$store>;
- &Reply( $client, "$reply\n", $userinput);
+ &Reply( $client, \$reply, $userinput);
close $store;
} else {
&Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
@@ -4339,7 +4339,7 @@
my ($cdom) = split(/:/, $tail, 2); # Domain we're asking about.
my $outcome = &localenroll::run($cdom);
- &Reply($client, "$outcome\n", $userinput);
+ &Reply($client, \$outcome, $userinput);
return 1;
}
@@ -4366,7 +4366,7 @@
my @secs = &localenroll::get_sections($coursecode,$cdom);
my $seclist = &escape(join(':',@secs));
- &Reply($client, "$seclist\n", $userinput);
+ &Reply($client, \$seclist, $userinput);
return 1;
@@ -4395,7 +4395,7 @@
$owner = &unescape($owner);
my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
- &Reply($client, "$outcome\n", $userinput);
+ &Reply($client, \$outcome, $userinput);
@@ -4426,7 +4426,7 @@
my ($inst_course_id, $cdom) = split(/:/, $tail);
my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);
- &Reply($client, "$outcome\n", $userinput);
+ &Reply($client, \$outcome, $userinput);
return 1;
@@ -4460,7 +4460,7 @@
local($SIG{__DIE__})='DEFAULT';
$outcome=&localenroll::check_section($inst_class,\@owners,$cdom);
};
- &Reply($client,"$outcome\n", $userinput);
+ &Reply($client,\$outcome, $userinput);
return 1;
}
@@ -4621,7 +4621,7 @@
$result.=&escape($key).'='.&escape($value).'&';
}
$result .= 'code_order='.&escape(join('&',@code_order));
- &Reply($client,$result."\n",$userinput);
+ &Reply($client,\$result,$userinput);
} else {
&Reply($client,"error\n", $userinput);
}
@@ -4656,7 +4656,7 @@
}
}
$result =~ s/\&$//;
- &Reply($client,$result."\n",$userinput);
+ &Reply($client,\$result,$userinput);
} else {
&Reply($client,"error\n", $userinput);
}
@@ -4686,7 +4686,7 @@
foreach my $key (keys(%rulecheck)) {
$result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
}
- &Reply($client,$result."\n",$userinput);
+ &Reply($client,\$result,$userinput);
} else {
&Reply($client,"error\n", $userinput);
}
@@ -4848,7 +4848,7 @@
}
$res=~s/\&$//;
}
- &Reply($client, "$res\n", $userinput);
+ &Reply($client, \$res, $userinput);
return 1;
}
®ister_handler("inst_usertypes", \&inst_usertypes_handler, 0, 1, 0);
@@ -5347,9 +5347,14 @@
#
sub Reply {
my ($fd, $reply, $request) = @_;
- print $fd $reply;
- Debug("Request was $request Reply was $reply");
-
+ if (ref($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++;
}
--albertel1191878037--