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         local $_ = shift;
 141
 142         return $_ if /^\w+$/;
 143
 144         s#\\#\\\\#g;
 145         s#"#\\"#g;
 146         return "\"$_\"";
 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 :