File Coverage

blib/lib/GTM/Run.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

=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 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 ()

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 ($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 ($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 ($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 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};
    my @re;
    my $mre;
    my $done;
    my $die;
    for my $i (@_) {
        if (ref $i eq "Regexp") {
            push @re, $i;
            next;
        }
        die "expected code-ref or regexp" if (ref $i ne "CODE");
        my $mre = merge_regexp (@re);
        my @xre = @re;
        my $cv  = AnyEvent->condvar;
        local $midx;
        $hdl->push_read (
            regex => $mre,
            sub {
                return if $done;
                if ($expect_debug) {
                    for (my $i = 0 ; $i < @xre ; $i++) {
                        print STDERR "RE: $xre[$i] == $i\n";
                    }
                    print STDERR "RE: match index == $midx\n\n";
                }
                eval { $i->($self, $_[1], $midx); };
                if ($@) {
                    $done = 1;
                    $die  = $@;
                    $self->close;
                }
                $cv->send;
            },
        );
        @re = ();

        $cv->recv;
        die $die if $die;
    }
}

sub DESTROY {
    my $hdl = shift;
    $hdl->close unless $hdl->{closed};
}

=item $hdl->B ()

Waits until the output buffer is empty.

=cut

sub flush ($) {
    my $self = shift;
    my $hdl  = $self->{hdl};
    my $cv   = AnyEvent->condvar;
    $hdl->on_drain (sub { $cv->send });
    $cv->recv;

}

=back

=head1 SEE ALSO

L

=head1 AUTHOR

   Stefan Traby
   http://oesiman.de/gt.m/

=cut

1;