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 sub _parse_identifier
  87 {
  88         my $string = shift;
  89         my $host;
  90         my $plugin;
  91         my $plugin_instance;
  92         my $type;
  93         my $type_instance;
  94         my $ident;
  95
  96         ($host, $plugin, $type) = split ('/', $string);
  97
  98         ($plugin, $plugin_instance) = split ('-', $plugin, 2);
  99         ($type, $type_instance) = split ('-', $type, 2);
 100
 101         $ident =
 102         {
 103                 host => $host,
 104                 plugin => $plugin,
 105                 type => $type
 106         };
 107         $ident->{'plugin_instance'} = $plugin_instance if (defined ($plugin_instance));
 108         $ident->{'type_instance'} = $type_instance if (defined ($type_instance));
 109
 110         return ($ident);
 111 } # _parse_identifier
 112
 113 =head1 PUBLIC METHODS
 114
 115 =over 4
 116
 117 =item I<$obj> = Collectd::Unixsock->B<new> ([I<$path>]);
 118
 119 Creates a new connection to the daemon. The optional I<$path> argument gives
 120 the path to the UNIX socket of the C<unixsock plugin> and defaults to
 121 F</var/run/collectd-unixsock>. Returns the newly created object on success and
 122 false on error.
 123
 124 =cut
 125
 126 sub new
 127 {
 128         my $pkg = shift;
 129         my $path = @_ ? shift : '/var/run/collectd-unixsock';
 130         my $sock = _create_socket ($path) or return;
 131         my $obj = bless (
 132                 {
 133                         path => $path,
 134                         sock => $sock,
 135                         error => 'No error'
 136                 }, $pkg);
 137         return ($obj);
 138 } # new
 139
 140 =item I<$res> = I<$obj>-E<gt>B<getval> (I<%identifier>);
 141
 142 Requests a value-list from the daemon. On success a hash-ref is returned with
 143 the name of each data-source as the key and the according value as, well, the
 144 value. On error false is returned.
 145
 146 =cut
 147
 148 sub getval
 149 {
 150         my $obj = shift;
 151         my %args = @_;
 152
 153         my $status;
 154         my $fh = $obj->{'sock'} or confess;
 155         my $msg;
 156         my $identifier;
 157
 158         my $ret = {};
 159
 160         $identifier = _create_identifier (\%args) or return;
 161
 162         $msg = "GETVAL $identifier\n";
 163         #print "-> $msg";
 164         send ($fh, $msg, 0) or confess ("send: $!");
 165
 166         $msg = undef;
 167         recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
 168         #print "<- $msg";
 169
 170         ($status, $msg) = split (' ', $msg, 2);
 171         if ($status <= 0)
 172         {
 173                 $obj->{'error'} = $msg;
 174                 return;
 175         }
 176
 177         for (split (' ', $msg))
 178         {
 179                 my $entry = $_;
 180                 if ($entry =~ m/^(\w+)=NaN$/)
 181                 {
 182                         $ret->{$1} = undef;
 183                 }
 184                 elsif ($entry =~ m/^(\w+)=($RE{num}{real})$/)
 185                 {
 186                         $ret->{$1} = 0.0 + $2;
 187                 }
 188         }
 189
 190         return ($ret);
 191 } # getval
 192
 193 =item I<$obj>-E<gt>B<putval> (I<%identifier>, B<time> => I<$time>, B<values> => [...]);
 194
 195 Submits a value-list to the daemon. If the B<time> argument is omitted
 196 C<time()> is used. The requierd argument B<values> is a reference to an array
 197 of values that is to be submitted. The number of values must match the number
 198 of values expected for the given B<type> (see L<VALUE IDENTIFIER>), though this
 199 is checked by the daemon, not the Perl module. Also, gauge data-sources
 200 (e.E<nbsp>g. system-load) may be C<undef>. Returns true upon success and false
 201 otherwise.
 202
 203 =cut
 204
 205 sub putval
 206 {
 207         my $obj = shift;
 208         my %args = @_;
 209
 210         my $status;
 211         my $fh = $obj->{'sock'} or confess;
 212         my $msg;
 213         my $identifier;
 214         my $values;
 215
 216         $identifier = _create_identifier (\%args) or return;
 217         if (!$args{'values'})
 218         {
 219                 cluck ("Need argument `values'");
 220                 return;
 221         }
 222
 223         if (!ref ($args{'values'}))
 224         {
 225                 $values = $args{'values'};
 226         }
 227         else
 228         {
 229                 my $time = $args{'time'} ? $args{'time'} : time ();
 230                 $values = join (':', $time, map { defined ($_) ? $_ : 'U' } (@{$args{'values'}}));
 231         }
 232
 233         $msg = "PUTVAL $identifier $values\n";
 234         #print "-> $msg";
 235         send ($fh, $msg, 0) or confess ("send: $!");
 236         $msg = undef;
 237         recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
 238         #print "<- $msg";
 239
 240         ($status, $msg) = split (' ', $msg, 2);
 241         return (1) if ($status == 0);
 242
 243         $obj->{'error'} = $msg;
 244         return;
 245 } # putval
 246
 247 =item I<$res> = I<$obj>-E<gt>B<listval> ()
 248
 249 Queries a list of values from the daemon. The list is returned as an array of
 250 hash references, where each hash reference is a valid identifier. The C<time>
 251 member of each hash holds the epoch value of the last update of that value.
 252
 253 =cut
 254
 255 sub listval
 256 {
 257         my $obj = shift;
 258         my $msg;
 259         my @ret = ();
 260         my $status;
 261         my $fh = $obj->{'sock'} or confess;
 262
 263         $msg = "LISTVAL\n";
 264         send ($fh, $msg, 0) or confess ("send: $!");
 265
 266         $msg = <$fh>;
 267         ($status, $msg) = split (' ', $msg, 2);
 268         if ($status < 0)
 269         {
 270                 $obj->{'error'} = $msg;
 271                 return;
 272         }
 273
 274         for (my $i = 0; $i < $status; $i++)
 275         {
 276                 my $time;
 277                 my $ident;
 278
 279                 $msg = <$fh>;
 280                 chomp ($msg);
 281
 282                 ($time, $ident) = split (' ', $msg, 2);
 283
 284                 $ident = _parse_identifier ($ident);
 285                 $ident->{'time'} = int ($time);
 286
 287                 push (@ret, $ident);
 288         } # for (i = 0 .. $status)
 289
 290         return (@ret);
 291 } # listval
 292
 293 =item I<$obj>-E<gt>destroy ();
 294
 295 Closes the socket before the object is destroyed. This function is also
 296 automatically called then the object goes out of scope.
 297
 298 =back
 299
 300 =cut
 301
 302 sub destroy
 303 {
 304         my $obj = shift;
 305         if ($obj->{'sock'})
 306         {
 307                 close ($obj->{'sock'});
 308                 delete ($obj->{'sock'});
 309         }
 310 }
 311
 312 sub DESTROY
 313 {
 314         my $obj = shift;
 315         $obj->destroy ();
 316 }
 317
 318 =head1 AUTHOR
 319
 320 Florian octo Forster E<lt>octo@verplant.orgE<gt>
 321
 322 =cut