X-Git-Url: https://git.octo.it/?a=blobdiff_plain;f=bindings%2Fperl%2Flib%2FCollectd%2FUnixsock.pm;h=5c6a5f9d24c74179b8c2e3a878619198398bdc73;hb=dd8429c16bc57f949abb2537e003b76ad88b6f90;hp=199a47c5ae304515d2e1ac5b6c84f796bd55951e;hpb=3bd6fcdfd20002eee1f1803460728449c0c98f86;p=collectd.git diff --git a/bindings/perl/lib/Collectd/Unixsock.pm b/bindings/perl/lib/Collectd/Unixsock.pm index 199a47c5..5c6a5f9d 100644 --- a/bindings/perl/lib/Collectd/Unixsock.pm +++ b/bindings/perl/lib/Collectd/Unixsock.pm @@ -1,22 +1,27 @@ # -# 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 +# Authors: +# Florian Forster # package Collectd::Unixsock; @@ -28,7 +33,7 @@ collectd's unixsock plugin. =head1 SYNOPSIS - use Collectd::Unixsock (); + use Collectd::Unixsock; my $sock = Collectd::Unixsock->new ($path); @@ -51,23 +56,15 @@ programmers to interact with the daemon. 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 @@ -84,88 +81,124 @@ 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, B, and -B, possibly completed by B and B. +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, B, and B, possibly completed by +B and B. 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 ([I<$path>]); +=item I<$self> = Collectd::Unixsock->B ([I<$path>]); Creates a new connection to the daemon. The optional I<$path> argument gives the path to the UNIX socket of the C and defaults to @@ -176,19 +209,18 @@ false on error. 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>-EB (I<%identifier>); +=item I<$res> = I<$self>-EB (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 @@ -198,53 +230,22 @@ value. On error false is returned. 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>-EB (I<%identifier>); +=item I<$res> = I<$self>-EB (I<%identifier>); Requests a threshold from the daemon. On success a hash-ref is returned with the threshold data. On error false is returned. @@ -253,55 +254,24 @@ 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; + /^\s*([^:]+):\s*(.*)/ and do { + $1 =~ s/\s*$//; + $ret->{$1} = $2; + }; + }, $ret + ); + return $ret; } # }}} sub getthreshold -=item I<$obj>-EB (I<%identifier>, B