![[tokkee]](http://tokkee.org/images/avatar.png){kind=avatar}
summary | shortlog | log | commit | commitdiff | tree
raw | patch | inline | side by side (parent: 389bd16)
raw | patch | inline | side by side (parent: 389bd16)
| author | Florian Forster <octo@leeloo.lan.home.verplant.org> | |
| Tue, 8 Dec 2009 16:57:51 +0000 (17:57 +0100) | ||
| committer | Florian Forster <octo@leeloo.lan.home.verplant.org> | |
| Tue, 8 Dec 2009 16:58:34 +0000 (17:58 +0100) |
| bindings/Makefile.am | patch | blob | history | |
| bindings/perl/Collectd.pm | [deleted file] | patch | blob | history |
| bindings/perl/Collectd/Makefile.PL | [deleted file] | patch | blob | history |
| bindings/perl/Collectd/Unixsock.pm | [deleted file] | patch | blob | history |
| bindings/perl/lib/Collectd.pm | [new file with mode: 0644] | patch | blob |
| bindings/perl/lib/Collectd/Unixsock.pm | [new file with mode: 0644] | patch | blob |
diff --git a/bindings/Makefile.am b/bindings/Makefile.am
index fb68657c777b55f93487cd6a47ea58ee9eeee783..1a28e290b7b10780e3fa608c3e15a63736cfc03c 100644 (file)
--- a/bindings/Makefile.am
+++ b/bindings/Makefile.am
SUBDIRS += java
endif
-EXTRA_DIST = perl/Collectd.pm perl/Makefile.PL perl/Collectd/Makefile.PL \
+EXTRA_DIST = perl/Collectd.pm perl/Makefile.PL \
perl/Collectd/Unixsock.pm
all-local: @PERL_BINDINGS@
cd perl && $(MAKE)
perl/Makefile: .perl-directory-stamp perl/Makefile.PL \
- perl/Collectd/Makefile.PL $(top_builddir)/config.status
+ $(top_builddir)/config.status
cd perl && @PERL@ Makefile.PL PREFIX=$(prefix) @PERL_BINDINGS_OPTIONS@
.perl-directory-stamp:
cp $(srcdir)/perl/Collectd.pm perl/; \
cp $(srcdir)/perl/Makefile.PL perl/; \
cp $(srcdir)/perl/Collectd/Unixsock.pm perl/Collectd/; \
- cp $(srcdir)/perl/Collectd/Makefile.PL perl/Collectd/; \
fi
touch $@
diff --git a/bindings/perl/Collectd.pm b/bindings/perl/Collectd.pm
+++ /dev/null
@@ -1,648 +0,0 @@
-# collectd - Collectd.pm
-# Copyright (C) 2007-2009 Sebastian Harl
-#
-# 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.
-#
-# 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.
-#
-# 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
-#
-# Author:
-# Sebastian Harl <sh at tokkee.org>
-
-package Collectd;
-
-use strict;
-use warnings;
-
-use Config;
-
-use threads;
-use threads::shared;
-
-BEGIN {
- if (! $Config{'useithreads'}) {
- die "Perl does not support ithreads!";
- }
-}
-
-require Exporter;
-
-our @ISA = qw( Exporter );
-
-our %EXPORT_TAGS = (
- 'plugin' => [ qw(
- plugin_register
- plugin_unregister
- plugin_dispatch_values
- plugin_write
- plugin_flush
- plugin_flush_one
- plugin_flush_all
- plugin_dispatch_notification
- plugin_log
- ) ],
- 'types' => [ qw(
- TYPE_INIT
- TYPE_READ
- TYPE_WRITE
- TYPE_SHUTDOWN
- TYPE_LOG
- TYPE_NOTIF
- TYPE_FLUSH
- TYPE_CONFIG
- TYPE_DATASET
- ) ],
- 'ds_types' => [ qw(
- DS_TYPE_COUNTER
- DS_TYPE_GAUGE
- ) ],
- 'log' => [ qw(
- ERROR
- WARNING
- NOTICE
- INFO
- DEBUG
- LOG_ERR
- LOG_WARNING
- LOG_NOTICE
- LOG_INFO
- LOG_DEBUG
- ) ],
- 'filter_chain' => [ qw(
- fc_register
- FC_MATCH_NO_MATCH
- FC_MATCH_MATCHES
- FC_TARGET_CONTINUE
- FC_TARGET_STOP
- FC_TARGET_RETURN
- ) ],
- 'fc_types' => [ qw(
- FC_MATCH
- FC_TARGET
- ) ],
- 'notif' => [ qw(
- NOTIF_FAILURE
- NOTIF_WARNING
- NOTIF_OKAY
- ) ],
- 'globals' => [ qw(
- $hostname_g
- $interval_g
- ) ],
-);
-
-{
- my %seen;
- push @{$EXPORT_TAGS{'all'}}, grep {! $seen{$_}++ } @{$EXPORT_TAGS{$_}}
- foreach keys %EXPORT_TAGS;
-}
-
-# global variables
-our $hostname_g;
-our $interval_g;
-
-Exporter::export_ok_tags ('all');
-
-my @plugins : shared = ();
-my @fc_plugins : shared = ();
-my %cf_callbacks : shared = ();
-
-my %types = (
- TYPE_INIT, "init",
- TYPE_READ, "read",
- TYPE_WRITE, "write",
- TYPE_SHUTDOWN, "shutdown",
- TYPE_LOG, "log",
- TYPE_NOTIF, "notify",
- TYPE_FLUSH, "flush"
-);
-
-my %fc_types = (
- FC_MATCH, "match",
- FC_TARGET, "target"
-);
-
-my %fc_exec_names = (
- FC_MATCH, "match",
- FC_TARGET, "invoke"
-);
-
-foreach my $type (keys %types) {
- $plugins[$type] = &share ({});
-}
-
-foreach my $type (keys %fc_types) {
- $fc_plugins[$type] = &share ({});
-}
-
-sub _log {
- my $caller = shift;
- my $lvl = shift;
- my $msg = shift;
-
- if ("Collectd" eq $caller) {
- $msg = "perl: $msg";
- }
- return plugin_log ($lvl, $msg);
-}
-
-sub ERROR { _log (scalar caller, LOG_ERR, shift); }
-sub WARNING { _log (scalar caller, LOG_WARNING, shift); }
-sub NOTICE { _log (scalar caller, LOG_NOTICE, shift); }
-sub INFO { _log (scalar caller, LOG_INFO, shift); }
-sub DEBUG { _log (scalar caller, LOG_DEBUG, shift); }
-
-sub plugin_call_all {
- my $type = shift;
-
- my %plugins;
-
- our $cb_name = undef;
-
- if (! defined $type) {
- return;
- }
-
- if (TYPE_LOG != $type) {
- DEBUG ("Collectd::plugin_call: type = \"$type\", args=\"@_\"");
- }
-
- if (! defined $plugins[$type]) {
- ERROR ("Collectd::plugin_call: unknown type \"$type\"");
- return;
- }
-
- {
- lock %{$plugins[$type]};
- %plugins = %{$plugins[$type]};
- }
-
- foreach my $plugin (keys %plugins) {
- my $p = $plugins{$plugin};
-
- my $status = 0;
-
- if ($p->{'wait_left'} > 0) {
- $p->{'wait_left'} -= $interval_g;
- }
-
- next if ($p->{'wait_left'} > 0);
-
- $cb_name = $p->{'cb_name'};
- $status = call_by_name (@_);
-
- if (! $status) {
- my $err = undef;
-
- if ($@) {
- $err = $@;
- }
- else {
- $err = "callback returned false";
- }
-
- if (TYPE_LOG != $type) {
- ERROR ("Execution of callback \"$cb_name\" failed: $err");
- }
-
- $status = 0;
- }
-
- if ($status) {
- $p->{'wait_left'} = 0;
- $p->{'wait_time'} = $interval_g;
- }
- elsif (TYPE_READ == $type) {
- if ($p->{'wait_time'} < $interval_g) {
- $p->{'wait_time'} = $interval_g;
- }
-
- $p->{'wait_left'} = $p->{'wait_time'};
- $p->{'wait_time'} *= 2;
-
- if ($p->{'wait_time'} > 86400) {
- $p->{'wait_time'} = 86400;
- }
-
- WARNING ("${plugin}->read() failed with status $status. "
- . "Will suspend it for $p->{'wait_left'} seconds.");
- }
- elsif (TYPE_INIT == $type) {
- ERROR ("${plugin}->init() failed with status $status. "
- . "Plugin will be disabled.");
-
- foreach my $type (keys %types) {
- plugin_unregister ($type, $plugin);
- }
- }
- elsif (TYPE_LOG != $type) {
- WARNING ("${plugin}->$types{$type}() failed with status $status.");
- }
- }
- return 1;
-}
-
-# Collectd::plugin_register (type, name, data).
-#
-# type:
-# init, read, write, shutdown, data set
-#
-# name:
-# name of the plugin
-#
-# data:
-# reference to the plugin's subroutine that does the work or the data set
-# definition
-sub plugin_register {
- my $type = shift;
- my $name = shift;
- my $data = shift;
-
- DEBUG ("Collectd::plugin_register: "
- . "type = \"$type\", name = \"$name\", data = \"$data\"");
-
- if (! ((defined $type) && (defined $name) && (defined $data))) {
- ERROR ("Usage: Collectd::plugin_register (type, name, data)");
- return;
- }
-
- if ((! defined $plugins[$type]) && (TYPE_DATASET != $type)
- && (TYPE_CONFIG != $type)) {
- ERROR ("Collectd::plugin_register: Invalid type \"$type\"");
- return;
- }
-
- if ((TYPE_DATASET == $type) && ("ARRAY" eq ref $data)) {
- return plugin_register_data_set ($name, $data);
- }
- elsif ((TYPE_CONFIG == $type) && (! ref $data)) {
- my $pkg = scalar caller;
-
- if ($data !~ m/^$pkg\:\:/) {
- $data = $pkg . "::" . $data;
- }
-
- lock %cf_callbacks;
- $cf_callbacks{$name} = $data;
- }
- elsif ((TYPE_DATASET != $type) && (! ref $data)) {
- my $pkg = scalar caller;
-
- my %p : shared;
-
- if ($data !~ m/^$pkg\:\:/) {
- $data = $pkg . "::" . $data;
- }
-
- %p = (
- wait_time => $interval_g,
- wait_left => 0,
- cb_name => $data,
- );
-
- lock %{$plugins[$type]};
- $plugins[$type]->{$name} = \%p;
- }
- else {
- ERROR ("Collectd::plugin_register: Invalid data.");
- return;
- }
- return 1;
-}
-
-sub plugin_unregister {
- my $type = shift;
- my $name = shift;
-
- DEBUG ("Collectd::plugin_unregister: type = \"$type\", name = \"$name\"");
-
- if (! ((defined $type) && (defined $name))) {
- ERROR ("Usage: Collectd::plugin_unregister (type, name)");
- return;
- }
-
- if (TYPE_DATASET == $type) {
- return plugin_unregister_data_set ($name);
- }
- elsif (TYPE_CONFIG == $type) {
- lock %cf_callbacks;
- delete $cf_callbacks{$name};
- }
- elsif (defined $plugins[$type]) {
- lock %{$plugins[$type]};
- delete $plugins[$type]->{$name};
- }
- else {
- ERROR ("Collectd::plugin_unregister: Invalid type.");
- return;
- }
-}
-
-sub plugin_write {
- my %args = @_;
-
- my @plugins = ();
- my @datasets = ();
- my @valuelists = ();
-
- if (! defined $args{'valuelists'}) {
- ERROR ("Collectd::plugin_write: Missing 'valuelists' argument.");
- return;
- }
-
- DEBUG ("Collectd::plugin_write:"
- . (defined ($args{'plugins'}) ? " plugins = $args{'plugins'}" : "")
- . (defined ($args{'datasets'}) ? " datasets = $args{'datasets'}" : "")
- . " valueslists = $args{'valuelists'}");
-
- if (defined ($args{'plugins'})) {
- if ("ARRAY" eq ref ($args{'plugins'})) {
- @plugins = @{$args{'plugins'}};
- }
- else {
- @plugins = ($args{'plugins'});
- }
- }
- else {
- @plugins = (undef);
- }
-
- if ("ARRAY" eq ref ($args{'valuelists'})) {
- @valuelists = @{$args{'valuelists'}};
- }
- else {
- @valuelists = ($args{'valuelists'});
- }
-
- if (defined ($args{'datasets'})) {
- if ("ARRAY" eq ref ($args{'datasets'})) {
- @datasets = @{$args{'datasets'}};
- }
- else {
- @datasets = ($args{'datasets'});
- }
- }
- else {
- @datasets = (undef) x scalar (@valuelists);
- }
-
- if ($#datasets != $#valuelists) {
- ERROR ("Collectd::plugin_write: Invalid number of datasets.");
- return;
- }
-
- foreach my $plugin (@plugins) {
- for (my $i = 0; $i < scalar (@valuelists); ++$i) {
- _plugin_write ($plugin, $datasets[$i], $valuelists[$i]);
- }
- }
-}
-
-sub plugin_flush {
- my %args = @_;
-
- my $timeout = -1;
- my @plugins = ();
- my @ids = ();
-
- DEBUG ("Collectd::plugin_flush:"
- . (defined ($args{'timeout'}) ? " timeout = $args{'timeout'}" : "")
- . (defined ($args{'plugins'}) ? " plugins = $args{'plugins'}" : "")
- . (defined ($args{'identifiers'})
- ? " identifiers = $args{'identifiers'}" : ""));
-
- if (defined ($args{'timeout'}) && ($args{'timeout'} > 0)) {
- $timeout = $args{'timeout'};
- }
-
- if (defined ($args{'plugins'})) {
- if ("ARRAY" eq ref ($args{'plugins'})) {
- @plugins = @{$args{'plugins'}};
- }
- else {
- @plugins = ($args{'plugins'});
- }
- }
- else {
- @plugins = (undef);
- }
-
- if (defined ($args{'identifiers'})) {
- if ("ARRAY" eq ref ($args{'identifiers'})) {
- @ids = @{$args{'identifiers'}};
- }
- else {
- @ids = ($args{'identifiers'});
- }
- }
- else {
- @ids = (undef);
- }
-
- foreach my $plugin (@plugins) {
- foreach my $id (@ids) {
- _plugin_flush($plugin, $timeout, $id);
- }
- }
-}
-
-sub plugin_flush_one {
- my $timeout = shift;
- my $name = shift;
-
- WARNING ("Collectd::plugin_flush_one is deprecated - "
- . "use Collectd::plugin_flush instead.");
-
- if (! (defined ($timeout) && defined ($name))) {
- ERROR ("Usage: Collectd::plugin_flush_one(timeout, name)");
- return;
- }
-
- plugin_flush (plugins => $name, timeout => $timeout);
-}
-
-sub plugin_flush_all {
- my $timeout = shift;
-
- WARNING ("Collectd::plugin_flush_all is deprecated - "
- . "use Collectd::plugin_flush instead.");
-
- if (! defined ($timeout)) {
- ERROR ("Usage: Collectd::plugin_flush_all(timeout)");
- return;
- }
-
- plugin_flush (timeout => $timeout);
-}
-
-sub fc_call {
- my $type = shift;
- my $name = shift;
- my $cb_type = shift;
-
- my %proc;
-
- our $cb_name = undef;
- my $status;
-
- if (! ((defined $type) && (defined $name) && (defined $cb_type))) {
- ERROR ("Usage: Collectd::fc_call(type, name, cb_type, ...)");
- return;
- }
-
- if (! defined $fc_plugins[$type]) {
- ERROR ("Collectd::fc_call: Invalid type \"$type\"");
- return;
- }
-
- if (! defined $fc_plugins[$type]->{$name}) {
- ERROR ("Collectd::fc_call: Unknown "
- . ($type == FC_MATCH ? "match" : "target")
- . " \"$name\"");
- return;
- }
-
- DEBUG ("Collectd::fc_call: "
- . "type = \"$type\", name = \"$name\", cb_type = \"$cb_type\"");
-
- {
- lock %{$fc_plugins[$type]};
- %proc = %{$fc_plugins[$type]->{$name}};
- }
-
- if (FC_CB_EXEC == $cb_type) {
- $cb_name = $proc{$fc_exec_names{$type}};
- }
- elsif (FC_CB_CREATE == $cb_type) {
- if (defined $proc{'create'}) {
- $cb_name = $proc{'create'};
- }
- else {
- return 1;
- }
- }
- elsif (FC_CB_DESTROY == $cb_type) {
- if (defined $proc{'destroy'}) {
- $cb_name = $proc{'destroy'};
- }
- else {
- return 1;
- }
- }
-
- $status = call_by_name (@_);
-
- if ($status < 0) {
- my $err = undef;
-
- if ($@) {
- $err = $@;
- }
- else {
- $err = "callback returned false";
- }
-
- ERROR ("Execution of fc callback \"$cb_name\" failed: $err");
- return;
- }
- return $status;
-}
-
-sub fc_register {
- my $type = shift;
- my $name = shift;
- my $proc = shift;
-
- my %fc : shared;
-
- DEBUG ("Collectd::fc_register: "
- . "type = \"$type\", name = \"$name\", proc = \"$proc\"");
-
- if (! ((defined $type) && (defined $name) && (defined $proc))) {
- ERROR ("Usage: Collectd::fc_register(type, name, proc)");
- return;
- }
-
- if (! defined $fc_plugins[$type]) {
- ERROR ("Collectd::fc_register: Invalid type \"$type\"");
- return;
- }
-
- if (("HASH" ne ref ($proc)) || (! defined $proc->{$fc_exec_names{$type}})
- || ("" ne ref ($proc->{$fc_exec_names{$type}}))) {
- ERROR ("Collectd::fc_register: Invalid proc.");
- return;
- }
-
- for my $p (qw( create destroy )) {
- if ((defined $proc->{$p}) && ("" ne ref ($proc->{$p}))) {
- ERROR ("Collectd::fc_register: Invalid proc.");
- return;
- }
- }
-
- %fc = %$proc;
-
- foreach my $p (keys %fc) {
- my $pkg = scalar caller;
-
- if ($p !~ m/^(create|destroy|$fc_exec_names{$type})$/) {
- next;
- }
-
- if ($fc{$p} !~ m/^$pkg\:\:/) {
- $fc{$p} = $pkg . "::" . $fc{$p};
- }
- }
-
- lock %{$fc_plugins[$type]};
- if (defined $fc_plugins[$type]->{$name}) {
- WARNING ("Collectd::fc_register: Overwriting previous "
- . "definition of match \"$name\".");
- }
-
- if (! _fc_register ($type, $name)) {
- ERROR ("Collectd::fc_register: Failed to register \"$name\".");
- return;
- }
-
- $fc_plugins[$type]->{$name} = \%fc;
- return 1;
-}
-
-sub _plugin_dispatch_config {
- my $plugin = shift;
- my $config = shift;
-
- our $cb_name = undef;
-
- if (! (defined ($plugin) && defined ($config))) {
- return;
- }
-
- if (! defined $cf_callbacks{$plugin}) {
- WARNING ("Found a configuration for the \"$plugin\" plugin, but "
- . "the plugin isn't loaded or didn't register "
- . "a configuration callback.");
- return;
- }
-
- {
- lock %cf_callbacks;
- $cb_name = $cf_callbacks{$plugin};
- }
- call_by_name ($config);
-}
-
-1;
-
-# vim: set sw=4 ts=4 tw=78 noexpandtab :
-
diff --git a/bindings/perl/Collectd/Makefile.PL b/bindings/perl/Collectd/Makefile.PL
+++ /dev/null
@@ -1,8 +0,0 @@
-use ExtUtils::MakeMaker;
-
-WriteMakefile(
- 'NAME' => 'Collectd::Unixsock',
- 'AUTHOR' => 'Florian Forster <octo@verplant.org>',
-);
-
-# vim: set sw=4 ts=4 tw=78 noexpandtab :
diff --git a/bindings/perl/Collectd/Unixsock.pm b/bindings/perl/Collectd/Unixsock.pm
+++ /dev/null
@@ -1,656 +0,0 @@
-#
-# collectd - Collectd::Unixsock
-# 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.
-#
-# 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.
-#
-# 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
-#
-# Author:
-# Florian octo Forster <octo at verplant.org>
-#
-
-package Collectd::Unixsock;
-
-=head1 NAME
-
-Collectd::Unixsock - Abstraction layer for accessing the functionality by
-collectd's unixsock plugin.
-
-=head1 SYNOPSIS
-
- use Collectd::Unixsock ();
-
- my $sock = Collectd::Unixsock->new ($path);
-
- my $value = $sock->getval (%identifier);
- $sock->putval (%identifier,
- time => time (),
- values => [123, 234, 345]);
-
- $sock->destroy ();
-
-=head1 DESCRIPTION
-
-collectd's unixsock plugin allows external programs to access the values it has
-collected or received and to submit own values. This Perl-module is simply a
-little abstraction layer over this interface to make it even easier for
-programmers to interact with the daemon.
-
-=cut
-
-use strict;
-use warnings;
-
-#use constant { NOTIF_FAILURE => 1, NOTIF_WARNING => 2, NOTIF_OKAY => 4 };
-
-use Carp (qw(cluck confess));
-use IO::Socket::UNIX;
-use Regexp::Common (qw(number));
-
-our $Debug = 0;
-
-return (1);
-
-sub _debug
-{
- if (!$Debug)
- {
- return;
- }
- print @_;
-}
-
-sub _create_socket
-{
- my $path = shift;
- my $sock = IO::Socket::UNIX->new (Type => SOCK_STREAM, Peer => $path);
- if (!$sock)
- {
- cluck ("Cannot open UNIX-socket $path: $!");
- return;
- }
- return ($sock);
-} # _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>.
-
-Usually you can pass this hash as follows:
-
- $obj->method (host => $host, plugin => $plugin, type => $type, %other_args);
-
-=cut
-
-sub _create_identifier
-{
- my $args = shift;
- my $host;
- my $plugin;
- my $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'}));
-
- 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;
-
- ($host, $plugin, $type) = split ('/', $string);
-
- ($plugin, $plugin_instance) = split ('-', $plugin, 2);
- ($type, $type_instance) = split ('-', $type, 2);
-
- $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));
-
- return ($ident);
-} # _parse_identifier
-
-sub _escape_argument
-{
- my $string = shift;
-
- if ($string =~ m/^\w+$/)
- {
- return ("$string");
- }
-
- $string =~ s#\\#\\\\#g;
- $string =~ s#"#\\"#g;
- $string = "\"$string\"";
-
- return ($string);
-}
-
-=head1 PUBLIC METHODS
-
-=over 4
-
-=item I<$obj> = 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
-F</var/run/collectd-unixsock>. Returns the newly created object on success and
-false on error.
-
-=cut
-
-sub new
-{
- my $pkg = shift;
- my $path = @_ ? shift : '/var/run/collectd-unixsock';
- my $sock = _create_socket ($path) or return;
- my $obj = bless (
- {
- path => $path,
- sock => $sock,
- error => 'No error'
- }, $pkg);
- return ($obj);
-} # new
-
-=item I<$res> = I<$obj>-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
-value. On error false is returned.
-
-=cut
-
-sub getval # {{{
-{
- my $obj = 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);
-} # }}} sub getval
-
-=item I<$res> = I<$obj>-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.
-
-=cut
-
-sub getthreshold # {{{
-{
- my $obj = 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);
-} # }}} sub getthreshold
-
-=item I<$obj>-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
-of values that is to be submitted. The number of values must match the number
-of values expected for the given B<type> (see L<VALUE IDENTIFIERS>), though
-this is checked by the daemon, not the Perl module. Also, gauge data-sources
-(e.E<nbsp>g. system-load) may be C<undef>. Returns true upon success and false
-otherwise.
-
-=cut
-
-sub putval
-{
- my $obj = shift;
- my %args = @_;
-
- my $status;
- my $fh = $obj->{'sock'} or confess;
- my $msg;
- my $identifier;
- my $values;
- my $interval = "";
-
- if (defined $args{'interval'})
- {
- $interval = ' interval='
- . _escape_argument ($args{'interval'});
- }
-
- $identifier = _create_identifier (\%args) or return;
- if (!$args{'values'})
- {
- cluck ("Need argument `values'");
- return;
- }
-
- if (!ref ($args{'values'}))
- {
- $values = $args{'values'};
- }
- else
- {
- my $time;
-
- if ("ARRAY" ne ref ($args{'values'}))
- {
- cluck ("Invalid `values' argument (expected an array ref)");
- return;
- }
-
- if (! scalar @{$args{'values'}})
- {
- cluck ("Empty `values' array");
- return;
- }
-
- $time = $args{'time'} ? $args{'time'} : time ();
- $values = join (':', $time, map { defined ($_) ? $_ : 'U' } (@{$args{'values'}}));
- }
-
- $msg = 'PUTVAL '
- . _escape_argument ($identifier)
- . $interval
- . ' ' . _escape_argument ($values) . "\n";
- _debug "-> $msg";
- print $fh $msg;
-
- $msg = <$fh>;
- chomp ($msg);
- _debug "<- $msg\n";
-
- ($status, $msg) = split (' ', $msg, 2);
- return (1) if ($status == 0);
-
- $obj->{'error'} = $msg;
- return;
-} # putval
-
-=item I<$res> = I<$obj>-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>
-member of each hash holds the epoch value of the last update of that value.
-
-=cut
-
-sub listval
-{
- my $obj = shift;
- my $msg;
- my @ret = ();
- my $status;
- my $fh = $obj->{'sock'} or confess;
-
- _debug "LISTVAL\n";
- print $fh "LISTVAL\n";
-
- $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 $time;
- my $ident;
-
- $msg = <$fh>;
- chomp ($msg);
- _debug "<- $msg\n";
-
- ($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<$obj>-E<gt>B<putnotif> (B<severity> =E<gt> I<$severity>, B<message> =E<gt> I<$message>, ...);
-
-Submits a notification to the daemon.
-
-Valid options are:
-
-=over 4
-
-=item B<severity>
-
-Sets the severity of the notification. The value must be one of the following
-strings: C<failure>, C<warning>, or C<okay>. Case does not matter. This option
-is mandatory.
-
-=item B<message>
-
-Sets the message of the notification. This option is mandatory.
-
-=item B<time>
-
-Sets the time. If omitted, C<time()> is used.
-
-=item I<Value identifier>
-
-All the other fields of the value identifiers, B<host>, B<plugin>,
-B<plugin_instance>, B<type>, and B<type_instance>, are optional. When given,
-the notification is associated with the performance data of that identifier.
-For more details, please see L<collectd-unixsock(5)>.
-
-=back
-
-=cut
-
-sub putnotif
-{
- my $obj = shift;
- my %args = @_;
-
- my $status;
- my $fh = $obj->{'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'))
- {
- cluck ("Invalid `severity: " . $args{'severity'});
- return;
- }
-
- if (!$args{'time'})
- {
- $args{'time'} = time ();
- }
-
- $msg = 'PUTNOTIF '
- . join (' ', map { $_ . '=' . _escape_argument ($args{$_}) } (keys %args))
- . "\n";
-
- _debug "-> $msg";
- print $fh $msg;
-
- $msg = <$fh>;
- chomp ($msg);
- _debug "<- $msg\n";
-
- ($status, $msg) = split (' ', $msg, 2);
- return (1) if ($status == 0);
-
- $obj->{'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> [...]);
-
-Flush cached data.
-
-Valid options are:
-
-=over 4
-
-=item B<timeout>
-
-If this option is specified, only data older than I<$timeout> seconds is
-flushed.
-
-=item B<plugins>
-
-If this option is specified, only the selected plugins will be flushed. The
-argument is a reference to an array of strings.
-
-=item B<identifier>
-
-If this option is specified, only the given identifier(s) will be flushed. The
-argument is a reference to an array of identifiers. Identifiers, in this case,
-are hash references and have the members as outlined in L<VALUE IDENTIFIERS>.
-
-=back
-
-=cut
-
-sub flush
-{
- my $obj = shift;
- my %args = @_;
-
- my $fh = $obj->{'sock'} or confess;
-
- my $status = 0;
- my $msg = "FLUSH";
-
- if (defined ($args{'timeout'}))
- {
- $msg .= " timeout=" . $args{'timeout'};
- }
-
- if ($args{'plugins'})
- {
- foreach my $plugin (@{$args{'plugins'}})
- {
- $msg .= " plugin=" . $plugin;
- }
- }
-
- if ($args{'identifier'})
- {
- for (@{$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)
- {
- return;
- }
-
- $msg .= ' identifier=' . _escape_argument ($ident_str);
- }
- }
-
- $msg .= "\n";
-
- _debug "-> $msg";
- print $fh $msg;
-
- $msg = <$fh>;
- chomp ($msg);
- _debug "<- $msg\n";
-
- ($status, $msg) = split (' ', $msg, 2);
- return (1) if ($status == 0);
-
- $obj->{'error'} = $msg;
- return;
-}
-
-sub error
-{
- my $obj = shift;
- if ($obj->{'error'})
- {
- return ($obj->{'error'});
- }
- return;
-}
-
-=item I<$obj>-E<gt>destroy ();
-
-Closes the socket before the object is destroyed. This function is also
-automatically called then the object goes out of scope.
-
-=back
-
-=cut
-
-sub destroy
-{
- my $obj = shift;
- if ($obj->{'sock'})
- {
- close ($obj->{'sock'});
- delete ($obj->{'sock'});
- }
-}
-
-sub DESTROY
-{
- my $obj = shift;
- $obj->destroy ();
-}
-
-=head1 SEE ALSO
-
-L<collectd(1)>,
-L<collectd.conf(5)>,
-L<collectd-unixsock(5)>
-
-=head1 AUTHOR
-
-Florian octo Forster E<lt>octo@verplant.orgE<gt>
-
-=cut
-
-# vim: set fdm=marker :
diff --git a/bindings/perl/lib/Collectd.pm b/bindings/perl/lib/Collectd.pm
--- /dev/null
@@ -0,0 +1,648 @@
+# collectd - Collectd.pm
+# Copyright (C) 2007-2009 Sebastian Harl
+#
+# 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.
+#
+# 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.
+#
+# 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
+#
+# Author:
+# Sebastian Harl <sh at tokkee.org>
+
+package Collectd;
+
+use strict;
+use warnings;
+
+use Config;
+
+use threads;
+use threads::shared;
+
+BEGIN {
+ if (! $Config{'useithreads'}) {
+ die "Perl does not support ithreads!";
+ }
+}
+
+require Exporter;
+
+our @ISA = qw( Exporter );
+
+our %EXPORT_TAGS = (
+ 'plugin' => [ qw(
+ plugin_register
+ plugin_unregister
+ plugin_dispatch_values
+ plugin_write
+ plugin_flush
+ plugin_flush_one
+ plugin_flush_all
+ plugin_dispatch_notification
+ plugin_log
+ ) ],
+ 'types' => [ qw(
+ TYPE_INIT
+ TYPE_READ
+ TYPE_WRITE
+ TYPE_SHUTDOWN
+ TYPE_LOG
+ TYPE_NOTIF
+ TYPE_FLUSH
+ TYPE_CONFIG
+ TYPE_DATASET
+ ) ],
+ 'ds_types' => [ qw(
+ DS_TYPE_COUNTER
+ DS_TYPE_GAUGE
+ ) ],
+ 'log' => [ qw(
+ ERROR
+ WARNING
+ NOTICE
+ INFO
+ DEBUG
+ LOG_ERR
+ LOG_WARNING
+ LOG_NOTICE
+ LOG_INFO
+ LOG_DEBUG
+ ) ],
+ 'filter_chain' => [ qw(
+ fc_register
+ FC_MATCH_NO_MATCH
+ FC_MATCH_MATCHES
+ FC_TARGET_CONTINUE
+ FC_TARGET_STOP
+ FC_TARGET_RETURN
+ ) ],
+ 'fc_types' => [ qw(
+ FC_MATCH
+ FC_TARGET
+ ) ],
+ 'notif' => [ qw(
+ NOTIF_FAILURE
+ NOTIF_WARNING
+ NOTIF_OKAY
+ ) ],
+ 'globals' => [ qw(
+ $hostname_g
+ $interval_g
+ ) ],
+);
+
+{
+ my %seen;
+ push @{$EXPORT_TAGS{'all'}}, grep {! $seen{$_}++ } @{$EXPORT_TAGS{$_}}
+ foreach keys %EXPORT_TAGS;
+}
+
+# global variables
+our $hostname_g;
+our $interval_g;
+
+Exporter::export_ok_tags ('all');
+
+my @plugins : shared = ();
+my @fc_plugins : shared = ();
+my %cf_callbacks : shared = ();
+
+my %types = (
+ TYPE_INIT, "init",
+ TYPE_READ, "read",
+ TYPE_WRITE, "write",
+ TYPE_SHUTDOWN, "shutdown",
+ TYPE_LOG, "log",
+ TYPE_NOTIF, "notify",
+ TYPE_FLUSH, "flush"
+);
+
+my %fc_types = (
+ FC_MATCH, "match",
+ FC_TARGET, "target"
+);
+
+my %fc_exec_names = (
+ FC_MATCH, "match",
+ FC_TARGET, "invoke"
+);
+
+foreach my $type (keys %types) {
+ $plugins[$type] = &share ({});
+}
+
+foreach my $type (keys %fc_types) {
+ $fc_plugins[$type] = &share ({});
+}
+
+sub _log {
+ my $caller = shift;
+ my $lvl = shift;
+ my $msg = shift;
+
+ if ("Collectd" eq $caller) {
+ $msg = "perl: $msg";
+ }
+ return plugin_log ($lvl, $msg);
+}
+
+sub ERROR { _log (scalar caller, LOG_ERR, shift); }
+sub WARNING { _log (scalar caller, LOG_WARNING, shift); }
+sub NOTICE { _log (scalar caller, LOG_NOTICE, shift); }
+sub INFO { _log (scalar caller, LOG_INFO, shift); }
+sub DEBUG { _log (scalar caller, LOG_DEBUG, shift); }
+
+sub plugin_call_all {
+ my $type = shift;
+
+ my %plugins;
+
+ our $cb_name = undef;
+
+ if (! defined $type) {
+ return;
+ }
+
+ if (TYPE_LOG != $type) {
+ DEBUG ("Collectd::plugin_call: type = \"$type\", args=\"@_\"");
+ }
+
+ if (! defined $plugins[$type]) {
+ ERROR ("Collectd::plugin_call: unknown type \"$type\"");
+ return;
+ }
+
+ {
+ lock %{$plugins[$type]};
+ %plugins = %{$plugins[$type]};
+ }
+
+ foreach my $plugin (keys %plugins) {
+ my $p = $plugins{$plugin};
+
+ my $status = 0;
+
+ if ($p->{'wait_left'} > 0) {
+ $p->{'wait_left'} -= $interval_g;
+ }
+
+ next if ($p->{'wait_left'} > 0);
+
+ $cb_name = $p->{'cb_name'};
+ $status = call_by_name (@_);
+
+ if (! $status) {
+ my $err = undef;
+
+ if ($@) {
+ $err = $@;
+ }
+ else {
+ $err = "callback returned false";
+ }
+
+ if (TYPE_LOG != $type) {
+ ERROR ("Execution of callback \"$cb_name\" failed: $err");
+ }
+
+ $status = 0;
+ }
+
+ if ($status) {
+ $p->{'wait_left'} = 0;
+ $p->{'wait_time'} = $interval_g;
+ }
+ elsif (TYPE_READ == $type) {
+ if ($p->{'wait_time'} < $interval_g) {
+ $p->{'wait_time'} = $interval_g;
+ }
+
+ $p->{'wait_left'} = $p->{'wait_time'};
+ $p->{'wait_time'} *= 2;
+
+ if ($p->{'wait_time'} > 86400) {
+ $p->{'wait_time'} = 86400;
+ }
+
+ WARNING ("${plugin}->read() failed with status $status. "
+ . "Will suspend it for $p->{'wait_left'} seconds.");
+ }
+ elsif (TYPE_INIT == $type) {
+ ERROR ("${plugin}->init() failed with status $status. "
+ . "Plugin will be disabled.");
+
+ foreach my $type (keys %types) {
+ plugin_unregister ($type, $plugin);
+ }
+ }
+ elsif (TYPE_LOG != $type) {
+ WARNING ("${plugin}->$types{$type}() failed with status $status.");
+ }
+ }
+ return 1;
+}
+
+# Collectd::plugin_register (type, name, data).
+#
+# type:
+# init, read, write, shutdown, data set
+#
+# name:
+# name of the plugin
+#
+# data:
+# reference to the plugin's subroutine that does the work or the data set
+# definition
+sub plugin_register {
+ my $type = shift;
+ my $name = shift;
+ my $data = shift;
+
+ DEBUG ("Collectd::plugin_register: "
+ . "type = \"$type\", name = \"$name\", data = \"$data\"");
+
+ if (! ((defined $type) && (defined $name) && (defined $data))) {
+ ERROR ("Usage: Collectd::plugin_register (type, name, data)");
+ return;
+ }
+
+ if ((! defined $plugins[$type]) && (TYPE_DATASET != $type)
+ && (TYPE_CONFIG != $type)) {
+ ERROR ("Collectd::plugin_register: Invalid type \"$type\"");
+ return;
+ }
+
+ if ((TYPE_DATASET == $type) && ("ARRAY" eq ref $data)) {
+ return plugin_register_data_set ($name, $data);
+ }
+ elsif ((TYPE_CONFIG == $type) && (! ref $data)) {
+ my $pkg = scalar caller;
+
+ if ($data !~ m/^$pkg\:\:/) {
+ $data = $pkg . "::" . $data;
+ }
+
+ lock %cf_callbacks;
+ $cf_callbacks{$name} = $data;
+ }
+ elsif ((TYPE_DATASET != $type) && (! ref $data)) {
+ my $pkg = scalar caller;
+
+ my %p : shared;
+
+ if ($data !~ m/^$pkg\:\:/) {
+ $data = $pkg . "::" . $data;
+ }
+
+ %p = (
+ wait_time => $interval_g,
+ wait_left => 0,
+ cb_name => $data,
+ );
+
+ lock %{$plugins[$type]};
+ $plugins[$type]->{$name} = \%p;
+ }
+ else {
+ ERROR ("Collectd::plugin_register: Invalid data.");
+ return;
+ }
+ return 1;
+}
+
+sub plugin_unregister {
+ my $type = shift;
+ my $name = shift;
+
+ DEBUG ("Collectd::plugin_unregister: type = \"$type\", name = \"$name\"");
+
+ if (! ((defined $type) && (defined $name))) {
+ ERROR ("Usage: Collectd::plugin_unregister (type, name)");
+ return;
+ }
+
+ if (TYPE_DATASET == $type) {
+ return plugin_unregister_data_set ($name);
+ }
+ elsif (TYPE_CONFIG == $type) {
+ lock %cf_callbacks;
+ delete $cf_callbacks{$name};
+ }
+ elsif (defined $plugins[$type]) {
+ lock %{$plugins[$type]};
+ delete $plugins[$type]->{$name};
+ }
+ else {
+ ERROR ("Collectd::plugin_unregister: Invalid type.");
+ return;
+ }
+}
+
+sub plugin_write {
+ my %args = @_;
+
+ my @plugins = ();
+ my @datasets = ();
+ my @valuelists = ();
+
+ if (! defined $args{'valuelists'}) {
+ ERROR ("Collectd::plugin_write: Missing 'valuelists' argument.");
+ return;
+ }
+
+ DEBUG ("Collectd::plugin_write:"
+ . (defined ($args{'plugins'}) ? " plugins = $args{'plugins'}" : "")
+ . (defined ($args{'datasets'}) ? " datasets = $args{'datasets'}" : "")
+ . " valueslists = $args{'valuelists'}");
+
+ if (defined ($args{'plugins'})) {
+ if ("ARRAY" eq ref ($args{'plugins'})) {
+ @plugins = @{$args{'plugins'}};
+ }
+ else {
+ @plugins = ($args{'plugins'});
+ }
+ }
+ else {
+ @plugins = (undef);
+ }
+
+ if ("ARRAY" eq ref ($args{'valuelists'})) {
+ @valuelists = @{$args{'valuelists'}};
+ }
+ else {
+ @valuelists = ($args{'valuelists'});
+ }
+
+ if (defined ($args{'datasets'})) {
+ if ("ARRAY" eq ref ($args{'datasets'})) {
+ @datasets = @{$args{'datasets'}};
+ }
+ else {
+ @datasets = ($args{'datasets'});
+ }
+ }
+ else {
+ @datasets = (undef) x scalar (@valuelists);
+ }
+
+ if ($#datasets != $#valuelists) {
+ ERROR ("Collectd::plugin_write: Invalid number of datasets.");
+ return;
+ }
+
+ foreach my $plugin (@plugins) {
+ for (my $i = 0; $i < scalar (@valuelists); ++$i) {
+ _plugin_write ($plugin, $datasets[$i], $valuelists[$i]);
+ }
+ }
+}
+
+sub plugin_flush {
+ my %args = @_;
+
+ my $timeout = -1;
+ my @plugins = ();
+ my @ids = ();
+
+ DEBUG ("Collectd::plugin_flush:"
+ . (defined ($args{'timeout'}) ? " timeout = $args{'timeout'}" : "")
+ . (defined ($args{'plugins'}) ? " plugins = $args{'plugins'}" : "")
+ . (defined ($args{'identifiers'})
+ ? " identifiers = $args{'identifiers'}" : ""));
+
+ if (defined ($args{'timeout'}) && ($args{'timeout'} > 0)) {
+ $timeout = $args{'timeout'};
+ }
+
+ if (defined ($args{'plugins'})) {
+ if ("ARRAY" eq ref ($args{'plugins'})) {
+ @plugins = @{$args{'plugins'}};
+ }
+ else {
+ @plugins = ($args{'plugins'});
+ }
+ }
+ else {
+ @plugins = (undef);
+ }
+
+ if (defined ($args{'identifiers'})) {
+ if ("ARRAY" eq ref ($args{'identifiers'})) {
+ @ids = @{$args{'identifiers'}};
+ }
+ else {
+ @ids = ($args{'identifiers'});
+ }
+ }
+ else {
+ @ids = (undef);
+ }
+
+ foreach my $plugin (@plugins) {
+ foreach my $id (@ids) {
+ _plugin_flush($plugin, $timeout, $id);
+ }
+ }
+}
+
+sub plugin_flush_one {
+ my $timeout = shift;
+ my $name = shift;
+
+ WARNING ("Collectd::plugin_flush_one is deprecated - "
+ . "use Collectd::plugin_flush instead.");
+
+ if (! (defined ($timeout) && defined ($name))) {
+ ERROR ("Usage: Collectd::plugin_flush_one(timeout, name)");
+ return;
+ }
+
+ plugin_flush (plugins => $name, timeout => $timeout);
+}
+
+sub plugin_flush_all {
+ my $timeout = shift;
+
+ WARNING ("Collectd::plugin_flush_all is deprecated - "
+ . "use Collectd::plugin_flush instead.");
+
+ if (! defined ($timeout)) {
+ ERROR ("Usage: Collectd::plugin_flush_all(timeout)");
+ return;
+ }
+
+ plugin_flush (timeout => $timeout);
+}
+
+sub fc_call {
+ my $type = shift;
+ my $name = shift;
+ my $cb_type = shift;
+
+ my %proc;
+
+ our $cb_name = undef;
+ my $status;
+
+ if (! ((defined $type) && (defined $name) && (defined $cb_type))) {
+ ERROR ("Usage: Collectd::fc_call(type, name, cb_type, ...)");
+ return;
+ }
+
+ if (! defined $fc_plugins[$type]) {
+ ERROR ("Collectd::fc_call: Invalid type \"$type\"");
+ return;
+ }
+
+ if (! defined $fc_plugins[$type]->{$name}) {
+ ERROR ("Collectd::fc_call: Unknown "
+ . ($type == FC_MATCH ? "match" : "target")
+ . " \"$name\"");
+ return;
+ }
+
+ DEBUG ("Collectd::fc_call: "
+ . "type = \"$type\", name = \"$name\", cb_type = \"$cb_type\"");
+
+ {
+ lock %{$fc_plugins[$type]};
+ %proc = %{$fc_plugins[$type]->{$name}};
+ }
+
+ if (FC_CB_EXEC == $cb_type) {
+ $cb_name = $proc{$fc_exec_names{$type}};
+ }
+ elsif (FC_CB_CREATE == $cb_type) {
+ if (defined $proc{'create'}) {
+ $cb_name = $proc{'create'};
+ }
+ else {
+ return 1;
+ }
+ }
+ elsif (FC_CB_DESTROY == $cb_type) {
+ if (defined $proc{'destroy'}) {
+ $cb_name = $proc{'destroy'};
+ }
+ else {
+ return 1;
+ }
+ }
+
+ $status = call_by_name (@_);
+
+ if ($status < 0) {
+ my $err = undef;
+
+ if ($@) {
+ $err = $@;
+ }
+ else {
+ $err = "callback returned false";
+ }
+
+ ERROR ("Execution of fc callback \"$cb_name\" failed: $err");
+ return;
+ }
+ return $status;
+}
+
+sub fc_register {
+ my $type = shift;
+ my $name = shift;
+ my $proc = shift;
+
+ my %fc : shared;
+
+ DEBUG ("Collectd::fc_register: "
+ . "type = \"$type\", name = \"$name\", proc = \"$proc\"");
+
+ if (! ((defined $type) && (defined $name) && (defined $proc))) {
+ ERROR ("Usage: Collectd::fc_register(type, name, proc)");
+ return;
+ }
+
+ if (! defined $fc_plugins[$type]) {
+ ERROR ("Collectd::fc_register: Invalid type \"$type\"");
+ return;
+ }
+
+ if (("HASH" ne ref ($proc)) || (! defined $proc->{$fc_exec_names{$type}})
+ || ("" ne ref ($proc->{$fc_exec_names{$type}}))) {
+ ERROR ("Collectd::fc_register: Invalid proc.");
+ return;
+ }
+
+ for my $p (qw( create destroy )) {
+ if ((defined $proc->{$p}) && ("" ne ref ($proc->{$p}))) {
+ ERROR ("Collectd::fc_register: Invalid proc.");
+ return;
+ }
+ }
+
+ %fc = %$proc;
+
+ foreach my $p (keys %fc) {
+ my $pkg = scalar caller;
+
+ if ($p !~ m/^(create|destroy|$fc_exec_names{$type})$/) {
+ next;
+ }
+
+ if ($fc{$p} !~ m/^$pkg\:\:/) {
+ $fc{$p} = $pkg . "::" . $fc{$p};
+ }
+ }
+
+ lock %{$fc_plugins[$type]};
+ if (defined $fc_plugins[$type]->{$name}) {
+ WARNING ("Collectd::fc_register: Overwriting previous "
+ . "definition of match \"$name\".");
+ }
+
+ if (! _fc_register ($type, $name)) {
+ ERROR ("Collectd::fc_register: Failed to register \"$name\".");
+ return;
+ }
+
+ $fc_plugins[$type]->{$name} = \%fc;
+ return 1;
+}
+
+sub _plugin_dispatch_config {
+ my $plugin = shift;
+ my $config = shift;
+
+ our $cb_name = undef;
+
+ if (! (defined ($plugin) && defined ($config))) {
+ return;
+ }
+
+ if (! defined $cf_callbacks{$plugin}) {
+ WARNING ("Found a configuration for the \"$plugin\" plugin, but "
+ . "the plugin isn't loaded or didn't register "
+ . "a configuration callback.");
+ return;
+ }
+
+ {
+ lock %cf_callbacks;
+ $cb_name = $cf_callbacks{$plugin};
+ }
+ call_by_name ($config);
+}
+
+1;
+
+# vim: set sw=4 ts=4 tw=78 noexpandtab :
+
diff --git a/bindings/perl/lib/Collectd/Unixsock.pm b/bindings/perl/lib/Collectd/Unixsock.pm
--- /dev/null
@@ -0,0 +1,656 @@
+#
+# collectd - Collectd::Unixsock
+# 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.
+#
+# 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.
+#
+# 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
+#
+# Author:
+# Florian octo Forster <octo at verplant.org>
+#
+
+package Collectd::Unixsock;
+
+=head1 NAME
+
+Collectd::Unixsock - Abstraction layer for accessing the functionality by
+collectd's unixsock plugin.
+
+=head1 SYNOPSIS
+
+ use Collectd::Unixsock ();
+
+ my $sock = Collectd::Unixsock->new ($path);
+
+ my $value = $sock->getval (%identifier);
+ $sock->putval (%identifier,
+ time => time (),
+ values => [123, 234, 345]);
+
+ $sock->destroy ();
+
+=head1 DESCRIPTION
+
+collectd's unixsock plugin allows external programs to access the values it has
+collected or received and to submit own values. This Perl-module is simply a
+little abstraction layer over this interface to make it even easier for
+programmers to interact with the daemon.
+
+=cut
+
+use strict;
+use warnings;
+
+#use constant { NOTIF_FAILURE => 1, NOTIF_WARNING => 2, NOTIF_OKAY => 4 };
+
+use Carp (qw(cluck confess));
+use IO::Socket::UNIX;
+use Regexp::Common (qw(number));
+
+our $Debug = 0;
+
+return (1);
+
+sub _debug
+{
+ if (!$Debug)
+ {
+ return;
+ }
+ print @_;
+}
+
+sub _create_socket
+{
+ my $path = shift;
+ my $sock = IO::Socket::UNIX->new (Type => SOCK_STREAM, Peer => $path);
+ if (!$sock)
+ {
+ cluck ("Cannot open UNIX-socket $path: $!");
+ return;
+ }
+ return ($sock);
+} # _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>.
+
+Usually you can pass this hash as follows:
+
+ $obj->method (host => $host, plugin => $plugin, type => $type, %other_args);
+
+=cut
+
+sub _create_identifier
+{
+ my $args = shift;
+ my $host;
+ my $plugin;
+ my $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'}));
+
+ 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;
+
+ ($host, $plugin, $type) = split ('/', $string);
+
+ ($plugin, $plugin_instance) = split ('-', $plugin, 2);
+ ($type, $type_instance) = split ('-', $type, 2);
+
+ $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));
+
+ return ($ident);
+} # _parse_identifier
+
+sub _escape_argument
+{
+ my $string = shift;
+
+ if ($string =~ m/^\w+$/)
+ {
+ return ("$string");
+ }
+
+ $string =~ s#\\#\\\\#g;
+ $string =~ s#"#\\"#g;
+ $string = "\"$string\"";
+
+ return ($string);
+}
+
+=head1 PUBLIC METHODS
+
+=over 4
+
+=item I<$obj> = 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
+F</var/run/collectd-unixsock>. Returns the newly created object on success and
+false on error.
+
+=cut
+
+sub new
+{
+ my $pkg = shift;
+ my $path = @_ ? shift : '/var/run/collectd-unixsock';
+ my $sock = _create_socket ($path) or return;
+ my $obj = bless (
+ {
+ path => $path,
+ sock => $sock,
+ error => 'No error'
+ }, $pkg);
+ return ($obj);
+} # new
+
+=item I<$res> = I<$obj>-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
+value. On error false is returned.
+
+=cut
+
+sub getval # {{{
+{
+ my $obj = 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);
+} # }}} sub getval
+
+=item I<$res> = I<$obj>-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.
+
+=cut
+
+sub getthreshold # {{{
+{
+ my $obj = 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);
+} # }}} sub getthreshold
+
+=item I<$obj>-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
+of values that is to be submitted. The number of values must match the number
+of values expected for the given B<type> (see L<VALUE IDENTIFIERS>), though
+this is checked by the daemon, not the Perl module. Also, gauge data-sources
+(e.E<nbsp>g. system-load) may be C<undef>. Returns true upon success and false
+otherwise.
+
+=cut
+
+sub putval
+{
+ my $obj = shift;
+ my %args = @_;
+
+ my $status;
+ my $fh = $obj->{'sock'} or confess;
+ my $msg;
+ my $identifier;
+ my $values;
+ my $interval = "";
+
+ if (defined $args{'interval'})
+ {
+ $interval = ' interval='
+ . _escape_argument ($args{'interval'});
+ }
+
+ $identifier = _create_identifier (\%args) or return;
+ if (!$args{'values'})
+ {
+ cluck ("Need argument `values'");
+ return;
+ }
+
+ if (!ref ($args{'values'}))
+ {
+ $values = $args{'values'};
+ }
+ else
+ {
+ my $time;
+
+ if ("ARRAY" ne ref ($args{'values'}))
+ {
+ cluck ("Invalid `values' argument (expected an array ref)");
+ return;
+ }
+
+ if (! scalar @{$args{'values'}})
+ {
+ cluck ("Empty `values' array");
+ return;
+ }
+
+ $time = $args{'time'} ? $args{'time'} : time ();
+ $values = join (':', $time, map { defined ($_) ? $_ : 'U' } (@{$args{'values'}}));
+ }
+
+ $msg = 'PUTVAL '
+ . _escape_argument ($identifier)
+ . $interval
+ . ' ' . _escape_argument ($values) . "\n";
+ _debug "-> $msg";
+ print $fh $msg;
+
+ $msg = <$fh>;
+ chomp ($msg);
+ _debug "<- $msg\n";
+
+ ($status, $msg) = split (' ', $msg, 2);
+ return (1) if ($status == 0);
+
+ $obj->{'error'} = $msg;
+ return;
+} # putval
+
+=item I<$res> = I<$obj>-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>
+member of each hash holds the epoch value of the last update of that value.
+
+=cut
+
+sub listval
+{
+ my $obj = shift;
+ my $msg;
+ my @ret = ();
+ my $status;
+ my $fh = $obj->{'sock'} or confess;
+
+ _debug "LISTVAL\n";
+ print $fh "LISTVAL\n";
+
+ $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 $time;
+ my $ident;
+
+ $msg = <$fh>;
+ chomp ($msg);
+ _debug "<- $msg\n";
+
+ ($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<$obj>-E<gt>B<putnotif> (B<severity> =E<gt> I<$severity>, B<message> =E<gt> I<$message>, ...);
+
+Submits a notification to the daemon.
+
+Valid options are:
+
+=over 4
+
+=item B<severity>
+
+Sets the severity of the notification. The value must be one of the following
+strings: C<failure>, C<warning>, or C<okay>. Case does not matter. This option
+is mandatory.
+
+=item B<message>
+
+Sets the message of the notification. This option is mandatory.
+
+=item B<time>
+
+Sets the time. If omitted, C<time()> is used.
+
+=item I<Value identifier>
+
+All the other fields of the value identifiers, B<host>, B<plugin>,
+B<plugin_instance>, B<type>, and B<type_instance>, are optional. When given,
+the notification is associated with the performance data of that identifier.
+For more details, please see L<collectd-unixsock(5)>.
+
+=back
+
+=cut
+
+sub putnotif
+{
+ my $obj = shift;
+ my %args = @_;
+
+ my $status;
+ my $fh = $obj->{'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'))
+ {
+ cluck ("Invalid `severity: " . $args{'severity'});
+ return;
+ }
+
+ if (!$args{'time'})
+ {
+ $args{'time'} = time ();
+ }
+
+ $msg = 'PUTNOTIF '
+ . join (' ', map { $_ . '=' . _escape_argument ($args{$_}) } (keys %args))
+ . "\n";
+
+ _debug "-> $msg";
+ print $fh $msg;
+
+ $msg = <$fh>;
+ chomp ($msg);
+ _debug "<- $msg\n";
+
+ ($status, $msg) = split (' ', $msg, 2);
+ return (1) if ($status == 0);
+
+ $obj->{'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> [...]);
+
+Flush cached data.
+
+Valid options are:
+
+=over 4
+
+=item B<timeout>
+
+If this option is specified, only data older than I<$timeout> seconds is
+flushed.
+
+=item B<plugins>
+
+If this option is specified, only the selected plugins will be flushed. The
+argument is a reference to an array of strings.
+
+=item B<identifier>
+
+If this option is specified, only the given identifier(s) will be flushed. The
+argument is a reference to an array of identifiers. Identifiers, in this case,
+are hash references and have the members as outlined in L<VALUE IDENTIFIERS>.
+
+=back
+
+=cut
+
+sub flush
+{
+ my $obj = shift;
+ my %args = @_;
+
+ my $fh = $obj->{'sock'} or confess;
+
+ my $status = 0;
+ my $msg = "FLUSH";
+
+ if (defined ($args{'timeout'}))
+ {
+ $msg .= " timeout=" . $args{'timeout'};
+ }
+
+ if ($args{'plugins'})
+ {
+ foreach my $plugin (@{$args{'plugins'}})
+ {
+ $msg .= " plugin=" . $plugin;
+ }
+ }
+
+ if ($args{'identifier'})
+ {
+ for (@{$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)
+ {
+ return;
+ }
+
+ $msg .= ' identifier=' . _escape_argument ($ident_str);
+ }
+ }
+
+ $msg .= "\n";
+
+ _debug "-> $msg";
+ print $fh $msg;
+
+ $msg = <$fh>;
+ chomp ($msg);
+ _debug "<- $msg\n";
+
+ ($status, $msg) = split (' ', $msg, 2);
+ return (1) if ($status == 0);
+
+ $obj->{'error'} = $msg;
+ return;
+}
+
+sub error
+{
+ my $obj = shift;
+ if ($obj->{'error'})
+ {
+ return ($obj->{'error'});
+ }
+ return;
+}
+
+=item I<$obj>-E<gt>destroy ();
+
+Closes the socket before the object is destroyed. This function is also
+automatically called then the object goes out of scope.
+
+=back
+
+=cut
+
+sub destroy
+{
+ my $obj = shift;
+ if ($obj->{'sock'})
+ {
+ close ($obj->{'sock'});
+ delete ($obj->{'sock'});
+ }
+}
+
+sub DESTROY
+{
+ my $obj = shift;
+ $obj->destroy ();
+}
+
+=head1 SEE ALSO
+
+L<collectd(1)>,
+L<collectd.conf(5)>,
+L<collectd-unixsock(5)>
+
+=head1 AUTHOR
+
+Florian octo Forster E<lt>octo@verplant.orgE<gt>
+
+=cut
+
+# vim: set fdm=marker :