1package Git::Packet; 2use 5.008; 3use strict; 4use warnings $ENV{GIT_PERL_FATAL_WARNINGS} ? qw(FATAL all) : (); 5BEGIN { 6 require Exporter; 7 if ($] < 5.008003) { 8 *import = \&Exporter::import; 9 } else { 10 # Exporter 5.57 which supports this invocation was 11 # released with perl 5.8.3 12 Exporter->import('import'); 13 } 14} 15 16our @EXPORT = qw( 17 packet_compare_lists 18 packet_bin_read 19 packet_txt_read 20 packet_key_val_read 21 packet_bin_write 22 packet_txt_write 23 packet_flush 24 packet_initialize 25 packet_read_capabilities 26 packet_read_and_check_capabilities 27 packet_check_and_write_capabilities 28 ); 29our @EXPORT_OK = @EXPORT; 30 31sub packet_compare_lists { 32 my ($expect, @result) = @_; 33 my $ix; 34 if (scalar @$expect != scalar @result) { 35 return undef; 36 } 37 for ($ix = 0; $ix < $#result; $ix++) { 38 if ($expect->[$ix] ne $result[$ix]) { 39 return undef; 40 } 41 } 42 return 1; 43} 44 45sub packet_bin_read { 46 my $buffer; 47 my $bytes_read = read STDIN, $buffer, 4; 48 if ( $bytes_read == 0 ) { 49 # EOF - Git stopped talking to us! 50 return ( -1, "" ); 51 } elsif ( $bytes_read != 4 ) { 52 die "invalid packet: '$buffer'"; 53 } 54 my $pkt_size = hex($buffer); 55 if ( $pkt_size == 0 ) { 56 return ( 1, "" ); 57 } elsif ( $pkt_size > 4 ) { 58 my $content_size = $pkt_size - 4; 59 $bytes_read = read STDIN, $buffer, $content_size; 60 if ( $bytes_read != $content_size ) { 61 die "invalid packet ($content_size bytes expected; $bytes_read bytes read)"; 62 } 63 return ( 0, $buffer ); 64 } else { 65 die "invalid packet size: $pkt_size"; 66 } 67} 68 69sub remove_final_lf_or_die { 70 my $buf = shift; 71 if ( $buf =~ s/\n$// ) { 72 return $buf; 73 } 74 die "A non-binary line MUST be terminated by an LF.\n" 75 . "Received: '$buf'"; 76} 77 78sub packet_txt_read { 79 my ( $res, $buf ) = packet_bin_read(); 80 if ( $res != -1 and $buf ne '' ) { 81 $buf = remove_final_lf_or_die($buf); 82 } 83 return ( $res, $buf ); 84} 85 86# Read a text packet, expecting that it is in the form "key=value" for 87# the given $key. An EOF does not trigger any error and is reported 88# back to the caller (like packet_txt_read() does). Die if the "key" 89# part of "key=value" does not match the given $key, or the value part 90# is empty. 91sub packet_key_val_read { 92 my ( $key ) = @_; 93 my ( $res, $buf ) = packet_txt_read(); 94 if ( $res == -1 or ( $buf =~ s/^$key=// and $buf ne '' ) ) { 95 return ( $res, $buf ); 96 } 97 die "bad $key: '$buf'"; 98} 99 100sub packet_bin_write { 101 my $buf = shift; 102 print STDOUT sprintf( "%04x", length($buf) + 4 ); 103 print STDOUT $buf; 104 STDOUT->flush(); 105} 106 107sub packet_txt_write { 108 packet_bin_write( $_[0] . "\n" ); 109} 110 111sub packet_flush { 112 print STDOUT sprintf( "%04x", 0 ); 113 STDOUT->flush(); 114} 115 116sub packet_initialize { 117 my ($name, $version) = @_; 118 119 packet_compare_lists([0, $name . "-client"], packet_txt_read()) || 120 die "bad initialize"; 121 packet_compare_lists([0, "version=" . $version], packet_txt_read()) || 122 die "bad version"; 123 packet_compare_lists([1, ""], packet_bin_read()) || 124 die "bad version end"; 125 126 packet_txt_write( $name . "-server" ); 127 packet_txt_write( "version=" . $version ); 128 packet_flush(); 129} 130 131sub packet_read_capabilities { 132 my @cap; 133 while (1) { 134 my ( $res, $buf ) = packet_bin_read(); 135 if ( $res == -1 ) { 136 die "unexpected EOF when reading capabilities"; 137 } 138 return ( $res, @cap ) if ( $res != 0 ); 139 $buf = remove_final_lf_or_die($buf); 140 unless ( $buf =~ s/capability=// ) { 141 die "bad capability buf: '$buf'"; 142 } 143 push @cap, $buf; 144 } 145} 146 147# Read remote capabilities and check them against capabilities we require 148sub packet_read_and_check_capabilities { 149 my @required_caps = @_; 150 my ($res, @remote_caps) = packet_read_capabilities(); 151 my %remote_caps = map { $_ => 1 } @remote_caps; 152 foreach (@required_caps) { 153 unless (exists($remote_caps{$_})) { 154 die "required '$_' capability not available from remote" ; 155 } 156 } 157 return %remote_caps; 158} 159 160# Check our capabilities we want to advertise against the remote ones 161# and then advertise our capabilities 162sub packet_check_and_write_capabilities { 163 my ($remote_caps, @our_caps) = @_; 164 foreach (@our_caps) { 165 unless (exists($remote_caps->{$_})) { 166 die "our capability '$_' is not available from remote" 167 } 168 packet_txt_write( "capability=" . $_ ); 169 } 170 packet_flush(); 171} 172 1731; 174