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                     /^\s*([^:]+):\s*(.*)/ and do {
 266                             $1 =~ s/\s*$//;
 267                             $ret->{$1} = $2;
 268                     };
 269         }, $ret
 270     );
 271         return $ret;
 272 } # }}} sub getthreshold
 273
 274 =item I<$self>-E<gt>B<putval> (I<%identifier>, B<time> =E<gt> I<$time>, B<values> =E<gt> [...]);
 275
 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.
 283
 284 =cut
 285
 286 sub putval
 287 {
 288         my $self = shift;
 289         my %args = @_;
 290
 291         my ($status, $msg, $identifier, $values);
 292         my $fh = $self->{sock} or confess;
 293
 294         my $interval = defined $args{interval} ?
 295     ' interval=' . _escape_argument ($args{interval}) : '';
 296
 297         $identifier = _create_identifier (\%args) or return;
 298         if (!$args{values})
 299         {
 300                 cluck ("Need argument `values'");
 301                 return;
 302         }
 303
 304         if (ref ($args{values}))
 305         {
 306                 my $time;
 307
 308                 if ("ARRAY" ne ref ($args{values}))
 309                 {
 310                         cluck ("Invalid `values' argument (expected an array ref)");
 311                         return;
 312                 }
 313
 314                 if (! scalar @{$args{values}})
 315                 {
 316                         cluck ("Empty `values' array");
 317                         return;
 318                 }
 319
 320                 $time = $args{time} || time;
 321                 $values = join (':', $time, map { defined $_ ? $_ : 'U' } @{$args{values}});
 322         }
 323         else
 324         {
 325                 $values = $args{values};
 326         }
 327
 328         $msg = 'PUTVAL '
 329         . _escape_argument ($identifier)
 330         . $interval
 331         . ' ' . _escape_argument ($values) . "\n";
 332         _debug "-> $msg";
 333         $fh->print($msg);
 334
 335         $msg = <$fh>;
 336         chomp $msg;
 337         _debug "<- $msg\n";
 338
 339         ($status, $msg) = split / /, $msg, 2;
 340         return 1 if $status == 0;
 341
 342         $self->{error} = $msg;
 343         return;
 344 } # putval
 345
 346 =item I<$res> = I<$self>-E<gt>B<listval_filter> ( C<%identifier> )
 347
 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>.
 352
 353 =cut
 354
 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;
 362
 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$/;
 370
 371     my $msg = $self->_socket_command('LISTVAL') or return;
 372         ($nresults, $msg) = split / /, $msg, 2;
 373
 374     # This could use _socket_chat() but doesn't for speed reasons
 375         if ($nresults < 0)
 376         {
 377                 $self->{error} = $msg;
 378                 return;
 379         }
 380
 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;
 388
 389                 $ident = _parse_identifier ($ident);
 390                 $ident->{time} = int $time;
 391
 392                 push (@ret, $ident);
 393         } # for (i = 0 .. $status)
 394
 395         return @ret;
 396 } # listval
 397
 398 =item I<$res> = I<$self>-E<gt>B<listval> ()
 399
 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.
 403
 404 =cut
 405
 406 sub listval
 407 {
 408         my $self = shift;
 409         my $nresults;
 410         my @ret;
 411         my $fh = $self->{sock} or confess;
 412
 413     my $msg = $self->_socket_command('LISTVAL') or return;
 414         ($nresults, $msg) = split / /, $msg, 2;
 415
 416     # This could use _socket_chat() but doesn't for speed reasons
 417         if ($nresults < 0)
 418         {
 419                 $self->{error} = $msg;
 420                 return;
 421         }
 422
 423         for (1 .. $nresults)
 424         {
 425                 $msg = <$fh>;
 426                 chomp $msg;
 427                 _debug "<- $msg\n";
 428
 429                 my ($time, $ident) = split / /, $msg, 2;
 430
 431                 $ident = _parse_identifier ($ident);
 432                 $ident->{time} = int $time;
 433
 434                 push (@ret, $ident);
 435         } # for (i = 0 .. $status)
 436
 437         return @ret;
 438 } # listval
 439
 440 =item I<$res> = I<$self>-E<gt>B<putnotif> (B<severity> =E<gt> I<$severity>, B<message> =E<gt> I<$message>, ...);
 441
 442 Submits a notification to the daemon.
 443
 444 Valid options are:
 445
 446 =over 4
 447
 448 =item B<severity>
 449
 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.
 453
 454 =item B<message>
 455
 456 Sets the message of the notification. This option is mandatory.
 457
 458 =item B<time>
 459
 460 Sets the time. If omitted, C<time()> is used.
 461
 462 =item I<Value identifier>
 463
 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)>.
 468
 469 =back
 470
 471 =cut
 472
 473 sub putnotif
 474 {
 475         my $self = shift;
 476         my %args = @_;
 477
 478         my $status;
 479         my $fh = $self->{sock} or confess;
 480
 481         my $msg; # message sent to the socket
 482
 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         }
 495
 496         $args{time} ||= time;
 497
 498         $msg = 'PUTNOTIF '
 499         . join (' ', map { $_ . '=' . _escape_argument ($args{$_}) } keys %args)
 500         . "\n";
 501
 502         _debug "-> $msg";
 503         $fh->print($msg);
 504
 505         $msg = <$fh>;
 506         chomp $msg;
 507         _debug "<- $msg\n";
 508
 509         ($status, $msg) = split / /, $msg, 2;
 510         return 1 if $status == 0;
 511
 512         $self->{error} = $msg;
 513         return;
 514 } # putnotif
 515
 516 =item I<$self>-E<gt>B<flush> (B<timeout> =E<gt> I<$timeout>, B<plugins> =E<gt> [...], B<identifier>  =E<gt> [...]);
 517
 518 Flush cached data.
 519
 520 Valid options are:
 521
 522 =over 4
 523
 524 =item B<timeout>
 525
 526 If this option is specified, only data older than I<$timeout> seconds is
 527 flushed.
 528
 529 =item B<plugins>
 530
 531 If this option is specified, only the selected plugins will be flushed. The
 532 argument is a reference to an array of strings.
 533
 534 =item B<identifier>
 535
 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>.
 539
 540 =back
 541
 542 =cut
 543
 544 sub flush
 545 {
 546         my $self  = shift;
 547         my %args = @_;
 548
 549         my $fh = $self->{sock} or confess;
 550
 551         my $status = 0;
 552         my $msg    = "FLUSH";
 553
 554     $msg .= " timeout=$args{timeout}" if defined $args{timeout};
 555
 556         if ($args{plugins})
 557         {
 558                 foreach my $plugin (@{$args{plugins}})
 559                 {
 560                         $msg .= " plugin=" . $plugin;
 561                 }
 562         }
 563
 564         if ($args{identifier})
 565         {
 566                 for my $identifier (@{$args{identifier}})
 567                 {
 568                         my $ident_str;
 569
 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                         }
 576
 577                         $ident_str = _create_identifier ($identifier) or return;
 578                         $msg .= ' identifier=' . _escape_argument ($ident_str);
 579                 }
 580         }
 581
 582         $msg .= "\n";
 583
 584         _debug "-> $msg";
 585         $fh->print($msg);
 586
 587         $msg = <$fh>;
 588         chomp ($msg);
 589         _debug "<- $msg\n";
 590
 591         ($status, $msg) = split / /, $msg, 2;
 592         return 1 if $status == 0;
 593
 594         $self->{error} = $msg;
 595         return;
 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 :