#
-# collectd - Collectd::Unixsock
+# collectd - bindings/buildperl/Collectd/Unixsock.pm
# Copyright (C) 2007,2008 Florian octo Forster
#
-# This program is free software; you can redistribute it and/or modify it
-# under the terms of the GNU General Public License as published by the
-# Free Software Foundation; only version 2 of the License is applicable.
+# Permission is hereby granted, free of charge, to any person obtaining a
+# copy of this software and associated documentation files (the "Software"),
+# to deal in the Software without restriction, including without limitation
+# the rights to use, copy, modify, merge, publish, distribute, sublicense,
+# and/or sell copies of the Software, and to permit persons to whom the
+# Software is furnished to do so, subject to the following conditions:
#
-# This program is distributed in the hope that it will be useful, but
-# WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-# General Public License for more details.
+# The above copyright notice and this permission notice shall be included in
+# all copies or substantial portions of the Software.
#
-# You should have received a copy of the GNU General Public License along
-# with this program; if not, write to the Free Software Foundation, Inc.,
-# 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+# DEALINGS IN THE SOFTWARE.
#
-# Author:
-# Florian octo Forster <octo at verplant.org>
+# Authors:
+# Florian Forster <octo at collectd.org>
#
package Collectd::Unixsock;
=head1 SYNOPSIS
- use Collectd::Unixsock ();
+ use Collectd::Unixsock;
my $sock = Collectd::Unixsock->new ($path);
use strict;
use warnings;
-#use constant { NOTIF_FAILURE => 1, NOTIF_WARNING => 2, NOTIF_OKAY => 4 };
-
-use Carp (qw(cluck confess));
+use Carp qw(cluck confess carp croak);
use IO::Socket::UNIX;
-use Regexp::Common (qw(number));
+use Scalar::Util qw( looks_like_number );
our $Debug = 0;
-return (1);
-
sub _debug
{
- if (!$Debug)
- {
- return;
- }
- print @_;
+ print @_ if $Debug;
}
sub _create_socket
=head1 VALUE IDENTIFIERS
-The values in the collectd are identified using an five-tuple (host, plugin,
-plugin-instance, type, type-instance) where only plugin-instance and
-type-instance may be NULL (or undefined). Many functions expect an
-I<%identifier> hash that has at least the members B<host>, B<plugin>, and
-B<type>, possibly completed by B<plugin_instance> and B<type_instance>.
+The values in the collectd are identified using a five-tuple (host, plugin,
+plugin-instance, type, type-instance) where only plugin instance and type
+instance may be undef. Many functions expect an I<%identifier> hash that has at
+least the members B<host>, B<plugin>, and B<type>, possibly completed by
+B<plugin_instance> and B<type_instance>.
Usually you can pass this hash as follows:
- $obj->method (host => $host, plugin => $plugin, type => $type, %other_args);
+ $self->method (host => $host, plugin => $plugin, type => $type, %other_args);
=cut
sub _create_identifier
{
my $args = shift;
- my $host;
- my $plugin;
- my $type;
+ my ($host, $plugin, $type);
- if (!$args->{'host'} || !$args->{'plugin'} || !$args->{'type'})
+ if (!$args->{host} || !$args->{plugin} || !$args->{type})
{
cluck ("Need `host', `plugin' and `type'");
return;
}
- $host = $args->{'host'};
- $plugin = $args->{'plugin'};
- $plugin .= '-' . $args->{'plugin_instance'} if (defined ($args->{'plugin_instance'}));
- $type = $args->{'type'};
- $type .= '-' . $args->{'type_instance'} if (defined ($args->{'type_instance'}));
+ $host = $args->{host};
+ $plugin = $args->{plugin};
+ $plugin .= '-' . $args->{plugin_instance} if defined $args->{plugin_instance};
+ $type = $args->{type};
+ $type .= '-' . $args->{type_instance} if defined $args->{type_instance};
- return ("$host/$plugin/$type");
+ return "$host/$plugin/$type";
} # _create_identifier
sub _parse_identifier
{
my $string = shift;
- my $host;
- my $plugin;
- my $plugin_instance;
- my $type;
- my $type_instance;
- my $ident;
+ my ($plugin_instance, $type_instance);
- ($host, $plugin, $type) = split ('/', $string);
+ my ($host, $plugin, $type) = split /\//, $string;
- ($plugin, $plugin_instance) = split ('-', $plugin, 2);
- ($type, $type_instance) = split ('-', $type, 2);
+ ($plugin, $plugin_instance) = split /-/, $plugin, 2;
+ ($type, $type_instance) = split /-/, $type, 2;
- $ident =
+ my $ident =
{
host => $host,
plugin => $plugin,
type => $type
};
- $ident->{'plugin_instance'} = $plugin_instance if (defined ($plugin_instance));
- $ident->{'type_instance'} = $type_instance if (defined ($type_instance));
+ $ident->{plugin_instance} = $plugin_instance if defined $plugin_instance;
+ $ident->{type_instance} = $type_instance if defined $type_instance;
- return ($ident);
+ return $ident;
} # _parse_identifier
sub _escape_argument
{
- my $string = shift;
+ local $_ = shift;
+
+ return $_ if /^\w+$/;
+
+ s#\\#\\\\#g;
+ s#"#\\"#g;
+ return "\"$_\"";
+}
+
+# Send a command on a socket, including any required argument escaping.
+# Return a single line of result.
+sub _socket_command {
+ my ($self, $command, $args) = @_;
+
+ my $fh = $self->{sock} or confess ('object has no filehandle');
+
+ if($args) {
+ my $identifier = _create_identifier ($args) or return;
+ $command .= ' ' . _escape_argument ($identifier) . "\n";
+ } else {
+ $command .= "\n";
+ }
+ _debug "-> $command";
+ $fh->print($command);
+
+ my $response = $fh->getline;
+ chomp $response;
+ _debug "<- $response\n";
+ return $response;
+}
+
+# Read any remaining results from a socket and pass them to
+# a callback for caller-defined mangling.
+sub _socket_chat
+{
+ my ($self, $msg, $callback, $cbdata) = @_;
+ my ($nresults, $ret);
+ my $fh = $self->{sock} or confess ('object has no filehandle');
- if ($string =~ m/^\w+$/)
+ ($nresults, $msg) = split / /, $msg, 2;
+ if ($nresults <= 0)
{
- return ("$string");
+ $self->{error} = $msg;
+ return;
}
- $string =~ s#\\#\\\\#g;
- $string =~ s#"#\\"#g;
- $string = "\"$string\"";
-
- return ($string);
+ for (1 .. $nresults)
+ {
+ my $entry = $fh->getline;
+ chomp $entry;
+ _debug "<- $entry\n";
+ $callback->($entry, $cbdata);
+ }
+ return $cbdata;
}
+
=head1 PUBLIC METHODS
=over 4
-=item I<$obj> = Collectd::Unixsock->B<new> ([I<$path>]);
+=item I<$self> = Collectd::Unixsock->B<new> ([I<$path>]);
Creates a new connection to the daemon. The optional I<$path> argument gives
the path to the UNIX socket of the C<unixsock plugin> and defaults to
sub new
{
- my $pkg = shift;
- my $path = @_ ? shift : '/var/run/collectd-unixsock';
+ my $class = shift;
+ my $path = shift || '/var/run/collectd-unixsock';
my $sock = _create_socket ($path) or return;
- my $obj = bless (
+ return bless
{
path => $path,
sock => $sock,
error => 'No error'
- }, $pkg);
- return ($obj);
+ }, $class;
} # new
-=item I<$res> = I<$obj>-E<gt>B<getval> (I<%identifier>);
+=item I<$res> = I<$self>-E<gt>B<getval> (I<%identifier>);
Requests a value-list from the daemon. On success a hash-ref is returned with
the name of each data-source as the key and the according value as, well, the
sub getval # {{{
{
- my $obj = shift;
+ my $self = shift;
my %args = @_;
-
- my $status;
- my $fh = $obj->{'sock'} or confess ('object has no filehandle');
- my $msg;
- my $identifier;
-
my $ret = {};
- $identifier = _create_identifier (\%args) or return;
-
- $msg = 'GETVAL ' . _escape_argument ($identifier) . "\n";
- _debug "-> $msg";
- print $fh $msg;
-
- $msg = <$fh>;
- chomp ($msg);
- _debug "<- $msg\n";
-
- ($status, $msg) = split (' ', $msg, 2);
- if ($status <= 0)
- {
- $obj->{'error'} = $msg;
- return;
- }
-
- for (my $i = 0; $i < $status; $i++)
- {
- my $entry = <$fh>;
- chomp ($entry);
- _debug "<- $entry\n";
-
- if ($entry =~ m/^(\w+)=NaN$/)
- {
- $ret->{$1} = undef;
- }
- elsif ($entry =~ m/^(\w+)=($RE{num}{real})$/)
- {
- $ret->{$1} = 0.0 + $2;
- }
- }
-
- return ($ret);
+ my $msg = $self->_socket_command('GETVAL', \%args) or return;
+ $self->_socket_chat($msg, sub {
+ local $_ = shift;
+ my $ret = shift;
+ /^(\w+)=NaN$/ and $ret->{$1} = undef, return;
+ /^(\w+)=(.*)$/ and looks_like_number($2) and $ret->{$1} = 0 + $2, return;
+ }, $ret
+ );
+ return $ret;
} # }}} sub getval
-=item I<$res> = I<$obj>-E<gt>B<getthreshold> (I<%identifier>);
+=item I<$res> = I<$self>-E<gt>B<getthreshold> (I<%identifier>);
Requests a threshold from the daemon. On success a hash-ref is returned with
the threshold data. On error false is returned.
sub getthreshold # {{{
{
- my $obj = shift;
+ my $self = shift;
my %args = @_;
-
- my $status;
- my $fh = $obj->{'sock'} or confess ('object has no filehandle');
- my $msg;
- my $identifier;
-
my $ret = {};
- $identifier = _create_identifier (\%args) or return;
-
- $msg = 'GETTHRESHOLD ' . _escape_argument ($identifier) . "\n";
- _debug "-> $msg";
- print $fh $msg;
-
- $msg = <$fh>;
- chomp ($msg);
- _debug "<- $msg\n";
-
- ($status, $msg) = split (' ', $msg, 2);
- if ($status <= 0)
- {
- $obj->{'error'} = $msg;
- return;
- }
-
- for (my $i = 0; $i < $status; $i++)
- {
- my $entry = <$fh>;
- chomp ($entry);
- _debug "<- $entry\n";
-
- if ($entry =~ m/^([^:]+):\s*(\S.*)$/)
- {
- my $key = $1;
- my $value = $2;
-
- $key =~ s/^\s+//;
- $key =~ s/\s+$//;
-
- $ret->{$key} = $value;
- }
- }
-
- return ($ret);
+ my $msg = $self->_socket_command('GETTHRESHOLD', \%args) or return;
+ $self->_socket_chat($msg, sub {
+ local $_ = shift;
+ my $ret = shift;
+ my ( $key, $val );
+ ( $key, $val ) = /^\s*([^:]+):\s*(.*)/ and do {
+ $key =~ s/\s*$//;
+ $ret->{$key} = $val;
+ };
+ }, $ret
+ );
+ return $ret;
} # }}} sub getthreshold
-=item I<$
obj>-E<gt>B<putval> (I<%identifier>, B<time> =E<gt> I<$time>, B<values> =E<gt> [...]);
+=item I<$
self>-E<gt>B<putval> (I<%identifier>, B<time> =E<gt> I<$time>, B<values> =E<gt> [...]);
Submits a value-list to the daemon. If the B<time> argument is omitted
C<time()> is used. The required argument B<values> is a reference to an array
sub putval
{
- my $obj = shift;
+ my $self = shift;
my %args = @_;
- my $status;
- my $fh = $obj->{'sock'} or confess;
- my $msg;
- my $identifier;
- my $values;
- my $interval = "";
+ my ($status, $msg, $identifier, $values);
+ my $fh = $self->{sock} or confess;
- if (defined $args{'interval'})
- {
- $interval = ' interval='
- . _escape_argument ($args{'interval'});
- }
+ my $interval = defined $args{interval} ?
+ ' interval=' . _escape_argument ($args{interval}) : '';
$identifier = _create_identifier (\%args) or return;
- if (!$args{'values'})
+ if (!$args{values})
{
cluck ("Need argument `values'");
return;
}
- if (!ref ($args{'values'}))
- {
- $values = $args{'values'};
- }
- else
+ if (ref ($args{values}))
{
my $time;
- if ("ARRAY" ne ref ($args{'values'}))
+ if ("ARRAY" ne ref ($args{values}))
{
cluck ("Invalid `values' argument (expected an array ref)");
return;
}
- if (! scalar @{$args{'values'}})
+ if (! scalar @{$args{values}})
{
cluck ("Empty `values' array");
return;
}
- $time = $args{'time'} ? $args{'time'} : time ();
- $values = join (':', $time, map { defined ($_) ? $_ : 'U' } (@{$args{'values'}}));
+ $time = $args{time} || time;
+ $values = join (':', $time, map { defined $_ ? $_ : 'U' } @{$args{values}});
+ }
+ else
+ {
+ $values = $args{values};
}
$msg = 'PUTVAL '
. $interval
. ' ' . _escape_argument ($values) . "\n";
_debug "-> $msg";
- print $fh $msg;
+ $fh->print($msg);
$msg = <$fh>;
- chomp ($msg);
+ chomp $msg;
_debug "<- $msg\n";
- ($status, $msg) = split (' ', $msg, 2);
- return (1) if ($status == 0);
+ ($status, $msg) = split / /, $msg, 2;
+ return 1 if $status == 0;
- $obj->{'error'} = $msg;
+ $self->{error} = $msg;
return;
} # putval
-=item I<$res> = I<$obj>-E<gt>B<listval> ()
+=item I<$res> = I<$self>-E<gt>B<listval_filter> ( C<%identifier> )
+
+Queries a list of values from the daemon while restricting the results to
+certain hosts, plugins etc. The argument may be anything that passes for an
+identifier (cf. L<VALUE IDENTIFIERS>), although all fields are optional.
+The returned data is in the same format as from C<listval>.
+
+=cut
+
+sub listval_filter
+{
+ my $self = shift;
+ my %args = @_;
+ my @ret;
+ my $nresults;
+ my $fh = $self->{sock} or confess;
+
+ my $pattern =
+ (exists $args{host} ? "$args{host}" : '[^/]+') .
+ (exists $args{plugin} ? "/$args{plugin}" : '/[^/-]+') .
+ (exists $args{plugin_instance} ? "-$args{plugin_instance}" : '(?:-[^/]+)?') .
+ (exists $args{type} ? "/$args{type}" : '/[^/-]+') .
+ (exists $args{type_instance} ? "-$args{type_instance}" : '(?:-[^/]+)?');
+ $pattern = qr/^\d+ $pattern$/;
+
+ my $msg = $self->_socket_command('LISTVAL') or return;
+ ($nresults, $msg) = split / /, $msg, 2;
+
+ # This could use _socket_chat() but doesn't for speed reasons
+ if ($nresults < 0)
+ {
+ $self->{error} = $msg;
+ return;
+ }
+
+ for (1 .. $nresults)
+ {
+ $msg = <$fh>;
+ chomp $msg;
+ _debug "<- $msg\n";
+ next unless $msg =~ $pattern;
+ my ($time, $ident) = split / /, $msg, 2;
+
+ $ident = _parse_identifier ($ident);
+ $ident->{time} = int $time;
+
+ push (@ret, $ident);
+ } # for (i = 0 .. $status)
+
+ return @ret;
+} # listval
+
+=item I<$res> = I<$self>-E<gt>B<listval> ()
Queries a list of values from the daemon. The list is returned as an array of
hash references, where each hash reference is a valid identifier. The C<time>
sub listval
{
- my $obj = shift;
- my $msg;
- my @ret = ();
- my $status;
- my $fh = $obj->{'sock'} or confess;
+ my $self = shift;
+ my $nresults;
+ my @ret;
+ my $fh = $self->{sock} or confess;
- _debug "LISTVAL\n";
- print $fh "LISTVAL\n";
+ my $msg = $self->_socket_command('LISTVAL') or return;
+ ($nresults, $msg) = split / /, $msg, 2;
- $msg = <$fh>;
- chomp ($msg);
- _debug "<- $msg\n";
- ($status, $msg) = split (' ', $msg, 2);
- if ($status < 0)
+ # This could use _socket_chat() but doesn't for speed reasons
+ if ($nresults < 0)
{
- $obj->{'error'} = $msg;
+ $self->{error} = $msg;
return;
}
- for (my $i = 0; $i < $status; $i++)
+ for (1 .. $nresults)
{
- my $time;
- my $ident;
-
$msg = <$fh>;
- chomp ($msg);
+ chomp $msg;
_debug "<- $msg\n";
- ($time, $ident) = split (' ', $msg, 2);
+ my ($time, $ident) = split / /, $msg, 2;
$ident = _parse_identifier ($ident);
- $ident->{'time'} = int ($time);
+ $ident->{time} = int $time;
push (@ret, $ident);
} # for (i = 0 .. $status)
- return (@ret);
+ return @ret;
} # listval
-=item I<$res> = I<$
obj>-E<gt>B<putnotif> (B<severity> =E<gt> I<$severity>, B<message> =E<gt> I<$message>, ...);
+=item I<$res> = I<$
self>-E<gt>B<putnotif> (B<severity> =E<gt> I<$severity>, B<message> =E<gt> I<$message>, ...);
Submits a notification to the daemon.
sub putnotif
{
- my $obj = shift;
+ my $self = shift;
my %args = @_;
my $status;
- my $fh = $obj->{'sock'} or confess;
+ my $fh = $self->{sock} or confess;
my $msg; # message sent to the socket
- if (!$args{'message'})
- {
- cluck ("Need argument `message'");
- return;
- }
- if (!$args{'severity'})
- {
- cluck ("Need argument `severity'");
- return;
- }
- $args{'severity'} = lc ($args{'severity'});
- if (($args{'severity'} ne 'failure')
- && ($args{'severity'} ne 'warning')
- && ($args{'severity'} ne 'okay'))
+ for my $arg (qw( message severity ))
+ {
+ cluck ("Need argument `$arg'"), return unless $args{$arg};
+ }
+ $args{severity} = lc $args{severity};
+ if (($args{severity} ne 'failure')
+ && ($args{severity} ne 'warning')
+ && ($args{severity} ne 'okay'))
{
- cluck ("Invalid `severity: " . $args{'severity'});
+ cluck ("Invalid `severity: " . $args{severity});
return;
}
- if (!$args{'time'})
- {
- $args{'time'} = time ();
- }
+ $args{time} ||= time;
$msg = 'PUTNOTIF '
- . join (' ', map { $_ . '=' . _escape_argument ($args{$_}) } (keys %args))
+ . join (' ', map { $_ . '=' . _escape_argument ($args{$_}) } keys %args)
. "\n";
_debug "-> $msg";
- print $fh $msg;
+ $fh->print($msg);
$msg = <$fh>;
- chomp ($msg);
+ chomp $msg;
_debug "<- $msg\n";
- ($status, $msg) = split (' ', $msg, 2);
- return (1) if ($status == 0);
+ ($status, $msg) = split / /, $msg, 2;
+ return 1 if $status == 0;
- $obj->{'error'} = $msg;
+ $self->{error} = $msg;
return;
} # putnotif
-=item I<$
obj>-E<gt>B<flush> (B<timeout> =E<gt> I<$timeout>, B<plugins> =E<gt> [...], B<identifier> =E<gt> [...]);
+=item I<$
self>-E<gt>B<flush> (B<timeout> =E<gt> I<$timeout>, B<plugins> =E<gt> [...], B<identifier> =E<gt> [...]);
Flush cached data.
sub flush
{
- my $obj = shift;
+ my $self = shift;
my %args = @_;
- my $fh = $obj->{'sock'} or confess;
+ my $fh = $self->{sock} or confess;
my $status = 0;
my $msg = "FLUSH";
- if (defined ($args{'timeout'}))
- {
- $msg .= " timeout=" . $args{'timeout'};
- }
+ $msg .= " timeout=$args{timeout}" if defined $args{timeout};
- if ($args{'plugins'})
+ if ($args{plugins})
{
- foreach my $plugin (@{$args{'plugins'}})
+ foreach my $plugin (@{$args{plugins}})
{
$msg .= " plugin=" . $plugin;
}
}
- if ($args{'identifier'})
+ if ($args{identifier})
{
- for (@{$args{'identifier'}})
+ for my $identifier (@{$args{identifier}})
{
- my $identifier = $_;
my $ident_str;
if (ref ($identifier) ne 'HASH')
{
cluck ("The argument of the `identifier' "
- . "option must be an array reference "
- . "of hash references.");
- return;
- }
-
- $ident_str = _create_identifier ($identifier);
- if (!$ident_str)
- {
+ . "option must be an array of hashrefs.");
return;
}
+ $ident_str = _create_identifier ($identifier) or return;
$msg .= ' identifier=' . _escape_argument ($ident_str);
}
}
$msg .= "\n";
_debug "-> $msg";
- print $fh $msg;
+ $fh->print($msg);
$msg = <$fh>;
chomp ($msg);
_debug "<- $msg\n";
- ($status, $msg) = split (' ', $msg, 2);
- return (1) if ($status == 0);
+ ($status, $msg) = split / /, $msg, 2;
+ return 1 if $status == 0;
- $obj->{'error'} = $msg;
+ $self->{error} = $msg;
return;
}
sub error
{
- my $obj = shift;
- if ($obj->{'error'})
- {
- return ($obj->{'error'});
- }
- return;
+ return shift->{error};
}
-=item I<$obj>-E<gt>destroy ();
+=item I<$self>-E<gt>destroy ();
Closes the socket before the object is destroyed. This function is also
automatically called then the object goes out of scope.
sub destroy
{
- my $obj = shift;
- if ($obj->{'sock'})
+ my $self = shift;
+ if ($self->{sock})
{
- close ($obj->{'sock'});
- delete ($obj->{'sock'});
+ close $self->{sock};
+ delete $self->{sock};
}
}
sub DESTROY
{
- my $obj = shift;
- $obj->destroy ();
+ my $self = shift;
+ $self->destroy ();
}
=head1 SEE ALSO
=head1 AUTHOR
-Florian octo Forster E<lt>octo@verplant.orgE<gt>
+Florian octo Forster E<lt>octo@collectd.orgE<gt>
=cut
-
+1;
# vim: set fdm=marker :
projects / collectd.git / blobdiff