File Coverage

blib/lib/VIC/PIC/Functions/GPIO.pm
Criterion Covered Total %
statement 211 252 83.7
branch 112 160 70.0
condition 17 33 51.5
subroutine 17 17 100.0
pod 0 8 0.0
total 357 470 75.9


line stmt bran cond sub pod time code
1             package VIC::PIC::Functions::GPIO;
2 31     31   14789 use strict;
  31         49  
  31         775  
3 31     31   104 use warnings;
  31         46  
  31         582  
4 31     31   103 use bigint;
  31         40  
  31         172  
5             our $VERSION = '0.29';
6             $VERSION = eval $VERSION;
7 31     31   18420 use Carp;
  31         61  
  31         1885  
8 31     31   126 use POSIX ();
  31         56  
  31         481  
9 31     31   106 use Scalar::Util qw(looks_like_number);
  31         52  
  31         1212  
10 31     31   264 use Moo::Role;
  31         1984  
  31         318  
11              
12             sub get_output_pin {
13 37     37 0 346 my ($self, $ipin) = @_;
14 37 100       169 return $ipin if exists $self->output_pins->{$ipin};
15             # find the correct GPIO pin then matching this pin
16 4         9 my $pin_no = $self->pins->{$ipin};
17 4         9 my $allpins = $self->pins->{$pin_no};
18 4 50       13 unless (ref $allpins eq 'ARRAY') {
19 0         0 carp "Invalid data for pin $pin_no";
20 0         0 return;
21             }
22 4         5 my $opin;
23 4         9 foreach my $iopin (@$allpins) {
24 4 50       15 next unless exists $self->output_pins->{$iopin};
25             # we have now found the correct iopin for the analog_pin
26 4         5 $opin = $iopin;
27 4         9 last;
28             }
29 4         12 return $opin;
30             }
31              
32             sub get_input_pin {
33 121     121 0 707 my ($self, $ipin) = @_;
34 121 100       379 return $ipin if exists $self->input_pins->{$ipin};
35             # find the correct GPIO pin then matching this pin
36 37         59 my $pin_no = $self->pins->{$ipin};
37 37         53 my $allpins = $self->pins->{$pin_no};
38 37 50       95 unless (ref $allpins eq 'ARRAY') {
39 0         0 carp "Invalid data for pin $pin_no";
40 0         0 return;
41             }
42 37         39 my $opin;
43 37         51 foreach my $iopin (@$allpins) {
44 37 50       73 next unless exists $self->input_pins->{$iopin};
45             # we have now found the correct iopin for the analog_pin
46 37         37 $opin = $iopin;
47 37         37 last;
48             }
49 37         77 return $opin;
50             }
51              
52             sub _gpio_select {
53 37     37   48 my $self = shift;
54 37         77 my ($io, $ad, $outp) = @_;
55 37 50       292 return unless $self->doesroles(qw(Chip GPIO));
56 37 50       102 return unless defined $outp;
57 37 100       162 $io = 0 if $io =~ /output/i;
58 37 100       131 $io = 1 if $io =~ /input/i;
59 37 100       742 $ad = 0 if $ad =~ /digital/i;
60 37 100       82 $ad = 1 if $ad =~ /analog/i;
61 37 50 66     625 return unless (($io == 0 or $io == 1) and ($ad == 0 or $ad == 1));
      66        
      33        
62             #TODO: check if banksel works for all chips
63             #if not then allow for a way to map instruction codes
64             #to something else
65              
66             # is this a register
67 37         1888 my ($trisp_code, $port_code, $an_code) = ('', '', '');
68 37 100 66     360 if (exists $self->io_ports->{$outp} and
    50          
69             exists $self->registers->{$outp}) {
70 13         43 my $trisp = $self->io_ports->{$outp};
71 13 50       26 my $flags = ($ad == 0) ? 0xFF : 0;
72 13 50       230 my $flagsH = ($ad == 0) ? 0xFF : 0;
73 13 50       227 if (exists $self->registers->{ANSEL}) {
74             # get the pins that belong to the register
75 13         23 my @portpins = ();
76 13 100       29 if ($io == 0) {
77 12         182 foreach (keys %{$self->output_pins}) {
  12         132  
78 204 100       1735 push @portpins, $_ if $self->output_pins->{$_}->[0] eq $outp;
79             }
80             } else {
81 1         13 foreach (keys %{$self->input_pins}) {
  1         6  
82 18 100       135 push @portpins, $_ if $self->input_pins->{$_}->[0] eq $outp;
83             }
84             }
85 13         257 foreach (@portpins) {
86 97         184 my $pin_no = $self->pins->{$_};
87 97 50       146 next unless defined $pin_no;
88 97         131 my $allpins = $self->pins->{$pin_no};
89 97 50       163 next unless ref $allpins eq 'ARRAY';
90 97         106 foreach my $anpin (@$allpins) {
91 324 100       9795 next unless exists $self->analog_pins->{$anpin};
92 72         58 my ($pno, $pbit) = @{$self->analog_pins->{$anpin}};
  72         149  
93 72 100       411 $flags ^= 1 << $pbit if $pbit < 8;
94 72 100       13022 $flagsH ^= 1 << ($pbit - 8) if $pbit >= 8;
95             }
96             }
97 13 50       34 my $iorandwf = ($ad == 0) ? 'andwf' : 'iorwf';
98 13 50       236 if ($flags != 0) {
99 13         222 $flags = sprintf "0x%02X", $flags;
100 13         166 $an_code .= "\tbanksel ANSEL\n";
101 13         28 $an_code .= "\tmovlw $flags\n";
102 13         33 $an_code .= "\t$iorandwf ANSEL, F\n";
103             }
104 13 50       54 if (exists $self->registers->{ANSELH}) {
105 13 50       28 if ($flagsH != 0) {
106 13         218 $flagsH = sprintf "0x%02X", $flagsH;
107 13         136 $an_code .= "\tbanksel ANSELH\n";
108 13         32 $an_code .= "\tmovlw $flagsH\n";
109 13         38 $an_code .= "\t$iorandwf ANSELH, F\n";
110             }
111             }
112             }
113 13 100       30 if ($io == 0) { # output
114 12         201 $trisp_code = "\tbanksel $trisp\n\tclrf $trisp";
115 12         39 $port_code = "\tbanksel $outp\n\tclrf $outp";
116             } else { # input
117 1         15 $trisp_code = "\tbanksel $trisp\n\tmovlw 0xFF\n\tmovwf $trisp";
118 1         1 $port_code = "\tbanksel $outp";
119             }
120             } elsif (exists $self->pins->{$outp}) {
121 24 100       57 my $iopin = ($io == 0) ? $self->get_output_pin($outp) :
122             $self->get_input_pin($outp);
123 24 50       91 unless (defined $iopin) {
124 0 0       0 my $iostr = ($io == 0) ? 'output' : 'input';
125 0         0 carp "Cannot find $outp in the list of registers or $iostr pins supporting GPIO for the chip " . $self->type;
126 0         0 return;
127             }
128             my ($port, $trisp, $pinbit) = ($io == 0) ?
129 14         290 @{$self->output_pins->{$iopin}} :
130 24 100       58 @{$self->input_pins->{$iopin}};
  10         198  
131              
132 24 50       107 if (exists $self->registers->{ANSEL}) {
133 24         68 my $pin_no = $self->pins->{$iopin};
134 24         65 my $allpins = $self->pins->{$pin_no};
135 24 50       85 unless (ref $allpins eq 'ARRAY') {
136 0         0 carp "Invalid data for pin $pin_no";
137 0         0 return;
138             }
139 24         53 foreach my $anpin (@$allpins) {
140 52 100       196 next unless exists $self->analog_pins->{$anpin};
141 20         33 my ($pno, $pbit) = @{$self->analog_pins->{$anpin}};
  20         84  
142 20         42 my $ansel = 'ANSEL';
143 20 50       74 if (exists $self->registers->{ANSELH}) {
144 20 50       59 $ansel = ($pbit >= 8) ? 'ANSELH' : 'ANSEL';
145             }
146             ##TODO: make sure that ANS$pbit exists for all header files
147 20 100       1941 my $bcfbsf = ($ad == 0) ? 'bcf' : 'bsf';
148 20         816 $an_code = "\tbanksel $ansel\n\t$bcfbsf $ansel, ANS$pbit";
149 20         46 last;
150             }
151             }
152 24 100       57 if ($io == 0) { # output
153 14         269 $trisp_code = "\tbanksel $trisp\n\tbcf $trisp, $trisp$pinbit";
154 14         45 $port_code = "\tbanksel $port\n\tbcf $port, $pinbit";
155             } else { # input
156 10         188 $trisp_code = "\tbanksel $trisp\n\tbsf $trisp, $trisp$pinbit";
157 10         23 $port_code = "\tbanksel $port";
158             }
159             } else {
160 0         0 carp "Cannot find $outp in the list of registers or pins supporting GPIO";
161 0         0 return;
162             }
163 37         188 return << "...";
164             $trisp_code
165             $an_code
166             $port_code
167             ...
168             }
169              
170             sub digital_output {
171 26     26 0 198 my $self = shift;
172 26         120 return $self->_gpio_select(output => 'digital', @_);
173             }
174              
175             sub digital_input {
176 8     8 0 54 my $self = shift;
177 8         28 return $self->_gpio_select(input => 'digital', @_);
178             }
179              
180             sub analog_input {
181 3     3 0 16 my $self = shift;
182 3         9 return $self->_gpio_select(input => 'analog', @_);
183             }
184              
185             sub setup {
186 3     3 0 27 my $self = shift;
187 3         6 my ($outp) = @_;
188 3 50       18 if ($outp =~ /US?ART/) {
189 3 50 33     13 if ($self->doesrole('USART') and exists $self->usart_pins->{$outp}) {
190 3         18 return $self->usart_setup(@_);
191             }
192             }
193 0         0 carp "The 'setup' function is not valid for $outp. Use something else.";
194 0         0 return;
195             }
196              
197             sub write {
198 46     46 0 246 my $self = shift;
199 46         89 my ($outp, $val) = @_;
200 46 50       153 return unless $self->doesroles(qw(CodeGen Operations Chip GPIO));
201 46 50       254 return unless defined $outp;
202 46 100 66     371 if (exists $self->io_ports->{$outp} and
    100          
    50          
203             exists $self->registers->{$outp}) {
204 20         46 my $port = $self->io_ports->{$outp};
205 20 50       40 unless (defined $val) {
206 0         0 return << "...";
207             \tclrf $outp
208             \tcomf $outp, 1
209             ...
210             }
211 20 50       73 if ($self->validate($val)) {
212             # ok we want to write the value of a pin to a port
213             # that doesn't seem right so let's provide a warning
214 0 0       0 if ($self->pins->{$val}) {
215 0         0 carp "$val is a pin and you're trying to write a pin to a port" .
216             " $outp. You can write a pin to a pin or a port to a port only.\n";
217 0         0 return;
218             }
219             }
220             # this handles the variable to port assigning
221 20         58 return $self->op_assign($outp, $val);
222             } elsif (exists $self->pins->{$outp}) {
223 19         42 my $iopin = $self->get_output_pin($outp);
224 19 50       46 unless (defined $iopin) {
225 0         0 carp "Cannot find $outp in the list of VALID ports, register or pins to write to";
226 0         0 return;
227             }
228 19         23 my ($port, $trisp, $pinbit) = @{$self->output_pins->{$iopin}};
  19         188  
229 19 100       129 if ($val =~ /^\d+$/) {
    100          
    100          
230 10 100       72 return "\tbanksel $port\n\tbcf $port, $pinbit\n" if "$val" eq '0';
231 7 50       51 return "\tbanksel $port\n\tbsf $port, $pinbit\n" if "$val" eq '1';
232 0         0 carp "$val cannot be applied to a pin $outp\n";
233 0         0 return;
234             } elsif (exists $self->pins->{$val}) {
235             # ok we want to short two pins, and this is not bit-banging
236             # although seems like it
237 4         9 my $vpin = $self->get_output_pin($val);
238 4 50       8 if ($vpin) {
239 4         7 my ($vport, $vtris, $vpinbit) = @{$self->output_pins->{$vpin}};
  4         13  
240 4         28 return << "...";
241             \tbtfss $vport, $vpin
242             \tbcf $port, $outp
243             \tbtfsc $vport, $vpin
244             \tbsf $port, $outp
245             ...
246             } else {
247 0         0 carp "$val is a port or unknown pin and cannot be written to a pin $outp. ".
248             "Only a pin can be written to a pin.\n";
249 0         0 return;
250             }
251             } elsif ($self->is_variable($val)) {
252 4         8 $val = uc $val;
253 4         25 return << "...";
254             ;;;; assigning $val to a pin => using the last bit
255             \tbtfss $val, 0
256             \tbcf $port, $outp
257             \tbtfsc $val, 0
258             \tbsf $port, $outp
259             ...
260             } else {
261 1         190 carp "$val is a port or unknown pin and cannot be written to a pin $outp. ".
262             "Only a pin can be written to a pin.\n";
263 1         84 return;
264             }
265 0         0 return $self->op_assign($port, $val);
266             } elsif (exists $self->registers->{$outp}) { # write a value to a register
267 0         0 my $code = "\tbanksel $outp\n";
268 0         0 $code .= $self->op_assign($outp, $val);
269 0         0 return $code;
270             } else {
271 7 50 33     15 if ($self->doesrole('USART') and exists $self->usart_pins->{$outp}) {
272 7         19 return $self->usart_write(@_);
273             }
274 0         0 carp "Cannot find $outp in the list of ports, register or pins to write to";
275 0         0 return;
276             }
277             }
278              
279             sub _macro_read_var {
280 6     6   10 my $v = $_[1];
281 6         14 $v = uc $v;
282 6         45 return << "...";
283             ;;;;;;; $v VARIABLES ;;;;;;
284             $v\_UDATA udata
285             $v res 1
286             ...
287             }
288              
289             sub read {
290 6     6 0 36 my $self = shift;
291 6         12 my $inp = shift;
292 6         6 my $var = undef;
293 6         16 my %action = ();
294 6 100       21 if (scalar(@_) == 1) {
295 1         59 $var = shift;
296             } else {
297 5         413 %action = @_;
298             }
299 6 50       21 return unless $self->doesroles(qw(CodeGen Chip GPIO));
300 6         19 my ($code, $funcs, $macros, $tables) = ('', {}, {}, []);
301              
302 6 100       16 if (defined $var) {
303 1 50 33     25 if (looks_like_number($var) or ref $var eq 'HASH') {
304 0         0 carp "Cannot read from $inp into a constant $var";
305 0         0 return;
306             }
307 1         4 $var = uc $var;
308             } else {
309             ## we need only 1 variable here
310 5 50       18 if (defined $action{PARAM}) {
311 5         15 $var = $action{PARAM} . '0';
312             } else {
313 0         0 carp "Implementation errors implementing the Action block";
314 0         0 return undef;
315             }
316 5         10 $var = uc $var;
317 5         17 $macros->{lc("m_read_$var")} = $self->_macro_read_var($var);
318 5 50 66     36 return unless (defined $action{ACTION} or defined $action{ISR});
319 5 50       13 return unless defined $action{END};
320             }
321 6         23 my $bits = $self->address_bits($var);
322 6         10 my ($port, $portbit);
323 6 100 66     54 if (exists $self->io_ports->{$inp} and
    100          
324             exists $self->registers->{$inp}) {
325             # this is a port like PORT[A-Z]
326             # we may end up reading from all pins on a port
327 1         2 $port = $inp;
328 1         4 $code = <<"...";
329             ;;; instant reading from $port into $var
330             \tbanksel $port
331             \tmovf $port, W
332             \tbanksel $var
333             \tmovwf $var
334             ...
335             } elsif (exists $self->pins->{$inp}) {
336 4         10 my $ipin = $self->get_input_pin($inp);
337 4 50       10 unless (defined $ipin) {
338 0         0 carp "Cannot find $inp in the list of GPIO ports or pins";
339 0         0 return;
340             } else {
341 4         7 my $tris;
342 4         5 ($port, $tris, $portbit) = @{$self->input_pins->{$inp}};
  4         15  
343 4         25 $code = <<"....";
344             ;;; instant reading from $inp into $var
345             \tclrw
346             \tbanksel $port
347             \tbtfsc $port, $portbit
348             \taddlw 0x01
349             \tbanksel $var
350             \tmovwf $var
351             ....
352             }
353             } else {
354 1 50 33     4 if ($self->doesrole('USART') and exists $self->usart_pins->{$inp}) {
355 1         5 return $self->usart_read($inp, @_);
356             }
357 0         0 carp "Cannot find $inp in the list of ports or pins to read from";
358 0         0 return;
359             }
360 5 100       16 if (%action) {
361 4 100       14 if (exists $action{ACTION}) {
    50          
362 1         3 my $action_label = $action{ACTION};
363 1         2 my $end_label = $action{END};
364 1         10 $code .= <<"...";
365             ;;; invoking $action_label
366             \tgoto $action_label
367             $end_label:\n
368             ...
369             } elsif (exists $action{ISR}) {
370             ## ok we can read from a port too, so let's do that as well
371 3 100       13 if (defined $portbit) {
372             # if we are a pin, then find the right pin
373 2         5 $inp = $self->get_input_pin($inp);
374             }
375             ## reset the code here since we have to check IOC pins
376 3         9 my ($ioc_bit, $ioc_reg, $ioc_flag, $ioc_enable);
377 3 100       12 if (exists $self->ioc_pins->{$inp}) {
    50          
378 2         2 my $apin;
379 2         3 ($apin, $ioc_bit, $ioc_reg) = @{$self->ioc_pins->{$inp}};
  2         7  
380             } elsif (exists $self->ioc_ports->{$inp}) {
381 1         5 $ioc_reg = $self->ioc_ports->{$inp};
382             } else {
383 0         0 carp "Reading using interrupt-on-change has to be for a pin ".
384             "that supports it, $inp does not support it or is not a pin.";
385 0         0 return;
386             }
387 3         13 $ioc_flag = $self->ioc_ports->{FLAG};
388 3         8 $ioc_enable = $self->ioc_ports->{ENABLE};
389 3         14 my $ioch = { bit => $ioc_bit, reg => $ioc_reg, flag =>
390             $ioc_flag, enable => $ioc_enable };
391 3         16 $code = $self->isr_ioc($ioch, $inp);
392 3 50       15 my $isr_label = 'isr_' . ((defined $ioc_bit) ? lc($ioc_bit) :
    100          
393             ((defined $ioc_reg) ? lc($ioc_reg) :
394             lc($inp)));
395 3         15 $funcs->{$isr_label} = $self->isr_ioc($ioch, $inp, $var, $port, $portbit, %action);
396             } else {
397 0         0 carp "Unknown action requested. Probably a bug in implementation";
398 0         0 return;
399             }
400             }
401 5 50       29 return wantarray ? ($code, $funcs, $macros, $tables) : $code;
402             }
403              
404             1;
405             __END__