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 ($args->{'plugin_instance'});
  80         $type = $args->{'type'};
  81         $type .= '-' . $args->{'type_instance'} if ($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         send ($fh, $msg, 0) or confess ("send: $!");
 137
 138         $msg = undef;
 139         recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
 140
 141         ($status, $msg) = split (' ', $msg, 2);
 142         if ($status <= 0)
 143         {
 144                 $obj->{'error'} = $msg;
 145                 return;
 146         }
 147
 148         for (split (' ', $msg))
 149         {
 150                 my $entry = $_;
 151                 if ($entry =~ m/^(\w+)=($RE{num}{real})$/)
 152                 {
 153                         $ret->{$1} = 0.0 + $2;
 154                 }
 155         }
 156
 157         return ($ret);
 158 } # getval
 159
 160 =item I<$obj>-E<gt>B<putval> (I<%identifier>, B<time> => I<$time>, B<values> => [...]);
 161
 162 Submits a value-list to the daemon. If the B<time> argument is omitted
 163 C<time()> is used. The requierd argument B<values> is a reference to an array
 164 of values that is to be submitted. The number of values must match the number
 165 of values expected for the given B<type> (see L<VALUE IDENTIFIER>), though this
 166 is checked by the daemon, not the Perl module. Also, gauge data-sources
 167 (e.E<nbsp>g. system-load) may be C<undef>. Returns true upon success and false
 168 otherwise.
 169
 170 =cut
 171
 172 sub putval
 173 {
 174         my $obj = shift;
 175         my %args = @_;
 176
 177         my $status;
 178         my $fh = $obj->{'sock'} or confess;
 179         my $msg;
 180         my $identifier;
 181         my $values;
 182
 183         $identifier = _create_identifier (\%args) or return;
 184         if (!$args{'values'})
 185         {
 186                 cluck ("Need argument `values'");
 187                 return;
 188         }
 189
 190         if (!ref ($args{'values'}))
 191         {
 192                 $values = $args{'values'};
 193         }
 194         else
 195         {
 196                 my $time = $args{'time'} ? $args{'time'} : time ();
 197                 $values = join (':', $time, map { defined ($_) ? $_ : 'U' } (@{$args{'values'}}));
 198         }
 199
 200         $msg = "PUTVAL $identifier $values\n";
 201         send ($fh, $msg, 0) or confess ("send: $!");
 202         $msg = undef;
 203         recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
 204
 205         ($status, $msg) = split (' ', $msg, 2);
 206         return (1) if ($status == 0);
 207
 208         $obj->{'error'} = $msg;
 209         return;
 210 } # putval
 211
 212 =item I<$obj>-E<gt>destroy ();
 213
 214 Closes the socket before the object is destroyed. This function is also
 215 automatically called then the object goes out of scope.
 216
 217 =back
 218
 219 =cut
 220
 221 sub destroy
 222 {
 223         my $obj = shift;
 224         if ($obj->{'sock'})
 225         {
 226                 close ($obj->{'sock'});
 227                 delete ($obj->{'sock'});
 228         }
 229 }
 230
 231 sub DESTROY
 232 {
 233         my $obj = shift;
 234         $obj->destroy ();
 235 }
 236
 237 =head1 AUTHOR
 238
 239 Florian octo Forster E<lt>octo@verplant.orgE<gt>
 240
 241 =cut