contrib/PerlLib/Collectd/Unixsock.pm

   1 package Collectd::Unixsock;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp (qw(cluck confess));
   7 use IO::Socket::UNIX;
   8 use Regexp::Common (qw(number));
   9
  10 return (1);
  11
  12 sub _create_socket
  13 {
  14         my $path = shift;
  15         my $sock = IO::Socket::UNIX->new (Type => SOCK_STREAM, Peer => $path);
  16         if (!$sock)
  17         {
  18                 cluck ("Cannot open UNIX-socket $path: $!");
  19                 return;
  20         }
  21         return ($sock);
  22 } # _create_socket
  23
  24 sub _create_identifier
  25 {
  26         my $args = shift;
  27         my $host;
  28         my $plugin;
  29         my $type;
  30
  31         if (!$args->{'host'} || !$args->{'plugin'} || !$args->{'type'})
  32         {
  33                 cluck ("Need `host', `plugin' and `type'");
  34                 return;
  35         }
  36
  37         $host = $args->{'host'};
  38         $plugin = $args->{'plugin'};
  39         $plugin .= '-' . $args->{'plugin_instance'} if ($args->{'plugin_instance'});
  40         $type = $args->{'type'};
  41         $type .= '-' . $args->{'type_instance'} if ($args->{'type_instance'});
  42
  43         return ("$host/$plugin/$type");
  44 } # _create_identifier
  45
  46 sub new
  47 {
  48         my $pkg = shift;
  49         my $path = @_ ? shift : '/var/run/collectd-unixsock';
  50         my $sock = _create_socket ($path) or return;
  51         my $obj = bless (
  52                 {
  53                         path => $path,
  54                         sock => $sock,
  55                         error => 'No error'
  56                 }, $pkg);
  57         return ($obj);
  58 } # new
  59
  60 sub getval
  61 {
  62         my $obj = shift;
  63         my %args = @_;
  64
  65         my $status;
  66         my $fh = $obj->{'sock'} or confess;
  67         my $msg;
  68         my $identifier;
  69
  70         my $ret = {};
  71
  72         $identifier = _create_identifier (\%args) or return;
  73
  74         $msg = "GETVAL $identifier\n";
  75         send ($fh, $msg, 0) or confess ("send: $!");
  76
  77         $msg = undef;
  78         recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
  79
  80         ($status, $msg) = split (' ', $msg, 2);
  81         if ($status <= 0)
  82         {
  83                 $obj->{'error'} = $msg;
  84                 return;
  85         }
  86
  87         for (split (' ', $msg))
  88         {
  89                 my $entry = $_;
  90                 if ($entry =~ m/^(\w+)=($RE{num}{real})$/)
  91                 {
  92                         $ret->{$1} = 0.0 + $2;
  93                 }
  94         }
  95
  96         return ($ret);
  97 } # getval
  98
  99 sub putval
 100 {
 101         my $obj = shift;
 102         my %args = @_;
 103
 104         my $status;
 105         my $fh = $obj->{'sock'} or confess;
 106         my $msg;
 107         my $identifier;
 108         my $values;
 109
 110         $identifier = _create_identifier (\%args) or return;
 111         if (!$args{'values'})
 112         {
 113                 cluck ("Need argument `values'");
 114                 return;
 115         }
 116
 117         if (!ref ($args{'values'}))
 118         {
 119                 $values = $args{'values'};
 120         }
 121         else
 122         {
 123                 my $time = $args{'time'} ? $args{'time'} : time ();
 124                 $values = join (':', $time, map { defined ($_) ? $_ : 'U' } (@{$args{'values'}}));
 125         }
 126
 127         $msg = "PUTVAL $identifier $values\n";
 128         send ($fh, $msg, 0) or confess ("send: $!");
 129         $msg = undef;
 130         recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
 131
 132         ($status, $msg) = split (' ', $msg, 2);
 133         return (1) if ($status == 0);
 134
 135         $obj->{'error'} = $msg;
 136         return;
 137 } # putval
 138
 139 sub destroy
 140 {
 141         my $obj = shift;
 142         if ($obj->{'sock'})
 143         {
 144                 close ($obj->{'sock'});
 145                 delete ($obj->{'sock'});
 146         }
 147 }
 148
 149 sub DESTROY
 150 {
 151         my $obj = shift;
 152         $obj->destroy ();
 153 }