File Coverage

blib/lib/DDCCI.pm
Criterion Covered Total %
statement 29 62 46.7
branch 5 20 25.0
condition 3 3 100.0
subroutine 9 16 56.2
pod 10 10 100.0
total 56 111 50.4


line stmt bran cond sub pod time code
1             package DDCCI;
2              
3 7     7   467739 use strict;
  7         63  
  7         231  
4 7     7   36 use warnings;
  7         16  
  7         166  
5 7     7   33 use XSLoader;
  7         12  
  7         222  
6 7     7   36 use Exporter 5.57 'import';
  7         161  
  7         263  
7 7     7   41 use Carp;
  7         13  
  7         6749  
8              
9             our $VERSION = '0.003';
10             our %EXPORT_TAGS = ( 'all' => [ qw() ] );
11             our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
12             our @EXPORT = qw(
13             &list_vcp_names
14             &get_vcp_name
15             &get_vcp_addr
16             &decode_edid
17             &scan_devices
18             );
19              
20             XSLoader::load('DDCCI', $VERSION);
21              
22             sub list_vcp_names {
23              
24 1     1 1 2 my $ret = [];
25              
26 1         4 for my $i (0x00 .. 0xff) {
27 256         440 my $n = _get_vcp_name($i);
28 256 100       433 push @{$ret}, $n if ($n ne '???');
  76         132  
29             }
30              
31 1         4 return $ret;
32             }
33              
34             sub get_vcp_name {
35              
36 258     258 1 575 my ($vcp) = @_;
37              
38 258         437 return _get_vcp_name($vcp);
39             }
40              
41             sub get_vcp_addr {
42              
43 5     5 1 561 my ($name) = @_;
44              
45 5         63 return _get_vcp_addr($name);
46             }
47              
48             sub decode_edid {
49              
50 3     3 1 830 my ($edid) = @_;
51 3 100 100     31 return undef if (!defined $edid || (length($edid) != 128));
52              
53 1         11 my @b = (
54             unpack('@8C', $edid),
55             unpack('@9C', $edid),
56             unpack('@10S<', $edid),
57             unpack('@12L', $edid),
58             unpack('@20C', $edid)
59             );
60             return {
61 1 50       15 id => sprintf(
62             '%c%c%c%04X',
63             (($b[0] >> 2) & 0x1f) - 1 + ord('A'),
64             (($b[0] & 0x03) << 3) + ($b[1] >> 5) - 1 + ord('A'),
65             ($b[1] & 0x1f) - 1 + ord('A'),
66             $b[2]
67             ),
68             sn => sprintf('%lu', $b[3]),
69             type => ($b[4] & 0x80) ? 'digital' : 'analog',
70             };
71             }
72              
73             sub scan_devices {
74              
75 0     0 1   my $ret = [];
76              
77 0 0         opendir(my $dh, '/dev') || croak "cannot open /dev";
78 0 0         my @devs = reverse grep { /^i2c-\d+$/ && (-c '/dev/' . $_) } readdir $dh;
  0            
79 0           closedir $dh;
80              
81 0           for my $i (0 .. scalar @devs - 1) {
82 0           my $fn = '/dev/' . $devs[$i];
83 0 0         (my $fd = _open_dev($fn)) || next;
84 0           my $edid = _read_edid($fd);
85 0           my $de = decode_edid($edid);
86 0 0         if (defined $de) {
87 0           push @{$ret}, {
88             dev => $fn,
89             id => $de->{'id'},
90             sn => $de->{'sn'},
91 0           type => $de->{'type'}
92             };
93             }
94 0           _close_dev($fd);
95             }
96              
97 0           return $ret;
98             }
99              
100             sub new {
101 0     0 1   my ($class, $dev) = @_;
102 0 0         defined($dev) || croak "usage: $class\->new(\$dev)";
103              
104 0           my $self = { fd => _open_dev($dev) };
105              
106 0 0         if ($self->{'fd'} < 0) {
107 0           croak "unable to open device $dev";
108 0           return undef;
109             }
110              
111 0           bless $self, $class;
112 0           return $self;
113             }
114              
115             sub DESTROY {
116 0     0     my ($self) = @_;
117              
118 0 0         _close_dev($self->{'fd'}) unless ($self->{'fd'} < 0);
119             }
120              
121             sub read_edid {
122 0     0 1   my ($self) = @_;
123              
124 0           return _read_edid($self->{'fd'});
125             }
126              
127             sub read_caps {
128 0     0 1   my ($self) = @_;
129              
130 0           return _read_caps($self->{'fd'});
131             }
132              
133             sub read_vcp {
134 0     0 1   my ($self, $addr) = @_;
135              
136 0           return _read_vcp($self->{'fd'}, $addr);
137             }
138              
139             sub write_vcp {
140 0     0 1   my ($self, $addr, $value) = @_;
141              
142 0           return _write_vcp($self->{'fd'}, $addr, $value);
143             }
144              
145             1;
146              
147             __END__