contrib/PerlLib/Collectd/Unixsock.pm

   1 package Collectd::Unixsock;
   2
   3 =head1 NAME
   4
   5 Collectd::Unixsock - Abstraction layer for accessing the functionality by collectd's unixsock plugin.
   6
   7 =head1 SYNOPSIS
   8
   9   use Collectd::Unixsock ();
  10
  11   my $sock = Collectd::Unixsock->new ($path);
  12
  13   my $value = $sock->getval (%identifier);
  14   $sock->putval (%identifier,
  15                  time => time (),
  16                  values => [123, 234, 345]);
  17
  18   $sock->destroy ();
  19
  20 =head1 DESCRIPTION
  21
  22 collectd's unixsock plugin allows external programs to access the values it has
  23 collected or received and to submit own values. This Perl-module is simply a
  24 little abstraction layer over this interface to make it even easier for
  25 programmers to interact with the daemon.
  26
  27 =cut
  28
  29 use strict;
  30 use warnings;
  31
  32 use Carp (qw(cluck confess));
  33 use IO::Socket::UNIX;
  34 use Regexp::Common (qw(number));
  35
  36 return (1);
  37
  38 sub _create_socket
  39 {
  40         my $path = shift;
  41         my $sock = IO::Socket::UNIX->new (Type => SOCK_STREAM, Peer => $path);
  42         if (!$sock)
  43         {
  44                 cluck ("Cannot open UNIX-socket $path: $!");
  45                 return;
  46         }
  47         return ($sock);
  48 } # _create_socket
  49
  50 =head1 VALUE IDENTIFIER
  51
  52 The values in the collectd are identified using an five-tupel (host, plugin,
  53 plugin-instance, type, type-instance) where only plugin-instance and
  54 type-instance may be NULL (or undefined). Many functions expect an
  55 I<%identifier> hash that has at least the members B<host>, B<plugin>, and
  56 B<type>, possibly completed by B<plugin_instance> and B<type_instance>.
  57
  58 Usually you can pass this hash as follows:
  59
  60   $obj->method (host => $host, plugin => $plugin, type => $type, %other_args);
  61
  62 =cut
  63
  64 sub _create_identifier
  65 {
  66         my $args = shift;
  67         my $host;
  68         my $plugin;
  69         my $type;
  70
  71         if (!$args->{'host'} || !$args->{'plugin'} || !$args->{'type'})
  72         {
  73                 cluck ("Need `host', `plugin' and `type'");
  74                 return;
  75         }
  76
  77         $host = $args->{'host'};
  78         $plugin = $args->{'plugin'};
  79         $plugin .= '-' . $args->{'plugin_instance'} if (defined ($args->{'plugin_instance'}));
  80         $type = $args->{'type'};
  81         $type .= '-' . $args->{'type_instance'} if (defined ($args->{'type_instance'}));
  82
  83         return ("$host/$plugin/$type");
  84 } # _create_identifier
  85
  86 =head1 PUBLIC METHODS
  87
  88 =over 4
  89
  90 =item I<$obj> = Collectd::Unixsock->B<new> ([I<$path>]);
  91
  92 Creates a new connection to the daemon. The optional I<$path> argument gives
  93 the path to the UNIX socket of the C<unixsock plugin> and defaults to
  94 F</var/run/collectd-unixsock>. Returns the newly created object on success and
  95 false on error.
  96
  97 =cut
  98
  99 sub new
 100 {
 101         my $pkg = shift;
 102         my $path = @_ ? shift : '/var/run/collectd-unixsock';
 103         my $sock = _create_socket ($path) or return;
 104         my $obj = bless (
 105                 {
 106                         path => $path,
 107                         sock => $sock,
 108                         error => 'No error'
 109                 }, $pkg);
 110         return ($obj);
 111 } # new
 112
 113 =item I<$res> = I<$obj>-E<gt>B<getval> (I<%identifier>);
 114
 115 Requests a value-list from the daemon. On success a hash-ref is returned with
 116 the name of each data-source as the key and the according value as, well, the
 117 value. On error false is returned.
 118
 119 =cut
 120
 121 sub getval
 122 {
 123         my $obj = shift;
 124         my %args = @_;
 125
 126         my $status;
 127         my $fh = $obj->{'sock'} or confess;
 128         my $msg;
 129         my $identifier;
 130
 131         my $ret = {};
 132
 133         $identifier = _create_identifier (\%args) or return;
 134
 135         $msg = "GETVAL $identifier\n";
 136         #print "-> $msg";
 137         send ($fh, $msg, 0) or confess ("send: $!");
 138
 139         $msg = undef;
 140         recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
 141         #print "<- $msg";
 142
 143         ($status, $msg) = split (' ', $msg, 2);
 144         if ($status <= 0)
 145         {
 146                 $obj->{'error'} = $msg;
 147                 return;
 148         }
 149
 150         for (split (' ', $msg))
 151         {
 152                 my $entry = $_;
 153                 if ($entry =~ m/^(\w+)=NaN$/)
 154                 {
 155                         $ret->{$1} = undef;
 156                 }
 157                 elsif ($entry =~ m/^(\w+)=($RE{num}{real})$/)
 158                 {
 159                         $ret->{$1} = 0.0 + $2;
 160                 }
 161         }
 162
 163         return ($ret);
 164 } # getval
 165
 166 =item I<$obj>-E<gt>B<putval> (I<%identifier>, B<time> => I<$time>, B<values> => [...]);
 167
 168 Submits a value-list to the daemon. If the B<time> argument is omitted
 169 C<time()> is used. The requierd argument B<values> is a reference to an array
 170 of values that is to be submitted. The number of values must match the number
 171 of values expected for the given B<type> (see L<VALUE IDENTIFIER>), though this
 172 is checked by the daemon, not the Perl module. Also, gauge data-sources
 173 (e.E<nbsp>g. system-load) may be C<undef>. Returns true upon success and false
 174 otherwise.
 175
 176 =cut
 177
 178 sub putval
 179 {
 180         my $obj = shift;
 181         my %args = @_;
 182
 183         my $status;
 184         my $fh = $obj->{'sock'} or confess;
 185         my $msg;
 186         my $identifier;
 187         my $values;
 188
 189         $identifier = _create_identifier (\%args) or return;
 190         if (!$args{'values'})
 191         {
 192                 cluck ("Need argument `values'");
 193                 return;
 194         }
 195
 196         if (!ref ($args{'values'}))
 197         {
 198                 $values = $args{'values'};
 199         }
 200         else
 201         {
 202                 my $time = $args{'time'} ? $args{'time'} : time ();
 203                 $values = join (':', $time, map { defined ($_) ? $_ : 'U' } (@{$args{'values'}}));
 204         }
 205
 206         $msg = "PUTVAL $identifier $values\n";
 207         #print "-> $msg";
 208         send ($fh, $msg, 0) or confess ("send: $!");
 209         $msg = undef;
 210         recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
 211         #print "<- $msg";
 212
 213         ($status, $msg) = split (' ', $msg, 2);
 214         return (1) if ($status == 0);
 215
 216         $obj->{'error'} = $msg;
 217         return;
 218 } # putval
 219
 220 =item I<$obj>-E<gt>destroy ();
 221
 222 Closes the socket before the object is destroyed. This function is also
 223 automatically called then the object goes out of scope.
 224
 225 =back
 226
 227 =cut
 228
 229 sub destroy
 230 {
 231         my $obj = shift;
 232         if ($obj->{'sock'})
 233         {
 234                 close ($obj->{'sock'});
 235                 delete ($obj->{'sock'});
 236         }
 237 }
 238
 239 sub DESTROY
 240 {
 241         my $obj = shift;
 242         $obj->destroy ();
 243 }
 244
 245 =head1 AUTHOR
 246
 247 Florian octo Forster E<lt>octo@verplant.orgE<gt>
 248
 249 =cut