view release on metacpan or  search on metacpan

lib/GTM/Run.pm  view on Meta::CPAN

=head1 NAME

GTM::Run - run interactive processes 

=head1 SYNOPSIS

   use GTM::Run;

   my $hdl = new GTM::Run ("mumps -direct");
   $hdl->expect(
        qr/GTM\>/,
        qr/^%.*/m,
        sub {
            die $_[1] if $_[2];
            shift->write ("D ^\%GO\n");
        }
   );

=head1 DESCRIPTION

This module is a helper-module for running interactive
processes in a "expect"-like way.

=head1 METHODS

=over 4

=cut

package GTM::Run;
use common::sense;
use AnyEvent;
use AnyEvent::Util;
use AnyEvent::Handle;
use POSIX qw(setsid dup2 _exit waitpid);
use re 'eval';
use GTM qw(set_busy output %override);

our $VERSION = $GTM::VERSION;
our $midx;

=item $handle = B<new> GTM::Run ($command)

Creates a GTM::Run object.
The $command is either a single string, which is then passed to a shell, or an arrayref,
which is passed to the "execvp" function.
If command is not a fully qualified command (ie: starts not with /) $ENV{gtm_dist} will be prepended.

=cut 

sub new {
    my ($class, $cmd) = @_;
    my $self = bless {@_}, $class;
    if (ref $cmd eq "ARRAY") {
        $cmd->[0] = "$ENV{gtm_dist}/$cmd->[0]" unless $cmd->[0] =~ m@^/@;
    } else {
        $cmd = "$ENV{gtm_dist}/$cmd" unless $cmd =~ m@^/@;
    }

    my ($fh1, $fh2) = portable_socketpair;
    my $pid = fork;
    if (!defined $pid) {
        die "can't fork: $!";
    }
    if (!$pid) {
        setsid;
        close $fh2;
        dup2 (fileno $fh1, 0);
        dup2 (fileno $fh1, 1);
        dup2 (fileno $fh1, 2);
        close $fh1;
        local %ENV = (%ENV, %override);
        ref $cmd
          ? exec {$cmd->[0]} @$cmd
          : exec $cmd;

        _exit (99);
    }
    my $hdl = new AnyEvent::Handle (
        fh       => $fh2,
        no_delay => 1,
        on_error => sub {
            my ($hdl, $fatal, $msg) = @_;
            die "on_error fatal=$fatal msg=\"$msg\"\n";
            $hdl->destroy;
        },

    );
    $self->{pid} = $pid;
    $self->{hdl} = $hdl;
    set_busy (1);
    $self;
}

sub merge_regexp (@) {
    my @re = @_;
    @re = map { qr{(?:$_(?{$GTM::Run::midx= mArK;}))}x } @re;
    my $r = join "|", @re;
    $r =~ s/mArK/$_/ for (0 .. @re - 1);
    $r;
}

=item $handle->B<close> ()

Closes the command. This runs waitpid so be sure that your command will terminate.
For mumps this means that "Halt\n" must be written before.

=cut

sub close ($) {
    my $self = shift;
    my $hdl  = $self->{hdl};
    die "already closed" if $self->{closed};
    $hdl->on_eof   (undef);
    $hdl->on_error (sub { });
    $hdl->on_read  (sub { });
    $self->flush;
    $hdl->destroy;
    waitpid ($self->{pid}, 0) if kill (0, $self->{pid});
    set_busy (0);
    $self->{closed} = 1;

}

=item $handle->B<write> ($data, ...)

writes $data to the process

=cut

sub write ($@) {
    my $self = shift;
    my $hdl  = $self->{hdl};
    $hdl->push_write (join "", @_);
}

our $expect_debug = 0;

=item $handle->B<debug> ($bool)

writes regular expression debug-info to STDERR if enabled.
Here an example:

    $self->expect(
        qr/^No globals selected/m,
        qr/^Header Label:/m,
        sub {
           ...
        },
   );

This writes:

  RE: (?m-xis:^No globals selected) == 0
  RE: (?m-xis:^Header Label:) == 1
  RE: match index == 1

if debugging is enabled.

=cut

sub debug ($$) {
    $expect_debug = !!$_[1];
}

=item $handle->B<expect> ($re0, [$re1,...,] &cb [, $re .... &cb])

Waits for input that matches one of the given regular expressions.
&cb will be invoked with three arguments: $class, $data, $reidx.
$reidx is the index of the regular expression that matched.

A callback may die - B<close> will be invoked and the die
gets propagated.
Subsequent callbacks within the same expect-call will be skipped. 

=cut

sub expect($@) {
    my $self = shift;
    my $hdl  = $self->{hdl};