Prologix USB - Ethernet emulator

gistfile1.pl

#!/usr/bin/perl
use strict;
use warnings;

use IO::Async::Loop;
use IO::Async::Stream;
use IO::Async::Socket;
use IO::Async::Listener;
use IO::Socket::INET;
use Socket;

my $loop = IO::Async::Loop->new;

my $discovery_socket = IO::Socket::INET->new(
  Proto => 'udp',
  LocalAddr => '0.0.0.0',
  LocalPort => 3040,
) or die "Can't bind udp/3040: $!";

my $discovery_io = IO::Async::Socket->new(
  handle => $discovery_socket,
  on_recv => sub {
    my ($self, $dgram, $addr) = @_;
    my ($err, $hostname, $portname) = Socket::getnameinfo($addr);
    my (undef, undef, $seq) = unpack "ccna6xx", $dgram;
    print "Received identify with seq $seq from $hostname/$portname\n";
    my $header = pack "ccna6xx",
      0x5a, # magic
      1, # identify reply
      $seq,
      "\x00\x24\x1d\x8b\x0e\x50";
    my $identify = pack "nccccccC4C4C4a4a4a4a32",
      1, 1, 1, 1, # uptime
      1, # mode
      0, # alert
      4, # ip type
      192, 168, 1, 3, # ip addr
      255, 255, 255, 0, # netmask
      192, 168, 1, 1, # gateway
      "\x01\x02\x03\x04", # app ver
      "\x01\x02\x03\x04", # boot ver
      "\x01\x02\x03\x04", # app ver
      "PL ETH/USB"; # name

    send $discovery_socket, $header . $identify, 0, $addr;
  },
  on_recv_error => sub {
    my ($self, $errno) = @_;
    die "recv error $errno on discovery";
  }
);

$loop->add($discovery_io);

my @clients;

open my $prologix, '+<', '/dev/ttyUSB0' or die "$! opening GPIB";
my $prologix_io = IO::Async::Stream->new(
  handle => $prologix,
  on_read => sub {
    my ($self, $buff) = @_;
    while ($$buff =~ s/(^.*\n)//) {
      my $line = $1;
      for my $client (@clients) {
        $client->write($line);
      }
      print ">> $line";
    }
  }
);

$loop->add($prologix_io);

my $listener = IO::Async::Listener->new(
  on_stream => sub {
    my ($self, $stream) = @_;
    $stream->configure(
      on_read => sub {
        my ($self, $buff) = @_;
        while ($$buff =~ s/(^.*\n)//) {
          my $line = $1;
          $prologix_io->write($line);
          print "<< $line";
        }
      },
      on_read_eof => sub {
        my ($self) = @_;
        @clients = grep { $_ != $self } @clients;
      },
    );
    push @clients, $stream;
    $loop->add($stream);
  },
);

$loop->add($listener);

my $listen_socket = IO::Socket::INET->new(
  Proto => 'tcp',
  LocalPort => 1234,
  LocalAddr => "0.0.0.0",
  Listen => 3,
  ReuseAddr => 1,
) or die "$! listening for TCP conns";

$listener->listen(
  handle => $listen_socket,
);

$loop->run;