File Coverage

blib/lib/Device/USB/Device.pm

Criterion	Covered	Total	%
statement	14	173	8.0
branch	0	38	0.0
condition	0	2	0.0
subroutine	5	44	11.3
pod	37	37	100.0
total	56	294	19.0

package Device::USB::Device;

require 5.006;
use warnings;
use strict;
use Carp;

use constant MAX_BUFFER_SIZE => 256;

=head1 Device::USB::Device

This class encapsulates the USB device structure and the methods that may be
applied to it.

=head1 NAME

Device::USB::Device - Use libusb to access USB devices.

=head1 VERSION

Version 0.36

=cut

our $VERSION=0.36;


=head1 SYNOPSIS

Device:USB::Device provides a Perl object for accessing a USB device
using the libusb library.

    use Device::USB;

    my $usb = Device::USB->new();
    my $dev = $usb->find_device( $VENDOR, $PRODUCT );

    printf "Device: %04X:%04X\n", $dev->idVendor(), $dev->idProduct();
    print "Manufactured by ", $dev->manufacturer(), "\n",
          " Product: ", $dev->product(), "\n";

    $dev->set_configuration( $CFG );
    $dev->control_msg( @params );
    ...

See the libusb manual for more information about most of the methods. The
functionality is generally the same as the libusb function whose name is
the method name prepended with "usb_".

=head1 DESCRIPTION

This module defines a Perl object that represents the data and functionality
associated with a USB device. The object interface provides read-only access
to the important data associated with a device. It also provides methods for
almost all of the functions supplied by libusb. Where necessary, the interfaces
to these methods were changed to better match Perl usage. However, most of the
methods are straight-forward wrappers around their libusb counterparts.

=head2 METHODS

=over 4

=item DESTROY

Close the device connected to the object.

=cut

sub DESTROY
{
    my $self = shift;
    Device::USB::libusb_close( $self->{handle} ) if $self->{handle};
    return;
}

# Make certain the device is open.
sub _assert_open
{
    my $self = shift;

    if(!defined $self->{handle})
    {
        $self->open() or croak "Cannot open device: $!\n";
    }
    return;
}


# I need to build a lot of accessors
sub _make_descr_accessor
{
    my $name = shift;
    ## no critic (ProhibitStringyEval)

    return eval <<"EOE";
sub $name
        {
            my \$self = shift;
            return \$self->{descriptor}->{$name};
        }
EOE
}

=item filename

Retrieve the filename associated with the device.

=cut

sub filename
{
    my $self = shift;
    return $self->{filename};
}

=item config

In list context, return a list of the configuration structures for this device.
In scalar context, return a reference to that list. This method is deprecated
in favor of the two new methods: configurations and get_configuration.

=cut

sub config
{
    my $self = shift;
    return wantarray ? @{$self->{config}} : $self->{config};
}

=item configurations

In list context, return a list of the configuration structures for this device.
In scalar context, return a reference to that list.

=cut

sub configurations
{
    my $self = shift;
    return wantarray ? @{$self->{config}} : $self->{config};
}

=item get_configuration

Retrieve the configuration requested by index. The legal values are from 0
to bNumConfigurations() - 1. Negative values access from the back of the list
of configurations.

=over 4

=item index numeric index of the index to return. If not supplied, use 0.

=back

Returns an object encapsulating the configuration on success, or C on
failure.

=cut

sub get_configuration
{
    my $self = shift;
    my $index = shift || 0;
    return $self->configurations()->[$index];
}

=item accessors

There a several accessor methods that return data from the device and device
descriptor. Each is named after the field that they return. All of the BCD
fields have been changed to floating point numbers, so that you don't have to
decode them yourself.

The methods include:

=over 4

=item bcdUSB

=item bDeviceClass

=item bDeviceSubClass

=item bDeviceProtocol

=item bMaxPacketSize0

=item idVendor

=item idProduct

=item bcdDevice

=item iManufacturer

=item iProduct

=item iSerialNumber

=item bNumConfigurations

=back

=cut

_make_descr_accessor( 'bcdUSB' );
_make_descr_accessor( 'bDeviceClass' );
_make_descr_accessor( 'bDeviceSubClass' );
_make_descr_accessor( 'bDeviceProtocol' );
_make_descr_accessor( 'bMaxPacketSize0' );
_make_descr_accessor( 'idVendor' );
_make_descr_accessor( 'idProduct' );
_make_descr_accessor( 'bcdDevice' );
_make_descr_accessor( 'iManufacturer' );
_make_descr_accessor( 'iProduct' );
_make_descr_accessor( 'iSerialNumber' );
_make_descr_accessor( 'bNumConfigurations' );

=item manufacturer

Retrieve the manufacture name from the device as a string.
Return undef if the device read fails.

=cut

sub manufacturer
{
    my $self = shift;

    return $self->get_string_simple( $self->iManufacturer() );
}

=item product

Retrieve the product name from the device as a string.
Return undef if the device read fails.

=cut

sub product
{
    my $self = shift;

    return $self->get_string_simple( $self->iProduct() );
}

=item serial_number

Retrieve the serial number from the device as a string.
Return undef if the device read fails.

=cut

sub serial_number
{
    my $self = shift;

    return $self->get_string_simple( $self->iSerialNumber() );
}

=item open

Open the device. If the device is already open, close it and reopen it.

If the device fails to open, the reason will be available in $!.

=cut

sub open  ## no critic (ProhibitBuiltinHomonyms)
{
    my $self = shift;
    Device::USB::libusb_close( $self->{handle} ) if $self->{handle};
    local $! = 0;
    $self->{handle} = Device::USB::libusb_open( $self->{device} );

    return 0 == $!;
}

=item set_configuration

Sets the active configuration of the device.

=over 4

=item configuration

the integer specified in the descriptor field bConfigurationValue.

=back

returns 0 on success or <0 on error

When using libusb-win32 under Windows, it is important to call
C after the C but before any other method calls.
Without this call, other methods may not work. This call is not required under
Linux.

=cut

sub set_configuration
{
    my $self = shift;
    my $configuration = shift;
    $self->_assert_open();

    return Device::USB::libusb_set_configuration( $self->{handle}, $configuration );
}

=item set_altinterface

Sets the active alternative setting of the current interface for the device.

=over 4

=item alternate

the integer specified in the descriptor field bAlternateSetting.

=back

returns 0 on success or <0 on error

=cut

sub set_altinterface
{
    my $self = shift;
    my $alternate = shift;
    $self->_assert_open();

    return Device::USB::libusb_set_altinterface( $self->{handle}, $alternate );
}

=item clear_halt

Clears any halt status on the supplied endpoint.

=over 4

=item alternate

the integer specified bEndpointAddress descriptor field.

=back

returns 0 on success or <0 on error

=cut

sub clear_halt
{
    my $self = shift;
    my $ep = shift;
    $self->_assert_open();

    return Device::USB::libusb_clear_halt( $self->{handle}, $ep );
}

=item reset

Resets the device. This also closes the handle and invalidates this device.
This device will be unusable.

=cut

sub reset  ## no critic (ProhibitBuiltinHomonyms)
{
    my $self = shift;

    return 0 unless defined $self->{handle};

    my $ret = Device::USB::libusb_reset( $self->{handle} );
    delete $self->{handle} unless $ret;

    return $ret;
}

=item claim_interface

Claims the specified interface with the operating system.

=over 4

=item interface

The interface value listed in the descriptor field bInterfaceNumber.

=back

Returns 0 on success, <0 on failure.

=cut

sub claim_interface
{
    my $self = shift;
    my $interface = shift;
    $self->_assert_open();

    return Device::USB::libusb_claim_interface( $self->{handle}, $interface );
}

=item release_interface

Releases the specified interface back to the operating system.

=over 4

=item interface

The interface value listed in the descriptor field bInterfaceNumber.

=back

Returns 0 on success, <0 on failure.

=cut

sub release_interface
{
    my $self = shift;
    my $interface = shift;
    $self->_assert_open();

    return Device::USB::libusb_release_interface( $self->{handle}, $interface );
}

=item control_msg

Performs a control request to the default control pipe on a device.

=over 4

=item requesttype

=item request

=item value

=item index

=item bytes

Any returned data is placed here. If you don't want any returned data,
pass undef.

=item size

Size of supplied buffer.

=item timeout

Milliseconds to wait for response.

=back

Returns number of bytes read or written on success, <0 on failure.

=cut

sub control_msg
{
    my $self = shift;
    ## no critic (RequireArgUnpacking)
    my ($requesttype, $request, $value, $index, $bytes, $size, $timeout) = @_;
    $bytes = q{} unless defined $bytes;
    $self->_assert_open();

    my ($retval, $out) = Device::USB::libusb_control_msg(
            $self->{handle}, $requesttype, $request, $value,
            $index, $bytes, $size, $timeout
       );
    # replace the input string in $bytes.
    $_[4] = $out if defined $_[4];
    return $retval;
}

=item get_string

Retrieve a string descriptor from the device.

=over 4

=item index

The index of the string in the string list.

=item langid

The language id used to specify which of the supported languages the string
should be encoded in.

=back

Returns a Unicode string. The function returns undef on error.

=cut

sub get_string
{
    my $self = shift;
    my $index = shift;
    my $langid = shift;

    $self->_assert_open();

    my $buf = "\0" x MAX_BUFFER_SIZE;

    my $retlen = Device::USB::libusb_get_string(
        $self->{handle}, $index, $langid, $buf, MAX_BUFFER_SIZE
    );

    return if $retlen < 0;

    return substr( $buf, 0, $retlen );
}

=item get_string_simple

Retrieve a string descriptor from the device.

=over 4

=item index

The index of the string in the string list.

=back

Returns a C-style string if successful, or undef on error.

=cut

sub get_string_simple
{
    my $self = shift;
    my $index = shift;
    $self->_assert_open();

    my $buf = "\0" x MAX_BUFFER_SIZE;

    my $retlen = Device::USB::libusb_get_string_simple(
        $self->{handle}, $index, $buf, MAX_BUFFER_SIZE
    );

    return if $retlen < 0;

    return substr( $buf, 0, $retlen );
}

=item get_descriptor

Retrieve a descriptor from the device

=over 4

=item type

The type of descriptor to retrieve.

=item index

The index of that descriptor in the list of descriptors of that type.

=back

TODO: This method needs major rewrite to be Perl-ish.
I need to provide a better way to specify the type (or at least document
which are available), and I need to return a Perl data structure, not
a buffer of binary data.

=cut

sub get_descriptor
{
    my $self = shift;
    my $type = shift;
    my $index = shift;
    $self->_assert_open();

    my $buf = "\0" x MAX_BUFFER_SIZE;

    my $retlen = Device::USB::libusb_get_descriptor(
        $self->{handle}, $type, $index, $buf, MAX_BUFFER_SIZE
    );

    return if $retlen < 0;

    return substr( $buf, 0, $retlen );
}

=item get_descriptor_by_endpoint

Retrieve an endpoint-specific descriptor from the device

=over 4

=item ep

Endpoint to query.

=item type

The type of descriptor to retrieve.

=item index

The index of that descriptor in the list of descriptors.

=item buf

Buffer into which to write the requested descriptor

=item size

Max size to read into the buffer.

=back

TODO: This method needs major rewrite to be Perl-ish.
I need to provide a better way to specify the type (or at least document
which are available), and I need to return a Perl data structure, not
a buffer of binary data.

=cut

sub get_descriptor_by_endpoint
{
    my $self = shift;
    my $ep = shift;
    my $type = shift;
    my $index = shift;

    $self->_assert_open();

    my $buf = "\0" x MAX_BUFFER_SIZE;

    my $retlen = Device::USB::libusb_get_descriptor_by_endpoint(
        $self->{handle}, $ep, $type, $index, $buf, MAX_BUFFER_SIZE
    );

    return if $retlen < 0;

    return substr( $buf, 0, $retlen );
}

=item bulk_read

Perform a bulk read request from the specified endpoint.

=over 4

=item ep

The number of the endpoint to read

=item bytes

Buffer into which to write the requested data.

=item size

Max size to read into the buffer.

=item timeout

Maximum time to wait (in milliseconds)

=back

The function returns the number of bytes returned or <0 on error.

USB is packet based, not stream based. So using C to read part
of the packet acts like a I. The next time you read, all of the packet
is still there.

The data is only removed when you read the entire packet. For this reason, you
should always call C with the total packet size.

=cut

sub bulk_read
{
    my $self = shift;
    # Don't change to shifts, I need to write back to $bytes.
    my ($ep, $bytes, $size, $timeout) = @_;
    $bytes = q{} unless defined $bytes;

    $self->_assert_open();

    if(length $bytes < $size)
    {
        $bytes .= "\0" x ($size - length $bytes);
    }

    my $retlen = Device::USB::libusb_bulk_read(
        $self->{handle}, $ep, $bytes, $size, $timeout
    );

    # stick back in the bytes parameter.
    $_[1] = substr( $bytes, 0, $retlen );

    return $retlen;
}

=item interrupt_read

Perform a interrupt read request from the specified endpoint.

=over 4

=item ep

The number of the endpoint to read

=item bytes

Buffer into which to write the requested data.

=item size

Max size to read into the buffer.

=item timeout

Maximum time to wait (in milliseconds)

=back

The function returns the number of bytes returned or <0 on error.

=cut

sub interrupt_read
{
    my $self = shift;
    # Don't change to shifts, I need to write back to $bytes.
    my ($ep, $bytes, $size, $timeout) = @_;
    $bytes = q{} unless defined $bytes;

    $self->_assert_open();

    if(length $bytes < $size)
    {
        $bytes .= "\0" x ($size - length $bytes);
    }

    my $retlen = Device::USB::libusb_interrupt_read(
        $self->{handle}, $ep, $bytes, $size, $timeout
    );

    # stick back in the bytes parameter.
    $_[1] = substr( $bytes, 0, $retlen );

    return $retlen;
}

=item bulk_write

Perform a bulk write request to the specified endpoint.

=over 4

=item ep

The number of the endpoint to write

=item bytes

Buffer from which to write the requested data.

=item timeout

Maximum time to wait (in milliseconds)

=back

The function returns the number of bytes written or <0 on error.

=cut

sub bulk_write
{
    my $self = shift;
    my $ep = shift;
    my $bytes = shift;
    my $timeout = shift;

    $self->_assert_open();

    return Device::USB::libusb_bulk_write(
        $self->{handle}, $ep, $bytes, length $bytes, $timeout
    );
}

=item interrupt_write

Perform a interrupt write request to the specified endpoint.

=over 4

=item ep

The number of the endpoint to write

=item bytes

Buffer from which to write the requested data.

=item timeout

Maximum time to wait (in milliseconds)

=back

The function returns the number of bytes written or <0 on error.

=cut

sub interrupt_write
{
    my $self = shift;
    my $ep = shift;
    my $bytes = shift;
    my $timeout = shift;

    $self->_assert_open();

    return Device::USB::libusb_interrupt_write(
        $self->{handle}, $ep, $bytes, length $bytes, $timeout
    );
}

=item get_driver_np

This function returns the name of the driver bound to the interface
specified by the parameter interface.

=over 4

=item $interface

The interface number of interest.

=back

Returns C on error.

=cut

sub get_driver_np
{
    my $self = shift;
    my $interface = shift;
    my $name = shift;

    $self->_assert_open();

    my $buf = "\0" x MAX_BUFFER_SIZE;

    my $retlen = Device::USB::libusb_get_driver_np(
        $self->{handle}, $interface, $buf, MAX_BUFFER_SIZE
    );

    return if $retlen < 0;

    return substr( $buf, 0, $retlen );
}


=item detach_kernel_driver_np

This function will detach a kernel driver from the interface specified by
parameter interface. Applications using libusb can then try claiming the
interface. Returns 0 on success or < 0 on error.

=cut

sub detach_kernel_driver_np
{
    my $self = shift;
    my $interface = shift;
    $self->_assert_open();

    return Device::USB::libusb_detach_kernel_driver_np(
        $self->{handle}, $interface
    );
}

=back

=head1 DIAGNOSTICS

This is an explanation of the diagnostic and error messages this module
can generate.

=over 4

=item Cannot open device: I

Unable to open the USB device for the reason given.

=back

=head1 DEPENDENCIES

This module depends on the Carp, Inline and Inline::C modules, as well as
the strict and warnings pragmas. Obviously, libusb must be available since
that is the entire reason for the module's existence.

=head1 AUTHOR

G. Wade Johnson (gwadej at cpan dot org)
Paul Archer (paul at paularcher dot org)

Houston Perl Mongers Group

=head1 BUGS

Please report any bugs or feature requests to
C, or through the web interface at
L.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 ACKNOWLEDGEMENTS

Thanks go to various members of the Houston Perl Mongers group for input
on the module. But thanks mostly go to Paul Archer who proposed the project
and helped with the development.

=head1 COPYRIGHT & LICENSE

Copyright 2006-2013 Houston Perl Mongers

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;