X-Git-Url: https://git.verplant.org/?a=blobdiff_plain;f=bindings%2Fperl%2Flib%2FCollectd%2FUnixsock.pm;h=5c6a5f9d24c74179b8c2e3a878619198398bdc73;hb=3c15b0e6fa66db107025ae08d3bbb9824d987a89;hp=f9981d98b0135859c934bc3dbe7e5ce700983065;hpb=bf66419c7726e85f31818d75aa521f4087719ca3;p=collectd.git diff --git a/bindings/perl/lib/Collectd/Unixsock.pm b/bindings/perl/lib/Collectd/Unixsock.pm index f9981d98..5c6a5f9d 100644 --- a/bindings/perl/lib/Collectd/Unixsock.pm +++ b/bindings/perl/lib/Collectd/Unixsock.pm @@ -146,6 +146,54 @@ sub _escape_argument 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 @@ -184,45 +232,16 @@ 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 = '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 @@ -237,45 +256,18 @@ sub getthreshold # {{{ { 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; + /^\s*([^:]+):\s*(.*)/ and do { + $1 =~ s/\s*$//; + $ret->{$1} = $2; + }; + }, $ret + ); return $ret; } # }}} sub getthreshold @@ -338,7 +330,7 @@ sub putval . $interval . ' ' . _escape_argument ($values) . "\n"; _debug "-> $msg"; - print $fh $msg; + $fh->print($msg); $msg = <$fh>; chomp $msg; @@ -351,6 +343,58 @@ sub putval return; } # putval +=item I<$res> = I<$self>-EB ( 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), although all fields are optional. +The returned data is in the same format as from C. + +=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>-EB () Queries a list of values from the daemon. The list is returned as an array of @@ -362,33 +406,27 @@ member of each hash holds the epoch value of the last update of that value. 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; @@ -462,7 +500,7 @@ sub putnotif . "\n"; _debug "-> $msg"; - print $fh $msg; + $fh->print($msg); $msg = <$fh>; chomp $msg; @@ -544,7 +582,7 @@ sub flush $msg .= "\n"; _debug "-> $msg"; - print $fh $msg; + $fh->print($msg); $msg = <$fh>; chomp ($msg);