Collectd::Unixsock: Add support for the “GETTHRESHOLD” command.

[collectd.git] / bindings / perl / Collectd / Unixsock.pm

diff --git a/bindings/perl/Collectd/Unixsock.pm b/bindings/perl/Collectd/Unixsock.pm
index cd910ed..199a47c 100644 (file)
--- a/bindings/perl/Collectd/Unixsock.pm
+++ b/bindings/perl/Collectd/Unixsock.pm
@@ -57,8 +57,19 @@ 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;
@@ -134,6 +145,22 @@ sub _parse_identifier
        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
@@ -169,13 +196,13 @@ value. On error false is returned.
 
 =cut
 
-sub getval
+sub getval # {{{
 {
        my $obj = shift;
        my %args = @_;
 
        my $status;
-       my $fh = $obj->{'sock'} or confess;
+       my $fh = $obj->{'sock'} or confess ('object has no filehandle');
        my $msg;
        my $identifier;
 
@@ -183,13 +210,13 @@ sub getval
 
        $identifier = _create_identifier (\%args) or return;
 
-       $msg = "GETVAL $identifier\n";
-       #print "-> $msg";
-       send ($fh, $msg, 0) or confess ("send: $!");
+       $msg = 'GETVAL ' . _escape_argument ($identifier) . "\n";
+       _debug "-> $msg";
+       print $fh $msg;
 
-       $msg = undef;
-       recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
-       #print "<- $msg";
+       $msg = <$fh>;
+       chomp ($msg);
+       _debug "<- $msg\n";
 
        ($status, $msg) = split (' ', $msg, 2);
        if ($status <= 0)
@@ -198,9 +225,12 @@ sub getval
                return;
        }
 
-       for (split (' ', $msg))
+       for (my $i = 0; $i < $status; $i++)
        {
-               my $entry = $_;
+               my $entry = <$fh>;
+               chomp ($entry);
+               _debug "<- $entry\n";
+
                if ($entry =~ m/^(\w+)=NaN$/)
                {
                        $ret->{$1} = undef;
@@ -212,7 +242,64 @@ sub getval
        }
 
        return ($ret);
-} # getval
+} # }}} 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> [...]);
 
@@ -240,7 +327,8 @@ sub putval
 
        if (defined $args{'interval'})
        {
-               $interval = ' interval=' . $args{'interval'};
+               $interval = ' interval='
+               . _escape_argument ($args{'interval'});
        }
 
        $identifier = _create_identifier (\%args) or return;
@@ -256,16 +344,34 @@ sub putval
        }
        else
        {
-               my $time = $args{'time'} ? $args{'time'} : time ();
+               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 $identifier$interval $values\n";
-       #print "-> $msg";
-       send ($fh, $msg, 0) or confess ("send: $!");
-       $msg = undef;
-       recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
-       #print "<- $msg";
+       $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);
@@ -290,10 +396,12 @@ sub listval
        my $status;
        my $fh = $obj->{'sock'} or confess;
 
-       $msg = "LISTVAL\n";
-       send ($fh, $msg, 0) or confess ("send: $!");
+       _debug "LISTVAL\n";
+       print $fh "LISTVAL\n";
 
        $msg = <$fh>;
+       chomp ($msg);
+       _debug "<- $msg\n";
        ($status, $msg) = split (' ', $msg, 2);
        if ($status < 0)
        {
@@ -308,6 +416,7 @@ sub listval
 
                $msg = <$fh>;
                chomp ($msg);
+               _debug "<- $msg\n";
 
                ($time, $ident) = split (' ', $msg, 2);
 
@@ -362,7 +471,6 @@ sub putnotif
        my $fh = $obj->{'sock'} or confess;
 
        my $msg; # message sent to the socket
-       my $opt_msg; # message of the notification
        
        if (!$args{'message'})
        {
@@ -388,16 +496,16 @@ sub putnotif
                $args{'time'} = time ();
        }
        
-       $opt_msg = $args{'message'};
-       delete ($args{'message'});
-
        $msg = 'PUTNOTIF '
-       . join (' ', map { $_ . '=' . $args{$_} } (keys %args))
-       . " message=$opt_msg\n";
+       . join (' ', map { $_ . '=' . _escape_argument ($args{$_}) } (keys %args))
+       . "\n";
+
+       _debug "-> $msg";
+       print $fh $msg;
 
-       send ($fh, $msg, 0) or confess ("send: $!");
-       $msg = undef;
-       recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
+       $msg = <$fh>;
+       chomp ($msg);
+       _debug "<- $msg\n";
 
        ($status, $msg) = split (' ', $msg, 2);
        return (1) if ($status == 0);
@@ -477,22 +585,19 @@ sub flush
                        {
                                return;
                        }
-                       if ($ident_str =~ m/ /)
-                       {
-                               $ident_str =~ s#\\#\\\\#g;
-                               $ident_str =~ s#"#\\"#g;
-                               $ident_str = "\"$ident_str\"";
-                       }
 
-                       $msg .= " identifier=$ident_str";
+                       $msg .= ' identifier=' . _escape_argument ($ident_str);
                }
        }
 
        $msg .= "\n";
 
-       send ($fh, $msg, 0) or confess ("send: $!");
-       $msg = undef;
-       recv ($fh, $msg, 1024, 0) or confess ("recv: $!");
+       _debug "-> $msg";
+       print $fh $msg;
+
+       $msg = <$fh>;
+       chomp ($msg);
+       _debug "<- $msg\n";
 
        ($status, $msg) = split (' ', $msg, 2);
        return (1) if ($status == 0);
@@ -501,6 +606,16 @@ sub flush
        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
@@ -537,3 +652,5 @@ L<collectd-unixsock(5)>
 Florian octo Forster E<lt>octo@verplant.orgE<gt>
 
 =cut
+
+# vim: set fdm=marker :