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