5c6a5f9d24c74179b8c2e3a878619198398bdc73
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 #
27 package Collectd::Unixsock;
29 =head1 NAME
31 Collectd::Unixsock - Abstraction layer for accessing the functionality by
32 collectd's unixsock plugin.
34 =head1 SYNOPSIS
36 use Collectd::Unixsock;
38 my $sock = Collectd::Unixsock->new ($path);
40 my $value = $sock->getval (%identifier);
41 $sock->putval (%identifier,
42 time => time (),
43 values => [123, 234, 345]);
45 $sock->destroy ();
47 =head1 DESCRIPTION
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.
54 =cut
56 use strict;
57 use warnings;
59 use Carp qw(cluck confess carp croak);
60 use IO::Socket::UNIX;
61 use Scalar::Util qw( looks_like_number );
63 our $Debug = 0;
65 sub _debug
66 {
67 print @_ if $Debug;
68 }
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
82 =head1 VALUE IDENTIFIERS
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>.
90 Usually you can pass this hash as follows:
92 $self->method (host => $host, plugin => $plugin, type => $type, %other_args);
94 =cut
96 sub _create_identifier
97 {
98 my $args = shift;
99 my ($host, $plugin, $type);
101 if (!$args->{host} || !$args->{plugin} || !$args->{type})
102 {
103 cluck ("Need `host', `plugin' and `type'");
104 return;
105 }
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};
113 return "$host/$plugin/$type";
114 } # _create_identifier
116 sub _parse_identifier
117 {
118 my $string = shift;
119 my ($plugin_instance, $type_instance);
121 my ($host, $plugin, $type) = split /\//, $string;
123 ($plugin, $plugin_instance) = split /-/, $plugin, 2;
124 ($type, $type_instance) = split /-/, $type, 2;
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;
135 return $ident;
136 } # _parse_identifier
138 sub _escape_argument
139 {
140 local $_ = shift;
142 return $_ if /^\w+$/;
144 s#\\#\\\\#g;
145 s#"#\\"#g;
146 return "\"$_\"";
147 }
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) = @_;
154 my $fh = $self->{sock} or confess ('object has no filehandle');
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);
165 my $response = $fh->getline;
166 chomp $response;
167 _debug "<- $response\n";
168 return $response;
169 }
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');
179 ($nresults, $msg) = split / /, $msg, 2;
180 if ($nresults <= 0)
181 {
182 $self->{error} = $msg;
183 return;
184 }
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 }
197 =head1 PUBLIC METHODS
199 =over 4
201 =item I<$self> = Collectd::Unixsock->B<new> ([I<$path>]);
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.
208 =cut
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
223 =item I<$res> = I<$self>-E<gt>B<getval> (I<%identifier>);
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.
229 =cut
231 sub getval # {{{
232 {
233 my $self = shift;
234 my %args = @_;
235 my $ret = {};
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
248 =item I<$res> = I<$self>-E<gt>B<getthreshold> (I<%identifier>);
250 Requests a threshold from the daemon. On success a hash-ref is returned with
251 the threshold data. On error false is returned.
253 =cut
255 sub getthreshold # {{{
256 {
257 my $self = shift;
258 my %args = @_;
259 my $ret = {};
261 my $msg = $self->_socket_command('GETTHRESHOLD', \%args) or return;
262 $self->_socket_chat($msg, sub {
263 local $_ = shift;
264 my $ret = shift;
265 /^\s*([^:]+):\s*(.*)/ and do {
266 $1 =~ s/\s*$//;
267 $ret->{$1} = $2;
268 };
269 }, $ret
270 );
271 return $ret;
272 } # }}} sub getthreshold
274 =item I<$self>-E<gt>B<putval> (I<%identifier>, B<time> =E<gt> I<$time>, B<values> =E<gt> [...]);
276 Submits a value-list to the daemon. If the B<time> argument is omitted
277 C<time()> is used. The required argument B<values> is a reference to an array
278 of values that is to be submitted. The number of values must match the number
279 of values expected for the given B<type> (see L<VALUE IDENTIFIERS>), though
280 this is checked by the daemon, not the Perl module. Also, gauge data-sources
281 (e.E<nbsp>g. system-load) may be C<undef>. Returns true upon success and false
282 otherwise.
284 =cut
286 sub putval
287 {
288 my $self = shift;
289 my %args = @_;
291 my ($status, $msg, $identifier, $values);
292 my $fh = $self->{sock} or confess;
294 my $interval = defined $args{interval} ?
295 ' interval=' . _escape_argument ($args{interval}) : '';
297 $identifier = _create_identifier (\%args) or return;
298 if (!$args{values})
299 {
300 cluck ("Need argument `values'");
301 return;
302 }
304 if (ref ($args{values}))
305 {
306 my $time;
308 if ("ARRAY" ne ref ($args{values}))
309 {
310 cluck ("Invalid `values' argument (expected an array ref)");
311 return;
312 }
314 if (! scalar @{$args{values}})
315 {
316 cluck ("Empty `values' array");
317 return;
318 }
320 $time = $args{time} || time;
321 $values = join (':', $time, map { defined $_ ? $_ : 'U' } @{$args{values}});
322 }
323 else
324 {
325 $values = $args{values};
326 }
328 $msg = 'PUTVAL '
329 . _escape_argument ($identifier)
330 . $interval
331 . ' ' . _escape_argument ($values) . "\n";
332 _debug "-> $msg";
333 $fh->print($msg);
335 $msg = <$fh>;
336 chomp $msg;
337 _debug "<- $msg\n";
339 ($status, $msg) = split / /, $msg, 2;
340 return 1 if $status == 0;
342 $self->{error} = $msg;
343 return;
344 } # putval
346 =item I<$res> = I<$self>-E<gt>B<listval_filter> ( C<%identifier> )
348 Queries a list of values from the daemon while restricting the results to
349 certain hosts, plugins etc. The argument may be anything that passes for an
350 identifier (cf. L<VALUE IDENTIFIERS>), although all fields are optional.
351 The returned data is in the same format as from C<listval>.
353 =cut
355 sub listval_filter
356 {
357 my $self = shift;
358 my %args = @_;
359 my @ret;
360 my $nresults;
361 my $fh = $self->{sock} or confess;
363 my $pattern =
364 (exists $args{host} ? "$args{host}" : '[^/]+') .
365 (exists $args{plugin} ? "/$args{plugin}" : '/[^/-]+') .
366 (exists $args{plugin_instance} ? "-$args{plugin_instance}" : '(?:-[^/]+)?') .
367 (exists $args{type} ? "/$args{type}" : '/[^/-]+') .
368 (exists $args{type_instance} ? "-$args{type_instance}" : '(?:-[^/]+)?');
369 $pattern = qr/^\d+ $pattern$/;
371 my $msg = $self->_socket_command('LISTVAL') or return;
372 ($nresults, $msg) = split / /, $msg, 2;
374 # This could use _socket_chat() but doesn't for speed reasons
375 if ($nresults < 0)
376 {
377 $self->{error} = $msg;
378 return;
379 }
381 for (1 .. $nresults)
382 {
383 $msg = <$fh>;
384 chomp $msg;
385 _debug "<- $msg\n";
386 next unless $msg =~ $pattern;
387 my ($time, $ident) = split / /, $msg, 2;
389 $ident = _parse_identifier ($ident);
390 $ident->{time} = int $time;
392 push (@ret, $ident);
393 } # for (i = 0 .. $status)
395 return @ret;
396 } # listval
398 =item I<$res> = I<$self>-E<gt>B<listval> ()
400 Queries a list of values from the daemon. The list is returned as an array of
401 hash references, where each hash reference is a valid identifier. The C<time>
402 member of each hash holds the epoch value of the last update of that value.
404 =cut
406 sub listval
407 {
408 my $self = shift;
409 my $nresults;
410 my @ret;
411 my $fh = $self->{sock} or confess;
413 my $msg = $self->_socket_command('LISTVAL') or return;
414 ($nresults, $msg) = split / /, $msg, 2;
416 # This could use _socket_chat() but doesn't for speed reasons
417 if ($nresults < 0)
418 {
419 $self->{error} = $msg;
420 return;
421 }
423 for (1 .. $nresults)
424 {
425 $msg = <$fh>;
426 chomp $msg;
427 _debug "<- $msg\n";
429 my ($time, $ident) = split / /, $msg, 2;
431 $ident = _parse_identifier ($ident);
432 $ident->{time} = int $time;
434 push (@ret, $ident);
435 } # for (i = 0 .. $status)
437 return @ret;
438 } # listval
440 =item I<$res> = I<$self>-E<gt>B<putnotif> (B<severity> =E<gt> I<$severity>, B<message> =E<gt> I<$message>, ...);
442 Submits a notification to the daemon.
444 Valid options are:
446 =over 4
448 =item B<severity>
450 Sets the severity of the notification. The value must be one of the following
451 strings: C<failure>, C<warning>, or C<okay>. Case does not matter. This option
452 is mandatory.
454 =item B<message>
456 Sets the message of the notification. This option is mandatory.
458 =item B<time>
460 Sets the time. If omitted, C<time()> is used.
462 =item I<Value identifier>
464 All the other fields of the value identifiers, B<host>, B<plugin>,
465 B<plugin_instance>, B<type>, and B<type_instance>, are optional. When given,
466 the notification is associated with the performance data of that identifier.
467 For more details, please see L<collectd-unixsock(5)>.
469 =back
471 =cut
473 sub putnotif
474 {
475 my $self = shift;
476 my %args = @_;
478 my $status;
479 my $fh = $self->{sock} or confess;
481 my $msg; # message sent to the socket
483 for my $arg (qw( message severity ))
484 {
485 cluck ("Need argument `$arg'"), return unless $args{$arg};
486 }
487 $args{severity} = lc $args{severity};
488 if (($args{severity} ne 'failure')
489 && ($args{severity} ne 'warning')
490 && ($args{severity} ne 'okay'))
491 {
492 cluck ("Invalid `severity: " . $args{severity});
493 return;
494 }
496 $args{time} ||= time;
498 $msg = 'PUTNOTIF '
499 . join (' ', map { $_ . '=' . _escape_argument ($args{$_}) } keys %args)
500 . "\n";
502 _debug "-> $msg";
503 $fh->print($msg);
505 $msg = <$fh>;
506 chomp $msg;
507 _debug "<- $msg\n";
509 ($status, $msg) = split / /, $msg, 2;
510 return 1 if $status == 0;
512 $self->{error} = $msg;
513 return;
514 } # putnotif
516 =item I<$self>-E<gt>B<flush> (B<timeout> =E<gt> I<$timeout>, B<plugins> =E<gt> [...], B<identifier> =E<gt> [...]);
518 Flush cached data.
520 Valid options are:
522 =over 4
524 =item B<timeout>
526 If this option is specified, only data older than I<$timeout> seconds is
527 flushed.
529 =item B<plugins>
531 If this option is specified, only the selected plugins will be flushed. The
532 argument is a reference to an array of strings.
534 =item B<identifier>
536 If this option is specified, only the given identifier(s) will be flushed. The
537 argument is a reference to an array of identifiers. Identifiers, in this case,
538 are hash references and have the members as outlined in L<VALUE IDENTIFIERS>.
540 =back
542 =cut
544 sub flush
545 {
546 my $self = shift;
547 my %args = @_;
549 my $fh = $self->{sock} or confess;
551 my $status = 0;
552 my $msg = "FLUSH";
554 $msg .= " timeout=$args{timeout}" if defined $args{timeout};
556 if ($args{plugins})
557 {
558 foreach my $plugin (@{$args{plugins}})
559 {
560 $msg .= " plugin=" . $plugin;
561 }
562 }
564 if ($args{identifier})
565 {
566 for my $identifier (@{$args{identifier}})
567 {
568 my $ident_str;
570 if (ref ($identifier) ne 'HASH')
571 {
572 cluck ("The argument of the `identifier' "
573 . "option must be an array of hashrefs.");
574 return;
575 }
577 $ident_str = _create_identifier ($identifier) or return;
578 $msg .= ' identifier=' . _escape_argument ($ident_str);
579 }
580 }
582 $msg .= "\n";
584 _debug "-> $msg";
585 $fh->print($msg);
587 $msg = <$fh>;
588 chomp ($msg);
589 _debug "<- $msg\n";
591 ($status, $msg) = split / /, $msg, 2;
592 return 1 if $status == 0;
594 $self->{error} = $msg;
595 return;
596 }
598 sub error
599 {
600 return shift->{error};
601 }
603 =item I<$self>-E<gt>destroy ();
605 Closes the socket before the object is destroyed. This function is also
606 automatically called then the object goes out of scope.
608 =back
610 =cut
612 sub destroy
613 {
614 my $self = shift;
615 if ($self->{sock})
616 {
617 close $self->{sock};
618 delete $self->{sock};
619 }
620 }
622 sub DESTROY
623 {
624 my $self = shift;
625 $self->destroy ();
626 }
628 =head1 SEE ALSO
630 L<collectd(1)>,
631 L<collectd.conf(5)>,
632 L<collectd-unixsock(5)>
634 =head1 AUTHOR
636 Florian octo Forster E<lt>octo@collectd.orgE<gt>
638 =cut
639 1;
640 # vim: set fdm=marker :