Beefy Boxes and Bandwidth Generously Provided by pair Networks
go ahead... be a heretic
 
PerlMonks  

IO:Socket question... sort of :)

by marcs (Acolyte)
on Aug 25, 2003 at 10:15 UTC ( #286340=perlquestion: print w/replies, xml ) Need Help??

marcs has asked for the wisdom of the Perl Monks concerning the following question:

Hi all, I am trying to write a TCP server in perl, and currently have one working except for the fact that it only seems to be able to handle one connection at a time... can anyone point me in the right direction if it needs to deal with more than one connection at a time?? Code below:

#!/usr/bin/perl -wT use strict; use IO::Socket; use POSIX qw(setsid); use vars qw( $pid $server $client $read_tmp @numbers $number $msg $dat +e $cnt ); umask 0177; $| = 1; # Do not allow this server to be run as root. if( $< != 0 ) { die "You must run this as root.\n"; } $pid = fork(); if( $pid ) { exit; } else { setsid or die "Could not start new session.\n"; $server = IO::Socket::INET->new( Type => SOCK_STREAM, LocalPort => "5001", Proto => "tcp", Reuse => "1", Listen => "20", Blocking => "0" ) or die "Could not bind to port 5001.\n"; #print "Daemon now running in the background using PID [" . $$ + . "].\n"; write_pid(); $cnt = 0; } while( $client = $server->accept() ) { $client->autoflush(1); while( defined( $client->recv( $read_tmp, 1024 ) ) ) { chomp $read_tmp; # Check the data we're being given for malicious char +acters. if( $read_tmp =~ /quit/ ) { server_exit( "501 Exiting normally." ); } if( $read_tmp =~ /^send ([0-9,]+) (.+)$/i ) { @numbers = split( ",", $1 ); $msg = $2; foreach $number ( @numbers ) { # Get the epoch... $date = time; # Increment the counter... $cnt++; open( SMS, "> /var/spool/sms/OTHER/sms +.$date.$cnt" ) || die "Couldn't open SMS file: $!\n"; print SMS << "end"; To: $number $msg end close( SMS ); } print $client "Message sent.\n"; } else { server_exit( "504 Invalid characters used in s +erver query." ); } } } sub server_exit { my( $errmsg ) = @_; if( defined( $msg ) && defined( $client ) ) { print $client "$errmsg\n"; } close( $client ); } sub write_pid { my( $pid ) = $$; open( PID, "> /var/run/sms_server.pid" ) || die "Could not ope +n PIDFILE.\n"; print PID $$ . "\n"; close( PID ); }

Any help would be appreciated. Thanks, Marc

edited by ybiC: Balanced <readmore> tags around code for frontpaged node

Replies are listed 'Best First'.
Re: IO:Socket question... sort of :)
by castaway (Parson) on Aug 25, 2003 at 11:15 UTC
    Try looking at IO::Select. What you need to do is create an IO::Select object, add your server and each new client to it, and call can_read() in your main while loop, which returns all handles which are currently readable/contain new data. You can then check if it's a client or server handle, and act accordingly.

    There's an example in the IO::Select docs, if you need help with it, just ask.

    C.

Re: IO:Socket question... sort of :)
by Preceptor (Deacon) on Aug 25, 2003 at 13:13 UTC
    I would recommend avoiding fork() in this context it's (IMHO) ugly. The better way to do it would be using IO::Select and asynchronous IO.

    In this way you get a program that's pretty straightforward For example:

    Edit: Minor rejig to do a blocking accept() if there's no open sockets.
    #!/bin/perl use strict; use warnings; use IO::Select; use IO::Socket; #initialise our socket my $listener = IO::Socket::INET -> new( LocalPort => 5001, Proto => "tcp", Reuse => 1, Listen => 20, Blocking => 0, ); $listener -> autoflush(1); #create our 'select' groups my $listen_select = new IO::Select( $listener ); my $sockets = new IO::Select ( ); #A timeout of 0 can be workable, but is inefficient unless #you have _lots_ of IO my $timeout = 1; #seconds; while () { if ( $sockets -> count ) { #check for an incoming socket. Could probably merge #the two can_read statements. if ( $listen_select -> can_read($timeout) ) { my $client; my $raddr = accept($client, $listener); $sockets -> add ( $client ); $client -> autoflush(1); $timeout = 0; print "Connection accepted from ", print unpack ( "C*", $raddr ) +, "\n"; } my @ready = $sockets -> can_read($timeout); #if any socket has pending data, read it and act on it. foreach my $handle ( @ready ) { my $read_tmp = <$handle>; if ( !defined ( $read_tmp ) ) { print "Filehandle closed.\n"; $sockets -> remove ( $handle ); $handle -> close; } else { #do processing here. #imagine doing something good with read_tmp print "Got data: $read_tmp\n"; #and sending something cool to the client print $handle "Fwatoom\n"; } } } #if count else { #we have no handles in our thingy, so we sit idle waiting for #a connection. print "No pending data. Idling for connect()\n"; my $client; my $raddr = accept($client, $listener); $sockets -> add ( $client ); $client -> autoflush(1); $timeout = 0; print "Connection accepted from ", print unpack ( "C*", $raddr ), +"\n"; } }
Re: IO:Socket question... sort of :)
by Ryszard (Priest) on Aug 25, 2003 at 11:29 UTC
    Have you seen Net::Server ? Its got a bit of a learning curve, however when you get past that, i've found it to be quite a good module to use for my tcp server stuff.
Re: IO:Socket question... sort of :)
by halley (Prior) on Aug 25, 2003 at 13:19 UTC
    Holy misleading comments, Batman!
    # Do not allow this server to be run as root. if( $< != 0 ) { die "You must run this as root.\n"; }

    --
    [ e d @ h a l l e y . c c ]

      Ooops... the code changed slightly while I was busy and I forgot to change this. Thank you to everyone for pointing me in the right direction... I've hacked something together with Net::Server now and it's working great. Thanks again.
Re: IO:Socket question... sort of :)
by bart (Canon) on Aug 25, 2003 at 12:02 UTC
    If you're puzzled by this, you're not ready to stand on your own two feet. Just this one pointer: Lincoln Stein's excellent book Network Programming with Perl. It deals with this and related problems in several manners, see all of part 3.

    Oh, and the technical answer is: fork, or multiplex. The server needs to be able to accept new connections while a converstation is going on.

Re: IO:Socket question... sort of :)
by prostoalex (Scribe) on Aug 25, 2003 at 20:38 UTC
    I wrote a TCP server once and struggled with exactly the same problem. Depending on whether you need to support multiple connections simultaneously or not, there are two options:
  • Use IO::Select for non-blocking IO and multiple clients connected simultaneously.
  • Kill the client connection as soon as message is passed.

    There is some happy horseshit to jump around if you implement either one of those methods, like calling fcntl to enforce the non-blocking IO on the operating system level. The examples from Network Programming in Perl are pretty good, I think this book was recommended above.

Re: IO:Socket question... sort of :)
by djbiv (Scribe) on Aug 25, 2003 at 16:37 UTC
    my 2 cents... (This is a snippet of code from a Server using IO::Socket, all of the code is not there but this is the main server portion..... take it for what you like...
    my ($acceptSock, $pid, $apprCode, $bufHdr, $buf, $length, $hdr, $req); my ($p1, $rsp, $rspMsg, $rspHdr, $msg); while (1) { printf("%sListening on port $args{p}\n", prHdr()); if (!($acceptSock = $listenSock->accept())) { print "bkpt 1: Accept failed: $!\n" if ($debug > 2); next; } # Spawn off a child to handle this connection $pid = fork(); die "Cannot fork: $!" unless defined($pid); # PID is zero when we're the child if($pid) { print "Parent continues\n" if ($debug > 2); next; } printf("%sAccepted connection from: %s\n", prHdr(), $acceptSock->pee +rhost()); srand(time); $apprCode = sprintf("%06d", int(rand 99999)+1); # Wait indefinitely for a message while (1) { print "Error reading 2-byte header: $!\n", last if (sysread($acceptSock, $bufHdr, 2) != 2); printf("%sReceiving request\n", prHdr()); # We got the 2-byte (data length) header $length = unpack("n", $bufHdr); print "$$: Length from request header = $length\n" if($debug > 2); print "Error length ($length) is < e-Header size ($EHDR_SIZE)\n", +last if ($length < $EHDR_SIZE); print "Error reading $length bytes of data: $!\n", last if (sysread($acceptSock, $buf, $length-2) != $length-2); if($debug > 1) { # Got the data, display it &hexDump($bufHdr . $buf); print "\n"; } }
Re: IO:Socket question... sort of :)
by Fletch (Chancellor) on Aug 25, 2003 at 14:23 UTC

    Not really a direct answer, but consider using POE (wiki).

Re: IO:Socket question... sort of :)
by welchavw (Pilgrim) on Aug 25, 2003 at 17:48 UTC

    There are obviously multiple ways to design a solution to your problem. I would suggest viewing multiple code snippets using the "Super Search" functionality of this website and borrowing outrageously from your favorite(s). I tried a mundane search of ("tcp" "multiple" "server") and found lots of potentials.

    I doubt that performance is an overriding concern for your purposes, but benchmarking others' code would also lend insights into the optimal approach for your architecture (perldoc benchmark).

Re: IO:Socket question... sort of :)
by Abigail-II (Bishop) on Aug 25, 2003 at 10:32 UTC
    Just print to the socket. Here's an example:
    #!/usr/bin/perl use strict; use warnings; use IO::Socket; my $sock = IO::Socket::INET -> new (LocalAddr => "localhost:5000", Listen => 5) or die $!; while (my $child = $sock -> accept ()) { my $line = <$child>; print $child "You send: $line"; close $child; } __END__

    Start it, and from another window:

    $ telnet localhost 5000 Trying 127.0.0.1... Connected to localhost. Escape character is '^]'. Hello! You send: Hello! Connection closed by foreign host. $

    Abigail

      I think you missed the point of the question entirely there. It was 'how to deal with multiple simultaneous connections', (as far as I understood it, anyways..)

      C.

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://286340]
Approved by Corion
Front-paged by Preceptor
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others pondering the Monastery: (2)
As of 2021-05-07 03:57 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Perl 7 will be out ...





    Results (85 votes). Check out past polls.

    Notices?