Monitoring-Livestatus-0.86/0000755000175000017500000000000015010056571014445 5ustar svensvenMonitoring-Livestatus-0.86/README0000644000175000017500000000133615010055415015324 0ustar svensvenMonitoring-Livestatus ===================== Monitoring::Livestatus can be used to access the data of the check_mk Livestatus Addon for Nagios and Icinga. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES This module requires no other modules. SYNOPSIS my $ml = Monitoring::Livestatus->new( socket => '/var/lib/livestatus/livestatus.sock' ); my $hosts = $ml->selectall_arrayref("GET hosts"); AUTHOR Sven Nierlein COPYRIGHT AND LICENCE Copyright (C) 2009 by Sven Nierlein This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Monitoring-Livestatus-0.86/Changes0000644000175000017500000001153115010056505015736 0ustar svensvenRevision history for Perl extension Monitoring::Livestatus. 0.86 Sun May 11 10:18:06 CEST 2025 - improve timeout handling - improve utf8 handling - fix flaky test case (#9) 0.84 Tue Dec 15 16:53:44 CET 2020 - add support for command response - remove alarm handler, timeouts should be handled in the calling module 0.82 Sat Nov 10 12:11:31 CET 2018 - add tls support for tcp livestatus connections 0.80 Fri Jan 26 08:24:00 CET 2018 - support ipv6 connections - change to Cpanel::JSON::XS 0.78 Fri Dec 23 17:09:35 CET 2016 - fix spelling errors (#5) 0.76 Tue Sep 27 21:45:25 CEST 2016 - fix utf-8 decoding error: missing high surrogate character in surrogate pair - fixed typo - removed MULTI class 0.74 Fri Apr 22 00:16:37 CEST 2011 - fixed problem with bulk commands 0.72 Tue Apr 19 15:38:34 CEST 2011 - fixed problem with inet timeout 0.70 Sat Apr 16 16:43:57 CEST 2011 - fixed tests using english 0.68 Wed Mar 23 23:16:22 CET 2011 - fixed typo 0.66 Tue Mar 22 23:19:23 CET 2011 - added support for additonal headers 0.64 Fri Nov 5 11:02:51 CET 2010 - removed useless test dependecies 0.62 Wed Nov 3 15:20:02 CET 2010 - fixed tests with threads > 1.79 0.60 Wed Aug 25 15:04:22 CEST 2010 - fixed package and made author tests optional 0.58 Wed Aug 11 09:30:30 CEST 2010 - added callback support 0.56 Tue Aug 10 09:45:28 CEST 2010 - changed parser from csv to JSON::XS 0.54 Wed Jun 23 16:43:11 CEST 2010 - fixed utf8 support 0.52 Mon May 17 15:54:42 CEST 2010 - fixed connection timeout 0.50 Mon May 17 12:29:20 CEST 2010 - fixed test requirements 0.48 Sun May 16 15:16:12 CEST 2010 - added retry option for better core restart handling - added new columns from livestatus 1.1.4 0.46 Tue Mar 16 15:19:08 CET 2010 - error code have been changed in livestatus (1.1.3) - fixed threads support 0.44 Sun Feb 28 12:19:56 CET 2010 - fixed bug when disabling backends and using threads 0.42 Thu Feb 25 21:32:37 CET 2010 - added possibility to disable specific backends 0.41 Sat Feb 20 20:37:36 CET 2010 - fixed tests on windows 0.40 Thu Feb 11 01:00:20 CET 2010 - fixed timeout for inet sockets 0.38 Fri Jan 29 20:54:50 CET 2010 - added limit option 0.37 Thu Jan 28 21:23:19 CET 2010 - removed inc from repository 0.36 Sun Jan 24 00:14:13 CET 2010 - added more backend tests - fixed problem with summing up non numbers 0.35 Mon Jan 11 15:37:51 CET 2010 - added TCP_NODELAY option for inet sockets - fixed undefined values 0.34 Sun Jan 10 12:29:57 CET 2010 - fixed return code with multi backend and different errors 0.32 Sat Jan 9 16:12:48 CET 2010 - added deepcopy option 0.31 Thu Jan 7 08:56:48 CET 2010 - added generic tests for livestatus backend - fixed problem when selecting specific backend 0.30 Wed Jan 6 16:05:33 CET 2010 - renamed project to Monitoring::Livestatus 0.29 Mon Dec 28 00:11:53 CET 2009 - retain order of backends when merge outut - renamed select_scalar_value to selectscalar_value - fixed sums for selectscalar_value - fixed missing META.yml 0.28 Sat Dec 19 19:19:13 CET 2009 - fixed bug in column alias - added support for multiple peers - changed to Module::Install 0.26 Fri Dec 4 08:25:07 CET 2009 - added peer name - added peer arg (can be socket or server) 0.24 Wed Dec 2 23:41:34 CET 2009 - added support for StatsAnd: and StatsOr: queries - table alias support for selectall_hashref and selectrow_hashref - added support for Stats: ... as alias - added support for StatsAnd:... as alias - added support for StatsOr: ... as alias - added support for StatsGroupBy: (with alias) - added support column aliases for Column: header 0.22 Fri Nov 27 01:04:16 CET 2009 - fixed errors on socket problems - fixed sending commands 0.20 Sun Nov 22 12:41:39 CET 2009 - added keepalive support - added support for ResponseHeader: fixed16 - added error handling - added pod test - added tests with real socket / server - added column aliases - added timeout option - implemented select_scalar_value() - fixed perl::critic tests 0.18 Sat Nov 14 2009 08:58:02 GMT - fixed requirements - fixed typos 0.17 Fri Nov 13 17:15:44 CET 2009 - added support for tcp connections 0.16 Sun Nov 8 23:17:35 CET 2009 - added support for stats querys 0.15 Sat Nov 7 21:28:33 CET 2009 - fixed typos in doc - minor bugfixes 0.14 Fri Nov 6 09:39:56 CET 2009 - implemented selectcol_arrayref - implemented selectrow_array - implemented selectrow_hashref 0.13 Fri Nov 6 00:03:38 CET 2009 - fixed tests on solaris - implemented selectall_hashref() 0.12 Thu Nov 5 09:34:59 CET 2009 - fixed tests with thread support - added more tests 0.11 Wed Nov 4 23:12:16 2009 - inital working version 0.10 Tue Nov 3 17:13:16 2009 - renamed to Nagios::MKLivestatus 0.01 Tue Nov 3 00:07:46 2009 - original version; created by h2xs 1.23 with options -A -X -n Nagios::Livestatus Monitoring-Livestatus-0.86/Makefile.PL0000644000175000017500000000273215010055415016417 0ustar svensven# IMPORTANT: if you delete this file your app will not work as # expected. you have been warned use inc::Module::Install; name 'Monitoring-Livestatus'; all_from 'lib/Monitoring/Livestatus.pm'; perl_version '5.006'; license 'perl'; resources( 'homepage', => 'http://search.cpan.org/dist/Monitoring-Livestatus/', 'bugtracker' => 'http://github.com/sni/Monitoring-Livestatus/issues', 'repository', => 'http://github.com/sni/Monitoring-Livestatus', ); requires 'IO::Socket::UNIX'; requires 'IO::Socket::IP'; requires 'IO::Select'; requires 'Test::More' => '0.87'; requires 'utf8'; requires 'Encode'; requires 'Cpanel::JSON::XS'; # test requirements # these requirements still make it into the META.yml, so they are commented so far #feature ('authortests', # -default => 0, # 'File::Copy::Recursive' => 0, # 'Test::Pod' => 1.14, # 'Test::Perl::Critic' => 0, # 'Test::Pod::Coverage' => 0, # 'Perl::Critic::Policy::Dynamic::NoIndirect' => 0, # 'Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseSubs' => 0, # 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitAccessOfPrivateData' => 0, #); auto_install; WriteAll; Monitoring-Livestatus-0.86/examples/0000755000175000017500000000000015010056571016263 5ustar svensvenMonitoring-Livestatus-0.86/examples/dump.pl0000755000175000017500000000402015010055415017560 0ustar svensven#!/usr/bin/env perl =head1 NAME dump.pl - print some information from a socket =head1 SYNOPSIS ./dump.pl [ -h ] [ -v ] =head1 DESCRIPTION this script print some information from a given livestatus socket or server =head1 ARGUMENTS script has the following arguments =over 4 =item help -h print help and exit =item verbose -v verbose output =item socket/server server local socket file or server remote address of livestatus =back =head1 EXAMPLE ./dump.pl /tmp/live.sock =head1 AUTHOR 2009, Sven Nierlein, =cut use warnings; use strict; use Data::Dumper; use Getopt::Long; use Pod::Usage; use lib 'lib'; use lib '../lib'; use Monitoring::Livestatus; $Data::Dumper::Sortkeys = 1; ######################################################################### # parse and check cmd line arguments my ($opt_h, $opt_v, $opt_f); Getopt::Long::Configure('no_ignore_case'); if(!GetOptions ( "h" => \$opt_h, "v" => \$opt_v, "<>" => \&add_file, )) { pod2usage( { -verbose => 1, -message => 'error in options' } ); exit 3; } if(defined $opt_h) { pod2usage( { -verbose => 1 } ); exit 3; } my $verbose = 0; if(defined $opt_v) { $verbose = 1; } if(!defined $opt_f) { pod2usage( { -verbose => 1, -message => 'socket/server is a required option' } ); exit 3; } ######################################################################### my $nl = Monitoring::Livestatus->new( peer => $opt_f, verbose => $opt_v ); ######################################################################### #my $hosts = $nl->selectall_hashref('GET hosts', 'name'); #print Dumper($hosts); ######################################################################### my $services = $nl->selectall_arrayref("GET services\nColumns: description host_name state\nLimit: 2", { Slice => {}}); print Dumper($services); ######################################################################### sub add_file { my $file = shift; $opt_f = $file; } Monitoring-Livestatus-0.86/examples/test.pl0000755000175000017500000000703215010055415017600 0ustar svensven#!/usr/bin/env perl =head1 NAME test.pl - print some information from a socket =head1 SYNOPSIS ./test.pl [ -h ] [ -v ] =head1 DESCRIPTION this script print some information from a given livestatus socket or server =head1 ARGUMENTS script has the following arguments =over 4 =item help -h print help and exit =item verbose -v verbose output =item socket/server server local socket file or server remote address of livestatus =back =head1 EXAMPLE ./test.pl /tmp/live.sock =head1 AUTHOR 2009, Sven Nierlein, =cut use warnings; use strict; use Data::Dumper; use Getopt::Long; use Pod::Usage; use Time::HiRes qw( gettimeofday tv_interval ); use Log::Log4perl qw(:easy); use lib 'lib'; use lib '../lib'; use Monitoring::Livestatus; $Data::Dumper::Sortkeys = 1; ######################################################################### # parse and check cmd line arguments my ($opt_h, $opt_v, @opt_f); Getopt::Long::Configure('no_ignore_case'); if(!GetOptions ( "h" => \$opt_h, "v" => \$opt_v, "<>" => \&add_file, )) { pod2usage( { -verbose => 1, -message => 'error in options' } ); exit 3; } if(defined $opt_h) { pod2usage( { -verbose => 1 } ); exit 3; } my $verbose = 0; if(defined $opt_v) { $verbose = 1; } if(scalar @opt_f == 0) { pod2usage( { -verbose => 1, -message => 'socket/server is a required option' } ); exit 3; } ######################################################################### Log::Log4perl->easy_init($DEBUG); my $nl = Monitoring::Livestatus->new( peer => \@opt_f, verbose => $opt_v, timeout => 5, keepalive => 1, logger => get_logger(), ); my $log = get_logger(); ######################################################################### my $querys = [ { 'query' => "GET hostgroups\nColumns: members\nFilter: name = flap\nFilter: name = down\nOr: 2", 'sub' => "selectall_arrayref", 'opt' => {Slice => 1 } }, # { 'query' => "GET comments", # 'sub' => "selectall_arrayref", # 'opt' => {Slice => 1 } # }, # { 'query' => "GET downtimes", # 'sub' => "selectall_arrayref", # 'opt' => {Slice => 1, Sum => 1} # }, # { 'query' => "GET log\nFilter: time > ".(time() - 600)."\nLimit: 1", # 'sub' => "selectall_arrayref", # 'opt' => {Slice => 1, AddPeer => 1} # }, # { 'query' => "GET services\nFilter: contacts >= test\nFilter: host_contacts >= test\nOr: 2\nColumns: host_name description contacts host_contacts", # 'sub' => "selectall_arrayref", # 'opt' => {Slice => 1, AddPeer => 0} # }, # { 'query' => "GET services\nFilter: host_name = test_host_00\nFilter: description = test_flap_02\nOr: 2\nColumns: host_name description contacts host_contacts", # 'sub' => "selectall_arrayref", # 'opt' => {Slice => 1, AddPeer => 0} # }, ]; for my $query (@{$querys}) { my $sub = $query->{'sub'}; my $t0 = [gettimeofday]; my $stats = $nl->$sub($query->{'query'}, $query->{'opt'}); my $elapsed = tv_interval($t0); print Dumper($stats); print "Query took ".($elapsed)." seconds\n"; } ######################################################################### sub add_file { my $file = shift; push @opt_f, $file; } Monitoring-Livestatus-0.86/lib/0000755000175000017500000000000015010056571015213 5ustar svensvenMonitoring-Livestatus-0.86/lib/Monitoring/0000755000175000017500000000000015010056571017340 5ustar svensvenMonitoring-Livestatus-0.86/lib/Monitoring/Livestatus.pm0000644000175000017500000013073115010056463022046 0ustar svensvenpackage Monitoring::Livestatus; use warnings; use strict; use Carp qw/carp confess/; use Cpanel::JSON::XS (); use Data::Dumper qw/Dumper/; use IO::Select (); use Storable qw/dclone/; use Monitoring::Livestatus::INET (); use Monitoring::Livestatus::UNIX (); our $VERSION = '0.86'; # list of allowed options my $allowed_options = { 'addpeer' => 1, 'backend' => 1, 'columns' => 1, 'deepcopy' => 1, 'header' => 1, 'limit' => 1, 'limit_start' => 1, 'limit_length' => 1, 'rename' => 1, 'slice' => 1, 'sum' => 1, 'callbacks' => 1, 'wrapped_json' => 1, 'sort' => 1, 'offset' => 1, }; =head1 NAME Monitoring::Livestatus - Perl API for check_mk livestatus to access runtime data from Nagios and Icinga =head1 SYNOPSIS use Monitoring::Livestatus; my $ml = Monitoring::Livestatus->new( socket => '/var/lib/livestatus/livestatus.sock' ); my $hosts = $ml->selectall_arrayref("GET hosts"); =head1 DESCRIPTION This module connects via socket/tcp to the livestatus addon for Naemon, Nagios, Icinga and Shinken. You first have to install and activate the livestatus addon in your monitoring installation. =head1 CONSTRUCTOR =head2 new ( [ARGS] ) Creates an C object. C takes at least the socketpath. Arguments are in key-value pairs. =over 4 =item socket path to the UNIX socket of check_mk livestatus =item server server address when using a TCP connection =item peer alternative way to set socket or server, if value contains ':' server is used, else socket =item name human readable name for this connection, defaults to the the socket/server address =item verbose verbose mode =item line_separator ascii code of the line separator, defaults to 10, (newline) =item column_separator ascii code of the column separator, defaults to 0 (null byte) =item list_separator ascii code of the list separator, defaults to 44 (comma) =item host_service_separator ascii code of the host/service separator, defaults to 124 (pipe) =item keepalive enable keepalive. Default is off =item errors_are_fatal errors will die with an error message. Default: on =item warnings show warnings currently only querys without Columns: Header will result in a warning =item timeout set a general timeout. Used for connect and querys, no default =item query_timeout set a query timeout. Used for retrieving querys, Default 60sec =item connect_timeout set a connect timeout. Used for initial connections, default 5sec =back If the constructor is only passed a single argument, it is assumed to be a the C specification. Use either socker OR server. =cut sub new { my($class,@args) = @_; unshift(@args, 'peer') if scalar @args == 1; my(%options) = @args; my $self = { 'verbose' => 0, # enable verbose output 'socket' => undef, # use unix sockets 'server' => undef, # use tcp connections 'peer' => undef, # use for socket / server connections 'name' => undef, # human readable name 'line_separator' => 10, # defaults to newline 'column_separator' => 0, # defaults to null byte 'list_separator' => 44, # defaults to comma 'host_service_separator' => 124, # defaults to pipe 'keepalive' => 0, # enable keepalive? 'errors_are_fatal' => 1, # die on errors 'backend' => undef, # should be keept undef, used internally 'timeout' => undef, # timeout for tcp connections 'query_timeout' => undef, # query timeout for tcp connections 'connect_timeout' => 30, # connect timeout for tcp connections 'warnings' => 1, # show warnings, for example on querys without Column: Header 'logger' => undef, # logger object used for statistical informations and errors / warnings 'deepcopy' => undef, # copy result set to avoid errors with tied structures 'retries_on_connection_error' => 3, # retry x times to connect 'retry_interval' => 1, # retry after x seconds # tls options 'cert' => undef, 'key' => undef, 'ca_file' => undef, 'verify' => undef, 'verifycn_name' => undef, }; my %old_key = ( line_seperator => 'line_separator', column_seperator => 'column_separator', list_seperator => 'list_separator', host_service_seperator => 'host_service_separator', ); # previous versions had spelling errors in the key name for my $opt_key (keys %old_key) { if(exists $options{$opt_key}) { my $value = $options{$opt_key}; $options{ $old_key{$opt_key} } = $value; delete $options{$opt_key}; } } for my $opt_key (keys %options) { if(exists $self->{$opt_key}) { $self->{$opt_key} = $options{$opt_key}; } else { confess("unknown option: $opt_key"); } } if($self->{'verbose'} && !defined $self->{'logger'}) { confess('please specify a logger object when using verbose mode'); } # setting a general timeout? if(defined $self->{'timeout'}) { $self->{'query_timeout'} = $self->{'timeout'}; $self->{'connect_timeout'} = $self->{'timeout'}; } bless $self, $class; # set our peer(s) from the options my $peer = $self->_get_peer(); if(!defined $self->{'backend'}) { $options{'name'} = $peer->{'name'}; $options{'peer'} = $peer->{'peer'}; if($peer->{'type'} eq 'UNIX') { $self->{'CONNECTOR'} = Monitoring::Livestatus::UNIX->new(%options); } elsif($peer->{'type'} eq 'INET') { $self->{'CONNECTOR'} = Monitoring::Livestatus::INET->new(%options); } $self->{'peer'} = $peer->{'peer'}; } # set names and peer for non multi backends if(defined $self->{'CONNECTOR'}->{'name'} && !defined $self->{'name'}) { $self->{'name'} = $self->{'CONNECTOR'}->{'name'}; } if(defined $self->{'CONNECTOR'}->{'peer'} && !defined $self->{'peer'}) { $self->{'peer'} = $self->{'CONNECTOR'}->{'peer'}; } return $self; } ######################################## =head1 METHODS =head2 do do($statement) do($statement, %opts) Send a single statement without fetching the result. Always returns true. =cut sub do { my($self, $statement, $opt) = @_; $self->_send($statement, $opt); return(1); } ######################################## =head2 selectall_arrayref selectall_arrayref($statement) selectall_arrayref($statement, %opts) selectall_arrayref($statement, %opts, $limit ) Sends a query and returns an array reference of arrays my $arr_refs = $ml->selectall_arrayref("GET hosts"); to get an array of hash references do something like my $hash_refs = $ml->selectall_arrayref( "GET hosts", { Slice => {} } ); to get an array of hash references from the first 2 returned rows only my $hash_refs = $ml->selectall_arrayref( "GET hosts", { Slice => {} }, 2 ); you may use limit to limit the result to this number of rows column aliases can be defined with a rename hash my $hash_refs = $ml->selectall_arrayref( "GET hosts", { Slice => {}, rename => { 'name' => 'host_name' } } ); =cut sub selectall_arrayref { my($self, $statement, $opt, $limit, $result) = @_; $limit = 0 unless defined $limit; # make opt hash keys lowercase $opt = &_lowercase_and_verify_options($self, $opt) unless $result; $self->_log_statement($statement, $opt, $limit) if !$result && $self->{'verbose'}; if(!defined $result) { $result = &_send($self, $statement, $opt); if(!defined $result) { return unless $self->{'errors_are_fatal'}; confess("got undef result for: $statement"); } } # trim result set down to excepted row count if(!$opt->{'offset'} && defined $limit && $limit >= 1) { if(scalar @{$result->{'result'}} > $limit) { @{$result->{'result'}} = @{$result->{'result'}}[0..$limit-1]; } } if($opt->{'slice'}) { my $callbacks = $opt->{'callbacks'}; # make an array of hashes, inplace to safe memory my $keys = $result->{'keys'}; # renamed columns if($opt->{'rename'}) { $keys = dclone($result->{'keys'}); my $keysize = scalar @{$keys}; for(my $x=0; $x<$keysize;$x++) { my $old = $keys->[$x]; if($opt->{'rename'}->{$old}) { $keys->[$x] = $opt->{'rename'}->{$old}; } } } $result = $result->{'result'}; my $rnum = scalar @{$result}; for(my $x=0;$x<$rnum;$x++) { # sort array into hash slices my %hash; @hash{@{$keys}} = @{$result->[$x]}; # add callbacks if($callbacks) { for my $key (keys %{$callbacks}) { $hash{$key} = $callbacks->{$key}->(\%hash); } } $result->[$x] = \%hash; } return($result); } if(exists $opt->{'callbacks'}) { for my $res (@{$result->{'result'}}) { # add callbacks if(exists $opt->{'callbacks'}) { for my $key (keys %{$opt->{'callbacks'}}) { push @{$res}, $opt->{'callbacks'}->{$key}->($res); } } } for my $key (keys %{$opt->{'callbacks'}}) { push @{$result->{'keys'}}, $key; } } return($result->{'result'}); } ######################################## =head2 selectall_hashref selectall_hashref($statement, $key_field) selectall_hashref($statement, $key_field, %opts) Sends a query and returns a hashref with the given key my $hashrefs = $ml->selectall_hashref("GET hosts", "name"); =cut sub selectall_hashref { my($self, $statement, $key_field, $opt) = @_; $opt = &_lowercase_and_verify_options($self, $opt); $opt->{'slice'} = 1; confess('key is required for selectall_hashref') if !defined $key_field; my $result = $self->selectall_arrayref($statement, $opt); my %indexed; for my $row (@{$result}) { if($key_field eq '$peername') { $indexed{$self->peer_name} = $row; } elsif(!defined $row->{$key_field}) { my %possible_keys = keys %{$row}; confess("key $key_field not found in result set, possible keys are: ".join(', ', sort keys %possible_keys)); } else { $indexed{$row->{$key_field}} = $row; } } return(\%indexed); } ######################################## =head2 selectcol_arrayref selectcol_arrayref($statement) selectcol_arrayref($statement, %opt ) Sends a query an returns an arrayref for the first columns my $array_ref = $ml->selectcol_arrayref("GET hosts\nColumns: name"); $VAR1 = [ 'localhost', 'gateway', ]; returns an empty array if nothing was found to get a different column use this my $array_ref = $ml->selectcol_arrayref( "GET hosts\nColumns: name contacts", { Columns => [2] } ); you can link 2 columns in a hash result set my %hash = @{ $ml->selectcol_arrayref( "GET hosts\nColumns: name contacts", { Columns => [1,2] } ) }; produces a hash with host the contact assosiation $VAR1 = { 'localhost' => 'user1', 'gateway' => 'user2' }; =cut sub selectcol_arrayref { my($self, $statement, $opt) = @_; # make opt hash keys lowercase $opt = &_lowercase_and_verify_options($self, $opt); # if now colums are set, use just the first one if(!defined $opt->{'columns'} || ref $opt->{'columns'} ne 'ARRAY') { @{$opt->{'columns'}} = qw{1}; } my $result = $self->selectall_arrayref($statement); my @column; for my $row (@{$result}) { for my $nr (@{$opt->{'columns'}}) { push @column, $row->[$nr-1]; } } return(\@column); } ######################################## =head2 selectrow_array selectrow_array($statement) selectrow_array($statement, %opts) Sends a query and returns an array for the first row my @array = $ml->selectrow_array("GET hosts"); returns undef if nothing was found =cut sub selectrow_array { my($self, $statement, $opt) = @_; # make opt hash keys lowercase $opt = &_lowercase_and_verify_options($self, $opt); my @result = @{$self->selectall_arrayref($statement, $opt, 1)}; return @{$result[0]} if scalar @result > 0; return; } ######################################## =head2 selectrow_arrayref selectrow_arrayref($statement) selectrow_arrayref($statement, %opts) Sends a query and returns an array reference for the first row my $arrayref = $ml->selectrow_arrayref("GET hosts"); returns undef if nothing was found =cut sub selectrow_arrayref { my($self, $statement, $opt) = @_; # make opt hash keys lowercase $opt = &_lowercase_and_verify_options($self, $opt); my $result = $self->selectall_arrayref($statement, $opt, 1); return if !defined $result; return $result->[0] if scalar @{$result} > 0; return; } ######################################## =head2 selectrow_hashref selectrow_hashref($statement) selectrow_hashref($statement, %opt) Sends a query and returns a hash reference for the first row my $hashref = $ml->selectrow_hashref("GET hosts"); returns undef if nothing was found =cut sub selectrow_hashref { my($self, $statement, $opt) = @_; # make opt hash keys lowercase $opt = &_lowercase_and_verify_options($self, $opt); $opt->{slice} = 1; my $result = $self->selectall_arrayref($statement, $opt, 1); return if !defined $result; return $result->[0] if scalar @{$result} > 0; return; } ######################################## =head2 selectscalar_value selectscalar_value($statement) selectscalar_value($statement, %opt) Sends a query and returns a single scalar my $count = $ml->selectscalar_value("GET hosts\nStats: state = 0"); returns undef if nothing was found =cut sub selectscalar_value { my($self, $statement, $opt) = @_; # make opt hash keys lowercase $opt = &_lowercase_and_verify_options($self, $opt); my $row = $self->selectrow_arrayref($statement); return if !defined $row; return $row->[0] if scalar @{$row} > 0; return; } ######################################## =head2 errors_are_fatal errors_are_fatal() errors_are_fatal($value) Enable or disable fatal errors. When enabled the module will confess on any error. returns the current setting if called without new value =cut sub errors_are_fatal { my($self, $value) = @_; my $old = $self->{'errors_are_fatal'}; $self->{'errors_are_fatal'} = $value; $self->{'CONNECTOR'}->{'errors_are_fatal'} = $value if defined $self->{'CONNECTOR'}; return $old; } ######################################## =head2 warnings warnings() warnings($value) Enable or disable warnings. When enabled the module will carp on warnings. returns the current setting if called without new value =cut sub warnings { my($self, $value) = @_; my $old = $self->{'warnings'}; $self->{'warnings'} = $value; $self->{'CONNECTOR'}->{'warnings'} = $value if defined $self->{'CONNECTOR'}; return $old; } ######################################## =head2 verbose verbose() verbose($values) Enable or disable verbose output. When enabled the module will dump out debug output returns the current setting if called without new value =cut sub verbose { my($self, $value) = @_; my $old = $self->{'verbose'}; $self->{'verbose'} = $value; $self->{'CONNECTOR'}->{'verbose'} = $value if defined $self->{'CONNECTOR'}; return $old; } ######################################## =head2 peer_addr $ml->peer_addr() returns the current peer address when using multiple backends, a list of all addresses is returned in list context =cut sub peer_addr { my($self) = @_; return ''.$self->{'peer'}; } ######################################## =head2 peer_name $ml->peer_name() $ml->peer_name($string) if new value is set, name is set to this value always returns the current peer name when using multiple backends, a list of all names is returned in list context =cut sub peer_name { my($self, $value) = @_; if(defined $value and $value ne '') { $self->{'name'} = $value; } return ''.$self->{'name'}; } ######################################## =head2 peer_key $ml->peer_key() returns a uniq key for this peer =cut sub peer_key { my($self) = @_; return $self->{'key'}; } ######################################## # INTERNAL SUBS ######################################## sub _send { my($self, $statement, $opt) = @_; confess('duplicate data') if $opt->{'data'}; delete $self->{'meta_data'}; my $header = ''; my $keys; $Monitoring::Livestatus::ErrorCode = 0; undef $Monitoring::Livestatus::ErrorMessage; return(490, $self->_get_error(490), undef) if !defined $statement; chomp($statement); my($status,$msg,$body); if($statement =~ m/^Separators:/mx) { $status = 492; $msg = $self->_get_error($status); } elsif($statement =~ m/^KeepAlive:/mx) { $status = 496; $msg = $self->_get_error($status); } elsif($statement =~ m/^ResponseHeader:/mx) { $status = 495; $msg = $self->_get_error($status); } elsif($statement =~ m/^ColumnHeaders:/mx) { $status = 494; $msg = $self->_get_error($status); } elsif($statement =~ m/^OuputFormat:/mx) { $status = 493; $msg = $self->_get_error($status); } # should be cought in mlivestatus directly elsif($statement =~ m/^Limit:\ (.*)$/mx and $1 !~ m/^\d+$/mx) { $status = 403; $msg = $self->_get_error($status); } elsif($statement =~ m/^GET\ (.*)$/mx and $1 =~ m/^\s*$/mx) { $status = 403; $msg = $self->_get_error($status); } elsif($statement =~ m/^Columns:\ (.*)$/mx and ($1 =~ m/,/mx or $1 =~ /^\s*$/mx)) { $status = 405; $msg = $self->_get_error($status); } elsif($statement !~ m/^GET\ /mx and $statement !~ m/^COMMAND\ /mx) { $status = 401; $msg = $self->_get_error($status); } else { # Add Limits header if(defined $opt->{'limit_start'}) { $statement .= "\nLimit: ".($opt->{'limit_start'} + $opt->{'limit_length'}); } # for querys with column header, no seperate columns will be returned if($statement =~ m/^Columns:\ (.*)$/mx) { ($statement,$keys) = $self->_extract_keys_from_columns_header($statement); } if($statement =~ m/^Stats:\ (.*)$/mx or $statement =~ m/^StatsGroupBy:\ (.*)$/mx) { my $has_columns = defined $keys ? join(",", @{$keys}) : undef; ($statement,$keys) = extract_keys_from_stats_statement($statement); unshift @{$keys}, $has_columns if $has_columns; } # Offset header (currently naemon only) if(defined $opt->{'offset'}) { $statement .= "\nOffset: ".$opt->{'offset'}; } # Sort header (currently naemon only) if(defined $opt->{'sort'}) { for my $sort (@{$opt->{'sort'}}) { $statement .= "\nSort: ".$sort; } } # Commands need no additional header if($statement !~ m/^COMMAND/mx) { if($opt->{'wrapped_json'}) { $header .= "OutputFormat: wrapped_json\n"; } else { $header .= "OutputFormat: json\n"; } $header .= "ResponseHeader: fixed16\n"; if($self->{'keepalive'}) { $header .= "KeepAlive: on\n"; } # remove empty lines from statement $statement =~ s/\n+/\n/gmx; } # add additional headers if(defined $opt->{'header'} and ref $opt->{'header'} eq 'HASH') { for my $key ( keys %{$opt->{'header'}}) { $header .= $key.': '.$opt->{'header'}->{$key}."\n"; } } chomp($statement); my $send = "$statement\n$header"; $self->{'logger'}->debug('> '.Dumper($send)) if $self->{'verbose'}; ($status,$msg,$body) = &_send_socket($self, $send); if($self->{'verbose'}) { #$self->{'logger'}->debug("got:"); #$self->{'logger'}->debug(Dumper(\@erg)); $self->{'logger'}->debug('status: '.Dumper($status)); $self->{'logger'}->debug('msg: '.Dumper($msg)); $self->{'logger'}->debug('< '.Dumper($body)); } } if(!$status || $status >= 300) { $body = '' if !defined $body; $status = 300 if !defined $status; chomp($body); $Monitoring::Livestatus::ErrorCode = $status; if(defined $body and $body ne '') { $Monitoring::Livestatus::ErrorMessage = $body; } else { $Monitoring::Livestatus::ErrorMessage = $msg; } $self->{'logger'}->error($status.' - '.$Monitoring::Livestatus::ErrorMessage." in query:\n".$statement) if $self->{'verbose'}; if($self->{'errors_are_fatal'}) { confess('ERROR '.$status.' - '.$Monitoring::Livestatus::ErrorMessage." in query:\n".$statement."\n"); } return; } # return a empty result set if nothing found return({ keys => [], result => []}) if !defined $body; # body is already parsed my $result; if($status == 200) { $result = $body; } else { my $json_decoder = Cpanel::JSON::XS->new->utf8->relaxed; # fix json output eval { $result = $json_decoder->decode($body); }; # fix low/high surrogate errors # missing high surrogate character in surrogate pair # surrogate pair expected if($@) { # replace u+D800 to u+DFFF (reserved utf-16 low/high surrogates) $body =~ s/\\ud[89a-f][0-9a-f]{2}/\\ufffd/gmxio; eval { $result = $json_decoder->decode($body); }; } if($@) { my $message = 'ERROR '.$@." in text: '".$body."'\" for statement: '$statement'\n"; $self->{'logger'}->error($message) if $self->{'verbose'}; if($self->{'errors_are_fatal'}) { confess($message); } return({ keys => [], result => []}); } } if(!defined $result) { my $message = "ERROR undef result for text: '".$body."'\" for statement: '$statement'\n"; $self->{'logger'}->error($message) if $self->{'verbose'}; if($self->{'errors_are_fatal'}) { confess($message); } return({ keys => [], result => []}); } # for querys with column header, no separate columns will be returned if(!defined $keys) { $self->{'logger'}->warn('got statement without Columns: header!') if $self->{'verbose'}; if($self->{'warnings'}) { carp('got statement without Columns: header! -> '.$statement); } $keys = shift @{$result}; } return(&post_processing($self, $result, $opt, $keys)); } ######################################## =head2 post_processing $ml->post_processing($result, $options, $keys) returns postprocessed result. Useful when using select based io. =cut sub post_processing { my($self, $result, $opt, $keys) = @_; my $orig_result; if($opt->{'wrapped_json'}) { $orig_result = $result; $result = delete $orig_result->{'data'}; } # add peer information? my $with_peers = 0; if(defined $opt->{'addpeer'} and $opt->{'addpeer'}) { $with_peers = 1; } if(defined $with_peers and $with_peers == 1) { my $peer_name = $self->peer_name; my $peer_addr = $self->peer_addr; my $peer_key = $self->peer_key; unshift @{$keys}, 'peer_name'; unshift @{$keys}, 'peer_addr'; unshift @{$keys}, 'peer_key'; for my $row (@{$result}) { unshift @{$row}, $peer_name; unshift @{$row}, $peer_addr; unshift @{$row}, $peer_key; } } # set some metadata $self->{'meta_data'} = { 'result_count' => scalar @{$result}, }; if($opt->{'wrapped_json'}) { $self->{'meta_data'} = $orig_result; } return({ keys => $keys, result => $result }); } ######################################## sub _open { my($self) = @_; # return the current socket in keep alive mode if($self->{'keepalive'} and defined $self->{'sock'} and $self->{'sock'}->connected) { $self->{'logger'}->debug('reusing old connection') if $self->{'verbose'}; return($self->{'sock'}); } my $sock = $self->{'CONNECTOR'}->_open(); # store socket for later retrieval if($self->{'keepalive'}) { $self->{'sock'} = $sock; } $self->{'logger'}->debug('using new connection') if $self->{'verbose'}; return($sock); } ######################################## sub _close { my($self) = @_; my $sock = delete $self->{'sock'}; return($self->{'CONNECTOR'}->_close($sock)); } ######################################## =head1 QUERY OPTIONS In addition to the normal query syntax from the livestatus addon, it is possible to set column aliases in various ways. =head2 AddPeer adds the peers name, addr and key to the result set: my $hosts = $ml->selectall_hashref( "GET hosts\nColumns: name alias state", "name", { AddPeer => 1 } ); =head2 Backend send the query only to some specific backends. Only useful when using multiple backends. my $hosts = $ml->selectall_arrayref( "GET hosts\nColumns: name alias state", { Backends => [ 'key1', 'key4' ] } ); =head2 Columns only return the given column indexes my $array_ref = $ml->selectcol_arrayref( "GET hosts\nColumns: name contacts", { Columns => [2] } ); see L for more examples =head2 Deepcopy deep copy/clone the result set. Only effective when using multiple backends and threads. This can be safely turned off if you don't change the result set. If you get an error like "Invalid value for shared scalar" error" this should be turned on. my $array_ref = $ml->selectcol_arrayref( "GET hosts\nColumns: name contacts", { Deepcopy => 1 } ); =head2 Limit Just like the Limit: option from livestatus itself. In addition you can add a start,length limit. my $array_ref = $ml->selectcol_arrayref( "GET hosts\nColumns: name contacts", { Limit => "10,20" } ); This example will return 20 rows starting at row 10. You will get row 10-30. Cannot be combined with a Limit inside the query because a Limit will be added automatically. Adding a limit this way will greatly increase performance and reduce memory usage. This option is multibackend safe contrary to the "Limit: " part of a statement. Sending a statement like "GET...Limit: 10" with 3 backends will result in 30 rows. Using this options, you will receive only the first 10 rows. =head2 Rename see L for detailed explainaton =head2 Slice see L for detailed explainaton =head2 Sum The Sum option only applies when using multiple backends. The values from all backends with be summed up to a total. my $stats = $ml->selectrow_hashref( "GET hosts\nStats: state = 0\nStats: state = 1", { Sum => 1 } ); =cut ######################################## # wrapper around _send_socket_do sub _send_socket { my($self, $statement) = @_; my $retries = 0; my($status, $msg, $recv, $sock); # closing a socket sends SIGPIPE to reader # https://riptutorial.com/posix/example/17424/handle-sigpipe-generated-by-write---in-a-thread-safe-manner local $SIG{PIPE} = 'IGNORE'; my $maxretries = $ENV{'LIVESTATUS_RETRIES'} // $self->{'retries_on_connection_error'}; # try to avoid connection errors eval { if($maxretries <= 0) { ($sock, $msg, $recv) = &_send_socket_do($self, $statement); return($sock, $msg, $recv) if $msg; ($status, $msg, $recv) = &_read_socket_do($self, $sock, $statement); return($status, $msg, $recv); } while((!defined $status || ($status == 491 || $status == 497 || $status == 500)) && $retries < $maxretries) { $retries++; ($sock, $msg, $recv) = &_send_socket_do($self, $statement); return($status, $msg, $recv) if $msg; ($status, $msg, $recv) = &_read_socket_do($self, $sock, $statement); $self->{'logger'}->debug('query status '.$status) if $self->{'verbose'}; if($status == 491 or $status == 497 or $status == 500) { $self->{'logger'}->debug('got status '.$status.' retrying in '.$self->{'retry_interval'}.' seconds') if $self->{'verbose'}; $self->_close(); sleep($self->{'retry_interval'}) if $retries < $maxretries; } } }; my $err = $@; if($err) { $self->{'logger'}->debug("try 1 failed: $err") if $self->{'verbose'}; if($err =~ /broken\ pipe/mx) { ($sock, $msg, $recv) = &_send_socket_do($self, $statement); return($status, $msg, $recv) if $msg; return(&_read_socket_do($self, $sock, $statement)); } _die_or_confess($err) if $self->{'errors_are_fatal'}; } $status = $sock unless $status; $msg =~ s/^$status:\s+//gmx; _die_or_confess($status.": ".$msg) if($status >= 400 and $self->{'errors_are_fatal'}); return($status, $msg, $recv); } ######################################## sub _send_socket_do { my($self, $statement) = @_; my $sock = $self->_open() or return(491, $self->_get_error(491, $@ || $!), $@ || $!); utf8::decode($statement); # make sure utf8::encode($statement); # query is utf8 $sock->printflush($statement,"\n") || return($self->_socket_error($statement, 'write to socket failed'.($! ? ': '.$! : ''))); return $sock; } ######################################## sub _read_socket_do { my($self, $sock, $statement) = @_; my($recv,$header); my $s = IO::Select->new(); $s->add($sock); # COMMAND statements might return a error message if($statement && $statement =~ m/^COMMAND/mx) { shutdown($sock, 1); if($s->can_read(3)) { $recv = <$sock>; } if($recv) { chomp($recv); if($recv =~ m/^(\d+):\s*(.*)$/mx) { return($1, $recv, undef); } return('400', $self->_get_error(400), $recv); } return('200', $self->_get_error(200), undef); } my $timeout = 180; if($statement) { # status requests should not take longer than 20 seconds $timeout = 20 if($statement =~ m/^GET\s+status/mx); $timeout = 300 if($statement =~ m/^GET\s+log/mx); } $timeout = $self->{'query_timeout'} if $self->{'query_timeout'}; local $! = undef; my @ready = $s->can_read($timeout); if(scalar @ready == 0) { my $err = $!; if($err) { return($self->_socket_error($statement, 'socket error '.$err)); } return($self->_socket_error($statement, 'timeout ('.$timeout.'s) while waiting for socket')); } $sock->read($header, 16) || return($self->_socket_error($statement, 'reading header from socket failed'.($! ? ': '.$! : ''))); $self->{'logger'}->debug("header: $header") if $self->{'verbose'}; my($status, $msg, $content_length) = &_parse_header($self, $header, $sock); return($status, $msg, undef) if !defined $content_length; our $json_decoder; if($json_decoder) { $json_decoder->incr_reset; } else { $json_decoder = Cpanel::JSON::XS->new->utf8->relaxed; } if($content_length > 0) { if($status == 200) { my $remaining = $content_length; my $length = 32768; if($remaining < $length) { $length = $remaining; } while($length > 0 && $sock->read(my $buf, $length)) { # replace u+D800 to u+DFFF (reserved utf-16 low/high surrogates) $buf =~ s/\\ud[89a-f][0-9a-f]{2}/\\ufffd/gmxio; $json_decoder->incr_parse($buf); $remaining = $remaining -$length; if($remaining < $length) { $length = $remaining; } } $recv = $json_decoder->incr_parse or return($self->_socket_error($statement, 'reading remaining '.$length.' bytes from socket failed'.($! ? ': '.$! : ''))); $json_decoder->incr_reset; } else { $sock->read($recv, $content_length) or return($self->_socket_error($statement, 'reading body from socket failed'.($! ? ': '.$! : ''))); } } $self->_close() unless $self->{'keepalive'}; if($status >= 400 && $recv) { $msg .= ' - '.$recv; } return($status, $msg, $recv); } ######################################## sub _socket_error { my($self, $statement, $err) = @_; my $message = "\n"; $message .= "peer ".Dumper($self->peer_name); $message .= "statement ".Dumper($statement); $self->{'logger'}->error($message) if $self->{'verbose'}; if($self->{'retries_on_connection_error'} <= 0) { if($self->{'errors_are_fatal'}) { _die_or_confess($message); } else { carp($message); } } $self->_close(); return(500, $self->_get_error(500).($err ? " - ".$err : ""), $message); } ######################################## sub _parse_header { my($self, $header, $sock) = @_; if(!defined $header) { return(497, $self->_get_error(497), undef); } my $headerlength = length($header); if($headerlength != 16) { return(498, $self->_get_error(498)."\ngot: ".$header.<$sock>, undef); } chomp($header); my $status = substr($header,0,3); my $content_length = substr($header,5); if($content_length !~ m/^\s*(\d+)$/mx) { return(499, $self->_get_error(499)."\ngot: ".$header.<$sock>, undef); } else { $content_length = $1; } return($status, $self->_get_error($status), $content_length); } ######################################## =head1 COLUMN ALIAS In addition to the normal query syntax from the livestatus addon, it is possible to set column aliases in various ways. A valid Columns: Header could look like this: my $hosts = $ml->selectall_arrayref( "GET hosts\nColumns: state as status" ); Stats queries could be aliased too: my $stats = $ml->selectall_arrayref( "GET hosts\nStats: state = 0 as up" ); This syntax is available for: Stats, StatsAnd, StatsOr and StatsGroupBy An alternative way to set column aliases is to define rename option key/value pairs: my $hosts = $ml->selectall_arrayref( "GET hosts\nColumns: name", { rename => { 'name' => 'hostname' } } ); =cut ######################################## =head2 extract_keys_from_stats_statement extract_keys_from_stats_statement($statement) Extract column keys from statement. =cut sub extract_keys_from_stats_statement { my($statement) = @_; my(@header, $new_statement); for my $line (split/\n/mx, $statement) { if(substr($line, 0, 5) ne 'Stats') { # faster shortcut for non-stats lines $new_statement .= $line."\n"; next; } if($line =~ m/^Stats:\ (.*)\s+as\s+(.*?)$/mxo) { push @header, $2; $line = 'Stats: '.$1; } elsif($line =~ m/^Stats:\ (.*)$/mxo) { push @header, $1; } elsif($line =~ m/^StatsAnd:\ (\d+)\s+as\s+(.*?)$/mxo) { for(my $x = 0; $x < $1; $x++) { pop @header; } $line = 'StatsAnd: '.$1; push @header, $2; } elsif($line =~ m/^StatsAnd:\ (\d+)$/mxo) { my @to_join; for(my $x = 0; $x < $1; $x++) { unshift @to_join, pop @header; } push @header, join(' && ', @to_join); } elsif($line =~ m/^StatsOr:\ (\d+)\s+as\s+(.*?)$/mxo) { for(my $x = 0; $x < $1; $x++) { pop @header; } $line = 'StatsOr: '.$1; push @header, $2; } elsif($line =~ m/^StatsOr:\ (\d+)$/mxo) { my @to_join; for(my $x = 0; $x < $1; $x++) { unshift @to_join, pop @header; } push @header, join(' || ', @to_join); } # StatsGroupBy header are always sent first elsif($line =~ m/^StatsGroupBy:\ (.*)\s+as\s+(.*?)$/mxo) { unshift @header, $2; $line = 'StatsGroupBy: '.$1; } elsif($line =~ m/^StatsGroupBy:\ (.*)$/mxo) { unshift @header, $1; } $new_statement .= $line."\n"; } return($new_statement, \@header); } ######################################## sub _extract_keys_from_columns_header { my($self, $statement) = @_; my(@header, $new_statement); for my $line (split/\n/mx, $statement) { if($line =~ m/^Columns:\s+(.*)$/mx) { for my $column (split/\s+/mx, $1) { if($column eq 'as') { pop @header; } else { push @header, $column; } } $line =~ s/\s+as\s+([^\s]+)/\ /gmx; } $new_statement .= $line."\n"; } return($new_statement, \@header); } ######################################## =head1 ERROR HANDLING Errorhandling can be done like this: use Monitoring::Livestatus; my $ml = Monitoring::Livestatus->new( socket => '/var/lib/livestatus/livestatus.sock' ); $ml->errors_are_fatal(0); my $hosts = $ml->selectall_arrayref("GET hosts"); if($Monitoring::Livestatus::ErrorCode) { confess($Monitoring::Livestatus::ErrorMessage); } =cut sub _get_error { my($self, $code, $append) = @_; my $codes = { '200' => 'OK. Reponse contains the queried data.', '201' => 'COMMANDs never return something', '400' => 'The request contains an invalid header.', '401' => 'The request contains an invalid header.', '402' => 'The request is completely invalid.', '403' => 'The request is incomplete.', '404' => 'The target of the GET has not been found (e.g. the table).', '405' => 'A non-existing column was being referred to', '413' => 'Maximum response size reached', '452' => 'internal livestatus error', '490' => 'no query', '491' => 'failed to connect', '492' => 'Separators not allowed in statement. Please use the separator options in new()', '493' => 'OuputFormat not allowed in statement. Header will be set automatically', '494' => 'ColumnHeaders not allowed in statement. Header will be set automatically', '495' => 'ResponseHeader not allowed in statement. Header will be set automatically', '496' => 'Keepalive not allowed in statement. Please use the keepalive option in new()', '497' => 'got no header', '498' => 'header is not exactly 16byte long', '499' => 'not a valid header (no content-length)', '500' => 'socket error', '502' => 'backend connection proxy error', }; confess('non existant error code: '.$code) if !defined $codes->{$code}; my $msg = $codes->{$code}; $msg .= ' - '.$append if $append; return($msg); } ######################################## sub _get_peer { my($self) = @_; # check if the supplied peer is a socket or a server address if(defined $self->{'peer'}) { if(ref $self->{'peer'} eq '') { my $name = $self->{'name'} || ''.$self->{'peer'}; if(index($self->{'peer'}, ':') > 0) { return({ 'peer' => ''.$self->{'peer'}, type => 'INET', name => $name }); } else { return({ 'peer' => ''.$self->{'peer'}, type => 'UNIX', name => $name }); } } elsif(ref $self->{'peer'} eq 'ARRAY') { for my $peer (@{$self->{'peer'}}) { if(ref $peer eq 'HASH') { next if !defined $peer->{'peer'}; $peer->{'name'} = ''.$peer->{'peer'} unless defined $peer->{'name'}; if(!defined $peer->{'type'}) { $peer->{'type'} = 'UNIX'; if(index($peer->{'peer'}, ':') >= 0) { $peer->{'type'} = 'INET'; } } return $peer; } else { my $type = 'UNIX'; if(index($peer, ':') >= 0) { $type = 'INET'; } return({ 'peer' => ''.$peer, type => $type, name => ''.$peer }); } } } elsif(ref $self->{'peer'} eq 'HASH') { for my $peer (keys %{$self->{'peer'}}) { my $name = $self->{'peer'}->{$peer}; my $type = 'UNIX'; if(index($peer, ':') >= 0) { $type = 'INET'; } return({ 'peer' => ''.$peer, type => $type, name => ''.$name }); } } else { confess('type '.(ref $self->{'peer'}).' is not supported for peer option'); } } if(defined $self->{'socket'}) { my $name = $self->{'name'} || ''.$self->{'socket'}; return({ 'peer' => ''.$self->{'socket'}, type => 'UNIX', name => $name }); } if(defined $self->{'server'}) { my $name = $self->{'name'} || ''.$self->{'server'}; return({ 'peer' => ''.$self->{'server'}, type => 'INET', name => $name }); } # check if we got a peer confess('please specify a peer'); } ######################################## sub _lowercase_and_verify_options { my($self, $opts) = @_; my $return = {}; # make keys lowercase %{$return} = map { lc($_) => $opts->{$_} } keys %{$opts}; if($self->{'warnings'}) { for my $key (keys %{$return}) { if(!defined $allowed_options->{$key}) { carp("unknown option used: $key - please use only: ".join(', ', keys %{$allowed_options})); } } } # set limits if(defined $return->{'limit'}) { if(index($return->{'limit'}, ',') != -1) { my($limit_start,$limit_length) = split /,/mx, $return->{'limit'}; $return->{'limit_start'} = $limit_start; $return->{'limit_length'} = $limit_length; } else { $return->{'limit_start'} = 0; $return->{'limit_length'} = $return->{'limit'}; } delete $return->{'limit'}; } return($return); } ######################################## sub _log_statement { my($self, $statement, $opt, $limit) = @_; my $d = Data::Dumper->new([$opt]); $d->Indent(0); my $optstring = $d->Dump; $optstring =~ s/^\$VAR1\s+=\s+//mx; $optstring =~ s/;$//mx; # remove empty lines from statement $statement =~ s/\n+/\n/gmx; my $cleanstatement = $statement; $cleanstatement =~ s/\n/\\n/gmx; $self->{'logger'}->debug('selectall_arrayref("'.$cleanstatement.'", '.$optstring.', '.$limit.')'); return 1; } ######################################## sub _die_or_confess { my($msg) = @_; my @lines = split/\n/mx, $msg; if(scalar @lines > 2) { die($msg); } confess($msg); } ######################################## 1; =head1 SEE ALSO For more information about the query syntax and the livestatus plugin installation see the Livestatus page: http://mathias-kettner.de/checkmk_livestatus.html =head1 AUTHOR Sven Nierlein, 2009-present, =head1 COPYRIGHT AND LICENSE Copyright (C) by Sven Nierlein This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut __END__ Monitoring-Livestatus-0.86/lib/Monitoring/Livestatus/0000755000175000017500000000000015010056571021503 5ustar svensvenMonitoring-Livestatus-0.86/lib/Monitoring/Livestatus/INET.pm0000644000175000017500000000673115010055415022603 0ustar svensvenpackage Monitoring::Livestatus::INET; use warnings; use strict; use Carp qw/confess/; use IO::Socket::IP (); use Socket qw(IPPROTO_TCP TCP_NODELAY); use parent 'Monitoring::Livestatus'; =head1 NAME Monitoring::Livestatus::INET - connector with tcp sockets =head1 SYNOPSIS use Monitoring::Livestatus; my $nl = Monitoring::Livestatus::INET->new( 'localhost:9999' ); my $hosts = $nl->selectall_arrayref("GET hosts"); =head1 CONSTRUCTOR =head2 new ( [ARGS] ) Creates an C object. C takes at least the server. Arguments are the same as in C. If the constructor is only passed a single argument, it is assumed to be a the C specification. Use either socker OR server. =cut sub new { my($class, @args) = @_; unshift(@args, "peer") if scalar @args == 1; my(%options) = @args; $options{'name'} = $options{'peer'} unless defined $options{'name'}; $options{'backend'} = $class; my $self = Monitoring::Livestatus->new(%options); bless $self, $class; confess('not a scalar') if ref $self->{'peer'} ne ''; if(($self->{'peer'}//$self->{'server'}) =~ m|^tls://|mx) { require IO::Socket::SSL; } return $self; } ######################################## =head1 METHODS =cut sub _open { my $self = shift; my $sock; my $options = { PeerAddr => $self->{'peer'}, Type => IO::Socket::IP::SOCK_STREAM, Timeout => $self->{'connect_timeout'}, }; my $tls = 0; my $peer_addr = $self->{'peer'}; if($peer_addr =~ s|tls://||mx) { #$IO::Socket::SSL::DEBUG = 2 if $ENV{'THRUK_VERBOSE'} && $ENV{'THRUK_VERBOSE'} >= 2; #$IO::Socket::SSL::DEBUG = 3 if $ENV{'THRUK_VERBOSE'} && $ENV{'THRUK_VERBOSE'} >= 3; $options->{'PeerAddr'} = $peer_addr; $options->{'SSL_cert_file'} = $self->{'cert'}; $options->{'SSL_key_file'} = $self->{'key'}; $options->{'SSL_ca_file'} = $self->{'ca_file'}; $options->{'SSL_verify_mode'} = 0 if(defined $self->{'verify'} && $self->{'verify'} == 0); $options->{'SSL_verifycn_name'} = $self->{'verifycn_name'}; $tls = 1; } eval { if($tls) { $sock = IO::Socket::SSL->new(%{$options}); } else { $sock = IO::Socket::IP->new(%{$options}); } if(!defined $sock || !$sock->connected()) { my $msg = "failed to connect to $peer_addr: ".($tls ? IO::Socket::SSL::errstr() : $!); if($self->{'errors_are_fatal'}) { confess($msg); } $Monitoring::Livestatus::ErrorCode = 500; $Monitoring::Livestatus::ErrorMessage = $msg; return; } setsockopt($sock, IPPROTO_TCP, TCP_NODELAY, 1); }; my $err = $@; if($err) { $Monitoring::Livestatus::ErrorCode = 500; $Monitoring::Livestatus::ErrorMessage = $err; return; } if(defined $self->{'query_timeout'}) { # set timeout $sock->timeout($self->{'query_timeout'}); } return($sock); } ######################################## sub _close { my $self = shift; my $sock = shift; return unless defined $sock; return close($sock); } 1; =head1 AUTHOR Sven Nierlein, 2009-present, =head1 COPYRIGHT AND LICENSE Copyright (C) by Sven Nierlein This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut __END__ Monitoring-Livestatus-0.86/lib/Monitoring/Livestatus/UNIX.pm0000644000175000017500000000556015010055415022626 0ustar svensvenpackage Monitoring::Livestatus::UNIX; use warnings; use strict; use Carp qw/confess/; use IO::Socket::UNIX (); use parent 'Monitoring::Livestatus'; =head1 NAME Monitoring::Livestatus::UNIX - connector with unix sockets =head1 SYNOPSIS use Monitoring::Livestatus; my $nl = Monitoring::Livestatus::UNIX->new( '/var/lib/livestatus/livestatus.sock' ); my $hosts = $nl->selectall_arrayref("GET hosts"); =head1 CONSTRUCTOR =head2 new ( [ARGS] ) Creates an C object. C takes at least the socketpath. Arguments are the same as in C. If the constructor is only passed a single argument, it is assumed to be a the C specification. Use either socker OR server. =cut sub new { my($class,@args) = @_; unshift(@args, "peer") if scalar @args == 1; my(%options) = @args; $options{'name'} = $options{'peer'} unless defined $options{'name'}; $options{'backend'} = $class; my $self = Monitoring::Livestatus->new(%options); bless $self, $class; confess('not a scalar') if ref $self->{'peer'} ne ''; return $self; } ######################################## =head1 METHODS =cut sub _open { my $self = shift; if(!-S $self->{'peer'}) { my $msg = "failed to open socket $self->{'peer'}: $!"; if($self->{'errors_are_fatal'}) { confess($msg); } $Monitoring::Livestatus::ErrorCode = 500; $Monitoring::Livestatus::ErrorMessage = $msg; return; } my $sock; eval { $sock = IO::Socket::UNIX->new( Peer => $self->{'peer'}, Type => IO::Socket::UNIX::SOCK_STREAM, Timeout => $self->{'connect_timeout'}, ); if(!defined $sock || !$sock->connected()) { my $msg = "failed to connect to $self->{'peer'}: $!"; if($self->{'errors_are_fatal'}) { confess($msg); } $Monitoring::Livestatus::ErrorCode = 500; $Monitoring::Livestatus::ErrorMessage = $msg; return; } }; if($@) { $Monitoring::Livestatus::ErrorCode = 500; $Monitoring::Livestatus::ErrorMessage = $@; return; } if(defined $self->{'query_timeout'}) { # set timeout $sock->timeout($self->{'query_timeout'}); } return($sock); } ######################################## sub _close { my $self = shift; my $sock = shift; return unless defined $sock; return close($sock); } 1; =head1 AUTHOR Sven Nierlein, 2009-present, =head1 COPYRIGHT AND LICENSE Copyright (C) by Sven Nierlein This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut __END__ Monitoring-Livestatus-0.86/META.yml0000644000175000017500000000163715010055670015724 0ustar svensven--- abstract: 'Perl API for check_mk livestatus to access runtime data from Nagios and Icinga' author: - 'Sven Nierlein, 2009-present, ' build_requires: ExtUtils::MakeMaker: 6.59 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.21' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Monitoring-Livestatus no_index: directory: - examples - inc - t requires: Cpanel::JSON::XS: 0 Encode: 0 IO::Select: 0 IO::Socket::IP: 0 IO::Socket::UNIX: 0 Test::More: '0.87' perl: 5.6.0 utf8: 0 resources: bugtracker: http://github.com/sni/Monitoring-Livestatus/issues homepage: http://search.cpan.org/dist/Monitoring-Livestatus/ license: http://dev.perl.org/licenses/ repository: http://github.com/sni/Monitoring-Livestatus version: '0.84' Monitoring-Livestatus-0.86/t/0000755000175000017500000000000015010056571014710 5ustar svensvenMonitoring-Livestatus-0.86/t/97-Pod.t0000644000175000017500000000036615010055415016055 0ustar svensvenuse strict; use warnings; use Test::More; eval "use Test::Pod 1.14"; plan skip_all => 'Test::Pod 1.14 required' if $@; plan skip_all => 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.' unless $ENV{TEST_AUTHOR}; all_pod_files_ok(); Monitoring-Livestatus-0.86/t/32-Monitoring-Livestatus-backend-test.t0000644000175000017500000001006615010055415024146 0ustar svensven#!/usr/bin/env perl ######################### use strict; use Carp; use Test::More; use Data::Dumper; if ( ! defined $ENV{TEST_SOCKET} or !defined $ENV{TEST_SERVER} or !defined $ENV{TEST_BACKEND} ) { my $msg = 'Author test. Set $ENV{TEST_SOCKET} and $ENV{TEST_SERVER} and $ENV{TEST_BACKEND} to run'; plan( skip_all => $msg ); } else { # we don't know yet how many tests we got plan( tests => 57070 ); } # set an alarm my $lastquery; $SIG{ALRM} = sub { my @caller = caller; $lastquery =~ s/\n+/\n/g; print STDERR 'last query: '.$lastquery."\n" if defined $lastquery; confess "timeout reached:".Dumper(\@caller)."\n" }; use_ok('Monitoring::Livestatus'); ######################### my $objects_to_test = { # UNIX '01 unix_single_arg' => Monitoring::Livestatus::UNIX->new( $ENV{TEST_SOCKET} ), # TCP '02 inet_single_arg' => Monitoring::Livestatus::INET->new( $ENV{TEST_SERVER} ), }; for my $key (sort keys %{$objects_to_test}) { my $ml = $objects_to_test->{$key}; isa_ok($ml, 'Monitoring::Livestatus') or BAIL_OUT("no need to continue without a proper Monitoring::Livestatus object: ".$key); # don't die on errors $ml->errors_are_fatal(0); $ml->warnings(0); ######################### # get tables my $data = $ml->selectall_hashref("GET columns\nColumns: table", 'table'); my @tables = sort keys %{$data}; ######################### # check keys for my $type (@tables) { next if $type eq 'statehist'; alarm(120); my $filter = ""; $filter = "Filter: time > ".(time() - 86400)."\n" if $type eq 'log'; $filter .= "Filter: time < ".(time())."\n" if $type eq 'log'; my $statement = "GET $type\n".$filter."Limit: 1"; $lastquery = $statement; my $keys = $ml->selectrow_hashref($statement ); undef $lastquery; is(ref $keys, 'HASH', $type.' keys are a hash');# or BAIL_OUT('keys are not in hash format, got '.Dumper($keys)); # status has no filter implemented next if $type eq 'status'; for my $key (keys %{$keys}) { my $value = $keys->{$key}; if(index($value, ',') > 0) { my @vals = split /,/, $value; $value = $vals[0]; } my $typefilter = "Filter: $key >= $value\n"; if($value eq '') { $typefilter = "Filter: $key =\n"; } my $statement = "GET $type\n".$filter.$typefilter."Limit: 1"; $lastquery = $statement; my $hash_ref = $ml->selectrow_hashref($statement ); undef $lastquery; is($Monitoring::Livestatus::ErrorCode, 0, "GET ".$type." Filter: ".$key." >= ".$value) or BAIL_OUT("query failed: ".$statement); #isnt($hash_ref, undef, "GET ".$type." Filter: ".$key." >= ".$value);# or BAIL_OUT("got undef for ".$statement); # send test stats query my $stats_query = [ $key.' = '.$value, 'std '.$key, 'min '.$key, 'max '.$key, 'avg '.$key, 'sum '.$key ]; for my $stats_part (@{$stats_query}) { my $statement = "GET $type\n".$filter.$typefilter."\nStats: $stats_part"; $lastquery = $statement; my $hash_ref = $ml->selectrow_hashref($statement ); undef $lastquery; is($Monitoring::Livestatus::ErrorCode, 0, "GET ".$type." Filter: ".$key." >= ".$value." Stats: $stats_part") or BAIL_OUT("query failed:\n".$statement); $statement = "GET $type\n".$filter.$typefilter."\nStats: $stats_part\nStatsGroupBy: $key"; $lastquery = $statement; $hash_ref = $ml->selectrow_hashref($statement ); undef $lastquery; is($Monitoring::Livestatus::ErrorCode, 0, "GET ".$type." Filter: ".$key." >= ".$value." Stats: $stats_part StatsGroupBy: $key") or BAIL_OUT("query failed:\n".$statement); } # wait till backend is started up again if(!defined $hash_ref and $Monitoring::Livestatus::ErrorCode > 200) { sleep(2); } } } } Monitoring-Livestatus-0.86/t/34-Monitoring-Livestatus-utf8_support.t0000644000175000017500000000566115010055415024273 0ustar svensven#!/usr/bin/env perl ######################### use strict; use Encode; use Test::More; use Data::Dumper; if ( !defined $ENV{TEST_UTF8} ) { my $msg = 'Author test. $ENV{TEST_UTF8} to run'; plan( skip_all => $msg ); } elsif ( !defined $ENV{TEST_SERVER} ) { my $msg = 'Author test. Set $ENV{TEST_SERVER} to run'; plan( skip_all => $msg ); } else { plan( tests => 9 ); } use_ok('Monitoring::Livestatus'); #use Log::Log4perl qw(:easy); #Log::Log4perl->easy_init($DEBUG); ######################### my $objects_to_test = { # create inet object with hash args '01 inet_hash_args' => Monitoring::Livestatus->new( verbose => 0, server => $ENV{TEST_SERVER}, keepalive => 1, timeout => 3, retries_on_connection_error => 0, # logger => get_logger(), ), # create inet object with a single arg '02 inet_single_arg' => Monitoring::Livestatus::INET->new( $ENV{TEST_SERVER} ), }; my $author = 'Monitoring::Livestatus test'; for my $key (sort keys %{$objects_to_test}) { my $ml = $objects_to_test->{$key}; isa_ok($ml, 'Monitoring::Livestatus'); # we don't need warnings for testing $ml->warnings(0); ######################### my $downtimes = $ml->selectall_arrayref("GET downtimes\nColumns: id"); my $num_downtimes = 0; $num_downtimes = scalar @{$downtimes} if defined $downtimes; ######################### # get a test host my $firsthost = $ml->selectscalar_value("GET hosts\nColumns: name\nLimit: 1"); isnt($firsthost, undef, 'get test hostname') or BAIL_OUT($key.': got not test hostname'); my $expect = "aa ²&é\"'''(§è!çà)- %s ''%s'' aa ~ € bb"; #my $expect = "öäüß"; my $teststrings = [ $expect, "aa \x{c2}\x{b2}&\x{c3}\x{a9}\"'''(\x{c2}\x{a7}\x{c3}\x{a8}!\x{c3}\x{a7}\x{c3}\x{a0})- %s ''%s'' aa ~ \x{e2}\x{82}\x{ac} bb", ]; for my $string (@{$teststrings}) { $ml->do('COMMAND ['.time().'] SCHEDULE_HOST_DOWNTIME;'.$firsthost.';'.time().';'.(time()+300).';1;0;300;'.$author.';'.$string); # sometimes it takes while till the downtime is accepted my $waited = 0; while($downtimes = $ml->selectall_arrayref("GET downtimes\nColumns: id comment", { Slice => 1 }) and scalar @{$downtimes} < $num_downtimes + 1) { print "waiting for the downtime...\n"; sleep(1); $waited++; BAIL_OUT('waited 30 seconds for the downtime...') if $waited > 30; } my $last_downtime = pop @{$downtimes}; #utf8::decode($expect); is($last_downtime->{'comment'}, $expect, 'get same utf8 comment: got '.Dumper($last_downtime)); } } Monitoring-Livestatus-0.86/t/98-Pod-Coverage.t0000644000175000017500000000066515010055415017611 0ustar svensven#!/usr/bin/env perl # # $Id$ # use strict; use warnings; use File::Spec; use Test::More; if ( not $ENV{TEST_AUTHOR} ) { my $msg = 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; plan( skip_all => $msg ); } eval { require Test::Pod::Coverage; }; if ( $@ ) { my $msg = 'Test::Pod::Coverage required to criticise pod'; plan( skip_all => $msg ); } eval "use Test::Pod::Coverage 1.00"; all_pod_coverage_ok(); Monitoring-Livestatus-0.86/t/20-Monitoring-Livestatus-test_socket.t0000644000175000017500000003363415010055415024134 0ustar svensven#!/usr/bin/env perl ######################### use strict; use Test::More; use IO::Socket::UNIX qw( SOCK_STREAM SOMAXCONN ); use Data::Dumper; use Cpanel::JSON::XS; BEGIN { eval {require threads;}; if ( $@ ) { plan skip_all => 'need threads support for testing a real socket' } elsif( $^O eq 'MSWin32' ) { plan skip_all => 'no sockets on windows'; } else{ plan tests => 109 } } use File::Temp; BEGIN { use_ok('Monitoring::Livestatus') }; ######################### # Normal Querys ######################### my $line_separator = 10; my $column_separator = 0; my $test_data = [ ["alias","name","contacts"], # table header ["alias1","host1","contact1"], # row 1 ["alias2","host2","contact2"], # row 2 ["alias3","host3","contact3"], # row 3 ]; my $test_hostgroups = [['']]; # test one row with no data # expected results my $selectall_arrayref1 = [ [ 'alias1', 'host1', 'contact1' ], [ 'alias2', 'host2', 'contact2' ], [ 'alias3', 'host3', 'contact3' ] ]; my $selectall_arrayref2 = [ { 'contacts' => 'contact1', 'name' => 'host1', 'alias' => 'alias1' }, { 'contacts' => 'contact2', 'name' => 'host2', 'alias' => 'alias2' }, { 'contacts' => 'contact3', 'name' => 'host3', 'alias' => 'alias3' } ]; my $selectall_hashref = { 'host1' => { 'contacts' => 'contact1', 'name' => 'host1', 'alias' => 'alias1' }, 'host2' => { 'contacts' => 'contact2', 'name' => 'host2', 'alias' => 'alias2' }, 'host3' => { 'contacts' => 'contact3', 'name' => 'host3', 'alias' => 'alias3' } }; my $selectcol_arrayref1 = [ 'alias1', 'alias2', 'alias3' ]; my $selectcol_arrayref2 = [ 'alias1', 'host1', 'alias2', 'host2', 'alias3', 'host3' ]; my $selectcol_arrayref3 = [ 'alias1', 'host1', 'contact1', 'alias2', 'host2', 'contact2', 'alias3', 'host3', 'contact3' ]; my @selectrow_array = ( 'alias1', 'host1', 'contact1' ); my $selectrow_arrayref = [ 'alias1', 'host1', 'contact1' ]; my $selectrow_hashref = { 'contacts' => 'contact1', 'name' => 'host1', 'alias' => 'alias1' }; ######################### # Single Querys ######################### my $single_statement = "GET hosts\nColumns: alias\nFilter: name = host1"; my $selectscalar_value = 'alias1'; ######################### # Stats Querys ######################### my $stats_statement = "GET services\nStats: state = 0\nStats: state = 1\nStats: state = 2\nStats: state = 3"; my $stats_data = [[4297,13,9,0]]; # expected results my $stats_selectall_arrayref1 = [ [4297,13,9,0] ]; my $stats_selectall_arrayref2 = [ { 'state = 0' => '4297', 'state = 1' => '13', 'state = 2' => '9', 'state = 3' => 0 } ]; my $stats_selectcol_arrayref = [ '4297' ]; my @stats_selectrow_array = ( '4297', '13', '9', '0' ); my $stats_selectrow_arrayref = [ '4297', '13', '9', '0' ]; my $stats_selectrow_hashref = { 'state = 0' => '4297', 'state = 1' => '13', 'state = 2' => '9', 'state = 3' => 0 }; ######################### # Empty Querys ######################### my $empty_statement = "GET services\nFilter: description = empty"; # expected results my $empty_selectall_arrayref = []; my $empty_selectcol_arrayref = []; my @empty_selectrow_array; my $empty_selectrow_arrayref; my $empty_selectrow_hashref; ######################### # get a temp file from File::Temp and replace it with our socket my $fh = File::Temp->new(UNLINK => 0); my $socket_path = $fh->filename; unlink($socket_path); my $thr1 = threads->create('create_socket', 'unix'); ######################### # get a temp file from File::Temp and replace it with our socket my $server = 'localhost:32987'; my $thr2 = threads->create('create_socket', 'inet'); sleep(1); ######################### my $objects_to_test = { # create unix object with hash args 'unix_hash_args' => Monitoring::Livestatus->new( verbose => 0, socket => $socket_path, line_separator => $line_separator, column_separator => $column_separator, ), # create unix object with a single arg 'unix_single_arg' => Monitoring::Livestatus::UNIX->new( $socket_path ), # create inet object with hash args 'inet_hash_args' => Monitoring::Livestatus->new( verbose => 0, server => $server, line_separator => $line_separator, column_separator => $column_separator, ), # create inet object with a single arg 'inet_single_arg' => Monitoring::Livestatus::INET->new( $server ), }; for my $key (keys %{$objects_to_test}) { my $ml = $objects_to_test->{$key}; isa_ok($ml, 'Monitoring::Livestatus'); # we don't need warnings for testing $ml->warnings(0); ################################################## # test settings my $rt = $ml->verbose(1); is($rt, '0', 'enable verbose'); $rt = $ml->verbose(0); is($rt, '1', 'disable verbose'); $rt = $ml->errors_are_fatal(0); is($rt, '1', 'disable errors_are_fatal'); $rt = $ml->errors_are_fatal(1); is($rt, '0', 'enable errors_are_fatal'); ################################################## # do some sample querys my $statement = "GET hosts"; ######################### my $ary_ref = $ml->selectall_arrayref($statement); is_deeply($ary_ref, $selectall_arrayref1, 'selectall_arrayref($statement)') or diag("got: ".Dumper($ary_ref)."\nbut expected ".Dumper($selectall_arrayref1)); ######################### $ary_ref = $ml->selectall_arrayref($statement, { Slice => {} }); is_deeply($ary_ref, $selectall_arrayref2, 'selectall_arrayref($statement, { Slice => {} })') or diag("got: ".Dumper($ary_ref)."\nbut expected ".Dumper($selectall_arrayref2)); ######################### my $hash_ref = $ml->selectall_hashref($statement, 'name'); is_deeply($hash_ref, $selectall_hashref, 'selectall_hashref($statement, "name")') or diag("got: ".Dumper($hash_ref)."\nbut expected ".Dumper($selectall_hashref)); ######################### $ary_ref = $ml->selectcol_arrayref($statement); is_deeply($ary_ref, $selectcol_arrayref1, 'selectcol_arrayref($statement)') or diag("got: ".Dumper($ary_ref)."\nbut expected ".Dumper($selectcol_arrayref1)); ######################### $ary_ref = $ml->selectcol_arrayref($statement, { Columns=>[1,2] }); is_deeply($ary_ref, $selectcol_arrayref2, 'selectcol_arrayref($statement, { Columns=>[1,2] })') or diag("got: ".Dumper($ary_ref)."\nbut expected ".Dumper($selectcol_arrayref2)); $ary_ref = $ml->selectcol_arrayref($statement, { Columns=>[1,2,3] }); is_deeply($ary_ref, $selectcol_arrayref3, 'selectcol_arrayref($statement, { Columns=>[1,2,3] })') or diag("got: ".Dumper($ary_ref)."\nbut expected ".Dumper($selectcol_arrayref3)); ######################### my @row_ary = $ml->selectrow_array($statement); is_deeply(\@row_ary, \@selectrow_array, 'selectrow_array($statement)') or diag("got: ".Dumper(\@row_ary)."\nbut expected ".Dumper(\@selectrow_array)); ######################### $ary_ref = $ml->selectrow_arrayref($statement); is_deeply($ary_ref, $selectrow_arrayref, 'selectrow_arrayref($statement)') or diag("got: ".Dumper($ary_ref)."\nbut expected ".Dumper($selectrow_arrayref)); ######################### $hash_ref = $ml->selectrow_hashref($statement); is_deeply($hash_ref, $selectrow_hashref, 'selectrow_hashref($statement)') or diag("got: ".Dumper($hash_ref)."\nbut expected ".Dumper($selectrow_hashref)); ################################################## # stats querys ################################################## $ary_ref = $ml->selectall_arrayref($stats_statement); is_deeply($ary_ref, $stats_selectall_arrayref1, 'selectall_arrayref($stats_statement)') or diag("got: ".Dumper($ary_ref)."\nbut expected ".Dumper($stats_selectall_arrayref1)); $ary_ref = $ml->selectall_arrayref($stats_statement, { Slice => {} }); is_deeply($ary_ref, $stats_selectall_arrayref2, 'selectall_arrayref($stats_statement, { Slice => {} })') or diag("got: ".Dumper($ary_ref)."\nbut expected ".Dumper($stats_selectall_arrayref2)); $ary_ref = $ml->selectcol_arrayref($stats_statement); is_deeply($ary_ref, $stats_selectcol_arrayref, 'selectcol_arrayref($stats_statement)') or diag("got: ".Dumper($ary_ref)."\nbut expected ".Dumper($stats_selectcol_arrayref)); @row_ary = $ml->selectrow_array($stats_statement); is_deeply(\@row_ary, \@stats_selectrow_array, 'selectrow_arrayref($stats_statement)') or diag("got: ".Dumper(\@row_ary)."\nbut expected ".Dumper(\@stats_selectrow_array)); $ary_ref = $ml->selectrow_arrayref($stats_statement); is_deeply($ary_ref, $stats_selectrow_arrayref, 'selectrow_arrayref($stats_statement)') or diag("got: ".Dumper($ary_ref)."\nbut expected ".Dumper($stats_selectrow_arrayref)); $hash_ref = $ml->selectrow_hashref($stats_statement); is_deeply($hash_ref, $stats_selectrow_hashref, 'selectrow_hashref($stats_statement)') or diag("got: ".Dumper($hash_ref)."\nbut expected ".Dumper($stats_selectrow_hashref)); my $scal = $ml->selectscalar_value($single_statement); is($scal, $selectscalar_value, 'selectscalar_value($single_statement)') or diag("got: ".Dumper($scal)."\nbut expected ".Dumper($selectscalar_value)); ################################################## # empty querys ################################################## $ary_ref = $ml->selectall_arrayref($empty_statement); is_deeply($ary_ref, $empty_selectall_arrayref, 'selectall_arrayref($empty_statement)') or diag("got: ".Dumper($ary_ref)."\nbut expected ".Dumper($empty_selectall_arrayref)); $ary_ref = $ml->selectcol_arrayref($empty_statement); is_deeply($ary_ref, $empty_selectcol_arrayref, 'selectcol_arrayref($empty_statement)') or diag("got: ".Dumper($ary_ref)."\nbut expected ".Dumper($empty_selectcol_arrayref)); @row_ary = $ml->selectrow_array($empty_statement); is_deeply(\@row_ary, \@empty_selectrow_array, 'selectrow_arrayref($empty_statement)') or diag("got: ".Dumper(\@row_ary)."\nbut expected ".Dumper(\@empty_selectrow_array)); $ary_ref = $ml->selectrow_arrayref($empty_statement); is_deeply($ary_ref, $empty_selectrow_arrayref, 'selectrow_arrayref($empty_statement)') or diag("got: ".Dumper($ary_ref)."\nbut expected ".Dumper($empty_selectrow_arrayref)); $hash_ref = $ml->selectrow_hashref($empty_statement); is_deeply($hash_ref, $empty_selectrow_hashref, 'selectrow_hashref($empty_statement)') or diag("got: ".Dumper($hash_ref)."\nbut expected ".Dumper($empty_selectrow_hashref)); ################################################## # empty rows and columns ################################################## my $empty_hostgroups_stm = "GET hostgroups\nColumns: members"; $ary_ref = $ml->selectall_arrayref($empty_hostgroups_stm); is_deeply($ary_ref, $test_hostgroups, 'selectall_arrayref($empty_hostgroups_stm)') or diag("got: ".Dumper($ary_ref)."\nbut expected ".Dumper($test_hostgroups)); } ################################################## # exit threads $thr1->kill('KILL')->detach(); $thr2->kill('KILL')->detach(); exit; ######################### # SUBS ######################### # test socket server sub create_socket { my $type = shift; my $listener; $SIG{'KILL'} = sub { threads->exit(); }; if($type eq 'unix') { print "creating unix socket\n"; $listener = IO::Socket::UNIX->new( Type => SOCK_STREAM, Listen => SOMAXCONN, Local => $socket_path, ) or die("failed to open $socket_path as test socket: $!"); } elsif($type eq 'inet') { print "creating tcp socket\n"; $listener = IO::Socket::INET->new( LocalAddr => $server, Proto => 'tcp', Listen => 1, Reuse => 1, ) or die("failed to listen on $server: $!"); } else { die("unknown type"); } while( my $socket = $listener->accept() or die('cannot accept: $!') ) { my $recv = ""; while(<$socket>) { $recv .= $_; last if $_ eq "\n" } my $data; my $status = 200; if($recv =~ m/^GET .*?\s+Filter:.*?empty/m) { $data = ''; } elsif($recv =~ m/^GET hosts\s+Columns: alias/m) { my @data = @{$test_data}[1..3]; $data = encode_json(\@data)."\n"; } elsif($recv =~ m/^GET hosts\s+Columns: name/m) { $data = encode_json(\@{$test_data}[1..3])."\n"; } elsif($recv =~ m/^GET hosts/) { $data = encode_json($test_data)."\n"; } elsif($recv =~ m/^GET hostgroups/) { $data = encode_json(\@{$test_hostgroups})."\n"; } elsif($recv =~ m/^GET services/ and $recv =~ m/Stats:/m) { $data = encode_json(\@{$stats_data})."\n"; } my $content_length = sprintf("%11s", length($data)); print $socket $status." ".$content_length."\n"; print $socket $data; close($socket); } unlink($socket_path); } Monitoring-Livestatus-0.86/t/23-Monitoring-Livestatus-BigData.t0000644000175000017500000000575615010056306023107 0ustar svensven#!/usr/bin/env perl ######################### use strict; use Test::More; if(!$ENV{TEST_AUTHOR}) { plan skip_all => 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; exit; } my $netcat; for my $path (split(/:/mx, $ENV{'PATH'})) { if(-x $path."/netcat") { $netcat = $path."/netcat"; last; } } if( $^O eq 'MSWin32' ) { plan skip_all => 'no sockets on windows'; } elsif(!$netcat) { plan skip_all => 'no netcat found in path'; } else { plan tests => 13; } use_ok('Monitoring::Livestatus'); my $testport = 60123; my $testresults = $ARGV[0] || 5; ######################### # create object with single arg my $ml = Monitoring::Livestatus->new('localhost:'.$testport); isa_ok($ml, 'Monitoring::Livestatus', 'Monitoring::Livestatus->new()'); ######################### # prepare testfile my $testfile = '/tmp/testresult.json'; open(my $fh, '>', $testfile.'.data') or die($testfile.'.data: '.$!); print $fh "["; for my $x (1..$testresults) { printf($fh '["Test Host %d","some test pluginoutput............................................",1],%s', $x, "\n"); } print $fh "]\n"; close($fh); ok(-f $testfile.".data", "testfile: ".$testfile.".data written"); my $size = -s $testfile.".data"; ok($size, "file has $size bytes"); open($fh, '>', $testfile.'.head') or die($testfile.'.head: '.$!); printf($fh "200 %12d\n", $size); close($fh); `cat $testfile.head $testfile.data > $testfile`; unlink($testfile.'.head', $testfile.'.data'); ########################################################## my $mem_start = get_memory_usage(); ok($mem_start, sprintf('memory at start: %.2f MB', $mem_start/1024)); ########################################################## # start netcat `$netcat -vvv -w 3 -l -p $testport >/dev/null 2>&1 < $testfile &`; sleep(1); ok(1, "netcat started"); ########################################################## my $result = $ml->selectall_arrayref( "GET hosts\nColumns: name plugin_output status", { Slice => {}, } ); is(ref $result, 'ARRAY', 'result is an array'); is(scalar @{$result}, $testresults, 'result has right number'); is(ref $result->[$testresults-1], 'HASH', 'result contains hashes'); is($result->[$testresults-1]->{'name'}, 'Test Host '.$testresults, 'result contains all hosts'); ########################################################## my $mem_end = get_memory_usage(); ok($mem_end, sprintf('memory at end: %.2f MB', $mem_end/1024)); my $delta = $mem_end - $mem_start; ok($delta, sprintf('memory delta: %.2f MB', $delta/1024)); ok($delta, sprintf('memory usage per entry: %d B', $delta*1024/$testresults)); ########################################################## # returns memory usage in kB sub get_memory_usage { my($pid) = @_; $pid = $$ unless defined $pid; my $rsize; open(my $ph, '-|', "ps -p $pid -o rss") or die("ps failed: $!"); while(my $line = <$ph>) { if($line =~ m/(\d+)/mx) { $rsize = sprintf("%.2f", $1); } } CORE::close($ph); return($rsize); } Monitoring-Livestatus-0.86/t/30-Monitoring-Livestatus-live-test.t0000644000175000017500000005565315010055415023527 0ustar svensven#!/usr/bin/env perl ######################### use strict; use Test::More; use Data::Dumper; if ( ! defined $ENV{TEST_SOCKET} or !defined $ENV{TEST_SERVER} ) { my $msg = 'Author test. Set $ENV{TEST_SOCKET} and $ENV{TEST_SERVER} to run'; plan( skip_all => $msg ); } else { plan( tests => 333 ); } # set an alarm my $lastquery; $SIG{ALRM} = sub { my @caller = caller; print STDERR 'last query: '.$lastquery if defined $lastquery; die "timeout reached:".Dumper(\@caller)."\n" }; alarm(120); use_ok('Monitoring::Livestatus'); use_ok('Monitoring::Livestatus::INET'); use_ok('Monitoring::Livestatus::UNIX'); ######################### my $line_separator = 10; my $column_separator = 0; my $objects_to_test = { # UNIX # create unix object with a single arg # '01 unix_single_arg' => Monitoring::Livestatus::UNIX->new( $ENV{TEST_SOCKET} ), # create unix object with hash args '02 unix_few_args' => Monitoring::Livestatus->new( #verbose => 1, socket => $ENV{TEST_SOCKET}, line_separator => $line_separator, column_separator => $column_separator, ), # create unix object with hash args '03 unix_keepalive' => Monitoring::Livestatus->new( verbose => 0, socket => $ENV{TEST_SOCKET}, keepalive => 1, ), # TCP # create inet object with a single arg '04 inet_single_arg' => Monitoring::Livestatus::INET->new( $ENV{TEST_SERVER} ), # create inet object with hash args '05 inet_few_args' => Monitoring::Livestatus->new( verbose => 0, server => $ENV{TEST_SERVER}, line_separator => $line_separator, column_separator => $column_separator, ), # create inet object with keepalive '06 inet_keepalive' => Monitoring::Livestatus->new( verbose => 0, server => $ENV{TEST_SERVER}, keepalive => 1, ), }; my $expected_keys = { 'columns' => [ 'description','name','table','type' ], 'commands' => [ 'line','name' ], 'comments' => [ '__all_from_hosts__', '__all_from_services__', 'author','comment','entry_time','entry_type','expire_time','expires', 'id','is_service','persistent', 'source','type' ], 'contacts' => [ 'address1','address2','address3','address4','address5','address6','alias', 'can_submit_commands','custom_variable_names','custom_variable_values','email','custom_variables', 'host_notification_period','host_notifications_enabled','in_host_notification_period', 'in_service_notification_period','name','modified_attributes','modified_attributes_list', 'pager','service_notification_period','service_notifications_enabled' ], 'contactgroups' => [ 'name', 'alias', 'members' ], 'downtimes' => [ '__all_from_hosts__', '__all_from_services__', 'author','comment','duration','end_time','entry_time','fixed','id','is_service','start_time', 'triggered_by','type' ], 'hostgroups' => [ 'action_url','alias','members','name','members_with_state','notes','notes_url','num_hosts','num_hosts_down', 'num_hosts_pending','num_hosts_unreach','num_hosts_up','num_services','num_services_crit', 'num_services_hard_crit','num_services_hard_ok','num_services_hard_unknown', 'num_services_hard_warn','num_services_ok','num_services_pending','num_services_unknown', 'num_services_warn','worst_host_state','worst_service_hard_state','worst_service_state' ], 'hosts' => [ 'accept_passive_checks','acknowledged','acknowledgement_type','action_url','action_url_expanded', 'active_checks_enabled','address','alias','check_command','check_command_expanded','check_flapping_recovery_notification','check_freshness','check_interval', 'check_options','check_period','check_type','checks_enabled','childs','comments','comments_with_extra_info','comments_with_info', 'contact_groups','contacts','current_attempt','current_notification_number','custom_variable_names', 'custom_variable_values','custom_variables','display_name','downtimes','downtimes_with_info','event_handler','event_handler_enabled', 'execution_time','filename','first_notification_delay','flap_detection_enabled','groups','hard_state','has_been_checked', 'high_flap_threshold','icon_image','icon_image_alt','icon_image_expanded','in_check_period', 'in_notification_period','initial_state','is_executing','is_flapping','last_check','last_hard_state', 'last_hard_state_change','last_notification','last_state','last_state_change','latency','last_time_down', 'last_time_unreachable','last_time_up','long_plugin_output','low_flap_threshold','max_check_attempts','name', 'modified_attributes','modified_attributes_list','next_check', 'next_notification','no_more_notifications','notes','notes_expanded','notes_url','notes_url_expanded','notification_interval', 'notification_period','notifications_enabled','num_services','num_services_crit','num_services_hard_crit', 'num_services_hard_ok','num_services_hard_unknown','num_services_hard_warn','num_services_ok', 'num_services_pending','num_services_unknown','num_services_warn','obsess_over_host','parents', 'pending_flex_downtime','percent_state_change','pnpgraph_present','perf_data','plugin_output', 'process_performance_data','retry_interval','scheduled_downtime_depth','services','services_with_info','services_with_state', 'state','state_type','statusmap_image','total_services','worst_service_hard_state','worst_service_state', 'x_3d','y_3d','z_3d' ], 'hostsbygroup' => [ '__all_from_hosts__', '__all_from_hostgroups__' ], 'log' => [ '__all_from_hosts__','__all_from_services__','__all_from_contacts__','__all_from_commands__', 'attempt','class','command_name','comment','contact_name','host_name','lineno','message','options', 'plugin_output','service_description','state','state_type','time','type' ], 'servicegroups' => [ 'action_url','alias','members','name','members_with_state','notes','notes_url','num_services','num_services_crit', 'num_services_hard_crit','num_services_hard_ok','num_services_hard_unknown', 'num_services_hard_warn','num_services_ok','num_services_pending','num_services_unknown', 'num_services_warn','worst_service_state' ], 'servicesbygroup' => [ '__all_from_services__', '__all_from_hosts__', '__all_from_servicegroups__' ], 'services' => [ '__all_from_hosts__', 'accept_passive_checks','acknowledged','acknowledgement_type','action_url','action_url_expanded', 'active_checks_enabled','check_command','check_command_expanded','check_freshness','check_interval','check_options','check_period', 'check_type','checks_enabled','comments','comments_with_extra_info','comments_with_info','contact_groups','contacts','current_attempt', 'current_notification_number','custom_variable_names','custom_variable_values','custom_variables', 'description','display_name','downtimes','downtimes_with_info','event_handler','event_handler_enabled', 'execution_time','first_notification_delay','flap_detection_enabled','groups', 'has_been_checked','high_flap_threshold','icon_image','icon_image_alt','icon_image_expanded','in_check_period', 'in_notification_period','initial_state','is_executing','is_flapping','last_check', 'last_hard_state','last_hard_state_change','last_notification','last_state', 'last_state_change','latency','last_time_critical','last_time_ok','last_time_unknown','last_time_warning', 'long_plugin_output','low_flap_threshold','max_check_attempts','modified_attributes','modified_attributes_list', 'next_check','next_notification','no_more_notifications','notes','notes_expanded','notes_url','notes_url_expanded', 'notification_interval','notification_period','notifications_enabled','obsess_over_service', 'percent_state_change','pnpgraph_present','perf_data','plugin_output','process_performance_data','retry_interval', 'scheduled_downtime_depth','state','state_type' ], 'servicesbyhostgroup' => [ '__all_from_services__', '__all_from_hosts__', '__all_from_hostgroups__' ], 'statehist' => [], 'status' => [ 'accept_passive_host_checks','accept_passive_service_checks','cached_log_messages', 'check_external_commands','check_host_freshness','check_service_freshness','connections', 'connections_rate','enable_event_handlers','enable_flap_detection','enable_notifications', 'execute_host_checks','execute_service_checks','external_command_buffer_max','external_command_buffer_slots','external_command_buffer_usage','external_commands','external_commands_rate','forks','forks_rate','host_checks','host_checks_rate','interval_length', 'last_command_check','last_log_rotation','livecheck_overflows','livecheck_overflows_rate','livechecks','livechecks_rate','livestatus_active_connections','livestatus_queued_connections','livestatus_threads','livestatus_version','log_messages','log_messages_rate','nagios_pid','neb_callbacks', 'neb_callbacks_rate','num_hosts','num_services','obsess_over_hosts','obsess_over_services','process_performance_data', 'program_start','program_version','requests','requests_rate','service_checks','service_checks_rate' ], 'timeperiods' => [ 'in', 'name', 'alias' ], }; my $author = 'Monitoring::Livestatus test'; for my $key (sort keys %{$objects_to_test}) { my $ml = $objects_to_test->{$key}; isa_ok($ml, 'Monitoring::Livestatus') or BAIL_OUT("no need to continue without a proper Monitoring::Livestatus object: ".$key); # don't die on errors $ml->errors_are_fatal(0); $ml->warnings(0); ######################### # set downtime for a host and service my $downtimes = $ml->selectall_arrayref("GET downtimes\nColumns: id"); my $num_downtimes = 0; $num_downtimes = scalar @{$downtimes} if defined $downtimes; my $firsthost = $ml->selectscalar_value("GET hosts\nColumns: name\nLimit: 1"); isnt($firsthost, undef, 'get test hostname') or BAIL_OUT($key.': got not test hostname'); $ml->do('COMMAND ['.time().'] SCHEDULE_HOST_DOWNTIME;'.$firsthost.';'.time().';'.(time()+300).';1;0;300;'.$author.';perl test: '.$0); my $firstservice = $ml->selectscalar_value("GET services\nColumns: description\nFilter: host_name = $firsthost\nLimit: 1"); isnt($firstservice, undef, 'get test servicename') or BAIL_OUT('got not test servicename'); $ml->do('COMMAND ['.time().'] SCHEDULE_SVC_DOWNTIME;'.$firsthost.';'.$firstservice.';'.time().';'.(time()+300).';1;0;300;'.$author.';perl test: '.$0); # sometimes it takes while till the downtime is accepted my $waited = 0; while(scalar @{$ml->selectall_arrayref("GET downtimes\nColumns: id")} < $num_downtimes + 2) { print "waiting for the downtime...\n"; sleep(1); $waited++; BAIL_OUT('waited 30 seconds for the downtime...') if $waited > 30; } ######################### ######################### # check tables my $data = $ml->selectall_hashref("GET columns\nColumns: table", 'table'); my @tables = sort keys %{$data}; my @expected_tables = sort keys %{$expected_keys}; is_deeply(\@tables, \@expected_tables, $key.' tables') or BAIL_OUT("got tables:\n".join(', ', @tables)."\nbut expected\n".join(', ', @expected_tables)); ######################### # check keys for my $type (keys %{$expected_keys}) { next if $type eq 'statehist'; my $filter = ""; $filter = "Filter: time > ".(time() - 86400)."\n" if $type eq 'log'; $filter .= "Filter: time < ".(time())."\n" if $type eq 'log'; my $expected_keys = get_expected_keys($type); my $statement = "GET $type\n".$filter."Limit: 1"; $lastquery = $statement; my $hash_ref = $ml->selectrow_hashref($statement); undef $lastquery; is(ref $hash_ref, 'HASH', $type.' keys are a hash') or BAIL_OUT($type.'keys are not in hash format, got '.Dumper($hash_ref)); my @keys = sort keys %{$hash_ref}; is_deeply(\@keys, $expected_keys, $key.' '.$type.' table columns') or BAIL_OUT("got $type keys:\n".join(', ', @keys)."\nbut expected\n".join(', ', @{$expected_keys})); } my $statement = "GET hosts\nColumns: name as hostname state\nLimit: 1"; $lastquery = $statement; my $hash_ref = $ml->selectrow_hashref($statement); undef $lastquery; isnt($hash_ref, undef, $key.' test column alias'); is($Monitoring::Livestatus::ErrorCode, 0, $key.' test column alias') or diag('got error: '.$Monitoring::Livestatus::ErrorMessage); ######################### # send a test command # commands still don't work and breaks livestatus my $rt = $ml->do('COMMAND ['.time().'] SAVE_STATE_INFORMATION'); is($rt, '1', $key.' test command'); ######################### # check for errors #$ml->{'verbose'} = 1; $statement = "GET hosts\nLimit: 1"; $lastquery = $statement; $hash_ref = $ml->selectrow_hashref($statement ); undef $lastquery; isnt($hash_ref, undef, $key.' test error 200 body'); is($Monitoring::Livestatus::ErrorCode, 0, $key.' test error 200 status') or diag('got error: '.$Monitoring::Livestatus::ErrorMessage); $statement = "BLAH hosts"; $lastquery = $statement; $hash_ref = $ml->selectrow_hashref($statement ); undef $lastquery; is($hash_ref, undef, $key.' test error 401 body'); is($Monitoring::Livestatus::ErrorCode, '401', $key.' test error 401 status') or diag('got error: '.$Monitoring::Livestatus::ErrorMessage); $statement = "GET hosts\nLimit: "; $lastquery = $statement; $hash_ref = $ml->selectrow_hashref($statement ); undef $lastquery; is($hash_ref, undef, $key.' test error 403 body'); is($Monitoring::Livestatus::ErrorCode, '403', $key.' test error 403 status') or diag('got error: '.$Monitoring::Livestatus::ErrorMessage); $statement = "GET unknowntable\nLimit: 1"; $lastquery = $statement; $hash_ref = $ml->selectrow_hashref($statement ); undef $lastquery; is($hash_ref, undef, $key.' test error 404 body'); is($Monitoring::Livestatus::ErrorCode, '404', $key.' test error 404 status') or diag('got error: '.$Monitoring::Livestatus::ErrorMessage); $statement = "GET hosts\nColumns: unknown"; $lastquery = $statement; $hash_ref = $ml->selectrow_hashref($statement ); undef $lastquery; is($hash_ref, undef, $key.' test error 405 body'); TODO: { local $TODO = 'livestatus returns wrong status'; is($Monitoring::Livestatus::ErrorCode, '405', $key.' test error 405 status') or diag('got error: '.$Monitoring::Livestatus::ErrorMessage); }; ######################### # some more broken statements $statement = "GET "; $lastquery = $statement; $hash_ref = $ml->selectrow_hashref($statement); undef $lastquery; is($hash_ref, undef, $key.' test error 403 body'); is($Monitoring::Livestatus::ErrorCode, '403', $key.' test error 403 status: GET ') or diag('got error: '.$Monitoring::Livestatus::ErrorMessage); $statement = "GET hosts\nColumns: name, name"; $lastquery = $statement; $hash_ref = $ml->selectrow_hashref($statement ); undef $lastquery; is($hash_ref, undef, $key.' test error 405 body'); is($Monitoring::Livestatus::ErrorCode, '405', $key.' test error 405 status: GET hosts\nColumns: name, name') or diag('got error: '.$Monitoring::Livestatus::ErrorMessage); $statement = "GET hosts\nColumns: "; $lastquery = $statement; $hash_ref = $ml->selectrow_hashref($statement ); undef $lastquery; is($hash_ref, undef, $key.' test error 405 body'); is($Monitoring::Livestatus::ErrorCode, '405', $key.' test error 405 status: GET hosts\nColumns: ') or diag('got error: '.$Monitoring::Livestatus::ErrorMessage); ######################### # some forbidden headers $statement = "GET hosts\nKeepAlive: on"; $lastquery = $statement; $hash_ref = $ml->selectrow_hashref($statement ); undef $lastquery; is($hash_ref, undef, $key.' test error 496 body'); is($Monitoring::Livestatus::ErrorCode, '496', $key.' test error 496 status: KeepAlive: on') or diag('got error: '.$Monitoring::Livestatus::ErrorMessage); $statement = "GET hosts\nResponseHeader: fixed16"; $lastquery = $statement; $hash_ref = $ml->selectrow_hashref($statement ); undef $lastquery; is($hash_ref, undef, $key.' test error 495 body'); is($Monitoring::Livestatus::ErrorCode, '495', $key.' test error 495 status: ResponseHeader: fixed16') or diag('got error: '.$Monitoring::Livestatus::ErrorMessage); $statement = "GET hosts\nColumnHeaders: on"; $lastquery = $statement; $hash_ref = $ml->selectrow_hashref($statement ); undef $lastquery; is($hash_ref, undef, $key.' test error 494 body'); is($Monitoring::Livestatus::ErrorCode, '494', $key.' test error 494 status: ColumnHeader: on') or diag('got error: '.$Monitoring::Livestatus::ErrorMessage); $statement = "GET hosts\nOuputFormat: json"; $lastquery = $statement; $hash_ref = $ml->selectrow_hashref($statement ); undef $lastquery; is($hash_ref, undef, $key.' test error 493 body'); is($Monitoring::Livestatus::ErrorCode, '493', $key.' test error 493 status: OutputForma: json') or diag('got error: '.$Monitoring::Livestatus::ErrorMessage); $statement = "GET hosts\nSeparators: 0 1 2 3"; $lastquery = $statement; $hash_ref = $ml->selectrow_hashref($statement ); undef $lastquery; is($hash_ref, undef, $key.' test error 492 body'); is($Monitoring::Livestatus::ErrorCode, '492', $key.' test error 492 status: Seperators: 0 1 2 3') or diag('got error: '.$Monitoring::Livestatus::ErrorMessage); ######################### # check some fancy stats queries my $stats_query = "GET services Stats: state = 0 as all_ok Stats: state = 1 as all_warning Stats: state = 2 as all_critical Stats: state = 3 as all_unknown Stats: state = 4 as all_pending Stats: host_state != 0 Stats: state = 1 StatsAnd: 2 as all_warning_on_down_hosts Stats: host_state != 0 Stats: state = 2 StatsAnd: 2 as all_critical_on_down_hosts Stats: host_state != 0 Stats: state = 3 StatsAnd: 2 as all_unknown_on_down_hosts Stats: host_state != 0 Stats: state = 3 Stats: active_checks_enabled = 1 StatsAnd: 3 as all_unknown_active_on_down_hosts Stats: state = 3 Stats: active_checks_enabled = 1 StatsOr: 2 as all_active_or_unknown"; $lastquery = $stats_query; $hash_ref = $ml->selectrow_hashref($stats_query ); undef $lastquery; isnt($hash_ref, undef, $key.' test fancy stats query') or diag('got error: '.Dumper($hash_ref)); } # generate expected keys sub get_expected_keys { my $type = shift; my $skip = shift; my @keys = @{$expected_keys->{$type}}; my @new_keys; for my $key (@keys) { my $replaced = 0; for my $replace_with (keys %{$expected_keys}) { if($key eq '__all_from_'.$replace_with.'__') { $replaced = 1; next if $skip; my $prefix = $replace_with.'_'; if($replace_with eq "hosts") { $prefix = 'host_'; } if($replace_with eq "services") { $prefix = 'service_'; } if($replace_with eq "commands") { $prefix = 'command_'; } if($replace_with eq "contacts") { $prefix = 'contact_'; } if($replace_with eq "servicegroups") { $prefix = 'servicegroup_'; } if($replace_with eq "hostgroups") { $prefix = 'hostgroup_'; } if($type eq "log") { $prefix = 'current_'.$prefix; } if($type eq "servicesbygroup" and $replace_with eq 'services') { $prefix = ''; } if($type eq "servicesbyhostgroup" and $replace_with eq 'services') { $prefix = ''; } if($type eq "hostsbygroup" and $replace_with eq 'hosts') { $prefix = ''; } my $replace_keys = get_expected_keys($replace_with, 1); for my $key2 (@{$replace_keys}) { push @new_keys, $prefix.$key2; } } } if($replaced == 0) { push @new_keys, $key; } } # has been fixed in 1.1.1rc #if($type eq 'log') { # my %keys = map { $_ => 1 } @new_keys; # delete $keys{'current_contact_can_submit_commands'}; # delete $keys{'current_contact_host_notifications_enabled'}; # delete $keys{'current_contact_in_host_notification_period'}; # delete $keys{'current_contact_in_service_notification_period'}; # delete $keys{'current_contact_service_notifications_enabled'}; # @new_keys = keys %keys; #} my @return = sort @new_keys; return(\@return); } Monitoring-Livestatus-0.86/t/02-Monitoring-Livestatus-internals.t0000644000175000017500000001107515010055415023577 0ustar svensven#!/usr/bin/env perl ######################### use strict; use Test::More; use File::Temp; use Data::Dumper; use IO::Socket::UNIX qw( SOCK_STREAM SOMAXCONN ); use_ok('Monitoring::Livestatus'); BEGIN { if( $^O eq 'MSWin32' ) { plan skip_all => 'no sockets on windows'; } else { plan tests => 14; } } ######################### # get a temp file from File::Temp and replace it with our socket my $fh = File::Temp->new(UNLINK => 0); my $socket_path = $fh->filename; unlink($socket_path); my $listener = IO::Socket::UNIX->new( Type => SOCK_STREAM, Listen => SOMAXCONN, Local => $socket_path, ) or die("failed to open $socket_path as test socket: $!"); ######################### # create object with single arg my $ml = Monitoring::Livestatus->new( 'localhost:12345' ); isa_ok($ml, 'Monitoring::Livestatus', 'single args server'); isa_ok($ml->{'CONNECTOR'}, 'Monitoring::Livestatus::INET', 'single args server peer'); is($ml->{'CONNECTOR'}->peer_name, 'localhost:12345', 'single args server peer name'); is($ml->{'CONNECTOR'}->peer_addr, 'localhost:12345', 'single args server peer addr'); ######################### # create object with single arg $ml = Monitoring::Livestatus->new( $socket_path ); isa_ok($ml, 'Monitoring::Livestatus', 'single args socket'); isa_ok($ml->{'CONNECTOR'}, 'Monitoring::Livestatus::UNIX', 'single args socket peer'); is($ml->{'CONNECTOR'}->peer_name, $socket_path, 'single args socket peer name'); is($ml->{'CONNECTOR'}->peer_addr, $socket_path, 'single args socket peer addr'); my $header = "404 43\n"; my($error,$error_msg) = $ml->_parse_header($header); is($error, '404', 'error code 404'); isnt($error_msg, undef, 'error code 404 message'); ######################### my $stats_query1 = "GET services Stats: state = 0 Stats: state = 1 Stats: state = 2 Stats: state = 3 Stats: state = 4 Stats: host_state != 0 Stats: state = 1 StatsAnd: 2 Stats: host_state != 0 Stats: state = 2 StatsAnd: 2 Stats: host_state != 0 Stats: state = 3 StatsAnd: 2 Stats: host_state != 0 Stats: state = 3 Stats: active_checks = 1 StatsAnd: 3 Stats: state = 3 Stats: active_checks = 1 StatsOr: 2"; my @expected_keys1 = ( 'state = 0', 'state = 1', 'state = 2', 'state = 3', 'state = 4', 'host_state != 0 && state = 1', 'host_state != 0 && state = 2', 'host_state != 0 && state = 3', 'host_state != 0 && state = 3 && active_checks = 1', 'state = 3 || active_checks = 1', ); my($statement, $got_keys1) = Monitoring::Livestatus::extract_keys_from_stats_statement($stats_query1); is_deeply($got_keys1, \@expected_keys1, 'statsAnd, statsOr query keys') or ( diag('got keys: '.Dumper($got_keys1)) ); ######################### my $stats_query2 = "GET services Stats: state = 0 as all_ok Stats: state = 1 as all_warning Stats: state = 2 as all_critical Stats: state = 3 as all_unknown Stats: state = 4 as all_pending Stats: host_state != 0 Stats: state = 1 StatsAnd: 2 as all_warning_on_down_hosts Stats: host_state != 0 Stats: state = 2 StatsAnd: 2 as all_critical_on_down_hosts Stats: host_state != 0 Stats: state = 3 StatsAnd: 2 as all_unknown_on_down_hosts Stats: host_state != 0 Stats: state = 3 Stats: active_checks_enabled = 1 StatsAnd: 3 as all_unknown_active_on_down_hosts Stats: state = 3 Stats: active_checks_enabled = 1 StatsOr: 2 as all_active_or_unknown"; my @expected_keys2 = ( 'all_ok', 'all_warning', 'all_critical', 'all_unknown', 'all_pending', 'all_warning_on_down_hosts', 'all_critical_on_down_hosts', 'all_unknown_on_down_hosts', 'all_unknown_active_on_down_hosts', 'all_active_or_unknown', ); my($statement, $got_keys2) = Monitoring::Livestatus::extract_keys_from_stats_statement($stats_query2); is_deeply($got_keys2, \@expected_keys2, 'stats query keys2') or ( diag('got keys: '.Dumper($got_keys2)) ); ######################### my $normal_query1 = "GET services Columns: host_name as host is_flapping description as name state "; my @expected_keys3 = ( 'host', 'is_flapping', 'name', 'state', ); my @got_keys3 = @{$ml->_extract_keys_from_columns_header($normal_query1)}; is_deeply(\@got_keys3, \@expected_keys3, 'normal query keys') or ( diag('got keys: '.Dumper(\@got_keys3)) ); ######################### unlink($socket_path); Monitoring-Livestatus-0.86/t/35-Monitoring-Livestatus-callbacks_support.t0000644000175000017500000000421615010055415025320 0ustar svensven#!/usr/bin/env perl ######################### use strict; use Encode; use Test::More; use Data::Dumper; if ( !defined $ENV{TEST_SERVER} ) { my $msg = 'Author test. Set $ENV{TEST_SOCKET} and $ENV{TEST_SERVER} to run'; plan( skip_all => $msg ); } else { plan( tests => 15 ); } use_ok('Monitoring::Livestatus'); #use Log::Log4perl qw(:easy); #Log::Log4perl->easy_init($DEBUG); ######################### my $objects_to_test = { # create inet object with hash args '01 inet_hash_args' => Monitoring::Livestatus->new( verbose => 0, server => $ENV{TEST_SERVER}, keepalive => 1, timeout => 3, retries_on_connection_error => 0, # logger => get_logger(), ), # create inet object with a single arg '02 inet_single_arg' => Monitoring::Livestatus::INET->new( $ENV{TEST_SERVER} ), }; for my $key (sort keys %{$objects_to_test}) { my $ml = $objects_to_test->{$key}; isa_ok($ml, 'Monitoring::Livestatus'); my $got = $ml->selectall_arrayref("GET hosts\nColumns: name alias state\nLimit: 1", { Slice => 1, callbacks => { 'c1' => sub { return $_[0]->{'alias'}; } } }); isnt($got->[0]->{'alias'}, undef, 'got a test host'); is($got->[0]->{'alias'}, $got->[0]->{'c1'}, 'callback for sliced results'); $got = $ml->selectall_arrayref("GET hosts\nColumns: name alias state\nLimit: 1", { Slice => 1, callbacks => { 'name' => sub { return $_[0]->{'alias'}; } } }); isnt($got->[0]->{'alias'}, undef, 'got a test host'); is($got->[0]->{'alias'}, $got->[0]->{'name'}, 'callback for sliced results which overwrites key'); $got = $ml->selectall_arrayref("GET hosts\nColumns: name alias state\nLimit: 1", { callbacks => { 'c1' => sub { return $_[0]->[1]; } } }); isnt($got->[0]->[1], undef, 'got a test host'); is($got->[0]->[1], $got->[0]->[3], 'callback for non sliced results'); } Monitoring-Livestatus-0.86/t/33-Monitoring-Livestatus-test_socket_timeout.t0000644000175000017500000000457415010055415025707 0ustar svensven#!/usr/bin/env perl ######################### use strict; use Test::More; use Data::Dumper; if ( !defined $ENV{TEST_SERVER} ) { my $msg = 'Author test. Set $ENV{TEST_SOCKET} and $ENV{TEST_SERVER} to run'; plan( skip_all => $msg ); } else { plan( tests => 7 ); } # set an alarm my $lastquery; $SIG{ALRM} = sub { my @caller = caller; print STDERR 'last query: '.$lastquery if defined $lastquery; die "timeout reached:".Dumper(\@caller)."\n" }; alarm(30); use_ok('Monitoring::Livestatus'); #use Log::Log4perl qw(:easy); #Log::Log4perl->easy_init($DEBUG); ######################### # Test Query ######################### my $statement = "GET hosts\nColumns: alias\nFilter: name = host1"; ######################### my $objects_to_test = { # create inet object with hash args '01 inet_hash_args' => Monitoring::Livestatus->new( verbose => 0, server => $ENV{TEST_SERVER}, keepalive => 1, timeout => 3, retries_on_connection_error => 0, # logger => get_logger(), ), # create inet object with a single arg '02 inet_single_arg' => Monitoring::Livestatus::INET->new( $ENV{TEST_SERVER} ), }; for my $key (sort keys %{$objects_to_test}) { my $ml = $objects_to_test->{$key}; isa_ok($ml, 'Monitoring::Livestatus'); # we don't need warnings for testing $ml->warnings(0); ######################### my $ary_ref = $ml->selectall_arrayref($statement); is($Monitoring::Livestatus::ErrorCode, 0, 'Query Status 0'); #is_deeply($ary_ref, $selectall_arrayref1, 'selectall_arrayref($statement)') # or diag("got: ".Dumper($ary_ref)."\nbut expected ".Dumper($selectall_arrayref1)); sleep(10); $ary_ref = $ml->selectall_arrayref($statement); is($Monitoring::Livestatus::ErrorCode, 0, 'Query Status 0'); #is_deeply($ary_ref, $selectall_arrayref1, 'selectall_arrayref($statement)') # or diag("got: ".Dumper($ary_ref)."\nbut expected ".Dumper($selectall_arrayref1)); #print Dumper($Monitoring::Livestatus::ErrorCode); #print Dumper($Monitoring::Livestatus::ErrorMessage); } Monitoring-Livestatus-0.86/t/perlcriticrc0000644000175000017500000001711515010055415017321 0ustar svensven############################################################################## # This Perl::Critic configuration file sets the Policy severity levels # according to Damian Conway's own personal recommendations. Feel free to # use this as your own, or make modifications. ############################################################################## [Perl::Critic::Policy::ValuesAndExpressions::ProhibitAccessOfPrivateData] severity = 3 [Perl::Critic::Policy::BuiltinFunctions::ProhibitLvalueSubstr] severity = 3 [Perl::Critic::Policy::BuiltinFunctions::ProhibitReverseSortBlock] severity = 1 [Perl::Critic::Policy::BuiltinFunctions::ProhibitSleepViaSelect] severity = 5 [Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval] severity = 5 [Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit] severity = 2 [Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalCan] severity = 4 [Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalIsa] severity = 4 [Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep] severity = 3 [Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap] severity = 3 [Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep] severity = 4 [Perl::Critic::Policy::BuiltinFunctions::RequireBlockMap] severity = 4 [Perl::Critic::Policy::BuiltinFunctions::RequireGlobFunction] severity = 5 [Perl::Critic::Policy::BuiltinFunctions::RequireSimpleSortBlock] severity = 3 [Perl::Critic::Policy::ClassHierarchies::ProhibitAutoloading] severity = 3 [Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA] severity = 4 [Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless] severity = 5 [Perl::Critic::Policy::CodeLayout::ProhibitHardTabs] severity = 3 [Perl::Critic::Policy::CodeLayout::ProhibitParensWithBuiltins] severity = 1 [Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists] severity = 2 [Perl::Critic::Policy::CodeLayout::RequireConsistentNewlines] severity = 4 [Perl::Critic::Policy::CodeLayout::RequireTidyCode] severity = 1 [Perl::Critic::Policy::CodeLayout::RequireTrailingCommas] severity = 3 [Perl::Critic::Policy::ControlStructures::ProhibitCStyleForLoops] severity = 3 [Perl::Critic::Policy::ControlStructures::ProhibitCascadingIfElse] severity = 3 [Perl::Critic::Policy::ControlStructures::ProhibitDeepNests] severity = 3 [Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions] severity = 5 [Perl::Critic::Policy::ControlStructures::ProhibitPostfixControls] severity = 4 [Perl::Critic::Policy::ControlStructures::ProhibitUnlessBlocks] severity = 4 [Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode] severity = 4 [Perl::Critic::Policy::ControlStructures::ProhibitUntilBlocks] severity = 4 [Perl::Critic::Policy::Documentation::RequirePodAtEnd] severity = 2 [Perl::Critic::Policy::Documentation::RequirePodSections] severity = 2 [Perl::Critic::Policy::ErrorHandling::RequireCarping] severity = 4 [Perl::Critic::Policy::InputOutput::ProhibitBacktickOperators] severity = 3 [Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles] severity = 5 [Perl::Critic::Policy::InputOutput::ProhibitInteractiveTest] severity = 4 [Perl::Critic::Policy::InputOutput::ProhibitOneArgSelect] severity = 4 [Perl::Critic::Policy::InputOutput::ProhibitReadlineInForLoop] severity = 5 [Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen] severity = 4 [Perl::Critic::Policy::InputOutput::RequireBracedFileHandleWithPrint] severity = 3 [Perl::Critic::Policy::Miscellanea::ProhibitFormats] severity = 3 [Perl::Critic::Policy::Miscellanea::ProhibitTies] severity = 4 [-Perl::Critic::Policy::Miscellanea::RequireRcsKeywords] [Perl::Critic::Policy::Modules::ProhibitAutomaticExportation] severity = 4 [Perl::Critic::Policy::Modules::ProhibitEvilModules] severity = 5 [Perl::Critic::Policy::Modules::ProhibitMultiplePackages] severity = 4 [Perl::Critic::Policy::Modules::RequireBarewordIncludes] severity = 5 [Perl::Critic::Policy::Modules::RequireEndWithOne] severity = 4 [Perl::Critic::Policy::Modules::RequireExplicitPackage] severity = 4 [Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage] severity = 5 [Perl::Critic::Policy::Modules::RequireVersionVar] severity = 4 [Perl::Critic::Policy::NamingConventions::ProhibitAmbiguousNames] severity = 3 [Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseSubs] severity = 1 [Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseVars] severity = 1 [Perl::Critic::Policy::References::ProhibitDoubleSigils] severity = 4 [Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest] severity = 4 [Perl::Critic::Policy::RegularExpressions::RequireExtendedFormatting] severity = 5 [Perl::Critic::Policy::RegularExpressions::RequireLineBoundaryMatching] severity = 5 [Perl::Critic::Policy::Subroutines::ProhibitAmpersandSigils] severity = 2 [Perl::Critic::Policy::Subroutines::ProhibitBuiltinHomonyms] severity = 4 [Perl::Critic::Policy::Subroutines::ProhibitExcessComplexity] severity = 3 [Perl::Critic::Policy::Subroutines::ProhibitExplicitReturnUndef] severity = 5 [Perl::Critic::Policy::Subroutines::ProhibitSubroutinePrototypes] severity = 4 [Perl::Critic::Policy::Subroutines::ProtectPrivateSubs] severity = 3 [Perl::Critic::Policy::Subroutines::RequireFinalReturn] severity = 5 [Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict] severity = 5 [Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings] severity = 4 [Perl::Critic::Policy::TestingAndDebugging::ProhibitProlongedStrictureOverride] severity = 4 [Perl::Critic::Policy::TestingAndDebugging::RequireTestLabels] severity = 3 [Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict] severity = 5 [Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings] severity = 4 [Perl::Critic::Policy::ValuesAndExpressions::ProhibitConstantPragma] severity = 4 [Perl::Critic::Policy::ValuesAndExpressions::ProhibitEmptyQuotes] severity = 2 [Perl::Critic::Policy::ValuesAndExpressions::ProhibitEscapedCharacters] severity = 2 [Perl::Critic::Policy::ValuesAndExpressions::ProhibitInterpolationOfLiterals] severity = 1 [Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros] severity = 5 [Perl::Critic::Policy::ValuesAndExpressions::ProhibitMismatchedOperators] severity = 2 [Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators] severity = 4 [Perl::Critic::Policy::ValuesAndExpressions::ProhibitNoisyQuotes] severity = 2 [Perl::Critic::Policy::ValuesAndExpressions::ProhibitVersionStrings] severity = 3 [Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars] severity = 1 [Perl::Critic::Policy::ValuesAndExpressions::RequireNumberSeparators] severity = 2 [Perl::Critic::Policy::ValuesAndExpressions::RequireQuotedHeredocTerminator] severity = 4 [Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator] severity = 4 [Perl::Critic::Policy::Variables::ProhibitConditionalDeclarations] severity = 5 [Perl::Critic::Policy::Variables::ProhibitLocalVars] severity = 2 [Perl::Critic::Policy::Variables::ProhibitMatchVars] severity = 4 [Perl::Critic::Policy::Variables::ProhibitPackageVars] severity = 3 [Perl::Critic::Policy::Variables::ProhibitPunctuationVars] severity = 2 [Perl::Critic::Policy::Variables::ProtectPrivateVars] severity = 3 [Perl::Critic::Policy::Variables::RequireInitializationForLocalVars] severity = 5 [Perl::Critic::Policy::Variables::RequireLexicalLoopIterators] severity = 5 [Perl::Critic::Policy::Variables::RequireNegativeIndices] severity = 4Monitoring-Livestatus-0.86/t/01-Monitoring-Livestatus-basic_tests.t0000644000175000017500000001205115010055415024075 0ustar svensven#!/usr/bin/env perl ######################### use strict; use Test::More; use File::Temp; use Data::Dumper; use IO::Socket::UNIX qw( SOCK_STREAM SOMAXCONN ); use_ok('Monitoring::Livestatus'); BEGIN { if( $^O eq 'MSWin32' ) { plan skip_all => 'no sockets on windows'; } else { plan tests => 29; } } ######################### # get a temp file from File::Temp and replace it with our socket my $fh = File::Temp->new(UNLINK => 0); my $socket_path = $fh->filename; unlink($socket_path); my $listener = IO::Socket::UNIX->new( Type => SOCK_STREAM, Listen => SOMAXCONN, Local => $socket_path, ) or die("failed to open $socket_path as test socket: $!"); ######################### # create object with single arg my $ml = Monitoring::Livestatus->new( $socket_path ); isa_ok($ml, 'Monitoring::Livestatus', 'single args'); is($ml->peer_name(), $socket_path, 'get peer_name()'); is($ml->peer_addr(), $socket_path, 'get peer_addr()'); ######################### # create object with hash args my $line_separator = 10; my $column_separator = 0; $ml = Monitoring::Livestatus->new( verbose => 0, socket => $socket_path, line_separator => $line_separator, column_separator => $column_separator, ); isa_ok($ml, 'Monitoring::Livestatus', 'new hash args'); is($ml->peer_name(), $socket_path, 'get peer_name()'); is($ml->peer_addr(), $socket_path, 'get peer_addr()'); ######################### # create object with peer arg $ml = Monitoring::Livestatus->new( peer => $socket_path, ); isa_ok($ml, 'Monitoring::Livestatus', 'peer hash arg socket'); is($ml->peer_name(), $socket_path, 'get peer_name()'); is($ml->peer_addr(), $socket_path, 'get peer_addr()'); isa_ok($ml->{'CONNECTOR'}, 'Monitoring::Livestatus::UNIX', 'peer backend UNIX'); ######################### # create object with peer arg my $server = 'localhost:12345'; $ml = Monitoring::Livestatus->new( peer => $server, ); isa_ok($ml, 'Monitoring::Livestatus', 'peer hash arg server'); is($ml->peer_name(), $server, 'get peer_name()'); is($ml->peer_addr(), $server, 'get peer_addr()'); isa_ok($ml->{'CONNECTOR'}, 'Monitoring::Livestatus::INET', 'peer backend INET'); ######################### $ml = Monitoring::Livestatus->new( peer => [ $socket_path ], verbose => 0, keepalive => 1, logger => undef, ); isa_ok($ml, 'Monitoring::Livestatus', 'peer hash arg multi with keepalive'); is($ml->peer_name(), $socket_path, 'get peer_name()'); is($ml->peer_addr(), $socket_path, 'get peer_addr()'); ######################### # timeout checks $ml = Monitoring::Livestatus->new( peer => [ $socket_path ], verbose => 0, timeout => 13, logger => undef, ); isa_ok($ml, 'Monitoring::Livestatus', 'peer hash arg multi with general timeout'); is($ml->peer_name(), $socket_path, 'get peer_name()'); is($ml->peer_addr(), $socket_path, 'get peer_addr()'); is($ml->{'connect_timeout'}, 13, 'connect_timeout'); is($ml->{'query_timeout'}, 13, 'query_timeout'); $ml = Monitoring::Livestatus->new( peer => [ $socket_path ], verbose => 0, query_timeout => 14, connect_timeout => 17, logger => undef, ); isa_ok($ml, 'Monitoring::Livestatus', 'peer hash arg multi with general timeout'); is($ml->peer_name(), $socket_path, 'get peer_name()'); is($ml->peer_addr(), $socket_path, 'get peer_addr()'); is($ml->{'connect_timeout'}, 17, 'connect_timeout'); is($ml->{'query_timeout'}, 14, 'query_timeout'); ######################### # error retry $ml = Monitoring::Livestatus->new( peer => [ $socket_path ], verbose => 0, retries_on_connection_error => 3, retry_interval => 1, logger => undef, ); isa_ok($ml, 'Monitoring::Livestatus', 'peer hash arg multi with error retry'); ######################### # cleanup unlink($socket_path); Monitoring-Livestatus-0.86/t/99-Perl-Critic.t0000644000175000017500000000076515010055415017455 0ustar svensven#!/usr/bin/env perl # # $Id$ # use strict; use warnings; use File::Spec; use Test::More; if ( not $ENV{TEST_AUTHOR} ) { my $msg = 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; plan( skip_all => $msg ); } eval { require Test::Perl::Critic; }; if ( $@ ) { my $msg = 'Test::Perl::Critic required to criticise code'; plan( skip_all => $msg ); } my $rcfile = File::Spec->catfile( 't', 'perlcriticrc' ); Test::Perl::Critic->import( -profile => $rcfile ); all_critic_ok(); Monitoring-Livestatus-0.86/t/22-Monitoring-Livestatus-UNIX.t0000644000175000017500000000166415010055415022370 0ustar svensven#!/usr/bin/env perl ######################### use strict; use Test::More tests => 3; use IO::Socket::INET; BEGIN { use_ok('Monitoring::Livestatus::UNIX') }; ######################### # create object with single arg my $socket = "/tmp/blah.socket"; my $ml = Monitoring::Livestatus::UNIX->new( $socket ); isa_ok($ml, 'Monitoring::Livestatus', 'Monitoring::Livestatus::UNIX->new()'); ######################### # create object with hash args my $line_separator = 10; my $column_separator = 0; $ml = Monitoring::Livestatus::UNIX->new( verbose => 0, socket => $socket, line_separator => $line_separator, column_separator => $column_separator, ); isa_ok($ml, 'Monitoring::Livestatus', 'Monitoring::Livestatus::UNIX->new(%args)'); Monitoring-Livestatus-0.86/t/085-json_xs.t0000644000175000017500000000106615010055415017071 0ustar svensvenuse strict; use warnings; use Test::More; plan skip_all => 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.' unless $ENV{TEST_AUTHOR}; open(my $ph, '-|', 'bash -c "find ./lib ./t -type f" 2>&1') or die('find failed: '.$!); while(<$ph>) { my $line = $_; chomp($line); check_json_xs($line); } done_testing(); sub check_json_xs { my($file) = @_; ok($file, $file); my $out = `grep -n JSON::XS "$file" | grep -v Cpanel::JSON::XS`; if($out) { fail($file." uses JSON::XS instead of Cpanel::JSON::XS"); } return; } Monitoring-Livestatus-0.86/t/21-Monitoring-Livestatus-INET.t0000644000175000017500000000214215010055415022333 0ustar svensven#!/usr/bin/env perl ######################### use strict; use Test::More tests => 3; use IO::Socket::INET; BEGIN { use_ok('Monitoring::Livestatus::INET') }; ######################### # create a tmp listener my $server = 'localhost:9999'; my $listener = IO::Socket::INET->new( ) or die("failed to open port as test listener: $!"); ######################### # create object with single arg my $ml = Monitoring::Livestatus::INET->new( $server ); isa_ok($ml, 'Monitoring::Livestatus', 'Monitoring::Livestatus::INET->new()'); ######################### # create object with hash args my $line_separator = 10; my $column_separator = 0; $ml = Monitoring::Livestatus::INET->new( verbose => 0, server => $server, line_separator => $line_separator, column_separator => $column_separator, ); isa_ok($ml, 'Monitoring::Livestatus', 'Monitoring::Livestatus::INET->new(%args)'); Monitoring-Livestatus-0.86/MANIFEST0000644000175000017500000000177015010055415015577 0ustar svensvenChanges examples/dump.pl examples/test.pl inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Monitoring/Livestatus.pm lib/Monitoring/Livestatus/INET.pm lib/Monitoring/Livestatus/UNIX.pm Makefile.PL MANIFEST META.yml README t/01-Monitoring-Livestatus-basic_tests.t t/02-Monitoring-Livestatus-internals.t t/085-json_xs.t t/20-Monitoring-Livestatus-test_socket.t t/21-Monitoring-Livestatus-INET.t t/22-Monitoring-Livestatus-UNIX.t t/23-Monitoring-Livestatus-BigData.t t/30-Monitoring-Livestatus-live-test.t t/32-Monitoring-Livestatus-backend-test.t t/33-Monitoring-Livestatus-test_socket_timeout.t t/34-Monitoring-Livestatus-utf8_support.t t/35-Monitoring-Livestatus-callbacks_support.t t/97-Pod.t t/98-Pod-Coverage.t t/99-Perl-Critic.t t/perlcriticrc Monitoring-Livestatus-0.86/inc/0000755000175000017500000000000015010056571015216 5ustar svensvenMonitoring-Livestatus-0.86/inc/Module/0000755000175000017500000000000015010056571016443 5ustar svensvenMonitoring-Livestatus-0.86/inc/Module/Install/0000755000175000017500000000000015010056571020051 5ustar svensvenMonitoring-Livestatus-0.86/inc/Module/Install/Include.pm0000644000175000017500000000101515010055670021766 0ustar svensven#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; Monitoring-Livestatus-0.86/inc/Module/Install/Makefile.pm0000644000175000017500000002743715010055670022140 0ustar svensven#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-separated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 Monitoring-Livestatus-0.86/inc/Module/Install/Can.pm0000644000175000017500000000640515010055670021114 0ustar svensven#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; if ($^O eq 'VMS') { require ExtUtils::CBuilder; my $builder = ExtUtils::CBuilder->new( quiet => 1, ); return $builder->have_compiler; } my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 245 Monitoring-Livestatus-0.86/inc/Module/Install/Metadata.pm0000644000175000017500000004343715010055670022141 0ustar svensven#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) [\s|;]* /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', artistic => 'http://opensource.org/licenses/artistic-license.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, # these are not actually allowed in meta-spec v1.4 but are left here for compatibility: apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashes delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Monitoring-Livestatus-0.86/inc/Module/Install/Win32.pm0000644000175000017500000000340315010055670021310 0ustar svensven#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Monitoring-Livestatus-0.86/inc/Module/Install/Fetch.pm0000644000175000017500000000462715010055670021450 0ustar svensven#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Monitoring-Livestatus-0.86/inc/Module/Install/AutoInstall.pm0000644000175000017500000000416215010055670022650 0ustar svensven#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub AutoInstall { $_[0] } sub run { my $self = shift; $self->auto_install_now(@_); } sub write { my $self = shift; $self->auto_install(@_); } sub auto_install { my $self = shift; return if $self->{done}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; my @config = @_; # We'll need Module::AutoInstall $self->include('Module::AutoInstall'); require Module::AutoInstall; my @features_require = Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); my %seen; my @requires = map @$_, map @$_, grep ref, $self->requires; while (my ($mod, $ver) = splice(@requires, 0, 2)) { $seen{$mod}{$ver}++; } my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @deduped; while (my ($mod, $ver) = splice(@features_require, 0, 2)) { push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; } $self->requires(@deduped); $self->makemaker_args( Module::AutoInstall::_make_args() ); my $class = ref($self); $self->postamble( "# --- $class section:\n" . Module::AutoInstall::postamble() ); } sub installdeps_target { my ($self, @args) = @_; $self->include('Module::AutoInstall'); require Module::AutoInstall; Module::AutoInstall::_installdeps_target(1); $self->auto_install(@args); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; Monitoring-Livestatus-0.86/inc/Module/Install/WriteAll.pm0000644000175000017500000000237615010055670022141 0ustar svensven#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Monitoring-Livestatus-0.86/inc/Module/Install/Base.pm0000644000175000017500000000214715010055670021264 0ustar svensven#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.21'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Monitoring-Livestatus-0.86/inc/Module/Install.pm0000644000175000017500000002714515010055670020417 0ustar svensven#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.006; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.21'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS'; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( {no_chdir => 1, wanted => sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($File::Find::name); my $in_pod = 0; foreach ( split /\n/, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }}, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; binmode FH; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. Monitoring-Livestatus-0.86/inc/Module/AutoInstall.pm0000644000175000017500000006231115010055670021242 0ustar svensven#line 1 package Module::AutoInstall; use strict; use Cwd (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.21'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps, $UpgradeDeps ); my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps, $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps, $PostambleActionsListAllDeps, $PostambleUsed, $NoTest); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub _installdeps_target { $InstallDepsTarget = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) { $UpgradeDeps = 1; __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::getcwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward compatibility while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. my $cur = _version_of($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { if (not defined $cur) # indeed missing { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; } else { # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above print "too old. ($cur < $arg)\n"; } push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or $InstallDepsTarget or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN) ) { require Config; my $make = $Config::Config{make}; if ($InstallDepsTarget) { print "*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n"; } else { print "*** Dependencies will be installed the next time you type '$make'.\n"; } # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; return (@Existing, @Missing); } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; if ($ENV{PERL5_CPANM_IS_RUNNING}) { return _running_under('cpanminus'); } my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89') { if ($cpan_env) { return _running_under('CPAN'); } return; # CPAN.pm new enough, don't need to check further } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed, @modules_to_upgrade ); while (my ($pkg, $ver) = splice(@_, 0, 2)) { # grep out those already installed if (_version_cmp(_version_of($pkg), $ver) >= 0) { push @installed, $pkg; if ($UpgradeDeps) { push @modules_to_upgrade, $pkg, $ver; } } else { push @modules, $pkg, $ver; } } if ($UpgradeDeps) { push @modules, @modules_to_upgrade; @installed = (); @modules_to_upgrade = (); } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } push @config, 'prereqs', $value; } elsif ( $key eq 'force' ) { push @config, $key, $value; } elsif ( $key eq 'notest' ) { push @config, 'skiptest', $value; } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^(?:force|notest)$/; # pseudo-option $CPAN::Config->{$opt} = $opt eq 'urllist' ? [$arg] : $arg; } if ($args{notest} && (not CPAN::Shell->can('notest'))) { die "Your version of CPAN is too old to support the 'notest' pragma"; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = do { if ($args{force}) { CPAN::Shell->force( install => $pkg ) } elsif ($args{notest}) { CPAN::Shell->notest( install => $pkg ) } else { CPAN::Shell->install($pkg) } }; $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::getcwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # report version without loading a module sub _version_of { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; foreach my $dir ( @INC ) { next if ref $dir; my $path = File::Spec->catfile($dir, $file); next unless -e $path; require ExtUtils::MM_Unix; return ExtUtils::MM_Unix->parse_version($path); } return undef; } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to # CPAN::HandleConfig->load. CPAN reports that the redirection # is deprecated in a warning printed at the user. # CPAN-1.81 expects CPAN::HandleConfig->load, does not have # $CPAN::HandleConfig::VERSION but cannot handle # CPAN::Config->load # Which "versions expect CPAN::Config->load? if ( $CPAN::HandleConfig::VERSION || CPAN::HandleConfig->can('load') ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison # return values same as <=> sub _version_cmp { my ( $cur, $min ) = @_; return -1 unless defined $cur; # if 0 keep comparing return 1 unless $min; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return version->new($cur) <=> version->new($min); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return Sort::Versions::versioncmp( $cur, $min ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return $cur <=> $min; } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); my $deps_list = join( ',', @Missing, @Existing ); $PostambleActionsUpgradeDeps = "\$(PERL) $0 --config=$config --upgradedeps=$deps_list"; my $config_notest = join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}), 'notest', 1 ) if $Config; $PostambleActionsNoTest = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); $PostambleActionsUpgradeDepsNoTest = "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list"; $PostambleActionsListDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing); my @all = (@Missing, @Existing); $PostambleActionsListAllDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; my $fragment; $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget; config :: installdeps \t\$(NOECHO) \$(NOOP) AUTO_INSTALL $fragment .= <<"END_MAKE"; checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions installdeps_notest :: \t$PostambleActionsNoTest upgradedeps :: \t$PostambleActionsUpgradeDeps upgradedeps_notest :: \t$PostambleActionsUpgradeDepsNoTest listdeps :: \t$PostambleActionsListDeps listalldeps :: \t$PostambleActionsListAllDeps END_MAKE return $fragment; } 1; __END__ #line 1197