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