Merge branch 'collectd-5.5' into collectd-5.6
[collectd.git] / bindings / perl / lib / Collectd / Unixsock.pm
1 #
2 # collectd - bindings/buildperl/Collectd/Unixsock.pm
3 # Copyright (C) 2007,2008  Florian octo Forster
4 #
5 # Permission is hereby granted, free of charge, to any person obtaining a
6 # copy of this software and associated documentation files (the "Software"),
7 # to deal in the Software without restriction, including without limitation
8 # the rights to use, copy, modify, merge, publish, distribute, sublicense,
9 # and/or sell copies of the Software, and to permit persons to whom the
10 # Software is furnished to do so, subject to the following conditions:
11 #
12 # The above copyright notice and this permission notice shall be included in
13 # all copies or substantial portions of the Software.
14 #
15 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
20 # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
21 # DEALINGS IN THE SOFTWARE.
22 #
23 # Authors:
24 #   Florian Forster <octo at collectd.org>
25 #
26
27 package Collectd::Unixsock;
28
29 =head1 NAME
30
31 Collectd::Unixsock - Abstraction layer for accessing the functionality by
32 collectd's unixsock plugin.
33
34 =head1 SYNOPSIS
35
36   use Collectd::Unixsock;
37
38   my $sock = Collectd::Unixsock->new ($path);
39
40   my $value = $sock->getval (%identifier);
41   $sock->putval (%identifier,
42                  time => time (),
43                  values => [123, 234, 345]);
44
45   $sock->destroy ();
46
47 =head1 DESCRIPTION
48
49 collectd's unixsock plugin allows external programs to access the values it has
50 collected or received and to submit own values. This Perl-module is simply a
51 little abstraction layer over this interface to make it even easier for
52 programmers to interact with the daemon.
53
54 =cut
55
56 use strict;
57 use warnings;
58
59 use Carp qw(cluck confess carp croak);
60 use IO::Socket::UNIX;
61 use Scalar::Util qw( looks_like_number );
62
63 our $Debug = 0;
64
65 sub _debug
66 {
67         print @_ if $Debug;
68 }
69
70 sub _create_socket
71 {
72         my $path = shift;
73         my $sock = IO::Socket::UNIX->new (Type => SOCK_STREAM, Peer => $path);
74         if (!$sock)
75         {
76                 cluck ("Cannot open UNIX-socket $path: $!");
77                 return;
78         }
79         return ($sock);
80 } # _create_socket
81
82 =head1 VALUE IDENTIFIERS
83
84 The values in the collectd are identified using a five-tuple (host, plugin,
85 plugin-instance, type, type-instance) where only plugin instance and type
86 instance may be undef. Many functions expect an I<%identifier> hash that has at
87 least the members B<host>, B<plugin>, and B<type>, possibly completed by
88 B<plugin_instance> and B<type_instance>.
89
90 Usually you can pass this hash as follows:
91
92   $self->method (host => $host, plugin => $plugin, type => $type, %other_args);
93
94 =cut
95
96 sub _create_identifier
97 {
98         my $args = shift;
99         my ($host, $plugin, $type);
100
101         if (!$args->{host} || !$args->{plugin} || !$args->{type})
102         {
103                 cluck ("Need `host', `plugin' and `type'");
104                 return;
105         }
106
107         $host = $args->{host};
108         $plugin = $args->{plugin};
109         $plugin .= '-' . $args->{plugin_instance} if defined $args->{plugin_instance};
110         $type = $args->{type};
111         $type .= '-' . $args->{type_instance} if defined $args->{type_instance};
112
113         return "$host/$plugin/$type";
114 } # _create_identifier
115
116 sub _parse_identifier
117 {
118         my $string = shift;
119         my ($plugin_instance, $type_instance);
120
121         my ($host, $plugin, $type) = split /\//, $string;
122
123         ($plugin, $plugin_instance) = split /-/, $plugin, 2;
124         ($type, $type_instance) = split /-/, $type, 2;
125
126         my $ident =
127         {
128                 host => $host,
129                 plugin => $plugin,
130                 type => $type
131         };
132         $ident->{plugin_instance} = $plugin_instance if defined $plugin_instance;
133         $ident->{type_instance} = $type_instance if defined $type_instance;
134
135         return $ident;
136 } # _parse_identifier
137
138 sub _escape_argument
139 {
140     my $arg = shift;
141
142         return $arg if $arg =~ /^\w+$/;
143
144         $arg =~ s#\\#\\\\#g;
145         $arg =~ s#"#\\"#g;
146         return "\"$arg\"";
147 }
148
149 # Send a command on a socket, including any required argument escaping.
150 # Return a single line of result.
151 sub _socket_command {
152         my ($self, $command, $args) = @_;
153
154         my $fh = $self->{sock} or confess ('object has no filehandle');
155
156     if($args) {
157         my $identifier = _create_identifier ($args) or return;
158             $command .= ' ' . _escape_argument ($identifier) . "\n";
159     } else {
160         $command .= "\n";
161     }
162         _debug "-> $command";
163         $fh->print($command);
164
165         my $response = $fh->getline;
166         chomp $response;
167         _debug "<- $response\n";
168     return $response;
169 }
170
171 # Read any remaining results from a socket and pass them to
172 # a callback for caller-defined mangling.
173 sub _socket_chat
174 {
175         my ($self, $msg, $callback, $cbdata) = @_;
176         my ($nresults, $ret);
177         my $fh = $self->{sock} or confess ('object has no filehandle');
178
179         ($nresults, $msg) = split / /, $msg, 2;
180         if ($nresults <= 0)
181         {
182                 $self->{error} = $msg;
183                 return;
184         }
185
186         for (1 .. $nresults)
187         {
188                 my $entry = $fh->getline;
189                 chomp $entry;
190                 _debug "<- $entry\n";
191         $callback->($entry, $cbdata);
192         }
193         return $cbdata;
194 }
195
196 # Send a raw message on a socket.
197 # Returns true upon success and false otherwise.
198 sub _send_message
199 {
200         my ($self, $msg) = @_;
201         
202         my $fh = $self->{'sock'} or confess ('object has no filehandle');
203         
204         $msg .= "\n" unless $msg =~/\n$/;
205         
206         #1024 is default buffer size at unixsock.c us_handle_client()
207         warn "Collectd::Unixsock->_send_message(\$msg): message is too long!" if length($msg) > 1024;
208         
209         _debug "-> $msg";
210         $fh->print($msg);
211
212         $msg = <$fh>;
213         chomp ($msg);
214         _debug "<- $msg\n";
215
216         my ($status, $error) = split / /, $msg, 2;
217         return 1 if $status == 0;
218
219         $self->{error} = $error;
220         return;
221 }
222
223 =head1 PUBLIC METHODS
224
225 =over 4
226
227 =item I<$self> = Collectd::Unixsock->B<new> ([I<$path>]);
228
229 Creates a new connection to the daemon. The optional I<$path> argument gives
230 the path to the UNIX socket of the C<unixsock plugin> and defaults to
231 F</var/run/collectd-unixsock>. Returns the newly created object on success and
232 false on error.
233
234 =cut
235
236 sub new
237 {
238         my $class = shift;
239         my $path = shift || '/var/run/collectd-unixsock';
240         my $sock = _create_socket ($path) or return;
241         return bless
242                 {
243                         path => $path,
244                         sock => $sock,
245                         error => 'No error'
246                 }, $class;
247 } # new
248
249 =item I<$res> = I<$self>-E<gt>B<getval> (I<%identifier>);
250
251 Requests a value-list from the daemon. On success a hash-ref is returned with
252 the name of each data-source as the key and the according value as, well, the
253 value. On error false is returned.
254
255 =cut
256
257 sub getval # {{{
258 {
259         my $self = shift;
260         my %args = @_;
261         my $ret = {};
262
263     my $msg = $self->_socket_command('GETVAL', \%args) or return;
264     $self->_socket_chat($msg, sub {
265             local $_ = shift;
266             my $ret = shift;
267             /^(\w+)=NaN$/ and $ret->{$1} = undef, return;
268             /^(\w+)=(.*)$/ and looks_like_number($2) and $ret->{$1} = 0 + $2, return;
269         }, $ret
270     );
271         return $ret;
272 } # }}} sub getval
273
274 =item I<$res> = I<$self>-E<gt>B<getthreshold> (I<%identifier>);
275
276 Requests a threshold from the daemon. On success a hash-ref is returned with
277 the threshold data. On error false is returned.
278
279 =cut
280
281 sub getthreshold # {{{
282 {
283         my $self = shift;
284         my %args = @_;
285         my $ret = {};
286
287     my $msg = $self->_socket_command('GETTHRESHOLD', \%args) or return;
288     $self->_socket_chat($msg, sub {
289             local $_ = shift;
290             my $ret = shift;
291             my ( $key, $val );
292             ( $key, $val ) = /^\s*([^:]+):\s*(.*)/ and do {
293                   $key =~ s/\s*$//;
294                   $ret->{$key} = $val;
295             };
296         }, $ret
297     );
298         return $ret;
299 } # }}} sub getthreshold
300
301 =item I<$self>-E<gt>B<putval> (I<%identifier>, B<time> =E<gt> I<$time>, B<values> =E<gt> [...]);
302
303 Submits a value-list to the daemon. If the B<time> argument is omitted
304 C<time()> is used. The required argument B<values> is a reference to an array
305 of values that is to be submitted. The number of values must match the number
306 of values expected for the given B<type> (see L<VALUE IDENTIFIERS>), though
307 this is checked by the daemon, not the Perl module. Also, gauge data-sources
308 (e.E<nbsp>g. system-load) may be C<undef>. Returns true upon success and false
309 otherwise.
310
311 =cut
312
313 sub putval
314 {
315         my $self = shift;
316         my %args = @_;
317
318         my ($status, $msg, $identifier, $values);
319         my $fh = $self->{sock} or confess;
320
321         my $interval = defined $args{interval} ?
322     ' interval=' . _escape_argument ($args{interval}) : '';
323
324         $identifier = _create_identifier (\%args) or return;
325         if (!$args{values})
326         {
327                 cluck ("Need argument `values'");
328                 return;
329         }
330
331         if (ref ($args{values}))
332         {
333                 my $time;
334
335                 if ("ARRAY" ne ref ($args{values}))
336                 {
337                         cluck ("Invalid `values' argument (expected an array ref)");
338                         return;
339                 }
340
341                 if (! scalar @{$args{values}})
342                 {
343                         cluck ("Empty `values' array");
344                         return;
345                 }
346
347                 $time = $args{time} || time;
348                 $values = join (':', $time, map { defined $_ ? $_ : 'U' } @{$args{values}});
349         }
350         else
351         {
352                 $values = $args{values};
353         }
354
355         $msg = 'PUTVAL '
356         . _escape_argument ($identifier)
357         . $interval
358         . ' ' . _escape_argument ($values) . "\n";
359
360         return $self->_send_message($msg);
361 } # putval
362
363 =item I<$res> = I<$self>-E<gt>B<listval_filter> ( C<%identifier> )
364
365 Queries a list of values from the daemon while restricting the results to
366 certain hosts, plugins etc. The argument may be anything that passes for an
367 identifier (cf. L<VALUE IDENTIFIERS>), although all fields are optional.
368 The returned data is in the same format as from C<listval>.
369
370 =cut
371
372 sub listval_filter
373 {
374         my $self = shift;
375     my %args = @_;
376         my @ret;
377         my $nresults;
378         my $fh = $self->{sock} or confess;
379
380     my $pattern =
381     (exists $args{host}              ? "$args{host}"             : '[^/]+') .
382     (exists $args{plugin}            ? "/$args{plugin}"          : '/[^/-]+') .
383         (exists $args{plugin_instance}   ? "-$args{plugin_instance}" : '(?:-[^/]+)?') .
384         (exists $args{type}              ? "/$args{type}"            : '/[^/-]+') .
385         (exists $args{type_instance}     ? "-$args{type_instance}"   : '(?:-[^/]+)?');
386     $pattern = qr/^\d+ $pattern$/;
387
388     my $msg = $self->_socket_command('LISTVAL') or return;
389         ($nresults, $msg) = split / /, $msg, 2;
390
391     # This could use _socket_chat() but doesn't for speed reasons
392         if ($nresults < 0)
393         {
394                 $self->{error} = $msg;
395                 return;
396         }
397
398         for (1 .. $nresults)
399         {
400                 $msg = <$fh>;
401                 chomp $msg;
402                 _debug "<- $msg\n";
403                 next unless $msg =~ $pattern;
404                 my ($time, $ident) = split / /, $msg, 2;
405
406                 $ident = _parse_identifier ($ident);
407                 $ident->{time} = int $time;
408
409                 push (@ret, $ident);
410         } # for (i = 0 .. $status)
411
412         return @ret;
413 } # listval
414
415 =item I<$res> = I<$self>-E<gt>B<listval> ()
416
417 Queries a list of values from the daemon. The list is returned as an array of
418 hash references, where each hash reference is a valid identifier. The C<time>
419 member of each hash holds the epoch value of the last update of that value.
420
421 =cut
422
423 sub listval
424 {
425         my $self = shift;
426         my $nresults;
427         my @ret;
428         my $fh = $self->{sock} or confess;
429
430     my $msg = $self->_socket_command('LISTVAL') or return;
431         ($nresults, $msg) = split / /, $msg, 2;
432
433     # This could use _socket_chat() but doesn't for speed reasons
434         if ($nresults < 0)
435         {
436                 $self->{error} = $msg;
437                 return;
438         }
439
440         for (1 .. $nresults)
441         {
442                 $msg = <$fh>;
443                 chomp $msg;
444                 _debug "<- $msg\n";
445
446                 my ($time, $ident) = split / /, $msg, 2;
447
448                 $ident = _parse_identifier ($ident);
449                 $ident->{time} = int $time;
450
451                 push (@ret, $ident);
452         } # for (i = 0 .. $status)
453
454         return @ret;
455 } # listval
456
457 =item I<$res> = I<$self>-E<gt>B<putnotif> (B<severity> =E<gt> I<$severity>, B<message> =E<gt> I<$message>, ...);
458
459 Submits a notification to the daemon.
460
461 Valid options are:
462
463 =over 4
464
465 =item B<severity>
466
467 Sets the severity of the notification. The value must be one of the following
468 strings: C<failure>, C<warning>, or C<okay>. Case does not matter. This option
469 is mandatory.
470
471 =item B<message>
472
473 Sets the message of the notification. This option is mandatory.
474
475 =item B<time>
476
477 Sets the time. If omitted, C<time()> is used.
478
479 =item I<Value identifier>
480
481 All the other fields of the value identifiers, B<host>, B<plugin>,
482 B<plugin_instance>, B<type>, and B<type_instance>, are optional. When given,
483 the notification is associated with the performance data of that identifier.
484 For more details, please see L<collectd-unixsock(5)>.
485
486 =back
487
488 =cut
489
490 sub putnotif
491 {
492         my $self = shift;
493         my %args = @_;
494
495         my $status;
496         my $fh = $self->{sock} or confess;
497
498         my $msg; # message sent to the socket
499         
500     for my $arg (qw( message severity ))
501     {
502         cluck ("Need argument `$arg'"), return unless $args{$arg};
503     }
504         $args{severity} = lc $args{severity};
505         if (($args{severity} ne 'failure')
506                 && ($args{severity} ne 'warning')
507                 && ($args{severity} ne 'okay'))
508         {
509                 cluck ("Invalid `severity: " . $args{severity});
510                 return;
511         }
512
513         $args{time} ||= time;
514         
515         $msg = 'PUTNOTIF '
516         . join (' ', map { $_ . '=' . _escape_argument ($args{$_}) } keys %args)
517         . "\n";
518
519         return $self->_send_message($msg);
520 } # putnotif
521
522 =item I<$self>-E<gt>B<flush> (B<timeout> =E<gt> I<$timeout>, B<plugins> =E<gt> [...], B<identifier>  =E<gt> [...]);
523
524 Flush cached data.
525
526 Valid options are:
527
528 =over 4
529
530 =item B<timeout>
531
532 If this option is specified, only data older than I<$timeout> seconds is
533 flushed.
534
535 =item B<plugins>
536
537 If this option is specified, only the selected plugins will be flushed. The
538 argument is a reference to an array of strings.
539
540 =item B<identifier>
541
542 If this option is specified, only the given identifier(s) will be flushed. The
543 argument is a reference to an array of identifiers. Identifiers, in this case,
544 are hash references and have the members as outlined in L<VALUE IDENTIFIERS>.
545
546 =back
547
548 =cut
549
550 sub flush
551 {
552         my $self  = shift;
553         my %args = @_;
554
555         my $fh = $self->{sock} or confess;
556
557         my $msg    = "FLUSH";
558
559     $msg .= " timeout=$args{timeout}" if defined $args{timeout};
560
561         if ($args{plugins})
562         {
563                 foreach my $plugin (@{$args{plugins}})
564                 {
565                         $msg .= " plugin=" . $plugin;
566                 }
567         }
568
569         if ($args{identifier})
570         {
571                 my $pre = $msg;
572                 for my $identifier (@{$args{identifier}})
573                 {
574                         my $ident_str;
575
576                         if (ref ($identifier) ne 'HASH')
577                         {
578                                 cluck ("The argument of the `identifier' "
579                                         . "option must be an array of hashrefs.");
580                                 return;
581                         }
582
583                         $ident_str = _create_identifier ($identifier) or return;
584                         $ident_str = ' identifier=' . _escape_argument ($ident_str);
585
586                         if (length($msg)+length($ident_str) >= 1023) { #1024 - 1 byte for \n
587                                 $self->_send_message($msg) or return;
588                                 $msg = $pre;
589                         }
590             
591                         $msg .= $ident_str;
592                 }
593         }
594     
595         return $self->_send_message($msg);
596 }
597
598 sub error
599 {
600         return shift->{error};
601 }
602
603 =item I<$self>-E<gt>destroy ();
604
605 Closes the socket before the object is destroyed. This function is also
606 automatically called then the object goes out of scope.
607
608 =back
609
610 =cut
611
612 sub destroy
613 {
614         my $self = shift;
615         if ($self->{sock})
616         {
617                 close $self->{sock};
618                 delete $self->{sock};
619         }
620 }
621
622 sub DESTROY
623 {
624         my $self = shift;
625         $self->destroy ();
626 }
627
628 =head1 SEE ALSO
629
630 L<collectd(1)>,
631 L<collectd.conf(5)>,
632 L<collectd-unixsock(5)>
633
634 =head1 AUTHOR
635
636 Florian octo Forster E<lt>octo@collectd.orgE<gt>
637
638 =cut
639 1;
640 # vim: set fdm=marker :