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 }
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) = @_;
202 my $fh = $self->{'sock'} or confess ('object has no filehandle');
204 $msg .= "\n" unless $msg =~/\n$/;
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;
209 _debug "-> $msg";
210 $fh->print($msg);
212 $msg = <$fh>;
213 chomp ($msg);
214 _debug "<- $msg\n";
216 my ($status, $error) = split / /, $msg, 2;
217 return 1 if $status == 0;
219 $self->{error} = $error;
220 return;
221 }
223 =head1 PUBLIC METHODS
225 =over 4
227 =item I<$self> = Collectd::Unixsock->B<new> ([I<$path>]);
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.
234 =cut
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
249 =item I<$res> = I<$self>-E<gt>B<getval> (I<%identifier>);
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.
255 =cut
257 sub getval # {{{
258 {
259 my $self = shift;
260 my %args = @_;
261 my $ret = {};
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
274 =item I<$res> = I<$self>-E<gt>B<getthreshold> (I<%identifier>);
276 Requests a threshold from the daemon. On success a hash-ref is returned with
277 the threshold data. On error false is returned.
279 =cut
281 sub getthreshold # {{{
282 {
283 my $self = shift;
284 my %args = @_;
285 my $ret = {};
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
301 =item I<$self>-E<gt>B<putval> (I<%identifier>, B<time> =E<gt> I<$time>, B<values> =E<gt> [...]);
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.
311 =cut
313 sub putval
314 {
315 my $self = shift;
316 my %args = @_;
318 my ($status, $msg, $identifier, $values);
319 my $fh = $self->{sock} or confess;
321 my $interval = defined $args{interval} ?
322 ' interval=' . _escape_argument ($args{interval}) : '';
324 $identifier = _create_identifier (\%args) or return;
325 if (!$args{values})
326 {
327 cluck ("Need argument `values'");
328 return;
329 }
331 if (ref ($args{values}))
332 {
333 my $time;
335 if ("ARRAY" ne ref ($args{values}))
336 {
337 cluck ("Invalid `values' argument (expected an array ref)");
338 return;
339 }
341 if (! scalar @{$args{values}})
342 {
343 cluck ("Empty `values' array");
344 return;
345 }
347 $time = $args{time} || time;
348 $values = join (':', $time, map { defined $_ ? $_ : 'U' } @{$args{values}});
349 }
350 else
351 {
352 $values = $args{values};
353 }
355 $msg = 'PUTVAL '
356 . _escape_argument ($identifier)
357 . $interval
358 . ' ' . _escape_argument ($values) . "\n";
360 return $self->_send_message($msg);
361 } # putval
363 =item I<$res> = I<$self>-E<gt>B<listval_filter> ( C<%identifier> )
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>.
370 =cut
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;
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$/;
388 my $msg = $self->_socket_command('LISTVAL') or return;
389 ($nresults, $msg) = split / /, $msg, 2;
391 # This could use _socket_chat() but doesn't for speed reasons
392 if ($nresults < 0)
393 {
394 $self->{error} = $msg;
395 return;
396 }
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;
406 $ident = _parse_identifier ($ident);
407 $ident->{time} = int $time;
409 push (@ret, $ident);
410 } # for (i = 0 .. $status)
412 return @ret;
413 } # listval
415 =item I<$res> = I<$self>-E<gt>B<listval> ()
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.
421 =cut
423 sub listval
424 {
425 my $self = shift;
426 my $nresults;
427 my @ret;
428 my $fh = $self->{sock} or confess;
430 my $msg = $self->_socket_command('LISTVAL') or return;
431 ($nresults, $msg) = split / /, $msg, 2;
433 # This could use _socket_chat() but doesn't for speed reasons
434 if ($nresults < 0)
435 {
436 $self->{error} = $msg;
437 return;
438 }
440 for (1 .. $nresults)
441 {
442 $msg = <$fh>;
443 chomp $msg;
444 _debug "<- $msg\n";
446 my ($time, $ident) = split / /, $msg, 2;
448 $ident = _parse_identifier ($ident);
449 $ident->{time} = int $time;
451 push (@ret, $ident);
452 } # for (i = 0 .. $status)
454 return @ret;
455 } # listval
457 =item I<$res> = I<$self>-E<gt>B<putnotif> (B<severity> =E<gt> I<$severity>, B<message> =E<gt> I<$message>, ...);
459 Submits a notification to the daemon.
461 Valid options are:
463 =over 4
465 =item B<severity>
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.
471 =item B<message>
473 Sets the message of the notification. This option is mandatory.
475 =item B<time>
477 Sets the time. If omitted, C<time()> is used.
479 =item I<Value identifier>
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)>.
486 =back
488 =cut
490 sub putnotif
491 {
492 my $self = shift;
493 my %args = @_;
495 my $status;
496 my $fh = $self->{sock} or confess;
498 my $msg; # message sent to the socket
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 }
513 $args{time} ||= time;
515 $msg = 'PUTNOTIF '
516 . join (' ', map { $_ . '=' . _escape_argument ($args{$_}) } keys %args)
517 . "\n";
519 return $self->_send_message($msg);
520 } # putnotif
522 =item I<$self>-E<gt>B<flush> (B<timeout> =E<gt> I<$timeout>, B<plugins> =E<gt> [...], B<identifier> =E<gt> [...]);
524 Flush cached data.
526 Valid options are:
528 =over 4
530 =item B<timeout>
532 If this option is specified, only data older than I<$timeout> seconds is
533 flushed.
535 =item B<plugins>
537 If this option is specified, only the selected plugins will be flushed. The
538 argument is a reference to an array of strings.
540 =item B<identifier>
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>.
546 =back
548 =cut
550 sub flush
551 {
552 my $self = shift;
553 my %args = @_;
555 my $fh = $self->{sock} or confess;
557 my $msg = "FLUSH";
559 $msg .= " timeout=$args{timeout}" if defined $args{timeout};
561 if ($args{plugins})
562 {
563 foreach my $plugin (@{$args{plugins}})
564 {
565 $msg .= " plugin=" . $plugin;
566 }
567 }
569 if ($args{identifier})
570 {
571 my $pre = $msg;
572 for my $identifier (@{$args{identifier}})
573 {
574 my $ident_str;
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 }
583 $ident_str = _create_identifier ($identifier) or return;
584 $ident_str = ' identifier=' . _escape_argument ($ident_str);
586 if (length($msg)+length($ident_str) >= 1023) { #1024 - 1 byte for \n
587 $self->_send_message($msg) or return;
588 $msg = $pre;
589 }
591 $msg .= $ident_str;
592 }
593 }
595 return $self->_send_message($msg);
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 :