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> ()
 347
 348 Queries a list of values from the daemon. The list is returned as an array of
 349 hash references, where each hash reference is a valid identifier. The C<time>
 350 member of each hash holds the epoch value of the last update of that value.
 351
 352 =cut
 353
 354 sub listval
 355 {
 356         my $self = shift;
 357         my $nresults;
 358         my @ret;
 359         my $fh = $self->{sock} or confess;
 360
 361     my $msg = $self->_socket_command('LISTVAL') or return;
 362         ($nresults, $msg) = split / /, $msg, 2;
 363
 364     # This could use _socket_chat() but doesn't for speed reasons
 365         if ($nresults < 0)
 366         {
 367                 $self->{error} = $msg;
 368                 return;
 369         }
 370
 371         for (1 .. $nresults)
 372         {
 373                 $msg = <$fh>;
 374                 chomp $msg;
 375                 _debug "<- $msg\n";
 376
 377                 my ($time, $ident) = split / /, $msg, 2;
 378
 379                 $ident = _parse_identifier ($ident);
 380                 $ident->{time} = int $time;
 381
 382                 push (@ret, $ident);
 383         } # for (i = 0 .. $status)
 384
 385         return @ret;
 386 } # listval
 387
 388 =item I<$res> = I<$self>-E<gt>B<putnotif> (B<severity> =E<gt> I<$severity>, B<message> =E<gt> I<$message>, ...);
 389
 390 Submits a notification to the daemon.
 391
 392 Valid options are:
 393
 394 =over 4
 395
 396 =item B<severity>
 397
 398 Sets the severity of the notification. The value must be one of the following
 399 strings: C<failure>, C<warning>, or C<okay>. Case does not matter. This option
 400 is mandatory.
 401
 402 =item B<message>
 403
 404 Sets the message of the notification. This option is mandatory.
 405
 406 =item B<time>
 407
 408 Sets the time. If omitted, C<time()> is used.
 409
 410 =item I<Value identifier>
 411
 412 All the other fields of the value identifiers, B<host>, B<plugin>,
 413 B<plugin_instance>, B<type>, and B<type_instance>, are optional. When given,
 414 the notification is associated with the performance data of that identifier.
 415 For more details, please see L<collectd-unixsock(5)>.
 416
 417 =back
 418
 419 =cut
 420
 421 sub putnotif
 422 {
 423         my $self = shift;
 424         my %args = @_;
 425
 426         my $status;
 427         my $fh = $self->{sock} or confess;
 428
 429         my $msg; # message sent to the socket
 430
 431     for my $arg (qw( message severity ))
 432     {
 433         cluck ("Need argument `$arg'"), return unless $args{$arg};
 434     }
 435         $args{severity} = lc $args{severity};
 436         if (($args{severity} ne 'failure')
 437                 && ($args{severity} ne 'warning')
 438                 && ($args{severity} ne 'okay'))
 439         {
 440                 cluck ("Invalid `severity: " . $args{severity});
 441                 return;
 442         }
 443
 444         $args{time} ||= time;
 445
 446         $msg = 'PUTNOTIF '
 447         . join (' ', map { $_ . '=' . _escape_argument ($args{$_}) } keys %args)
 448         . "\n";
 449
 450         _debug "-> $msg";
 451         $fh->print($msg);
 452
 453         $msg = <$fh>;
 454         chomp $msg;
 455         _debug "<- $msg\n";
 456
 457         ($status, $msg) = split / /, $msg, 2;
 458         return 1 if $status == 0;
 459
 460         $self->{error} = $msg;
 461         return;
 462 } # putnotif
 463
 464 =item I<$self>-E<gt>B<flush> (B<timeout> =E<gt> I<$timeout>, B<plugins> =E<gt> [...], B<identifier>  =E<gt> [...]);
 465
 466 Flush cached data.
 467
 468 Valid options are:
 469
 470 =over 4
 471
 472 =item B<timeout>
 473
 474 If this option is specified, only data older than I<$timeout> seconds is
 475 flushed.
 476
 477 =item B<plugins>
 478
 479 If this option is specified, only the selected plugins will be flushed. The
 480 argument is a reference to an array of strings.
 481
 482 =item B<identifier>
 483
 484 If this option is specified, only the given identifier(s) will be flushed. The
 485 argument is a reference to an array of identifiers. Identifiers, in this case,
 486 are hash references and have the members as outlined in L<VALUE IDENTIFIERS>.
 487
 488 =back
 489
 490 =cut
 491
 492 sub flush
 493 {
 494         my $self  = shift;
 495         my %args = @_;
 496
 497         my $fh = $self->{sock} or confess;
 498
 499         my $status = 0;
 500         my $msg    = "FLUSH";
 501
 502     $msg .= " timeout=$args{timeout}" if defined $args{timeout};
 503
 504         if ($args{plugins})
 505         {
 506                 foreach my $plugin (@{$args{plugins}})
 507                 {
 508                         $msg .= " plugin=" . $plugin;
 509                 }
 510         }
 511
 512         if ($args{identifier})
 513         {
 514                 for my $identifier (@{$args{identifier}})
 515                 {
 516                         my $ident_str;
 517
 518                         if (ref ($identifier) ne 'HASH')
 519                         {
 520                                 cluck ("The argument of the `identifier' "
 521                                         . "option must be an array of hashrefs.");
 522                                 return;
 523                         }
 524
 525                         $ident_str = _create_identifier ($identifier) or return;
 526                         $msg .= ' identifier=' . _escape_argument ($ident_str);
 527                 }
 528         }
 529
 530         $msg .= "\n";
 531
 532         _debug "-> $msg";
 533         $fh->print($msg);
 534
 535         $msg = <$fh>;
 536         chomp ($msg);
 537         _debug "<- $msg\n";
 538
 539         ($status, $msg) = split / /, $msg, 2;
 540         return 1 if $status == 0;
 541
 542         $self->{error} = $msg;
 543         return;
 544 }
 545
 546 sub error
 547 {
 548         return shift->{error};
 549 }
 550
 551 =item I<$self>-E<gt>destroy ();
 552
 553 Closes the socket before the object is destroyed. This function is also
 554 automatically called then the object goes out of scope.
 555
 556 =back
 557
 558 =cut
 559
 560 sub destroy
 561 {
 562         my $self = shift;
 563         if ($self->{sock})
 564         {
 565                 close $self->{sock};
 566                 delete $self->{sock};
 567         }
 568 }
 569
 570 sub DESTROY
 571 {
 572         my $self = shift;
 573         $self->destroy ();
 574 }
 575
 576 =head1 SEE ALSO
 577
 578 L<collectd(1)>,
 579 L<collectd.conf(5)>,
 580 L<collectd-unixsock(5)>
 581
 582 =head1 AUTHOR
 583
 584 Florian octo Forster E<lt>octo@collectd.orgE<gt>
 585
 586 =cut
 587 1;
 588 # vim: set fdm=marker :