
package UPenn::ISC::AccountMgmt::Test;
my $PTSNAME = "/home/m/j/mjd/src/apps/accountmgmt/ptsname";
my $SHOWMODULES = "/home/m/j/mjd/src/apps/accountmgmt/show_modules";

use POSIX 'setsid';
use Carp;

sub DESTROY {
  my $self = shift;
  if ($$ == $self->{parent}) {
    kill 1 => $self->{child};
  }
}

sub run {
  my ($class, $command, @args) = @_;
  croak "Usage: $class->run(command, args...)" unless defined $command;

  my $pty = _allocate_pty() or return;
  my $tty = _ttyname($pty) or return;

  my $pid = fork();
  return unless defined $pid;
  if ($pid) {                   # parent
    { my $ofh = select $pty;
      $|=1;
      select $ofh;
    }
    return bless { parent => $$, child => $pid, pty => $pty } => $class;
  } else {
    close $pty;
    setsid();
    open STDIN, "+<", $tty or die $!;
    open STDOUT, "+>", $tty or die $!;
    open STDERR, "+>", $tty or die $!;
    pushstr(\*STDIN) or return;
    exec $command, @args;
    die "exec: $!";
  }
}

# Push terminal semantics STREAMS modules onto each specified filehandle
sub pushstr {
  my $I_PUSH = (ord('S') << 8) | 02; # Incredibly nonportable
  for (@_) {
    ioctl($_, $I_PUSH, my $s = "ptem") or return;
    ioctl($_, $I_PUSH, my $t = "ldterm") or return;
  }
  _show_modules($_[0]);
  return 1;
}

sub _show_modules {
  return 1;
  my $fh = shift;
  my $fd = fileno($fh);
  my $old = _close_on_exec($fh, 0);
  system($SHOWMODULES, $fd, "/dev/pts/4");
  _close_on_exec($fh, $old);
}

sub _ttyname {
  my $pty = shift;
  my $fileno = fileno($pty);
  my $old = _close_on_exec($pty, 0);
  chomp(my $result = qx{ $PTSNAME $fileno });
  _close_on_exec($pty, $old);
  $result;
}

sub _allocate_pty {
  my $ptydev = shift || "/dev/ptmx";
  open my($pty), "+<", $ptydev or return;
  return $pty;
}

sub get {
  my $self = shift;
  return if $self->{read_eof};

  my %opts = @_;
  $opts{blocksize} ||= 8192;

  return unless $self->select("read", timeout => $opts{timeout});

  my $br = sysread $self->{pty}, my($buf), 8192;
  return unless defined $br;
  $self->{read_eof} = 1 if $br == 0;

  if (exists $self->{buf}) {
    $buf = delete($self->{buf}) . $buf;
    if ($opts{blocksize}) {
      my $result = substr($buf, 0, $opts{blocksize}, "");
      $self->{buf} = $buf;
      $buf = $result;
    }
  }

  $buf =~ s/\r\n/\n/g;
  return $buf;
}

sub getline {
  my $self = shift;
  while (1) {
    if (exists $self->{buf} && (my $pos = index($self->{buf}, $/)) >= 0) {
      return substr($self->{buf}, 0, $pos+length($/), "");
    }
    $self->{buf} = "" unless exists $self->{buf};

    my $block = $self->get;
    return unless defined $block;
    return delete $self->{buf} if $block eq "";
    $self->{buf} .= $block;
  }
}

sub put {
  my $self = shift;
  croak "Already send EOF signal to command" if $self->{sent_eof};

  my $buf = shift;
  my %opts = @_;
  my $off = 0;
  my $length = length($buf);

  while ($length) {
    return unless $self->select("write", timeout => $opts{timeout});
    my $bw = syswrite $self->{pty}, $buf, $length, $off;
    return unless defined $bw;
    $off += $bw;
    $length -= $bw;
  }
  return $off;
}

sub select {
  my ($self, $dir, %opts) = @_;
  my $bits = "";
  vec($bits, fileno($self->{pty}), 1) = 1;

  my $rdvec = $dir eq "read" ? $bits : "";
  my $wrvec = $dir eq "write" ? $bits : "";

  my $ready = select $rdvec, $wrvec, undef, $opts{timeout};
  return if $ready < 0;
  return $ready;
}

sub in_out {
  my ($in, $out, $prefix) = @_;
  my ($vin, $vout) = ("", "");
  vec($vin, fileno($in), 1) = 1;
  vec($vout, fileno($out), 1) = 1;
  while (1) {
    my ($oin, $oout) = ($vin, $vout);
    my $nready = select($oin, $oout, undef, 1);
    warn "$prefix: nready = $nready\n";
    if ($nready < 0) {
      die "select: $!";
    }
    unless ($nready) {
      sleep 1;
      redo;
    }
    if (vec($oin, fileno($in), 1)) {
      my $br = sysread $in, my($buf), 8192;
      if (! defined $br) {
        die "$prefix: Read error: $!\n";
      } elsif ($br == 0) {
        print "$prefix: <<EOF>>\n";
        exit;
      } else {
        warn "$prefix: read $br bytes\n";
        for (split /^/, $buf) {
          print "$prefix: $_";
        }
      }
    }
    if (vec($oout, fileno($out), 1)) {
      ++$N;
      warn "$prefix: writing message $N\n";
      print $out scalar(localtime), ": ", $N, "\n";
      print STDERR "*";
    }
    if ($N == 3) {
      warn "$prefix: closing output\n";
      $vout = "";
      send_eof($out);
      undef $N;
    }
  }
}

sub send_eof {
  my $self = shift;
  return if $self->{sent_eof};
  my $fh = $self->{pty};
  $self->{sent_eof} = (syswrite($fh, "") == 0);
}

sub _close_on_exec {
  my ($fh, $val) = @_;
  my $buf;
  my $old;
  use Fcntl 'F_GETFD', 'F_SETFD', 'FD_CLOEXEC';
  unless (fcntl $fh, F_GETFD, $buf) {
    die "Couldn't get  flags for handle: $!; aborting";
  }

  { my $bufval = unpack "I", $buf;
#    warn "buf: $bufval\n";
    $old = $bufval & FD_CLOEXEC;
    if ($val) {
      $bufval |=   FD_CLOEXEC;
    } else {
      $bufval &= ~ FD_CLOEXEC;
    }
#    warn "buf: $bufval\n";
    $buf = pack "I", $bufval;
  }

  unless (fcntl $fh, F_SETFD, $buf) {
    my $clear = $val ? "set" : "clear";
    die "Couldn't $clear close-on-exec flag for ptmx: $!; aborting";
  }
  return $old;
}

1;
