File Coverage

blib/lib/Lab/Bus/VICP.pm
Criterion Covered Total %
statement 44 350 12.5
branch 0 128 0.0
condition 0 86 0.0
subroutine 15 34 44.1
pod 5 14 35.7
total 64 612 10.4


line stmt bran cond sub pod time code
1             package Lab::Bus::VICP;
2             #ABSTRACT: VICP bus
3             $Lab::Bus::VICP::VERSION = '3.880';
4 1     1   1789 use v5.20;
  1         6  
5              
6 1     1   5 use strict;
  1         4  
  1         25  
7 1     1   6 use Scalar::Util qw(weaken);
  1         2  
  1         44  
8 1     1   8 use Time::HiRes qw (usleep sleep);
  1         137  
  1         9  
9 1     1   104 use Lab::Bus;
  1         2  
  1         21  
10 1     1   5 use Data::Dumper;
  1         2  
  1         37  
11 1     1   5 use Carp;
  1         3  
  1         179  
12 1     1   10 use IO::Socket::INET;
  1         3  
  1         11  
13 1     1   495 use IO::Select;
  1         2  
  1         35  
14 1     1   5 use Socket qw( SOCK_STREAM SHUT_RDWR MSG_OOB TCP_NODELAY );
  1         2  
  1         222  
15 1     1   15 use Clone qw(clone);
  1         2  
  1         147  
16              
17             $Data::Dumper::Useqq = 1;
18              
19             our @ISA = ("Lab::Bus");
20              
21             # GPIB status bit vector :
22             # global variable ibsta and wait mask
23             use constant {
24 1         224 ERR => ( 1 << 15 ), # Error detected 0x8000
25             TIMO => ( 1 << 14 ), # Timeout 0x4000
26             EOI => ( 1 << 13 ), # EOI or EOS detected 0x2000
27             SRQI => ( 1 << 12 ), # SRQ detected by CIC 0x1000
28             RQS => ( 1 << 11 ), # Device needs service 0x0800
29             SPOLL => ( 1 << 10 ), # Board has been serially polled 0x0400
30             CMPL => ( 1 << 8 ), # I/O completed 0x0100
31             REM => ( 1 << 6 ), # Remote state 0x0040
32             CIC => ( 1 << 5 ), # Controller-in-Charge 0x0020
33             ATN => ( 1 << 4 ), # Attention asserted 0x0010
34             TACS => ( 1 << 3 ), # Talker active 0x0008
35             LACS => ( 1 << 2 ), # Listener active 0x0004
36             DTAS => ( 1 << 1 ), # Device trigger state 0x0002
37             DCAS => ( 1 << 0 ), # Device clear state 0x0001
38 1     1   16 };
  1         3  
39              
40             # GPIB error codes :
41             # iberr
42             use constant {
43 1         187 EDVR => 0, # System error
44             ECIC => 1, # Function requires GPIB board to be CIC
45             ENOL => 2, # Write function detected no Listeners
46             EADR => 3, # Interface board not addressed correctly
47             EARG => 4, # Invalid argument to function call
48             ESAC => 5, # Function requires GPIB board to be SAC
49             EABO => 6, # I/O operation aborted
50             ENEB => 7, # Non-existent interface board
51             EDMA => 8, # Error performing DMA
52             EOIP => 10, # I/O operation started before previous operation completed
53             ECAP => 11, # No capability for intended operation
54             EFSO => 12, # File system operation error
55             EBUS => 14, # Command error during device call
56             ESTB => 15, # Serial poll status byte lost
57             ESRQ => 16, # SRQ remains asserted
58             ETAB => 20, # The return buffer is full.
59             ELCK => 21, # Address or board is locked.
60 1     1   7 };
  1         2  
61              
62             # VICP header 'Operation' bits
63             use constant {
64 1         116 OPERATION_DATA => 0x80,
65             OPERATION_REMOTE => 0x40,
66             OPERATION_LOCKOUT => 0x20,
67             OPERATION_CLEAR => 0x10,
68             OPERATION_SRQ => 0x08,
69             OPERATION_REQSERIALPOLL => 0x04,
70             OPERATION_EOI => 0x01,
71 1     1   8 };
  1         2  
72              
73             use constant {
74 1         3490 HEADER_VERSION1 => 0x01, # header version
75             SERVER_PORT_NUM => 1861, # port # for lecroy-vicp
76             IO_NET_HEADER_SIZE => 8, # size of network header
77             SMALL_DATA_BUFSIZE => 8192, # small buffer, combined header+data
78 1     1   8 };
  1         1  
79              
80             our %fields = (
81             type => 'VICP',
82             brutal => 0, # brutal as default?
83             wait_query => 5, # sec;
84             read_length => 1000, # bytes
85             query_length => 300, # bytes
86             query_long_length => 10240, #bytes
87              
88             remote_port => SERVER_PORT_NUM,
89             remote_addr => undef,
90             proto => 'tcp',
91             timeout => 10,
92              
93             _state => 'NetWaitHeader',
94             _remote => 0,
95             _lockout => 0,
96             _iberr => 0,
97             _ibsta => 0,
98             _ibcntl => 0,
99             _errflag => 0,
100             _nextseq => 1,
101             _lastseq => 1,
102             _flushunread => 1,
103             _version1a => 0,
104             _maxblocksize => 512,
105             _maxcommandbuf => 256,
106             );
107              
108             sub new {
109 0     0 1   my $proto = shift;
110 0   0       my $class = ref($proto) || $proto;
111 0           my $self = $class->SUPER::new(@_)
112             ; # getting fields and _permitted from parent class
113 0           $self->${ \( __PACKAGE__ . '::_construct' ) }(__PACKAGE__);
  0            
114              
115 0 0         $self->remote_addr( $self->config('remote_addr') )
116             if defined $self->config('remote_addr');
117 0 0         $self->remote_port( $self->config('remote_port') )
118             if defined $self->config('remote_port');
119 0 0         $self->proto( $self->config('proto') )
120             if defined $self->config('proto');
121 0 0         $self->timeout( $self->config('timeout') )
122             if defined $self->config('timeout');
123              
124             # only one VICP connection/device, so don't do 'twins' stuff
125              
126 0           return $self;
127             }
128              
129             sub connection_new { # {
130 0     0 1   my $self = shift;
131 0           my $args = undef;
132 0 0         if ( ref $_[0] eq 'HASH' ) {
133 0           $args = shift;
134             } # try to be flexible about options as hash/hashref
135 0           else { $args = {@_} }
136              
137 0 0         croak("remote_addr not specified") unless defined $args->{'remote_addr'};
138              
139             my $client = IO::Socket::INET->new(
140             PeerAddr => $args->{'remote_addr'} || $self->remote_addr(),
141             PeerPort => $args->{'remote_port'} || $self->remote_port(),
142             Proto => $args->{'proto'} || $self->proto(),
143 0   0       Timeout => $args->{'timeout'} || $self->timeout(),
      0        
      0        
      0        
144             Type => SOCK_STREAM,
145             );
146 0 0         croak("Could not create socket client: $!") unless $client;
147              
148             #$client->autoflush(1);
149 0           $client->sockopt(TCP_NODELAY);
150              
151 0           sleep(5);
152 0 0         croak("did not connect") unless $client->connected();
153              
154 0           my $connection_handle = { valid => 1, type => "VICP", socket => $client };
155 0           return $connection_handle;
156             }
157              
158             sub connect {
159 0     0 0   my $self = shift;
160 0           my $connection_handle = shift;
161 0           my $nch = $self->connection_new( remote_addr => $self->remote_addr() );
162 0           $connection_handle->{socket} = $nch->{socket};
163 0           $connection_handle->{valid} = $nch->{valid};
164 0           $connection_handle->{type} = $nch->{type};
165             }
166              
167             sub disconnect {
168 0     0 0   my $self = shift;
169 0           my $connection_handle = shift;
170              
171 0 0         return unless defined($connection_handle);
172 0           $connection_handle->{socket}->shutdown(2);
173             }
174              
175             # VICP v1a uses an 8 bit 'sequence number' to keep in sync
176              
177             sub _nextSeq {
178 0     0     my $self = shift;
179 0   0       my $eoi = shift || 0;
180              
181 0           $self->{_lastseq} = $self->{_nextseq};
182 0 0         if ($eoi) {
183 0           $self->{_nextseq}++;
184 0 0         $self->{_nextseq} = 1 if $self->{_nextseq} > 0xFF;
185             }
186 0           return $self->{_lastseq};
187             }
188              
189             sub _lastSeq {
190 0     0     my $self = shift;
191 0           return $self->{_lastseq};
192             }
193              
194             # Lecroy VICP has a really weird bug, where commands need to be
195             # an even number of bytes. Pad with spaces.
196              
197             sub connection_write
198             { # @_ = ( $connection_handle, $args = { command, wait_status }
199 0     0 1   my $self = shift;
200 0           my $connection_handle = shift;
201 0           my $args = undef;
202 0 0         if ( ref $_[0] eq 'HASH' ) {
203 0           $args = shift;
204             } # try to be flexible about options as hash/hashref
205 0           else { $args = {@_} }
206              
207 0   0       my $command = $args->{'command'} || undef;
208 0   0       my $brutal = $args->{'brutal'} || 0;
209 0   0       my $eoi = $args->{'eoi'} || 1;
210 0   0       my $clr = $args->{'clr'} || 0;
211 0   0       my $poll = $args->{'poll'} || 0;
212              
213 0 0         croak("no command") unless defined $command;
214 0 0         croak("not connected") unless $connection_handle->{socket}->connected();
215              
216 0   0       my $nb = $args->{'length'} || length($command);
217 0 0         croak("zero length command") unless $nb > 0;
218              
219 0           my $cmdlen = $nb;
220              
221 0 0         if ($eoi) { # make sure proper termination char, EVEN length
222 0           $command = substr( $command, 0, $nb );
223 0           $command =~ s/(\r\n|\n\r|\r|\n)$//;
224 0 0         $command .= ' ' if ( length($command) & 1 ) == 0;
225 0           $command .= "\n";
226 0           $nb = length($command);
227             }
228              
229 0 0 0       if ( $self->{_flushunread} && $self->{_state} ne 'NetWaitHeader' ) {
230 0           $self->connection_read( $connection_handle, flush => 1 );
231             }
232              
233 0           $self->{_ibsta} &= (RQS);
234 0           $self->{_ibcntl} = 0;
235 0           $self->{_iberr} = 0;
236              
237             # prepare and send header
238 0           my $hdr = OPERATION_DATA;
239 0 0         $hdr |= OPERATION_EOI if $eoi;
240 0 0         $hdr |= OPERATION_REMOTE if $self->{_remote};
241 0 0         $hdr |= OPERATION_CLEAR if $clr;
242 0 0         $hdr |= OPERATION_REQSERIALPOLL if $poll;
243              
244 0           my $hbuf = pack(
245             'CCCCN', $hdr, HEADER_VERSION1, $self->_nextSeq($eoi), 0,
246             $nb
247             );
248              
249 0           my $sent;
250 0 0         if ( $nb >= SMALL_DATA_BUFSIZE ) {
251             $sent = $connection_handle->{socket}
252 0           ->send( $hbuf, IO_NET_HEADER_SIZE, 0 );
253 0 0 0       if ( !defined($sent) || $sent != IO_NET_HEADER_SIZE ) {
254 0           carp("error sending header packet: $!");
255 0           $self->{_errflag} = 1;
256 0           $self->{_ibsta} |= ERR;
257 0           return 0;
258             }
259             }
260             else { # if the packet is small combine header with data
261 0           $command = $hbuf . $command;
262 0           $nb += IO_NET_HEADER_SIZE;
263             }
264              
265 0           $sent = $connection_handle->{socket}->send( $command, $nb, 0 );
266 0 0 0       if ( !defined($sent) || $sent != $nb ) {
267 0           carp("error sending header packet: $! sent $sent != $nb ?");
268 0           $self->{_errflag} = 1;
269 0           $self->{_ibsta} |= ERR;
270 0           return 0;
271             }
272 0           $self->{_ibsta} = CMPL | CIC | TACS;
273 0           $self->{_ibcntl} = $cmdlen;
274              
275 0           return 1;
276             }
277              
278             #
279             # read the header portion of response
280              
281             sub _readHeader {
282 0     0     my $self = shift;
283 0           my $connection_handle = shift;
284 0           my $args = undef;
285 0 0         if ( ref $_[0] eq 'HASH' ) {
286 0           $args = shift;
287             } # try to be flexible about options as hash/hashref
288 0           else { $args = {@_} }
289              
290 0   0       my $brutal = $args->{'brutal'} || 0;
291 0   0       my $timeout = $args->{'timeout'} || $self->timeout();
292              
293 0           my $hdr = {
294             SIZE => 0,
295             SEQ => undef,
296             EOI => 0,
297             SRQ => 0,
298             BUF => '',
299             };
300              
301 0           my $sel = IO::Select->new( $connection_handle->{socket} );
302              
303 0           my (@ready) = $sel->can_read($timeout);
304 0 0         return undef if ( $#ready < 0 );
305              
306 0           my $nb = 0;
307 0           my $header = '';
308 0           while ( $nb < 8 ) {
309 0           (@ready) = $sel->can_read($timeout);
310 0 0         last if $#ready < 0;
311 0           my $buf;
312             $connection_handle->{socket}
313 0           ->recv( $buf, IO_NET_HEADER_SIZE- $nb, 0 );
314              
315             # print STDERR "hdr buf=",Dumper($buf),"\n";
316 0 0         if ( length($buf) > 0 ) {
317 0           $nb += length($buf);
318 0           $header .= $buf;
319             }
320 0 0         last if $nb == 0;
321             }
322 0           $sel->remove( $connection_handle->{socket} );
323              
324 0 0         if ( $nb > IO_NET_HEADER_SIZE ) {
325 0           $hdr->{BUF} = substr( $header, IO_NET_HEADER_SIZE );
326 0           $nb = IO_NET_HEADER_SIZE;
327             }
328              
329 0 0         if ( $nb == IO_NET_HEADER_SIZE ) {
330 0           my ( $op, $ver, $seq, $zero, $len ) = unpack( 'CCCCN', $header );
331 0           $hdr->{SIZE} = $len;
332 0 0 0       if ( !( ( $op & OPERATION_DATA ) && ( $ver == HEADER_VERSION1 ) ) ) {
333 0           carp("Invalid header");
334 0           $self->{_errflag} = 1;
335 0           $self->disconnect($connection_handle);
336 0           $self->connect($connection_handle);
337 0           return undef;
338             }
339 0 0         $hdr->{EOI} = ( $op & OPERATION_EOI ) == 0 ? 0 : 1;
340 0 0         $hdr->{SRQ} = ( $op & OPERATION_SRQ ) == 0 ? 0 : 1;
341 0           $hdr->{SEQ} = $seq;
342             }
343             else {
344             # error state out of sync
345 0           $self->disconnect($connection_handle);
346 0           $self->connect($connection_handle);
347 0           return undef;
348             }
349 0           return $hdr;
350             }
351              
352             # dump data until next header is found
353             sub _dumpdata {
354 0     0     my $self = shift;
355 0           my $connection_handle = shift;
356 0           my $nb = shift;
357              
358 0           carp("Unread response, dumping $nb bytes");
359 0           while ( $nb > 0 ) {
360 0           my $nr = $self->{_maxblocksize};
361 0 0         $nr = $nb if $nr > $nb;
362 0           my $buf;
363             last
364             unless
365 0 0         defined( $connection_handle->{socket}->recv( $buf, $nr, 0 ) );
366 0           $nb -= length($buf);
367             }
368             }
369              
370             sub _first {
371 0     0     my $s = shift;
372 0           my $n = length($s);
373 0 0         $n = 20 if $n > 20;
374 0           return substr( $s, 0, $n );
375             }
376              
377             #
378             # Todo: Evaluate $ibstatus: http://linux-gpib.sourceforge.net/doc_html/r634.html
379             #
380             sub connection_read
381             { # @_ = ( $connection_handle, $args = { read_length, brutal }
382 0     0 1   my $self = shift;
383 0           my $connection_handle = shift;
384 0           my $args = undef;
385 0 0         if ( ref $_[0] eq 'HASH' ) {
386 0           $args = shift;
387             } # try to be flexible about options as hash/hashref
388 0           else { $args = {@_} }
389              
390 0   0       my $command = $args->{'command'} || undef;
391 0   0       my $brutal = $args->{'brutal'} || $self->brutal();
392 0   0       my $read_length = $args->{'read_length'} || $self->read_length();
393 0   0       my $flush = $args->{'flush'} || 0;
394 0   0       my $timeout = $args->{'timeout'} || $self->timeout();
395 0           $read_length = undef;
396              
397 0 0         if ( !$connection_handle->{socket}->connected() ) {
398 0           carp("socket not connected");
399 0           return undef;
400             }
401              
402 0           my $result = '';
403 0           my $eoi = 0;
404 0           my $srq = 0;
405              
406 0           $self->{_ibsta} &= (RQS);
407 0           $self->{_ibcntl} = 0;
408 0           $self->{_iberr} = 0;
409              
410 0           my $nb;
411             my $hdr;
412 0           my $size;
413 0           my $read = 0;
414              
415 0           while (1) {
416 0 0         if ( $self->{_state} eq 'NetWaitHeader' ) {
417              
418 0           $hdr = $self->_readHeader( $connection_handle, $args );
419 0 0         if ( defined($hdr) ) {
420 0           $self->{_state} = 'NetWaitData';
421 0           $nb = 0;
422 0           $eoi = $hdr->{EOI};
423 0           $size = $hdr->{SIZE};
424              
425             #$read += length($hdr->{BUF});
426             #$result .= $hdr->{BUF}; # in case appended to header
427              
428 0           my $seq = $hdr->{SEQ};
429              
430             # print STDERR "hdr tot read=$read ",Dumper($hdr,$result),"\n";
431              
432             # flush old stuff?
433 0 0 0       if ( $self->{_flushread}
      0        
434             && $seq != 0
435             && $self->_lastseq() > $seq ) {
436 0           $self->_dumpdata( $connection_handle, $hdr->{SIZE} );
437 0           $self->{_state} = 'NetWaitHeader';
438             }
439              
440             # vicp version 1a has nonzero seq #
441 0 0         if ( $seq != 0 ) {
442 0           $self->{_version1a} = 1;
443             }
444             else {
445 0           $self->{_version1a} = 0;
446             }
447             }
448             else {
449 0           $self->{_ibsta} |= ERR;
450 0           $self->{_iberr} = TIMO;
451 0           last;
452             }
453             }
454              
455 0 0         if ( $self->{_state} eq 'NetWaitData' ) {
456              
457 0 0         if ($flush) {
458 0           $self->_dumpdata( $connection_handle, $size - $read );
459 0           $self->{_state} = 'NetWaitHeader';
460 0           last;
461             }
462              
463 0           my $sel = IO::Select->new( $connection_handle->{socket} );
464              
465 0           my (@ready) = $sel->can_read($timeout);
466 0 0         if ( $#ready < 0 ) {
467 0           carp("timeout on socket read:$!");
468 0           $self->{_ibsta} |= ERR;
469 0           $self->{_iberr} = TIMO;
470 0           $sel->remove( $connection_handle->{socket} );
471 0           return undef;
472             }
473 0           my $got = 0;
474 0           while (1) {
475 0 0         last if $got >= $size;
476 0           my $buf = '';
477 0           $nb = $size - $got;
478 0 0         $nb = $self->{_maxblocksize} if $nb > $self->{_maxblocksize};
479              
480 0           (@ready) = $sel->can_read($timeout);
481 0 0         if ( $#ready < 0 ) {
482 0           carp("timeout on socket read:$!");
483 0           $self->{_ibsta} |= ERR;
484 0           $self->{_iberr} = TIMO;
485 0           $sel->remove( $connection_handle->{socket} );
486 0           return undef;
487             }
488              
489 0           $connection_handle->{socket}->recv( $buf, $nb, 0 );
490              
491             # print STDERR "try read $nb, got:",Dumper(_first($buf)),"\n";
492 0 0         if ( length($buf) < 1 ) {
493 0           carp("socket error on recv $!");
494 0           $self->{_errflag} = 1;
495 0           $self->{_state} = 'NetError';
496 0           $self->{_ibsta} |= ERR;
497 0           last;
498             }
499 0           $result .= $buf;
500 0           $read += length($buf);
501 0           $got += length($buf);
502             }
503 0           $sel->remove( $connection_handle->{socket} );
504              
505 0           $self->{_state} = 'NetWaitHeader';
506 0 0         if ( $hdr->{SRQ} ) { # update srq status, discard packet
507 0           print "SRQ!\n";
508 0 0         if ( substr( $result, 0, 1 ) eq '1' ) {
509 0           $self->{_ibsta} |= (RQS);
510             }
511             else {
512 0           $self->{_ibsta} &= ~(RQS);
513             }
514 0           $result = '';
515 0           next;
516             }
517 0 0         if ($eoi) {
518 0           $self->{_ibsta} |= EOI;
519 0           last;
520             }
521             }
522 0 0         if ( $self->{_state} eq 'NetError' ) {
523 0           $self->{_state} = 'NetWaitHeader';
524 0           last;
525             }
526              
527             # print STDERR "look for more packets? eoi=$eoi\n";
528 0 0         last if $eoi;
529             }
530 0           $self->{_ibcntl} = length($result);
531              
532             # no timeout, regular return
533 0           return $result;
534             }
535              
536             sub connection_query
537             { # @_ = ( $connection_handle, $args = { command, read_length, wait_status, wait_query, brutal }
538 0     0 0   my $self = shift;
539 0           my $connection_handle = shift;
540 0           my $args = undef;
541 0 0         if ( ref $_[0] eq 'HASH' ) {
542 0           $args = shift;
543             } # try to be flexible about options as hash/hashref
544 0           else { $args = {@_} }
545              
546 0   0       my $command = $args->{'command'} || undef;
547 0   0       my $brutal = $args->{'brutal'} || $self->brutal();
548 0   0       my $read_length = $args->{'read_length'} || $self->read_length();
549 0   0       my $wait_query = $args->{'wait_query'} || $self->wait_query();
550 0           my $result = undef;
551              
552 0           $self->connection_write( $connection_handle, $args );
553              
554 0           $args->{'timeout'} = $wait_query;
555 0           $result = $self->connection_read( $connection_handle, $args );
556 0           return $result;
557             }
558              
559             sub connection_settermchar { # @_ = ( $connection_handle, $termchar
560             # do nothing
561 0     0 0   return 1;
562             }
563              
564             sub connection_enabletermchar { # @_ = ( $connection_handle, 0/1 off/on
565             # do nothing
566 0     0 0   return 1;
567             }
568              
569             sub serial_poll {
570 0     0 0   my $self = shift;
571 0           my $connection_handle = shift;
572 0           my $sbyte = undef;
573              
574 0           my $ibstatus = ibrsp( $connection_handle->{'gpib_handle'}, $sbyte );
575              
576 0           my $ib_bits = $self->ParseIbstatus($ibstatus);
577              
578 0 0         if ( $ib_bits->{'ERR'} == 1 ) {
579 0           Lab::Exception::GPIBError->throw(
580             error => sprintf(
581             "ibrsp (serial poll) failed with status %x\n",
582             $ibstatus
583             )
584             . Dumper($ib_bits),
585             ibsta => $ibstatus,
586             ibsta_hash => $ib_bits,
587             );
588             }
589              
590 0           return $sbyte;
591             }
592              
593             sub connection_clear {
594 0     0 0   my $self = shift;
595 0           my $connection_handle = shift;
596              
597             }
598              
599             sub timeout {
600 0     0 1   my $self = shift;
601 0           my $connection_handle = shift;
602 0 0         return $self->{timeout} unless defined $connection_handle;
603 0           my $timo = shift;
604 0 0         return $self->{timeout} unless defined $timo;
605              
606 0 0 0       if ( !defined($timo)
607             || $timo !~ /^\s*\+?(\d+|\d+\.\d*|\.\d+)(e[\+\-]?\d+)?\s*/i ) {
608 0           carp("bad value for timeout");
609 0           return;
610             }
611 0           $timo += 0;
612 0           $self->{timeout} = $timo;
613 0           $connection_handle->{socket}->timeout($timo);
614             }
615              
616             sub ParseIbstatus
617             { # Ibstatus http://linux-gpib.sourceforge.net/doc_html/r634.html
618 0     0 0   my $self = shift;
619 0           my $ibstatus = shift; # 16 Bit int
620 0           my @ibbits = ();
621              
622 0 0 0       if ( $ibstatus !~ /[0-9]*/ || $ibstatus < 0 || $ibstatus > 0xFFFF )
      0        
623             { # should be a 16 bit integer
624 0           carp("Got an invalid Ibstatus");
625 0           return undef;
626             }
627              
628 0           for ( my $i = 0; $i < 16; $i++ ) {
629 0           $ibbits[$i] = 0x0001 & ( $ibstatus >> $i );
630             }
631              
632 0           my %Ib = ();
633             (
634             $Ib{'DCAS'}, $Ib{'DTAS'}, $Ib{'LACS'}, $Ib{'TACS'},
635             $Ib{'ATN'}, $Ib{'CIC'}, $Ib{'REM'}, $Ib{'LOK'},
636             $Ib{'CMPL'}, $Ib{'EVENT'}, $Ib{'SPOLL'}, $Ib{'RQS'},
637 0           $Ib{'SRQI'}, $Ib{'END'}, $Ib{'TIMO'}, $Ib{'ERR'}
638             ) = @ibbits;
639              
640 0           return \%Ib;
641              
642             } # return: ($ERR, $TIMO, $END, $SRQI, $RQS, $SPOLL, $EVENT, $CMPL, $LOK, $REM, $CIC, $ATN, $TACS, $LACS, $DTAS, $DCAS)
643              
644             sub VerboseIbstatus {
645 0     0 0   my $self = shift;
646 0           my $ibstatus = shift;
647 0           my $ibstatus_verbose = "";
648              
649 0 0         if ( ref( \$ibstatus ) =~ /SCALAR/ ) {
    0          
650 0           $ibstatus = $self->ParseIbstatus($ibstatus);
651             }
652             elsif ( ref($ibstatus) !~ /HASH/ ) {
653 0           carp("invalid ibstatus parameter");
654 0           return undef;
655             }
656              
657 0           while ( my ( $k, $v ) = each %$ibstatus ) {
658 0           $ibstatus_verbose .= "$k: $v\n";
659             }
660              
661 0           return $ibstatus_verbose;
662             }
663              
664             1;
665              
666              
667             1;
668              
669             __END__
670              
671             =pod
672              
673             =encoding utf-8
674              
675             =head1 NAME
676              
677             Lab::Bus::VICP - VICP bus
678              
679             =head1 VERSION
680              
681             version 3.880
682              
683             =head1 SYNOPSIS
684              
685             This is the bus class for the VICP connection used for GPIB communication
686              
687             my $GPIB = new Lab::Bus::VICP(remote_host=>'myhost' );
688              
689             or implicit through instrument and connection creation:
690              
691             my $instrument = new Lab::Instrument::LeCroy640({
692             connection_type => 'VICP',
693             remote_addr => 'myhost',
694             }
695              
696             =head1 DESCRIPTION
697              
698             Note: you don't need to explicitly handle bus objects. The Instruments will create them themselves, and existing bus will
699             be automagically reused.
700              
701             =head1 CONSTRUCTOR
702              
703             =head2 new
704              
705             my $bus = new Lab::Bus::VICP(
706             remote_addr => $ipaddr
707             );
708              
709             Return blessed $self, with @_ accessible through $self->config().
710              
711             ===== TBD below ===
712              
713             =head1 METHODS
714              
715             =head2 connection_new
716              
717             $GPIB->connection_new({ gpib_address => $paddr });
718              
719             Creates a new connection ("instrument handle") for this bus. The argument is a hash, whose contents depend on the bus type.
720             For GPIB at least 'gpib_address' is needed.
721              
722             The handle is usually stored in an instrument object and given to connection_read, connection_write etc.
723             to identify and handle the calling instrument:
724              
725             $InstrumentHandle = $GPIB->connection_new({ gpib_address => 13 });
726             $result = $GPIB->connection_read($self->InstrumentHandle(), { options });
727              
728             See C<Lab::Instrument::Read()>.
729              
730             TODO: this is probably not correct anymore
731              
732             =head2 connection_write
733              
734             $GPIB->connection_write( $InstrumentHandle, { Cmd => $Command } );
735              
736             Sends $Command to the instrument specified by the handle.
737              
738             =head2 connection_read
739              
740             $GPIB->connection_read( $InstrumentHandle, { Cmd => $Command, ReadLength => $readlength, Brutal => 0/1 } );
741              
742             Sends $Command to the instrument specified by the handle. Reads back a maximum of $readlength bytes. If a timeout or
743             an error occurs, Lab::Exception::GPIBError or Lab::Exception::GPIBTimeout are thrown, respectively. The Timeout object
744             carries the data received up to the timeout event, accessible through $Exception->Data().
745              
746             Setting C<Brutal> to a true value will result in timeouts being ignored, and the gathered data returned without error.
747              
748             =head2 timeout
749              
750             $GPIB->timeout( $connection_handle, $timeout );
751              
752             Sets the timeout in seconds for GPIB operations on the device/connection specified by $connection_handle.
753              
754             =head2 config
755              
756             Provides unified access to the fields in initial @_ to all the child classes.
757             E.g.
758              
759             $GPIB_Address=$instrument->config(gpib_address);
760              
761             Without arguments, returns a reference to the complete $self->config aka @_ of the constructor.
762              
763             $config = $bus->config();
764             $GPIB_PAddress = $bus->config()->{'gpib_address'};
765              
766             =head1 CAVEATS/BUGS
767              
768             Few. Also, not a lot to be done here.
769              
770             =head1 SEE ALSO
771              
772             =over 4
773              
774             =item
775              
776             L<Lab::Bus>
777              
778             =item
779              
780             L<Lab::Bus::MODBUS>
781              
782             =item
783              
784             and many more...
785              
786             =back
787              
788             =head1 COPYRIGHT AND LICENSE
789              
790             This software is copyright (c) 2023 by the Lab::Measurement team; in detail:
791              
792             Copyright 2016 Charles Lane
793             2017 Andreas K. Huettel
794             2020 Andreas K. Huettel
795              
796              
797             This is free software; you can redistribute it and/or modify it under
798             the same terms as the Perl 5 programming language system itself.
799              
800             =cut