File Coverage

blib/lib/NetPacket/USBMon.pm
Criterion Covered Total %
statement 82 84 97.6
branch 10 12 83.3
condition n/a
subroutine 21 21 100.0
pod 1 1 100.0
total 114 118 96.6


line stmt bran cond sub pod time code
1             package NetPacket::USBMon;
2             BEGIN {
3 2     2   34767 $NetPacket::USBMon::AUTHORITY = 'cpan:YANICK';
4             }
5             #ABSTRACT: Assemble and disassemble USB packets captured via Linux USBMon interface.
6             $NetPacket::USBMon::VERSION = '1.5.0';
7 2     2   36 use 5.10.0;
  2         6  
  2         93  
8              
9 2     2   13 use strict;
  2         12  
  2         88  
10 2     2   12 use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS);
  2         9  
  2         207  
11 2     2   507 use NetPacket;
  2         4  
  2         311  
12              
13             BEGIN {
14 2     2   40 @ISA = qw(Exporter NetPacket);
15              
16 2         15 @EXPORT_OK = qw(
17             USB_TYPE_SUBMISSION USB_TYPE_CALLBACK USB_TYPE_ERROR
18             USB_XFER_TYPE_ISO USB_XFER_TYPE_INTR
19             USB_XFER_TYPE_CONTROL USB_XFER_TYPE_BULK
20             USB_FLAG_SETUP_IRRELEVANT USB_FLAG_SETUP_RELEVANT
21             USB_FLAG_DATA_ERROR USB_FLAG_DATA_INCOMING
22             USB_FLAG_DATA_OUTGOING USB_FLAG_DATA_PRESENT
23             USB_TYPE_VENDOR
24             );
25              
26 2         80 %EXPORT_TAGS =(
27             ALL => \@EXPORT_OK,
28             types => [qw(USB_TYPE_SUBMISSION USB_TYPE_CALLBACK
29             USB_TYPE_ERROR)],
30             xfer_types => [qw(USB_XFER_TYPE_ISO USB_XFER_TYPE_INTR
31             USB_XFER_TYPE_CONTROL USB_XFER_TYPE_BULK)],
32             setup_flags => [qw(USB_FLAG_SETUP_IRRELEVANT USB_FLAG_SETUP_RELEVANT)],
33             data_flags => [qw(USB_FLAG_DATA_ERROR USB_FLAG_DATA_INCOMING
34             USB_FLAG_DATA_OUTGOING USB_FLAG_DATA_PRESENT)],
35             setup_types => [qw(USB_TYPE_VENDOR)],
36             );
37              
38             }
39              
40 2     2   14 use constant USB_TYPE_SUBMISSION => 'S';
  2         10  
  2         378  
41 2     2   13 use constant USB_TYPE_CALLBACK => 'C';
  2         3  
  2         101  
42 2     2   12 use constant USB_TYPE_ERROR => 'E';
  2         4  
  2         91  
43              
44 2     2   10 use constant USB_XFER_TYPE_ISO => 0;
  2         4  
  2         102  
45 2     2   9 use constant USB_XFER_TYPE_INTR => 1;
  2         4  
  2         94  
46 2     2   11 use constant USB_XFER_TYPE_CONTROL => 2;
  2         2  
  2         100  
47 2     2   11 use constant USB_XFER_TYPE_BULK => 3;
  2         4  
  2         120  
48              
49 2     2   11 use constant USB_FLAG_SETUP_IRRELEVANT => '-';
  2         3  
  2         98  
50 2     2   19 use constant USB_FLAG_SETUP_RELEVANT => chr(0);
  2         4  
  2         95  
51              
52 2     2   11 use constant USB_FLAG_DATA_ERROR => 'E';
  2         4  
  2         106  
53 2     2   17 use constant USB_FLAG_DATA_INCOMING => '<';
  2         4  
  2         95  
54 2     2   10 use constant USB_FLAG_DATA_OUTGOING => '>';
  2         3  
  2         88  
55 2     2   11 use constant USB_FLAG_DATA_PRESENT => chr(0);
  2         5  
  2         94  
56              
57 2     2   54 use constant USB_TYPE_VENDOR => 0x40;
  2         9  
  2         950  
58              
59             sub decode
60             {
61 7     7 1 51776 my $class = shift;
62 7         14 my $packet = shift;
63 7         11 my $parent = shift;
64              
65 7         91 my($id, $type, $xfer_type, $epnum, $devnum, $busnum, $flag_setup,
66             $flag_data, $ts_sec, $ts_usec, $status, $length, $len_cap,
67             $s, $interval, $start_frame, $xfer_flags, $ndesc, $rest) =
68             unpack('a8CCCCS
69              
70             # Try to grok quads. We may lose some address information with 32-bit
71             # Perl parsing 64-bit captures, or timestamp after 2038. Still the best
72             # we can do.
73 7         18 eval {
74 7         17 $id = unpack ('Q<', $id);
75 7         17 $ts_sec = unpack ('Q<', $ts_sec);
76             };
77 7 50       31 if ($@) {
78 0         0 ($id) = unpack ('L
79 0         0 ($ts_sec) = unpack ('L
80             }
81              
82 7 100       149 my $self = {
83             _parent => $parent,
84             _frame => $packet,
85              
86             id => $id,
87             type => chr($type),
88             xfer_type => $xfer_type,
89             ep => {
90             num => ($epnum & 0x7f),
91             dir => ($epnum & 0x80 ? 'IN' : 'OUT'),
92             },
93             devnum => $devnum,
94             busnum => $busnum,
95             flag_setup => chr($flag_setup),
96             flag_data => chr($flag_data),
97             ts_sec => $ts_sec,
98             ts_usec => $ts_usec,
99             status => $status,
100             length => $length,
101             len_cap => $len_cap,
102             interval => $interval,
103             start_frame => $start_frame,
104             xfer_flags => $xfer_flags,
105             ndesc => $ndesc,
106             };
107              
108             # Setup
109 7 100       26 if ($self->{flag_setup} ne USB_FLAG_SETUP_IRRELEVANT) {
110 3         7 my $setup = {};
111 3         4 my $rest;
112              
113 3         14 ($setup->{bmRequestType}, $setup->{bRequest}, $rest)
114             = unpack('CCa*', $s);
115              
116 3 100       12 if ($setup->{bmRequestType} & USB_TYPE_VENDOR) {
117 2         11 ($setup->{wValue}, $setup->{wIndex},
118             $setup->{wLength}) = unpack('S<3', $rest);
119             } else {
120             # Unknown setup request;
121 1         3 $setup->{data} = $rest;
122             }
123              
124 3         8 $self->{setup} = $setup;
125             }
126              
127             # Isochronous descriptors
128 7 100       27 if ($self->{xfer_type} == USB_XFER_TYPE_ISO) {
129 1         2 my $iso = {};
130 1         4 ($iso->{error_count}, $iso->{numdesc}) = unpack('i
131 1         4 $self->{iso} = $iso;
132             }
133              
134             # Data
135 7 50       47 warn 'Payload length mismatch'
136             if length($rest) ne $self->{len_cap};
137 7         15 $self->{data} = $rest;
138              
139 7         33 return bless $self, $class;
140             }
141              
142             1;
143              
144             __END__