File Coverage

blib/lib/HiPi/Interface/IS31FL3730.pm
Criterion Covered Total %
statement 24 63 38.1
branch 0 12 0.0
condition 0 2 0.0
subroutine 8 19 42.1
pod 0 9 0.0
total 32 105 30.4


line stmt bran cond sub pod time code
1             #########################################################################################
2             # Package HiPi::Interface::IS31FL3730
3             # Description : Interface to IS31FL3730 matrix LED driver
4             # Copyright : Copyright (c) 2018 Mark Dootson
5             # License : This is free software; you can redistribute it and/or modify it under
6             # the same terms as the Perl 5 programming language system itself.
7             #########################################################################################
8              
9             package HiPi::Interface::IS31FL3730;
10              
11             #########################################################################################
12              
13 1     1   1421 use strict;
  1         2  
  1         28  
14 1     1   6 use warnings;
  1         2  
  1         29  
15 1     1   5 use parent qw( HiPi::Interface );
  1         1  
  1         6  
16 1     1   59 use HiPi qw( :i2c :rpi :fl3730);
  1         3  
  1         507  
17 1     1   8 use HiPi::RaspberryPi;
  1         2  
  1         8  
18 1     1   30 use Carp;
  1         2  
  1         54  
19 1     1   5 use Try::Tiny;
  1         3  
  1         100  
20              
21             our $VERSION ='0.80';
22              
23             __PACKAGE__->create_accessors( qw( ) );
24              
25             use constant {
26 1         752 REG_CONFIG => 0x00,
27             REG_MATRIX_1 => 0x01,
28             REG_MATRIX_2 => 0x0E,
29             REG_UPD_COL => 0x0C,
30             REG_LIGHTING => 0x0D,
31             REG_PWM => 0x19,
32             REG_RESET => 0xFF,
33 1     1   7 };
  1         2  
34              
35              
36             sub new {
37 0     0 0   my ($class, %userparams) = @_;
38 0           my $pi = HiPi::RaspberryPi->new();
39            
40 0 0         my %params = (
41             devicename => ( $pi->board_type == RPI_BOARD_TYPE_1 ) ? '/dev/i2c-0' : '/dev/i2c-1',
42             address => 0x60,
43             device => undef,
44             backend => 'smbus',
45             );
46            
47             # get user params
48 0           foreach my $key( keys (%userparams) ) {
49 0           $params{$key} = $userparams{$key};
50             }
51            
52 0 0         unless( defined($params{device}) ) {
53 0 0         if ( $params{backend} eq 'bcm2835' ) {
54 0           require HiPi::BCM2835::I2C;
55             $params{device} = HiPi::BCM2835::I2C->new(
56             address => $params{address},
57 0 0         peripheral => ( $params{devicename} eq '/dev/i2c-0' ) ? HiPi::BCM2835::I2C::BB_I2C_PERI_0() : HiPi::BCM2835::I2C::BB_I2C_PERI_1(),
58             );
59             } else {
60 0           require HiPi::Device::I2C;
61             $params{device} = HiPi::Device::I2C->new(
62             devicename => $params{devicename},
63             address => $params{address},
64             #busmode => $params{backend},
65 0           busmode => 'i2c', # force i2c
66             );
67             }
68             }
69            
70 0           my $self = $class->SUPER::new(%params);
71            
72 0           return $self;
73             }
74              
75             sub configure {
76 0     0 0   my($self, $mask ) = @_;
77 0           $self->send_command( REG_CONFIG, $mask );
78             }
79              
80             sub matrix_1_data {
81 0     0 0   my($self, @data ) = @_;
82 0           $self->send_command( REG_MATRIX_1, @data );
83             }
84              
85             sub matrix_2_data {
86 0     0 0   my($self, @data ) = @_;
87 0           $self->send_command( REG_MATRIX_2, @data );
88             }
89              
90             sub lighting_effect {
91 0     0 0   my($self, $mask) = @_;
92 0           $self->send_command( REG_LIGHTING, $mask );
93             }
94              
95             sub brightness {
96 0     0 0   my($self, $value) = @_;
97 0   0       $value //= 127; # undefined get default 127
98 0 0         my $mask = ( $value > 127 ) ? 0x80 : $value & 0x7F;
99 0           $self->send_command( REG_PWM, $mask );
100             }
101              
102             sub update {
103 0     0 0   my $self = shift;
104 0           $self->send_command( REG_UPD_COL, 0x00 );
105             }
106              
107             sub reset {
108 0     0 0   my $self = shift;
109 0           $self->send_command( REG_RESET, 0x00 );
110             }
111              
112             sub send_command {
113 0     0 0   my($self, $register, @data ) = @_;
114             # Timing issue - pullup values if not mounted as pHAT ?
115             # Clock too high on RPi 3 ??
116             # Need to resolve - but for now catch and retry
117 0           my $continue = 10;
118 0           while( $continue ) {
119             try {
120 0     0     $self->device->bus_write( $register, @data );
121 0           $continue = 0;
122             } catch {
123 0     0     $continue --;
124 0 0         if( $continue <= 0 ) {
125 0           croak sprintf('IO Error writing to register 0x%X', $register);
126             }
127 0           $self->delay(5);
128 0           };
129             }
130             }
131              
132             1;
133              
134             __END__