File Coverage

blib/lib/Lab/Bus/Socket.pm
Criterion Covered Total %
statement 26 125 20.8
branch 0 48 0.0
condition 0 30 0.0
subroutine 9 16 56.2
pod 4 7 57.1
total 39 226 17.2


line stmt bran cond sub pod time code
1             package Lab::Bus::Socket;
2             #ABSTRACT: IP network socket bus
3             $Lab::Bus::Socket::VERSION = '3.880';
4 1     1   2840 use v5.20;
  1         4  
5              
6 1     1   7 use strict;
  1         4  
  1         26  
7 1     1   9 use Scalar::Util qw(weaken);
  1         3  
  1         54  
8 1     1   5 use Time::HiRes qw (usleep sleep);
  1         2  
  1         9  
9 1     1   138 use Lab::Bus;
  1         2  
  1         41  
10 1     1   6 use Data::Dumper;
  1         2  
  1         44  
11 1     1   7 use Carp;
  1         2  
  1         56  
12 1     1   542 use IO::Socket;
  1         13198  
  1         50  
13 1     1   963 use IO::Select;
  1         1653  
  1         1303  
14              
15             our @ISA = ("Lab::Bus");
16              
17             our %fields = (
18             type => 'Socket',
19             remote_addr => 'localhost', # Client for Write
20             remote_port => '6342',
21             open_server => 0,
22             local_addr => 'localhost', # Server for Read
23             local_port => '6342',
24             proto => 'tcp',
25             listen_queue => 1,
26             reuse => 1,
27             timeout => 60,
28             closechar => "\004", # EOT
29             brutal => 0, # brutal as default?
30             wait_query => 10e-6, # sec;
31             read_length => 1000, # bytes
32             query_length => 300, # bytes
33             query_long_length => 10240, #bytes
34             );
35              
36             sub new {
37 0     0 1   my $proto = shift;
38 0   0       my $class = ref($proto) || $proto;
39 0           my $twin = undef;
40 0           my $self = $class->SUPER::new(@_)
41             ; # getting fields and _permitted from parent class
42 0           $self->${ \( __PACKAGE__ . '::_construct' ) }(__PACKAGE__);
  0            
43              
44             # parameter parsing
45              
46 0 0         $self->remote_addr( $self->config('remote_addr') )
47             if defined $self->config('remote_addr');
48 0 0         $self->remote_port( $self->config('remote_port') )
49             if defined $self->config('remote_port');
50 0 0         $self->open_server( $self->config('open_server') )
51             if defined $self->config('open_server');
52 0 0         $self->local_addr( $self->config('local_addr') )
53             if defined $self->config('local_addr');
54 0 0         $self->local_port( $self->config('local_port') )
55             if defined $self->config('local_port');
56 0 0         $self->Proto( $self->config('Proto') ) if defined $self->config('Proto');
57 0 0         $self->Timeout( $self->config('Timeout') )
58             if defined $self->config('Timeout');
59 0 0         $self->EnableTermChar( $self->config('EnableTermChar') )
60             if defined $self->config('EnableTermChar');
61 0 0         $self->TermChar( $self->config('TermChar') )
62             if defined $self->config('TermChar');
63              
64             # search for twin in %Lab::Bus::BusList. If there's none, place $self there and weaken it.
65 0 0         if ( $class eq __PACKAGE__ )
66             { # careful - do only if this is not a parent class constructor
67 0 0         if ( $twin = $self->_search_twin() ) {
68 0           undef $self;
69 0           return $twin; # ...and that's it.
70             }
71             else {
72 0           $Lab::Bus::BusList{ $self->type() }->{'default'} = $self;
73 0           weaken( $Lab::Bus::BusList{ $self->type() }->{'default'} );
74             }
75             }
76              
77 0           return $self;
78             }
79              
80             sub connection_new { # { gpib_address => primary address }
81 0     0 1   my $self = shift;
82 0           my $args = undef;
83 0 0         if ( ref $_[0] eq 'HASH' ) {
84 0           $args = shift;
85             } # try to be flexible about options as hash/hashref
86 0           else { $args = {@_} }
87 0           my $server = undef;
88 0           my $client = undef;
89 0 0         if ( $args->{'open_server'} ) {
90 0           die "server sockets not yet supported\n";
91             $server = new IO::Socket::INET(
92             LocalHost => $args->{'local_addr'},
93             LocalPort => $args->{'local_port'},
94             Proto => $args->{'proto'},
95             Listen => $args->{'listen_queue'},
96 0           Reuse => $args->{'reuse'},
97             );
98 0 0         die "Could not create socket server: $!\n" unless $server;
99             }
100             $client = new IO::Socket::INET(
101             PeerAddr => $args->{'remote_addr'},
102             PeerPort => $args->{'remote_port'},
103 0           Proto => $args->{'proto'},
104             );
105 0 0         die "Could not create socket client: $!\n" unless $client;
106 0           $client->autoflush(1);
107 0           my $connection_handle = undef;
108 0           $connection_handle = {
109             valid => 1,
110             type => "SOCKET",
111             socket_client_handle => $client,
112             socket_server_handle => $server
113             }; #,
114 0           return $connection_handle;
115             }
116              
117             sub connection_write
118             { # @_ = ( $connection_handle, $args = { command, wait_status }
119 0     0 1   my $self = shift;
120 0           my $connection_handle = shift;
121 0           my $args = undef;
122 0 0         if ( ref $_[0] eq 'HASH' ) {
123 0           $args = shift;
124             } # try to be flexible about options as hash/hashref
125 0           else { $args = {@_} }
126 0   0       my $command = $args->{'command'} || undef;
127 0   0       my $brutal = $args->{'brutal'} || $self->brutal();
128 0   0       my $read_length = $args->{'read_length'} || $self->read_length();
129 0 0         if ( !defined $command ) {
130 0           Lab::Exception::CorruptParameter->throw(
131             error => "No command given to "
132             . __PACKAGE__
133             . "::connection_write().\n", );
134             }
135             else {
136 0 0         if ( $self->{'EnableTermChar'} ) { $command .= $self->{'TermChar'} }
  0            
137 0           my $sock = $connection_handle->{'socket_client_handle'};
138              
139 0           my @ready = IO::Select->new($sock)->can_write( $self->{'Timeout'} );
140 0 0         if (@ready) {
141 0 0         $sock->send($command) or die "$! sending command";
142             }
143             else {
144 0           Lab::Exception::Timeout->throw(
145             error => "Socket write time out\n",
146             );
147             }
148             }
149 0           return 1;
150             }
151              
152             sub connection_read
153             { # @_ = ( $connection_handle, $args = { read_length, brutal }
154 0     0 1   my $self = shift;
155 0           my $connection_handle = shift;
156 0           my $args = undef;
157 0 0         if ( ref $_[0] eq 'HASH' ) {
158 0           $args = shift;
159             } # try to be flexible about options as hash/hashref
160 0           else { $args = {@_} }
161              
162 0   0       my $sock = $connection_handle->{'socket_client_handle'} || undef;
163 0   0       my $brutal = $args->{'brutal'} || $self->brutal();
164 0   0       my $read_length = $args->{'read_length'} || $self->read_length();
165              
166 0           my $raw = "";
167 0           my $result = undef;
168              
169 0 0         if ( !defined $sock ) {
170 0           Lab::Exception::CorruptParameter->throw(
171             error => "No Socket given to "
172             . __PACKAGE__
173             . "::connection_read().\n", );
174             }
175             else {
176 0           my @ready = IO::Select->new($sock)->can_read( $self->{'Timeout'} );
177 0 0         if (@ready) {
178 0           $sock->recv( $result, $read_length );
179             }
180             else {
181 0           Lab::Exception::Timeout->throw(
182             error => "Socket read time out\n",
183             );
184             }
185             }
186              
187 0           $raw = $result;
188 0           $result =~ s/[\n\r\x00]*$//;
189 0           return $result;
190             }
191              
192             sub connection_query
193             { # @_ = ( $connection_handle, $args = { command, read_length, wait_status, wait_query, brutal }
194 0     0 0   my $self = shift;
195 0           my $connection_handle = shift;
196 0           my $args = undef;
197 0 0         if ( ref $_[0] eq 'HASH' ) {
198 0           $args = shift;
199             } # try to be flexible about options as hash/hashref
200 0           else { $args = {@_} }
201              
202 0   0       my $command = $args->{'command'} || undef;
203 0   0       my $brutal = $args->{'brutal'} || $self->brutal();
204 0   0       my $read_length = $args->{'read_length'} || $self->read_length();
205 0   0       my $wait_query = $args->{'wait_query'} || $self->wait_query();
206 0           my $result = undef;
207              
208 0           $self->connection_write($args);
209              
210 0           sleep($wait_query); #<---ensures that asked data presented from the device
211              
212 0           $result = $self->connection_read($args);
213 0           return $result;
214             }
215              
216             sub serial_poll {
217 0     0 0   my $self = shift;
218 0           my $connection_handle = shift;
219 0           return undef;
220             }
221              
222             sub connection_clear {
223 0     0 0   my $self = shift;
224 0           my $connection_handle = shift;
225 0           return undef;
226             }
227              
228             1;
229              
230             __END__
231              
232             =pod
233              
234             =encoding UTF-8
235              
236             =head1 NAME
237              
238             Lab::Bus::Socket - IP network socket bus
239              
240             =head1 VERSION
241              
242             version 3.880
243              
244             =head1 COPYRIGHT AND LICENSE
245              
246             This software is copyright (c) 2023 by the Lab::Measurement team; in detail:
247              
248             Copyright 2012 David Kalok
249             2013 Andreas K. Huettel
250             2016 Simon Reinhardt
251             2017 Andreas K. Huettel
252             2020 Andreas K. Huettel
253              
254              
255             This is free software; you can redistribute it and/or modify it under
256             the same terms as the Perl 5 programming language system itself.
257              
258             =cut