Skip to content

Commit 2a1d1b1

Browse files
bobtfishbobtfish
committed
Merge branch 'ssh'
* ssh: Add autoclean Support the file:// protocol, as well Parse ssh:// urls as well SSH protocol support, via IPC::Open2
2 parents 80fc29d + 8920c18 commit 2a1d1b1

File tree

5 files changed

+157
-30
lines changed

5 files changed

+157
-30
lines changed

‎lib/Git/PurePerl.pm

Lines changed: 13 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -439,10 +439,20 @@ sub checkout {
439439
}
440440

441441
sub clone {
442-
my ( $self, $hostname, $project ) = @_;
442+
my $self = shift;
443+
444+
my $remote;
445+
if (@_ == 2) {
446+
# For backwards compatibility
447+
$remote = "git://$_[0]";
448+
$remote .= "/" unless $_[1] =~ m{^/};
449+
$remote .= $_[1];
450+
} else {
451+
$remote = shift;
452+
}
453+
443454
my $protocol = Git::PurePerl::Protocol->new(
444-
hostname => $hostname,
445-
project => $project,
455+
remote => $remote,
446456
);
447457

448458
my $sha1s = $protocol->connect;

‎lib/Git/PurePerl/Protocol.pm

Lines changed: 52 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -4,27 +4,39 @@ use MooseX::StrictConstructor;
44
use Moose::Util::TypeConstraints;
55
use namespace::autoclean;
66

7-
has 'hostname' => ( is => 'ro', isa => 'Str', required => 1 );
8-
has 'port' => ( is => 'ro', isa => 'Int', required => 0, default => 9418 );
9-
has 'project' => ( is => 'ro', isa => 'Str', required => 1 );
10-
has 'socket' => ( is => 'rw', isa => 'IO::Socket', required => 0 );
7+
use Git::PurePerl::Protocol::Git;
8+
use Git::PurePerl::Protocol::SSH;
9+
use Git::PurePerl::Protocol::File;
10+
11+
has 'remote' => ( is => 'ro', isa => 'Str', required => 1 );
12+
has 'read_socket' => ( is => 'rw', required => 0 );
13+
has 'write_socket' => ( is => 'rw', required => 0 );
1114

1215
sub connect {
1316
my $self = shift;
1417

15-
my $socket = IO::Socket::INET->new(
16-
PeerAddr => $self->hostname,
17-
PeerPort => $self->port,
18-
Proto => 'tcp'
19-
) || die $! . ' ' . $self->hostname . ':' . $self->port;
20-
$socket->autoflush(1) || die $!;
21-
$self->socket($socket);
18+
if ($self->remote =~ m{^git://(.*?@)?(.*?)(/.*)}) {
19+
Git::PurePerl::Protocol::Git->meta->rebless_instance(
20+
$self,
21+
hostname => $2,
22+
project => $3,
23+
);
24+
} elsif ($self->remote =~ m{^file://(/.*)}) {
25+
Git::PurePerl::Protocol::File->meta->rebless_instance(
26+
$self,
27+
path => $1,
28+
);
29+
} elsif ($self->remote =~ m{^ssh://(?:(.*?)@)?(.*?)(/.*)}
30+
or $self->remote =~ m{^(?:(.*?)@)?(.*?):(.*)}) {
31+
Git::PurePerl::Protocol::SSH->meta->rebless_instance(
32+
$self,
33+
$1 ? (username => $1) : (),
34+
hostname => $2,
35+
path => $3,
36+
);
37+
}
2238

23-
$self->send_line( "git-upload-pack "
24-
. $self->project
25-
. "\0host="
26-
. $self->hostname
27-
. "\0" );
39+
$self->connect_socket;
2840

2941
my %sha1s;
3042
while ( my $line = $self->read_line() ) {
@@ -78,19 +90,34 @@ sub send_line {
7890
my $text = $prefix . $line;
7991

8092
# warn "$text";
81-
$self->socket->print($text) || die $!;
93+
$self->write_socket->print($text) || die $!;
94+
}
95+
96+
sub read {
97+
my $self = shift;
98+
my $len = shift;
99+
100+
my $ret = "";
101+
use bytes;
102+
while (1) {
103+
my $got = $self->read_socket->read( my $data, $len - length($ret));
104+
if (not defined $got) {
105+
die "error: $!";
106+
} elsif ( $got == 0) {
107+
die "EOF"
108+
}
109+
$ret .= $data;
110+
if (length($ret) == $len) {
111+
return $ret;
112+
}
113+
}
82114
}
83115

84116
sub read_line {
85117
my $self = shift;
86-
my $socket = $self->socket;
118+
my $socket = $self->read_socket;
87119

88-
my $ret = $socket->read( my $prefix, 4 );
89-
if ( not defined $ret ) {
90-
die "error: $!";
91-
} elsif ( $ret == 0 ) {
92-
die "EOF";
93-
}
120+
my $prefix = $self->read( 4 );
94121

95122
return if $prefix eq '0000';
96123

@@ -110,9 +137,7 @@ sub read_line {
110137
}
111138
}
112139

113-
#say "len $len";
114-
$socket->read( my $data, $len - 4 ) || die $!;
115-
return $data;
140+
return $self->read( $len - 4 );
116141
}
117142

118143
__PACKAGE__->meta->make_immutable;

‎lib/Git/PurePerl/Protocol/File.pm

Lines changed: 28 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,28 @@
1+
package Git::PurePerl::Protocol::File;
2+
use Moose;
3+
use MooseX::StrictConstructor;
4+
use Moose::Util::TypeConstraints;
5+
use IPC::Open2;
6+
use namespace::autoclean;
7+
8+
extends 'Git::PurePerl::Protocol';
9+
10+
has 'path' => ( is => 'ro', isa => 'Str', required => 1 );
11+
12+
sub connect_socket {
13+
my $self = shift;
14+
15+
my ($read, $write);
16+
my $pid = open2(
17+
$read, $write,
18+
"git-upload-pack",
19+
$self->path,
20+
);
21+
22+
$read->autoflush(1);
23+
$write->autoflush(1);
24+
$self->read_socket($read);
25+
$self->write_socket($write);
26+
}
27+
28+
1;

‎lib/Git/PurePerl/Protocol/Git.pm

Lines changed: 32 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,32 @@
1+
package Git::PurePerl::Protocol::Git;
2+
use Moose;
3+
use MooseX::StrictConstructor;
4+
use Moose::Util::TypeConstraints;
5+
use namespace::autoclean;
6+
7+
extends 'Git::PurePerl::Protocol';
8+
9+
has 'hostname' => ( is => 'ro', isa => 'Str', required => 1 );
10+
has 'port' => ( is => 'ro', isa => 'Int', required => 0, default => 9418 );
11+
has 'project' => ( is => 'rw', isa => 'Str', required => 1 );
12+
13+
sub connect_socket {
14+
my $self = shift;
15+
16+
my $socket = IO::Socket::INET->new(
17+
PeerAddr => $self->hostname,
18+
PeerPort => $self->port,
19+
Proto => 'tcp'
20+
) || die $! . ' ' . $self->hostname . ':' . $self->port;
21+
$socket->autoflush(1) || die $!;
22+
$self->read_socket($socket);
23+
$self->write_socket($socket);
24+
25+
$self->send_line( "git-upload-pack "
26+
. $self->project
27+
. "\0host="
28+
. $self->hostname
29+
. "\0" );
30+
}
31+
32+
1;

‎lib/Git/PurePerl/Protocol/SSH.pm

Lines changed: 32 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,32 @@
1+
package Git::PurePerl::Protocol::SSH;
2+
use Moose;
3+
use MooseX::StrictConstructor;
4+
use Moose::Util::TypeConstraints;
5+
use IPC::Open2;
6+
use namespace::autoclean;
7+
8+
extends 'Git::PurePerl::Protocol';
9+
10+
has 'hostname' => ( is => 'ro', isa => 'Str', required => 1 );
11+
has 'username' => ( is => 'ro', isa => 'Str', required => 0 );
12+
has 'path' => ( is => 'ro', isa => 'Str', required => 1 );
13+
14+
sub connect_socket {
15+
my $self = shift;
16+
17+
my ($read, $write);
18+
my $connect = join('@', grep {defined} $self->username, $self->hostname);
19+
my $pid = open2(
20+
$read, $write,
21+
"ssh", $connect,
22+
"-o", "BatchMode yes",
23+
"git-upload-pack", $self->path,
24+
);
25+
26+
$read->autoflush(1);
27+
$write->autoflush(1);
28+
$self->read_socket($read);
29+
$self->write_socket($write);
30+
}
31+
32+
1;

0 commit comments

Comments
 (0)