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