Initial commit of OpenSPARC T2 design and verification files.

[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / CommandTerm / ProgPty.pm

package CommandTerm::ProgPty;

require 5.004;
use strict;
use Getopt::Long;
use IO::Pty;
use POSIX;

use vars qw(
  @ISA
  $VERSION
  $Verbose
  $PrintFunc
  $AUTOLOAD
);

$VERSION     = '1.00';
$Verbose     = 3;
$PrintFunc   = undef;

sub new {
  my ($class, $progname, @opts) = @_;
  my $this = {};

  bless $this, $class;

  $this->{'read_buf'} = '';
  $this->{'alive'}    = 1;
  $this->{'prompt'}   = 'rivet> ';
  $this->{'response_pending'} = 0;

  if( defined($PrintFunc) ) {
    $this->{'printfunc'} = $PrintFunc;
  } else {
    $| = 1;
    $this->{'printfunc'} = sub { $this->default_print(@_); };
  }

  $this->verbose($Verbose);
  $this->print_status(8, "SETTING VERBOSE LEVEL TO $Verbose\n");

  my $resolved_progname = which($progname);

  unless( $resolved_progname ) {
    $this->print_error(0, "Can't find '$progname', check your path.\n");
    return undef;
  }
  
  my @prog_exec_opts = ($resolved_progname, @opts);

  $this->install_error_handler(\&default_error_handler);
  $this->reset_data_handler;

  $this->{'pty'} = new IO::Pty;
  $this->pty->autoflush(1);

  if( $this->pty->IO::Pty::ttyname ) {
    $this->print_status(8, "OPENED A PTY NAMED '", $this->pty->IO::Pty::ttyname, "'\n");
  } else {
    $this->print_error(0, "Couldn't get a ttyname for IO::Pty. Proceeding anyway\n");
  }

  # Parent
  if( $this->{'pid'} = fork ) {
    $this->{'fileno'} = $this->pty->fileno;
    $this->print_status(8, "FORKED '$prog_exec_opts[0]'\n",
      "  PID    ", $this->pid, "\n",
      "  FILENO ", $this->fileno, "\n");

    # read data until a prompt
    my $response = $this->wait_response;

    return undef unless defined($response);

    # Normal return point
    return $this;

  # Child
  } elsif( defined($this->pid) ) { 
    POSIX::setsid or die;
    my $tty = $this->pty->slave;

    # Below are 6 lines of terminal wizardry turn out to really save the
    # day for this whole module. If you set the terminal correctly, many
    # problems simply disappear and things start working great.  So what do
    # these lines do? Here we go:
    # 
    # 1) The part that says ~(ECHO | ECHOE | ECHOK | ECHONL) turns off all local
    #    echoing. Imagine your sitting at a keyboard and you type the command
    #    "cat -". The cat command reads your keystrokes and echoes them when
    #    you press return.  But notice how you can see what you're typing as
    #    hit the keys. After you hit return, the cat echoes again everything
    #    you just entered and you see what you typed twice. The moral of the
    #    story is that cat relies on the terminal being in "ECHO" mode to allow
    #    the user to see what they're typing as they type it. Now imagine
    #    you're a process writing to the terminal of another process *AND* your
    #    stdin and stdout are tied to the same file handle. If the terminal
    #    were in echo mode, the first thing you'd ever read from the terminal
    #    is the exact thing that you sent to it. By turning off ECHO, we save
    #    ourselves the trouble of removing what we sent from the return data
    #    stream. If you ever looked at the original dc_perl by Steve Golson,
    #    you saw how he went to great effort to remove the first line he got
    #    back.
    #
    # 2) The part that says ~(ICANON) turns off canonical mode processing.
    #    When canonical mode is enabled, the terminal assembles the input
    #    characters into lines and also has a fixed line length. This presents
    #    two problems for Synopsys. The most obvious one is that our line
    #    length is limited by the length of the canonical mode input queue. For
    #    my box (Sun Solaris 2.6) that is 256 characters. The second
    #    reason is a little more esoteric. One of the features of Synopsys
    #    is that it only ties STDOUT back to itself. STDERR is left alone to
    #    allow users to print to it from their Tcl scripts, bypassing
    #    Synopsys. With this setup, if native Synopsys paging were enabled
    #    and activated (a paging command were issued), the terminal would hang.
    #    I don't really have a good explanation of why, but obviously something
    #    in the canonical processing is causing the terminal to hang. Even more
    #    mysterious is the fact that when STDERR is also tied back to
    #    $tty->fileno, the problem goes away, but the user loses the ability to
    #    bypass Synopsys by printing to STDERR. This is not a good trade.
    #   
    #    Well, almost no worries. When you disable canonical mode processing,
    #    the terminal won't deliver data to the reader unless a certain number
    #    of bytes have been received, EVEN if one of those bytes is a newline
    #    (since a newline loses it's meaning in non-canonical mode). Actually,
    #    I'm lying again because non-canonical mode really has 4 modes of
    #    operation and I'm just speaking about two of them. Anyway, on my box
    #    (Solaris 2.6) the default minimum number of bytes to receive before
    #    delivery is 4 (even that's a long story). That's no good. I want
    #    Synosys to read byte if I send a byte. Of course, I can setup the
    #    terminal anyway that I want. So I set the magical VMIN to 1 and the
    #    VTIME to 0 which tells the terminal to deliver a mininum of 1 bytes to
    #    Synopsys every time it tries to read. If nothing is available to read,
    #    the Synopsys will block. I'm assuming that Synopsys was written to
    #    block on a read when nothing is available so that's ok.
    #
    # So life is good. I don't have to re-extract the data I sent. I don't have
    # line length limit.  I can leave STDERR alone and still not care whether
    # the user enables native paging.  Actually, It's still recommended that
    # native paging be disabled because I still see the occasional hiccup that
    # I can't explain.
    my $termios = POSIX::Termios->new;
    $termios->getattr($tty->fileno) or die;
    $termios->setlflag($termios->getlflag & ~(ECHO | ECHOE | ECHOK | ECHONL | ICANON));
    $termios->setcc(VMIN, 1);
    $termios->setcc(VTIME, 0);
    $termios->setattr($tty->fileno, TCSANOW) or die;

    close $this->pty;
    close STDIN;
    close STDOUT; 
    open(STDIN,  "<&" . $tty->fileno) or die "Child Error: Couldn't re-open STDIN:  $!";
    open(STDOUT, ">&" . $tty->fileno) or die "Child Error: Couldn't re-open STDOUT: $!";

    exec(@prog_exec_opts);

  # Error
  } else {
    $this->print_error(0, "FORK FAILED: $!\n");
    return undef;
  }
}

sub DESTROY {}

sub AUTOLOAD {
  my ($this, @opts) = @_;
  my $method         = $AUTOLOAD;

  $method =~ s/.*:://;

  return $this->print_error(1, "$method @opts\n");
}

sub default_error_handler {
  my ($this, $error_type) = @_;

  if( $error_type == 1 ) {
    if( $this->verbose < 3 ) {
      $this->print_error(1, "Error with the command '", 
                         $this->current_command, "'\n\n",
                         $this->output_string);
    }
  } elsif( $error_type == -1 ) {
    $this->print_error(0, "Fatal error, exiting.\n");
    exit;
  }
}

sub perl_list2tcl_list {
  my $this = shift;

  return (not defined($_[0]) or @_ < 1) ? '""' : return "[list @_]";
}

sub get_options {
  my ($this, $argv_ref, $config_ref, @opts) = (@_);

  local (@ARGV) = @$argv_ref;
  Getopt::Long::config(@$config_ref) if @$config_ref > 0;
  my $ret = GetOptions(@opts);
  Getopt::Long::config('default');
  @$argv_ref = @ARGV;
  return $ret;
}

sub alive {
  my $this = shift;

  return $this->{'alive'};
}

sub verbose {
  my ($this, $verbose) = @_;

  my $old_verbose = $this->{'verbose'};

  $this->{'verbose'} = $verbose if defined($verbose);

  return $old_verbose;
}

sub print_data {
  my ($this, $verbose, @what) = @_;        
  
  &{ $this->{'printfunc'} }('data', @what) if $this->verbose >= $verbose;
} 
  
sub print_status {
  my ($this, $verbose, @what) = @_;
  
  &{ $this->{'printfunc'} }('status', @what) if $this->verbose >= $verbose;
} 
  
sub print_error {
  my ($this, $verbose, @what) = @_;
  
  &{ $this->{'printfunc'} }('error', @what) if $this->verbose >= $verbose;
} 
  
sub default_print {
  my ($this, $type, @what) = @_;

  print STDOUT @what;
}

sub reset_data_handler {
  my ($this) = @_;

  $this->{'data_handler'} = undef;
}

sub install_print_handler {
  my ($this, $handler) = @_;

  unless( defined($handler) and ref($handler) eq 'CODE' ) {
    $this->print_error(1, "Argument to install_print_handler must be a CODE ref.\n");
    return;
  }

  $this->{'printfunc'} = $handler;
}

sub install_data_handler {
  my ($this, $handler) = @_;

  unless( defined($handler) and ref($handler) eq 'CODE' ) {
    $this->print_error(1, "Argument to install_data_handler must be a CODE ref.\n");
    return;
  }

  $this->{'data_handler'} = $handler;
}

sub install_error_handler {
  my ($this, $handler) = @_;

  unless( defined($handler) and ref($handler) eq 'CODE' ) {
    $this->print_error(1, "Argument to install_error_handler must be a CODE ref.\n");
    return;
  }

  $this->{'error_handler'} = $handler;
}

sub current_command {
  my $this = shift;

  return $this->{'current_command'};
}

sub output_lines {
  my $this = shift;

  return @{ $this->{'output_lines'} };
}

sub output_lastline {
  my $this = shift;

  return $this->{'output_lastline'};
}

sub output_string {
  my $this = shift;

  return $this->{'output_string'};
}

sub run {
  my ($this, $command, $verbose, $update) = @_;

  unless( defined($command) ) {
    $this->print_error(1, "Argument to run ommitted.\n");
    return undef;
  }

  $this->{'current_command'} = $command 
    unless( defined($update) and $update == 0 );

  my $old_verbose = $this->verbose;

  $this->verbose($verbose) 
    if defined($verbose) and ($this->verbose < 4 or $verbose == 0);

  $this->write_data("$command\n");

  my $retval = $this->wait_response($update);

  # It doesn't hurt to restore, even if we didn't change it.
  $this->verbose($old_verbose);

  return $retval;
}

sub _output_lines {
  my $this = shift;

  return split /\n/, $this->{'current_response'};
}

sub _output_lastline {
  my $this = shift;

  my @output_lines = split /\n/, $this->{'current_response'};
  return $output_lines[ $#output_lines ];
}

sub fileno {
  my $this = shift;

  return $this->{'fileno'};
}

sub pid {
  my $this = shift;

  return $this->{'pid'};
}

sub pty {
  my $this = shift;

  return $this->{'pty'};
}

sub write_data {
  my ($this, $data) = @_;

  return unless defined($data) and length($data) > 0;

  $this->print_status(4,  "$data");
  $this->print_status(8,  "WRITING ", length($data), " BYTES TO PTY\n");
  $this->print_status(10, "WRITE DATA: '", _make_readable($data), "'\n");

  print { $this->pty } $data;
}

sub readable {
  my $this = shift;
  my $fd_set;

  vec($fd_set, $this->fileno, 1) = 1;

  return select($fd_set, undef, undef, 0);
}

sub wait_response {
  my ($this, $update) = @_;

  if( $this->{'response_pending'} == 0 ) {

    $this->{'current_response'} = '';
    $this->{'partial_response'} = '';

    my ($fd_set, $global_fd) = ('', '');

    vec($global_fd, $this->fileno, 1) = 1;

    my $done = 0;

    while( not $done ) {

      $this->print_status(8, "BLOCKING ON SELECT\n");

      my $s = select($fd_set = $global_fd, undef, undef, undef);

      $this->print_status(8, "SELECT RETURNS ", defined($s) ? $s : "UNDEFINED", "\n");

      if( $s < 0 ) { 
        $this->print_error(8, "SELECT ERROR: $!\n");
        &{ $this->{'error_handler'} }($this, 0);
        return 0;
      }

      if( vec($fd_set, $this->fileno, 1) ) {
        $done = $this->read_data;
        return undef unless defined($done);
      }
    }
  }

  $this->print_status(10, "RESPONSE: '", _make_readable($this->{'current_response'}), "'\n");

  $update = 1 unless defined($update);

  if( $update ) {
    $this->{'output_string'}   = $this->{'current_response'};
    $this->{'output_lines'}    = [ split /\n/, $this->{'current_response'} ];
    $this->{'output_lastline'} =
       ${ $this->{'output_lines'} }[ $#{ $this->{'output_lines'} } ];
  }

  $this->{'response_pending'} = 0;

  my $retval = ($this->{'current_response'} =~ /^Error: /m) ? 0 : 1;

  &{ $this->{'error_handler'} }($this, 1) if $retval == 0;

  return $retval;
}

sub read_data {
  my $this = shift;

  $this->print_status(8, "BLOCKING ON SYSREAD\n");

  my $nbytes = 
       sysread($this->pty, $this->{'read_buf'}, 2048, length($this->{'read_buf'}));

  $this->print_status(8, "SYSREAD RETURNS: ", defined($nbytes) ? $nbytes : "UNDEFINED", "\n");

  # Error from sysread
  if( not defined($nbytes) ) {
    # check to see if prog is still alive
    my $pid = waitpid($this->pid, WNOHANG);

    # Normal termination.
    if( $pid = $this->pid ) {
      $this->{'alive'} = 0;
      $this->print_status(8, "WAITPID RETURNS. PID: $pid, NORMAL EXIT STATUS.\n");
      return undef;

    # Still alive!
    } elsif( $pid == 0 ) {
      return 0;

    # Yikes! Unexpected error.
    } else {
      $this->print_error(0, "waitpid on pid($this->{'pid'}) returned $pid: $!.\n");
      $this->{'alive'} = 0;
      &{ $this->{'error_handler'} }($this, -1);
      return undef;
    }

  # EOF from sysread
  } elsif( $nbytes == 0 ) {
    $this->print_status(8, "GOT EOF FROM SYSREAD.\n");
    $this->{'alive'} = 0;
    return undef;

  # Data from sysread
  } else {
    $this->print_status(10, "RAW DATA: '", _make_readable($this->{'read_buf'}), "'\n");

    if( defined($this->{'data_handler'}) ) {
      $this->{'partial_response'} .= $this->{'read_buf'};
      $this->{'partial_response'} =~ s/(\r|\e.{0,2})//mg;
      my @partial_lines = split /\n/, $this->{'partial_response'};
      if( $this->{'partial_response'} =~ /\n$/ ) {
        $this->{'partial_response'} = '';
      } else {
        $this->{'partial_response'} = pop @partial_lines;
      }
      &{ $this->{'data_handler'} }($this, @partial_lines);
    }

    my $before;

    # The data read contains a prompt. Process all the prompts. Multiple prompts
    # will be in the data when the user hits Ctrl-C.
    if( $this->{'read_buf'} =~ /^$this->{'prompt'}/m ) {
      while( $this->{'read_buf'} =~ /^$this->{'prompt'}/m ) {
        $this->print_status(8, "MATCHED\n",
              "BEFORE: '", _make_readable($`), "'\n",
              "PROMPT: '", _make_readable($&), "'\n",
              "AFTER:  '", _make_readable($'), "'\n");
        $this->{'read_buf'} = $';
        $before = $`;
        $before =~ s/(\r|\e.{0,2})//mg;
        $this->print_data(3, $before);
        $this->{'current_response'} .= $before;
      }
      $this->{'response_pending'} = 1;
      return 1;

    # The pager string is in the data. If the termios stuff is functioning 
    # properly, I should be able to send a space to advance the pager.
    } elsif( $this->{'read_buf'} =~ /\e\[7m--More--\e\[m/ ) {
      $this->print_status(8, "MATCHED THE PAGER STRING\n",
            "SENDING A SPACE TO ADVANCE THE PAGER.\n",
            "BEFORE: '", _make_readable($`), "'\n",
            "PROMPT: '", _make_readable($&), "'\n",
            "AFTER:  '", _make_readable($'), "'\n");
      $before = $`;
      $before =~ s/(\r|\e.{0,2})//mg;
      $this->print_data(3, $before);
      $this->{'$current_response'} .= $before;
      $this->write_data(' ');
      $this->{'read_buf'} = '';
      return 0;

    # Multiline command detected - this is by no means full proof.
    # People shouldn't be entering mlc, just return so they don't hang.
    } elsif( $this->{'read_buf'} =~ /^(\? )+/ and $this->{'current_response'} eq '' ) {
      $this->print_status(3, "Multiline command detected.\n");
      $this->{'read_buf'} = '';
      return 1;

    # No prompt, just data.
    } else {
      $this->print_status(9, "NOMATCH\n'", _make_readable($this->{'read_buf'}), "'\n");
      $before = $this->{'read_buf'};
      $before =~ s/(\r|\e.{0,2})//mg;
      $this->print_data(3, $before);
      $this->{'current_response'} .= $before;
      $this->{'read_buf'} = '';
      return 0;
    }
  }
}

# 
# Private local subroutines that aren't methods are below. Only used by this
# module.
#

sub _make_readable {
  local $_ = shift;
  return '' unless defined $_;
  s/\\/\\\\/g;
  s/\n/\\n/g;
  s/\r/\\r/g;
  s/\e/\\e/g;
  s/\t/\\t/g;
  s/\0/\\0/g;
  s/\f/\\f/g;
  s/([\000-\037\177])/'^' . chr(ord($1)^64)/eg;
  s/([\200-\377])/sprintf("\\%3o", ord($1))/eg;
  return $_;
}

sub which {
  my $file = shift;
  my @dirs;

  if( $file =~ m(^/) ) {
    if( -f $file and -x _ ) {
      return $file;
    } else {
      return undef;
    }
  } elsif( $file =~ m(/) ) {
    @dirs = (POSIX::getcwd);
  } else {
    @dirs = (split ':', $ENV{'PATH'});
  }

  foreach my $dir (@dirs) {
    my $path = "$dir/$file";
    return $path if( -f $path and -x _ );
  }

  return undef;
}

1;