File Coverage

blib/lib/Net/Frame/Layer/TCP.pm
Criterion Covered Total %
statement 80 124 64.5
branch 8 42 19.0
condition 1 8 12.5
subroutine 21 26 80.7
pod 12 12 100.0
total 122 212 57.5


line stmt bran cond sub pod time code
1             #
2             # $Id: TCP.pm,v 7609c9d085d3 2018/03/15 15:17:19 gomor $
3             #
4             package Net::Frame::Layer::TCP;
5 2     2   7371 use strict; use warnings;
  2     2   11  
  2         62  
  2         8  
  2         4  
  2         88  
6              
7 2     2   481 use Net::Frame::Layer qw(:consts :subs);
  2         6  
  2         406  
8 2     2   16 use Exporter;
  2         4  
  2         289  
9             our @ISA = qw(Net::Frame::Layer Exporter);
10              
11             our %EXPORT_TAGS = (
12             consts => [qw(
13             NF_TCP_HDR_LEN
14             NF_TCP_FLAGS_FIN
15             NF_TCP_FLAGS_SYN
16             NF_TCP_FLAGS_RST
17             NF_TCP_FLAGS_PSH
18             NF_TCP_FLAGS_ACK
19             NF_TCP_FLAGS_URG
20             NF_TCP_FLAGS_ECE
21             NF_TCP_FLAGS_CWR
22             )],
23             );
24             our @EXPORT_OK = (
25             @{$EXPORT_TAGS{consts}},
26             );
27              
28 2     2   15 use constant NF_TCP_HDR_LEN => 20;
  2         5  
  2         110  
29 2     2   13 use constant NF_TCP_FLAGS_FIN => 0x01;
  2         11  
  2         93  
30 2     2   12 use constant NF_TCP_FLAGS_SYN => 0x02;
  2         3  
  2         90  
31 2     2   11 use constant NF_TCP_FLAGS_RST => 0x04;
  2         5  
  2         80  
32 2     2   10 use constant NF_TCP_FLAGS_PSH => 0x08;
  2         4  
  2         94  
33 2     2   20 use constant NF_TCP_FLAGS_ACK => 0x10;
  2         5  
  2         105  
34 2     2   12 use constant NF_TCP_FLAGS_URG => 0x20;
  2         4  
  2         82  
35 2     2   11 use constant NF_TCP_FLAGS_ECE => 0x40;
  2         3  
  2         110  
36 2     2   14 use constant NF_TCP_FLAGS_CWR => 0x80;
  2         5  
  2         211  
37              
38             our @AS = qw(
39             src
40             dst
41             flags
42             win
43             seq
44             ack
45             off
46             x2
47             checksum
48             urp
49             options
50             );
51             __PACKAGE__->cgBuildIndices;
52             __PACKAGE__->cgBuildAccessorsScalar(\@AS);
53              
54 2     2   14 no strict 'vars';
  2         4  
  2         2948  
55              
56             sub new {
57 1     1 1 13 my $self = shift->SUPER::new(
58             src => getRandomHighPort(),
59             dst => 0,
60             seq => getRandom32bitsInt(),
61             ack => 0,
62             x2 => 0,
63             off => 0,
64             flags => NF_TCP_FLAGS_SYN,
65             win => 0xffff,
66             checksum => 0,
67             urp => 0,
68             options => '',
69             @_,
70             );
71              
72 1         417 return $self;
73             }
74              
75             sub pack {
76 1     1 1 5 my $self = shift;
77              
78 1         9 my $offX2Flags = ($self->[$__off] << 12)|(0x0f00 & ($self->[$__x2] << 8))
79             |(0x00ff & $self->[$__flags]);
80              
81 1 50       7 $self->[$__raw] = $self->SUPER::pack('nnNNnnnn',
82             $self->[$__src],
83             $self->[$__dst],
84             $self->[$__seq],
85             $self->[$__ack],
86             $offX2Flags,
87             $self->[$__win],
88             $self->[$__checksum],
89             $self->[$__urp],
90             ) or return;
91              
92 1 50       3 if ($self->[$__options]) {
93 0 0       0 $self->[$__raw] =
94             $self->[$__raw].$self->SUPER::pack('a*', $self->[$__options])
95             or return;
96             }
97              
98 1         2 return $self->[$__raw];
99             }
100              
101             sub unpack {
102 1     1 1 5 my $self = shift;
103              
104             # Pad it if less than the required length
105 1 50       4 if (length($self->[$__raw]) < NF_TCP_HDR_LEN) {
106 0         0 $self->[$__raw] .= ("\x00" x (NF_TCP_HDR_LEN - length($self->[$__raw])));
107             }
108              
109 1 50       7 my ($src, $dst, $seq, $ack, $offX2Flags, $win, $checksum, $urp, $payload) =
110             $self->SUPER::unpack('nnNNnnnn a*', $self->[$__raw])
111             or return;
112              
113 1         4 $self->[$__src] = $src;
114 1         3 $self->[$__dst] = $dst;
115 1         1 $self->[$__seq] = $seq;
116 1         2 $self->[$__ack] = $ack;
117 1         12 $self->[$__off] = ($offX2Flags & 0xf000) >> 12;
118 1         3 $self->[$__x2] = ($offX2Flags & 0x0f00) >> 8;
119 1         2 $self->[$__flags] = $offX2Flags & 0x00ff;
120 1         2 $self->[$__win] = $win;
121 1         1 $self->[$__checksum] = $checksum;
122 1         2 $self->[$__urp] = $urp;
123 1         2 $self->[$__payload] = $payload;
124              
125 1 50       3 my ($options, $payload2) = $self->SUPER::unpack(
126             'a'. $self->getOptionsLength. 'a*', $self->[$__payload]
127             ) or return;
128              
129 1         2 $self->[$__options] = $options;
130 1         2 $self->[$__payload] = $payload2;
131              
132 1         3 return $self;
133             }
134              
135 1 50   1 1 2 sub getLength { my $self = shift; $self->[$__off] ? $self->[$__off] * 4 : 0 }
  1         2  
136              
137             sub getOptionsLength {
138 1     1 1 2 my $self = shift;
139 1         3 my $gLen = $self->getLength;
140 1         3 my $hLen = NF_TCP_HDR_LEN;
141 1 50       6 return $gLen > $hLen ? $gLen - $hLen : 0;
142             }
143              
144             sub computeLengths {
145 0     0 1 0 my $self = shift;
146              
147 0   0     0 my $optLen = ($self->[$__options] && length($self->[$__options])) || 0;
148              
149 0         0 my $hLen = NF_TCP_HDR_LEN;
150 0         0 $self->[$__off] = ($hLen + $optLen) / 4;
151              
152 0         0 return 1;
153             }
154              
155             sub computeChecksums {
156 0     0 1 0 my $self = shift;
157 0         0 my ($layers) = @_;
158              
159 0         0 my $len = $self->getLength;
160              
161 0         0 my $start = 0;
162 0         0 my $last = $self;
163 0         0 my $payload = '';
164 0         0 for my $l (@$layers) {
165 0         0 $last = $l;
166 0 0       0 if (! $start) {
167 0 0       0 $start++ if $l->layer eq 'TCP';
168 0         0 next;
169             }
170 0         0 $len += $l->getLength;
171 0         0 $payload .= $l->pack;
172             }
173              
174 0 0 0     0 if (defined($last->payload) && length($last->payload)) {
175 0         0 $len += length($last->payload);
176 0         0 $payload .= $last->payload;
177             }
178              
179 0         0 my $phpkt;
180 0         0 for my $l (@$layers) {
181 0 0       0 if ($l->layer eq 'IPv4') {
    0          
182 0         0 $phpkt = $self->SUPER::pack('a4a4CCn',
183             inetAton($l->src), inetAton($l->dst), 0, 6, $len);
184             }
185             elsif ($l->layer eq 'IPv6') {
186 0         0 $phpkt = $self->SUPER::pack('a*a*NnCC',
187             inet6Aton($l->src), inet6Aton($l->dst), $len, 0, 0, 6);
188             }
189             }
190              
191 0         0 my $offX2Flags = ($self->[$__off] << 12) | (0x0f00 & ($self->[$__x2] << 8))
192             | (0x00ff & $self->[$__flags]);
193              
194 0 0       0 $phpkt .= $self->SUPER::pack('nnNNnnnn',
195             $self->[$__src], $self->[$__dst], $self->[$__seq], $self->[$__ack],
196             $offX2Flags, $self->[$__win], 0, $self->[$__urp],
197             ) or return;
198              
199 0 0       0 if ($self->[$__options]) {
200 0 0       0 $phpkt .= $self->SUPER::pack('a*', $self->[$__options])
201             or return;
202             }
203              
204 0 0       0 if (length($payload)) {
205 0 0       0 $phpkt .= $self->SUPER::pack('a*', $payload)
206             or return;
207             }
208              
209 0         0 $self->[$__checksum] = inetChecksum($phpkt);
210              
211 0         0 return 1;
212             }
213              
214             our $Next = {
215             };
216              
217             sub encapsulate {
218 1     1 1 9 my $self = shift;
219 1   33     11 return $Next->{$self->[$__dst]} || $Next->{$self->[$__src]}
220             || $self->[$__nextLayer];
221             }
222              
223             sub match {
224 0     0 1 0 my $self = shift;
225 0         0 my ($with) = @_;
226 0 0       0 ($with->[$__ack] == $self->[$__seq] + 1)
227             || ($with->[$__flags] & NF_TCP_FLAGS_RST);
228             }
229              
230             sub getKey {
231 0     0 1 0 my $self = shift;
232 0         0 $self->layer.':'.$self->[$__src].'-'.$self->[$__dst];
233             }
234              
235             sub getKeyReverse {
236 0     0 1 0 my $self = shift;
237 0         0 $self->layer.':'.$self->[$__dst].'-'.$self->[$__src];
238             }
239              
240             sub print {
241 1     1 1 4 my $self = shift;
242              
243 1         6 my $l = $self->layer;
244 1         12 my $buf = sprintf
245             "$l: src:%d dst:%d seq:0x%04x ack:0x%04x \n".
246             "$l: off:0x%02x x2:0x%01x flags:0x%02x win:%d checksum:0x%04x ".
247             "urp:0x%02x",
248             $self->[$__src], $self->[$__dst], $self->[$__seq], $self->[$__ack],
249             $self->[$__off], $self->[$__x2], $self->[$__flags], $self->[$__win],
250             $self->[$__checksum], $self->[$__urp];
251              
252 1 50       4 if ($self->[$__options]) {
253 0 0       0 $buf .= sprintf("\n$l: optionsLength:%d options:%s",
254             $self->getOptionsLength,
255             $self->SUPER::unpack('H*', $self->[$__options])
256             ) or return undef;
257             }
258              
259 1         293 $buf;
260             }
261              
262             1;
263              
264             __END__