SSH protocol support, via IPC::Open2

Author: alexmv

lib/Git/PurePerl.pm

@@ -426,10 +426,20 @@ sub checkout {
 }
 
 sub clone {
-    my ( $self, $hostname, $project ) = @_;
+    my $self = shift;
+
+    my $remote;
+    if (@_  == 2) {
+        # For backwards compatibility
+        $remote = "git://$_[0]";
+        $remote .= "/" unless $_[1] =~ m{^/};
+        $remote .= $_[1];
+    } else {
+        $remote = shift;
+    }
+
     my $protocol = Git::PurePerl::Protocol->new(
-        hostname => $hostname,
-        project  => $project,
+        remote => $remote,
     );
 
     my $sha1s = $protocol->connect;

lib/Git/PurePerl/Protocol.pm

@@ -3,27 +3,33 @@ use Moose;
 use MooseX::StrictConstructor;
 use Moose::Util::TypeConstraints;
 
-has 'hostname' => ( is => 'ro', isa => 'Str', required => 1 );
-has 'port'    => ( is => 'ro', isa => 'Int', required => 0, default => 9418 );
-has 'project' => ( is => 'ro', isa => 'Str', required => 1 );
-has 'socket' => ( is => 'rw', isa => 'IO::Socket', required => 0 );
+use Git::PurePerl::Protocol::Git;
+use Git::PurePerl::Protocol::SSH;
+use Git::PurePerl::Protocol::SSH;
+
+has 'remote' => ( is => 'ro', isa => 'Str', required => 1 );
+has 'read_socket' => ( is => 'rw', required => 0 );
+has 'write_socket' => ( is => 'rw', required => 0 );
 
 sub connect {
     my $self = shift;
 
-    my $socket = IO::Socket::INET->new(
-        PeerAddr => $self->hostname,
-        PeerPort => $self->port,
-        Proto    => 'tcp'
-    ) || die $! . ' ' . $self->hostname . ':' . $self->port;
-    $socket->autoflush(1) || die $!;
-    $self->socket($socket);
+    if ($self->remote =~ m{^git://(.*?@)?(.*?)(/.*)}) {
+        Git::PurePerl::Protocol::Git->meta->rebless_instance(
+            $self,
+            hostname => $2,
+            project => $3,
+        );
+    } elsif ($self->remote =~ m{^(?:(.*?)@)?(.*?):(.*)}) {
+        Git::PurePerl::Protocol::SSH->meta->rebless_instance(
+            $self,
+            $1 ? (username => $1) : (),
+            hostname => $2,
+            path => $3,
+        );
+    }
 
-    $self->send_line( "git-upload-pack "
-            . $self->project
-            . "\0host="
-            . $self->hostname
-            . "\0" );
+    $self->connect_socket;
 
     my %sha1s;
     while ( my $line = $self->read_line() ) {
@@ -77,19 +83,34 @@ sub send_line {
     my $text = $prefix . $line;
 
     # warn "$text";
-    $self->socket->print($text) || die $!;
+    $self->write_socket->print($text) || die $!;
+}
+
+sub read {
+    my $self = shift;
+    my $len = shift;
+
+    my $ret = "";
+    use bytes;
+    while (1) {
+        my $got = $self->read_socket->read( my $data, $len - length($ret));
+        if (not defined $got) {
+            die "error: $!";
+        } elsif ( $got == 0) {
+            die "EOF"
+        }
+        $ret .= $data;
+        if (length($ret) == $len) {
+            return $ret;
+        }
+    }
 }
 
 sub read_line {
     my $self   = shift;
-    my $socket = $self->socket;
+    my $socket = $self->read_socket;
 
-    my $ret = $socket->read( my $prefix, 4 );
-    if ( not defined $ret ) {
-        die "error: $!";
-    } elsif ( $ret == 0 ) {
-        die "EOF";
-    }
+    my $prefix = $self->read( 4 );
 
     return if $prefix eq '0000';
 
@@ -109,9 +130,7 @@ sub read_line {
         }
     }
 
-    #say "len $len";
-    $socket->read( my $data, $len - 4 ) || die $!;
-    return $data;
+    return $self->read( $len - 4 );
 }
 
 1;

lib/Git/PurePerl/Protocol/Git.pm

@@ -0,0 +1,31 @@
+package Git::PurePerl::Protocol::Git;
+use Moose;
+use MooseX::StrictConstructor;
+use Moose::Util::TypeConstraints;
+
+extends 'Git::PurePerl::Protocol';
+
+has 'hostname' => ( is => 'ro', isa => 'Str', required => 1 );
+has 'port'    => ( is => 'ro', isa => 'Int', required => 0, default => 9418 );
+has 'project' => ( is => 'rw', isa => 'Str', required => 1 );
+
+sub connect_socket {
+    my $self = shift;
+
+    my $socket = IO::Socket::INET->new(
+        PeerAddr => $self->hostname,
+        PeerPort => $self->port,
+        Proto    => 'tcp'
+    ) || die $! . ' ' . $self->hostname . ':' . $self->port;
+    $socket->autoflush(1) || die $!;
+    $self->read_socket($socket);
+    $self->write_socket($socket);
+
+    $self->send_line( "git-upload-pack "
+            . $self->project
+            . "\0host="
+            . $self->hostname
+            . "\0" );
+}
+
+1;

lib/Git/PurePerl/Protocol/SSH.pm

@@ -0,0 +1,31 @@
+package Git::PurePerl::Protocol::SSH;
+use Moose;
+use MooseX::StrictConstructor;
+use Moose::Util::TypeConstraints;
+use IPC::Open2;
+
+extends 'Git::PurePerl::Protocol';
+
+has 'hostname' => ( is => 'ro', isa => 'Str', required => 1 );
+has 'username' => ( is => 'ro', isa => 'Str', required => 0 );
+has 'path' => ( is => 'ro', isa => 'Str', required => 1 );
+
+sub connect_socket {
+    my $self = shift;
+
+    my ($read, $write);
+    my $connect = join('@', grep {defined} $self->username, $self->hostname);
+    my $pid = open2(
+        $read, $write,
+        "ssh", $connect,
+        "-o", "BatchMode yes",
+        "git-upload-pack", $self->path,
+    );
+
+    $read->autoflush(1);
+    $write->autoflush(1);
+    $self->read_socket($read);
+    $self->write_socket($write);
+}
+
+1;