]>
Commit | Line | Data |
---|---|---|
0fe8d516 CC |
1 | package Git::Packet; |
2 | use 5.008; | |
3 | use strict; | |
4 | use warnings; | |
5 | BEGIN { | |
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 | ||
16 | our @EXPORT = qw( | |
17 | packet_compare_lists | |
18 | packet_bin_read | |
19 | packet_txt_read | |
cb1c64b4 | 20 | packet_key_val_read |
0fe8d516 CC |
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 | ); | |
29 | our @EXPORT_OK = @EXPORT; | |
30 | ||
31 | sub 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 | ||
45 | sub 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 | ||
69 | sub remove_final_lf_or_die { | |
70 | my $buf = shift; | |
4a543708 CC |
71 | if ( $buf =~ s/\n$// ) { |
72 | return $buf; | |
0fe8d516 | 73 | } |
4a543708 CC |
74 | die "A non-binary line MUST be terminated by an LF.\n" |
75 | . "Received: '$buf'"; | |
0fe8d516 CC |
76 | } |
77 | ||
78 | sub packet_txt_read { | |
79 | my ( $res, $buf ) = packet_bin_read(); | |
4a543708 | 80 | if ( $res != -1 and $buf ne '' ) { |
0fe8d516 CC |
81 | $buf = remove_final_lf_or_die($buf); |
82 | } | |
83 | return ( $res, $buf ); | |
84 | } | |
85 | ||
cb1c64b4 CC |
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. | |
91 | sub packet_key_val_read { | |
0fe8d516 CC |
92 | my ( $key ) = @_; |
93 | my ( $res, $buf ) = packet_txt_read(); | |
4a543708 CC |
94 | if ( $res == -1 or ( $buf =~ s/^$key=// and $buf ne '' ) ) { |
95 | return ( $res, $buf ); | |
0fe8d516 | 96 | } |
4a543708 | 97 | die "bad $key: '$buf'"; |
0fe8d516 CC |
98 | } |
99 | ||
100 | sub packet_bin_write { | |
101 | my $buf = shift; | |
102 | print STDOUT sprintf( "%04x", length($buf) + 4 ); | |
103 | print STDOUT $buf; | |
104 | STDOUT->flush(); | |
105 | } | |
106 | ||
107 | sub packet_txt_write { | |
108 | packet_bin_write( $_[0] . "\n" ); | |
109 | } | |
110 | ||
111 | sub packet_flush { | |
112 | print STDOUT sprintf( "%04x", 0 ); | |
113 | STDOUT->flush(); | |
114 | } | |
115 | ||
116 | sub 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 | ||
131 | sub 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 | |
148 | sub 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 | |
162 | sub 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 | ||
173 | 1; |