File Coverage

blib/lib/App/EventStreamr/Devices.pm

Criterion	Covered	Total	%
statement	47	132	35.6
branch	5	30	16.6
condition	2	6	33.3
subroutine	10	13	76.9
pod	0	7	0.0
total	64	188	34.0

package App::EventStreamr::Devices;
use Moo; # libmoo-perl
use Cwd 'realpath';
use File::Slurp 'read_file'; #libfile-slurp-perl
use Hash::Merge::Simple; # libhash-merge-simple-perl
use Data::Dumper;

# ABSTRACT: Devices Methods

our $VERSION = '0.3'; # VERSION: Generated by DZP::OurPkg:Version


# TODO: Needs a cleanup!

sub all {
  my $self = shift;
  my $v4l = v4l();
  my $dv = dv();
  my $alsa = alsa();
  @{$self->{devices}{v4l}{all}} = ();
  @{$self->{devices}{dv}{all}} = ();
  @{$self->{devices}{alsa}{all}} = ();

  if ($v4l) { $self->{devices}{v4l} = $v4l;       }
  if ($dv)  { $self->{devices}{dv} = $dv;         }
  if ($alsa)  { $self->{devices}{alsa} = $alsa;   }
  if ($v4l || $dv || $alsa) {
    $self->{devices}{all} = Hash::Merge::Simple->merge($v4l,$dv,$alsa);
    @{$self->{devices}{array}} = (@{$self->{devices}{v4l}{all}}, @{$self->{devices}{dv}{all}},@{$self->{devices}{alsa}{all}});
  } else {
    $self->{devices}{all} = undef;
    @{$self->{devices}{array}} = [];
  }

  return $self->{devices};
}

sub v4l {
  my @v4ldevices = glob "/dev/video*";
  my $v4l_devices;
  foreach my $device (@v4ldevices) {
    $device =~ m/\/dev\/(?<index>.+)/;
    my $index = $+{index};
    $v4l_devices->{$index}{device} = $device;
    $v4l_devices->{$index}{name} = get_v4l_name($index);
    $v4l_devices->{$index}{type} = "V4L";
    $v4l_devices->{$index}{id} = $index;
    push (@{$v4l_devices->{all}}, $v4l_devices->{$index});
  }
  return $v4l_devices;
}

sub dv {
  my @dvs =  glob "/sys/bus/firewire/devices/*";
  my $dv_devices;

  foreach my $dv (@dvs) {
    if (-e "$dv/vendor") {
      my $vendor_name = read_file("$dv/vendor");
      $vendor_name = read_file("$dv/vendor_name") if ( -e "$dv/vendor_name" );
      chomp $vendor_name;
      $vendor_name = "Canopus" if ( $vendor_name eq "0x002011" );

      unless ($vendor_name eq "Linux Firewire") {
        my $guid = read_file("$dv/guid");
        my $model = "unknown";
        $model = "twinpact100" if ( $vendor_name eq "Canopus" );
        $model = read_file("$dv/model_name") if ( -e "$dv/model_name" );
        chomp $guid;
        chomp $model;
        $dv_devices->{$guid}{device} = $guid;
        $dv_devices->{$guid}{model} = $model;
        $dv_devices->{$guid}{name} = "$vendor_name $model";
        $dv_devices->{$guid}{type} = "DV";
        $dv_devices->{$guid}{id} = $guid;
        $dv_devices->{$guid}{path} = "$dv/guid";
        push (@{$dv_devices->{all}}, $dv_devices->{$guid}); ;
      }
    }
  }
  return $dv_devices;
}

sub alsa { # Only Does USB devices currently
  my $alsa_devices;
  if (-e "/proc/asound/cards") {
    my @devices = read_file("/proc/asound/cards");
    @devices = grep { /].+USB Audio (CODEC|Device)/ } @devices;
    chomp @devices;

    foreach my $device (@devices) {
      $device =~ m/^.+(?<card> \d+).*/x;
      my $card = $+{card};
      my $usbid = read_file("/proc/asound/card$card/usbid");
      my $name = name_lsusb($usbid);
      chomp $usbid;

      $alsa_devices->{$usbid}{id} = $usbid;
      $alsa_devices->{$usbid}{name} = $name;
      $alsa_devices->{$usbid}{device} = $card;
      $alsa_devices->{$usbid}{type} = "ALSA";
      $alsa_devices->{$usbid}{alsa} = $card;
      push (@{$alsa_devices->{all}}, $alsa_devices->{$usbid});
    }
  }
  return $alsa_devices;
}

sub get_v4l_name {
  my ($device) = @_;
  my $name;

  # Find USB
  my $index = $+{index};
  my @usbs = glob "/dev/v4l/by-id/*";
  foreach my $usb (@usbs) {
    if ( realpath($usb) =~ /$index/ ) {
      $usb =~ m/\/dev\/v4l\/by-id\/usb-(?<name> .+)-video-index\d/ix;
      $name = $+{name};

      # Some lesser known devices don't present a name in the path but an ID
      if ( $name =~ /^[^+s]{4}_[^+s]{4}$/ ) {
        $name = name_lsusb($name);
      } else {
        $name =~ s/_/\ /g;
      }
      last;
    }
  }
  # Find PCI
  unless ($name) {
    my @pcis = glob "/dev/v4l/by-path/*";
    foreach my $pci (@pcis) {
      if ( realpath($pci) =~ /$index/ ) {
        $pci =~ m/pci-[^+s]{4}:(?<pciid>..:..\..)-video-index\d/ix;
        $name = name_lspci($+{pciid});
        last;
      }
    }
  }

  return $name;
}

sub name_lsusb {
  my ($name) = @_;
  $name =~ m/^(?<vid> [^+s]{4}).(?<did> [^+s]{4})$/ix;
  $name = `lsusb | grep \"$+{vid}:$+{did}\"`;
  $name =~ m/^Bus.\d+.Device.\d+:.ID.[^+s]{4}:[^+s]{4}.(?<name>.+)/ix;
  $name = $+{name};
  return $name;
}

sub name_lspci {
  my ($name) = @_;
  $name = `lspci | grep \"$name\"`;
  $name =~ m/..:..\...(?<name>.+)/ix;
  $name = $+{name};
  return $name;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

App::EventStreamr::Devices - Devices Methods

=head1 VERSION

version 0.3

=head1 SYNOPSIS

Return available devices

=head1 DESCRIPTION

Return array/hash of available devices.

=head1 AUTHOR

Leon Wright < [e-mail] >

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2014 by Leon Wright.

This is free software, licensed under:

  The GNU Affero General Public License, Version 3, November 2007

=cut