Commits

Diab Jerius  committed ff867e8

replace home-grown pipe connection code with System::Command (yeah!)

add environment attribute (env)

  • Participants
  • Parent commits 025e505

Comments (0)

Files changed (3)

     license     => 'perl',
 
     requires => {
-        'IO::Handle'               => 0,
-        'IPC::Open2'               => 0,
+		 'System::Command' => 0,
         'Moo'                      => '1.001000',
         'MooX::Attributes::Shadow' => 0,
         'MooX::Types::MooseLike'   => 0,
-        'POSIX'                    => 0,
         'Params::Validate'         => 0,
         'Scalar::Util'             => 0,
         'Try::Tiny'                => 0,

File lib/Hg/Lib/Server/Pipe.pm

 use strict;
 use warnings;
 
-use Symbol 'gensym';
-#use IPC::Open3 qw[ open3 ];
-use IPC::Open2 qw[ open2 ];
-
 use Carp;
 
-use POSIX qw[ WNOHANG WEXITSTATUS WIFEXITED WTERMSIG WIFSIGNALED ];
+use System::Command;
 use Try::Tiny;
 
-# 5.10.1 requires usage to gain access to methods
-use IO::Handle;
-
 use Moo;
 use MooX::Types::MooseLike::Base qw[ :all ];
 
-# attempt to make things work on Windows, which doesn't define
-# WUNTRACED
-BEGIN {
-    my $have_WUNTRACED = eval { POSIX::WUNTRACED() | 1; };
-
-    *WUNTRACED = $have_WUNTRACED ? \&POSIX::WUNTRACED : sub () { 0 };
-}
-
 use constant forceArray => sub { 'ARRAY' eq ref $_[0] ? $_[0] : [ $_[0] ] };
 
 with 'MooX::Attributes::Shadow::Role';
 
-shadowable_attrs( qw[ hg args path configs ] );
+shadowable_attrs( qw[ hg args path configs env ] );
 
 has _pid => (
     is        => 'rwp',
     is      => 'ro',
     default => 'hg',
     coerce  => forceArray,
-    isa     => ArrayRef[Str],
+    isa     => ArrayRef [Str],
 );
 
 # arguments to hg
 has args => (
     is      => 'ro',
     coerce  => forceArray,
-    isa     => ArrayRef[Str],
+    isa     => ArrayRef [Str],
     default => sub { [] },
 );
 
 has configs => (
     is      => 'ro',
     coerce  => forceArray,
-    isa     => ArrayRef[Str],
+    isa     => ArrayRef [Str],
     default => sub { [] },
 );
 
-has cmd => (
+has cmdline => (
     is       => 'lazy',
     init_arg => undef,
 );
 
+has env => (
 
-sub _build_cmd {
+    is      => 'ro',
+    isa     => HashRef,
+    default => sub { {} },
+
+);
+
+has cmd => (
+
+    is        => 'lazy',
+    init_arg  => undef,
+    predicate => 1,
+    handles   => [ qw[ stdin stdout stderr pid close ] ],
+    builder   => sub {
+        my $self = shift;
+        System::Command->new( @{ $self->cmdline },
+			    { env => $self->env }
+			    );
+    },
+
+
+);
+
+sub _build_cmdline {
 
     my $self = shift;
 
     return \@cmd;
 }
 
-sub BUILD {
-
-    shift()->open;
-
-}
-
-sub open {
+sub DEMOLISH {
 
     my $self = shift;
 
-    my ( $write, $read );
-    my $error = gensym();
-
-    my $pid;
-
-    try {
-
-        $pid = open2( $read, $write, @{ $self->cmd } );
-        #        $pid = open3( $write, $read, $error, @{ $self->cmd } );
-
-        # there's probably not enough time elapsed between starting
-        # the child process and checking for its existence, but this
-        # doesn't cost much
-        _check_on_child( $pid, status => 'alive' );
-
-    }
-    catch {
-
-        croak( $_ );
-
-    };
-
-
-    $self->_set__pid( $pid );
-    $self->_set__write( $write );
-    $self->_set__read( $read );
-    $self->_set__error( $error );
-
-}
-
-sub DEMOLISH {
-
-    shift()->close;
+    $self->close if $self->has_cmd;
 
 }
 
     my $self = shift;
 
     # use aliased data in @_ to prevent copying
-    return $self->_read->sysread( @_ );
+    return $self->stdout->sysread( @_ );
 }
 
 # always use aliased $_[0] as buffer to prevent copying
 
     my $self = shift;
     my $len = @_ > 1 ? $_[1] : length( $_[0] );
-    $self->_write->syswrite( $_[0], $len ) == $len
+    $self->stdin->syswrite( $_[0], $len ) == $len
       or croak( "error writing $len bytes to server\n" );
 }
 
     $self->write( pack( "N/a*", $_[0] ) );
 }
 
-sub close {
+1;
 
-    my $self = shift;
+__END__
 
-    # if the command server was created, see if it's
-    # still hanging around
-    if ( $self->_has_pid ) {
+=pod
 
-        $self->_write->close;
+=head1 NAME
 
-        _check_on_child(
-            $self->_pid,
-            status => 'exit',
-            wait   => 1
-        );
+Hg::Lib::Server::Pipe
 
-        $self->_clear_pid;
-    }
+=head1 VERSION
 
-    return;
+version 0.01_02
 
-}
+=head1 AUTHOR
 
-sub _check_on_child {
+Diab Jerius E<lt>djerius@cpan.orgE<gt>
 
-    my $pid = shift;
-    my %opt = @_;
+=head1 COPYRIGHT AND LICENSE
 
-    my $flags = WUNTRACED | ( $opt{wait} ? 0 : WNOHANG );
-    my $status = waitpid( $pid, $flags );
+This software is copyright (c) 2013 by Diab Jerius E<lt>djerius@cpan.orgE<gt>.
 
-    # if the child exitted, it had better have been a clean death;
-    # anything else is not ok.
-    if ( $pid == $status ) {
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
 
-        die( "unexpected exit of child with status ", WEXITSTATUS( $? ), "\n" )
-          if WIFEXITED( $? ) && WEXITSTATUS( $? ) != 0;
-
-        die( "unexpected exit of child with signal ", WTERMSIG( $? ), "\n" )
-          if WIFSIGNALED( $? );
-
-    }
-
-    if ( $opt{status} eq 'alive' ) {
-
-        die( "unexpected exit of child\n" )
-          if $pid == $status || -1 == $status;
-
-    }
-
-    elsif ( $opt{status} eq 'exit' ) {
-
-        # is the child still alive
-        die( "child still alive\n" )
-          unless $pid == $status || -1 == $status;
-
-    }
-
-    else {
-
-        die( "internal error: unknown child status requested\n" );
-
-    }
-
-}
-1;
+=cut

File t/Server/Pipe/check_on_child.t

-#!/perl
-
-use 5.10.1;
-
-use Test::More;
-use Test::Exception;
-use IO::Pipe;
-use Carp;
-
-# map from signal name to signal; just in case some systems differ
-use Config;
-my %Signal;
-{
-    my @sig = split( ' ', $Config{sig_name} );
-    @Signal{@sig} = ( 0..@sig-1 );
-}
-
-use Hg::Lib::Server::Pipe;
-
-
-*_check_on_child = \&Hg::Lib::Server::Pipe::_check_on_child;
-
-
-# see
-# http://blogs.perl.org/users/aristotle/2012/10/concise-fork-idiom.html
-
-use constant {
-  FORK_ERROR  => undef,
-  FORK_CHILD  => 0,
-  FORK_PARENT => sub { $_[0] > 0 },
-};
-
-subtest fork_alive => sub {
-
-    my $pipe = IO::Pipe->new;
-
-    for (fork) {
-
-	when (FORK_ERROR) {
-	    confess "Error forking";
-	}
-	when (FORK_PARENT) {
-
-	    throws_ok {_check_on_child( $_, status => 'exit' ) }
-		qr/still alive/, 'alive, expect exit';
-
-	    lives_ok {
-		_check_on_child( $_, status => 'alive' );
-	    } 'alive, expect alive';
-
-	    $pipe->writer->close;
-
-	    lives_ok {
-		_check_on_child( $_, status => 'exit', wait => 1 );
-	    } 'exit, expect exit';
-
-	}
-	when (FORK_CHILD) {
-
-	    my $fh = $pipe->reader;
-
-	    $fh->getline;
-	    exit(0);
-	}
-    }
-
-};
-
-
-subtest fork_exit => sub {
-
-    my $pipe = IO::Pipe->new;
-
-    for (fork) {
-
-	when (FORK_ERROR) {
-	    confess "Error forking";
-	}
-	when (FORK_PARENT) {
-
-	    throws_ok {_check_on_child( $_, status => 'exit' ) }
-		qr/still alive/, 'alive, expect exit';
-
-	    lives_ok {
-		_check_on_child( $_, status => 'alive' );
-	    } 'alive, expect alive';
-
-
-	    kill $Signal{'TERM'}, $_
-		or die( "unable to send SIGTERM to child\n" );
-
-	    throws_ok {
-		_check_on_child( $_, status => 'exit', wait => 1 );
-	    } qr/signal $Signal{'TERM'}/, 'exit with signal';
-
-	    # handle case when child has been reaped
-	    lives_ok {
-		_check_on_child( $_, status => 'exit', wait => 1 );
-	    } 'exit: reaped child';
-
-	    throws_ok {
-		_check_on_child( $_, status => 'alive', wait => 1 );
-	    } qr/unexpected exit/, 'alive: reaped child';
-
-	}
-	when (FORK_CHILD) {
-
-	    my $fh = $pipe->reader;
-
-	    $fh->getline;
-
-	    exit(0);
-
-	}
-    }
-
-};
-
-
-done_testing;