[24125] in Perl-Users-Digest
Perl-Users Digest, Issue: 6319 Volume: 10
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Sun Mar 28 18:20:58 2004
Date: Sun, 28 Mar 2004 15:20:11 -0800 (PST)
From: Perl-Users Digest <Perl-Users-Request@ruby.OCE.ORST.EDU>
To: Perl-Users@ruby.OCE.ORST.EDU (Perl-Users Digest)
Perl-Users Digest Sun, 28 Mar 2004 Volume: 10 Number: 6319
Today's topics:
Re: losing data on socket (Anno Siegel)
Re: losing data on socket (Vorxion)
Re: losing data on socket <tassilo.parseval@rwth-aachen.de>
Re: Loss of privledges in a perl app <bernie@fantasyfarm.com>
Digest Administrivia (Last modified: 6 Apr 01) (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: 28 Mar 2004 14:23:16 GMT
From: anno4000@lublin.zrz.tu-berlin.de (Anno Siegel)
Subject: Re: losing data on socket
Message-Id: <c46n4k$7lm$1@mamenchi.zrz.TU-Berlin.DE>
Vorxion <vorxion@knockingshopofthemind.com> wrote in comp.lang.perl.misc:
> I'm losing data on incoming sockets on a server written in perl.
> I'm using IO::Socket, and I'm setting $server->autoflush(0) and
> $server->blocking(0) as well as trying both $server->setbuf($main_buffer)
> or $server->setvbuf($main_buffer,_IOFBF,102400000). I'm using IO::Select
> to tell when I'm ready for reading on individual connections. $main_buffer
> is a pure global in the main:: namspace.
>
> Most telling, the length of $main_buffer never changes from 0. I have no
> idea why. It acts like it's not being used.
>
> I've read the docs, I've been beating myself over the head with this code
> for a week. Someone have mercy on me and tell me how to keep from losing
> the input? Please? I'm desperate at this point.
>
> Same behaviour on perl 5.6.1 Solaris and 5.8.3 Linux. 5.8.0 on Solaris
> actually silently dies when it hits the set[v]buf() command. :-/
>
> Help? Please?
How? All you give us is a description of some program properties in English
prose. What is a "pure global"?
Show your code.
Anno
------------------------------
Date: 28 Mar 2004 16:32:01 -0500
From: vorxion@knockingshopofthemind.com (Vorxion)
Subject: Re: losing data on socket
Message-Id: <40674451$1_1@news.iglou.com>
In article <c46n4k$7lm$1@mamenchi.zrz.TU-Berlin.DE>, Anno Siegel wrote:
>Vorxion <vorxion@knockingshopofthemind.com> wrote in comp.lang.perl.misc:
>> I'm losing data on incoming sockets on a server written in perl.
>> I'm using IO::Socket, and I'm setting $server->autoflush(0) and
>> $server->blocking(0) as well as trying both $server->setbuf($main_buffer)
>> or $server->setvbuf($main_buffer,_IOFBF,102400000). I'm using IO::Select
>> to tell when I'm ready for reading on individual connections. $main_buffer
>> is a pure global in the main:: namspace.
>>
>> Most telling, the length of $main_buffer never changes from 0. I have no
>> idea why. It acts like it's not being used.
>>
>> I've read the docs, I've been beating myself over the head with this code
>> for a week. Someone have mercy on me and tell me how to keep from losing
>> the input? Please? I'm desperate at this point.
>>
>> Same behaviour on perl 5.6.1 Solaris and 5.8.3 Linux. 5.8.0 on Solaris
>> actually silently dies when it hits the set[v]buf() command. :-/
>>
>> Help? Please?
>
>How? All you give us is a description of some program properties in English
>prose. What is a "pure global"?
Pure global would be something not locally or globally scoped with local()
or my().
>Show your code.
I didn't think you'd want me posting that much. Even pared down to what
-may- be relevant in the overall scheme of how I'm doing things, it was 427
lines or so. The whole thing is over 1100. Okay, here's everything that
-should- be germaine, and probably more, but I didn't want to leave out
anything that -could- be an important key. And FWIW, I left the
daemonization code in, just in case, but the behaviour occurs whether it's
attached or not.
Most of the way I'm doing things is straight out of the POD's or the Camel.
One side note--The server itself isn't a forking model, but it does fork
at one point for each client to run some sub-processes without hanging
everything else up. That's why there's a reference to spawn yet. I need
to use it at one point. However, it buffering breaks before anything is
ever spawned, so that isn't what's causing it to blow up.
On with the code then. Maybe this will help...
#!/usr/local/bin/perl5.8.0
# EXCEEDINGLY PARED DOWN FOR USENET.
# I've left just about anything I thought -could- be relevant.
$| = 1;
use Fcntl;
use Fcntl qw(:flock);
use Socket;
use Sys::Hostname;
$local_host = hostname();
$local_addr = inet_ntoa(scalar(gethostbyname(${local_host} || 'localhost')));
use IO::Handle '_IOFBF';
use IO::Socket;
use IO::Select;
use Net::hostent;
##### Set default values.
$port = 4016;
$max_conn = '16';
$psep = "\001\004\000__FLT__\000\004\001";
$timeout_seconds = 30;
$timeouts_per_second = 10;
$logopen = 0;
##### Signal handlers.
$SIG{INT} = \&parent_signal_die;
$SIG{QUIT} = \&parent_signal_die;
$SIG{TERM} = \&parent_signal_die;
$SIG{TSTP} = 'IGNORE';
##### Forward declaration.
sub spawn;
##### Set reaper.
my $waitedpid = 0;
use POSIX ":sys_wait_h";
$SIG{CHLD} = \&REAPER;
########## Begin main processing.
##### Background mode.
if (defined(${cli_background})) {
unless (${working_dir} =~ /^\//) {
fl_log("Daemon mode called without absolutely pathed working directory - exiting.");
${cli_logfile} = '__FLTbogus', fl_die(27,"Daemon mode called without absolutely pathed working directory.");
}
use POSIX;
chdir('/') or fl_die(10,"Could not chdir prior to daemonisation.");
close(STDIN);
close(STDOUT);
close(STDERR);
open(STDIN,"</dev/null");
open(STDOUT,">/dev/null");
fork && exit;
setsid() or fl_die(6,"Could not setsid as part of daemonisation.");
open(STDERR,">/dev/null");
} else {
close(STDERR);
}
##### Create socket.
my $sel = IO::Select->new;
$server = IO::Socket::INET->new(
Proto => 'tcp',
LocalPort => ${port},
Listen => SOMAXCONN,
ReuseAddr => 1,
Timeout => 0.25
);
fl_die(3,"Cannot create socket.") unless ${server};
${server}->setvbuf($super_main_buffer,_IOFBF,102400000);
${server}->autoflush(0);
##### Main server loop.
while (1) {
##### Clean up dead connections.
while (scalar(@del_sels)) {
my $single_conn = shift(@del_sels);
clean_dead(${single_conn});
}
##### Resume timers for connections whose children have finished.
foreach my $client (${sel}->handles) {
my $found = 0;
my $fd = ${client}->fileno;
foreach my $child (keys(%child_pids)) {
$found++,last if ${child_pids{${child}}} == ${fd};
}
$no_degrade{${fd}} = 0 unless ${found};
}
##### Update timers for connections that didn't get anything last time.
##### First, determine which processes were active and select the rest
##### for update.
foreach my $inactive (keys(%timeouts)) {
my $found = 0;
foreach my $single_conn (@active) {
$found++ if ${single_conn} == ${inactive};
}
push(@inactives,${inactive}) unless ${found};
}
##### Make sure to clear the active list for the next cycle.
undef @active;
##### Actually decrement the timers for selected idle connections.
while (scalar(@inactives)) {
my $inactive = shift(@inactives);
$timeouts{${inactive}} -= (1 / ${timeouts_per_second}) * 2 unless ${no_degrade{${inactive}}};
}
##### Clean connections that have timed out entirely.
undef @time_sels;
@time_sels = keys(%timeouts);
while (scalar(@time_sels)) {
my $single_conn = shift(@time_sels);
if (${timeouts{${single_conn}}} <= 0) {
push(@del_sels,${single_conn});
}
}
while (scalar(@del_sels)) {
my $single_conn = shift(@del_sels);
foreach my $one_sel (${sel}->handles) {
$single_conn = ${one_sel}, last if ${one_sel}->fileno == ${single_conn};
}
my $remote_hostinfo = gethostbyaddr(${single_conn}->peeraddr);
my ($remote_hostname);
if (defined(${remote_hostinfo})) {
$remote_hostname = ${remote_hostinfo}->name || ${single_conn}->peerhost;
} else {
$remote_hostname = inet_ntoa(${single_conn}->peeraddr);
}
$remote_hostname .= ' (' . ${single_conn}->fileno . ')';
${single_conn}->shutdown(2);
$total_clients--;
clean_dead(${single_conn});
}
##### Obtain new connections.
undef $client;
$client = ${server}->accept();
if (defined(${client})) {
##### Got one. Initialise everything.
${client}->autoflush(0);
${client}->blocking(0);
${sel}->add(${client});
$total_clients++;
my $remote_hostinfo = gethostbyaddr(${client}->peeraddr);
my ($remote_hostname);
if (defined(${remote_hostinfo})) {
$remote_hostname = ${remote_hostinfo}->name || ${client}->peerhost;
} else {
$remote_hostname = inet_ntoa(${client}->peeraddr);
}
$remote_hostname .= ' (' . ${client}->fileno . ')';
##### Must have passed initial restrictions.
${client}->syswrite(make_packet('PROTOCOL',"FLTSV_SERVER_READY\n"));
}
##### Handle connections whose child system processes have completed.
foreach my $fd (keys(%child_done)) {
foreach my $single_conn (${sel}->handles) {
if (${fd} == ${single_conn}->fileno) {
if (${child_done{${fd}}} == 1) {
${single_conn}->syswrite(make_packet('PROTOCOL',"FLTSV_QUERY_ACCEPTED\n"));
${single_conn}->syswrite(make_packet('PROTOCOL',"FLTSV_START_REPLY\n"));
$child_done{${fd}}++;
}
}
}
}
##### Handle connections with exceptions.
foreach my $single_conn (${sel}->has_exception(1/${timeouts_per_second})) {
##### Handle non-polite connection drops.
unless (defined(${single_conn}->peeraddr)) {
push(@del_sels,${single_conn});
${single_conn}->shutdown(2);
$total_clients--;
next;
}
##### Handle rest of polite exceptions.
my $remote_hostinfo = gethostbyaddr(${single_conn}->peeraddr);
my ($remote_hostname);
if (defined(${remote_hostinfo})) {
$remote_hostname = ${remote_hostinfo}->name || ${single_conn}->peerhost;
} else {
$remote_hostname = inet_ntoa(${single_conn}->peeraddr);
}
$remote_hostname .= ' (' . ${single_conn}->fileno . ')';
push(@del_sels,${single_conn});
${single_conn}->shutdown(2);
$total_clients--;
fl_log("${total_clients} clients are connected.") if ${log} ne 'off' and ${log} > 8;
}
##### Delete references to connections that had exceptions.
while (scalar(@del_sels)) {
my $single_conn = shift(@del_sels);
clean_dead(${single_conn});
}
##### Handle reading from connections with data ready.
foreach my $single_conn (${sel}->can_read(1/${timeouts_per_second})) {
fl_log("BUFFER: ".length(${super_main_buffer})."\n") if ${log} ne 'off' and ${log} > 9;
##### Handle non-polite connection drops.
unless (defined(${single_conn}->peeraddr)) {
push(@del_sels,${single_conn});
${single_conn}->shutdown(2);
$total_clients--;
next;
}
##### Handle reading on connections that politely hung around.
my $remote_hostinfo = gethostbyaddr(${single_conn}->peeraddr);
my ($remote_hostname);
if (defined(${remote_hostinfo})) {
$remote_hostname = ${remote_hostinfo}->name || ${single_conn}->peerhost;
} else {
$remote_hostname = inet_ntoa(${single_conn}->peeraddr);
}
$remote_hostname .= ' (' . ${single_conn}->fileno . ')';
##### Try to get packet length.
my $line_pos = ${positions{${single_conn}->fileno}};
while (${single_conn}->sysread($line,1) and not ${got_length{${single_conn}->fileno}}) {
$line_pos++;
$lengths{${single_conn}->fileno} = ${lengths{${single_conn}->fileno}} . ${line};
if (${lengths{${single_conn}->fileno}} =~ /.*${psep}$/) {
${lengths{${single_conn}->fileno}} =~ s/${psep}//;
$got_length{${single_conn}->fileno} = 1;
$timeouts{${single_conn}->fileno} = ${timeout_seconds};
last;
}
}
##### Handle failure to get any length data as lost conn.
if (not ${got_length{${single_conn}->fileno}} and not ${line_pos}) {
push(@del_sels,${single_conn});
${single_conn}->shutdown(2);
$total_clients--;
next;
} elsif (${line_pos}) {
my $found = 0;
foreach my $active (@active) {
$found++ if ${single_conn}->fileno == ${active};
}
push(@active,${single_conn}->fileno) unless ${found};
}
##### Try to get rest of packet.
my $result = 0;
$line_pos = 0;
while (${got_length{${single_conn}->fileno}} and $result = ${single_conn}->sysread($line,${lengths{${single_conn}->fileno}} - ${positions{${single_conn}->fileno}}) and not ${got_packet{${single_conn}->fileno}}) {
$line_pos += ${result};
$packets{${single_conn}->fileno} .= ${line};
$positions{${single_conn}->fileno} += ${line_pos};
if (${positions{${single_conn}->fileno}} == ${lengths{${single_conn}->fileno}}) {
$got_packet{${single_conn}->fileno} = 1;
$positions{${single_conn}->fileno} = 0;
$timeouts{${single_conn}->fileno} = ${timeout_seconds};
last;
}
}
##### Handle failure to get any packet data as lost conn.
if (${got_length{${single_conn}->fileno}} and not ${got_packet{${single_conn}->fileno}} and not ${line_pos}) {
push(@del_sels,${single_conn});
${single_conn}->shutdown(2);
$total_clients--;
next;
} elsif (${line_pos}) {
my $found = 0;
foreach my $active (@active) {
$found++ if ${single_conn}->fileno == ${active};
}
push(@active,${single_conn}->fileno) unless ${found};
}
##### We got our packet, let's handle protocol.
if (${got_length{${single_conn}->fileno}} and ${got_packet{${single_conn}->fileno}}) {
my ($proto,$data);
##### Determine packet type and data.
($proto,$data) = get_packet(${packets{${single_conn}->fileno}});
##### reset the flags for the next packet read attempt.
$got_length{${single_conn}->fileno} = 0;
$got_packet{${single_conn}->fileno} = 0;
$positions{${single_conn}->fileno} = 0;
$lengths{${single_conn}->fileno} = '';
$packets{${single_conn}->fileno} = '';
$timeouts{${single_conn}->fileno} = ${timeout_seconds};
##### Handle protocol packets.
if (${proto} eq 'PROTOCOL') {
chomp(${data});
my ($pstring,$dstring);
($pstring,$dstring) = split(/ /,${data},2);
##### Obtain and validate query type.
if (${pstring} =~ /^FLTSV_QUERY_TYPE:/ and not defined(${got_type{${single_conn}->fileno}})) {
my $found = 0;
foreach $valid_type (@query_types) {
$found++ if ${valid_type} eq ${dstring};
}
if (${found}) {
$got_type{${single_conn}->fileno} = ${dstring};
${single_conn}->syswrite(make_packet('PROTOCOL',"FLTSV_SUCCESS: Query type '${dstring}' valid.\n"));
fl_log("[${remote_hostname}] Query type '${dstring}' accepted.") if ${log} ne 'off';
next;
} else {
${single_conn}->syswrite(make_packet('PROTOCOL',"FLTSV_ERROR: Invalid query type.\n"));
fl_log("[${remote_hostname}] Query type '${dstring}' invalid - disconnecting.") if ${log} ne 'off';
push(@del_sels,${single_conn});
${single_conn}->shutdown(2);
$total_clients--;
fl_log("${total_clients} clients are connected.") if ${log} ne 'off' and ${log} > 8;
next;
}
}
# ABOUT SIX MORE POTENTIAL APPLICATION LEVEL PROTOCOL BLOCKS LIKE THAT,
# AND ANOTHER BLOCK FOR GATHERING DATA TYPE PACKETS.
}
my ($check_adv);
${single_conn}->recv($check_adv,1,MSG_PEEK);
redo if length(${check_adv});
}
##### Clean up any dead connections.
while (scalar(@del_sels)) {
my $single_conn = shift(@del_sels);
clean_dead(${single_conn});
}
}
##### Close log if set.
if (defined(${cli_logfile}) and ${cli_logfile} ne '__FLTbogus') {
fl_log("Closing logfile ${logfile}.") if ${log} ne 'off';
close(LOGFILE) or fl_die(2,"Could not close log file.");
}
##### Done.
exit;
########## Miscellaneous functions.
##### Mr. Reaper.
sub REAPER {
my ($waitedpid,$remote_hostname);
$waitedpid = 0;
while (($waitedpid = waitpid(-1,WNOHANG)) > 0) {
fl_log("Reaped process ${waitedpid}.") if ${log} ne 'off' and ${log} > 8;
if (exists(${child_pids{${waitedpid}}})) {
fl_log("Process ${waitedpid} was the main child of fd (".${child_pids{${waitedpid}}}.").") if ${log} ne 'off' and ${log} > 8;
$child_done{${child_pids{${waitedpid}}}}++;
delete(${child_pids{${waitedpid}}});
}
}
$SIG{CHLD} = \&REAPER; #SysV
}
##### Spawn subroutine to fork off children for system command calls.
sub spawn {
my $client = shift;
my $coderef = shift;
my $remote_hostinfo = gethostbyaddr(${client}->peeraddr);
my ($remote_hostname);
if (defined(${remote_hostinfo})) {
$remote_hostname = ${remote_hostinfo}->name || ${client}->peerhost;
} else {
$remote_hostname = inet_ntoa(${client}->peeraddr);
}
$remote_hostname .= ' (' . ${client}->fileno . ')';
unless (@_ == 0 && ${coderef} && ref(${coderef}) eq 'CODE') {
fl_log("Spawn subroutine failed.") if ${log} ne 'off' and ${log} == 9;
}
my $pid;
if (!defined($pid = fork)) {
fl_log("Failed to fork child process.") if ${log} ne 'off' and ${log} == 9;
return;
} elsif (${pid}) {
fl_log("[${remote_hostname}] Forked child process ${pid}.") if ${log} ne 'off' and ${log} == 9;
$child_pids{${pid}} = ${client}->fileno;
return;
}
$0 = "${short_bin_name} [Running System Command (child)]";
my $stdfd = ${client}->fileno;
open(STDIN,"<&${stdfd}") or fl_die(15,"Could not dup client to STDIN.");
unless (defined(${cli_logfile})) {
open(LOGFILE,">&STDOUT") or fl_die(16,"Could not dup logfile for child.");
}
open(STDOUT,">&${stdfd}") or fl_die(17,"Could not dup client to STDOUT.");
exit(&$coderef());
}
##### Die as a child when catching a signal.
sub child_signal_die {
my ($signal);
$signal = $_[0];
$cli_logfile = "__FLTbogus";
fl_log("Child caught SIG${signal} - exiting.") if ${log} ne 'off' and ${log} > 8;
exit;
}
##### Clean up sockets on a signal.
sub parent_signal_die {
my ($signal,$conn,$peer,$child);
$signal = $_[0];
fl_log("Caught SIG${signal} - cleaning up.") if ${log} ne 'off';
foreach $conn (${sel}->handles) {
my $remote_hostinfo = gethostbyaddr(${conn}->peeraddr);
my ($remote_hostname);
if (defined(${remote_hostinfo})) {
$remote_hostname = ${remote_hostinfo}->name || ${conn}->peerhost;
} else {
$remote_hostname = inet_ntoa(${conn}->peeraddr);
}
$remote_hostname .= ' (' . ${conn}->fileno . ')';
fl_log("Disconnecting ${remote_hostname}.") if ${log} > 8;
${conn}->shutdown(2);
}
foreach $child (keys %child_pids) {
fl_log("Killing child process ${child}.") if ${log} ne 'off' and ${log} > 8;
kill(${signal},${child});
}
fl_log("Server shutting down.") if ${log} ne 'off' and ${log} > 8;
if (defined(${cli_logfile}) and ${cli_logfile} ne '__FLTbogus') {
fl_log("Closing logfile ${logfile}.") if ${log} ne 'off';
close(LOGFILE);
}
exit;
}
--
Vorxion - Member of The Vortexa Elite
------------------------------
Date: 28 Mar 2004 22:30:13 GMT
From: "Tassilo v. Parseval" <tassilo.parseval@rwth-aachen.de>
Subject: Re: losing data on socket
Message-Id: <c47jll$kov$1@nets3.rz.RWTH-Aachen.DE>
Also sprach Vorxion:
> In article <c46n4k$7lm$1@mamenchi.zrz.TU-Berlin.DE>, Anno Siegel wrote:
>>Vorxion <vorxion@knockingshopofthemind.com> wrote in comp.lang.perl.misc:
>>> I'm losing data on incoming sockets on a server written in perl.
>>> I'm using IO::Socket, and I'm setting $server->autoflush(0) and
>>> $server->blocking(0) as well as trying both $server->setbuf($main_buffer)
>>> or $server->setvbuf($main_buffer,_IOFBF,102400000). I'm using IO::Select
>>> to tell when I'm ready for reading on individual connections. $main_buffer
>>> is a pure global in the main:: namspace.
>>>
>>> Most telling, the length of $main_buffer never changes from 0. I have no
>>> idea why. It acts like it's not being used.
>>>
>>> I've read the docs, I've been beating myself over the head with this code
>>> for a week. Someone have mercy on me and tell me how to keep from losing
>>> the input? Please? I'm desperate at this point.
>>>
>>> Same behaviour on perl 5.6.1 Solaris and 5.8.3 Linux. 5.8.0 on Solaris
>>> actually silently dies when it hits the set[v]buf() command. :-/
>>>
>>> Help? Please?
>>
>>How? All you give us is a description of some program properties in English
>>prose. What is a "pure global"?
>
> Pure global would be something not locally or globally scoped with local()
> or my().
So it's neither a lexical nor a package variable (to which local() can
be applied). What is it then? There are only those two flavour of
variables. In your case $main_buffer is a package variable as you say
that it lives in the package 'main'. In this case it could be subject to
local(), of course.
>>Show your code.
>
> I didn't think you'd want me posting that much. Even pared down to what
> -may- be relevant in the overall scheme of how I'm doing things, it was 427
> lines or so. The whole thing is over 1100. Okay, here's everything that
> -should- be germaine, and probably more, but I didn't want to leave out
> anything that -could- be an important key. And FWIW, I left the
> daemonization code in, just in case, but the behaviour occurs whether it's
> attached or not.
This code is a mess, I am afraid. I doubt people will be able to spot
the problem in it. Here are some comments that should help you to clean
up your code a bit. Maybe it will help you to find out what is wrong.
> #!/usr/local/bin/perl5.8.0
> # EXCEEDINGLY PARED DOWN FOR USENET.
> # I've left just about anything I thought -could- be relevant.
> $| = 1;
> use Fcntl;
> use Fcntl qw(:flock);
> use Socket;
> use Sys::Hostname;
> $local_host = hostname();
You are not using strictures. A program of a certain size (and yours
does qualify) will benefit from using strict along with lexical
variables. I wouldn't be surprised if your program behaved badly due to
too many global variables and actions-at-a-distance arising from that.
Therefore:
use strict;
my $local_host = hostname();
and likewise for all other variables you introduce at some point.
> $local_addr = inet_ntoa(scalar(gethostbyname(${local_host} || 'localhost')));
^ ^
What are those curlies doing there? They are not wrong, but they serve
no purpose either. All they do is harm readability. Ditch them here and
everywhere else where you are using them.
> use IO::Handle '_IOFBF';
> use IO::Socket;
> use IO::Select;
> use Net::hostent;
> ##### Set default values.
> $port = 4016;
> $max_conn = '16';
> $psep = "\001\004\000__FLT__\000\004\001";
> $timeout_seconds = 30;
> $timeouts_per_second = 10;
> $logopen = 0;
> ##### Signal handlers.
> $SIG{INT} = \&parent_signal_die;
> $SIG{QUIT} = \&parent_signal_die;
> $SIG{TERM} = \&parent_signal_die;
> $SIG{TSTP} = 'IGNORE';
> ##### Forward declaration.
> sub spawn;
What's this for? You always use parens on functions (and no prototypes
either), so you don't need any forward declarations.
> ##### Set reaper.
> my $waitedpid = 0;
Interestingly enough, you used a lexical variable here. Why here and not
elsewhere?
> use POSIX ":sys_wait_h";
> $SIG{CHLD} = \&REAPER;
> ########## Begin main processing.
> ##### Background mode.
> if (defined(${cli_background})) {
> unless (${working_dir} =~ /^\//) {
> fl_log("Daemon mode called without absolutely pathed working directory - exiting.");
> ${cli_logfile} = '__FLTbogus', fl_die(27,"Daemon mode called without absolutely pathed working directory.");
I find using the comma like this confusing. This line looks as though it
contains two statements. Don't unecessarily join them into on.
Also, fl_die() looks like a function that terminates your program. Why
do you first assign to a variable just to die immediately afterwards.
Is it maybe because fl_die() accesses the value of $cli_logfile? If so,
this is a poor way of passing data around. Pass it as a proper argument:
fl_die(27, '...', '__FLTbogus');
The first argument '27', is that a sort of error-code? Maybe you declare
those as constants. 27 looks rather meaningless to me (and maybe even to
you when you read your program again in a few months without touching it
in between).
> }
> use POSIX;
> chdir('/') or fl_die(10,"Could not chdir prior to daemonisation.");
Wouldn't hurt to include $! in the error message:
chdir '/' or fl_die(10, "...: $!");
> close(STDIN);
> close(STDOUT);
> close(STDERR);
> open(STDIN,"</dev/null");
> open(STDOUT,">/dev/null");
> fork && exit;
> setsid() or fl_die(6,"Could not setsid as part of daemonisation.");
> open(STDERR,">/dev/null");
> } else {
> close(STDERR);
> }
>
> ##### Create socket.
> my $sel = IO::Select->new;
> $server = IO::Socket::INET->new(
> Proto => 'tcp',
> LocalPort => ${port},
> Listen => SOMAXCONN,
> ReuseAddr => 1,
> Timeout => 0.25
> );
> fl_die(3,"Cannot create socket.") unless ${server};
> ${server}->setvbuf($super_main_buffer,_IOFBF,102400000);
You didn't read the perldocs too carefully, as it seems. 'perldoc
IO::Handle' says:
WARNING: The IO::Handle::setvbuf() is not available by default on
Perls 5.8.0 and later because setvbuf() is rather specific to using
the stdio library, while Perl prefers the new perlio subsystem
instead.
According to your shebang line, you are using 5.8.0.
> ${server}->autoflush(0);
>
> ##### Main server loop.
> while (1) {
> ##### Clean up dead connections.
> while (scalar(@del_sels)) {
> my $single_conn = shift(@del_sels);
> clean_dead(${single_conn});
> }
Easier:
clean_dead(shift @del_sels) while @del_sels;
You neither need the temporary variable $single_conn nor the explicit
'scalar'.
> ##### Resume timers for connections whose children have finished.
> foreach my $client (${sel}->handles) {
> my $found = 0;
> my $fd = ${client}->fileno;
> foreach my $child (keys(%child_pids)) {
> $found++,last if ${child_pids{${child}}} == ${fd};
> }
> $no_degrade{${fd}} = 0 unless ${found};
> }
>
> ##### Update timers for connections that didn't get anything last time.
> ##### First, determine which processes were active and select the rest
> ##### for update.
> foreach my $inactive (keys(%timeouts)) {
> my $found = 0;
> foreach my $single_conn (@active) {
> $found++ if ${single_conn} == ${inactive};
> }
> push(@inactives,${inactive}) unless ${found};
> }
I think you should try to decrease your character-count a bit. All those
braces make your code harder on the eye. I particularly hate
${child_pids{${child}}}
# should be
$child_pids{$child}
Keep in mind that humans aren't very good at deciphering hordes of
nested delimiters (especially when they are all the same).
> ##### Make sure to clear the active list for the next cycle.
> undef @active;
I don't know where that variable is coming from. However, an explicit
'undef' in a while-loop along with this comment above makes me wonder
whether you really restricted your variables to its smallest possible
scope.
[...]
I am a bit tired now and my eyes started to blead over lines like this
one:
> while (${got_length{${single_conn}->fileno}} and $result = ${single_conn}->sysread($line,${lengths{${single_conn}->fileno}} - ${positions{${single_conn}->fileno}}) and not ${got_packet{${single_conn}->fileno}}) {
I suppose you got the idea by now. My honest suggestion would be to
dispose of this whole code and re-start from scratch. Before you do so,
find a consistent coding style that requires less characters (I've
seldom seen a program where the lines are that long throughout the whole
code). Maybe you have a preliminary read of 'perldoc perlstyle' for a
start. Apart from that, pay particular attention to the scoping of your
variables and try to use less of them as well. In other spots, introduce
a few variables where it increases readability. The above
while-condition is such an example. For that you could also write a
function with a descriptive name that returns a booleans value.
Tassilo
--
$_=q#",}])!JAPH!qq(tsuJ[{@"tnirp}3..0}_$;//::niam/s~=)]3[))_$-3(rellac(=_$({
pam{rekcahbus})(rekcah{lrePbus})(lreP{rehtonabus})!JAPH!qq(rehtona{tsuJbus#;
$_=reverse,s+(?<=sub).+q#q!'"qq.\t$&."'!#+sexisexiixesixeseg;y~\n~~dddd;eval
------------------------------
Date: Sun, 28 Mar 2004 10:44:20 -0500
From: Bernie Cosell <bernie@fantasyfarm.com>
Subject: Re: Loss of privledges in a perl app
Message-Id: <7ksd605e85r7gvob9edkq18tv13k8ph6mq@library.airnews.net>
perl coder <perlcdr@mail.rumania> wrote:
} sub drop_privs {
[...]
}
} $) = $gid; # effective gid
} $( = $gid; # real gid
} $> = $uid; # effective uid
} $< = $uid; # real uid
}
} if ($> != $uid || $< != $uid || $) != $gid || $( != $gid) {
} die "Can't drop root privs to UID $uid, GID $gid :(\n";
} }
} }
}
} I read somewhere that it's also necessary to call fork and exit for the
} switch to happen correctly. Why is that?
Dunno - where did you read it? I use code essentially similar to what
you've written above *all* the time and haven't found a need to fork/ext.
/Bernie\
--
Bernie Cosell Fantasy Farm Fibers
bernie@fantasyfarm.com Pearisburg, VA
--> Too many people, too few sheep <--
------------------------------
Date: 6 Apr 2001 21:33:47 GMT (Last modified)
From: Perl-Users-Request@ruby.oce.orst.edu (Perl-Users-Digest Admin)
Subject: Digest Administrivia (Last modified: 6 Apr 01)
Message-Id: <null>
Administrivia:
#The Perl-Users Digest is a retransmission of the USENET newsgroup
#comp.lang.perl.misc. For subscription or unsubscription requests, send
#the single line:
#
# subscribe perl-users
#or:
# unsubscribe perl-users
#
#to almanac@ruby.oce.orst.edu.
NOTE: due to the current flood of worm email banging on ruby, the smtp
server on ruby has been shut off until further notice.
To submit articles to comp.lang.perl.announce, send your article to
clpa@perl.com.
#To request back copies (available for a week or so), send your request
#to almanac@ruby.oce.orst.edu with the command "send perl-users x.y",
#where x is the volume number and y is the issue number.
#For other requests pertaining to the digest, send mail to
#perl-users-request@ruby.oce.orst.edu. Do not waste your time or mine
#sending perl questions to the -request address, I don't have time to
#answer them even if I did know the answer.
------------------------------
End of Perl-Users Digest V10 Issue 6319
***************************************
