X-Git-Url: https://git.octo.it/?a=blobdiff_plain;f=bindings%2Fperl%2FCollectd%2FUnixsock.pm;h=199a47c5ae304515d2e1ac5b6c84f796bd55951e;hb=24b8995d6ffaba6e1ad59cc330938466454059e7;hp=af274a588e5eed3a8d7503b72326c318ae13eb1a;hpb=07a3dec2e1a60416dcf4c6172755691097a2fb39;p=collectd.git

diff --git a/bindings/perl/Collectd/Unixsock.pm b/bindings/perl/Collectd/Unixsock.pm
index af274a58..199a47c5 100644
--- 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> [...]);
 
@@ -236,6 +323,13 @@ sub putval
 	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'})
@@ -250,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 $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);
@@ -284,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)
 	{
@@ -302,6 +416,7 @@ sub listval
 
 		$msg = <$fh>;
 		chomp ($msg);
+		_debug "<- $msg\n";
 
 		($time, $ident) = split (' ', $msg, 2);
 
@@ -356,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'})
 	{
@@ -382,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";
 
-	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);
@@ -472,15 +586,18 @@ sub flush
 				return;
 			}
 
-			$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);
@@ -489,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
@@ -525,3 +652,5 @@ L<collectd-unixsock(5)>
 Florian octo Forster E<lt>octo@verplant.orgE<gt>
 
 =cut
+
+# vim: set fdm=marker :