bindings/perl/lib/Collectd/Unixsock.pm

   1 #
   2 # collectd - bindings/buildperl/Collectd/Unixsock.pm
   3 # Copyright (C) 2007,2008  Florian octo Forster
   4 #
   5 # Permission is hereby granted, free of charge, to any person obtaining a
   6 # copy of this software and associated documentation files (the "Software"),
   7 # to deal in the Software without restriction, including without limitation
   8 # the rights to use, copy, modify, merge, publish, distribute, sublicense,
   9 # and/or sell copies of the Software, and to permit persons to whom the
  10 # Software is furnished to do so, subject to the following conditions:
  11 #
  12 # The above copyright notice and this permission notice shall be included in
  13 # all copies or substantial portions of the Software.
  14 #
  15 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  16 # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  17 # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  18 # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  19 # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  20 # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  21 # DEALINGS IN THE SOFTWARE.
  22 #
  23 # Authors:
  24 #   Florian Forster <octo at collectd.org>
  25 #
  26
  27 package Collectd::Unixsock;
  28
  29 =head1 NAME
  30
  31 Collectd::Unixsock - Abstraction layer for accessing the functionality by
  32 collectd's unixsock plugin.
  33
  34 =head1 SYNOPSIS
  35
  36   use Collectd::Unixsock ();
  37
  38   my $sock = Collectd::Unixsock->new ($path);
  39
  40   my $value = $sock->getval (%identifier);
  41   $sock->putval (%identifier,
  42                  time => time (),
  43                  values => [123, 234, 345]);
  44
  45   $sock->destroy ();
  46
  47 =head1 DESCRIPTION
  48
  49 collectd's unixsock plugin allows external programs to access the values it has
  50 collected or received and to submit own values. This Perl-module is simply a
  51 little abstraction layer over this interface to make it even easier for
  52 programmers to interact with the daemon.
  53
  54 =cut
  55
  56 use strict;
  57 use warnings;
  58
  59 #use constant { NOTIF_FAILURE => 1, NOTIF_WARNING => 2, NOTIF_OKAY => 4 };
  60
  61 use Carp (qw(cluck confess));
  62 use IO::Socket::UNIX;
  63 use Regexp::Common (qw(number));
  64
  65 our $Debug = 0;
  66
  67 return (1);
  68
  69 sub _debug
  70 {
  71         if (!$Debug)
  72         {
  73                 return;
  74         }
  75         print @_;
  76 }
  77
  78 sub _create_socket
  79 {
  80         my $path = shift;
  81         my $sock = IO::Socket::UNIX->new (Type => SOCK_STREAM, Peer => $path);
  82         if (!$sock)
  83         {
  84                 cluck ("Cannot open UNIX-socket $path: $!");
  85                 return;
  86         }
  87         return ($sock);
  88 } # _create_socket
  89
  90 =head1 VALUE IDENTIFIERS
  91
  92 The values in the collectd are identified using an five-tuple (host, plugin,
  93 plugin-instance, type, type-instance) where only plugin-instance and
  94 type-instance may be NULL (or undefined). Many functions expect an
  95 I<%identifier> hash that has at least the members B<host>, B<plugin>, and
  96 B<type>, possibly completed by B<plugin_instance> and B<type_instance>.
  97
  98 Usually you can pass this hash as follows:
  99
 100   $obj->method (host => $host, plugin => $plugin, type => $type, %other_args);
 101
 102 =cut
 103
 104 sub _create_identifier
 105 {
 106         my $args = shift;
 107         my $host;
 108         my $plugin;
 109         my $type;
 110
 111         if (!$args->{'host'} || !$args->{'plugin'} || !$args->{'type'})
 112         {
 113                 cluck ("Need `host', `plugin' and `type'");
 114                 return;
 115         }
 116
 117         $host = $args->{'host'};
 118         $plugin = $args->{'plugin'};
 119         $plugin .= '-' . $args->{'plugin_instance'} if (defined ($args->{'plugin_instance'}));
 120         $type = $args->{'type'};
 121         $type .= '-' . $args->{'type_instance'} if (defined ($args->{'type_instance'}));
 122
 123         return ("$host/$plugin/$type");
 124 } # _create_identifier
 125
 126 sub _parse_identifier
 127 {
 128         my $string = shift;
 129         my $host;
 130         my $plugin;
 131         my $plugin_instance;
 132         my $type;
 133         my $type_instance;
 134         my $ident;
 135
 136         ($host, $plugin, $type) = split ('/', $string);
 137
 138         ($plugin, $plugin_instance) = split ('-', $plugin, 2);
 139         ($type, $type_instance) = split ('-', $type, 2);
 140
 141         $ident =
 142         {
 143                 host => $host,
 144                 plugin => $plugin,
 145                 type => $type
 146         };
 147         $ident->{'plugin_instance'} = $plugin_instance if (defined ($plugin_instance));
 148         $ident->{'type_instance'} = $type_instance if (defined ($type_instance));
 149
 150         return ($ident);
 151 } # _parse_identifier
 152
 153 sub _escape_argument
 154 {
 155         my $string = shift;
 156
 157         if ($string =~ m/^\w+$/)
 158         {
 159                 return ("$string");
 160         }
 161
 162         $string =~ s#\\#\\\\#g;
 163         $string =~ s#"#\\"#g;
 164         $string = "\"$string\"";
 165
 166         return ($string);
 167 }
 168
 169 =head1 PUBLIC METHODS
 170
 171 =over 4
 172
 173 =item I<$obj> = Collectd::Unixsock->B<new> ([I<$path>]);
 174
 175 Creates a new connection to the daemon. The optional I<$path> argument gives
 176 the path to the UNIX socket of the C<unixsock plugin> and defaults to
 177 F</var/run/collectd-unixsock>. Returns the newly created object on success and
 178 false on error.
 179
 180 =cut
 181
 182 sub new
 183 {
 184         my $pkg = shift;
 185         my $path = @_ ? shift : '/var/run/collectd-unixsock';
 186         my $sock = _create_socket ($path) or return;
 187         my $obj = bless (
 188                 {
 189                         path => $path,
 190                         sock => $sock,
 191                         error => 'No error'
 192                 }, $pkg);
 193         return ($obj);
 194 } # new
 195
 196 =item I<$res> = I<$obj>-E<gt>B<getval> (I<%identifier>);
 197
 198 Requests a value-list from the daemon. On success a hash-ref is returned with
 199 the name of each data-source as the key and the according value as, well, the
 200 value. On error false is returned.
 201
 202 =cut
 203
 204 sub getval # {{{
 205 {
 206         my $obj = shift;
 207         my %args = @_;
 208
 209         my $status;
 210         my $fh = $obj->{'sock'} or confess ('object has no filehandle');
 211         my $msg;
 212         my $identifier;
 213
 214         my $ret = {};
 215
 216         $identifier = _create_identifier (\%args) or return;
 217
 218         $msg = 'GETVAL ' . _escape_argument ($identifier) . "\n";
 219         _debug "-> $msg";
 220         print $fh $msg;
 221
 222         $msg = <$fh>;
 223         chomp ($msg);
 224         _debug "<- $msg\n";
 225
 226         ($status, $msg) = split (' ', $msg, 2);
 227         if ($status <= 0)
 228         {
 229                 $obj->{'error'} = $msg;
 230                 return;
 231         }
 232
 233         for (my $i = 0; $i < $status; $i++)
 234         {
 235                 my $entry = <$fh>;
 236                 chomp ($entry);
 237                 _debug "<- $entry\n";
 238
 239                 if ($entry =~ m/^(\w+)=NaN$/)
 240                 {
 241                         $ret->{$1} = undef;
 242                 }
 243                 elsif ($entry =~ m/^(\w+)=($RE{num}{real})$/)
 244                 {
 245                         $ret->{$1} = 0.0 + $2;
 246                 }
 247         }
 248
 249         return ($ret);
 250 } # }}} sub getval
 251
 252 =item I<$res> = I<$obj>-E<gt>B<getthreshold> (I<%identifier>);
 253
 254 Requests a threshold from the daemon. On success a hash-ref is returned with
 255 the threshold data. On error false is returned.
 256
 257 =cut
 258
 259 sub getthreshold # {{{
 260 {
 261         my $obj = shift;
 262         my %args = @_;
 263
 264         my $status;
 265         my $fh = $obj->{'sock'} or confess ('object has no filehandle');
 266         my $msg;
 267         my $identifier;
 268
 269         my $ret = {};
 270
 271         $identifier = _create_identifier (\%args) or return;
 272
 273         $msg = 'GETTHRESHOLD ' . _escape_argument ($identifier) . "\n";
 274         _debug "-> $msg";
 275         print $fh $msg;
 276
 277         $msg = <$fh>;
 278         chomp ($msg);
 279         _debug "<- $msg\n";
 280
 281         ($status, $msg) = split (' ', $msg, 2);
 282         if ($status <= 0)
 283         {
 284                 $obj->{'error'} = $msg;
 285                 return;
 286         }
 287
 288         for (my $i = 0; $i < $status; $i++)
 289         {
 290                 my $entry = <$fh>;
 291                 chomp ($entry);
 292                 _debug "<- $entry\n";
 293
 294                 if ($entry =~ m/^([^:]+):\s*(\S.*)$/)
 295                 {
 296                         my $key = $1;
 297                         my $value = $2;
 298
 299                         $key =~ s/^\s+//;
 300                         $key =~ s/\s+$//;
 301
 302                         $ret->{$key} = $value;
 303                 }
 304         }
 305
 306         return ($ret);
 307 } # }}} sub getthreshold
 308
 309 =item I<$obj>-E<gt>B<putval> (I<%identifier>, B<time> =E<gt> I<$time>, B<values> =E<gt> [...]);
 310
 311 Submits a value-list to the daemon. If the B<time> argument is omitted
 312 C<time()> is used. The required argument B<values> is a reference to an array
 313 of values that is to be submitted. The number of values must match the number
 314 of values expected for the given B<type> (see L<VALUE IDENTIFIERS>), though
 315 this is checked by the daemon, not the Perl module. Also, gauge data-sources
 316 (e.E<nbsp>g. system-load) may be C<undef>. Returns true upon success and false
 317 otherwise.
 318
 319 =cut
 320
 321 sub putval
 322 {
 323         my $obj = shift;
 324         my %args = @_;
 325
 326         my $status;
 327         my $fh = $obj->{'sock'} or confess;
 328         my $msg;
 329         my $identifier;
 330         my $values;
 331         my $interval = "";
 332
 333         if (defined $args{'interval'})
 334         {
 335                 $interval = ' interval='
 336                 . _escape_argument ($args{'interval'});
 337         }
 338
 339         $identifier = _create_identifier (\%args) or return;
 340         if (!$args{'values'})
 341         {
 342                 cluck ("Need argument `values'");
 343                 return;
 344         }
 345
 346         if (!ref ($args{'values'}))
 347         {
 348                 $values = $args{'values'};
 349         }
 350         else
 351         {
 352                 my $time;
 353
 354                 if ("ARRAY" ne ref ($args{'values'}))
 355                 {
 356                         cluck ("Invalid `values' argument (expected an array ref)");
 357                         return;
 358                 }
 359
 360                 if (! scalar @{$args{'values'}})
 361                 {
 362                         cluck ("Empty `values' array");
 363                         return;
 364                 }
 365
 366                 $time = $args{'time'} ? $args{'time'} : time ();
 367                 $values = join (':', $time, map { defined ($_) ? $_ : 'U' } (@{$args{'values'}}));
 368         }
 369
 370         $msg = 'PUTVAL '
 371         . _escape_argument ($identifier)
 372         . $interval
 373         . ' ' . _escape_argument ($values) . "\n";
 374         _debug "-> $msg";
 375         print $fh $msg;
 376
 377         $msg = <$fh>;
 378         chomp ($msg);
 379         _debug "<- $msg\n";
 380
 381         ($status, $msg) = split (' ', $msg, 2);
 382         return (1) if ($status == 0);
 383
 384         $obj->{'error'} = $msg;
 385         return;
 386 } # putval
 387
 388 =item I<$res> = I<$obj>-E<gt>B<listval> ()
 389
 390 Queries a list of values from the daemon. The list is returned as an array of
 391 hash references, where each hash reference is a valid identifier. The C<time>
 392 member of each hash holds the epoch value of the last update of that value.
 393
 394 =cut
 395
 396 sub listval
 397 {
 398         my $obj = shift;
 399         my $msg;
 400         my @ret = ();
 401         my $status;
 402         my $fh = $obj->{'sock'} or confess;
 403
 404         _debug "LISTVAL\n";
 405         print $fh "LISTVAL\n";
 406
 407         $msg = <$fh>;
 408         chomp ($msg);
 409         _debug "<- $msg\n";
 410         ($status, $msg) = split (' ', $msg, 2);
 411         if ($status < 0)
 412         {
 413                 $obj->{'error'} = $msg;
 414                 return;
 415         }
 416
 417         for (my $i = 0; $i < $status; $i++)
 418         {
 419                 my $time;
 420                 my $ident;
 421
 422                 $msg = <$fh>;
 423                 chomp ($msg);
 424                 _debug "<- $msg\n";
 425
 426                 ($time, $ident) = split (' ', $msg, 2);
 427
 428                 $ident = _parse_identifier ($ident);
 429                 $ident->{'time'} = int ($time);
 430
 431                 push (@ret, $ident);
 432         } # for (i = 0 .. $status)
 433
 434         return (@ret);
 435 } # listval
 436
 437 =item I<$res> = I<$obj>-E<gt>B<putnotif> (B<severity> =E<gt> I<$severity>, B<message> =E<gt> I<$message>, ...);
 438
 439 Submits a notification to the daemon.
 440
 441 Valid options are:
 442
 443 =over 4
 444
 445 =item B<severity>
 446
 447 Sets the severity of the notification. The value must be one of the following
 448 strings: C<failure>, C<warning>, or C<okay>. Case does not matter. This option
 449 is mandatory.
 450
 451 =item B<message>
 452
 453 Sets the message of the notification. This option is mandatory.
 454
 455 =item B<time>
 456
 457 Sets the time. If omitted, C<time()> is used.
 458
 459 =item I<Value identifier>
 460
 461 All the other fields of the value identifiers, B<host>, B<plugin>,
 462 B<plugin_instance>, B<type>, and B<type_instance>, are optional. When given,
 463 the notification is associated with the performance data of that identifier.
 464 For more details, please see L<collectd-unixsock(5)>.
 465
 466 =back
 467
 468 =cut
 469
 470 sub putnotif
 471 {
 472         my $obj = shift;
 473         my %args = @_;
 474
 475         my $status;
 476         my $fh = $obj->{'sock'} or confess;
 477
 478         my $msg; # message sent to the socket
 479
 480         if (!$args{'message'})
 481         {
 482                 cluck ("Need argument `message'");
 483                 return;
 484         }
 485         if (!$args{'severity'})
 486         {
 487                 cluck ("Need argument `severity'");
 488                 return;
 489         }
 490         $args{'severity'} = lc ($args{'severity'});
 491         if (($args{'severity'} ne 'failure')
 492                 && ($args{'severity'} ne 'warning')
 493                 && ($args{'severity'} ne 'okay'))
 494         {
 495                 cluck ("Invalid `severity: " . $args{'severity'});
 496                 return;
 497         }
 498
 499         if (!$args{'time'})
 500         {
 501                 $args{'time'} = time ();
 502         }
 503
 504         $msg = 'PUTNOTIF '
 505         . join (' ', map { $_ . '=' . _escape_argument ($args{$_}) } (keys %args))
 506         . "\n";
 507
 508         _debug "-> $msg";
 509         print $fh $msg;
 510
 511         $msg = <$fh>;
 512         chomp ($msg);
 513         _debug "<- $msg\n";
 514
 515         ($status, $msg) = split (' ', $msg, 2);
 516         return (1) if ($status == 0);
 517
 518         $obj->{'error'} = $msg;
 519         return;
 520 } # putnotif
 521
 522 =item I<$obj>-E<gt>B<flush> (B<timeout> =E<gt> I<$timeout>, B<plugins> =E<gt> [...], B<identifier>  =E<gt> [...]);
 523
 524 Flush cached data.
 525
 526 Valid options are:
 527
 528 =over 4
 529
 530 =item B<timeout>
 531
 532 If this option is specified, only data older than I<$timeout> seconds is
 533 flushed.
 534
 535 =item B<plugins>
 536
 537 If this option is specified, only the selected plugins will be flushed. The
 538 argument is a reference to an array of strings.
 539
 540 =item B<identifier>
 541
 542 If this option is specified, only the given identifier(s) will be flushed. The
 543 argument is a reference to an array of identifiers. Identifiers, in this case,
 544 are hash references and have the members as outlined in L<VALUE IDENTIFIERS>.
 545
 546 =back
 547
 548 =cut
 549
 550 sub flush
 551 {
 552         my $obj  = shift;
 553         my %args = @_;
 554
 555         my $fh = $obj->{'sock'} or confess;
 556
 557         my $status = 0;
 558         my $msg    = "FLUSH";
 559
 560         if (defined ($args{'timeout'}))
 561         {
 562                 $msg .= " timeout=" . $args{'timeout'};
 563         }
 564
 565         if ($args{'plugins'})
 566         {
 567                 foreach my $plugin (@{$args{'plugins'}})
 568                 {
 569                         $msg .= " plugin=" . $plugin;
 570                 }
 571         }
 572
 573         if ($args{'identifier'})
 574         {
 575                 for (@{$args{'identifier'}})
 576                 {
 577                         my $identifier = $_;
 578                         my $ident_str;
 579
 580                         if (ref ($identifier) ne 'HASH')
 581                         {
 582                                 cluck ("The argument of the `identifier' "
 583                                         . "option must be an array reference "
 584                                         . "of hash references.");
 585                                 return;
 586                         }
 587
 588                         $ident_str = _create_identifier ($identifier);
 589                         if (!$ident_str)
 590                         {
 591                                 return;
 592                         }
 593
 594                         $msg .= ' identifier=' . _escape_argument ($ident_str);
 595                 }
 596         }
 597
 598         $msg .= "\n";
 599
 600         _debug "-> $msg";
 601         print $fh $msg;
 602
 603         $msg = <$fh>;
 604         chomp ($msg);
 605         _debug "<- $msg\n";
 606
 607         ($status, $msg) = split (' ', $msg, 2);
 608         return (1) if ($status == 0);
 609
 610         $obj->{'error'} = $msg;
 611         return;
 612 }
 613
 614 sub error
 615 {
 616         my $obj = shift;
 617         if ($obj->{'error'})
 618         {
 619                 return ($obj->{'error'});
 620         }
 621         return;
 622 }
 623
 624 =item I<$obj>-E<gt>destroy ();
 625
 626 Closes the socket before the object is destroyed. This function is also
 627 automatically called then the object goes out of scope.
 628
 629 =back
 630
 631 =cut
 632
 633 sub destroy
 634 {
 635         my $obj = shift;
 636         if ($obj->{'sock'})
 637         {
 638                 close ($obj->{'sock'});
 639                 delete ($obj->{'sock'});
 640         }
 641 }
 642
 643 sub DESTROY
 644 {
 645         my $obj = shift;
 646         $obj->destroy ();
 647 }
 648
 649 =head1 SEE ALSO
 650
 651 L<collectd(1)>,
 652 L<collectd.conf(5)>,
 653 L<collectd-unixsock(5)>
 654
 655 =head1 AUTHOR
 656
 657 Florian octo Forster E<lt>octo@collectd.orgE<gt>
 658
 659 =cut
 660
 661 # vim: set fdm=marker :