Re: Tk & Socket: Tk::Error: fileno not same for read X and write Y

This is the same program as above, but without Tk, and therefore implementing it's own select() loop and triggers to call the events.

I wrote this in Redhat Linux 9, but it appears to runs fine even under Windows ... no blocking! Start up the script, and then in a few other windows, "telnet localhost 40000".

Isn't using filevent under Tk essentially the same thing as what this script does?

#!/usr/bin/perl

use strict;
use IO::Socket;

my $clients = {};
my ($last_time);

# Setup server socket
my $server = IO::Socket::INET->new (
    LocalPort => 40000,
    Type            => SOCK_STREAM,
    Reuse            => 1,
    Listen        => 10) 
    or die "Couldn't be a tcp server on port 40000: $@\n";

my ($readbits, $writebits, $execbits);
vec ($readbits, $server->fileno(), 1) = 1;


while (1) {
    my ($rout, $wout, $eout, $timeout);
    $timeout = 1;
    select( $rout=$readbits,
          $wout=$writebits,
                    $eout=$execbits,
                    $timeout);
    my $nowtime = time;


    # check if server socket readable (new client)
    if (vec ($rout, $server->fileno(), 1) == 1) {
        server_read();
    };

    # check for client activity
    foreach my $socket_no (keys %{$clients}) {
        if (vec ($rout, $socket_no, 1) == 1) {    
            print "calling client_read for $socket_no\n";
            client_read ($socket_no);
        };
        if (vec ($wout, $socket_no, 1) == 1) {
            print "calling client_write for $socket_no\n";
            client_write ($socket_no);
        };
    };

    # do 1 sec activity
    if ($nowtime != $last_time) {
        event_tick();
        $last_time = $nowtime;
    };

    print ($nowtime % 2 ? "tick ...\n" : "tock ...\n");

};



sub server_read {
    
    # get new client
    my $new_client = $server->accept ();
    my $socket_no  = $new_client->fileno();

    print "Got new client #" . $socket_no . "\n";
    $clients->{$socket_no} = {
        -socket => $new_client,
        -buffer    => ''
    };

    # trigger on any read events (usually client disconnecting)
    vec ($readbits, $new_client->fileno(), 1) = 1;
};
    

sub client_read {
    my ($socket_no) = @_;
    my ($buf, $len);

    my $client= $clients->{$socket_no}->{-socket};

    $len = $client->sysread ($buf, 1024);
    print "Read $len bytes from client $socket_no\n";

    if ($len == 0) {

        # client has disconnected
        print "client $socket_no has disconnected\n";
        vec ($readbits, $socket_no, 1) = 0;
        vec ($writebits, $socket_no, 1) = 0;
        delete ($clients->{$socket_no});
        $client->close();

    } else {
        print "received [$buf] from client\n";
    };

};


sub event_tick {
    my $time = time;
    my $localtime = scalar (localtime($time)) . "\n";

    # write to all the clients
    foreach my $socket_no (keys %$clients) {
        print "adding to buffer for client $socket_no\n";
        my $client = $clients->{$socket_no}->{-socket};
        $clients->{$socket_no}->{-buffer} .= $localtime;
        vec ($writebits, $client->fileno(), 1) = 1;
    };
};


sub client_write {
    my ($socket_no) = @_;
    my ($len);

    print "client $socket_no is writable!\n";
    my $client = $clients->{$socket_no}->{-socket};

    $len = $client->syswrite ($clients->{$socket_no}->{-buffer});
    print "wrote $len bytes to client $socket_no\n";

    if ($len == 0) {
        # buffer emptied
        print "buffer for $socket_no emptied\n";
        $clients->{$socket_no}->{-buffer} = '';
        vec ($writebits, $socket_no, 1) = 0;
    } else {
        # buffer partially emptied
        $clients->{$socket_no}->{-buffer} = substr ( 
            $clients->{$socket_no}->{-buffer}, $len);
    };

};
[download]

Comment on Re: Tk & Socket: Tk::Error: fileno not same for read X and write Y Download Code