File Coverage

blib/lib/Device/USB.pm

Criterion	Covered	Total	%
statement	54	105	51.4
branch	2	28	7.1
condition			n/a
subroutine	18	31	58.0
pod			n/a
total	74	164	45.1

package Device::USB;

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

use Inline (
        C => "DATA",
        ($ENV{LIBUSB_LIBDIR}
            ? ( LIBS => "-L\"$ENV{LIBUSB_LIBDIR}\" " .
                        ($^O eq 'MSWin32' ? ' -llibusb -L\"$ENV{WINDDK}\\lib\\crt\\i386\" -lmsvcrt ' : '-lusb') )
            : ( LIBS => '-lusb', )
        ),
        ($ENV{LIBUSB_INCDIR} ? ( INC => "-I\"$ENV{LIBUSB_INCDIR}\"" ) : () ),
        NAME => 'Device::USB',
        VERSION => '0.36',
   );

Inline->init();

#
# Now the Perl code.
#

use Device::USB::Device;
use Device::USB::DevConfig;
use Device::USB::DevInterface;
use Device::USB::DevEndpoint;
use Device::USB::Bus;

use constant CLASS_PER_INSTANCE => 0;
use constant CLASS_AUDIO => 1;
use constant CLASS_COMM =>  2;
use constant CLASS_HID =>   3;
use constant CLASS_PRINTER => 7;
use constant CLASS_MASS_STORAGE => 8;
use constant CLASS_HUB =>     9;
use constant CLASS_DATA =>   10;
use constant CLASS_VENDOR_SPEC => 0xff;

=encoding utf8

=head1 NAME

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

=head1 VERSION

Version 0.36

=cut

our $VERSION=0.36;


=head1 SYNOPSIS

Device::USB provides a Perl wrapper around the libusb library. This
supports Perl code controlling and accessing USB devices.

    use Device::USB;

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

    printf "Device: %04X:%04X\n", $dev->idVendor(), $dev->idProduct();
    $dev->open();
    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 provides a Perl interface to the C library libusb. This library
supports a relatively full set of functionality to access a USB device. In
addition to the libusb, functioality, Device::USB provides a few
convenience features that are intended to produce a more Perl-ish interface.

These features include:

=over 4

=item *

Using the library initializes it, no need to call the underlying usb_init
function.

=item *

Object interface reduces namespace pollution and provides a better interface
to the library.

=item *

The find_device method finds the device associated with a vendor id and
product id and creates an appropriate Device::USB::Device object to
manipulate the USB device.

=item *

Object interfaces to the bus and device data structures allowing read access
to information about each.

=back

=head1 Device::USB

This class provides an interface to the non-bus and non-device specific
functions of the libusb library. In particular, it provides interfaces to
find busses and devices. It also provides convenience methods that simplify
some of the tasks above.

=head2 CONSTANTS

This class provides a set of constants for the defined device classes. The
constants defined at this time are:

=over 4

=item *

CLASS_PER_INSTANCE

=item *

CLASS_AUDIO

=item *

CLASS_COMM

=item *

CLASS_HID

=item *

CLASS_PRINTER

=item *

CLASS_MASS_STORAGE

=item *

CLASS_HUB

=item *

CLASS_DATA

=item *

CLASS_VENDOR_SPEC

=back

=head2 FUNCTIONS

=over 4

=cut

#
#  Internal-only, one-time init function.
my $init_ref;
$init_ref = sub
{
    libusb_init();
    $init_ref = sub {};
};

=item new

Create a new Device::USB object for accessing the library.

=cut

sub new
{
    my $class = shift;

    $init_ref->();

    return bless {}, $class;
}

=item debug_mode

This class method enables low-level debugging messages from the library
interface code.

=over 4

=item level

0 disables debugging, 1 enables some debug messages, and 2 enables verbose
debug messages

Any other values are forced to the nearest endpoint.

=back

=cut

sub debug_mode
{
    my ($class, $level) = @_;

    lib_debug_mode( $level );
    return;
}


=item find_busses

Returns the number of changes since previous call to the function: the
number of busses added or removed.

=cut

sub find_busses
{
    my $self = shift;
    return libusb_find_busses();
}

=item find_devices

Returns the number of changes since previous call to the function: the
number of devices added or removed. Should be called after find_busses.

=cut

sub find_devices
{
    my $self = shift;
    return libusb_find_devices();
}

=item find_device

Find a particular USB device based on the vendor and product ids. If more
than one device has the same product id from the same vendor, the first one
found is returned.

=over 4

=item vendor

the vendor id

=item product

product id for that vendor

=back

returns a device reference or undef if none was found.

=cut

sub find_device
{
    my $self = shift;
    my $vendor = shift;
    my $product = shift;

    return lib_find_usb_device( $vendor, $product );
}

=item find_device_if

Find a particular USB device based on the supplied predicate coderef. If
more than one device would satisfy the predicate, the first one found is
returned.

=over 4

=item pred

the predicate used to select a device

=back

returns a device reference or undef if none was found.

=cut

sub find_device_if
{
    my $self = shift;
    my $pred = shift;

    croak( "Missing predicate for choosing a device.\n" )
        unless defined $pred;

    croak( "Predicate must be a code reference.\n" )
        unless 'CODE' eq ref $pred;

    foreach my $bus ($self->list_busses())
    {
        my $dev = $bus->find_device_if( $pred );
        return $dev if defined $dev;
    }

    return;
}

=item list_devices

Find all devices matching a vendor id and optional product id. If called
with no parameters, returns a list of all devices. If no product id is
given, returns all devices found with the supplied vendor id. If a product
id is given, returns all devices matching both the vendor id and product id.

=over 4

=item vendor

the optional vendor id

=item product

optional product id for that vendor

=back

returns a list of devices matching the supplied criteria or a reference
to that array in scalar context

=cut

sub list_devices
{
    my $self = shift;
    my $vendor = shift;
    my $product = shift;
    my $pred = undef;

    if(!defined $vendor)
    {
        $pred = sub { defined };
    }
    elsif(!defined $product)
    {
        $pred = sub { $vendor == $_->idVendor() };
    }
    else
    {
        $pred =
            sub { $vendor == $_->idVendor() && $product == $_->idProduct() };
    }

    return $self->list_devices_if( $pred );
}

=item list_devices_if

This method provides a more flexible interface for finding devices. It
takes a single coderef parameter that is used to test each discovered
device. If the coderef returns a true value, the device is returned in the
list of matching devices, otherwise it is not.

=over 4

=item pred

coderef to test devices.

=back

For example,

    my @devices = $usb->list_devices_if(
        sub { Device::USB::CLASS_HUB == $_->bDeviceClass() }
    );

Returns all USB hubs found. The device to test is available to the coderef
in the C<$_> variable for simplicity.

=cut

sub list_devices_if
{
    my $self = shift;
    my $pred = shift;

    croak( "Missing predicate for choosing devices.\n" )
        unless defined $pred;

    croak( "Predicate must be a code reference.\n" )
        unless 'CODE' eq ref $pred;

    my @devices = ();
    local $_ = undef;

    foreach my $bus ($self->list_busses())
    {
        # Push all matching devices for this bus on list.
        push @devices, $bus->list_devices_if( $pred );
    }

    return wantarray ? @devices : \@devices;
}

=item list_busses

Return the complete list of information after finding busses and devices.

By using this function, you do not need to do the find_* calls yourself.

returns a reference to an array of busses.

=cut

sub list_busses
{
    my $self = shift;
    my $busses = lib_list_busses();

    return wantarray ? @{$busses} : $busses;
}

=item get_busses

Return the complete list of information after finding busses and devices.

Before calling this function, remember to call find_busses and find_devices.

returns a reference to an array of busses.

=cut

sub get_busses
{
    my $self = shift;
    my $busses = lib_get_usb_busses();

    return wantarray ? @{$busses} : $busses;
}

=back

=head1 DIAGNOSTICS

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

=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

Original author: David Davis

=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 FOR MORE INFORMATION

The project is hosted at Google Code L.
More information on the project, including installation help is avaliable on the
Wiki.

=head1 LIMITATIONS

So far, this module has only been tested on Linux. It should work on any
OS that supports the libusb library. Several people have reported problems
compiling the module on Windows. In theory, it should be possible to make
the library work with LibUsb-Win32 L.
Without access to a Windows development system, I can't make those changes.

The Interfaces and Endpoints are not yet proper objects. The code to extract
this information is not yet written.

=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.

Thanks to Josep Monés Teixidor for fixing the C bug.

Thanks to Mike McCauley for support of C and
C.

Thanks to Vadim Mikhailov for fixing a compile problem with VC6 on Windows
and then chipping in again for VS 2005 on Windows, and yet again to fix
warnings on C99-compliant compilers.

Thanks to John R. Hogheruis for information about modifying the Inline
parameters for compiling with Strawberry Perl on Windows.

Thanks to Tony Shadwick for helping me resolve a problem with bulk_read and
interrupt_read.

=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;

__DATA__