File Coverage

blib/lib/VIC/PIC/Functions/USART.pm
Criterion Covered Total %
statement 188 220 85.4
branch 60 110 54.5
condition 10 32 31.2
subroutine 16 16 100.0
pod 0 3 0.0
total 274 381 71.9


line stmt bran cond sub pod time code
1             package VIC::PIC::Functions::USART;
2 31     31   19022 use strict;
  31         45  
  31         814  
3 31     31   111 use warnings;
  31         39  
  31         1320  
4             our $VERSION = '0.31';
5             $VERSION = eval $VERSION;
6 31     31   113 use Carp;
  31         35  
  31         1544  
7 31     31   136 use POSIX ();
  31         37  
  31         491  
8 31     31   100 use Scalar::Util qw(looks_like_number);
  31         35  
  31         1157  
9 31     31   137 use Moo::Role;
  31         42  
  31         157  
10              
11             sub usart_setup {
12 3     3 0 8 my ($self, $outp, $baudr) = @_;
13 3 50       31 return unless $self->doesroles(qw(USART GPIO CodeGen Chip));
14 3 50       21 return unless $outp =~ /UART|USART/;
15 3 50       12 my $sync = ($outp =~ /^UART/) ? 0 : 1; # the other is USART
16 3         15 my $ipin = $self->usart_pins->{async_in};
17 3         9 my $opin = $self->usart_pins->{async_out};
18 3         8 my $sclk = $self->usart_pins->{sync_clock};
19 3         8 my $sdat = $self->usart_pins->{sync_data};
20 3 50 33     21 return unless (defined $ipin and defined $opin);
21             #return if ($sync == 1 and not defined $sclk and not defined $sdat);
22 3 50 33     29 return unless (exists $self->pins->{$ipin} and exists $self->pins->{$opin});
23 3         12 my ($code, $funcs, $macros, $tables) = ('', {}, {}, []);
24 3         14 $macros->{m_usart_var} = $self->_usart_var;
25 3 50 33     40 if (exists $self->registers->{SPBRGH} and
    0 33        
26             exists $self->registers->{SPBRG} and
27             exists $self->registers->{BAUDCTL}) {
28             ## Enhanced USART (16-bit)
29             ## Required registers TXSTA, RCSTA, BAUDCTL, TXREG, RCREG
30             ## To enable the transmitter for asynchronous ops
31             ## TXEN = 1, SYNC = 0, SPEN = 1
32             ## if TX/CK pin is shared with analog I/O then clear the appropriate
33             ## ANSEL bit
34             ## find if the $ipin/$opin is shared with an analog pin
35 3         8 my ($baud_code, $io_code, $an_code) = ('', '', '');
36 3 50       8 my $key = $sync ? 'usart' : 'uart';
37             ## calculate the Baud rate
38 3         4 my $baudrate = $baudr;
39 3 50       8 $baudrate = $self->code_config->{$key}->{baud} unless defined $baudr;
40             # find closest approximation of baud-rate
41             # if baud-rate not given assume 9600
42 3   33     35 my $f_osc = $self->code_config->{$key}->{f_osc} || $self->f_osc;
43 3         16 my $baudref = $self->usart_baudrates($baudrate, $f_osc, $sync);
44 3 50       12 unless (ref $baudref eq 'HASH') {
45 0         0 carp "Baud rate $baudrate cannot be supported";
46 0         0 return;
47             }
48 3         23 my $spbrgh = sprintf "0x%02X", (($baudref->{SPBRG} >> 8) & 0xFF);
49 3         7 my $spbrg = sprintf "0x%02X", ($baudref->{SPBRG} & 0xFF);
50 3         4 my $baudctl_code = '';
51 3 50       19 if ($baudref->{BRG16}) {
52 0         0 $baudctl_code .= "\tbanksel BAUDCTL\n\tbsf BAUDCTL, BRG16\n";
53             } else {
54 3         8 $baudctl_code .= "\tbanksel BAUDCTL\n\tbcf BAUDCTL, BRG16\n";
55             }
56 3 50       8 if ($baudref->{BRGH}) {
57 3         5 $baudctl_code .= "\tbanksel TXSTA\n\tbsf TXSTA, BRGH\n";
58             } else {
59 0         0 $baudctl_code .= "\tbanksel TXSTA\n\tbcf TXSTA, BRGH\n";
60             }
61 3         6 chomp $baudctl_code;
62 3         50 my $cbaud = sprintf "%0.04f", $baudref->{actual};
63 3         14 my $ebaud = sprintf "%0.06f%%", $baudref->{error};
64 3         22 $baud_code .= <<"...";
65             ;;;Desired Baud: $baudref->{baud}
66             ;;;Calculated Baud: $cbaud
67             ;;;Error: $ebaud
68             ;;;SPBRG: $baudref->{SPBRG}
69             ;;;BRG16: $baudref->{BRG16}
70             ;;;BRGH: $baudref->{BRGH}
71             $baudctl_code
72             \tbanksel SPBRG
73             \tmovlw $spbrgh
74             \tmovwf SPBRGH
75             \tmovlw $spbrg
76             \tmovwf SPBRG
77             ...
78 3 50       13 if (exists $self->registers->{ANSEL}) {
79 3         8 my $ipin_no = $self->pins->{$ipin};
80 3         12 my $opin_no = $self->pins->{$opin};
81 3         7 my $iallpins = $self->pins->{$ipin_no};
82 3         8 my $oallpins = $self->pins->{$opin_no};
83 3 50       13 unless (ref $iallpins eq 'ARRAY') {
84 0         0 carp "Invalid data for pin $ipin_no";
85 0         0 return;
86             }
87 3 50       9 unless (ref $oallpins eq 'ARRAY') {
88 0         0 carp "Invalid data for pin $opin_no";
89 0         0 return;
90             }
91 3         6 my @anpins = ();
92 3         7 foreach (@$iallpins) {
93 12 100       47 push @anpins, $_ if exists $self->analog_pins->{$_};
94             }
95 3         7 foreach (@$oallpins) {
96 9 50       155 push @anpins, $_ if exists $self->analog_pins->{$_};
97             }
98 3         4 my $pansel = '';
99 3         9 foreach (sort @anpins) {
100 3         4 my ($pno, $pbit) = @{$self->analog_pins->{$_}};
  3         13  
101 3         4 my $ansel = 'ANSEL';
102 3 50       11 if (exists $self->registers->{ANSELH}) {
103 3 50       8 $ansel = ($pbit >= 8) ? 'ANSELH' : 'ANSEL';
104             }
105 3 50       8 if ($ansel ne $pansel) {
106 3         8 $an_code .= "\tbanksel $ansel\n";
107 3         4 $pansel = $ansel;
108             }
109 3         11 $an_code .= "\tbcf $ansel, ANS$pbit\n";
110             }
111             }
112 3 50 33     20 unless (exists $self->registers->{TXSTA} and
113             exists $self->registers->{RCSTA}) {
114 0         0 carp "Register TXSTA & RCSTA are required for operations for $outp";
115 0         0 return;
116             }
117 3 50       7 if ($sync) {
118             #TODO
119 0         0 carp "Synchronous operations not implemented\n";
120 0         0 return;
121             }
122 3         13 $io_code .= <<"...";
123             \tbanksel TXSTA
124             \t;; asynchronous operation
125             \tbcf TXSTA, SYNC
126             \t;; transmit enable
127             \tbsf TXSTA, TXEN
128             \tbanksel RCSTA
129             \t;; serial port enable
130             \tbsf RCSTA, SPEN
131             \t;; continuous receive enable
132             \tbsf RCSTA, CREN
133             $an_code
134             ...
135              
136 3         14 $code = <<"EUSARTCODE";
137             $baud_code
138             $io_code
139             EUSARTCODE
140             } elsif (exists $self->registers->{SPBRG}) {
141             ## USART (8-bit)
142             } else {
143 0         0 carp "$outp for chip ", $self->type, " is not supported";
144 0         0 return;
145             }
146 3 50       20 return wantarray ? ($code, $funcs, $macros, $tables) : $code;
147             }
148              
149             sub _usart_var {
150 3     3   7 return <<'...';
151             ;;;;;;; USART I/O VARS ;;;;;;
152             VIC_VAR_USART_UDATA udata
153             VIC_VAR_USART_WLEN res 1
154             VIC_VAR_USART_WIDX res 1
155             VIC_VAR_USART_RLEN res 1
156             VIC_VAR_USART_RIDX res 1
157             ...
158             }
159              
160             sub _usart_write_bytetbl {
161 5     5   13 return <<"....";
162             m_usart_write_bytetbl macro tblentry, wlen
163             \tlocal _usart_write_bytetbl_loop_0
164             \tlocal _usart_write_bytetbl_loop_1
165             \tbanksel VIC_VAR_USART_WLEN
166             \tmovlw wlen
167             \tmovwf VIC_VAR_USART_WLEN
168             \tbanksel VIC_VAR_USART_WIDX
169             \tclrf VIC_VAR_USART_WIDX
170             _usart_write_bytetbl_loop_0:
171             \tmovf VIC_VAR_USART_WIDX, W
172             \tcall tblentry
173             \tbanksel TXREG
174             \tmovwf TXREG
175             \tbanksel TXSTA
176             \tbtfss TXSTA, TRMT
177             \tgoto \$ - 1
178             \tbanksel VIC_VAR_USART_WIDX
179             \tincf VIC_VAR_USART_WIDX, F
180             \tbcf STATUS, Z
181             \tbcf STATUS, C
182             \tmovf VIC_VAR_USART_WIDX, W
183             \tsubwf VIC_VAR_USART_WLEN, W
184             \t;; W == 0
185             \tbtfsc STATUS, Z
186             \tgoto _usart_write_bytetbl_loop_1
187             \tgoto _usart_write_bytetbl_loop_0
188             _usart_write_bytetbl_loop_1:
189             \t;; finish the sending
190             \tbanksel TXSTA
191             \tbtfss TXSTA, TRMT
192             \tgoto \$ - 1
193             \tbanksel VIC_VAR_USART_WIDX
194             \tclrf VIC_VAR_USART_WIDX
195             \tclrf VIC_VAR_USART_WLEN
196             \tendm
197             ....
198             }
199              
200             sub _usart_write_byte {
201 1     1   4 return <<"....";
202             m_usart_write_byte macro wvar
203             \tbanksel wvar
204             \tmovf wvar, W
205             \tbanksel TXREG
206             \tmovwf TXREG
207             \tbanksel TXSTA
208             \tbtfss TXSTA, TRMT
209             \tgoto \$ - 1
210             \tendm
211             ....
212             }
213              
214             sub _usart_write_bytes {
215 1     1   3 return <<"....";
216             m_usart_write_bytes macro wvar, wlen
217             \tlocal _usart_write_bytes_loop_0
218             \tlocal _usart_write_bytes_loop_1
219             \tbanksel VIC_VAR_USART_WLEN
220             \tmovlw (wlen - 1)
221             \tmovwf VIC_VAR_USART_WLEN
222             \tclrf VIC_VAR_USART_WIDX
223             \tbanksel wvar
224             \tmovlw (wvar - 1) ;; load address into FSR
225             \tmovwf FSR
226             _usart_write_bytes_loop_0:
227             \tincf FSR, F ;; increment the FSR pointer
228             \tmovf INDF, W ;; load byte into register
229             \tbanksel TXREG
230             \tmovwf TXREG
231             \tbanksel TXSTA
232             \tbtfss TXSTA, TRMT
233             \tgoto \$ - 1
234             \tbanksel VIC_VAR_USART_WIDX
235             \tincf VIC_VAR_USART_WIDX, F
236             \tbcf STATUS, Z
237             \tbcf STATUS, C
238             \tmovf VIC_VAR_USART_WIDX, W
239             \tsubwf VIC_VAR_USART_WLEN, W
240             \t;; W == 0
241             \tbtfsc STATUS, Z
242             \tgoto _usart_write_bytes_loop_1
243             \tgoto _usart_write_bytes_loop_0
244             _usart_write_bytes_loop_1:
245             \tbanksel TXSTA
246             \tbtfss TXSTA, TRMT
247             \tgoto \$ - 1
248             \tbanksel VIC_VAR_USART_WIDX
249             \tclrf VIC_VAR_USART_WIDX
250             \tclrf VIC_VAR_USART_WLEN
251             \tendm
252             ....
253             }
254              
255             sub _usart_read_byte {
256             # TODO: check RX9 for 9th-bit
257 1     1   3 return <<"...";
258             m_usart_read_byte macro rvar
259             \tlocal _usart_read_byte_0
260             \tbanksel VIC_VAR_USART_RIDX
261             \tclrf VIC_VAR_USART_RIDX
262             \tbanksel PIR1
263             \tbtfss PIR1, RCIF
264             \tgoto \$ - 1
265             \tbtfsc RCSTA, OERR
266             \tbcf RCSTA, CREN
267             \tbtfsc RCSTA, FERR
268             \tbcf RCSTA, CREN
269             _usart_read_byte_0:
270             \tbanksel RCREG
271             \tmovf RCREG, W
272             \tbanksel rvar
273             \tmovwf rvar
274             \tbanksel RCSTA
275             \tbtfss RCSTA, CREN
276             \tbsf RCSTA, CREN
277             \tendm
278             ...
279             }
280              
281             sub usart_write {
282 7     7 0 11 my ($self, $outp, $data) = @_;
283 7 50       15 return unless $self->doesroles(qw(USART GPIO CodeGen Chip));
284 7 50       37 return unless $outp =~ /US?ART/;
285 7 50       12 return unless defined $data;
286 7         13 my ($code, $funcs, $macros, $tables) = ('', {}, {}, []);
287             # check if $data is a string or value or variable
288 7         11 my @bytearr = ();
289 7         7 my $nstr;
290 7         7 my $table_entry = '';
291 7         8 my $szvar;
292 7 100       14 if (ref $data eq 'HASH') {
293 5 100       11 if (exists $data->{type}) {
294             # this is a variable with data
295 1 50       3 unless ($data->{type} eq 'string') {
296 0         0 carp "Only string variables can use this part of the code";
297 0         0 return;
298             }
299 1         2 $szvar = $data->{size};
300 1         1 $data = $data->{name};
301 1         3 $code .= ";;; sending contents of the variable '$data' of size '$szvar' to $outp\n";
302             } else {
303             # this is a string
304 4         6 $nstr = $data->{string};
305 4         5 my $nstr2 = $nstr;
306 4         8 $nstr2 =~ s/[\n]/\\n/gs;
307 4         6 $nstr2 =~ s/[\r]/\\r/gs;
308 4         10 $code .= ";;; sending the string '$nstr2' to $outp\n";
309 4         18 @bytearr = split //, $nstr;
310             push @$tables, {
311 41         72 bytes => [(map { sprintf "0x%02X", ord($_) } @bytearr), "0x00"],
312             name => $data->{name},
313 4         9 comment => "\t;;storing string '$nstr2'",
314             };
315 4         8 $table_entry = $data->{name};
316             }
317             } else {
318 2 100       10 if (looks_like_number($data)) {
319 1         4 $code .= ";;; sending the number '$data' to $outp in big-endian mode\n";
320 1         5 my $nstr = pack "N", $data;
321 1         3 $nstr =~ s/^\x00{1,3}//g; # remove the beginning nulls
322 1         2 @bytearr = split //, $nstr;
323 1         3 $table_entry = sprintf("_vic_bytes_0x%02X", $data);
324             push @$tables, {
325 1         3 bytes => [(map { sprintf "0x%02X", ord($_) } @bytearr), "0x00"],
  1         12  
326             name => $table_entry,
327             comment => "\t;;storing number $data",
328             };
329             } else {
330 1         6 $code .= ";;; sending the variable '$data' to $outp\n";
331             }
332             }
333 7 100       17 if (@bytearr) {
    100          
334             ## length has to be 1 byte only
335             ## use TXREG and TRMT bit of TXSTA to check if it is done
336             ## by polling the TRMT check
337             ## use DECFSZ to manage the loop
338             ## use a table to store multiple strings/byte arrays
339             ## TODO: call store_string() to store the string/array of bytes
340             ## the best way is to store all strings as temporary variables and
341             ## send the variable into the functions to be detected appropriately
342             ## use the dt directive to store each string entry in a table
343             ## the byte arrays generated by a number can be pushed back using a
344             ## temporary variable
345 5 50       15 if (scalar @bytearr > 256) {
346 0         0 carp "Warning: Cannot write more than 256 bytes at a time to $outp. You tried to write ", scalar @bytearr;
347             }
348 5 50       10 my $len = scalar(@bytearr) < 256 ? scalar(@bytearr) : 0xFF;
349 5         11 $len = sprintf "0x%02X", $len;
350 5         13 $macros->{m_usart_write_bytetbl} = $self->_usart_write_bytetbl;
351 5         16 $code .= <<"...";
352             ;;;; byte array has length $len
353             \tm_usart_write_bytetbl $table_entry, $len
354             ...
355             } elsif (defined $szvar) {
356             ## multiple bytes writing
357 1         3 $macros->{m_usart_write_bytes} = $self->_usart_write_bytes;
358 1         2 $data = uc $data;
359 1         3 $code .= <<"...";
360             \tm_usart_write_bytes $data, $szvar
361             ...
362             } else {
363 1         4 $macros->{m_usart_write_byte} = $self->_usart_write_byte;
364 1         3 $data = uc $data;
365 1         2 $code .= <<"...";
366             \tm_usart_write_byte $data
367             ...
368             }
369 7 50       31 return wantarray ? ($code, $funcs, $macros, $tables) : $code;
370             }
371              
372             sub usart_read {
373 1     1 0 2 my $self = shift;
374 1         1 my $inp = shift;
375 1         2 my $var = undef;
376 1         1 my %action = ();
377 1 50       8 if (scalar(@_) == 1) {
    50          
378 0         0 $var = shift;
379             } elsif (scalar(@_) > 1){
380 1         2 %action = @_;
381             } else {
382 0         0 carp 'Invalid invocation of usart_read() function';
383 0         0 return;
384             }
385 1 50       3 return unless $self->doesroles(qw(USART GPIO CodeGen Chip));
386 1 50       7 return unless $inp =~ /US?ART/;
387 1         3 my ($code, $funcs, $macros, $tables) = ('', {}, {}, []);
388 1 50       3 unless (defined $var) {
389 1 50       3 if (defined $action{PARAM}) {
390 1         2 $var = $action{PARAM} . '0';
391             } else {
392 0         0 carp "Implementation errors implementing the Action block";
393 0         0 return;
394             }
395 1         2 $var = uc $var;
396 1         5 $macros->{lc("m_read_$var")} = $self->_macro_read_var($var);
397 1 50 33     7 return unless (defined $action{ACTION} or defined $action{ISR});
398 1 50       2 return unless defined $action{END};
399             }
400 1         3 $macros->{m_usart_read_byte} = $self->_usart_read_byte;
401 1         3 $code .= <<"...";
402             ;;;; reading single byte on the $inp port
403             \tm_usart_read_byte $var
404             ...
405 1 50       3 if (%action) {
406 1 50       3 if (exists $action{ACTION}) {
    50          
407 0         0 my $action_label = $action{ACTION};
408 0         0 my $end_label = $action{END};
409 0         0 $code .= <<"...";
410             ;;; invoking $action_label
411             \tgoto $action_label
412             $end_label:\n
413             ...
414             } elsif (exists $action{ISR}) {
415 1         4 my $pictype = $self->type;
416 1 50       3 unless ($self->doesrole('ISR')) {
417 0         0 carp "$pictype does not do the ISR role";
418 0         0 return;
419             }
420 1         3 my $rx_int = $self->usart_pins->{rx_int};
421 1 50 0     2 carp "rx_int not defined for $pictype" and return unless $rx_int;
422 1         2 my $isr_label = lc "isr_rx_$inp"; # required by receiver
423 1         3 $code = ";;;; $inp read is done using $isr_label";
424 1         3 $code .= $self->_usart_isr_setup($inp, $rx_int);
425 1         5 $funcs->{$isr_label} = $self->_usart_isr_read($inp, $rx_int, %action);
426             } else {
427 0         0 carp "Unknown action requested. Probably a bug in implementation";
428 0         0 return;
429             }
430             }
431 1 50       7 return wantarray ? ($code, $funcs, $macros, $tables) : $code;
432             }
433              
434             sub _usart_isr_setup {
435 1     1   2 my $self = shift;
436 1         4 my $inp = shift;
437 1         2 my $href = shift;
438 1 50 33     6 return unless (defined $href and ref $href eq 'HASH');
439 1 50       5 unless (exists $self->registers->{INTCON}) {
440 0         0 carp $self->type, " has no register named INTCON";
441 0         0 return;
442             }
443 1         2 my $reg = $href->{reg};
444 1         4 my $enable = $href->{enable};
445 1         2 my $preg = $href->{preg};
446 1         1 my $penable = $href->{penable};
447 1         2 my $code = << "...";
448             ;;; enable interrupt servicing for $inp
449             \tbanksel INTCON
450             \tbsf INTCON, GIE
451             ...
452 1 50       6 if ($preg eq 'INTCON') {
453 1         3 $code .= "\tbsf $preg, $penable\n";
454             } else {
455 0         0 $code .= "\tbanksel $preg\n\tbsf $preg, $penable\n";
456             }
457 1         4 $code .= << "...";
458             \tbanksel $reg
459             \tbsf $reg, $enable
460             ;;; end of interrupt servicing for $inp
461             ...
462 1         1 return $code;
463             }
464              
465             sub _usart_isr_read {
466 1     1   1 my $self = shift;
467 1         2 my $inp = shift;
468 1         1 my $href = shift;
469 1         2 my %isr = @_;
470 1 50 33     8 return unless (defined $href and ref $href eq 'HASH');
471 1 50 33     9 return unless (defined $isr{ISR} and $isr{END});
472 1         2 my $reg = $href->{reg};
473 1         2 my $enable = $href->{enable};
474 1         2 my $flag = $href->{flag};
475 1         1 my $begin_label = $isr{ISR};
476 1         2 my $end_label = $isr{END};
477 1         1 my $isr_var_code = '';
478 1 50       3 if (defined $isr{PARAM}) {
479 1         3 my $ivar = uc ($isr{PARAM} . '0');
480 1         2 $isr_var_code = "\tbanksel $ivar\n\tmovwf $ivar\n";
481             }
482 1         2 my $isr_label = lc "_isr_rx_$inp"; # required by receiver to be this way
483 1         7 return << "....";
484             $isr_label:
485             \tbanksel $reg
486             \tbtfss $reg, $flag
487             \tgoto $end_label
488             \tbtfsc RCSTA, OERR
489             \tbcf RCSTA, CREN
490             \tbtfsc RCSTA, FERR
491             \tbcf RCSTA, CREN
492             \tbanksel RCREG
493             \tmovf RCREG, W
494             $isr_var_code
495             \tbanksel RCSTA
496             \tbtfss RCSTA, CREN
497             \tbsf RCSTA, CREN
498             \tgoto $begin_label
499             $end_label:
500             ....
501             }
502              
503             1;
504             __END__