bindings/perl/lib/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 collectd.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 } # }}} sub getval
 246
 247 =item I<$res> = I<$obj>-E<gt>B<getthreshold> (I<%identifier>);
 248
 249 Requests a threshold from the daemon. On success a hash-ref is returned with
 250 the threshold data. On error false is returned.
 251
 252 =cut
 253
 254 sub getthreshold # {{{
 255 {
 256         my $obj = shift;
 257         my %args = @_;
 258
 259         my $status;
 260         my $fh = $obj->{'sock'} or confess ('object has no filehandle');
 261         my $msg;
 262         my $identifier;
 263
 264         my $ret = {};
 265
 266         $identifier = _create_identifier (\%args) or return;
 267
 268         $msg = 'GETTHRESHOLD ' . _escape_argument ($identifier) . "\n";
 269         _debug "-> $msg";
 270         print $fh $msg;
 271
 272         $msg = <$fh>;
 273         chomp ($msg);
 274         _debug "<- $msg\n";
 275
 276         ($status, $msg) = split (' ', $msg, 2);
 277         if ($status <= 0)
 278         {
 279                 $obj->{'error'} = $msg;
 280                 return;
 281         }
 282
 283         for (my $i = 0; $i < $status; $i++)
 284         {
 285                 my $entry = <$fh>;
 286                 chomp ($entry);
 287                 _debug "<- $entry\n";
 288
 289                 if ($entry =~ m/^([^:]+):\s*(\S.*)$/)
 290                 {
 291                         my $key = $1;
 292                         my $value = $2;
 293
 294                         $key =~ s/^\s+//;
 295                         $key =~ s/\s+$//;
 296
 297                         $ret->{$key} = $value;
 298                 }
 299         }
 300
 301         return ($ret);
 302 } # }}} sub getthreshold
 303
 304 =item I<$obj>-E<gt>B<putval> (I<%identifier>, B<time> =E<gt> I<$time>, B<values> =E<gt> [...]);
 305
 306 Submits a value-list to the daemon. If the B<time> argument is omitted
 307 C<time()> is used. The required argument B<values> is a reference to an array
 308 of values that is to be submitted. The number of values must match the number
 309 of values expected for the given B<type> (see L<VALUE IDENTIFIERS>), though
 310 this is checked by the daemon, not the Perl module. Also, gauge data-sources
 311 (e.E<nbsp>g. system-load) may be C<undef>. Returns true upon success and false
 312 otherwise.
 313
 314 =cut
 315
 316 sub putval
 317 {
 318         my $obj = shift;
 319         my %args = @_;
 320
 321         my $status;
 322         my $fh = $obj->{'sock'} or confess;
 323         my $msg;
 324         my $identifier;
 325         my $values;
 326         my $interval = "";
 327
 328         if (defined $args{'interval'})
 329         {
 330                 $interval = ' interval='
 331                 . _escape_argument ($args{'interval'});
 332         }
 333
 334         $identifier = _create_identifier (\%args) or return;
 335         if (!$args{'values'})
 336         {
 337                 cluck ("Need argument `values'");
 338                 return;
 339         }
 340
 341         if (!ref ($args{'values'}))
 342         {
 343                 $values = $args{'values'};
 344         }
 345         else
 346         {
 347                 my $time;
 348
 349                 if ("ARRAY" ne ref ($args{'values'}))
 350                 {
 351                         cluck ("Invalid `values' argument (expected an array ref)");
 352                         return;
 353                 }
 354
 355                 if (! scalar @{$args{'values'}})
 356                 {
 357                         cluck ("Empty `values' array");
 358                         return;
 359                 }
 360
 361                 $time = $args{'time'} ? $args{'time'} : time ();
 362                 $values = join (':', $time, map { defined ($_) ? $_ : 'U' } (@{$args{'values'}}));
 363         }
 364
 365         $msg = 'PUTVAL '
 366         . _escape_argument ($identifier)
 367         . $interval
 368         . ' ' . _escape_argument ($values) . "\n";
 369         _debug "-> $msg";
 370         print $fh $msg;
 371
 372         $msg = <$fh>;
 373         chomp ($msg);
 374         _debug "<- $msg\n";
 375
 376         ($status, $msg) = split (' ', $msg, 2);
 377         return (1) if ($status == 0);
 378
 379         $obj->{'error'} = $msg;
 380         return;
 381 } # putval
 382
 383 =item I<$res> = I<$obj>-E<gt>B<listval> ()
 384
 385 Queries a list of values from the daemon. The list is returned as an array of
 386 hash references, where each hash reference is a valid identifier. The C<time>
 387 member of each hash holds the epoch value of the last update of that value.
 388
 389 =cut
 390
 391 sub listval
 392 {
 393         my $obj = shift;
 394         my $msg;
 395         my @ret = ();
 396         my $status;
 397         my $fh = $obj->{'sock'} or confess;
 398
 399         _debug "LISTVAL\n";
 400         print $fh "LISTVAL\n";
 401
 402         $msg = <$fh>;
 403         chomp ($msg);
 404         _debug "<- $msg\n";
 405         ($status, $msg) = split (' ', $msg, 2);
 406         if ($status < 0)
 407         {
 408                 $obj->{'error'} = $msg;
 409                 return;
 410         }
 411
 412         for (my $i = 0; $i < $status; $i++)
 413         {
 414                 my $time;
 415                 my $ident;
 416
 417                 $msg = <$fh>;
 418                 chomp ($msg);
 419                 _debug "<- $msg\n";
 420
 421                 ($time, $ident) = split (' ', $msg, 2);
 422
 423                 $ident = _parse_identifier ($ident);
 424                 $ident->{'time'} = int ($time);
 425
 426                 push (@ret, $ident);
 427         } # for (i = 0 .. $status)
 428
 429         return (@ret);
 430 } # listval
 431
 432 =item I<$res> = I<$obj>-E<gt>B<putnotif> (B<severity> =E<gt> I<$severity>, B<message> =E<gt> I<$message>, ...);
 433
 434 Submits a notification to the daemon.
 435
 436 Valid options are:
 437
 438 =over 4
 439
 440 =item B<severity>
 441
 442 Sets the severity of the notification. The value must be one of the following
 443 strings: C<failure>, C<warning>, or C<okay>. Case does not matter. This option
 444 is mandatory.
 445
 446 =item B<message>
 447
 448 Sets the message of the notification. This option is mandatory.
 449
 450 =item B<time>
 451
 452 Sets the time. If omitted, C<time()> is used.
 453
 454 =item I<Value identifier>
 455
 456 All the other fields of the value identifiers, B<host>, B<plugin>,
 457 B<plugin_instance>, B<type>, and B<type_instance>, are optional. When given,
 458 the notification is associated with the performance data of that identifier.
 459 For more details, please see L<collectd-unixsock(5)>.
 460
 461 =back
 462
 463 =cut
 464
 465 sub putnotif
 466 {
 467         my $obj = shift;
 468         my %args = @_;
 469
 470         my $status;
 471         my $fh = $obj->{'sock'} or confess;
 472
 473         my $msg; # message sent to the socket
 474
 475         if (!$args{'message'})
 476         {
 477                 cluck ("Need argument `message'");
 478                 return;
 479         }
 480         if (!$args{'severity'})
 481         {
 482                 cluck ("Need argument `severity'");
 483                 return;
 484         }
 485         $args{'severity'} = lc ($args{'severity'});
 486         if (($args{'severity'} ne 'failure')
 487                 && ($args{'severity'} ne 'warning')
 488                 && ($args{'severity'} ne 'okay'))
 489         {
 490                 cluck ("Invalid `severity: " . $args{'severity'});
 491                 return;
 492         }
 493
 494         if (!$args{'time'})
 495         {
 496                 $args{'time'} = time ();
 497         }
 498
 499         $msg = 'PUTNOTIF '
 500         . join (' ', map { $_ . '=' . _escape_argument ($args{$_}) } (keys %args))
 501         . "\n";
 502
 503         _debug "-> $msg";
 504         print $fh $msg;
 505
 506         $msg = <$fh>;
 507         chomp ($msg);
 508         _debug "<- $msg\n";
 509
 510         ($status, $msg) = split (' ', $msg, 2);
 511         return (1) if ($status == 0);
 512
 513         $obj->{'error'} = $msg;
 514         return;
 515 } # putnotif
 516
 517 =item I<$obj>-E<gt>B<flush> (B<timeout> =E<gt> I<$timeout>, B<plugins> =E<gt> [...], B<identifier>  =E<gt> [...]);
 518
 519 Flush cached data.
 520
 521 Valid options are:
 522
 523 =over 4
 524
 525 =item B<timeout>
 526
 527 If this option is specified, only data older than I<$timeout> seconds is
 528 flushed.
 529
 530 =item B<plugins>
 531
 532 If this option is specified, only the selected plugins will be flushed. The
 533 argument is a reference to an array of strings.
 534
 535 =item B<identifier>
 536
 537 If this option is specified, only the given identifier(s) will be flushed. The
 538 argument is a reference to an array of identifiers. Identifiers, in this case,
 539 are hash references and have the members as outlined in L<VALUE IDENTIFIERS>.
 540
 541 =back
 542
 543 =cut
 544
 545 sub flush
 546 {
 547         my $obj  = shift;
 548         my %args = @_;
 549
 550         my $fh = $obj->{'sock'} or confess;
 551
 552         my $status = 0;
 553         my $msg    = "FLUSH";
 554
 555         if (defined ($args{'timeout'}))
 556         {
 557                 $msg .= " timeout=" . $args{'timeout'};
 558         }
 559
 560         if ($args{'plugins'})
 561         {
 562                 foreach my $plugin (@{$args{'plugins'}})
 563                 {
 564                         $msg .= " plugin=" . $plugin;
 565                 }
 566         }
 567
 568         if ($args{'identifier'})
 569         {
 570                 for (@{$args{'identifier'}})
 571                 {
 572                         my $identifier = $_;
 573                         my $ident_str;
 574
 575                         if (ref ($identifier) ne 'HASH')
 576                         {
 577                                 cluck ("The argument of the `identifier' "
 578                                         . "option must be an array reference "
 579                                         . "of hash references.");
 580                                 return;
 581                         }
 582
 583                         $ident_str = _create_identifier ($identifier);
 584                         if (!$ident_str)
 585                         {
 586                                 return;
 587                         }
 588
 589                         $msg .= ' identifier=' . _escape_argument ($ident_str);
 590                 }
 591         }
 592
 593         $msg .= "\n";
 594
 595         _debug "-> $msg";
 596         print $fh $msg;
 597
 598         $msg = <$fh>;
 599         chomp ($msg);
 600         _debug "<- $msg\n";
 601
 602         ($status, $msg) = split (' ', $msg, 2);
 603         return (1) if ($status == 0);
 604
 605         $obj->{'error'} = $msg;
 606         return;
 607 }
 608
 609 sub error
 610 {
 611         my $obj = shift;
 612         if ($obj->{'error'})
 613         {
 614                 return ($obj->{'error'});
 615         }
 616         return;
 617 }
 618
 619 =item I<$obj>-E<gt>destroy ();
 620
 621 Closes the socket before the object is destroyed. This function is also
 622 automatically called then the object goes out of scope.
 623
 624 =back
 625
 626 =cut
 627
 628 sub destroy
 629 {
 630         my $obj = shift;
 631         if ($obj->{'sock'})
 632         {
 633                 close ($obj->{'sock'});
 634                 delete ($obj->{'sock'});
 635         }
 636 }
 637
 638 sub DESTROY
 639 {
 640         my $obj = shift;
 641         $obj->destroy ();
 642 }
 643
 644 =head1 SEE ALSO
 645
 646 L<collectd(1)>,
 647 L<collectd.conf(5)>,
 648 L<collectd-unixsock(5)>
 649
 650 =head1 AUTHOR
 651
 652 Florian octo Forster E<lt>octo@collectd.orgE<gt>
 653
 654 =cut
 655
 656 # vim: set fdm=marker :