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');
+
+ ($nresults, $msg) = split / /, $msg, 2;
+ if ($nresults <= 0)
+ {
+ $self->{error} = $msg;
+ return;
+ }
+
+ for (1 .. $nresults)
+ {
+ my $entry = $fh->getline;
+ chomp $entry;
+ _debug "<- $entry\n";
+ $callback->($entry, $cbdata);
+ }
+ return $cbdata;
+}
+
+
=head1 PUBLIC METHODS
=over 4
{
my $self = shift;
my %args = @_;
-
- my ($status, $msg, $identifier, $ret);
- my $fh = $self->{sock} or confess ('object has no filehandle');
-
- $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)
- {
- $self->{error} = $msg;
- return;
- }
-
- for (1 .. $status)
- {
- my $entry = <$fh>;
- chomp $entry;
- _debug "<- $entry\n";
-
- if ($entry =~ m/^(\w+)=NaN$/)
- {
- $ret->{$1} = undef;
- }
- elsif ($entry =~ m/^(\w+)=(.*)$/ and looks_like_number($2))
- {
- $ret->{$1} = 0.0 + $2;
- }
- }
-
+ my $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
{
my $self = shift;
my %args = @_;
-
- my ($status, $msg, $identifier, $ret);
- my $fh = $self->{sock} or confess ('object has no filehandle');
-
- $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)
- {
- $self->{error} = $msg;
- return;
- }
-
- for (1 .. $status)
- {
- my $entry = <$fh>;
- chomp ($entry);
- _debug "<- $entry\n";
-
- if ($entry =~ m/^([^:]+):\s*(\S.*)$/)
- {
- my $key = $1;
- my $value = $2;
-
- $key =~ s/(?:^\s+|\s$)//;
- $ret->{$key} = $value;
- }
- }
-
+ my $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
. $interval
. ' ' . _escape_argument ($values) . "\n";
_debug "-> $msg";
- print $fh $msg;
+ $fh->print($msg);
$msg = <$fh>;
chomp $msg;
return;
} # putval
+=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
sub listval
{
my $self = shift;
- my ($msg, $status);
+ 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)
{
$self->{error} = $msg;
return;
}
- for (1 .. $status)
+ 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;
. "\n";
_debug "-> $msg";
- print $fh $msg;
+ $fh->print($msg);
$msg = <$fh>;
chomp $msg;
$msg .= "\n";
_debug "-> $msg";
- print $fh $msg;
+ $fh->print($msg);
$msg = <$fh>;
chomp ($msg);
projects / collectd.git / blobdiff