line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Lab::Connection; |
2
|
|
|
|
|
|
|
$Lab::Connection::VERSION = '3.880'; |
3
|
|
|
|
|
|
|
#ABSTRACT: Connection base class |
4
|
|
|
|
|
|
|
|
5
|
9
|
|
|
9
|
|
662
|
use v5.20; |
|
9
|
|
|
|
|
32
|
|
6
|
|
|
|
|
|
|
|
7
|
9
|
|
|
9
|
|
66
|
use strict; |
|
9
|
|
|
|
|
26
|
|
|
9
|
|
|
|
|
189
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
#use POSIX; # added for int() function |
10
|
9
|
|
|
9
|
|
47
|
use Lab::Generic; |
|
9
|
|
|
|
|
32
|
|
|
9
|
|
|
|
|
244
|
|
11
|
9
|
|
|
9
|
|
61
|
use Time::HiRes qw (usleep sleep); |
|
9
|
|
|
|
|
29
|
|
|
9
|
|
|
|
|
79
|
|
12
|
|
|
|
|
|
|
|
13
|
9
|
|
|
9
|
|
1516
|
use Carp; |
|
9
|
|
|
|
|
25
|
|
|
9
|
|
|
|
|
629
|
|
14
|
9
|
|
|
9
|
|
68
|
use Data::Dumper; |
|
9
|
|
|
|
|
33
|
|
|
9
|
|
|
|
|
10733
|
|
15
|
|
|
|
|
|
|
our $AUTOLOAD; |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
our @ISA = ('Lab::Generic'); |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
our %fields = ( |
20
|
|
|
|
|
|
|
connection_handle => undef, |
21
|
|
|
|
|
|
|
bus => undef, # set default here in child classes, e.g. bus => "GPIB" |
22
|
|
|
|
|
|
|
bus_class => undef, |
23
|
|
|
|
|
|
|
config => undef, |
24
|
|
|
|
|
|
|
type => undef, # e.g. 'GPIB' |
25
|
|
|
|
|
|
|
ins_debug => 0, # do we need additional output? |
26
|
|
|
|
|
|
|
timeout => 1, # in seconds |
27
|
|
|
|
|
|
|
); |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
sub new { |
30
|
7
|
|
|
7
|
1
|
20
|
my $proto = shift; |
31
|
7
|
|
33
|
|
|
32
|
my $class = ref($proto) || $proto; |
32
|
7
|
|
|
|
|
18
|
my $config = undef; |
33
|
7
|
50
|
|
|
|
45
|
if ( ref $_[0] eq 'HASH' ) { |
34
|
7
|
|
|
|
|
18
|
$config = shift; |
35
|
|
|
|
|
|
|
} # try to be flexible about options as hash/hashref |
36
|
0
|
|
|
|
|
0
|
else { $config = {@_} } |
37
|
7
|
|
|
|
|
73
|
my $self = $class->SUPER::new(@_); |
38
|
7
|
|
|
|
|
20
|
bless( $self, $class ); |
39
|
7
|
|
|
|
|
20
|
$self->${ \( __PACKAGE__ . '::_construct' ) }(__PACKAGE__); |
|
7
|
|
|
|
|
48
|
|
40
|
|
|
|
|
|
|
|
41
|
7
|
|
|
|
|
47
|
$self->config($config); |
42
|
|
|
|
|
|
|
|
43
|
7
|
|
|
|
|
22
|
return $self; |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
# |
47
|
|
|
|
|
|
|
# generic methods - interface definition |
48
|
|
|
|
|
|
|
# |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
sub Clear { |
51
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
# do nothing if connection is blocked |
54
|
0
|
0
|
|
|
|
0
|
if ( $self->{blocked} ) { |
55
|
0
|
|
|
|
|
0
|
return undef; |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
|
58
|
0
|
0
|
|
|
|
0
|
return $self->bus()->connection_clear( $self->connection_handle() ) |
59
|
|
|
|
|
|
|
if ( $self->bus()->can('connection_clear') ); |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
# error message |
62
|
0
|
|
|
|
|
0
|
warn "Clear function is not implemented in the bus " |
63
|
|
|
|
|
|
|
. ref( $self->bus() ) . "\n"; |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
sub Write { |
67
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
68
|
0
|
|
|
|
|
0
|
my $options = undef; |
69
|
0
|
0
|
|
|
|
0
|
if ( ref $_[0] eq 'HASH' ) { $options = shift } |
|
0
|
|
|
|
|
0
|
|
70
|
0
|
|
|
|
|
0
|
else { $options = {@_} } |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
# do nothing if connection is blocked |
73
|
0
|
0
|
|
|
|
0
|
if ( $self->{connection_blocked} ) { |
74
|
0
|
|
|
|
|
0
|
return undef; |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
|
77
|
0
|
|
|
|
|
0
|
return $self->bus() |
78
|
|
|
|
|
|
|
->connection_write( $self->connection_handle(), $options ); |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
sub Read { |
82
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
83
|
0
|
|
|
|
|
0
|
my $options = undef; |
84
|
0
|
0
|
|
|
|
0
|
if ( ref $_[0] eq 'HASH' ) { $options = shift } |
|
0
|
|
|
|
|
0
|
|
85
|
0
|
|
|
|
|
0
|
else { $options = {@_} } |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
# do nothing if connection is blocked |
88
|
0
|
0
|
|
|
|
0
|
if ( $self->{connection_blocked} ) { |
89
|
0
|
|
|
|
|
0
|
return undef; |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
|
92
|
0
|
|
|
|
|
0
|
my $result = $self->bus() |
93
|
|
|
|
|
|
|
->connection_read( $self->connection_handle(), $options ); |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
# cut off all termination characters: |
96
|
0
|
|
|
|
|
0
|
my $temp = $/; |
97
|
0
|
0
|
|
|
|
0
|
if ( ref( $self->config('termchar') ) eq "ARRAY" ) { |
98
|
0
|
|
|
|
|
0
|
foreach my $term ( @{ $self->config('termchar') } ) { |
|
0
|
|
|
|
|
0
|
|
99
|
0
|
|
|
|
|
0
|
$/ = $term; |
100
|
0
|
|
|
|
|
0
|
chomp($result); |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
else { |
104
|
0
|
|
|
|
|
0
|
$/ = $self->config('termchar'); |
105
|
0
|
|
|
|
|
0
|
chomp($result); |
106
|
|
|
|
|
|
|
} |
107
|
0
|
|
|
|
|
0
|
$/ = $temp; |
108
|
|
|
|
|
|
|
|
109
|
0
|
|
|
|
|
0
|
return $result; |
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
sub BrutalRead { |
113
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
114
|
0
|
|
|
|
|
0
|
my $options = undef; |
115
|
0
|
0
|
|
|
|
0
|
if ( ref $_[0] eq 'HASH' ) { $options = shift } |
|
0
|
|
|
|
|
0
|
|
116
|
0
|
|
|
|
|
0
|
else { $options = {@_} } |
117
|
0
|
|
|
|
|
0
|
$options->{'brutal'} = 1; |
118
|
|
|
|
|
|
|
|
119
|
0
|
|
|
|
|
0
|
return $self->Read($options); |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
sub Query { |
123
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
124
|
0
|
|
|
|
|
0
|
my $options = undef; |
125
|
0
|
0
|
|
|
|
0
|
if ( ref $_[0] eq 'HASH' ) { $options = shift } |
|
0
|
|
|
|
|
0
|
|
126
|
0
|
|
|
|
|
0
|
else { $options = {@_} } |
127
|
|
|
|
|
|
|
|
128
|
0
|
|
0
|
|
|
0
|
my $wait_query = $options->{'wait_query'} || $self->wait_query(); |
129
|
|
|
|
|
|
|
|
130
|
0
|
|
|
|
|
0
|
$self->Write($options); |
131
|
0
|
|
|
|
|
0
|
sleep($wait_query); |
132
|
0
|
|
|
|
|
0
|
return $self->Read($options); |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
sub LongQuery { |
136
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
137
|
0
|
|
|
|
|
0
|
my $options = undef; |
138
|
0
|
0
|
|
|
|
0
|
if ( ref $_[0] eq 'HASH' ) { $options = shift } |
|
0
|
|
|
|
|
0
|
|
139
|
0
|
|
|
|
|
0
|
else { $options = {@_} } |
140
|
|
|
|
|
|
|
|
141
|
0
|
|
|
|
|
0
|
$options->{read_length} = 10240; |
142
|
0
|
|
|
|
|
0
|
return $self->Query($options); |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
sub BrutalQuery { |
146
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
147
|
0
|
|
|
|
|
0
|
my $options = undef; |
148
|
0
|
0
|
|
|
|
0
|
if ( ref $_[0] eq 'HASH' ) { $options = shift } |
|
0
|
|
|
|
|
0
|
|
149
|
0
|
|
|
|
|
0
|
else { $options = {@_} } |
150
|
|
|
|
|
|
|
|
151
|
0
|
|
|
|
|
0
|
$options->{brutal} = 1; |
152
|
0
|
|
|
|
|
0
|
return $self->Query($options); |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
sub timeout { |
156
|
4
|
|
|
4
|
0
|
10
|
my $self = shift; |
157
|
4
|
|
|
|
|
9
|
my $timo = shift; |
158
|
|
|
|
|
|
|
|
159
|
4
|
50
|
|
|
|
13
|
return $self->{'timeout'} if ( !defined $timo ); |
160
|
|
|
|
|
|
|
|
161
|
4
|
|
|
|
|
17
|
$self->{'timeout'} = $timo; |
162
|
4
|
100
|
|
|
|
26
|
$self->bus()->timeout( $self->connection_handle(), $timo ) |
163
|
|
|
|
|
|
|
if defined( $self->bus() ) |
164
|
|
|
|
|
|
|
; # if called by $self->configure() before the bus is created. |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
sub block_connection { |
168
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
169
|
|
|
|
|
|
|
|
170
|
0
|
|
|
|
|
0
|
$self->{connection_blocked} = 1; |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
sub unblock_connection { |
175
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
176
|
|
|
|
|
|
|
|
177
|
0
|
|
|
|
|
0
|
$self->{connection_blocked} = undef; |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
sub is_blocked { |
182
|
54
|
|
|
54
|
0
|
73
|
my $self = shift; |
183
|
|
|
|
|
|
|
|
184
|
54
|
50
|
|
|
|
143
|
if ( $self->{connection_blocked} == 1 ) { |
185
|
0
|
|
|
|
|
0
|
return 1; |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
else { |
188
|
54
|
|
|
|
|
169
|
return 0; |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
# |
194
|
|
|
|
|
|
|
# infrastructure stuff below |
195
|
|
|
|
|
|
|
# |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
# |
198
|
|
|
|
|
|
|
# Fill $self->device_settings() from config parameters |
199
|
|
|
|
|
|
|
# |
200
|
|
|
|
|
|
|
sub configure { |
201
|
14
|
|
|
14
|
0
|
30
|
my $self = shift; |
202
|
14
|
|
|
|
|
27
|
my $config = shift; |
203
|
|
|
|
|
|
|
|
204
|
14
|
50
|
|
|
|
58
|
if ( ref($config) ne 'HASH' ) { |
205
|
0
|
|
|
|
|
0
|
Lab::Exception::CorruptParameter->throw( |
206
|
|
|
|
|
|
|
error => 'Given Configuration is not a hash.' ); |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
else { |
209
|
|
|
|
|
|
|
# |
210
|
|
|
|
|
|
|
# fill matching fields definded in %fields from the configuration hash ($self->config ) |
211
|
|
|
|
|
|
|
# |
212
|
14
|
|
|
|
|
27
|
for my $fields_key ( keys %{ $self->{_permitted} } ) { |
|
14
|
|
|
|
|
93
|
|
213
|
|
|
|
|
|
|
{ # restrict scope of "no strict" |
214
|
9
|
|
|
9
|
|
105
|
no strict 'refs'; |
|
9
|
|
|
|
|
20
|
|
|
9
|
|
|
|
|
1274
|
|
|
156
|
|
|
|
|
203
|
|
215
|
|
|
|
|
|
|
$self->$fields_key( $config->{$fields_key} ) |
216
|
156
|
100
|
|
|
|
674
|
if exists $config->{$fields_key}; |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
# |
223
|
|
|
|
|
|
|
# Call this in inheriting class's constructors to conveniently initialize the %fields object data |
224
|
|
|
|
|
|
|
# |
225
|
|
|
|
|
|
|
sub _construct { # _construct(__PACKAGE__); |
226
|
14
|
|
|
14
|
|
40
|
( my $self, my $package ) = ( shift, shift ); |
227
|
14
|
|
|
|
|
36
|
my $class = ref($self); |
228
|
14
|
|
|
|
|
24
|
my $fields = undef; |
229
|
|
|
|
|
|
|
{ |
230
|
9
|
|
|
9
|
|
80
|
no strict 'refs'; |
|
9
|
|
|
|
|
29
|
|
|
9
|
|
|
|
|
5920
|
|
|
14
|
|
|
|
|
23
|
|
231
|
14
|
|
|
|
|
26
|
$fields = *${ \( $package . '::fields' ) }{HASH}; |
|
14
|
|
|
|
|
80
|
|
232
|
|
|
|
|
|
|
} |
233
|
|
|
|
|
|
|
|
234
|
14
|
|
|
|
|
42
|
foreach my $element ( keys %{$fields} ) { |
|
14
|
|
|
|
|
63
|
|
235
|
82
|
|
|
|
|
201
|
$self->{_permitted}->{$element} = $fields->{$element}; |
236
|
|
|
|
|
|
|
} |
237
|
14
|
|
|
|
|
31
|
@{$self}{ keys %{$fields} } = values %{$fields}; |
|
14
|
|
|
|
|
49
|
|
|
14
|
|
|
|
|
36
|
|
|
14
|
|
|
|
|
33
|
|
238
|
|
|
|
|
|
|
|
239
|
14
|
100
|
|
|
|
56
|
if ( $class eq $package ) { |
240
|
7
|
|
|
|
|
24
|
$self->configure( $self->config() ) |
241
|
|
|
|
|
|
|
; # so that _setbus has access to all the fields |
242
|
7
|
|
|
|
|
48
|
$self->_setbus(); |
243
|
7
|
|
|
|
|
22
|
$self->configure( $self->config() ) |
244
|
|
|
|
|
|
|
; # for configuration that needs the bus to be set (timeout()) |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
# |
249
|
|
|
|
|
|
|
# Method to handle bus creation generically. This is called by _construct(). |
250
|
|
|
|
|
|
|
# If the following (rather simple code) doesn't suit your child class, or your need to |
251
|
|
|
|
|
|
|
# introduce more thorough parameter checking and/or conversion, overwrite it - _construct() |
252
|
|
|
|
|
|
|
# calls it only if it is called by the topmost class in the inheritance hierarchy itself. |
253
|
|
|
|
|
|
|
# |
254
|
|
|
|
|
|
|
# set $self->connection_handle |
255
|
|
|
|
|
|
|
# |
256
|
|
|
|
|
|
|
sub _setbus { # $self->setbus() create new or use existing bus |
257
|
2
|
|
|
2
|
|
3
|
my $self = shift; |
258
|
2
|
|
|
|
|
13
|
my $bus_class = $self->bus_class(); |
259
|
|
|
|
|
|
|
|
260
|
2
|
50
|
|
|
|
206
|
$self->bus( |
261
|
|
|
|
|
|
|
eval("require $bus_class; new $bus_class(\$self->config());") ) |
262
|
|
|
|
|
|
|
|| Lab::Exception::Error->throw( |
263
|
|
|
|
|
|
|
error => "Failed to create bus $bus_class in " |
264
|
|
|
|
|
|
|
. __PACKAGE__ |
265
|
|
|
|
|
|
|
. "::_setbus. Error message was:" |
266
|
|
|
|
|
|
|
. "\n\n----------------------------------------------\n\n" |
267
|
|
|
|
|
|
|
. "$@\n----------------------------------------------\n" ); |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
# again, pass it all. |
270
|
2
|
|
|
|
|
12
|
$self->connection_handle( |
271
|
|
|
|
|
|
|
$self->bus()->connection_new( $self->config() ) ); |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
sub _configurebus { |
275
|
10
|
|
|
10
|
|
21
|
my $self = shift; |
276
|
|
|
|
|
|
|
|
277
|
10
|
|
|
|
|
26
|
return; |
278
|
|
|
|
|
|
|
} |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
# |
281
|
|
|
|
|
|
|
# config gets it's own accessor - convenient access like $self->config('GPIB_Paddress') instead of $self->config()->{'GPIB_Paddress'} |
282
|
|
|
|
|
|
|
# with a hashref as argument, set $self->{'config'} to the given hashref. |
283
|
|
|
|
|
|
|
# without an argument it returns a reference to $self->config (just like AUTOLOAD would) |
284
|
|
|
|
|
|
|
# |
285
|
|
|
|
|
|
|
sub config { # $value = self->config($key); |
286
|
71
|
|
|
71
|
1
|
162
|
( my $self, my $key ) = ( shift, shift ); |
287
|
|
|
|
|
|
|
|
288
|
71
|
100
|
|
|
|
216
|
if ( !defined $key ) { |
|
|
100
|
|
|
|
|
|
289
|
30
|
|
|
|
|
126
|
return $self->{'config'}; |
290
|
|
|
|
|
|
|
} |
291
|
|
|
|
|
|
|
elsif ( ref($key) =~ /HASH/ ) { |
292
|
17
|
|
|
|
|
54
|
return $self->{'config'} = $key; |
293
|
|
|
|
|
|
|
} |
294
|
|
|
|
|
|
|
else { |
295
|
24
|
|
|
|
|
108
|
return $self->{'config'}->{$key}; |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
} |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
sub AUTOLOAD { |
300
|
|
|
|
|
|
|
|
301
|
2708
|
|
|
2708
|
|
4139
|
my $self = shift; |
302
|
2708
|
50
|
|
|
|
5275
|
my $type = ref($self) or croak "$self is not an object"; |
303
|
|
|
|
|
|
|
|
304
|
2708
|
|
|
|
|
3870
|
my $name = $AUTOLOAD; |
305
|
2708
|
|
|
|
|
7988
|
$name =~ s/.*://; # strip fully qualified portion |
306
|
|
|
|
|
|
|
|
307
|
2708
|
50
|
|
|
|
5984
|
unless ( exists $self->{_permitted}->{$name} ) { |
308
|
0
|
|
|
|
|
0
|
Lab::Exception::Error->throw( error => "AUTOLOAD in " |
309
|
|
|
|
|
|
|
. __PACKAGE__ |
310
|
|
|
|
|
|
|
. " couldn't access field '${name}'.\n" ); |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
|
313
|
2708
|
100
|
|
|
|
4596
|
if (@_) { |
314
|
683
|
|
|
|
|
1660
|
return $self->{$name} = shift; |
315
|
|
|
|
|
|
|
} |
316
|
|
|
|
|
|
|
else { |
317
|
2025
|
|
|
|
|
5354
|
return $self->{$name}; |
318
|
|
|
|
|
|
|
} |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
# needed so AUTOLOAD doesn't try to call DESTROY on cleanup and prevent the inherited DESTROY |
322
|
|
|
|
|
|
|
sub DESTROY { |
323
|
0
|
|
|
0
|
|
|
my $self = shift; |
324
|
0
|
0
|
|
|
|
|
$self->SUPER::DESTROY if $self->can("SUPER::DESTROY"); |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
1; |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
1; |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
__END__ |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
=pod |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
=encoding utf-8 |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
=head1 NAME |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
Lab::Connection - Connection base class |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
=head1 VERSION |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
version 3.880 |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
=head1 SYNOPSIS |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
This is the base class for all connections. |
349
|
|
|
|
|
|
|
Every inheriting classes constructors should start as follows: |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
sub new { |
352
|
|
|
|
|
|
|
my $proto = shift; |
353
|
|
|
|
|
|
|
my $class = ref($proto) || $proto; |
354
|
|
|
|
|
|
|
my $self = $class->SUPER::new(@_); |
355
|
|
|
|
|
|
|
$self->_construct(__PACKAGE__); #initialize fields etc. |
356
|
|
|
|
|
|
|
... |
357
|
|
|
|
|
|
|
} |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
=head1 DESCRIPTION |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
C<Lab::Connection> is the base class for all connections and implements a generic set of |
362
|
|
|
|
|
|
|
access methods. It doesn't do anything on its own. |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
A connection in general is an object which is created by an instrument and provides it |
365
|
|
|
|
|
|
|
with a generic set of methods to talk to its hardware counterpart. |
366
|
|
|
|
|
|
|
For example L<Lab::Instrument::HP34401A> can work with any connection of the type GPIB, |
367
|
|
|
|
|
|
|
that is, connections derived from Lab::Connection::GPIB. |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
That would be, for example |
370
|
|
|
|
|
|
|
Lab::Connection::LinuxGPIB |
371
|
|
|
|
|
|
|
Lab::Connection::VISA_GPIB |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
Towards the instrument, these look the same, but they work with different drivers/backends. |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
=head1 CONSTRUCTOR |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
=head2 new |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
Generally called in child class constructor: |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
my $self = $class->SUPER::new(@_); |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
Return blessed $self, with @_ accessible through $self->Config(). |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
=head1 METHODS |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
=head2 Clear |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
Try to clear the connection, if the bus supports it. |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
=head2 Read |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
my $result = $connection->Read(); |
394
|
|
|
|
|
|
|
my $result = $connection->Read( timeout => 30 ); |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
configuration hash options: |
397
|
|
|
|
|
|
|
brutal => <1/0> # suppress timeout errors if set to 1 |
398
|
|
|
|
|
|
|
read_length => <int> # how many bytes/characters to read |
399
|
|
|
|
|
|
|
...see bus documentation |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
Reads a string from the connected device. In this basic form, its merely a wrapper to the |
402
|
|
|
|
|
|
|
method connection_read() of the used bus. |
403
|
|
|
|
|
|
|
You can give a configuration hash, which options are passed on to the bus. |
404
|
|
|
|
|
|
|
This hash is also meant for options to Read itself, if need be. |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
=head2 Write |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
$connection->Write( command => '*CLS' ); |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
configuration hash options: |
411
|
|
|
|
|
|
|
command => <command string> |
412
|
|
|
|
|
|
|
...more (see bus documentation) |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
Write a command string to the connected device. In this basic form, its merely a wrapper to the |
415
|
|
|
|
|
|
|
method connection_write() of the used bus. |
416
|
|
|
|
|
|
|
You need to supply a configuration hash, with at least the key 'command' set. |
417
|
|
|
|
|
|
|
This hash is also meant for options to Read itself, if need be. |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
=head2 Query |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
my $result = $connection->Query( command => '*IDN?' ); |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
configuration hash options: |
424
|
|
|
|
|
|
|
command => <command string> |
425
|
|
|
|
|
|
|
wait_query => <wait time between read and write in seconds> # overwrites the connection default |
426
|
|
|
|
|
|
|
brutal => <1/0> # suppress timeout errors if set to true |
427
|
|
|
|
|
|
|
read_length => <int> # how many bytes/characters to read |
428
|
|
|
|
|
|
|
...more (see bus documentation) |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
Write a command string to the connected device, and immediately read the response. |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
You need to supply a configuration hash with at least the 'command' key set. |
433
|
|
|
|
|
|
|
The wait_query key sets the time to wait between read and write in usecs. |
434
|
|
|
|
|
|
|
The hash is also passed along to the used bus methods. |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
=head2 BrutalRead |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
The same as read with the 'brutal' option set to 1. |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
=head2 BrutalQuery |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
The same as Query with the 'brutal' option set to 1. |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
=head2 LongQuery |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
The same as Query with 'read_length' set to 10240. |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
=head2 config |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
Provides unified access to the fields in initial @_ to all the cild classes. |
451
|
|
|
|
|
|
|
E.g. |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
$GPIB_Address=$instrument->Config(gpib_address); |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
Without arguments, returns a reference to the complete $self->Config aka @_ of the constructor. |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
$Config = $connection->Config(); |
458
|
|
|
|
|
|
|
$GPIB_Address = $connection->Config()->{'gpib_address'}; |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
=head1 CAVEATS/BUGS |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
Probably few. Mostly because there's not a lot to be done here. Please report. |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
=head1 SEE ALSO |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
=over 4 |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
=item * L<Lab::Connection::GPIB> |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
=item * L<Lab::Connection::VISA_GPIB> |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
=item * L<Lab::Connection::MODBUS> |
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
=item * and all the others... |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
=back |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
This software is copyright (c) 2023 by the Lab::Measurement team; in detail: |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
Copyright 2010-2011 Andreas K. Huettel, Florian Olbrich |
483
|
|
|
|
|
|
|
2012 Florian Olbrich, Hermann Kraus, Stefan Geissler |
484
|
|
|
|
|
|
|
2013 Alois Dirnaichner, Christian Butschkow, Stefan Geissler |
485
|
|
|
|
|
|
|
2014 Alexei Iankilevitch |
486
|
|
|
|
|
|
|
2016 Simon Reinhardt |
487
|
|
|
|
|
|
|
2017 Andreas K. Huettel |
488
|
|
|
|
|
|
|
2019 Simon Reinhardt |
489
|
|
|
|
|
|
|
2020 Andreas K. Huettel |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
This is free software; you can redistribute it and/or modify it under |
493
|
|
|
|
|
|
|
the same terms as the Perl 5 programming language system itself. |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
=cut |