Quote:
> I am attempting to create a server application in Perl that offers a
> simpleeyword-based data access system to be used by a separate,
> Windows-GUI
[snip]
When you said, "Windows/GUI", did you meant a GUI in a window, or a GUI
on the Windows Operating System?
Your code uses a number of outdated and/or unportable programming
constructs.
All of your socket stuff should be replaced with IO::Socket. Direct use
of the functions in Socket.pm is very outdated.
important.
You cannot use the alarm() function on the Windows OS -- it doesn't work
there. Also, on Windows, fork() is emulated using threads and thus has
a fairly high overhead -- much more overhead than there would be if you
multiplexed your sockets using IO::Select.
Even if you're not on windows, it's a good idea to learn to multiplex
with IO::Select.
Consider the following [untested] code:
#!/usr/bin/perl
use strict;
use warnings;
use IO::Socket qw(CRLF);
use IO::Select;
# These are the only global variables.
my ($r, $w) = map IO::Select->new, 1, 2;
my %callbacks;
{
my $listener = IO::Socket::INET->new(
LocalPort => 2323,
Reuse => 1,
Listen => SOMAXCONN,
$r->add($listener);
$callbacks{$listener}{read_callback} = \&do_accept;
}
while( 1 ) {
my $timeout;
if( !$w->count ) {
my $expire;
foreach my $info (values %callbacks) {
my $e = $info->{expire_at} or next;
$expire = $e if !$expire or $e < $expire;
}
$timeout = $expire ? time() - $expire : undef;
$timeout = 0 if defined($timeout) and $timeout < 0;
}
# Yes, $w is passed in, and the corresponding
# arrayref is indeed ignored. This is on purpose;
# it has an effect on how long select() blocks.
(IO::Select->select($r, $w, undef, $timeout))[0]
or die "Error in select: $!";
}) {
$callbacks{$r}{read_callback}->($rrr);
}
for my $ww ($w->can_write(0)) {
$callbacks{$ww}{write_callback}->($ww);
}
my $now = time;
while( my ($sock_stringified, $info) = each %callbacks) ) {
next unless $info->{expire_callback};
$info->{expire_cb}->($sock_stringified);
}
}
# end of main loop.
sub do_accept {
my $listener = shift;
my $newsock = $listener->accept or die "Error in accept: $!\n";
$r->add($newsock);
$callbacks{$newsock} = {
fd => fileno($newsock),
read_callback = \&read_command,
input_buffer = "",
write_callback = \&do_write,
output_buffer = "",
data_id => "",
expire_at => (time() + 10),
expire_callback => \&do_expire,
};
# but don't add $newsock to $w.
}
sub closeit {
warn "Error $action socket: $!\n" if $e;
$_->remove($client) for $r, $w;
delete $callbacks{$client};
}
# ok, here's one more global variable.
my %commands = map { no strict 'refs'; \&{"do_$_"} }
qw(ANNC TIME STATUS QUIT LOGOFF);
sub read_command {
my $client = shift;
my $buffer = \ $callbacks{$client}{input_buffer};
my $n = sysread( $client, $$buffer, 8192, length $$buffer );
$n or return closeit( $client, "reading from", defined $n );
while( $$buffer =~ s/^((?s).*?)$CRLF// ) {
my ($command, $data) = $1 =~ /^(\w*)(.*)/s;
if( my $f = $commands{ uc $command } ) {
$f->($client, $data);
return if $f == \&do_QUIT or $f == \&do_LOGOFF;
} else {
my_print($client, "501 Command not recognized" . CRLF);
}
}
$callbacks{$client}{expire_at} = time() + 10;
}
sub my_print {
$callbacks{$client}{outgoing_buffer} .= $message;
$w->add($client};
}
sub do_write {
my $client = shift;
my $buffer = \ $callbacks{$client}{outgoing_buffer};
local $SIG{PIPE} = 'IGNORE';
my $n = syswrite( $client, $$buffer )
or return closeit($client, "writing to", 1);
substr( $$buffer, 0, $n ) = "";
$w->remove($client) unless length $$buffer;
delete $callbacks{$client} unless $r->exists($client);
}
sub do_ANCC {
my $data_id = \ $callbacks{$client}{data_id};
$args = "" unless defined $args;
if( length($args) and $$data_id eq $args ) {
my_print( $client, "230 $data_id" . CRLF );
return;
}
$$data_id = $args;
my_print( $client, "231 $$data_id" . CRLF );
}
my_print( $client, "." . CRLF );
}
sub do_TIME {
my_print($client, join("|", (localtime)[2,1,0,4,3,5] ) . CRLF );
}
sub do_STATUS {
my_print($client, "220 1|HELLO" . CRLF );
}
sub do_QUIT { closeit( shift(), "", 0 ) }
BEGIN { *do_LOGOFF = \&do_quit }
sub do_expire {
my $callback_key = shift;
warn "Socket timed out\n";
my $fd = $callbacks{$callback_key}{$fd};
$_->remove($fd) for $r, $w;
delete $callbacks{$callback_key};
}
__END__
This is typed off the top of my head, and quite untested. But I think
that you get the idea, and perhaps more important, I think that this
*type* of program should be more understandable than that stuff you'd
had.
For a serious implementation, I would use a min-heap to keep track of
the timeouts. In addition, each warn()ing that I output would include
some info such as the results of gethostbyaddr or inet_aton upon
$client->peeraddr... maybe include $client->peerport, too.
--
$..='(?:(?{local$^C=$^C|'.(1<<$_).'})|)'for+a..4;
$..='(?{print+substr"\n !,$^C,1 if $^C<26})(?!)';
$.=~s'!'haktrsreltanPJ,r coeueh"';BEGIN{${"\cH"}
|=(1<<21)}""=~$.;qw(Just another Perl hacker,\n);
Discerning an Open and Closed Socket...