File Coverage

blib/lib/Net/LCDproc.pm
Criterion Covered Total %
statement 51 135 37.7
branch 0 24 0.0
condition 0 3 0.0
subroutine 17 27 62.9
pod 0 5 0.0
total 68 194 35.0


line stmt bran cond sub pod time code
1             package Net::LCDproc;
2             $Net::LCDproc::VERSION = '0.104';
3             #ABSTRACT: Client library to interact with L
4              
5 1     1   26251 use v5.10.2;
  1         4  
  1         67  
6 1     1   548 use Net::LCDproc::Error;
  1         3  
  1         42  
7 1     1   710 use Net::LCDproc::Screen;
  1         3  
  1         68  
8 1     1   646 use Net::LCDproc::Widget::HBar;
  1         3  
  1         43  
9 1     1   425 use Net::LCDproc::Widget::Icon;
  1         3  
  1         50  
10 1     1   520 use Net::LCDproc::Widget::Num;
  1         4  
  1         39  
11 1     1   562 use Net::LCDproc::Widget::Scroller;
  1         3  
  1         79  
12 1     1   622 use Net::LCDproc::Widget::String;
  1         3  
  1         66  
13 1     1   779 use Net::LCDproc::Widget::Title;
  1         3  
  1         54  
14 1     1   554 use Net::LCDproc::Widget::VBar;
  1         2  
  1         67  
15              
16 1     1   8 use Log::Any qw($log);
  1         2  
  1         10  
17 1     1   772 use IO::Socket::INET;
  1         21627  
  1         8  
18 1     1   1279 use Const::Fast;
  1         991  
  1         6  
19 1     1   82 use Types::Standard qw/ArrayRef HashRef InstanceOf Int Str/;
  1         2  
  1         10  
20 1     1   819 use Moo 1.001000;
  1         26  
  1         7  
21 1     1   511 use namespace::clean;
  1         1  
  1         9  
22              
23 1     1   2432 no if $] >= 5.018, 'warnings', 'experimental::smartmatch';
  1         10  
  1         6  
24              
25             const my $PROTOCOL_VERSION => 0.3;
26             const my $MAX_DATA_READ => 4096;
27              
28             sub BUILD {
29 0     0 0   my $self = shift;
30 0           $self->_send_hello;
31 0           return 1;
32             }
33              
34             sub DEMOLISH {
35 0     0 0   my $self = shift;
36 0 0 0       if ($self->has_socket && defined $self->socket) {
37 0 0         $log->debug('Shutting down socket') if $log->is_debug;
38 0           $self->socket->shutdown('2');
39             }
40 0           return 1;
41             }
42              
43             has server => (
44             is => 'ro',
45             isa => Str,
46             default => 'localhost',
47             documentation => 'Hostname or IP address of LCDproc server',
48             );
49              
50             has port => (
51             is => 'ro',
52             isa => Int,
53             default => 13666,
54             documentation => 'Port the LCDproc server is listening on',
55             );
56              
57             has ['width', 'height'] => (
58             is => 'rw',
59             isa => Int,
60             documentation => 'Dimensions of the display in cells',
61             );
62              
63             has ['cell_width', 'cell_height'] => (
64             is => 'rw',
65             isa => Int,
66             documentation => 'Dimensions of a cell in pixels',
67             );
68              
69             has screens => (
70             is => 'rw',
71             isa => ArrayRef [InstanceOf ['Net::LCDproc::Screen']],
72             documentation => 'Array of active screens',
73             default => sub { [] },
74             );
75              
76             has socket => (
77             is => 'lazy',
78             predicate => 1,
79             isa => InstanceOf ['IO::Socket::INET'],
80             );
81              
82             has responses => (
83             is => 'ro',
84             isa => HashRef,
85             required => 1,
86             default => sub {
87             return {
88             connect =>
89             qr{^connect LCDproc (\S+) protocol (\S+) lcd wid (\d+) hgt (\d+) cellwid (\d+) cellhgt (\d+)$},
90             success => qr{^success$},
91             error => qr{^huh\?\s(.+)$},
92             listen => qr{^listen\s(.+)$},
93             ignore => qr{^ignore\s(.+)$},
94             };
95             },
96             );
97              
98             sub _build_socket {
99 0     0     my $self = shift;
100              
101 0           $log->debug('Connecting to server');
102              
103 0           my $socket = IO::Socket::INET->new(
104             PeerAddr => $self->server,
105             PeerPort => $self->port,
106             ReuseAddr => 1,
107             );
108              
109 0 0         if (!defined $socket) {
110              
111 0           Net::LCDproc::Error->throwf(
112             'Failed to connect to lcdproc server at "%s:%s": %s',
113             $self->server, $self->port, $!,);
114             }
115              
116 0           return $socket;
117             }
118              
119             sub _send_cmd {
120 0     0     my ($self, $cmd) = @_;
121              
122 0 0         $log->debug("Sending '$cmd'") if $log->is_debug;
123              
124 0           my $ret = $self->socket->send($cmd . "\n");
125 0 0         if (!defined $ret) {
126 0           Net::LCDproc::Error->throw("Error sending cmd '$cmd': $!");
127             }
128              
129 0           my $response = $self->_handle_response;
130              
131             #if (ref $response eq 'Array') {
132 0           return $response;
133              
134             }
135              
136             sub _recv_response {
137 0     0     my $self = shift;
138 0           $self->socket->recv(my $response, $MAX_DATA_READ);
139              
140 0 0         if (!defined $response) {
141 0           Net::LCDproc::Error->throw("No response from lcdproc: $!");
142             }
143              
144 0           chomp $response;
145 0           $log->debug("Received '$response'");
146              
147 0           return $response;
148             }
149              
150             sub _handle_response {
151 0     0     my $self = shift;
152              
153 0           my $response_str = $self->_recv_response;
154 0           my $matched;
155             my @args;
156 0           foreach my $msg (keys %{$self->responses}) {
  0            
157 0 0         if (@args = $response_str =~ $self->responses->{$msg}) {
158 0           $matched = $msg;
159 0           last;
160             }
161             }
162              
163 0 0         if (!$matched) {
164 0           say "Invalid/Unknown response from server: '$response_str'";
165 0           return;
166             }
167              
168 0           given ($matched) {
169 0           when (/error/) {
170 0           $log->error('ERROR: ' . $args[0]);
171 0           return;
172             }
173 0           when (/connect/) {
174 0           return \@args;
175             }
176 0           when (/success/) {
177 0           return 1;
178             }
179 0           default {
180              
181             # don't care about listen or ignore
182             # so find something useful to return
183             # FIXME: start caring! Then only update the server when
184             # it is actually listening
185 0           return $self->_handle_response;
186             }
187             }
188              
189             }
190              
191             sub _send_hello {
192 0     0     my $self = shift;
193              
194 0           my $response = $self->_send_cmd('hello');
195              
196 0 0         if (!ref $response eq 'ARRAY') {
197 0           Net::LCDproc::Error->throw('Failed to read connect string');
198             }
199 0           my $proto = $response->[1];
200              
201 0           $log->infof('Connected to LCDproc version %s, proto %s',
202             $response->[0], $proto);
203 0 0         if ($proto != $PROTOCOL_VERSION) {
204 0           Net::LCDproc::Error->throwf(
205             'Unsupported protocol version. Available: %s Supported: %s',
206             $proto, $PROTOCOL_VERSION);
207             }
208             ## no critic (ProhibitMagicNumbers)
209 0           $self->width($response->[2]);
210 0           $self->height($response->[3]);
211 0           $self->cell_width($response->[4]);
212 0           $self->cell_height($response->[5]);
213             ## use critic
214 0           return 1;
215             }
216              
217             sub add_screen {
218 0     0 0   my ($self, $screen) = @_;
219 0           $screen->_lcdproc($self);
220 0           push @{$self->screens}, $screen;
  0            
221 0           return 1;
222             }
223              
224             sub remove_screen {
225 0     0 0   my ($self, $screen) = @_;
226 0           my $i = 0;
227 0           foreach my $s (@{$self->screens}) {
  0            
228 0 0         if ($s == $screen) {
229 0 0         $log->debug("Removing $s") if $log->is_debug;
230 0           splice @{$self->screens}, $i, 1;
  0            
231 0           return 1;
232             }
233 0           $i++;
234             }
235 0           $log->error('Failed to remove screen');
236 0           return;
237              
238             }
239              
240             # updates the screen on the server
241             sub update {
242 0     0 0   my $self = shift;
243 0           foreach my $s (@{$self->screens}) {
  0            
244 0           $s->update;
245             }
246 0           return 1;
247             }
248              
249             1;
250              
251             __END__