| Category: |
Networking Code |
| Author/Contact Info |
zentara of perlmonks |
| Description: |
This is a forking server to handle multiple connections, as well as 1 way root messaging to all connected clients. If you need a bi-directional client for testing, try Gtk2 Interactive Chat client or get the super simple commandline forking client at Simple bi-directional forking commandline client
The code will allow root messages to be sent to all clients (or you can disable this feature by comment changes.) It should also show the way for multi-echoing all text to all clients, if desired. This server is Glib based, an event-loop system, so you can put many other things in the mainloop simply by adding a timer to launch them. This saves the hassle od complex nested while loops. UPDATED Sept 6,2008, added commented code to use Glib::IO instead of Gtk2::Helper; both are available, but Gtk2::Helper is simpler to use. |
#!/usr/bin/perl
use warnings;
use strict;
use Glib;
use Gtk2::Helper; # can use plain Glib instead, see below
use IO::Socket;
$|++;
my @clients; #used for root messaging to all
# a cheap and easy way to prevent zombie children
# when the forked child exits
# avoids the waitpid stuff,otherwise, the defunct
# forked children will wait until the main parent script ends.
$SIG{CHLD} = 'IGNORE';
my $num_of_client = -1;
my $port = 2345;
my $server = new IO::Socket::INET(
Timeout => 7200,
Proto => "tcp",
LocalPort => $port,
Reuse => 1,
Listen => SOMAXCONN
);
print "\n",$server,' ',fileno($server),"\n";
if( ! defined $server){
print "\nERROR: Can't connect to port $port on host: $!\n" ;
exit;
} else{ print "\nServer up and running on $port\n" }
my $main_loop = Glib::MainLoop->new;
# Gtk2::Helper shown for comparison, use either Helper or IO
my $con_watcher = Gtk2::Helper->add_watch ( fileno( $server ),
'in', \&callback, $server );
my $stdin_watcher = Gtk2::Helper->add_watch ( fileno( 'STDIN' ),
'in', \&watch_stdin, 'STDIN' );
# if you just want to use pure Glib, use these instead, and alter the
# removers below
# my $con_watcher = Glib::IO->add_watch ( fileno( $server ),
# 'in', \&callback, $server );
# my $stdin_watcher = Glib::IO->add_watch ( fileno( 'STDIN' ),
# 'in', \&watch_stdin, 'STDIN' );
$main_loop->run;
sub watch_stdin {
# this is line oriented,
# enter as many lines as you want
# and you must press Control-d when
# finished to send
# print "@_\n";
my ($fd, $condition, $fh) = @_;
my (@lines) = (<STDIN>);
print @lines;
foreach my $cli(@clients){
if($cli->connected){
print $cli 'MESSAGE-> ', @lines;
}else{
# remove dead client
@clients = grep { $_ ne $cli } @clients;
+
}
}
#always return TRUE to continue the callback
return 1;
}
sub callback{
my ( $fd, $condition, $fh ) = @_;
print "callback start $fd, $condition, $fh\n";
#this grabs the incoming connections and forks them off
my $client;
do { $client = $server->accept } until ( defined($client) );
print "accepted a client, id = ", ++$num_of_client, "\n";
# going into forked handler
if ( !fork ) {
close($server); #this only closes the copy in the child pro
+cess
Gtk2::Helper->remove_watch( $con_watcher ); #remove server por
+t watch in child
Gtk2::Helper->remove_watch( $stdin_watcher ); #remove STDIN wa
+tch in child
# removers for IO, if used above
# Glib::Source->remove( $con_watcher ); #remove server port watch
+in child
# Glib::Source->remove( $stdin_watcher ); #remove STDIN watch in c
+hild
# add a new watch in the forked client
my $cli_watcher = Glib::IO->add_watch( fileno( $client ),
['in', 'hup','err'], \&cli_callback, $client);
sub cli_callback{
print "\ncli_callback @_\n";
my ( $fd, $condition, $client ) = @_;
# since 'in','hup', and 'err' are not mutually exclusive,
# they can all come in together, so test for hup/err first
if ( $condition >= 'hup' or $condition >= 'err' ) {
# End Of File, Hang UP, or ERRor. that means
# we're finished.
#print "\nhup or err received\n";
#close socket
$client->close;
$client = undef;
# normally return 0 here,
# except we need to exit the fork, down below
# return 0; #stop callback
}
# if the client still exists, get data and return 1 to keep callback a
+live
if ($client) {
if ( $condition >= 'in' ){
# data available for reading
my $bytes = sysread($client,my $data,1024);
if ( defined $data ) {
# do something useful with the text.
print length $data, $data,"\n";
print $client "$data\n"; #echo back
}
}
# the file handle is still open, so return TRUE to
# stay installed and be called again.
# print "still connected\n";
# possibly have a "connection alive" indicator
#print "still alive\n";
return 1;
}
else {
# we're finished with this job. start another one,
# if there are any, and uninstall ourselves.
print "child exiting\n";
#return 0; #exit instead
exit; #since this is forked, we exit
}
}
#end of client callback
}
#end of forked code
else {
#back in parent, save clients for messaging or close them
push @clients, $client; #save clients for root message
# back to parent, close client that's been forked
#print "\nin parent closed forked client $client\n";
#close($client); # this only closes the copy in the parent proces
+s,
# assume the parent no longer need talk to the clie
+nt
}
return 1; # keep the main port watching callback alive
}
__END__
|
|
Re: Glib based forking server with root messaging
by CharlesClarkson (Curate) on Sep 09, 2008 at 10:52 UTC
|
What is your reasoning for the numeric operators in the conditionals instead of string operators (like "ge")? How are you avoiding "Argument isn't numeric in numeric" warnings? Or are you avoiding them?
$condition >= 'hup' or $condition >= 'err'
| [reply]
[d/l] |
|
|
It's some Glib overloading. From muppet's explanation on the Perl/Gtk2 maillist:
> On 25/02/07, muppet <scott@asofyet.org> wrote:
>> Well, TIMTOWDI, of course. :-) But, yes, the ">=" operator, which
+is
>> overloaded for Glib::Flags bitsets to mean the same as "&", which i
+s
>> "are all of the flags listed on the right hand side set in the left
>> hand side?" is how i would write it.
>
> I can see that &, >= and * should be the same for this example.
>
>> The Glib::Flags operators are explained in the "This Is Now That"
>> section of the Glib manpage.
>
> But in the manpage, it implies (to me at least) that there is a
> difference between &, >= and *. Is there difference?
For a boolean test, no. & and >= are implemented differently, but *
and & are the same. The names (and operators) are derived from set
theory, but you can also use any knowledge of binary logic operations
+
from C.
(Warning: potentially redundant but intended-to-be complete
information follows.)
Glib.pm contains this:
package Glib::Flags;
use overload
'bool' => \&bool,
'+' => \&union, '|' => \&union,
'-' => \&sub,
'>=' => \&ge,
'==' => \&eq, 'eq' => \&eq, # eq for is_deeply in
Test::More
'*' => \&intersect, '&' => \&intersect,
'/' => \&xor, '^' => \&xor,
'@{}' => \&as_arrayref,
'""' => sub { "[ @{$_[0]} ]" },
fallback => 1;
Those subs are implemented essentially like this:
bool := NOT NOT a
if any of the bits in a are set, the expression evaluates to TR
+UE
union := a OR b
the result contains all of the bits set in a and b
that is, the result is the union of the two sets.
the | mnemonic is for the C (and Perl) bitwise OR operator.
the + mnemonic is for union of two sets -- you're adding them
together.
sub := a AND NOT b
the result contains all the bits set in a minus the bits that
were also on in b.
this is subtracting the set of b from the set of a.
the - mnemonic is awesome, because "a & ~b" is bizarre looking.
ge := (a AND b) IS b
the result is TRUE if the bits in b are on in a.
other bits may be on in a, but they are ignored (by the AND).
hence, this is true if the set of a is greater than or equal
to the set of b.
eq := a IS b
the result is TRUE iff the same set of bits are on in both.
intersect := a AND b
the result contains all of the bits that are on in both a and b
+.
that is, it returns the intersection of sets a and b.
the & mnemonic is the C (and Perl) bitwise AND operator.
the * mnemonic is for the intersection of two sets.
xor := a XOR b
the result contains all of the bits that are on in either or
both a and b.
the bits that are on in both are not included; this is the
exclusive or of the two sets.
the ^ mnemonic is for the C (and Perl) bitwise XOR operator.
All that said, i think the only ones i have ever used are the >= and
bool operators.
| [reply]
[d/l] |
|
|
