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 our $Debug = 0;
  61
  62 return (1);
  63
  64 sub _debug
  65 {
  66         if (!$Debug)
  67         {
  68                 return;
  69         }
  70         print @_;
  71 }
  72
  73 sub _create_socket
  74 {
  75         my $path = shift;
  76         my $sock = IO::Socket::UNIX->new (Type => SOCK_STREAM, Peer => $path);
  77         if (!$sock)
  78         {
  79                 cluck ("Cannot open UNIX-socket $path: $!");
  80                 return;
  81         }
  82         return ($sock);
  83 } # _create_socket
  84
  85 =head1 VALUE IDENTIFIERS
  86
  87 The values in the collectd are identified using an five-tuple (host, plugin,
  88 plugin-instance, type, type-instance) where only plugin-instance and
  89 type-instance may be NULL (or undefined). Many functions expect an
  90 I<%identifier> hash that has at least the members B<host>, B<plugin>, and
  91 B<type>, possibly completed by B<plugin_instance> and B<type_instance>.
  92
  93 Usually you can pass this hash as follows:
  94
  95   $obj->method (host => $host, plugin => $plugin, type => $type, %other_args);
  96
  97 =cut
  98
  99 sub _create_identifier
 100 {
 101         my $args = shift;
 102         my $host;
 103         my $plugin;
 104         my $type;
 105
 106         if (!$args->{'host'} || !$args->{'plugin'} || !$args->{'type'})
 107         {
 108                 cluck ("Need `host', `plugin' and `type'");
 109                 return;
 110         }
 111
 112         $host = $args->{'host'};
 113         $plugin = $args->{'plugin'};
 114         $plugin .= '-' . $args->{'plugin_instance'} if (defined ($args->{'plugin_instance'}));
 115         $type = $args->{'type'};
 116         $type .= '-' . $args->{'type_instance'} if (defined ($args->{'type_instance'}));
 117
 118         return ("$host/$plugin/$type");
 119 } # _create_identifier
 120
 121 sub _parse_identifier
 122 {
 123         my $string = shift;
 124         my $host;
 125         my $plugin;
 126         my $plugin_instance;
 127         my $type;
 128         my $type_instance;
 129         my $ident;
 130
 131         ($host, $plugin, $type) = split ('/', $string);
 132
 133         ($plugin, $plugin_instance) = split ('-', $plugin, 2);
 134         ($type, $type_instance) = split ('-', $type, 2);
 135
 136         $ident =
 137         {
 138                 host => $host,
 139                 plugin => $plugin,
 140                 type => $type
 141         };
 142         $ident->{'plugin_instance'} = $plugin_instance if (defined ($plugin_instance));
 143         $ident->{'type_instance'} = $type_instance if (defined ($type_instance));
 144
 145         return ($ident);
 146 } # _parse_identifier
 147
 148 sub _escape_argument
 149 {
 150         my $string = shift;
 151
 152         if ($string =~ m/^\w+$/)
 153         {
 154                 return ("$string");
 155         }
 156
 157         $string =~ s#\\#\\\\#g;
 158         $string =~ s#"#\\"#g;
 159         $string = "\"$string\"";
 160
 161         return ($string);
 162 }
 163
 164 =head1 PUBLIC METHODS
 165
 166 =over 4
 167
 168 =item I<$obj> = Collectd::Unixsock->B<new> ([I<$path>]);
 169
 170 Creates a new connection to the daemon. The optional I<$path> argument gives
 171 the path to the UNIX socket of the C<unixsock plugin> and defaults to
 172 F</var/run/collectd-unixsock>. Returns the newly created object on success and
 173 false on error.
 174
 175 =cut
 176
 177 sub new
 178 {
 179         my $pkg = shift;
 180         my $path = @_ ? shift : '/var/run/collectd-unixsock';
 181         my $sock = _create_socket ($path) or return;
 182         my $obj = bless (
 183                 {
 184                         path => $path,
 185                         sock => $sock,
 186                         error => 'No error'
 187                 }, $pkg);
 188         return ($obj);
 189 } # new
 190
 191 =item I<$res> = I<$obj>-E<gt>B<getval> (I<%identifier>);
 192
 193 Requests a value-list from the daemon. On success a hash-ref is returned with
 194 the name of each data-source as the key and the according value as, well, the
 195 value. On error false is returned.
 196
 197 =cut
 198
 199 sub getval
 200 {
 201         my $obj = shift;
 202         my %args = @_;
 203
 204         my $status;
 205         my $fh = $obj->{'sock'} or confess ('object has no filehandle');
 206         my $msg;
 207         my $identifier;
 208
 209         my $ret = {};
 210
 211         $identifier = _create_identifier (\%args) or return;
 212
 213         $msg = 'GETVAL ' . _escape_argument ($identifier) . "\n";
 214         _debug "-> $msg";
 215         print $fh $msg;
 216
 217         $msg = <$fh>;
 218         chomp ($msg);
 219         _debug "<- $msg\n";
 220
 221         ($status, $msg) = split (' ', $msg, 2);
 222         if ($status <= 0)
 223         {
 224                 $obj->{'error'} = $msg;
 225                 return;
 226         }
 227
 228         for (my $i = 0; $i < $status; $i++)
 229         {
 230                 my $entry = <$fh>;
 231                 chomp ($entry);
 232                 _debug "<- $entry\n";
 233
 234                 if ($entry =~ m/^(\w+)=NaN$/)
 235                 {
 236                         $ret->{$1} = undef;
 237                 }
 238                 elsif ($entry =~ m/^(\w+)=($RE{num}{real})$/)
 239                 {
 240                         $ret->{$1} = 0.0 + $2;
 241                 }
 242         }
 243
 244         return ($ret);
 245 } # getval
 246
 247 =item I<$obj>-E<gt>B<putval> (I<%identifier>, B<time> =E<gt> I<$time>, B<values> =E<gt> [...]);
 248
 249 Submits a value-list to the daemon. If the B<time> argument is omitted
 250 C<time()> is used. The required argument B<values> is a reference to an array
 251 of values that is to be submitted. The number of values must match the number
 252 of values expected for the given B<type> (see L<VALUE IDENTIFIERS>), though
 253 this is checked by the daemon, not the Perl module. Also, gauge data-sources
 254 (e.E<nbsp>g. system-load) may be C<undef>. Returns true upon success and false
 255 otherwise.
 256
 257 =cut
 258
 259 sub putval
 260 {
 261         my $obj = shift;
 262         my %args = @_;
 263
 264         my $status;
 265         my $fh = $obj->{'sock'} or confess;
 266         my $msg;
 267         my $identifier;
 268         my $values;
 269         my $interval = "";
 270
 271         if (defined $args{'interval'})
 272         {
 273                 $interval = ' interval='
 274                 . _escape_argument ($args{'interval'});
 275         }
 276
 277         $identifier = _create_identifier (\%args) or return;
 278         if (!$args{'values'})
 279         {
 280                 cluck ("Need argument `values'");
 281                 return;
 282         }
 283
 284         if (!ref ($args{'values'}))
 285         {
 286                 $values = $args{'values'};
 287         }
 288         else
 289         {
 290                 my $time;
 291
 292                 if ("ARRAY" ne ref ($args{'values'}))
 293                 {
 294                         cluck ("Invalid `values' argument (expected an array ref)");
 295                         return;
 296                 }
 297
 298                 if (! scalar @{$args{'values'}})
 299                 {
 300                         cluck ("Empty `values' array");
 301                         return;
 302                 }
 303
 304                 $time = $args{'time'} ? $args{'time'} : time ();
 305                 $values = join (':', $time, map { defined ($_) ? $_ : 'U' } (@{$args{'values'}}));
 306         }
 307
 308         $msg = 'PUTVAL '
 309         . _escape_argument ($identifier)
 310         . $interval
 311         . ' ' . _escape_argument ($values) . "\n";
 312         _debug "-> $msg";
 313         print $fh $msg;
 314
 315         $msg = <$fh>;
 316         chomp ($msg);
 317         _debug "<- $msg\n";
 318
 319         ($status, $msg) = split (' ', $msg, 2);
 320         return (1) if ($status == 0);
 321
 322         $obj->{'error'} = $msg;
 323         return;
 324 } # putval
 325
 326 =item I<$res> = I<$obj>-E<gt>B<listval> ()
 327
 328 Queries a list of values from the daemon. The list is returned as an array of
 329 hash references, where each hash reference is a valid identifier. The C<time>
 330 member of each hash holds the epoch value of the last update of that value.
 331
 332 =cut
 333
 334 sub listval
 335 {
 336         my $obj = shift;
 337         my $msg;
 338         my @ret = ();
 339         my $status;
 340         my $fh = $obj->{'sock'} or confess;
 341
 342         _debug "LISTVAL\n";
 343         print $fh "LISTVAL\n";
 344
 345         $msg = <$fh>;
 346         chomp ($msg);
 347         _debug "<- $msg\n";
 348         ($status, $msg) = split (' ', $msg, 2);
 349         if ($status < 0)
 350         {
 351                 $obj->{'error'} = $msg;
 352                 return;
 353         }
 354
 355         for (my $i = 0; $i < $status; $i++)
 356         {
 357                 my $time;
 358                 my $ident;
 359
 360                 $msg = <$fh>;
 361                 chomp ($msg);
 362                 _debug "<- $msg\n";
 363
 364                 ($time, $ident) = split (' ', $msg, 2);
 365
 366                 $ident = _parse_identifier ($ident);
 367                 $ident->{'time'} = int ($time);
 368
 369                 push (@ret, $ident);
 370         } # for (i = 0 .. $status)
 371
 372         return (@ret);
 373 } # listval
 374
 375 =item I<$res> = I<$obj>-E<gt>B<putnotif> (B<severity> =E<gt> I<$severity>, B<message> =E<gt> I<$message>, ...);
 376
 377 Submits a notification to the daemon.
 378
 379 Valid options are:
 380
 381 =over 4
 382
 383 =item B<severity>
 384
 385 Sets the severity of the notification. The value must be one of the following
 386 strings: C<failure>, C<warning>, or C<okay>. Case does not matter. This option
 387 is mandatory.
 388
 389 =item B<message>
 390
 391 Sets the message of the notification. This option is mandatory.
 392
 393 =item B<time>
 394
 395 Sets the time. If omitted, C<time()> is used.
 396
 397 =item I<Value identifier>
 398
 399 All the other fields of the value identifiers, B<host>, B<plugin>,
 400 B<plugin_instance>, B<type>, and B<type_instance>, are optional. When given,
 401 the notification is associated with the performance data of that identifier.
 402 For more details, please see L<collectd-unixsock(5)>.
 403
 404 =back
 405
 406 =cut
 407
 408 sub putnotif
 409 {
 410         my $obj = shift;
 411         my %args = @_;
 412
 413         my $status;
 414         my $fh = $obj->{'sock'} or confess;
 415
 416         my $msg; # message sent to the socket
 417
 418         if (!$args{'message'})
 419         {
 420                 cluck ("Need argument `message'");
 421                 return;
 422         }
 423         if (!$args{'severity'})
 424         {
 425                 cluck ("Need argument `severity'");
 426                 return;
 427         }
 428         $args{'severity'} = lc ($args{'severity'});
 429         if (($args{'severity'} ne 'failure')
 430                 && ($args{'severity'} ne 'warning')
 431                 && ($args{'severity'} ne 'okay'))
 432         {
 433                 cluck ("Invalid `severity: " . $args{'severity'});
 434                 return;
 435         }
 436
 437         if (!$args{'time'})
 438         {
 439                 $args{'time'} = time ();
 440         }
 441
 442         $msg = 'PUTNOTIF '
 443         . join (' ', map { $_ . '=' . _escape_argument ($args{$_}) } (keys %args))
 444         . "\n";
 445
 446         _debug "-> $msg";
 447         print $fh $msg;
 448
 449         $msg = <$fh>;
 450         chomp ($msg);
 451         _debug "<- $msg\n";
 452
 453         ($status, $msg) = split (' ', $msg, 2);
 454         return (1) if ($status == 0);
 455
 456         $obj->{'error'} = $msg;
 457         return;
 458 } # putnotif
 459
 460 =item I<$obj>-E<gt>B<flush> (B<timeout> =E<gt> I<$timeout>, B<plugins> =E<gt> [...], B<identifier>  =E<gt> [...]);
 461
 462 Flush cached data.
 463
 464 Valid options are:
 465
 466 =over 4
 467
 468 =item B<timeout>
 469
 470 If this option is specified, only data older than I<$timeout> seconds is
 471 flushed.
 472
 473 =item B<plugins>
 474
 475 If this option is specified, only the selected plugins will be flushed. The
 476 argument is a reference to an array of strings.
 477
 478 =item B<identifier>
 479
 480 If this option is specified, only the given identifier(s) will be flushed. The
 481 argument is a reference to an array of identifiers. Identifiers, in this case,
 482 are hash references and have the members as outlined in L<VALUE IDENTIFIERS>.
 483
 484 =back
 485
 486 =cut
 487
 488 sub flush
 489 {
 490         my $obj  = shift;
 491         my %args = @_;
 492
 493         my $fh = $obj->{'sock'} or confess;
 494
 495         my $status = 0;
 496         my $msg    = "FLUSH";
 497
 498         if (defined ($args{'timeout'}))
 499         {
 500                 $msg .= " timeout=" . $args{'timeout'};
 501         }
 502
 503         if ($args{'plugins'})
 504         {
 505                 foreach my $plugin (@{$args{'plugins'}})
 506                 {
 507                         $msg .= " plugin=" . $plugin;
 508                 }
 509         }
 510
 511         if ($args{'identifier'})
 512         {
 513                 for (@{$args{'identifier'}})
 514                 {
 515                         my $identifier = $_;
 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 reference "
 522                                         . "of hash references.");
 523                                 return;
 524                         }
 525
 526                         $ident_str = _create_identifier ($identifier);
 527                         if (!$ident_str)
 528                         {
 529                                 return;
 530                         }
 531
 532                         $msg .= ' identifier=' . _escape_argument ($ident_str);
 533                 }
 534         }
 535
 536         $msg .= "\n";
 537
 538         _debug "-> $msg";
 539         print $fh $msg;
 540
 541         $msg = <$fh>;
 542         chomp ($msg);
 543         _debug "<- $msg\n";
 544
 545         ($status, $msg) = split (' ', $msg, 2);
 546         return (1) if ($status == 0);
 547
 548         $obj->{'error'} = $msg;
 549         return;
 550 }
 551
 552 sub error
 553 {
 554         my $obj = shift;
 555         if ($obj->{'error'})
 556         {
 557                 return ($obj->{'error'});
 558         }
 559         return;
 560 }
 561
 562 =item I<$obj>-E<gt>destroy ();
 563
 564 Closes the socket before the object is destroyed. This function is also
 565 automatically called then the object goes out of scope.
 566
 567 =back
 568
 569 =cut
 570
 571 sub destroy
 572 {
 573         my $obj = shift;
 574         if ($obj->{'sock'})
 575         {
 576                 close ($obj->{'sock'});
 577                 delete ($obj->{'sock'});
 578         }
 579 }
 580
 581 sub DESTROY
 582 {
 583         my $obj = shift;
 584         $obj->destroy ();
 585 }
 586
 587 =head1 SEE ALSO
 588
 589 L<collectd(1)>,
 590 L<collectd.conf(5)>,
 591 L<collectd-unixsock(5)>
 592
 593 =head1 AUTHOR
 594
 595 Florian octo Forster E<lt>octo@verplant.orgE<gt>
 596
 597 =cut