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 my $arg = shift;
142 return $arg if $arg =~ /^\w+$/;
144 $arg =~ s#\\#\\\\#g;
145 $arg =~ s#"#\\"#g;
146 return "\"$arg\"";
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 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
275 =item I<$self>-E<gt>B<putval> (I<%identifier>, B<time> =E<gt> I<$time>, B<values> =E<gt> [...]);
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.
285 =cut
287 sub putval
288 {
289 my $self = shift;
290 my %args = @_;
292 my ($status, $msg, $identifier, $values);
293 my $fh = $self->{sock} or confess;
295 my $interval = defined $args{interval} ?
296 ' interval=' . _escape_argument ($args{interval}) : '';
298 $identifier = _create_identifier (\%args) or return;
299 if (!$args{values})
300 {
301 cluck ("Need argument `values'");
302 return;
303 }
305 if (ref ($args{values}))
306 {
307 my $time;
309 if ("ARRAY" ne ref ($args{values}))
310 {
311 cluck ("Invalid `values' argument (expected an array ref)");
312 return;
313 }
315 if (! scalar @{$args{values}})
316 {
317 cluck ("Empty `values' array");
318 return;
319 }
321 $time = $args{time} || time;
322 $values = join (':', $time, map { defined $_ ? $_ : 'U' } @{$args{values}});
323 }
324 else
325 {
326 $values = $args{values};
327 }
329 $msg = 'PUTVAL '
330 . _escape_argument ($identifier)
331 . $interval
332 . ' ' . _escape_argument ($values) . "\n";
333 _debug "-> $msg";
334 $fh->print($msg);
336 $msg = <$fh>;
337 chomp $msg;
338 _debug "<- $msg\n";
340 ($status, $msg) = split / /, $msg, 2;
341 return 1 if $status == 0;
343 $self->{error} = $msg;
344 return;
345 } # putval
347 =item I<$res> = I<$self>-E<gt>B<listval_filter> ( C<%identifier> )
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>.
354 =cut
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;
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$/;
372 my $msg = $self->_socket_command('LISTVAL') or return;
373 ($nresults, $msg) = split / /, $msg, 2;
375 # This could use _socket_chat() but doesn't for speed reasons
376 if ($nresults < 0)
377 {
378 $self->{error} = $msg;
379 return;
380 }
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;
390 $ident = _parse_identifier ($ident);
391 $ident->{time} = int $time;
393 push (@ret, $ident);
394 } # for (i = 0 .. $status)
396 return @ret;
397 } # listval
399 =item I<$res> = I<$self>-E<gt>B<listval> ()
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.
405 =cut
407 sub listval
408 {
409 my $self = shift;
410 my $nresults;
411 my @ret;
412 my $fh = $self->{sock} or confess;
414 my $msg = $self->_socket_command('LISTVAL') or return;
415 ($nresults, $msg) = split / /, $msg, 2;
417 # This could use _socket_chat() but doesn't for speed reasons
418 if ($nresults < 0)
419 {
420 $self->{error} = $msg;
421 return;
422 }
424 for (1 .. $nresults)
425 {
426 $msg = <$fh>;
427 chomp $msg;
428 _debug "<- $msg\n";
430 my ($time, $ident) = split / /, $msg, 2;
432 $ident = _parse_identifier ($ident);
433 $ident->{time} = int $time;
435 push (@ret, $ident);
436 } # for (i = 0 .. $status)
438 return @ret;
439 } # listval
441 =item I<$res> = I<$self>-E<gt>B<putnotif> (B<severity> =E<gt> I<$severity>, B<message> =E<gt> I<$message>, ...);
443 Submits a notification to the daemon.
445 Valid options are:
447 =over 4
449 =item B<severity>
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.
455 =item B<message>
457 Sets the message of the notification. This option is mandatory.
459 =item B<time>
461 Sets the time. If omitted, C<time()> is used.
463 =item I<Value identifier>
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)>.
470 =back
472 =cut
474 sub putnotif
475 {
476 my $self = shift;
477 my %args = @_;
479 my $status;
480 my $fh = $self->{sock} or confess;
482 my $msg; # message sent to the socket
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 }
497 $args{time} ||= time;
499 $msg = 'PUTNOTIF '
500 . join (' ', map { $_ . '=' . _escape_argument ($args{$_}) } keys %args)
501 . "\n";
503 _debug "-> $msg";
504 $fh->print($msg);
506 $msg = <$fh>;
507 chomp $msg;
508 _debug "<- $msg\n";
510 ($status, $msg) = split / /, $msg, 2;
511 return 1 if $status == 0;
513 $self->{error} = $msg;
514 return;
515 } # putnotif
517 =item I<$self>-E<gt>B<flush> (B<timeout> =E<gt> I<$timeout>, B<plugins> =E<gt> [...], B<identifier> =E<gt> [...]);
519 Flush cached data.
521 Valid options are:
523 =over 4
525 =item B<timeout>
527 If this option is specified, only data older than I<$timeout> seconds is
528 flushed.
530 =item B<plugins>
532 If this option is specified, only the selected plugins will be flushed. The
533 argument is a reference to an array of strings.
535 =item B<identifier>
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>.
541 =back
543 =cut
545 sub flush
546 {
547 my $self = shift;
548 my %args = @_;
550 my $fh = $self->{sock} or confess;
552 my $status = 0;
553 my $msg = "FLUSH";
555 $msg .= " timeout=$args{timeout}" if defined $args{timeout};
557 if ($args{plugins})
558 {
559 foreach my $plugin (@{$args{plugins}})
560 {
561 $msg .= " plugin=" . $plugin;
562 }
563 }
565 if ($args{identifier})
566 {
567 for my $identifier (@{$args{identifier}})
568 {
569 my $ident_str;
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 }
578 $ident_str = _create_identifier ($identifier) or return;
579 $msg .= ' identifier=' . _escape_argument ($ident_str);
580 }
581 }
583 $msg .= "\n";
585 _debug "-> $msg";
586 $fh->print($msg);
588 $msg = <$fh>;
589 chomp ($msg);
590 _debug "<- $msg\n";
592 ($status, $msg) = split / /, $msg, 2;
593 return 1 if $status == 0;
595 $self->{error} = $msg;
596 return;
597 }
599 sub error
600 {
601 return shift->{error};
602 }
604 =item I<$self>-E<gt>destroy ();
606 Closes the socket before the object is destroyed. This function is also
607 automatically called then the object goes out of scope.
609 =back
611 =cut
613 sub destroy
614 {
615 my $self = shift;
616 if ($self->{sock})
617 {
618 close $self->{sock};
619 delete $self->{sock};
620 }
621 }
623 sub DESTROY
624 {
625 my $self = shift;
626 $self->destroy ();
627 }
629 =head1 SEE ALSO
631 L<collectd(1)>,
632 L<collectd.conf(5)>,
633 L<collectd-unixsock(5)>
635 =head1 AUTHOR
637 Florian octo Forster E<lt>octo@collectd.orgE<gt>
639 =cut
640 1;
641 # vim: set fdm=marker :