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;
 179         my $msg;
 180         my $identifier;
 181
 182         my $ret = {};
 183
 184         $identifier = _create_identifier (\%args) or return;
 185
 186         $msg = "GETVAL $identifier\n";
 187         #print "-> $msg";
 188         send ($fh, $msg, 0) or confess ("send: $!");
 189
 190         $msg = undef;
 191         recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
 192         #print "<- $msg";
 193
 194         ($status, $msg) = split (' ', $msg, 2);
 195         if ($status <= 0)
 196         {
 197                 $obj->{'error'} = $msg;
 198                 return;
 199         }
 200
 201         for (split (' ', $msg))
 202         {
 203                 my $entry = $_;
 204                 if ($entry =~ m/^(\w+)=NaN$/)
 205                 {
 206                         $ret->{$1} = undef;
 207                 }
 208                 elsif ($entry =~ m/^(\w+)=($RE{num}{real})$/)
 209                 {
 210                         $ret->{$1} = 0.0 + $2;
 211                 }
 212         }
 213
 214         return ($ret);
 215 } # getval
 216
 217 =item I<$obj>-E<gt>B<putval> (I<%identifier>, B<time> =E<gt> I<$time>, B<values> =E<gt> [...]);
 218
 219 Submits a value-list to the daemon. If the B<time> argument is omitted
 220 C<time()> is used. The required argument B<values> is a reference to an array
 221 of values that is to be submitted. The number of values must match the number
 222 of values expected for the given B<type> (see L<VALUE IDENTIFIERS>), though
 223 this is checked by the daemon, not the Perl module. Also, gauge data-sources
 224 (e.E<nbsp>g. system-load) may be C<undef>. Returns true upon success and false
 225 otherwise.
 226
 227 =cut
 228
 229 sub putval
 230 {
 231         my $obj = shift;
 232         my %args = @_;
 233
 234         my $status;
 235         my $fh = $obj->{'sock'} or confess;
 236         my $msg;
 237         my $identifier;
 238         my $values;
 239         my $interval = "";
 240
 241         if (defined $args{'interval'})
 242         {
 243                 $interval = ' interval=' . $args{'interval'};
 244         }
 245
 246         $identifier = _create_identifier (\%args) or return;
 247         if (!$args{'values'})
 248         {
 249                 cluck ("Need argument `values'");
 250                 return;
 251         }
 252
 253         if (!ref ($args{'values'}))
 254         {
 255                 $values = $args{'values'};
 256         }
 257         else
 258         {
 259                 my $time = $args{'time'} ? $args{'time'} : time ();
 260                 $values = join (':', $time, map { defined ($_) ? $_ : 'U' } (@{$args{'values'}}));
 261         }
 262
 263         $msg = "PUTVAL $identifier$interval $values\n";
 264         #print "-> $msg";
 265         send ($fh, $msg, 0) or confess ("send: $!");
 266         $msg = undef;
 267         recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
 268         #print "<- $msg";
 269
 270         ($status, $msg) = split (' ', $msg, 2);
 271         return (1) if ($status == 0);
 272
 273         $obj->{'error'} = $msg;
 274         return;
 275 } # putval
 276
 277 =item I<$res> = I<$obj>-E<gt>B<listval> ()
 278
 279 Queries a list of values from the daemon. The list is returned as an array of
 280 hash references, where each hash reference is a valid identifier. The C<time>
 281 member of each hash holds the epoch value of the last update of that value.
 282
 283 =cut
 284
 285 sub listval
 286 {
 287         my $obj = shift;
 288         my $msg;
 289         my @ret = ();
 290         my $status;
 291         my $fh = $obj->{'sock'} or confess;
 292
 293         $msg = "LISTVAL\n";
 294         send ($fh, $msg, 0) or confess ("send: $!");
 295
 296         $msg = <$fh>;
 297         ($status, $msg) = split (' ', $msg, 2);
 298         if ($status < 0)
 299         {
 300                 $obj->{'error'} = $msg;
 301                 return;
 302         }
 303
 304         for (my $i = 0; $i < $status; $i++)
 305         {
 306                 my $time;
 307                 my $ident;
 308
 309                 $msg = <$fh>;
 310                 chomp ($msg);
 311
 312                 ($time, $ident) = split (' ', $msg, 2);
 313
 314                 $ident = _parse_identifier ($ident);
 315                 $ident->{'time'} = int ($time);
 316
 317                 push (@ret, $ident);
 318         } # for (i = 0 .. $status)
 319
 320         return (@ret);
 321 } # listval
 322
 323 =item I<$res> = I<$obj>-E<gt>B<putnotif> (B<severity> =E<gt> I<$severity>, B<message> =E<gt> I<$message>, ...);
 324
 325 Submits a notification to the daemon.
 326
 327 Valid options are:
 328
 329 =over 4
 330
 331 =item B<severity>
 332
 333 Sets the severity of the notification. The value must be one of the following
 334 strings: C<failure>, C<warning>, or C<okay>. Case does not matter. This option
 335 is mandatory.
 336
 337 =item B<message>
 338
 339 Sets the message of the notification. This option is mandatory.
 340
 341 =item B<time>
 342
 343 Sets the time. If omitted, C<time()> is used.
 344
 345 =item I<Value identifier>
 346
 347 All the other fields of the value identifiers, B<host>, B<plugin>,
 348 B<plugin_instance>, B<type>, and B<type_instance>, are optional. When given,
 349 the notification is associated with the performance data of that identifier.
 350 For more details, please see L<collectd-unixsock(5)>.
 351
 352 =back
 353
 354 =cut
 355
 356 sub putnotif
 357 {
 358         my $obj = shift;
 359         my %args = @_;
 360
 361         my $status;
 362         my $fh = $obj->{'sock'} or confess;
 363
 364         my $msg; # message sent to the socket
 365         my $opt_msg; # message of the notification
 366
 367         if (!$args{'message'})
 368         {
 369                 cluck ("Need argument `message'");
 370                 return;
 371         }
 372         if (!$args{'severity'})
 373         {
 374                 cluck ("Need argument `severity'");
 375                 return;
 376         }
 377         $args{'severity'} = lc ($args{'severity'});
 378         if (($args{'severity'} ne 'failure')
 379                 && ($args{'severity'} ne 'warning')
 380                 && ($args{'severity'} ne 'okay'))
 381         {
 382                 cluck ("Invalid `severity: " . $args{'severity'});
 383                 return;
 384         }
 385
 386         if (!$args{'time'})
 387         {
 388                 $args{'time'} = time ();
 389         }
 390
 391         $opt_msg = $args{'message'};
 392         delete ($args{'message'});
 393
 394         $msg = 'PUTNOTIF '
 395         . join (' ', map { $_ . '=' . $args{$_} } (keys %args))
 396         . " message=$opt_msg\n";
 397
 398         send ($fh, $msg, 0) or confess ("send: $!");
 399         $msg = undef;
 400         recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
 401
 402         ($status, $msg) = split (' ', $msg, 2);
 403         return (1) if ($status == 0);
 404
 405         $obj->{'error'} = $msg;
 406         return;
 407 } # putnotif
 408
 409 =item I<$obj>-E<gt>B<flush> (B<timeout> =E<gt> I<$timeout>, B<plugins> =E<gt> [...], B<identifier>  =E<gt> [...]);
 410
 411 Flush cached data.
 412
 413 Valid options are:
 414
 415 =over 4
 416
 417 =item B<timeout>
 418
 419 If this option is specified, only data older than I<$timeout> seconds is
 420 flushed.
 421
 422 =item B<plugins>
 423
 424 If this option is specified, only the selected plugins will be flushed. The
 425 argument is a reference to an array of strings.
 426
 427 =item B<identifier>
 428
 429 If this option is specified, only the given identifier(s) will be flushed. The
 430 argument is a reference to an array of identifiers. Identifiers, in this case,
 431 are hash references and have the members as outlined in L<VALUE IDENTIFIERS>.
 432
 433 =back
 434
 435 =cut
 436
 437 sub flush
 438 {
 439         my $obj  = shift;
 440         my %args = @_;
 441
 442         my $fh = $obj->{'sock'} or confess;
 443
 444         my $status = 0;
 445         my $msg    = "FLUSH";
 446
 447         if (defined ($args{'timeout'}))
 448         {
 449                 $msg .= " timeout=" . $args{'timeout'};
 450         }
 451
 452         if ($args{'plugins'})
 453         {
 454                 foreach my $plugin (@{$args{'plugins'}})
 455                 {
 456                         $msg .= " plugin=" . $plugin;
 457                 }
 458         }
 459
 460         if ($args{'identifier'})
 461         {
 462                 for (@{$args{'identifier'}})
 463                 {
 464                         my $identifier = $_;
 465                         my $ident_str;
 466
 467                         if (ref ($identifier) ne 'HASH')
 468                         {
 469                                 cluck ("The argument of the `identifier' "
 470                                         . "option must be an array reference "
 471                                         . "of hash references.");
 472                                 return;
 473                         }
 474
 475                         $ident_str = _create_identifier ($identifier);
 476                         if (!$ident_str)
 477                         {
 478                                 return;
 479                         }
 480                         if ($ident_str =~ m/ /)
 481                         {
 482                                 $ident_str =~ s#\\#\\\\#g;
 483                                 $ident_str =~ s#"#\\"#g;
 484                                 $ident_str = "\"$ident_str\"";
 485                         }
 486
 487                         $msg .= " identifier=$ident_str";
 488                 }
 489         }
 490
 491         $msg .= "\n";
 492
 493         send ($fh, $msg, 0) or confess ("send: $!");
 494         $msg = undef;
 495         recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
 496
 497         ($status, $msg) = split (' ', $msg, 2);
 498         return (1) if ($status == 0);
 499
 500         $obj->{'error'} = $msg;
 501         return;
 502 }
 503
 504 =item I<$obj>-E<gt>destroy ();
 505
 506 Closes the socket before the object is destroyed. This function is also
 507 automatically called then the object goes out of scope.
 508
 509 =back
 510
 511 =cut
 512
 513 sub destroy
 514 {
 515         my $obj = shift;
 516         if ($obj->{'sock'})
 517         {
 518                 close ($obj->{'sock'});
 519                 delete ($obj->{'sock'});
 520         }
 521 }
 522
 523 sub DESTROY
 524 {
 525         my $obj = shift;
 526         $obj->destroy ();
 527 }
 528
 529 =head1 SEE ALSO
 530
 531 L<collectd(1)>,
 532 L<collectd.conf(5)>,
 533 L<collectd-unixsock(5)>
 534
 535 =head1 AUTHOR
 536
 537 Florian octo Forster E<lt>octo@verplant.orgE<gt>
 538
 539 =cut