Phoenix.pm: socket, select & sysread questions

[Scott Walters]

Sorry to bug you folks, but I'm stumped. Normally when I'm completely stuck, I
nuke the offending code and recode it differently. In this case, select() is the
only thing (aside form polling - yuck) that can wait for input on one of several
file handles.

I'm trying to tie two daemons together. This script needs to seriously munge
the output of each for the consuption of the other, but that isn't done yet.
Haven't gotten that far. I'm stuck on the async IO aspect still...

select() should modify it's first arg to only have bits set that correspond
to ready input channels, and I should be able to test that modified arg and find
out weither any given input has data I can read from without blocking.

I've got it set so that if it spends 3 seconds trying to read input, the
alarm goes off, and the $SIG{ALRM} handler gives me a quick line-number
backtrace. At the comment below ending in '!!!', it keeps entering that
routine when it shouldn't. The code works, basicly, but continiously
gets apparently false alerts.

What really gets my goat is that the code is stolen from the man perlfunc
page =P

Polling isn't an option. The CPU is too slow, theres a load of other
stuff running on the machine, it's only got 32 megs ram, and I need
low latency here. Threads might work, but I don't want to have to
learn Perl threads unless I have to or someone is there to hold my
hand ;)

Does anyone see offhand what I'm doing wrong here?

Thanks,
-scott

#!/usr/bin/perl


use Socket;
use Carp qw(confess);

$irchost = 'mesa.az.us.undernet.org';

$|=1;
$SIG{ALRM} = sub { print join "\n", map { (caller($_))[2]; } 0..10; print "\n"; die; };

# mud
socket(MUD, PF_INET, SOCK_STREAM, getprotobyname('tcp'));
connect(MUD, sockaddr_in(2000, inet_aton("weehours.net"))) or die;
select((select(MUD),$|=1)[0]) or die;
print MUD "guest\n";
print MUD "\n";
$bmud = simbuf();
print "debug: filno for MUD: ", fileno(MUD), "\n";

# irc
socket(IRC, PF_INET, SOCK_STREAM, getprotobyname('tcp'));
connect(IRC, sockaddr_in(6660, inet_aton($irchost))) or die;
select((select(IRC),$|=1)[0]) or die;
$rnd=int(rand()*10);
type("USER phaedrus . . phaedrus\@starlight.omega2.com\n");
type("NICK weehours$rnd\n");
$birc = simbuf();
print "debug: filno for IRC: ", fileno(IRC), "\n";

READLOOP: while(1) {
  $rmud=''; vec($rmud,fileno(MUD),1) = 1;
  $rirc=''; vec($rirc,fileno(IRC),1) = 1;
  $rout='';
  vec($rout,fileno(IRC),1) = 1;
  vec($rout,fileno(MUD),1) = 1;

  # this is the select that should be leaving only bits set that correspond to ready inputs
  next READLOOP unless select($rout, undef, undef, undef);

  if($rout&$rirc) { eval {
    # we keep entering this block when we shouldnt, and blocking for input!!!
    alarm 3;
    sysread IRC, $buf, 8192;
    $birc->('write', $buf);
    while($buf = $birc->('read')) {
      $buf = fromirc($buf);
      syswrite MUD, $buf, length($buf) if($buf);
    }
    alarm 0;
  } }

  if($rout&$rmud) { eval {
    alarm 3;
    sysread MUD, $buf, 8192;
    $bmud->('write', $buf);
    while($buf = $bmud->('read')) {
      $buf = frommud($buf);
      syswrite IRC, $buf, length($buf) if($buf);
    } 
    alarm 0;
  } }
}

sub fromirc {
  # filter input from IRC for output to MUD
  my $buf = shift;
  print STDOUT $buf, "\n";
  if($buf =~ m/ 376 /) {
    type("MODE weehours$rnd +i\n");
    type("JOIN #mud\n");
    return '';
  } elsif($buf =~ m/PING :(.+)/) {
    type("PONG $1\n");
    return '';
  }
  #} elsif($buf =~ m/$irchost:(.*)!(.*)PRIVMSG #(.*) :(.*)/o) {
  #  #substitute {:%1!%2PRIVMSG #%4 :%3} {%1 says: %3}
  #  return "$1 says: %3\n";
  #}
  return "say $buf\n";
}

sub frommud {
  my $buf = shift;
  if($buf =~ m/^([A-Z][a-z]+) tells you in common: (.*)/) {
    # return "PRIVMSG #mud :$1 says, $2\n";
print "debug: tell from mud: $2\n";
    return "$2\n";
  }
  return '';
}

sub type ($) {
  my $str = shift; syswrite IRC, $str, length($str); print $str;
}

# this gives us a nice little buffering capability, so we can feed it
# all of the data we get in, and then get only whole lines if a whole line
# is available.

sub simbuf {
  my $buf;
  return sub {
    my $act=shift;
    if($act eq 'read') {
      $buf =~ s/^(.*)\n//; return $1;
    } elsif($act eq 'write') {
      $buf .= shift;
    }
  }
}