Merge branch 'collectd-5.5'
[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
197 =head1 PUBLIC METHODS
198
199 =over 4
200
201 =item I<$self> = Collectd::Unixsock->B<new> ([I<$path>]);
202
203 Creates a new connection to the daemon. The optional I<$path> argument gives
204 the path to the UNIX socket of the C<unixsock plugin> and defaults to
205 F</var/run/collectd-unixsock>. Returns the newly created object on success and
206 false on error.
207
208 =cut
209
210 sub new
211 {
212         my $class = shift;
213         my $path = shift || '/var/run/collectd-unixsock';
214         my $sock = _create_socket ($path) or return;
215         return bless
216                 {
217                         path => $path,
218                         sock => $sock,
219                         error => 'No error'
220                 }, $class;
221 } # new
222
223 =item I<$res> = I<$self>-E<gt>B<getval> (I<%identifier>);
224
225 Requests a value-list from the daemon. On success a hash-ref is returned with
226 the name of each data-source as the key and the according value as, well, the
227 value. On error false is returned.
228
229 =cut
230
231 sub getval # {{{
232 {
233         my $self = shift;
234         my %args = @_;
235         my $ret = {};
236
237     my $msg = $self->_socket_command('GETVAL', \%args) or return;
238     $self->_socket_chat($msg, sub {
239             local $_ = shift;
240             my $ret = shift;
241             /^(\w+)=NaN$/ and $ret->{$1} = undef, return;
242             /^(\w+)=(.*)$/ and looks_like_number($2) and $ret->{$1} = 0 + $2, return;
243         }, $ret
244     );
245         return $ret;
246 } # }}} sub getval
247
248 =item I<$res> = I<$self>-E<gt>B<getthreshold> (I<%identifier>);
249
250 Requests a threshold from the daemon. On success a hash-ref is returned with
251 the threshold data. On error false is returned.
252
253 =cut
254
255 sub getthreshold # {{{
256 {
257         my $self = shift;
258         my %args = @_;
259         my $ret = {};
260
261     my $msg = $self->_socket_command('GETTHRESHOLD', \%args) or return;
262     $self->_socket_chat($msg, sub {
263             local $_ = shift;
264             my $ret = shift;
265             my ( $key, $val );
266             ( $key, $val ) = /^\s*([^:]+):\s*(.*)/ and do {
267                   $key =~ s/\s*$//;
268                   $ret->{$key} = $val;
269             };
270         }, $ret
271     );
272         return $ret;
273 } # }}} sub getthreshold
274
275 =item I<$self>-E<gt>B<putval> (I<%identifier>, B<time> =E<gt> I<$time>, B<values> =E<gt> [...]);
276
277 Submits a value-list to the daemon. If the B<time> argument is omitted
278 C<time()> is used. The required argument B<values> is a reference to an array
279 of values that is to be submitted. The number of values must match the number
280 of values expected for the given B<type> (see L<VALUE IDENTIFIERS>), though
281 this is checked by the daemon, not the Perl module. Also, gauge data-sources
282 (e.E<nbsp>g. system-load) may be C<undef>. Returns true upon success and false
283 otherwise.
284
285 =cut
286
287 sub putval
288 {
289         my $self = shift;
290         my %args = @_;
291
292         my ($status, $msg, $identifier, $values);
293         my $fh = $self->{sock} or confess;
294
295         my $interval = defined $args{interval} ?
296     ' interval=' . _escape_argument ($args{interval}) : '';
297
298         $identifier = _create_identifier (\%args) or return;
299         if (!$args{values})
300         {
301                 cluck ("Need argument `values'");
302                 return;
303         }
304
305         if (ref ($args{values}))
306         {
307                 my $time;
308
309                 if ("ARRAY" ne ref ($args{values}))
310                 {
311                         cluck ("Invalid `values' argument (expected an array ref)");
312                         return;
313                 }
314
315                 if (! scalar @{$args{values}})
316                 {
317                         cluck ("Empty `values' array");
318                         return;
319                 }
320
321                 $time = $args{time} || time;
322                 $values = join (':', $time, map { defined $_ ? $_ : 'U' } @{$args{values}});
323         }
324         else
325         {
326                 $values = $args{values};
327         }
328
329         $msg = 'PUTVAL '
330         . _escape_argument ($identifier)
331         . $interval
332         . ' ' . _escape_argument ($values) . "\n";
333         _debug "-> $msg";
334         $fh->print($msg);
335
336         $msg = <$fh>;
337         chomp $msg;
338         _debug "<- $msg\n";
339
340         ($status, $msg) = split / /, $msg, 2;
341         return 1 if $status == 0;
342
343         $self->{error} = $msg;
344         return;
345 } # putval
346
347 =item I<$res> = I<$self>-E<gt>B<listval_filter> ( C<%identifier> )
348
349 Queries a list of values from the daemon while restricting the results to
350 certain hosts, plugins etc. The argument may be anything that passes for an
351 identifier (cf. L<VALUE IDENTIFIERS>), although all fields are optional.
352 The returned data is in the same format as from C<listval>.
353
354 =cut
355
356 sub listval_filter
357 {
358         my $self = shift;
359     my %args = @_;
360         my @ret;
361         my $nresults;
362         my $fh = $self->{sock} or confess;
363
364     my $pattern =
365     (exists $args{host}              ? "$args{host}"             : '[^/]+') .
366     (exists $args{plugin}            ? "/$args{plugin}"          : '/[^/-]+') .
367         (exists $args{plugin_instance}   ? "-$args{plugin_instance}" : '(?:-[^/]+)?') .
368         (exists $args{type}              ? "/$args{type}"            : '/[^/-]+') .
369         (exists $args{type_instance}     ? "-$args{type_instance}"   : '(?:-[^/]+)?');
370     $pattern = qr/^\d+ $pattern$/;
371
372     my $msg = $self->_socket_command('LISTVAL') or return;
373         ($nresults, $msg) = split / /, $msg, 2;
374
375     # This could use _socket_chat() but doesn't for speed reasons
376         if ($nresults < 0)
377         {
378                 $self->{error} = $msg;
379                 return;
380         }
381
382         for (1 .. $nresults)
383         {
384                 $msg = <$fh>;
385                 chomp $msg;
386                 _debug "<- $msg\n";
387                 next unless $msg =~ $pattern;
388                 my ($time, $ident) = split / /, $msg, 2;
389
390                 $ident = _parse_identifier ($ident);
391                 $ident->{time} = int $time;
392
393                 push (@ret, $ident);
394         } # for (i = 0 .. $status)
395
396         return @ret;
397 } # listval
398
399 =item I<$res> = I<$self>-E<gt>B<listval> ()
400
401 Queries a list of values from the daemon. The list is returned as an array of
402 hash references, where each hash reference is a valid identifier. The C<time>
403 member of each hash holds the epoch value of the last update of that value.
404
405 =cut
406
407 sub listval
408 {
409         my $self = shift;
410         my $nresults;
411         my @ret;
412         my $fh = $self->{sock} or confess;
413
414     my $msg = $self->_socket_command('LISTVAL') or return;
415         ($nresults, $msg) = split / /, $msg, 2;
416
417     # This could use _socket_chat() but doesn't for speed reasons
418         if ($nresults < 0)
419         {
420                 $self->{error} = $msg;
421                 return;
422         }
423
424         for (1 .. $nresults)
425         {
426                 $msg = <$fh>;
427                 chomp $msg;
428                 _debug "<- $msg\n";
429
430                 my ($time, $ident) = split / /, $msg, 2;
431
432                 $ident = _parse_identifier ($ident);
433                 $ident->{time} = int $time;
434
435                 push (@ret, $ident);
436         } # for (i = 0 .. $status)
437
438         return @ret;
439 } # listval
440
441 =item I<$res> = I<$self>-E<gt>B<putnotif> (B<severity> =E<gt> I<$severity>, B<message> =E<gt> I<$message>, ...);
442
443 Submits a notification to the daemon.
444
445 Valid options are:
446
447 =over 4
448
449 =item B<severity>
450
451 Sets the severity of the notification. The value must be one of the following
452 strings: C<failure>, C<warning>, or C<okay>. Case does not matter. This option
453 is mandatory.
454
455 =item B<message>
456
457 Sets the message of the notification. This option is mandatory.
458
459 =item B<time>
460
461 Sets the time. If omitted, C<time()> is used.
462
463 =item I<Value identifier>
464
465 All the other fields of the value identifiers, B<host>, B<plugin>,
466 B<plugin_instance>, B<type>, and B<type_instance>, are optional. When given,
467 the notification is associated with the performance data of that identifier.
468 For more details, please see L<collectd-unixsock(5)>.
469
470 =back
471
472 =cut
473
474 sub putnotif
475 {
476         my $self = shift;
477         my %args = @_;
478
479         my $status;
480         my $fh = $self->{sock} or confess;
481
482         my $msg; # message sent to the socket
483         
484     for my $arg (qw( message severity ))
485     {
486         cluck ("Need argument `$arg'"), return unless $args{$arg};
487     }
488         $args{severity} = lc $args{severity};
489         if (($args{severity} ne 'failure')
490                 && ($args{severity} ne 'warning')
491                 && ($args{severity} ne 'okay'))
492         {
493                 cluck ("Invalid `severity: " . $args{severity});
494                 return;
495         }
496
497         $args{time} ||= time;
498         
499         $msg = 'PUTNOTIF '
500         . join (' ', map { $_ . '=' . _escape_argument ($args{$_}) } keys %args)
501         . "\n";
502
503         _debug "-> $msg";
504         $fh->print($msg);
505
506         $msg = <$fh>;
507         chomp $msg;
508         _debug "<- $msg\n";
509
510         ($status, $msg) = split / /, $msg, 2;
511         return 1 if $status == 0;
512
513         $self->{error} = $msg;
514         return;
515 } # putnotif
516
517 =item I<$self>-E<gt>B<flush> (B<timeout> =E<gt> I<$timeout>, B<plugins> =E<gt> [...], B<identifier>  =E<gt> [...]);
518
519 Flush cached data.
520
521 Valid options are:
522
523 =over 4
524
525 =item B<timeout>
526
527 If this option is specified, only data older than I<$timeout> seconds is
528 flushed.
529
530 =item B<plugins>
531
532 If this option is specified, only the selected plugins will be flushed. The
533 argument is a reference to an array of strings.
534
535 =item B<identifier>
536
537 If this option is specified, only the given identifier(s) will be flushed. The
538 argument is a reference to an array of identifiers. Identifiers, in this case,
539 are hash references and have the members as outlined in L<VALUE IDENTIFIERS>.
540
541 =back
542
543 =cut
544
545 sub flush
546 {
547         my $self  = shift;
548         my %args = @_;
549
550         my $fh = $self->{sock} or confess;
551
552         my $status = 0;
553         my $msg    = "FLUSH";
554
555     $msg .= " timeout=$args{timeout}" if defined $args{timeout};
556
557         if ($args{plugins})
558         {
559                 foreach my $plugin (@{$args{plugins}})
560                 {
561                         $msg .= " plugin=" . $plugin;
562                 }
563         }
564
565         if ($args{identifier})
566         {
567                 for my $identifier (@{$args{identifier}})
568                 {
569                         my $ident_str;
570
571                         if (ref ($identifier) ne 'HASH')
572                         {
573                                 cluck ("The argument of the `identifier' "
574                                         . "option must be an array of hashrefs.");
575                                 return;
576                         }
577
578                         $ident_str = _create_identifier ($identifier) or return;
579                         $msg .= ' identifier=' . _escape_argument ($ident_str);
580                 }
581         }
582
583         $msg .= "\n";
584
585         _debug "-> $msg";
586         $fh->print($msg);
587
588         $msg = <$fh>;
589         chomp ($msg);
590         _debug "<- $msg\n";
591
592         ($status, $msg) = split / /, $msg, 2;
593         return 1 if $status == 0;
594
595         $self->{error} = $msg;
596         return;
597 }
598
599 sub error
600 {
601         return shift->{error};
602 }
603
604 =item I<$self>-E<gt>destroy ();
605
606 Closes the socket before the object is destroyed. This function is also
607 automatically called then the object goes out of scope.
608
609 =back
610
611 =cut
612
613 sub destroy
614 {
615         my $self = shift;
616         if ($self->{sock})
617         {
618                 close $self->{sock};
619                 delete $self->{sock};
620         }
621 }
622
623 sub DESTROY
624 {
625         my $self = shift;
626         $self->destroy ();
627 }
628
629 =head1 SEE ALSO
630
631 L<collectd(1)>,
632 L<collectd.conf(5)>,
633 L<collectd-unixsock(5)>
634
635 =head1 AUTHOR
636
637 Florian octo Forster E<lt>octo@collectd.orgE<gt>
638
639 =cut
640 1;
641 # vim: set fdm=marker :