local-lib5/lib/perl5/Git/PurePerl/Protocol.pm

   1 package Git::PurePerl::Protocol;
   2 use Moose;
   3 use MooseX::StrictConstructor;
   4 use Moose::Util::TypeConstraints;
   5 use namespace::autoclean;
   6
   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 );
  11
  12 sub connect {
  13     my $self = shift;
  14
  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);
  22
  23     $self->send_line( "git-upload-pack "
  24             . $self->project
  25             . "\0host="
  26             . $self->hostname
  27             . "\0" );
  28
  29     my %sha1s;
  30     while ( my $line = $self->read_line() ) {
  31
  32         # warn "S $line";
  33         my ( $sha1, $name ) = $line =~ /^([a-z0-9]+) ([^\0\n]+)/;
  34
  35         #use YAML; warn Dump $line;
  36         $sha1s{$name} = $sha1;
  37     }
  38     return \%sha1s;
  39 }
  40
  41 sub fetch_pack {
  42     my ( $self, $sha1 ) = @_;
  43     $self->send_line("want $sha1 side-band-64k\n");
  44
  45 #send_line(
  46 #    "want 0c7b3d23c0f821e58cd20e60d5e63f5ed12ef391 multi_ack side-band-64k ofs-delta\n"
  47 #);
  48     $self->send_line('');
  49     $self->send_line('done');
  50
  51     my $pack;
  52
  53     while ( my $line = $self->read_line() ) {
  54         if ( $line =~ s/^\x02// ) {
  55             print $line;
  56         } elsif ( $line =~ /^NAK\n/ ) {
  57         } elsif ( $line =~ s/^\x01// ) {
  58             $pack .= $line;
  59         } else {
  60             die "Unknown line: $line";
  61         }
  62
  63         #say "s $line";
  64     }
  65     return $pack;
  66 }
  67
  68 sub send_line {
  69     my ( $self, $line ) = @_;
  70     my $length = length($line);
  71     if ( $length == 0 ) {
  72     } else {
  73         $length += 4;
  74     }
  75
  76     #warn "length $length";
  77     my $prefix = sprintf( "%04X", $length );
  78     my $text = $prefix . $line;
  79
  80     # warn "$text";
  81     $self->socket->print($text) || die $!;
  82 }
  83
  84 sub read_line {
  85     my $self   = shift;
  86     my $socket = $self->socket;
  87
  88     my $ret = $socket->read( my $prefix, 4 );
  89     if ( not defined $ret ) {
  90         die "error: $!";
  91     } elsif ( $ret == 0 ) {
  92         die "EOF";
  93     }
  94
  95     return if $prefix eq '0000';
  96
  97     # warn "read prefix [$prefix]";
  98
  99     my $len = 0;
 100     foreach my $n ( 0 .. 3 ) {
 101         my $c = substr( $prefix, $n, 1 );
 102         $len <<= 4;
 103
 104         if ( $c ge '0' && $c le '9' ) {
 105             $len += ord($c) - ord('0');
 106         } elsif ( $c ge 'a' && $c le 'f' ) {
 107             $len += ord($c) - ord('a') + 10;
 108         } elsif ( $c ge 'A' && $c le 'F' ) {
 109             $len += ord($c) - ord('A') + 10;
 110         }
 111     }
 112
 113     #say "len $len";
 114     $socket->read( my $data, $len - 4 ) || die $!;
 115     return $data;
 116 }
 117
 118 __PACKAGE__->meta->make_immutable;