File Coverage

blib/lib/Metabrik/Network/Frame.pm
Criterion Covered Total %
statement 9 154 5.8
branch 0 72 0.0
condition 0 48 0.0
subroutine 3 24 12.5
pod 3 21 14.2
total 15 319 4.7


line stmt bran cond sub pod time code
1             #
2             # $Id$
3             #
4             # network::frame Brik
5             #
6             package Metabrik::Network::Frame;
7 3     3   25 use strict;
  3         5  
  3         84  
8 3     3   15 use warnings;
  3         6  
  3         80  
9              
10 3     3   15 use base qw(Metabrik);
  3         6  
  3         6381  
11              
12             sub brik_properties {
13             return {
14 0     0 1   revision => '$Revision$',
15             tags => [ qw(unstable packet ip tcp udp icmp eth ethernet arp) ],
16             author => 'GomoR ',
17             license => 'http://opensource.org/licenses/BSD-3-Clause',
18             attributes => {
19             device => [ qw(device) ],
20             device_info => [ qw(device_info_hash) ],
21             },
22             commands => {
23             get_device_info => [ qw(device|OPTIONAL) ],
24             update_device_info => [ qw(device|OPTIONAL) ],
25             from_read => [ qw(frame|$frame_list) ],
26             to_read => [ qw(simple|$simple_list) ],
27             from_hexa => [ qw(hexa first_layer|OPTIONAL) ],
28             from_raw => [ qw(raw first_layer|OPTIONAL) ],
29             show => [ ],
30             mac2eui64 => [ qw(mac_address) ],
31             frame => [ qw(layers_array) ],
32             arp => [ qw(destination_ipv4_address|OPTIONAL destination_mac|OPTIONAL) ],
33             eth => [ qw(destination_mac|OPTIONAL type|OPTIONAL) ],
34             ipv4 => [ qw(destination_ipv4_address protocol|OPTIONAL source_ipv4_address|OPTIONAL) ],
35             tcp => [ qw(destination_port source_port|OPTIONAL flags|OPTIONAL) ],
36             udp => [ qw(destination_port source_port|OPTIONAL payload|OPTIONAL) ],
37             icmpv4 => [ ],
38             echo_icmpv4 => [ ],
39             is_read => [ qw(data) ],
40             is_simple => [ qw(data) ],
41             },
42             require_modules => {
43             'Net::Frame::Simple' => [ ],
44             'Net::Frame::Layer::ARP' => [ ],
45             'Net::Frame::Layer::ETH' => [ ],
46             'Net::Frame::Layer::IPv4' => [ ],
47             'Net::Frame::Layer::IPv6' => [ ],
48             'Net::Frame::Layer::TCP' => [ ],
49             'Net::Frame::Layer::UDP' => [ ],
50             'Net::Frame::Layer::ICMPv4' => [ ],
51             'Net::Frame::Layer::ICMPv6' => [ ],
52             'Metabrik::String::Hexa' => [ ],
53             'Metabrik::Network::Device' => [ ],
54             },
55             };
56             }
57              
58             sub brik_use_properties {
59 0     0 1   my $self = shift;
60              
61             return {
62 0   0       attributes_default => {
63             device => defined($self->global) && $self->global->device || 'eth0',
64             },
65             };
66             }
67              
68             sub brik_init {
69 0     0 1   my $self = shift;
70              
71 0 0         $self->update_device_info
72             or return $self->log->error("brik_init: update_device_info failed, you may not have a global device set");
73              
74 0           return $self->SUPER::brik_init(@_);
75             }
76              
77             sub get_device_info {
78 0     0 0   my $self = shift;
79 0           my ($device) = @_;
80              
81 0   0       $device ||= $self->device;
82              
83 0 0         my $nd = Metabrik::Network::Device->new_from_brik_init($self) or return;
84              
85 0 0         my $device_info = $nd->get($device) or return;
86              
87 0           $self->log->debug("get_device_info: got info from device [$device]");
88              
89 0           return $device_info;
90             }
91              
92             sub update_device_info {
93 0     0 0   my $self = shift;
94 0           my ($device) = @_;
95              
96 0           return $self->device_info($self->get_device_info($device));
97             }
98              
99             sub from_read {
100 0     0 0   my $self = shift;
101 0           my ($frames) = @_;
102              
103 0 0         $self->brik_help_run_undef_arg('from_read', $frames) or return;
104 0 0         my $ref = $self->brik_help_run_invalid_arg('from_read', $frames, 'HASH', 'ARRAY')
105             or return;
106              
107             # We accept a one frame Argument...
108 0 0         if ($ref eq 'HASH') {
109 0 0 0       if (! exists($frames->{raw})
110             || ! exists($frames->{firstLayer})
111             || ! exists($frames->{timestamp})) {
112 0           return $self->log->error("from_read: frames Argument is not an array of valid next HASHREFs");
113             }
114             else {
115 0           return Net::Frame::Simple->newFromDump($frames);
116             }
117             }
118              
119             # Or an ARRAY or frames
120 0 0         if ($ref ne 'ARRAY') {
121 0           return $self->log->error("from_read: frames Argument must be an ARRAYREF");
122             }
123 0 0         if (@$frames <= 0) {
124 0           return $self->log->error("from_read: frames Argument is empty");
125             }
126 0           my $first = $frames->[0];
127 0 0         if (ref($first) ne 'HASH') {
128 0           return $self->log->error("from_read: frames Argument is not an array of next HASHREFs");
129             }
130 0 0 0       if (! exists($first->{raw})
      0        
131             || ! exists($first->{firstLayer})
132             || ! exists($first->{timestamp})) {
133 0           return $self->log->error("from_read: frames Argument is not an array of valid next HASHREFs");
134             }
135              
136 0           my @simple = ();
137 0           for my $h (@$frames) {
138 0 0         my $simple = Net::Frame::Simple->newFromDump($h) or next;
139 0           push @simple, $simple;
140             }
141              
142 0           return \@simple;
143             }
144              
145             sub to_read {
146 0     0 0   my $self = shift;
147 0           my ($frame) = @_;
148              
149 0 0         $self->brik_help_run_undef_arg('to_read', $frame) or return;
150 0 0         my $ref = $self->brik_help_run_invalid_arg('to_read', $frame, 'ARRAY', 'Net::Frame::Simple')
151             or return;
152              
153 0 0         my $first = $ref eq 'ARRAY' ? $frame->[0] : $frame;
154 0 0         if ($ref eq 'ARRAY') {
    0          
155             # We just check the first item in the list.
156 0 0         if (ref($first) eq 'Net::Frame::Simple') {
157 0           my @read = ();
158 0           for my $simple (@$frame) {
159 0           push @read, {
160             timestamp => $simple->timestamp,
161             firstLayer => $simple->firstLayer,
162             raw => $simple->raw,
163             };
164             }
165 0           return \@read;
166             }
167             else {
168 0           return $self->log->error("to_read: frame ARRAYREF must contain Net::Frame::Simple objects");
169             }
170             }
171             elsif ($ref eq 'Net::Frame::Simple') {
172 0           my $h = {
173             timestamp => $frame->timestamp,
174             firstLayer => $frame->firstLayer,
175             raw => $frame->raw,
176             };
177 0           return $h;
178             }
179              
180 0           return $self->log->error("to_read: unknown error occured");
181             }
182              
183             sub from_hexa {
184 0     0 0   my $self = shift;
185 0           my ($data, $first_layer) = @_;
186              
187 0   0       $first_layer ||= 'IPv4';
188 0 0         $self->brik_help_run_undef_arg('from_hexa', $data) or return;
189              
190 0 0         my $sh = Metabrik::String::Hexa->new_from_brik_init($self) or return;
191              
192 0 0         if (! $sh->is_hexa($data)) {
193 0           return $self->log->error('from_hexa: data is not hexa');
194             }
195              
196 0 0         my $raw = $sh->decode($data) or return;
197              
198 0           my $frame;
199 0           eval {
200 0           $frame = Net::Frame::Simple->new(raw => $raw, firstLayer => $first_layer);
201             };
202 0 0         if ($@) {
203 0           chomp($@);
204 0           return $self->log->error("from_hexa: cannot parse frame, not a $first_layer first layer? [$@]");
205             }
206              
207 0           return $frame;
208             }
209              
210             sub from_raw {
211 0     0 0   my $self = shift;
212 0           my ($raw, $first_layer) = @_;
213              
214 0 0         $self->brik_help_run_undef_arg('from_raw', $raw) or return;
215              
216 0           return $self->from_hexa(unpack('H*', $raw), $first_layer);
217             }
218              
219             sub show {
220 0     0 0   my $self = shift;
221 0           my ($frame) = @_;
222              
223 0 0         $self->brik_help_run_undef_arg('show', $frame) or return;
224 0 0         $self->brik_help_run_invalid_arg('show', $frame, 'Net::Frame::Simple') or return;
225              
226 0           my $str = $frame->print;
227              
228 0           print $str."\n";
229              
230 0           return 1;
231             }
232              
233             # http://tools.ietf.org/html/rfc2373
234             sub mac2eui64 {
235 0     0 0   my $self = shift;
236 0           my ($mac) = @_;
237              
238 0 0         $self->brik_help_run_undef_arg('mac2eui64', $mac) or return;
239              
240 0           my @b = split(':', $mac);
241 0           my $b0 = hex($b[0]) ^ 2;
242              
243 0           return sprintf("fe80::%x%x:%xff:fe%x:%x%x", $b0, hex($b[1]), hex($b[2]),
244             hex($b[3]), hex($b[4]), hex($b[5]));
245             }
246              
247             # Returns an ARP header with a set of default values
248             sub arp {
249 0     0 0   my $self = shift;
250 0           my ($dst_ip, $dst_mac) = @_;
251              
252 0           my $device_info = $self->device_info;
253              
254 0   0       $dst_ip ||= '127.0.0.1';
255 0   0       $dst_mac ||= '00:00:00:00:00:00';
256              
257             my $hdr = Net::Frame::Layer::ARP->new(
258             #opCode => NF_ARP_OPCODE_REQUEST, # Default
259             srcIp => $device_info->{ipv4},
260             dstIp => $dst_ip,
261             src => $device_info->{mac},
262 0           dst => $dst_mac,
263             );
264              
265 0           return $hdr;
266             }
267              
268             # Returns an Ethernet header with a set of default values
269             sub eth {
270 0     0 0   my $self = shift;
271 0           my ($dst, $type) = @_;
272              
273 0           my $device_info = $self->device_info;
274              
275 0   0       $dst ||= 'ff:ff:ff:ff:ff:ff'; # Broadcast
276 0   0       $type ||= 0x0800; # IPv4
277              
278             my $hdr = Net::Frame::Layer::ETH->new(
279             src => $device_info->{mac},
280 0           dst => $dst,
281             type => $type,
282             );
283              
284 0           return $hdr;
285             }
286              
287             sub ipv4 {
288 0     0 0   my $self = shift;
289 0           my ($dst, $protocol, $src) = @_;
290              
291 0   0       $protocol ||= 6; # TCP
292 0 0         $self->brik_help_run_undef_arg('ipv4', $dst) or return;
293              
294 0           my $device_info = $self->device_info;
295 0   0       $src ||= $device_info->{ipv4};
296              
297 0           my $hdr = Net::Frame::Layer::IPv4->new(
298             src => $src,
299             dst => $dst,
300             protocol => $protocol,
301             );
302              
303 0           return $hdr;
304             }
305              
306             sub tcp {
307 0     0 0   my $self = shift;
308 0           my ($dst, $src, $flags) = @_;
309              
310 0   0       $src ||= 1025;
311 0   0       $flags ||= 0x02; # SYN
312 0 0         $self->brik_help_run_undef_arg('tcp', $dst) or return;
313              
314 0           return Net::Frame::Layer::TCP->new(
315             dst => $dst,
316             src => $src,
317             flags => $flags,
318             );
319             }
320              
321             sub udp {
322 0     0 0   my $self = shift;
323 0           my ($dst, $src, $payload) = @_;
324              
325 0   0       $src ||= 1025;
326 0   0       $payload ||= '';
327 0 0         $self->brik_help_run_undef_arg('udp', $dst) or return;
328              
329 0           return Net::Frame::Layer::UDP->new(
330             dst => $dst,
331             src => $src,
332             length => length($payload),
333             )->pack.$payload;
334             }
335              
336             sub icmpv4 {
337 0     0 0   my $self = shift;
338              
339 0           my $hdr = Net::Frame::Layer::ICMPv4->new;
340              
341 0           return $hdr;
342             }
343              
344             sub echo_icmpv4 {
345 0     0 0   my $self = shift;
346 0           my ($data) = @_;
347              
348 0   0       $data ||= 'echo';
349              
350 0           my $hdr = Net::Frame::Layer::ICMPv4::Echo->new(
351             payload => $data,
352             );
353              
354 0           return $hdr;
355             }
356              
357             sub frame {
358 0     0 0   my $self = shift;
359 0           my ($layers) = @_;
360              
361 0 0         $self->brik_help_run_undef_arg('frame', $layers) or return;
362 0 0         $self->brik_help_run_invalid_arg('frame', $layers, 'ARRAY') or return;
363              
364 0           my $request = Net::Frame::Simple->new(
365             layers => $layers,
366             );
367              
368 0           return $request;
369             }
370              
371             sub is_read {
372 0     0 0   my $self = shift;
373 0           my ($data) = @_;
374              
375 0 0         $self->brik_help_run_undef_arg('is_read', $data) or return;
376              
377 0 0 0       if (ref($data) eq 'HASH'
      0        
      0        
378             && exists($data->{raw})
379             && exists($data->{firstLayer})
380             && exists($data->{timestamp})) {
381 0           return 1;
382             }
383              
384 0           return 0;
385             }
386              
387             sub is_simple {
388 0     0 0   my $self = shift;
389 0           my ($data) = @_;
390              
391 0 0         $self->brik_help_run_undef_arg('is_simple', $data) or return;
392              
393 0 0         if (ref($data) eq 'Net::Frame::Simple') {
394 0           return 1;
395             }
396              
397 0           return 0;
398             }
399              
400             1;
401              
402             __END__