File Coverage

blib/lib/NetPacket/USBMon.pm

Criterion	Covered	Total	%
statement	79	81	97.5
branch	10	12	83.3
condition			n/a
subroutine	20	20	100.0
pod	1	1	100.0
total	110	114	96.4

package NetPacket::USBMon;
BEGIN {
  $NetPacket::USBMon::AUTHORITY = 'cpan:YANICK';
}
#ABSTRACT: Assemble and disassemble USB packets captured via Linux USBMon interface.
$NetPacket::USBMon::VERSION = '1.6.0';
use 5.10.0;
use strict;
use warnings;

use parent 'NetPacket';

our @EXPORT_OK = qw(
    USB_TYPE_SUBMISSION USB_TYPE_CALLBACK USB_TYPE_ERROR
    USB_XFER_TYPE_ISO USB_XFER_TYPE_INTR
    USB_XFER_TYPE_CONTROL USB_XFER_TYPE_BULK
    USB_FLAG_SETUP_IRRELEVANT USB_FLAG_SETUP_RELEVANT
    USB_FLAG_DATA_ERROR USB_FLAG_DATA_INCOMING
    USB_FLAG_DATA_OUTGOING USB_FLAG_DATA_PRESENT
    USB_TYPE_VENDOR
);

our %EXPORT_TAGS =(
    ALL         => \@EXPORT_OK,
    types       => [qw(USB_TYPE_SUBMISSION USB_TYPE_CALLBACK
                       USB_TYPE_ERROR)],
    xfer_types  => [qw(USB_XFER_TYPE_ISO USB_XFER_TYPE_INTR
                       USB_XFER_TYPE_CONTROL USB_XFER_TYPE_BULK)],
    setup_flags => [qw(USB_FLAG_SETUP_IRRELEVANT USB_FLAG_SETUP_RELEVANT)],
    data_flags  => [qw(USB_FLAG_DATA_ERROR USB_FLAG_DATA_INCOMING
                       USB_FLAG_DATA_OUTGOING USB_FLAG_DATA_PRESENT)],
    setup_types => [qw(USB_TYPE_VENDOR)],
);


use constant USB_TYPE_SUBMISSION        => 'S';
use constant USB_TYPE_CALLBACK          => 'C';
use constant USB_TYPE_ERROR             => 'E';

use constant USB_XFER_TYPE_ISO          => 0;
use constant USB_XFER_TYPE_INTR         => 1;
use constant USB_XFER_TYPE_CONTROL      => 2;
use constant USB_XFER_TYPE_BULK         => 3;

use constant USB_FLAG_SETUP_IRRELEVANT  => '-';
use constant USB_FLAG_SETUP_RELEVANT    => chr(0);

use constant USB_FLAG_DATA_ERROR        => 'E';
use constant USB_FLAG_DATA_INCOMING     => '<';
use constant USB_FLAG_DATA_OUTGOING     => '>';
use constant USB_FLAG_DATA_PRESENT      => chr(0);

use constant USB_TYPE_VENDOR            => 0x40;

sub decode
{
    my $class = shift;
    my $packet = shift;
    my $parent = shift;

    my($id, $type, $xfer_type, $epnum, $devnum, $busnum, $flag_setup,
        $flag_data, $ts_sec, $ts_usec, $status, $length, $len_cap,
        $s, $interval, $start_frame, $xfer_flags, $ndesc, $rest) =
        unpack('a8CCCCS

    # Try to grok quads. We may lose some address information with 32-bit
    # Perl parsing 64-bit captures, or timestamp after 2038. Still the best
    # we can do.
    eval {
      $id = unpack ('Q<', $id);
      $ts_sec = unpack ('Q<', $ts_sec);
    };
    if ($@) {
      ($id) = unpack ('L
      ($ts_sec) = unpack ('L
    }

    my $self = {
        _parent         => $parent,
        _frame          => $packet,

        id              => $id,
        type            => chr($type),
        xfer_type       => $xfer_type,
        ep              => {
            num         => ($epnum & 0x7f),
            dir         => ($epnum & 0x80 ? 'IN' : 'OUT'),
        },
        devnum          => $devnum,
        busnum          => $busnum,
        flag_setup      => chr($flag_setup),
        flag_data       => chr($flag_data),
        ts_sec          => $ts_sec,
        ts_usec         => $ts_usec,
        status          => $status,
        length          => $length,
        len_cap         => $len_cap,
        interval        => $interval,
        start_frame     => $start_frame,
        xfer_flags      => $xfer_flags,
        ndesc           => $ndesc,
    };

    # Setup
    if ($self->{flag_setup} ne USB_FLAG_SETUP_IRRELEVANT) {
        my $setup = {};
        my $rest;

       ($setup->{bmRequestType}, $setup->{bRequest}, $rest)
            = unpack('CCa*', $s);

        if ($setup->{bmRequestType} & USB_TYPE_VENDOR) {
           ($setup->{wValue}, $setup->{wIndex},
                $setup->{wLength}) = unpack('S<3', $rest);
        } else {
            # Unknown setup request;
            $setup->{data} = $rest;
        }

        $self->{setup} = $setup;
    }

    # Isochronous descriptors
    if ($self->{xfer_type} == USB_XFER_TYPE_ISO) {
        my $iso = {};
       ($iso->{error_count}, $iso->{numdesc}) = unpack('i
        $self->{iso} = $iso;
    }

    # Data
    warn 'Payload length mismatch'
        if length($rest) ne $self->{len_cap};
    $self->{data} = $rest;

    return bless $self, $class;
}

1;

__END__