Commits

Anonymous committed d249445

with switch to System::Command, need for Pipe object fades. fold into Server

- Server constructor:
- encoding option specifies encoding
- connect option (default false) indicates if to immediately
connect, or to lazy load
- update tests

Comments (0)

Files changed (5)

lib/Hg/Lib/Server.pm

 
 use Carp;
 
+use System::Command;
 use Params::Validate ':all';
 
 use Moo;
 use MooX::Types::MooseLike::Base qw[ :all ];
 
-use Hg::Lib::Server::Pipe;
+use Try::Tiny;
 
-Hg::Lib::Server::Pipe->shadow_attrs;
+use constant forceArray => sub { 'ARRAY' eq ref $_[0] ? $_[0] : [ $_[0] ] };
 
-has server => (
-    is       => 'ro',
-    lazy     => 1,
+with 'MooX::Attributes::Shadow::Role';
+
+shadowable_attrs( qw[ hg args path configs encoding env ] );
+
+# path to hg executable; allow multiple components
+has hg => (
+    is      => 'ro',
+    default => 'hg',
+    coerce  => forceArray,
+    isa     => ArrayRef [Str],
+);
+
+# arguments to hg
+has args => (
+    is      => 'ro',
+    coerce  => forceArray,
+    isa     => ArrayRef [Str],
+    default => sub { [] },
+);
+
+has path => (
+    is        => 'ro',
+    predicate => 1,
+);
+
+has configs => (
+    is      => 'ro',
+    coerce  => forceArray,
+    isa     => ArrayRef [Str],
+    default => sub { [] },
+);
+
+# default encoding; set to that returned by the hg hello response
+has encoding => (
+    is        => 'rwp',
+    predicate => 1,
+    clearer   => '_clear_encoding',
+);
+
+has env => (
+    is      => 'ro',
+    isa     => HashRef,
+    default => sub { {} },
+);
+
+# the actual pipe object.  the pipe should be lazily created when any
+# handled method is used.  $server->_get_hello *must* be called after
+# pipe creation; trigger will do that.  however, trigger is not called
+# when default is used, only when attribute is set. so, have
+# default call $server->open which calls setter.
+
+has _pipe => (
+
+    is        => 'rw',
+	      init_arg => undef,
+    lazy => 1,
+    predicate => 1,
+    trigger   => sub { $_[0]->_get_hello },
+    handles  => [qw[ stdin stdout stderr pid close is_terminated ]],
+    default => sub { $_[0]->open },
+);
+
+
+has connect => (
+
+    is      => 'ro',
+    default => 0,
+
+);
+
+# constructed command line; does not include environment variables
+has _cmdline => (
+    is       => 'lazy',
     init_arg => undef,
-    handles  => [qw[ get_chunk write writeblock ]],
-    default  => sub {
-        Hg::Lib::Server::Pipe->new(
-            Hg::Lib::Server::Pipe->xtract_attrs( $_[0] ) );
+    builder  => sub {
+
+        my $self = shift;
+
+        my @cmd = (
+            @{ $self->hg },
+            qw[ --config ui.interactive=True
+              serve
+              --cmdserver pipe
+              ],
+        );
+
+        push @cmd, '-R', $self->path if $self->has_path;
+
+        push @cmd, map { ( '--config' => $_ ) } @{ $self->configs };
+
+        push @cmd, @{ $self->args };
+
+        return \@cmd;
     },
+
 );
 
+
 has capabilities => (
     is        => 'rwp',
     predicate => 1,
     init_arg  => undef,
 );
 
-has encoding => (
-    is        => 'rwp',
-    predicate => 1,
-    init_arg  => undef,
-);
-
-
 sub BUILD {
 
-    $_[0]->_get_hello;
+    my $self = shift;
+
+    $self->open if $self->connect;
+
+}
+
+sub DEMOLISH {
+
+    my $self = shift;
+
+    $self->close if $self->_has_pipe;
+
+}
+
+sub open {
+
+    my $self = shift;
+
+    my $env = $self->env;
+
+    $env->{HGPLAIN}    = 1;
+    $env->{HGENCODING} = $self->encoding
+      if $self->has_encoding;
+
+    my $pipe
+      = System::Command->new( @{ $self->_cmdline }, { env => $self->env } );
+    $self->_pipe( $pipe );
+
+    return $pipe;
+}
+
+sub read {
+
+    my $self = shift;
+
+    # use aliased data in @_ to prevent copying
+    return $self->stdout->sysread( @_ );
+}
+
+# always use aliased $_[0] as buffer to prevent copying
+# call as get_chunk( $buf )
+sub get_chunk {
+
+    my $self = shift;
+
+    # catch pipe errors from child
+    local $SIG{'PIPE'} = sub { croak( "SIGPIPE on read from server\n" ) };
+
+    my $nr = $self->read( $_[0], 5 );
+    croak( "error reading chunk header from server: $!\n" )
+      unless defined $nr;
+
+    $nr > 0
+      or croak( "unexpected end-of-file getting chunk header from server\n" );
+
+    my ( $ch, $len ) = unpack( 'A[1] l>', $_[0] );
+
+    if ( $ch =~ /IL/ ) {
+
+        croak(
+            "get_chunk called incorrectly called in scalar context for channel $ch\n"
+        ) unless wantarray();
+
+        return $ch, $len;
+    }
+
+    else {
+
+        $self->read( $_[0], $len ) == $len
+          or croak(
+            "unexpected end-of-file reading $len bytes from server channel $ch\n"
+          );
+
+        return $ch;
+    }
+
+}
+
+# call as $self->write( $buf, [ $len ] )
+sub write {
+
+    my $self = shift;
+    my $len = @_ > 1 ? $_[1] : length( $_[0] );
+    $self->stdin->syswrite( $_[0], $len ) == $len
+      or croak( "error writing $len bytes to server\n" );
+}
+
+sub writeblock {
+
+    my $self = shift;
+
+    $self->write( pack( "N/a*", $_[0] ) );
 }
 
 sub _get_hello {
     croak( "corrupt or incomplete hello message from server\n" )
       unless $ch eq 'o' && length $buf;
 
+    my $requested_encoding = $self->has_encoding ? $self->encoding : undef;
+    $self->_clear_encoding;
+
     for my $item ( split( "\n", $buf ) ) {
 
         my ( $field, $value ) = $item =~ /([a-z0-9]+):\s*(.*)/;
 
         elsif ( $field eq 'encoding' ) {
 
+            croak( sprintf "requested encoding of %s; got %s",
+                $requested_encoding, $value )
+              if defined $requested_encoding && $requested_encoding ne $value;
+
             $self->_set_encoding( $value );
 
         }
 }
 
 1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Hg::Lib::Server
+
+=head1 VERSION
+
+version 0.01_02
+
+=head1 AUTHOR
+
+Diab Jerius E<lt>djerius@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2013 by Diab Jerius E<lt>djerius@cpan.orgE<gt>.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut

lib/Hg/Lib/Server/Pipe.pm

-package Hg::Lib::Server::Pipe;
-
-use strict;
-use warnings;
-
-use Carp;
-
-use System::Command;
-use Try::Tiny;
-
-use Moo;
-use MooX::Types::MooseLike::Base qw[ :all ];
-
-use constant forceArray => sub { 'ARRAY' eq ref $_[0] ? $_[0] : [ $_[0] ] };
-
-with 'MooX::Attributes::Shadow::Role';
-
-shadowable_attrs( qw[ hg args path configs env ] );
-
-has _pid => (
-    is        => 'rwp',
-    predicate => 1,
-    clearer   => 1,
-    init_arg  => undef
-);
-has _write => (
-    is       => 'rwp',
-    init_arg => undef
-);
-has _read => (
-    is       => 'rwp',
-    init_arg => undef
-);
-has _error => (
-    is       => 'rwp',
-    init_arg => undef
-);
-
-# path to hg executable
-has hg => (
-    is      => 'ro',
-    default => 'hg',
-    coerce  => forceArray,
-    isa     => ArrayRef [Str],
-);
-
-# arguments to hg
-has args => (
-    is      => 'ro',
-    coerce  => forceArray,
-    isa     => ArrayRef [Str],
-    default => sub { [] },
-);
-
-has path => (
-    is        => 'ro',
-    predicate => 1,
-);
-
-has configs => (
-    is      => 'ro',
-    coerce  => forceArray,
-    isa     => ArrayRef [Str],
-    default => sub { [] },
-);
-
-has cmdline => (
-    is       => 'lazy',
-    init_arg => undef,
-);
-
-has env => (
-
-    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;
-
-    my @cmd = (
-        @{ $self->hg },
-        qw[ --config ui.interactive=True
-          serve
-          --cmdserver pipe
-          ],
-    );
-
-    push @cmd, '-R', $self->path if $self->has_path;
-
-    push @cmd, map { ( '--config' => $_ ) } @{ $self->configs };
-
-    push @cmd, @{ $self->args };
-
-    return \@cmd;
-}
-
-sub DEMOLISH {
-
-    my $self = shift;
-
-    $self->close if $self->has_cmd;
-
-}
-
-sub read {
-
-    my $self = shift;
-
-    # use aliased data in @_ to prevent copying
-    return $self->stdout->sysread( @_ );
-}
-
-# always use aliased $_[0] as buffer to prevent copying
-# call as get_chunk( $buf )
-sub get_chunk {
-
-    my $self = shift;
-
-    # catch pipe errors from child
-    local $SIG{'PIPE'} = sub { croak( "SIGPIPE on read from server\n" ) };
-
-    my $nr = $self->read( $_[0], 5 );
-    croak( "error reading chunk header from server: $!\n" )
-      unless defined $nr;
-
-    $nr > 0
-      or croak( "unexpected end-of-file getting chunk header from server\n" );
-
-    my ( $ch, $len ) = unpack( 'A[1] l>', $_[0] );
-
-    if ( $ch =~ /IL/ ) {
-
-        croak(
-            "get_chunk called incorrectly called in scalar context for channel $ch\n"
-        ) unless wantarray();
-
-        return $ch, $len;
-    }
-
-    else {
-
-        $self->read( $_[0], $len ) == $len
-          or croak(
-            "unexpected end-of-file reading $len bytes from server channel $ch\n"
-          );
-
-        return $ch;
-    }
-
-}
-
-# call as $pipe->write( $buf, [ $len ] )
-sub write {
-
-    my $self = shift;
-    my $len = @_ > 1 ? $_[1] : length( $_[0] );
-    $self->stdin->syswrite( $_[0], $len ) == $len
-      or croak( "error writing $len bytes to server\n" );
-}
-
-sub writeblock {
-
-    my $self = shift;
-
-    $self->write( pack( "N/a*", $_[0] ) );
-}
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-Hg::Lib::Server::Pipe
-
-=head1 VERSION
-
-version 0.01_02
-
-=head1 AUTHOR
-
-Diab Jerius E<lt>djerius@cpan.orgE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-This software is copyright (c) 2013 by Diab Jerius E<lt>djerius@cpan.orgE<gt>.
-
-This is free software; you can redistribute it and/or modify it under
-the same terms as the Perl 5 programming language system itself.
-
-=cut

t/Server/Pipe.t

-#!perl
-
-use strict;
-use warnings;
-
-use t::common;
-
-use Test::More;
-use Test::Exception;
-
-use Hg::Lib::Server::Pipe;
-
-sub fnew { Hg::Lib::Server::Pipe->new( hg => fake_hg, @_ ) }
-
-lives_ok { fnew( args => [ qw( wait ) ] ) } 'fake, no args';
-
-throws_ok {
-
-    my $pipe = fnew( args => [ qw( fail )  ] );
-
-    # we have to wait a bit to make sure that the process actually
-    # dies.
-    for ( 0..10 ) {
-	sleep 1;
-	Hg::Lib::Server::Pipe::_check_on_child( $pipe->_pid,
-						status => 'alive' );
-    }
-
-
-}  qr/unexpected exit of child/, 'fake, fail';
-
-
-subtest 'badlen' => sub {
-
-    my $hg;
-    lives_ok { $hg = fnew( args => [ qw(  badlen ) ] ) } 'open hg';
-
-
-    throws_ok { $hg->get_chunk( my $buf ) } qr/end-of-file reading/, 'short data';
-
-};
-
-
-done_testing;
-
-

t/Server/Server.t

+#!perl
+
+use strict;
+use warnings;
+
+use t::common;
+
+use Test::More;
+use Test::Exception;
+
+use Hg::Lib::Server;
+
+sub fnew { Hg::Lib::Server->new( hg => fake_hg, @_ ) }
+
+lives_ok { fnew( args => [ qw( wait ) ] ) } 'fake, no args';
+
+throws_ok {
+
+    my $server = fnew( args => [ qw( fail )  ] );
+
+    # we have to wait a bit to make sure that the process actually
+    # dies.
+    for ( 0..10 ) {
+	sleep 1;
+	$server->is_terminated && die( "unexpected exit of child" );
+    }
+
+
+}  qr/unexpected end-of-file/, 'fake, fail';
+
+
+subtest 'badlen' => sub {
+
+    my $hg;
+    lives_ok { $hg = fnew( args => [ qw(  badlen ) ] ) } 'open hg';
+
+
+    throws_ok { $hg->get_chunk( my $buf ) } qr/end-of-file reading/, 'short data';
+
+};
+
+
+done_testing;
+
+
 
 use Hg::Lib::Server;
 
-sub new { Hg::Lib::Server->new( hg => fake_hg, @_ ) }
+sub new { Hg::Lib::Server->new( hg => fake_hg, connect => 1, @_ ) }
 
 lives_ok { new( args => [ qw( basic ) ] ) } 'hello, no args';