Commits

Diab Jerius  committed 6a3ccef

reorganize test server code

* Server -> Server::Base
* implement getencoding and runcommand capabilities
* properly return result code from runcommand
* runcommand delegated to Server::Commands
* basic server w/ no commands is now Server::Basic
* server w/ commands is Server::Full
* fake-hg has new full mode, which starts Server::Full

  • Participants
  • Parent commits 9addf9b

Comments (0)

Files changed (9)

 use lib 't';
 use lib 't/lib';
 
-use BadServer;
-
 my %opt = ( exitval => 0 );
 
 eval {
 
 sub bad_hello_chan {
 
+    require BadServer;
     BadServer::Hello::Chan->new->serve;
 
 }
 
 sub bad_hello_len {
 
+    require BadServer;
     BadServer::Hello::Len->new->serve;
 
 }
 
 sub bad_hello_no_capabilities {
 
+    require BadServer;
     BadServer::NoCapabilities->new->serve;
 }
 
 sub bad_hello_no_runcommand {
 
+    require BadServer;
     BadServer::NoRunCommand->new->serve;
 
 }
 
 sub bad_hello_no_encoding {
 
+    require BadServer;
     BadServer::NoEncoding->new->serve;
 
 }
 
 sub basic {
 
-    Server->new->serve;
+    require Server::Basic;
+    Server::Basic->new->serve;
 
 }
 
+sub full {
+
+    require Server::Full;
+    Server::Full->new->serve;
+
+}
+
+
 $_->() foreach @ARGV;
 
 exit $opt{exitval};

File t/lib/BadServer.pm

-use Server;
 use lib 't';
 
 ########################################################################
 
 use Moo;
 
-extends 'Server';
+extends 'Server::Base';
 
 sub say_hello {
 
 
 use Moo;
 
-extends 'Server';
+extends 'Server::Base';
 
 sub say_hello {
 
 use Moo;
 
 extends 'Server::Base';
+
+sub dispatch{ return }
+
 with 'Server::Capability::RunCommand';
 
 sub BUILD {

File t/lib/Server.pm

-package Server::Base;
-
-use Moo;
-use Sub::Quote qw[ quote_sub ];
-use IO::Handle;
-use Carp;
-
-has capabilities => (
-    is      => 'lazy',
-    builder => sub { return {} },
-);
-
-
-has input => (
-    is       => 'ro',
-    init_arg => undef,
-    default  => quote_sub q{ \*STDIN },
-);
-
-has output => (
-    is       => 'ro',
-    init_arg => undef,
-    default  => quote_sub q{ \*STDOUT },
-);
-
-has encoding => (
-    is        => 'rw',
-    predicate => 1,
-    clearer   => 1,
-    default   => quote_sub q{ $ENV{HGENCODING} // 'utf-8' }
-);
-
-sub read {
-
-    my ( $self, $size ) = ( shift, shift );
-
-    my $buf;
-
-    if ( $size ) {
-
-        my $r = $self->input->read( @_ ? $_[-1] : $buf, $size );
-        croak( "EOF\n" ) unless defined $r && $size == $r;
-
-    }
-
-    else {
-
-        ( @_ ? $_[-1] : $buf ) = '';
-
-    }
-
-    return $buf unless @_;
-    return;
-}
-
-sub read_chunk {
-
-    my $self = shift;
-
-    my $buf;
-
-    $self->read( 4, $buf );
-
-    my $len = unpack( 'N', $buf );
-
-    return $self->read( $len, @_ );
-}
-
-sub write_chunk {
-
-    my $self = shift;
-
-    # my ( $channel, $data ) = @_;
-
-    $self->output->syswrite( pack( 'A[1] N/A*', @_ ) );
-}
-
-sub say_hello {
-
-    my $self = shift;
-
-    my @capabilities = keys %{ $self->capabilities };
-
-    $self->write_chunk(
-        'o',
-        join( "\n",
-            @capabilities
-            ? ( join( ' ', 'capabilities:', @capabilities ) )
-            : (),
-            $self->has_encoding ? 'encoding: ' . $self->encoding : (),
-        ) );
-}
-
-sub serve {
-
-    my $self = shift;
-
-    $self->say_hello;
-
-    while ( my $cmd = $self->input->getline ) {
-
-        chomp $cmd;
-
-	my $handler = $self->capabilities->{$cmd};
-
-	if ( $handler ) {
-
-	    $handler->handle( $cmd, $self )
-
-	}
-	else {
-
-	    croak( "unknown command: $cmd\n" );
-
-	}
-
-    }
-
-}
-
-sub DEMOLISH { }
-
-########################################################################
-
-package Server::Capability::GetEncoding;
-
-use Moo::Role;
-
-around '_build_capabilities' => sub {
-
-    my ( $orig, $self ) = ( shift, shift );
-
-    my $capabilities = $self->$orig( @_ );
-
-    $capabilities->{getencoding} = sub { $self->encoding };
-
-    return $capabilities
-
-};
-
-########################################################################
-
-package Server::Capability::RunCommand;
-
-use Moo::Role;
-
-has dispatch => (
-
-    is      => 'lazy',
-    builder => sub { return {} },
-);
-
-
-around _build_capabilities => sub {
-
-    my ( $orig, $self ) = ( shift, shift );
-
-    my $capabilities = $self->$orig( @_ );
-
-    $capabilities->{runcommand} = sub { $self->runcommand( @_ ) };
-
-    return $capabilities;
-
-};
-
-sub runcommand {
-
-    my $self = shift;
-
-    my ( $cmd, @args ) = split( "\0", $self->read_chunk );
-
-    my $mth = $self->dispatch->{$cmd};
-
-    croak( "unknown command: $cmd\n" )
-      if !defined $mth;
-
-    $mth->( $self, $cmd, @args );
-}
-
-########################################################################
-
-package Server;
-
-use Moo;
-
-extends 'Server::Base';
-
-with 'Server::Capability::GetEncoding', 'Server::Capability::RunCommand';
-
-########################################################################
-
-1;

File t/lib/Server/Base.pm

+package Server::Base;
+
+use Moo;
+use Sub::Quote qw[ quote_sub ];
+use IO::Handle;
+use Carp;
+
+has capabilities => (
+    is      => 'lazy',
+    builder => sub { return {} },
+);
+
+
+has input => (
+    is       => 'ro',
+    init_arg => undef,
+    default  => quote_sub q{ \*STDIN },
+);
+
+has output => (
+    is       => 'ro',
+    init_arg => undef,
+    default  => quote_sub q{ \*STDOUT },
+);
+
+has encoding => (
+    is        => 'rw',
+    predicate => 1,
+    clearer   => 1,
+    default   => quote_sub q{ $ENV{HGENCODING} // 'utf-8' }
+);
+
+sub read {
+
+    my ( $self, $size ) = ( shift, shift );
+
+    my $buf;
+
+    if ( $size ) {
+
+        my $r = $self->input->read( @_ ? $_[-1] : $buf, $size );
+        croak( "EOF\n" ) unless defined $r && $size == $r;
+
+    }
+
+    else {
+
+        ( @_ ? $_[-1] : $buf ) = '';
+
+    }
+
+    return $buf unless @_;
+    return;
+}
+
+sub read_chunk {
+
+    my $self = shift;
+
+    my $buf;
+
+    $self->read( 4, $buf );
+
+    my $len = unpack( 'N', $buf );
+
+    return $self->read( $len, @_ );
+}
+
+sub write_chunk {
+
+    my $self = shift;
+
+    # my ( $channel, $data ) = @_;
+
+    return  defined $self->output->syswrite( pack( 'A[1] N/A*', @_ ) );
+}
+
+sub say_hello {
+
+    my $self = shift;
+
+    my @capabilities = keys %{ $self->capabilities };
+
+    $self->write_chunk(
+        'o',
+        join( "\n",
+            @capabilities
+            ? ( join( ' ', 'capabilities:', @capabilities ) )
+            : (),
+            $self->has_encoding ? 'encoding: ' . $self->encoding : (),
+        ) );
+}
+
+sub serve {
+
+    my $self = shift;
+
+    $self->say_hello;
+
+    while ( my $cmd = $self->input->getline ) {
+
+        chomp $cmd;
+
+        if ( $self->capabilities->{$cmd} ) {
+
+            my $mth = $self->can( $cmd )
+              or croak(
+                "internal error; should be able to perform capability: $cmd\n"
+              );
+
+            $self->$mth;
+
+        }
+
+        else {
+
+            croak( "unknown command: $cmd\n" );
+
+        }
+
+    }
+
+}
+
+sub DEMOLISH { }
+
+1;

File t/lib/Server/Basic.pm

+package Server::Basic;
+
+use Moo;
+
+extends 'Server::Base';
+
+sub dispatch { return }
+
+with 'Server::Capability::GetEncoding', 'Server::Capability::RunCommand';
+
+
+1;

File t/lib/Server/Capability/GetEncoding.pm

+package Server::Capability::GetEncoding;
+
+use Moo::Role;
+
+requires 'encoding';
+
+around _build_capabilities => sub {
+
+    my ( $orig, $self ) = ( shift, shift );
+
+    my $capabilities = $self->$orig( @_ );
+
+    $capabilities->{getencoding} = 1;
+
+    return $capabilities
+
+};
+
+sub getencoding {
+
+    my $self = shift;
+
+    $self->write_chunk( 'r', $self->encoding );
+
+}
+
+1;

File t/lib/Server/Capability/RunCommand.pm

+package Server::Capability::RunCommand;
+
+use Carp;
+
+use Moo::Role;
+
+requires 'dispatch';
+
+around _build_capabilities => sub {
+
+    my ( $orig, $self ) = ( shift, shift );
+
+    my $capabilities = $self->$orig( @_ );
+
+    $capabilities->{runcommand} = 1;
+
+    return $capabilities;
+
+};
+
+sub runcommand {
+
+    my $self = shift;
+
+    my ( $cmd, @args ) = split( "\0", $self->read_chunk );
+
+    my $mth = $self->dispatch( $cmd );
+
+    croak( "unknown command: $cmd\n" )
+      if !defined $mth;
+
+    my $ret = $mth->( $self, $cmd, @args );
+
+    $self->write_chunk( 'r', pack( 'l>', $ret ) );
+
+    return;
+}
+
+1;
+
+

File t/lib/Server/Commands.pm

+package Server::Commands;
+
+use Moo::Role;
+
+my %commands = (
+
+    ls => sub {
+	my $server = shift;
+	my $dir = qx{ls};
+	chomp $dir;
+	! $server->write_chunk( 'o', $dir );
+    }
+);
+
+sub dispatch {
+
+    print STDERR "DISPATCHED\n";
+
+    my $cmd = $_[1];
+    chomp $cmd;
+    return $commands{ $cmd };
+
+}
+
+1;
+
+
+

File t/lib/Server/Full.pm

+package Server::Full;
+
+use Moo;
+
+extends 'Server::Base';
+
+# get dispatch
+with 'Server::Commands';
+
+with 'Server::Capability::GetEncoding', 'Server::Capability::RunCommand';
+
+
+1;