Add built local::lib

[catagits/Gitalist.git] / local-lib5 / lib / perl5 / Git / PurePerl / Protocol.pm

diff --git a/local-lib5/lib/perl5/Git/PurePerl/Protocol.pm b/local-lib5/lib/perl5/Git/PurePerl/Protocol.pm
new file mode 100644 (file)
index 0000000..e5bee9d
--- /dev/null
+++ b/local-lib5/lib/perl5/Git/PurePerl/Protocol.pm
@@ -0,0 +1,118 @@
+package Git::PurePerl::Protocol;
+use Moose;
+use MooseX::StrictConstructor;
+use Moose::Util::TypeConstraints;
+use namespace::autoclean;
+
+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 );
+
+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);
+
+    $self->send_line( "git-upload-pack "
+            . $self->project
+            . "\0host="
+            . $self->hostname
+            . "\0" );
+
+    my %sha1s;
+    while ( my $line = $self->read_line() ) {
+
+        # warn "S $line";
+        my ( $sha1, $name ) = $line =~ /^([a-z0-9]+) ([^\0\n]+)/;
+
+        #use YAML; warn Dump $line;
+        $sha1s{$name} = $sha1;
+    }
+    return \%sha1s;
+}
+
+sub fetch_pack {
+    my ( $self, $sha1 ) = @_;
+    $self->send_line("want $sha1 side-band-64k\n");
+
+#send_line(
+#    "want 0c7b3d23c0f821e58cd20e60d5e63f5ed12ef391 multi_ack side-band-64k ofs-delta\n"
+#);
+    $self->send_line('');
+    $self->send_line('done');
+
+    my $pack;
+
+    while ( my $line = $self->read_line() ) {
+        if ( $line =~ s/^\x02// ) {
+            print $line;
+        } elsif ( $line =~ /^NAK\n/ ) {
+        } elsif ( $line =~ s/^\x01// ) {
+            $pack .= $line;
+        } else {
+            die "Unknown line: $line";
+        }
+
+        #say "s $line";
+    }
+    return $pack;
+}
+
+sub send_line {
+    my ( $self, $line ) = @_;
+    my $length = length($line);
+    if ( $length == 0 ) {
+    } else {
+        $length += 4;
+    }
+
+    #warn "length $length";
+    my $prefix = sprintf( "%04X", $length );
+    my $text = $prefix . $line;
+
+    # warn "$text";
+    $self->socket->print($text) || die $!;
+}
+
+sub read_line {
+    my $self   = shift;
+    my $socket = $self->socket;
+
+    my $ret = $socket->read( my $prefix, 4 );
+    if ( not defined $ret ) {
+        die "error: $!";
+    } elsif ( $ret == 0 ) {
+        die "EOF";
+    }
+
+    return if $prefix eq '0000';
+
+    # warn "read prefix [$prefix]";
+
+    my $len = 0;
+    foreach my $n ( 0 .. 3 ) {
+        my $c = substr( $prefix, $n, 1 );
+        $len <<= 4;
+
+        if ( $c ge '0' && $c le '9' ) {
+            $len += ord($c) - ord('0');
+        } elsif ( $c ge 'a' && $c le 'f' ) {
+            $len += ord($c) - ord('a') + 10;
+        } elsif ( $c ge 'A' && $c le 'F' ) {
+            $len += ord($c) - ord('A') + 10;
+        }
+    }
+
+    #say "len $len";
+    $socket->read( my $data, $len - 4 ) || die $!;
+    return $data;
+}
+
+__PACKAGE__->meta->make_immutable;