tdenetwork/ksirc/puke/puke.pl

use Socket;
use Fcntl;

#
# Clean up if this is the second load.
#
# Don't close anything so we can be loaded twice.
#
#if($PUKEFd != undef){
#  &remsel($PUKEFd);
#  close($PUKEFd);
#  sleep(1);
#  $PUKEFd = undef;
#}

#
# Puke timeout waiting for messages
$PUKE_TIMEOUT = 10;

#
# Setup flag fo syncronous operation
# 1 for sync
# 0 for async/fly by the seat of your pants
#
$SYNC = 0;

#
# Setup debugging logger, comment out for production use
#
$DEBUG = 0;
if($DEBUG){
  open(LOG, ">msg-log") || warn "Failed to open log file: $!\n";
  select(LOG); $| = 1; select(STDOUT);
  print LOG "Start time: ". `date`;
}



# 
# Multi operation level handler, winId Based.
# 
# PUKE_HANDLER{Cmd}{winId} = sub();

%PUKE_HANDLER = ();

# 
# Default handler is called if no handler defined
# Default handlers defined in commands-handler.pl
# Single level PUKE_DEF_HANDLER{$cmd};
#

#%PUKE_DEF_HANDLER = ();

#require 'commands-perl.pl';
&docommand("/load commands-perl.pl");
#require 'commands-handler.pl';
&docommand("/load commands-handler.pl");

$PukeHeader = 42; # Alternating 1010 for 32 bits
$PukePacking = "Iiiiia*";  # 4 ints, followed by any number of of characters
$PukeMSize = length(pack($PukePacking, $PukeHeader, 0, 0, 0, 0, ""));

if(!$ENV{'PUKE_SOCKET'}) {
    $sock = $ENV{'HOME'} . "/.ksirc.socket";
}
else {
    $sock = $ENV{'PUKE_SOCKET'};
}

if($PUKEFd == undef){
    $PUKEFd = &newfh;
    $proto = getprotobyname('tcp');
    socket($PUKEFd, PF_UNIX, SOCK_STREAM, 0) || print "PUKE: Sock failed: $!\n";
    $sun = sockaddr_un($sock);
    print "*P* PUKE: Connecting to $sock\n";
    connect($PUKEFd,$sun) || (die "Puke: Connect failed: $!\n",$PUKEFailed=1);
    select($PUKEFd); $| = 1; select(STDOUT);
    #fcntl($PUKEFd, F_SETFL, O_NONBLOCK);
}

# Arg1: Command
# Arg2: WinId
# Arg3: iArg
# Arg4: cArg
sub PukeSendMessage {
  my($cmd, $winid, $iarg, $carg, $handler, $waitfor) = @_;
  #  print("PUKE: cArg message too long $cArg\n") if(length($carg) > 50);
  $PUKE_HANDLER{$cmd}{$winid} = $handler if $handler != undef;
  my $msg = pack($PukePacking, $PukeHeader, $cmd, $winid, $iarg, length($carg), $carg);
  syswrite($PUKEFd, $msg, length($msg));
  #  print STDERR "*** " . $msg . "\n";
  print LOG kgettimeofday() . " SEND message: CMD: $PUKE_NUM2NAME{$cmd} WIN: $winid IARG: $iarg LEN: " . length($carg) . " CARG: $carg\n" if $DEBUG;
  if($SYNC == 1 || $waitfor == 1){
    return &sel_PukeRecvMessage(1, $winid, -$cmd, $carg);
  }
  return ();
}

sub sel_PukeRecvMessage {
  ($wait, $wait_winid, $wait_cmd, $wait_carg) = @_;
  my($m);
  my($cmd, $winid, $iarg, $carg, $junk);

  while(1){
    my $old_a = $SIG{'alarm'};
    $SIG{'alarm'} = sub { die "alarm\n"; };
    my $old_time = alarm($PUKE_TIMEOUT);
    eval {
      $len = sysread($PUKEFd, $m, $PukeMSize);
    };
    if($@){
       print "*E* Timeout waiting for data for first sysread\n";
       $SIG{ALRM} = $old_a;
       alarm($old_time);
       return;
    }
    $SIG{ALRM} = $old_a;
    alarm($old_time);

    if($len== 0){
      &remsel($PUKEFd);
      close($PUKEFd);
      return;
    }
    #  print "Length: $len " . length($m) . "\n";
    ($header, $cmd, $winid, $iarg, $length, $carg) = unpack($PukePacking, $m);
    if($header != $PukeHeader){
      print("*E* Invalid message received! Discarding! Got: $header wanted: $PukeHeader\n");
      #      return;
    }
    if($length > 0){
      my $old_a = $SIG{'alarm'};
      $SIG{'alarm'} = sub { die "alarm\n"; };
      my $old_time = alarm($PUKE_TIMEOUT);
      eval {
	$clen = sysread($PUKEFd, $m2, $length);
      };
      if($@){
         print "*E* Timeout waiting for cArg data\n";
      }
      $SIG{ALRM} = $old_a;
      alarm($old_time);
      
      if($length != $clen){
        print "\n*E* Warning: wanted to read: $length got $clen\n";
      }
      $m .= $m2;
      ($header, $cmd, $winid, $iarg, $length, $carg) = unpack($PukePacking, $m);
    }
               #    print("PUKE: Got => $PUKE_NUM2NAME{$cmd}/$cmd\n");
               #    print("PUKE: Got: $cmd, $winid, $iarg, $length, $carg\n");
               #    print("\n");
    if($winid == undef){ $winid = 0; }
    $blah = $carg;
    $blah =~ s/\000//g;
    print LOG kgettimeofday() . " GOT  message: CMD: $PUKE_NUM2NAME{$cmd} WIN: $winid IARG: $iarg LEN: $length CARG: $blah\n" if $DEBUG;
    #
    # Check both $cmd and the correct reply -$cmd
    #
    my(%ARG) = ('iCommand' => $cmd,
                'iWinId' => $winid,
                'iArg' => $iarg,
                'cArg' => $carg);

    #  print "*I* Def handler: $PUKE_DEF_HANDLER{$cmd}\n";

    if($wait == 1 && $winid == $wait_winid && $wait_cmd == $cmd){
      print LOG kgettimeofday() . " WAIT message: CMD: $PUKE_NUM2NAME{$cmd} WIN: $winid IARG: $iarg LEN: $length CARG: $blah\n" if $DEBUG;
      ($wait, $wait_winid, $wait_cmd, $wait_carg) = ();
      return %ARG;
    }

    if($PUKE_HANDLER{-$cmd}{$winid}){ # one shot/command handler
      &{$PUKE_HANDLER{-$cmd}{$winid}}(\%ARG);
    } elsif ($PUKE_HANDLER{$cmd}{$winid}){
      &{$PUKE_HANDLER{$cmd}{$winid}}(\%ARG);
    } elsif ($PUKE_W_HANDLER{$cmd}{$winid}) { # widget specific handler
      &{$PUKE_W_HANDLER{$cmd}{$winid}}(\%ARG);
    } elsif ($PUKE_DEF_HANDLER{"$cmd"}) {# catch all
      &{$PUKE_DEF_HANDLER{"$cmd"}}(\%ARG);
    }
    else {
      #
      # If there was no handler this is a widget creation falling throuhg
      #

      if($wait == 1 && (substr($wait_carg,0,7) eq substr($carg,0,7))){
	print LOG kgettimeofday() . " WAI2 message: CMD: $PUKE_NUM2NAME{$cmd} WIN: $winid IARG: $iarg LEN: $length CARG: $blah\n" if $DEBUG;
	($wait, $wait_winid, $wait_cmd, $wait_carg) = ();
        return %ARG;
      }
      # No handler at all, unkown reply
      print("*E* PUKE: Got unkown command: $cmd/$PUKE_NUM2NAME{$cmd}\n");
      #    print("PUKE: Got: $cmd, $winid, $iarg, $carg\n");
    }

    #
    # If we're not waiting for a message, return
    #
    if(!$wait){
      ($wait, $wait_winid, $wait_cmd, $wait_carg) = ();
      return ();
    }
    
    my($rin, $rout) =('', '');
    vec($rin,fileno($PUKEFd),1) = 1;
    $nfound = select($rout=$rin, undef, undef, 1);
    if($nfound < 1){
      print "*E* PUKE: Timed out waiting for reply, returning null\n";
      print LOG kgettimeofday() . " FAIL message: CMD: $PUKE_NUM2NAME{$wait_cmd} WIN: $wait_winid IARG: ### LEN: $length CARG: $wait_carg\n" if $DEBUG;
      return ();
    }
  }
}

&addsel($PUKEFd, "PukeRecvMessage", 0);

# Basics are up and running, now init Puke/Ksirc Interface.

my(%ARG) = &PukeSendMessage($PUKE_SETUP, $::PUKE_CONTROLLER, 0, $server, undef, 1);

$PukeMSize = $ARG{'iArg'};
print "*P* Puke: Initial Setup complete\n";
print "*P* Puke: Communications operational\n";