File Coverage

blib/lib/NetPacket/TCP.pm
Criterion Covered Total %
statement 109 138 78.9
branch 16 22 72.7
condition n/a
subroutine 15 18 83.3
pod 4 6 66.6
total 144 184 78.2


line stmt bran cond sub pod time code
1             package NetPacket::TCP;
2             our $AUTHORITY = 'cpan:YANICK';
3             # ABSTRACT: Assemble and disassemble TCP (Transmission Control Protocol) packets.
4             $NetPacket::TCP::VERSION = '1.7.2';
5 3     3   71695 use strict;
  3         15  
  3         126  
6 3     3   16 use warnings;
  3         6  
  3         82  
7              
8 3     3   434 use parent 'NetPacket';
  3         323  
  3         15  
9              
10             # TCP Flags
11              
12 3     3   155 use constant FIN => 0x01;
  3         20  
  3         214  
13 3     3   18 use constant SYN => 0x02;
  3         6  
  3         166  
14 3     3   19 use constant RST => 0x04;
  3         6  
  3         132  
15 3     3   17 use constant PSH => 0x08;
  3         6  
  3         143  
16 3     3   18 use constant ACK => 0x10;
  3         13  
  3         204  
17 3     3   30 use constant URG => 0x20;
  3         6  
  3         194  
18 3     3   21 use constant ECE => 0x40;
  3         5  
  3         158  
19 3     3   18 use constant CWR => 0x80;
  3         6  
  3         1710  
20              
21             our @EXPORT = qw(FIN SYN RST PSH ACK URG ECE CWR);
22              
23             our @EXPORT_OK = qw(tcp_strip );
24              
25             our %EXPORT_TAGS = (
26             ALL => [@EXPORT, @EXPORT_OK],
27             strip => [qw(tcp_strip)],
28             );
29              
30             #
31             # Strip header from packet and return the data contained in it
32             #
33              
34             sub tcp_strip {
35 0     0 0 0 goto \&strip;
36             }
37              
38             sub strip {
39 0     0 1 0 my ($pkt) = @_;
40              
41 0         0 my $tcp_obj = NetPacket::TCP->decode($pkt);
42 0         0 return $tcp_obj->{data};
43             }
44              
45             #
46             # Decode the packet
47             #
48              
49             sub decode {
50 3     3 1 16 my $class = shift;
51 3         8 my($pkt, $parent) = @_;
52 3         5 my $self = {};
53              
54             # Class fields
55              
56 3         7 $self->{_parent} = $parent;
57 3         5 $self->{_frame} = $pkt;
58              
59             # Decode TCP packet
60              
61 3 50       8 if (defined($pkt)) {
62 3         4 my $tmp;
63              
64             ($self->{src_port}, $self->{dest_port}, $self->{seqnum},
65             $self->{acknum}, $tmp, $self->{winsize}, $self->{cksum},
66 3         19 $self->{urg}, $self->{options}) =
67             unpack("nnNNnnnna*", $pkt);
68              
69             # Extract flags
70              
71 3         8 $self->{hlen} = ($tmp & 0xf000) >> 12;
72 3         5 $self->{reserved} = ($tmp & 0x0f00) >> 8;
73 3         5 $self->{flags} = $tmp & 0x00ff;
74              
75             # Decode variable length header and remaining data
76              
77 3         6 my $olen = $self->{hlen} - 5;
78 3 50       7 $olen = 0 if $olen < 0; # Check for bad hlen
79              
80             # Option length is number of 32 bit words
81              
82 3         5 $olen *= 4;
83              
84             ( $self->{options}, $self->{data} )
85 3         13 = unpack( 'a' . $olen . 'a*', $self->{options});
86             }
87              
88             # Return a blessed object
89              
90 3         5 bless($self, $class);
91 3         18 return $self;
92             }
93              
94             #
95             # Encode a packet
96             #
97              
98             sub encode {
99              
100 0     0 1 0 my $self = shift;
101 0         0 my ($ip) = @_;
102 0         0 my ($packet,$tmp);
103              
104             # First of all, fix the checksum
105 0         0 $self->checksum($ip);
106              
107 0         0 $tmp = $self->{hlen} << 12;
108 0         0 $tmp = $tmp | (0x0f00 & ($self->{reserved} << 8));
109 0         0 $tmp = $tmp | (0x00ff & $self->{flags});
110              
111             # Put the packet together
112             $packet = pack('n n N N n n n n a* a*',
113             $self->{src_port}, $self->{dest_port}, $self->{seqnum},
114             $self->{acknum}, $tmp, $self->{winsize}, $self->{cksum},
115 0         0 $self->{urg}, $self->{options},$self->{data});
116              
117              
118 0         0 return($packet);
119              
120             }
121              
122             #
123             # TCP Checksum
124             #
125              
126             sub checksum {
127              
128 2     2 0 96 my $self = shift;
129 2         4 my ($ip) = @_;
130 2         8 my ($packet,$zero,$tcplen,$tmp);
131 2         0 my ($src_ip, $dest_ip,$proto);
132              
133 2         4 $zero = 0;
134 2         4 $proto = 6;
135 2         11 $tcplen = ($self->{hlen} * 4)+ length($self->{data});
136              
137 3     3   25 no warnings qw/ uninitialized /;
  3         13  
  3         1913  
138 2         5 $tmp = $self->{hlen} << 12;
139 2         6 $tmp = $tmp | (0x0f00 & ($self->{reserved} << 8));
140 2         4 $tmp = $tmp | (0x00ff & $self->{flags});
141              
142             # Pack pseudo-header for tcp checksum
143              
144 2 50       16 if ($ip->isa('NetPacket::IPv6')) {
145 0         0 $packet = $ip->pseudo_header($tcplen, $proto);
146             } else {
147 2         95 $src_ip = gethostbyname($ip->{src_ip});
148 2         51 $dest_ip = gethostbyname($ip->{dest_ip});
149              
150 2         17 $packet = pack('a4a4nn',$src_ip,$dest_ip,$proto,$tcplen);
151             }
152              
153             $packet .= pack('nnNNnnnna*a*',
154             $self->{src_port}, $self->{dest_port}, $self->{seqnum},
155             $self->{acknum}, $tmp, $self->{winsize}, $zero,
156 2         13 $self->{urg}, $self->{options},$self->{data});
157              
158             # pad packet if odd-sized
159 2 100       8 $packet .= "\x00" if length( $packet ) % 2;
160              
161 2         8 $self->{cksum} = NetPacket::htons(NetPacket::in_cksum($packet));
162             }
163              
164             sub parse_tcp_options {
165             #
166             # dissect tcp options header. see:
167             # http://www.networksorcery.com/enp/protocol/tcp.htm#Options
168             #
169             # we create an byte array from the options header
170             # and iterate through that. If we find an option
171             # kind number we act accordingly (sometimes it has
172             # a fixed length, sometimes a variable one).
173             # once we've got the option stored, we shift the
174             # bytes we fetched away from the byte array and
175             # re-enter the loop.
176              
177 2     2 1 660 my $self = shift;
178              
179 2         8 my $opts = $self->{options};
180 2         11 my @bytes = split //, $opts;
181 2         4 my %options;
182             my $size;
183 10         15 ENTRY:
184             $size = $#bytes;
185 10         19 foreach my $byte (@bytes) {
186 8         15 my $kind = unpack('C', $byte);
187 8 100       28 if($kind == 2) {
    100          
    100          
    100          
    50          
    50          
188             # MSS.
189             # next byte is size, set to 4
190             # next 2 bytes are mss value 16 bit unsigned short
191 1         3 $options{mss} = unpack('n', $bytes[2] . $bytes[3]);
192 1         2 shift @bytes;
193 1         2 shift @bytes;
194 1         2 shift @bytes;
195 1         1 shift @bytes;
196 1         58 goto ENTRY;
197             }
198             elsif ($kind == 1) {
199             # a noop
200 3         5 shift @bytes;
201 3         39 goto ENTRY;
202             }
203             elsif ($kind == 3) {
204             # Windows Scale Factor
205             # next byte is size, set to 3
206             # next byte is shift count, 8 bit unsigned
207 1         2 $options{ws} = unpack('C', $bytes[2]);
208 1         2 shift @bytes;
209 1         1 shift @bytes;
210 1         2 shift @bytes;
211 1         7 goto ENTRY;
212             }
213             elsif ($kind == 4) {
214             # SACK Permitted
215             # next byte is length
216 1         2 $options{sack} = unpack('C', $bytes[1]);
217 1         2 shift @bytes;
218 1         2 shift @bytes;
219 1         8 goto ENTRY;
220             }
221             elsif ($kind == 5) {
222             # SACK Blocks
223             # next byte is length, 2 + (number of blocks * 8)
224             # in every block,
225             # former 4 bytes is SACK left edge, 32 bit unsigned int
226             # latter 4 bytes is SACK right edge, 32 bit unsigned int
227 0         0 my $block_num = (unpack('C', $bytes[1]) - 2) / 8;
228 0         0 shift @bytes;
229 0         0 shift @bytes;
230 0         0 my @sack_blocks;
231 0         0 for (1..$block_num) {
232 0         0 push @sack_blocks, [unpack('N', join '', @bytes[0..3]),
233             unpack('N', join '', @bytes[4..7])];
234 0         0 shift @bytes;
235 0         0 shift @bytes;
236 0         0 shift @bytes;
237 0         0 shift @bytes;
238 0         0 shift @bytes;
239 0         0 shift @bytes;
240 0         0 shift @bytes;
241 0         0 shift @bytes;
242             }
243 0         0 $options{sack_blocks} = \@sack_blocks;
244             }
245             elsif ($kind == 8) {
246             # timestamp
247             # next byte is length, set to 10
248             # next 4 byte is timestamp, 32 bit unsigned int
249             # next 4 byte is timestamp echo reply, 32 bit unsigned int
250 2         7 $options{ts} = unpack('N', join '', @bytes[2..5]);
251 2         5 $options{er} = unpack('N', join '', @bytes[6,7,8,9]);
252 2         4 shift @bytes;
253 2         2 shift @bytes;
254 2         3 shift @bytes;
255 2         3 shift @bytes;
256 2         3 shift @bytes;
257 2         3 shift @bytes;
258 2         2 shift @bytes;
259 2         3 shift @bytes;
260 2         3 shift @bytes;
261 2         3 shift @bytes;
262 2         16 goto ENTRY;
263             }
264             }
265 2 50       16 return wantarray ? %options : \%options;
266             }
267             #
268             # Module initialisation
269             #
270              
271             1;
272              
273             # autoloaded methods go after the END token (&& pod) below
274              
275             __END__