bindings/perl/Collectd/Unixsock.pm

   1 #
   2 # collectd - Collectd::Unixsock
   3 # Copyright (C) 2007,2008  Florian octo Forster
   4 #
   5 # This program is free software; you can redistribute it and/or modify it
   6 # under the terms of the GNU General Public License as published by the
   7 # Free Software Foundation; only version 2 of the License is applicable.
   8 #
   9 # This program is distributed in the hope that it will be useful, but
  10 # WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 # General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License along
  15 # with this program; if not, write to the Free Software Foundation, Inc.,
  16 # 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  17 #
  18 # Author:
  19 #   Florian octo Forster <octo at verplant.org>
  20 #
  21
  22 package Collectd::Unixsock;
  23
  24 =head1 NAME
  25
  26 Collectd::Unixsock - Abstraction layer for accessing the functionality by
  27 collectd's unixsock plugin.
  28
  29 =head1 SYNOPSIS
  30
  31   use Collectd::Unixsock ();
  32
  33   my $sock = Collectd::Unixsock->new ($path);
  34
  35   my $value = $sock->getval (%identifier);
  36   $sock->putval (%identifier,
  37                  time => time (),
  38                  values => [123, 234, 345]);
  39
  40   $sock->destroy ();
  41
  42 =head1 DESCRIPTION
  43
  44 collectd's unixsock plugin allows external programs to access the values it has
  45 collected or received and to submit own values. This Perl-module is simply a
  46 little abstraction layer over this interface to make it even easier for
  47 programmers to interact with the daemon.
  48
  49 =cut
  50
  51 use strict;
  52 use warnings;
  53
  54 #use constant { NOTIF_FAILURE => 1, NOTIF_WARNING => 2, NOTIF_OKAY => 4 };
  55
  56 use Carp (qw(cluck confess));
  57 use IO::Socket::UNIX;
  58 use Regexp::Common (qw(number));
  59
  60 return (1);
  61
  62 sub _create_socket
  63 {
  64         my $path = shift;
  65         my $sock = IO::Socket::UNIX->new (Type => SOCK_STREAM, Peer => $path);
  66         if (!$sock)
  67         {
  68                 cluck ("Cannot open UNIX-socket $path: $!");
  69                 return;
  70         }
  71         return ($sock);
  72 } # _create_socket
  73
  74 =head1 VALUE IDENTIFIERS
  75
  76 The values in the collectd are identified using an five-tuple (host, plugin,
  77 plugin-instance, type, type-instance) where only plugin-instance and
  78 type-instance may be NULL (or undefined). Many functions expect an
  79 I<%identifier> hash that has at least the members B<host>, B<plugin>, and
  80 B<type>, possibly completed by B<plugin_instance> and B<type_instance>.
  81
  82 Usually you can pass this hash as follows:
  83
  84   $obj->method (host => $host, plugin => $plugin, type => $type, %other_args);
  85
  86 =cut
  87
  88 sub _create_identifier
  89 {
  90         my $args = shift;
  91         my $host;
  92         my $plugin;
  93         my $type;
  94
  95         if (!$args->{'host'} || !$args->{'plugin'} || !$args->{'type'})
  96         {
  97                 cluck ("Need `host', `plugin' and `type'");
  98                 return;
  99         }
 100
 101         $host = $args->{'host'};
 102         $plugin = $args->{'plugin'};
 103         $plugin .= '-' . $args->{'plugin_instance'} if (defined ($args->{'plugin_instance'}));
 104         $type = $args->{'type'};
 105         $type .= '-' . $args->{'type_instance'} if (defined ($args->{'type_instance'}));
 106
 107         return ("$host/$plugin/$type");
 108 } # _create_identifier
 109
 110 sub _parse_identifier
 111 {
 112         my $string = shift;
 113         my $host;
 114         my $plugin;
 115         my $plugin_instance;
 116         my $type;
 117         my $type_instance;
 118         my $ident;
 119
 120         ($host, $plugin, $type) = split ('/', $string);
 121
 122         ($plugin, $plugin_instance) = split ('-', $plugin, 2);
 123         ($type, $type_instance) = split ('-', $type, 2);
 124
 125         $ident =
 126         {
 127                 host => $host,
 128                 plugin => $plugin,
 129                 type => $type
 130         };
 131         $ident->{'plugin_instance'} = $plugin_instance if (defined ($plugin_instance));
 132         $ident->{'type_instance'} = $type_instance if (defined ($type_instance));
 133
 134         return ($ident);
 135 } # _parse_identifier
 136
 137 =head1 PUBLIC METHODS
 138
 139 =over 4
 140
 141 =item I<$obj> = Collectd::Unixsock->B<new> ([I<$path>]);
 142
 143 Creates a new connection to the daemon. The optional I<$path> argument gives
 144 the path to the UNIX socket of the C<unixsock plugin> and defaults to
 145 F</var/run/collectd-unixsock>. Returns the newly created object on success and
 146 false on error.
 147
 148 =cut
 149
 150 sub new
 151 {
 152         my $pkg = shift;
 153         my $path = @_ ? shift : '/var/run/collectd-unixsock';
 154         my $sock = _create_socket ($path) or return;
 155         my $obj = bless (
 156                 {
 157                         path => $path,
 158                         sock => $sock,
 159                         error => 'No error'
 160                 }, $pkg);
 161         return ($obj);
 162 } # new
 163
 164 =item I<$res> = I<$obj>-E<gt>B<getval> (I<%identifier>);
 165
 166 Requests a value-list from the daemon. On success a hash-ref is returned with
 167 the name of each data-source as the key and the according value as, well, the
 168 value. On error false is returned.
 169
 170 =cut
 171
 172 sub getval
 173 {
 174         my $obj = shift;
 175         my %args = @_;
 176
 177         my $status;
 178         my $fh = $obj->{'sock'} or confess ('object has no filehandle');
 179         my $msg;
 180         my $identifier;
 181
 182         my $ret = {};
 183
 184         $identifier = _create_identifier (\%args) or return;
 185         if ($identifier =~ m/[\s"]/)
 186         {
 187                 $identifier =~ s#\\#\\\\#g;
 188                 $identifier =~ s#"#\\"#g;
 189                 $identifier = "\"$identifier\"";
 190         }
 191
 192         $msg = "GETVAL $identifier\n";
 193         #print "-> $msg";
 194         send ($fh, $msg, 0) or confess ("send: $!");
 195
 196         $msg = undef;
 197         recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
 198         #print "<- $msg";
 199
 200         ($status, $msg) = split (' ', $msg, 2);
 201         if ($status <= 0)
 202         {
 203                 $obj->{'error'} = $msg;
 204                 return;
 205         }
 206
 207         for (split (' ', $msg))
 208         {
 209                 my $entry = $_;
 210                 if ($entry =~ m/^(\w+)=NaN$/)
 211                 {
 212                         $ret->{$1} = undef;
 213                 }
 214                 elsif ($entry =~ m/^(\w+)=($RE{num}{real})$/)
 215                 {
 216                         $ret->{$1} = 0.0 + $2;
 217                 }
 218         }
 219
 220         return ($ret);
 221 } # getval
 222
 223 =item I<$obj>-E<gt>B<putval> (I<%identifier>, B<time> =E<gt> I<$time>, B<values> =E<gt> [...]);
 224
 225 Submits a value-list to the daemon. If the B<time> argument is omitted
 226 C<time()> is used. The required argument B<values> is a reference to an array
 227 of values that is to be submitted. The number of values must match the number
 228 of values expected for the given B<type> (see L<VALUE IDENTIFIERS>), though
 229 this is checked by the daemon, not the Perl module. Also, gauge data-sources
 230 (e.E<nbsp>g. system-load) may be C<undef>. Returns true upon success and false
 231 otherwise.
 232
 233 =cut
 234
 235 sub putval
 236 {
 237         my $obj = shift;
 238         my %args = @_;
 239
 240         my $status;
 241         my $fh = $obj->{'sock'} or confess;
 242         my $msg;
 243         my $identifier;
 244         my $values;
 245         my $interval = "";
 246
 247         if (defined $args{'interval'})
 248         {
 249                 $interval = ' interval=' . $args{'interval'};
 250         }
 251
 252         $identifier = _create_identifier (\%args) or return;
 253         if (!$args{'values'})
 254         {
 255                 cluck ("Need argument `values'");
 256                 return;
 257         }
 258
 259         if (!ref ($args{'values'}))
 260         {
 261                 $values = $args{'values'};
 262         }
 263         else
 264         {
 265                 my $time = $args{'time'} ? $args{'time'} : time ();
 266                 $values = join (':', $time, map { defined ($_) ? $_ : 'U' } (@{$args{'values'}}));
 267         }
 268
 269         $msg = "PUTVAL $identifier$interval $values\n";
 270         #print "-> $msg";
 271         send ($fh, $msg, 0) or confess ("send: $!");
 272         $msg = undef;
 273         recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
 274         #print "<- $msg";
 275
 276         ($status, $msg) = split (' ', $msg, 2);
 277         return (1) if ($status == 0);
 278
 279         $obj->{'error'} = $msg;
 280         return;
 281 } # putval
 282
 283 =item I<$res> = I<$obj>-E<gt>B<listval> ()
 284
 285 Queries a list of values from the daemon. The list is returned as an array of
 286 hash references, where each hash reference is a valid identifier. The C<time>
 287 member of each hash holds the epoch value of the last update of that value.
 288
 289 =cut
 290
 291 sub listval
 292 {
 293         my $obj = shift;
 294         my $msg;
 295         my @ret = ();
 296         my $status;
 297         my $fh = $obj->{'sock'} or confess;
 298
 299         $msg = "LISTVAL\n";
 300         send ($fh, $msg, 0) or confess ("send: $!");
 301
 302         $msg = <$fh>;
 303         ($status, $msg) = split (' ', $msg, 2);
 304         if ($status < 0)
 305         {
 306                 $obj->{'error'} = $msg;
 307                 return;
 308         }
 309
 310         for (my $i = 0; $i < $status; $i++)
 311         {
 312                 my $time;
 313                 my $ident;
 314
 315                 $msg = <$fh>;
 316                 chomp ($msg);
 317
 318                 ($time, $ident) = split (' ', $msg, 2);
 319
 320                 $ident = _parse_identifier ($ident);
 321                 $ident->{'time'} = int ($time);
 322
 323                 push (@ret, $ident);
 324         } # for (i = 0 .. $status)
 325
 326         return (@ret);
 327 } # listval
 328
 329 =item I<$res> = I<$obj>-E<gt>B<putnotif> (B<severity> =E<gt> I<$severity>, B<message> =E<gt> I<$message>, ...);
 330
 331 Submits a notification to the daemon.
 332
 333 Valid options are:
 334
 335 =over 4
 336
 337 =item B<severity>
 338
 339 Sets the severity of the notification. The value must be one of the following
 340 strings: C<failure>, C<warning>, or C<okay>. Case does not matter. This option
 341 is mandatory.
 342
 343 =item B<message>
 344
 345 Sets the message of the notification. This option is mandatory.
 346
 347 =item B<time>
 348
 349 Sets the time. If omitted, C<time()> is used.
 350
 351 =item I<Value identifier>
 352
 353 All the other fields of the value identifiers, B<host>, B<plugin>,
 354 B<plugin_instance>, B<type>, and B<type_instance>, are optional. When given,
 355 the notification is associated with the performance data of that identifier.
 356 For more details, please see L<collectd-unixsock(5)>.
 357
 358 =back
 359
 360 =cut
 361
 362 sub putnotif
 363 {
 364         my $obj = shift;
 365         my %args = @_;
 366
 367         my $status;
 368         my $fh = $obj->{'sock'} or confess;
 369
 370         my $msg; # message sent to the socket
 371         my $opt_msg; # message of the notification
 372
 373         if (!$args{'message'})
 374         {
 375                 cluck ("Need argument `message'");
 376                 return;
 377         }
 378         if (!$args{'severity'})
 379         {
 380                 cluck ("Need argument `severity'");
 381                 return;
 382         }
 383         $args{'severity'} = lc ($args{'severity'});
 384         if (($args{'severity'} ne 'failure')
 385                 && ($args{'severity'} ne 'warning')
 386                 && ($args{'severity'} ne 'okay'))
 387         {
 388                 cluck ("Invalid `severity: " . $args{'severity'});
 389                 return;
 390         }
 391
 392         if (!$args{'time'})
 393         {
 394                 $args{'time'} = time ();
 395         }
 396
 397         $opt_msg = $args{'message'};
 398         delete ($args{'message'});
 399
 400         $msg = 'PUTNOTIF '
 401         . join (' ', map { $_ . '=' . $args{$_} } (keys %args))
 402         . " message=$opt_msg\n";
 403
 404         send ($fh, $msg, 0) or confess ("send: $!");
 405         $msg = undef;
 406         recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
 407
 408         ($status, $msg) = split (' ', $msg, 2);
 409         return (1) if ($status == 0);
 410
 411         $obj->{'error'} = $msg;
 412         return;
 413 } # putnotif
 414
 415 =item I<$obj>-E<gt>B<flush> (B<timeout> =E<gt> I<$timeout>, B<plugins> =E<gt> [...], B<identifier>  =E<gt> [...]);
 416
 417 Flush cached data.
 418
 419 Valid options are:
 420
 421 =over 4
 422
 423 =item B<timeout>
 424
 425 If this option is specified, only data older than I<$timeout> seconds is
 426 flushed.
 427
 428 =item B<plugins>
 429
 430 If this option is specified, only the selected plugins will be flushed. The
 431 argument is a reference to an array of strings.
 432
 433 =item B<identifier>
 434
 435 If this option is specified, only the given identifier(s) will be flushed. The
 436 argument is a reference to an array of identifiers. Identifiers, in this case,
 437 are hash references and have the members as outlined in L<VALUE IDENTIFIERS>.
 438
 439 =back
 440
 441 =cut
 442
 443 sub flush
 444 {
 445         my $obj  = shift;
 446         my %args = @_;
 447
 448         my $fh = $obj->{'sock'} or confess;
 449
 450         my $status = 0;
 451         my $msg    = "FLUSH";
 452
 453         if (defined ($args{'timeout'}))
 454         {
 455                 $msg .= " timeout=" . $args{'timeout'};
 456         }
 457
 458         if ($args{'plugins'})
 459         {
 460                 foreach my $plugin (@{$args{'plugins'}})
 461                 {
 462                         $msg .= " plugin=" . $plugin;
 463                 }
 464         }
 465
 466         if ($args{'identifier'})
 467         {
 468                 for (@{$args{'identifier'}})
 469                 {
 470                         my $identifier = $_;
 471                         my $ident_str;
 472
 473                         if (ref ($identifier) ne 'HASH')
 474                         {
 475                                 cluck ("The argument of the `identifier' "
 476                                         . "option must be an array reference "
 477                                         . "of hash references.");
 478                                 return;
 479                         }
 480
 481                         $ident_str = _create_identifier ($identifier);
 482                         if (!$ident_str)
 483                         {
 484                                 return;
 485                         }
 486                         if ($ident_str =~ m/[\s"]/)
 487                         {
 488                                 $ident_str =~ s#\\#\\\\#g;
 489                                 $ident_str =~ s#"#\\"#g;
 490                                 $ident_str = "\"$ident_str\"";
 491                         }
 492
 493                         $msg .= " identifier=$ident_str";
 494                 }
 495         }
 496
 497         $msg .= "\n";
 498
 499         send ($fh, $msg, 0) or confess ("send: $!");
 500         $msg = undef;
 501         recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
 502
 503         ($status, $msg) = split (' ', $msg, 2);
 504         return (1) if ($status == 0);
 505
 506         $obj->{'error'} = $msg;
 507         return;
 508 }
 509
 510 =item I<$obj>-E<gt>destroy ();
 511
 512 Closes the socket before the object is destroyed. This function is also
 513 automatically called then the object goes out of scope.
 514
 515 =back
 516
 517 =cut
 518
 519 sub destroy
 520 {
 521         my $obj = shift;
 522         if ($obj->{'sock'})
 523         {
 524                 close ($obj->{'sock'});
 525                 delete ($obj->{'sock'});
 526         }
 527 }
 528
 529 sub DESTROY
 530 {
 531         my $obj = shift;
 532         $obj->destroy ();
 533 }
 534
 535 =head1 SEE ALSO
 536
 537 L<collectd(1)>,
 538 L<collectd.conf(5)>,
 539 L<collectd-unixsock(5)>
 540
 541 =head1 AUTHOR
 542
 543 Florian octo Forster E<lt>octo@verplant.orgE<gt>
 544
 545 =cut