Commits

Diab Jerius committed 282fa75

add higher level run method (similar to Python hglib's rawcommand

Comments (0)

Files changed (4)

lib/Hg/Lib/Client.pm

 package Hg::Lib::Client;
 
+use feature 'state';
+
+use autodie;
+
 use Moo;
 
 use boolean ':all';
 use Scalar::Util qw[ reftype ];
 
 use Hg::Lib::Server;
+use Hg::Lib::Exception ':aliases';
+
+use Types::Standard -all;
+use Type::Params qw[ compile ];
+use Hg::Lib::Types -types;
 
 Hg::Lib::Server->shadow_attrs;
 
     return \@cmd;
 }
 
-# everything that follows is sugar
+sub run {
 
-sub add {
+    my $self = shift;
 
-    my ( $self, $files ) = (shift, shift);
+    state $check = compile( StrList,
+        slurpy Dict [
+            prompt => Optional [CodeRef],
+            input  => Optional [CodeRef],
+            eh     => Optional [CodeRef] ] );
 
-    $files = [ $files ] unless 'ARRAY' eq ref $files;
+    my ( $cmd, $opts ) = $check->( @_ );
 
-    my $cmd = _prep_cmd( 'add', $files, { @_ } );
+    my ( $output, $error );
 
-    
+    my %outchannel = (
+        o => sub { $output .= join( '', @_ ) },
+        e => sub { $error  .= join( '', @_ ) } );
 
+    my %inchannel;
+
+    $inchannel{L} = sub { $opts->{prompt}->( @_, $output ) }
+      if $opts->{prompt};
+
+    $inchannel{I} = sub { $opts->{input}->( @_ ) }
+      if $opts->{input};
+
+    my $ret = $self->runcommand(
+        $cmd,
+        inchannels  => \%inchannel,
+        outchannels => \%outchannel
+    );
+
+    if ( $ret ) {
+
+        ECommand->throw(
+            cmd    => $cmd,
+            ret    => $ret,
+            output => $output,
+            error  => $error
+        ) unless defined $opts->{eh};
+
+        return $opts->{eh}->( $ret, $output, $error );
+
+    }
+
+    return $output;
 }
 
 1;

lib/Hg/Lib/Exception.pm

     'Server::Pipe::Timeout'    => ['EPipeTimeout'],
 );
 
-while ( my ( $exception, $aliases ) = splice( @Exceptions, 0, 2 ) ) {
+mk_exception( splice( @Exceptions, 0, 2 ) ) while @Exceptions;
+
+sub mk_exception {
+
+    my ( $exception, $aliases ) = @_;
 
     my ( $parent ) = $exception =~ /(?:(.*)::)?.*/;
 
     push @{"$exception\::ISA"}, $parent;
 
     for my $alias ( @$aliases ) {
-	# no closures, please
-	*{ __PACKAGE__ . "::$alias"} = eval qq[sub () { '$exception' }];
-	push @EXPORT_OK, $alias;
+        # no closures, please
+        *{ __PACKAGE__ . "::$alias" } = eval qq[sub () { '$exception' }];
+        push @EXPORT_OK, $alias;
     }
+
 }
 
 #--------------------------------
         $self->text, ( defined( $s = $self->previous_exception ) ? $s : () ) );
 }
 
+# special sub classes
 
+package Hg::Lib::Exception::Command;
+
+use Moo;
+
+extends 'Hg::Lib::Exception';
+
+has '+text' => (
+    required => 0,
+    lazy     => 1,
+    default  => sub {
+        my $self = shift;
+        sprintf( qq[command "%s" exited with "%d": %s],
+            join( ' ', @{$self->cmd}), $self->ret, $self->error );
+    },
+);
+has cmd => ( is => 'ro', required => 1 );
+has ret => ( is => 'ro', required => 1 );
+has output => ( is => 'ro' );
+has error  => ( is => 'ro' );
+
+Hg::Lib::Exception::mk_exception( Command => ['ECommand'] );
 
 1;
 

t/Hg/Lib/Client/run.t

+#! perl
+
+use strict;
+use warnings;
+
+use 5.10.1;
+
+use lib 't/lib';
+
+use base 'Test::Hg::Client';
+
+use boolean;
+use Test::More;
+use Test::Fatal;
+
+use Hg::Lib::Client;
+use Hg::Lib::Exception ':aliases';
+
+use YAML::Tiny;
+
+INIT { Test::Class->runtests }
+
+
+# test the output channel handler
+sub echo_output : Tests {
+
+    my $self = shift;
+
+    my $out = YAML::Tiny->read_string(
+        $self->{client}->run( [ 'echo_output', '--a', 3 ] ) );
+
+    is_deeply(
+        $out->[0],
+        {
+            cmd  => 'echo_output',
+            args => [ '--a', 3 ]
+        },
+        "echo_output, args: --a 3"
+    );
+
+}
+
+sub failed_without_error_handler : Tests {
+
+    my $self = shift;
+
+    my $e = exception { $self->{client}->run( ['fail'] ) };
+
+    isa_ok( $e, ECommand, 'ECommand' );
+
+    is( $e->output, undef,     'no output on failure' );
+    is( $e->error,  'failed!', 'error output on failure' );
+    is( $e->ret,    193,       'error code' );
+}
+
+sub failed_with_error_handler : Tests {
+
+    my $self = shift;
+
+    my ( $ret, $output, $error );
+
+    my $e = exception {
+        $self->{client}
+          ->run( ['fail'], eh => sub { ( $ret, $output, $error ) = @_ } );
+    };
+
+    is( $e, undef, 'no exception' );
+
+    is( $output, undef,     'no output on failure' );
+    is( $error,  'failed!', 'error output on failure' );
+    is( $ret,    193,       'error code' );
+}
+
+sub L_handler : Tests {
+
+    my $self = shift;
+
+    my $msg    = 'Please enter something';
+    my $prompt = sub {
+        my $length = shift;
+
+        state $i = 5;
+
+        is( $length, 4096, "requested length\n" );
+
+        is( $_[0], $msg, 'output channel' );
+
+        return $i ? sprintf( "%03d\n", $i-- ) : '';
+    };
+
+    my $output;
+    my $e = exception {
+        $output = $self->{client}->run( ['read_line'], prompt => $prompt );
+    };
+
+    is( $e, undef, 'no exception' );
+    is( $output, "${msg}001\n002\n003\n004\n005\n", 'returned message' );
+
+}

t/lib/Test/Hg/Client.pm

+#! perl
+
+package Test::Hg::Client;
+
+use base 'Test::Class';
+
+use t::common;
+
+use Test::More;
+use Test::Fatal;
+
+use Hg::Lib::Client;
+use Hg::Lib::Exception ':aliases';
+
+sub start_client : Test(setup) {
+
+    shift->{client} = Hg::Lib::Client->new(
+        hg   => fake_hg,
+        args => 'full'
+    );
+}
+
+sub stop_server : Test(teardown => no_plan) {
+
+    my $self = shift;
+
+    my $e = exception { delete $self->{client} };
+
+    if ( defined $self->{stop_error} ) {
+
+	my ( $exp_exception, $exp_message ) = @{$self->{stop_error}};
+
+	__PACKAGE__->num_method_tests( 'stop_server', 2 );
+
+	isa_ok( $e, $exp_exception, $exp_exception );
+	like( $e, $exp_message, 'message' );
+    }
+
+    else {
+
+	__PACKAGE__->num_method_tests( 'stop_server', 1 );
+
+	is ( $e, undef, "successful server exit" );
+    }
+
+}
+
+1;
+