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 :