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

I recently took on another project to write somewhat of a chat client to teach myself socket programming in perl a little better. However like always I have hit some snags.

I have found a way to implement multiple socket connections it have this working quiet well but the problems are:

1) How do I get my "server" program to broadcast what it reveives to all it's sockets?

The following code is what I have so far in the "server" app. 

#!/usr/bin/perl -w

use strict;
use IO::Socket;
use IO::Select;

$| = 1;   # Make program hot!

my $sock = IO::Socket::INET->new(Proto     => 'tcp',    
                                 LocalAddr => '192.168.0.100',
                                 LocalPort => 7778,
                                 Broadcast => 1,
                                 Blocking  => 0,
                                 Reuse     => 1,
                                 Listen    => 1)
                             or die "Can't bind : $@\n";
my $sel = new IO::Select($sock, undef, undef, 0);

print "Server now listening for connections!\n" if ($sock);

#while ($sock) {
#   if ($sock->recv(my $data, 1024)) {
#      print STDOUT "Input detected is: $data\n";
#      $sock->send($data);
#   }
#}

while(my @queues = $sel->can_read) {
   foreach my $obj (@queues) {
      my $new;
      if($obj == $sock) {
         # Create a new socket
         $new = $sock->accept;
         $sel->add($new);
      }else {
         # Process socket
         if (my $pid = fork()) {
            # parent: close the connection so we can
            # keep listening

            $sel->remove($obj);
            $obj->close();
         }else {
            # child: deal with connection
            while ($obj) {
               #my $recv = $obj->recv(my $data, 1024);
               #if (defined($recv)) {
               if (defined($obj->recv(my $data, 1024))) {
                  last if (($data =~ /^quit/i)||($data eq ""));
                  print STDOUT "Input detected is: $data\n";
                  $obj->send($data);
               }else{
                  last;
               }
            }

            #$obj->send("thanks, goodbye\r\n");

            # finished with the socket
            $sel->remove($obj);
            $obj->close;
         }
      }
   }
}

[download]
2) Now for the client, I have written a simple Tk gui and this also works quiet well for what it is suppose to do so far but I need a way to have it poll for buffered text every second or two and needless to say I cannot implement an endless loop in a gui so I am somewhat confused on how to accomplish this.

Here is the client gui code: 

#!/usr/bin/perl

# The following comments are for perl2exe compilation!

#perl2exe_include Tk;
#perl2exe_include Tk::Text;
#perl2exe_include Tk::Menu;
#perl2exe_include Tk::Photo;
#perl2exe_include Tk::ROText;
#perl2exe_include strict;

use Tk;
use Tk::Text;
use Tk::Menu;
use Tk::Photo;
use Tk::ROText;
use IO::Socket::INET;
use strict;

$| = 1;    # Make buffers hot!

my ($sock);
my $main_title = "pIM v0.3 (Beta Release)";
my $info       = $main_title;
 
my $mw = MainWindow->new();
$mw->minsize(qw(300 500));
$mw->title($main_title);

# Create main application widgets

my $t = $mw->Scrolled("ROText", -scrollbars => 'e', -font => ['Courier
+', 8], -background => 'white')->pack(-pady => 3,
                      -padx => 3, -ipady => 3, -ipadx => 3, -side => '
+top', -fill => 'both', -expand => 1);

my $ts = $mw->Frame->pack(-side => 'top', -fill => 'x');
$mw->Label(-textvariable => \$info, -relief => 'ridge')->
   pack(-side => 'top', -fill => 'x');
my $data = $mw->Scrolled("Text", -scrollbars => 'e', -height => '3', -
+font => ['Courier New', 8], 
                            -background => 'white')->pack(-pady => 3, 
+-padx => 3, -ipady => 3, -ipadx => 3,
                                -side => 'left',-fill => 'none', -expa
+nd => 0);
my $butt = $mw->Button(-text => "Send", -command => \&send)->pack(-pad
+y => 3, -padx => 3, -ipady => 3, -ipadx => 3,
                                -side => 'right',-fill => 'none', -exp
+and => 0);


#####################################################
#Start of menubar creation
my $menubar = $mw->Menu;

my $file_menu = $menubar->cascade(-label => "~File", -tearoff => 0);
$file_menu->command(-label => '~Some Function',
            -command => sub {return});
$file_menu->command(-label => '~Dis-Connect',
            -command => \&disconnect);
$file_menu->command(-label => '~Grab',
            -command => \&grab);

$file_menu->command(-label => '~Exit',
            -command => sub {exit(0)});

my $edit_menu = $menubar->cascade(-label => "~Edit", -tearoff => 0);
$edit_menu->command(-label => '~Some Function',
            -command => sub {return});

my $functions_menu = $menubar->cascade(-label => "~Functions", -tearof
+f => 0);
$functions_menu->command(-label => '~Some Function',    
            -command => sub {return});

my $help_menu = $menubar->cascade(-label => "~Info", -tearoff => 0);
$help_menu->command(-label => '~About',    
            -command => sub {return});

$mw->configure(-menu => $menubar);
#End of menubar creation
#######################################################

my $temp_dir = $ENV{TEMP} || $ENV{TMP} || ($^O eq "MSWin32" ? $ENV{WIN
+DIR} : '/tmp');

######################################################################
+########
# The following code is used to define specific text tags for formatti
+ng.

$t->tagConfigure("blue",   -foreground => "blue");
$t->tagConfigure("red",    -foreground => "red");
$t->tagConfigure("orange", -foreground => "orange");
$t->tagConfigure("brown",  -foreground => "brown");
$t->tagConfigure("grey",   -foreground => "grey");
$t->tagConfigure("green",  -foreground => "forest green");


$t->tagConfigure('bold',       -font => ['Courier New', 8, 'bold']);
$t->tagConfigure('italic',     -font => ['Courier New', 8, 'italic']);
$t->tagConfigure('bg',         -background => 'yellow');
$t->tagConfigure('big_italic', -font => ['Courier New', 18, 'italic'])
+;

######################################################################
+#######
# Some of my own bindings!

#$mw->bind('Tk::Text', '<Control-s>', [\&save_file]);
$mw->bind('Tk::Text', '<Control-a>', sub {$t->tagAdd('sel','1.0','end'
+)});
#$mw->bind('Tk::Text', '<Control-n>', [\&clear_new]);
#$mw->bind('Tk::Text', '<Control-p>', [\&print]);
$mw->bind('Tk::Text', '<Return>', [\&send]);
$mw->bind('Tk::Text', '<Shift-Return>', [sub {$data->insert("end", "\n
+");}]);
$mw->bind('<MouseWheel>' => 
[  sub {$_[0]->yview('scroll', -($_[1] / 120) * 4, 'units');}, Ev('D')
+ ]); 

# Automatically prepends $data to called sub's args
$data->bind('<KeyRelease>', [\&checkKey,Ev('K')]);

######################################################################
+#######

$sock = new IO::Socket::INET->new(PeerPort => '7778',
                                  PeerAddr => '192.168.0.100',
                                  Blocking => 0,
                                  Proto    => 'tcp')
                                 or $t->insert("end", "Can't bind : $@
+\n");
if ($sock) {
   my $paddr = $sock->peerhost();
   my $pport = $sock->peerport();
   $t->insert("end", "Connection to $paddr:$pport successfull...\n\n")
+;
}

MainLoop();

sub disconnect {
   $t->insert("end", "Connection closed\n");
   $sock->close();
   undef $sock;
}

sub checkKey {
   return;
}

sub send {
   chomp(my $text = $data->get("1.0", "end"));
   if ($sock) {
      if ($text ne "") {
         $sock->send($text);
         $t->insert("end", "<YOU>: $text\n");
         $data->delete("1.0", "end");
         grab();
      }
   }else{
      $t->insert("end", "Error: Not connected!\n");
   }
}

sub grab {
   my $stat = $sock->recv(my $incoming, 1024);
   print "stat is $stat\n";
   if ($stat) {
      $t->insert("end", "<USER>: $incoming\n") if ($incoming ne "");
   }
}

[download]
A few last things, is setting $| = 1 neccessary when using non-blocking socket? Also when I try to recv() data from the socket when none is available it locks up the application and I have to break the process to get it to close. This will be a problem if and when I get the app to poll itself if nothing is available at that time.

Thanks for any help..


www.perlskripts.com

Replies are listed 'Best First'.
Re: Two-Part Socket Question.
by pg (Canon) on Aug 31, 2004 at 03:42 UTC
    "Also when I try to recv() data from the socket when none is available it locks up the application"

    I noticed that you don't use IO::Select in your client program. Probably you thought IO::Select is only for multiplexing, thus there is no need to use it in your client program, but that is a misunderstanding.

    If you don't want to block on recv() even when nothing to recv(), then better use IO::Select, and check can_read first.

    Try with the attached scripts, and observe the results:

    Server:

    use IO::Select;
use IO::Socket::INET;

use warnings;
use strict;

my $s = IO::Socket::INET->new(Proto => "tcp", LocalAddr => "localhost"
+, LocalPort => 1234, Listen => 10);
print "waiting...\n";
my $c = $s->accept();
print "connected\n";
while (1) {
    $c->send("abc");
    sleep(3);
}

    [download]

    A client that does not block

    use IO::Select;
use IO::Socket::INET;

use warnings;
use strict;

print "started\n";
my $c = IO::Socket::INET->new(Proto => "tcp", PeerAddr => "localhost",
+ PeerPort => 1234);
print "connected\n";

my $sel = IO::Select->new($c);

my $msg;
my @r;

while (1) {
    if (@r = $sel->can_read(0)) {
        $r[0]->recv($msg, 1024);
        print time() . " $msg" . "\n"
    } else {
        print time() . " one loop\n";
    }
    sleep(1);
}

    [download]

    A client blocks

    use IO::Socket::INET;

use warnings;
use strict;

print "started\n";
my $c = IO::Socket::INET->new(Proto => "tcp", PeerAddr => "localhost",
+ PeerPort => 1234);
print "connected\n";

my $msg;

while (1) {
    $c->recv($msg, 1024);
    print time() . " one loop\n";
}

    [download]
[reply]
[d/l]
[select]
Re: Two-Part Socket Question.
by sgifford (Prior) on Aug 31, 2004 at 03:08 UTC
    1) How do I get my "server" program to broadcast what it reveives to all it's sockets?
    There's no special way to do this; you simply loop through the sockets you have and write it to each one. Of course they may not be ready and your loop would hang, so if you want to write a robust program you'll have to keep a buffer for each client, use select to figure out which ones are writable, and then write as much of their outstanding buffer as you can. If you want better scaling you'll have to use multiple processes or threads.
[reply]
[d/l]
Re: Two-Part Socket Question.
by GreyGlass (Sexton) on Aug 31, 2004 at 04:29 UTC
    Check out Tk::fileevent for selecting readable handles in a Tk loop.
[reply]
[d/l]

      Unfortunately, there is a limitation: fileevent does not work on Windows. Even if we are not talking about Windows, it still hurts portability.

[reply]
Re: Two-Part Socket Question.
by Popcorn Dave (Abbot) on Aug 31, 2004 at 03:31 UTC
    One thing you're probably going to need to look at is the repeat method if you use the TK interface. I'm using it in a stock quote program I'm working on to specify the refresh rate and call the refresh subroutine.

    Hope that helps!

    Useless trivia: In the 2004 Las Vegas phone book there are approximately 28 pages of ads for massage, but almost 200 for lawyers.
[reply]
Re: Two-Part Socket Question.
by Elijah (Hermit) on Aug 31, 2004 at 06:12 UTC
    First off thank you guys. I have gotten soemthing from each of your replys.

    Now I have another interesting issue, although it makes since I cannot figure where to put a portion of my write code to allow proper functionality. 

    #!/usr/bin/perl -w

use strict;
use IO::Socket;
use IO::Select;

$| = 1;   # Make program hot!

my $sock = IO::Socket::INET->new(Proto     => 'tcp',
                                 LocalAddr => '192.168.0.100',
                                 LocalPort => 7778,
                                 Broadcast => 1,
                                 Blocking  => 0,
                                 Reuse     => 1,
                                 Listen    => 1)
                             or die "Can't bind : $@\n";
my $sel = new IO::Select($sock, undef, undef, 0);

print "Server now listening for connections!\n" if ($sock);

while(my @queues = $sel->can_read()) {
   my @canWrite = $sel->can_write();
   foreach my $obj (@queues) {
      my $new;
      if($obj == $sock) {
         # Create a new socket
         $new = $sock->accept;
         $sel->add($new);
      }else {
         # Process socket
         if (my $pid = fork()) {
            # parent: close the connection so we can
            # keep listening

            $sel->remove($obj);
            $obj->close();
         }else {
            # child: deal with connection
            while ($obj) {
               if (defined($obj->recv(my $data, 1024))) {
                  last if (($data =~ /^quit/i) || ($data eq ""));
                  print STDOUT "Input detected is: $data\n";

                  foreach my $target (@canWrite) {
                     $target->send($data) if ($target);;
                  }
               }else{
                  last;
               }
            }

            # finished with the socket
            $sel->remove($obj);
            $obj->close;
         }
      }
   }
}

    [download]
    Now in the above server code each time a new connection comes in it is forked along with current circuit data such as already existing sockets that are both readable and writable. Now every new socket that comes in gets a more and more complete array list of sockets and this list does not match across all connection. For example, I ran this with 4 clients and the first cleint launched can only talk to the server and itself. The second one can talk to the server, first one, and itself. The third one can talk to the server, first, second, and itself. Finally the fourth can talk to the server, first, second, third, and itself.

    I say this makes since because when the first connection comes in the second, third and foruth do not exist yet so the forked process has no way of knowing abou them, Same with the second, third, fourth and so-on.

    How can I logically setup this code to keep an updated list of socket conenction on all forked children?


    www.perlskripts.com
[reply]
[d/l]

      There's not a straightforward way to do that. File descriptors are shared between parent and child, but not between siblings, so even if two sibling processes knew the file descriptor number they wouldn't be able to write to it.

      The way that's closest to what you want is probably the most complicated way. If each parent and child maintain a socket between them, the parent can send new file descriptors to all children with ioctl.

      A more straightforward way to handle it would be to have the parent process act as a central point for distributing information; it receives messages from each client over a pipe/socket, then writes them out to all of the other clients.

      Another possibility is to write messages that should be sent into a shared memory segment, created with mmap or shmget.

      Yet another possibility is to create threads instead of processes, since all threads in a process share file descriptors (though you should probably use locking to make sure writes to file descriptors don't get intermingled).

[reply]
[d/l]
[select]
      "I say this makes since because when the first connection comes in the second, third and foruth do not exist yet so the forked process has no way of knowing abou them, Same with the second, third, fourth and so-on. How can I logically setup this code to keep an updated list of socket conenction on all forked children? "

      It gets pretty hard to do this in a forking server model. I use the Net::EasyTCP module for this, but it dosn't use a forked model. The basic idea is to save your client objects in a hash, like this PSEUDOCODE: 

      my $new;
my $counter = 0;
my %clients;

      if($obj == $sock) {
         # Create a new socket
         $new = $sock->accept;
         $sel->add($new);
$counter++
$clients{$counter}{'obj'} = $obj;
$clients{$counter}{'ip'} = $obj->remoteip;
#or whatever identifiers you can get

      [download]

      Now you have to figure out how to get that hash data to all your forked processes. You can either you pipes or sockets for the interprocess communication. It's more complicated than I can code of the top of my head.

      The other option is to use a threaded server model, which has been done nicely at this node: Re: Re: ChatServer

      In threads, you can use the cond_broadcast to communicate between threads.

      I'm not really a human, but I play one on earth. flash japh
[reply]
[d/l]

Back to Seekers of Perl Wisdom