File Coverage

blib/lib/Lab/Bus.pm
Criterion Covered Total %
statement 64 74 86.4
branch 8 14 57.1
condition 1 3 33.3
subroutine 13 18 72.2
pod 5 5 100.0
total 91 114 79.8


line stmt bran cond sub pod time code
1             package Lab::Bus;
2             $Lab::Bus::VERSION = '3.880';
3             #ABSTRACT: Bus base class
4              
5 3     3   2308 use v5.20;
  3         10  
6              
7 3     3   17 use strict;
  3         6  
  3         64  
8              
9 3     3   14 use Lab::Generic;
  3         9  
  3         82  
10 3     3   18 use Lab::Exception;
  3         7  
  3         71  
11 3     3   15 use Time::HiRes qw (usleep sleep);
  3         5  
  3         19  
12              
13             #use POSIX; # added for int() function
14 3     3   380 use Scalar::Util qw(weaken);
  3         7  
  3         160  
15 3     3   19 use Carp qw(croak cluck);
  3         6  
  3         175  
16 3     3   19 use Data::Dumper;
  3         6  
  3         924  
17             our $AUTOLOAD;
18              
19             our @ISA = ('Lab::Generic');
20              
21             # this holds a list of references to all the bus objects that are floating around in memory,
22             # to enable transparent bus reuse, so the user doesn't have to handle (or even know about,
23             # to that end) bus objects. weaken() is used so the reference in this list does not prevent destruction
24             # of the object when the last "real" reference is gone.
25             our %BusList = (
26              
27             # BusType => $BusReference,
28             );
29              
30             our %fields = (
31             config => undef,
32             type => undef, # e.g. 'GPIB'
33             ignore_twins => 0, #
34             ins_debug => 0, # do we need additional output?
35             );
36              
37             sub new {
38 2     2 1 4 my $proto = shift;
39 2   33     20 my $class = ref($proto) || $proto;
40 2         3 my $config = undef;
41 2 50       8 if ( ref $_[0] eq 'HASH' ) {
42 2         5 $config = shift;
43             } # try to be flexible about options as hash/hashref
44 0         0 else { $config = {@_} }
45 2         12 my $self = $class->SUPER::new(@_);
46 2         4 bless( $self, $class );
47 2         3 $self->${ \( __PACKAGE__ . '::_construct' ) }(__PACKAGE__);
  2         12  
48              
49 2         13 $self->config($config);
50              
51             # Object data setup
52 2         5 $self->ignore_twins( $self->config('ignore_twins') );
53              
54 2         6 return $self;
55             }
56              
57             #
58             # Call this in inheriting class's constructors to conveniently initialize the %fields object data
59             #
60             sub _construct { # _construct(__PACKAGE__);
61 4     4   8 ( my $self, my $package ) = ( shift, shift );
62 4         10 my $class = ref($self);
63 4         6 my $fields = undef;
64             {
65 3     3   30 no strict 'refs';
  3         7  
  3         1699  
  4         8  
66 4         6 $fields = *${ \( $package . '::fields' ) }{HASH};
  4         16  
67             }
68 4         8 my $twin = undef;
69              
70 4         8 foreach my $element ( keys %{$fields} ) {
  4         25  
71 24         52 $self->{_permitted}->{$element} = $fields->{$element};
72             }
73 4         9 @{$self}{ keys %{$fields} } = values %{$fields};
  4         23  
  4         15  
  4         9  
74             }
75              
76             #
77             # these are stubs to be overwritten in child classes
78             #
79              
80             #
81             # In child classes, this should search %Lab::Bus::BusList for a reusable
82             # instance (and be called in the constructor).
83             # e.g.
84             # return $self->_search_twin() || $self;
85             #
86             sub _search_twin {
87 0     0   0 return 0;
88             }
89              
90             sub connection_read { # @_ = ( $connection_handle, \%args )
91 0     0 1 0 return 0;
92             }
93              
94             sub connection_write { # @_ = ( $connection_handle, \%args )
95 0     0 1 0 return 0;
96             }
97              
98             #
99             # generates and returns a connection handle;
100             #
101             sub connection_new {
102 0     0 1 0 return 0;
103             }
104              
105             #
106             # config gets it's own accessor - convenient access like $self->config('GPIB_Paddress') instead of $self->config()->{'GPIB_Paddress'}
107             # with a hashref as argument, set $self->{'config'} to the given hashref.
108             # without an argument it returns a reference to $self->config (just like AUTOLOAD would)
109             #
110             sub config { # $value = self->config($key);
111 4     4 1 8 ( my $self, my $key ) = ( shift, shift );
112              
113 4 50       23 if ( !defined $key ) {
    100          
114 0         0 return $self->{'config'};
115             }
116             elsif ( ref($key) =~ /HASH/ ) {
117 2         6 return $self->{'config'} = $key;
118             }
119             else {
120 2         20 return $self->{'config'}->{$key};
121             }
122             }
123              
124             sub AUTOLOAD {
125              
126 14     14   28 my $self = shift;
127 14 50       39 my $type = ref($self) or croak "$self is not an object";
128              
129 14         22 my $name = $AUTOLOAD;
130 14         57 $name =~ s/.*://; # strip fully qualified portion
131              
132 14 50       36 unless ( exists $self->{_permitted}->{$name} ) {
133 0         0 cluck( "AUTOLOAD in "
134             . __PACKAGE__
135             . " couldn't access field '${name}'.\n" );
136 0         0 Lab::Exception::Error->throw( error => "AUTOLOAD in "
137             . __PACKAGE__
138             . " couldn't access field '${name}'.\n" );
139             }
140              
141 14 100       26 if (@_) {
142 4         10 return $self->{$name} = shift;
143             }
144             else {
145 10         61 return $self->{$name};
146             }
147             }
148              
149             # needed so AUTOLOAD doesn't try to call DESTROY on cleanup and prevent the inherited DESTROY
150             sub DESTROY {
151 0     0     my $self = shift;
152 0 0         $self->SUPER::DESTROY if $self->can("SUPER::DESTROY");
153             }
154              
155             1;
156              
157             __END__
158              
159             =pod
160              
161             =encoding utf-8
162              
163             =head1 NAME
164              
165             Lab::Bus - Bus base class
166              
167             =head1 VERSION
168              
169             version 3.880
170              
171             =head1 SYNOPSIS
172              
173             This is a base class for inheriting bus types.
174              
175             =head1 DESCRIPTION
176              
177             C<Lab::Bus> is a base class for individual buses. It does not do anything on its
178             own. For more detailed information on the use of bus objects, take a look on a
179             child class, e.g. L<Lab::Bus::LinuxGPIB>.
180              
181             C<Lab::Bus::BusList> contains a hash with references to all the active buses in
182             your program. They are put there by the constructor of the individual bus
183             C<Lab::Bus::new()> and have two levels: Package name and a unique bus ID (GPIB
184             board index offers itself for GPIB). This is to transparently (to the use
185             interface) reuse bus objects, as there may only be one bus object for every
186             (hardware) bus. weaken() is used on every reference stored in this hash, so
187             it doesn't prevent object destruction when the last "real" reference is lost.
188             Yes, this breaks object orientation a little, but it comes so handy!
189              
190             our %Lab::Bus::BusList = [
191             $Package => {
192             $UniqueID => $Object,
193             }
194             'Lab::Bus::GPIB' => {
195             '0' => $Object, "0" is the gpib board index
196             }
197              
198             Place your twin searching code in C<$self->_search_twin()>. Make sure it
199             evaluates C<$self->IgnoreTwin()>. Look at L<Lab::Bus::LinuxGPIB>.
200              
201             =head1 CONSTRUCTOR
202              
203             =head2 new
204              
205             Generally called in child class constructor:
206              
207             my $self = $class->SUPER::new(@_);
208              
209             Return blessed $self, with @_ accessible through $self->Config().
210              
211             =head1 METHODS
212              
213             =head2 config
214              
215             Provides unified access to the fields in initial @_ to all the child classes.
216              
217             =head2 connection_new
218              
219             Empty stub function for overloading
220              
221             =head2 connection_read
222              
223             Empty stub function for overloading
224              
225             =head2 connection_write
226              
227             Empty stub function for overloading
228              
229             =head1 CAVEATS/BUGS
230              
231             Probably few. Mostly because there's not so much done here.
232              
233             =head1 SEE ALSO
234              
235             =over 4
236              
237             =item
238              
239             L<Lab::Bus::GPIB>
240              
241             =item
242              
243             L<Lab::Bus::MODBUS>
244              
245             =item
246              
247             and many more...
248              
249             =back
250              
251             =head1 COPYRIGHT AND LICENSE
252              
253             This software is copyright (c) 2023 by the Lab::Measurement team; in detail:
254              
255             Copyright 2011-2012 Andreas K. Huettel, Florian Olbrich
256             2014 Alexei Iankilevitch
257             2016 Simon Reinhardt
258             2017 Andreas K. Huettel
259             2019 Simon Reinhardt
260             2020 Andreas K. Huettel
261              
262              
263             This is free software; you can redistribute it and/or modify it under
264             the same terms as the Perl 5 programming language system itself.
265              
266             =cut