initial commit
This commit is contained in:
Phillip Smith
164
api/perl/Changes
Normal file
164
api/perl/Changes
Normal file
@@ -0,0 +1,164 @@
|
||||
Revision history for Perl extension Monitoring::Livestatus.
|
||||
|
||||
|
||||
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
|
||||
38
api/perl/MANIFEST
Normal file
38
api/perl/MANIFEST
Normal file
@@ -0,0 +1,38 @@
|
||||
Changes
|
||||
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/MULTI.pm
|
||||
lib/Monitoring/Livestatus/UNIX.pm
|
||||
Makefile.PL
|
||||
MANIFEST This list of files
|
||||
META.yml
|
||||
README
|
||||
t/01-Monitoring-Livestatus-basic_tests.t
|
||||
t/02-Monitoring-Livestatus-internals.t
|
||||
t/03-Monitoring-Livestatus-MULTI-internals.t
|
||||
t/20-Monitoring-Livestatus-test_socket.t
|
||||
t/21-Monitoring-Livestatus-INET.t
|
||||
t/22-Monitoring-Livestatus-UNIX.t
|
||||
t/30-Monitoring-Livestatus-live-test.t
|
||||
t/31-Monitoring-Livestatus-MULTI-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
|
||||
37
api/perl/META.yml
Normal file
37
api/perl/META.yml
Normal file
@@ -0,0 +1,37 @@
|
||||
---
|
||||
abstract: 'Perl API for check_mk livestatus to access runtime'
|
||||
author:
|
||||
- 'Sven Nierlein, <nierlein@cpan.org>'
|
||||
build_requires:
|
||||
ExtUtils::MakeMaker: 6.42
|
||||
configure_requires:
|
||||
ExtUtils::MakeMaker: 6.42
|
||||
distribution_type: module
|
||||
generated_by: 'Module::Install version 1.00'
|
||||
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:
|
||||
Digest::MD5: 0
|
||||
Encode: 0
|
||||
IO::Socket::INET: 0
|
||||
IO::Socket::UNIX: 0
|
||||
JSON::XS: 0
|
||||
Scalar::Util: 0
|
||||
Test::More: 0.87
|
||||
Thread::Queue: 2.11
|
||||
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.74
|
||||
41
api/perl/Makefile.PL
Normal file
41
api/perl/Makefile.PL
Normal file
@@ -0,0 +1,41 @@
|
||||
# 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::INET';
|
||||
requires 'Digest::MD5';
|
||||
requires 'Scalar::Util';
|
||||
requires 'Test::More' => '0.87';
|
||||
requires 'Thread::Queue' => '2.11';
|
||||
requires 'utf8';
|
||||
requires 'Encode';
|
||||
requires '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;
|
||||
32
api/perl/README
Normal file
32
api/perl/README
Normal file
@@ -0,0 +1,32 @@
|
||||
Monitoring-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 <nierlein@cpan.org>
|
||||
|
||||
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.
|
||||
104
api/perl/examples/dump.pl
Executable file
104
api/perl/examples/dump.pl
Executable file
@@ -0,0 +1,104 @@
|
||||
#!/usr/bin/env perl
|
||||
|
||||
=head1 NAME
|
||||
|
||||
dump.pl - print some information from a socket
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
./dump.pl [ -h ] [ -v ] <socket|server>
|
||||
|
||||
=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, <nierlein@cpan.org>
|
||||
|
||||
=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;
|
||||
}
|
||||
143
api/perl/examples/test.pl
Executable file
143
api/perl/examples/test.pl
Executable file
@@ -0,0 +1,143 @@
|
||||
#!/usr/bin/env perl
|
||||
|
||||
=head1 NAME
|
||||
|
||||
test.pl - print some information from a socket
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
./test.pl [ -h ] [ -v ] <socket|server>
|
||||
|
||||
=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, <nierlein@cpan.org>
|
||||
|
||||
=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;
|
||||
}
|
||||
820
api/perl/inc/Module/AutoInstall.pm
Normal file
820
api/perl/inc/Module/AutoInstall.pm
Normal file
@@ -0,0 +1,820 @@
|
||||
#line 1
|
||||
package Module::AutoInstall;
|
||||
|
||||
use strict;
|
||||
use Cwd ();
|
||||
use ExtUtils::MakeMaker ();
|
||||
|
||||
use vars qw{$VERSION};
|
||||
BEGIN {
|
||||
$VERSION = '1.03';
|
||||
}
|
||||
|
||||
# special map on pre-defined feature sets
|
||||
my %FeatureMap = (
|
||||
'' => 'Core Features', # XXX: deprecated
|
||||
'-core' => 'Core Features',
|
||||
);
|
||||
|
||||
# various lexical flags
|
||||
my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
|
||||
my (
|
||||
$Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps
|
||||
);
|
||||
my ( $PostambleActions, $PostambleUsed );
|
||||
|
||||
# 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 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 =~ /^--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::cwd();
|
||||
|
||||
$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;
|
||||
|
||||
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 combatability
|
||||
|
||||
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 = _load($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 _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;
|
||||
print
|
||||
"*** Dependencies will be installed the next time you type '$Config::Config{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 @_;
|
||||
|
||||
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() : <LOCK> == 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 );
|
||||
while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
|
||||
|
||||
# grep out those already installed
|
||||
if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
|
||||
push @installed, $pkg;
|
||||
}
|
||||
else {
|
||||
push @modules, $pkg, $ver;
|
||||
}
|
||||
}
|
||||
|
||||
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 (<FAILED>) { 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( _load($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";
|
||||
}
|
||||
} 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$/; # pseudo-option
|
||||
$CPAN::Config->{$opt} = $arg;
|
||||
}
|
||||
|
||||
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 = $args{force} ? CPAN::Shell->force( install => $pkg )
|
||||
: 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::cwd() );
|
||||
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( _load($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; # class/instance doesn't matter
|
||||
my $file = $mod;
|
||||
|
||||
$file =~ s|::|/|g;
|
||||
$file .= '.pm';
|
||||
|
||||
local $@;
|
||||
return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 );
|
||||
}
|
||||
|
||||
# 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)"
|
||||
);
|
||||
|
||||
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;
|
||||
|
||||
return <<"END_MAKE";
|
||||
|
||||
config :: installdeps
|
||||
\t\$(NOECHO) \$(NOOP)
|
||||
|
||||
checkdeps ::
|
||||
\t\$(PERL) $0 --checkdeps
|
||||
|
||||
installdeps ::
|
||||
\t$PostambleActions
|
||||
|
||||
END_MAKE
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
#line 1071
|
||||
470
api/perl/inc/Module/Install.pm
Normal file
470
api/perl/inc/Module/Install.pm
Normal file
@@ -0,0 +1,470 @@
|
||||
#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.005;
|
||||
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.00';
|
||||
|
||||
# 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::cwd();
|
||||
my $sym = "${who}::AUTOLOAD";
|
||||
$sym->{$cwd} = sub {
|
||||
my $pwd = Cwd::cwd();
|
||||
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::cwd()) eq $base_path ) {
|
||||
delete $args{prefix};
|
||||
}
|
||||
return $args{_self} if $args{_self};
|
||||
|
||||
$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( 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($subpath . '.pm');
|
||||
my $in_pod = 0;
|
||||
foreach ( split //, $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;
|
||||
}
|
||||
|
||||
# Done in evals to avoid confusing Perl::MinimumVersion
|
||||
eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
|
||||
sub _read {
|
||||
local *FH;
|
||||
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
|
||||
my $string = do { local $/; <FH> };
|
||||
close FH or die "close($_[0]): $!";
|
||||
return $string;
|
||||
}
|
||||
END_NEW
|
||||
sub _read {
|
||||
local *FH;
|
||||
open( FH, "< $_[0]" ) or die "open($_[0]): $!";
|
||||
my $string = do { local $/; <FH> };
|
||||
close FH or die "close($_[0]): $!";
|
||||
return $string;
|
||||
}
|
||||
END_OLD
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
# Done in evals to avoid confusing Perl::MinimumVersion
|
||||
eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
|
||||
sub _write {
|
||||
local *FH;
|
||||
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
|
||||
foreach ( 1 .. $#_ ) {
|
||||
print FH $_[$_] or die "print($_[0]): $!";
|
||||
}
|
||||
close FH or die "close($_[0]): $!";
|
||||
}
|
||||
END_NEW
|
||||
sub _write {
|
||||
local *FH;
|
||||
open( FH, "> $_[0]" ) or die "open($_[0]): $!";
|
||||
foreach ( 1 .. $#_ ) {
|
||||
print FH $_[$_] or die "print($_[0]): $!";
|
||||
}
|
||||
close FH or die "close($_[0]): $!";
|
||||
}
|
||||
END_OLD
|
||||
|
||||
# _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($_[0]) <=> _version($_[1]);
|
||||
}
|
||||
|
||||
# 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 - 2010 Adam Kennedy.
|
||||
82
api/perl/inc/Module/Install/AutoInstall.pm
Normal file
82
api/perl/inc/Module/Install/AutoInstall.pm
Normal file
@@ -0,0 +1,82 @@
|
||||
#line 1
|
||||
package Module::Install::AutoInstall;
|
||||
|
||||
use strict;
|
||||
use Module::Install::Base ();
|
||||
|
||||
use vars qw{$VERSION @ISA $ISCORE};
|
||||
BEGIN {
|
||||
$VERSION = '1.00';
|
||||
@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 auto_install_now {
|
||||
my $self = shift;
|
||||
$self->auto_install(@_);
|
||||
Module::AutoInstall::do_install();
|
||||
}
|
||||
|
||||
1;
|
||||
83
api/perl/inc/Module/Install/Base.pm
Normal file
83
api/perl/inc/Module/Install/Base.pm
Normal file
@@ -0,0 +1,83 @@
|
||||
#line 1
|
||||
package Module::Install::Base;
|
||||
|
||||
use strict 'vars';
|
||||
use vars qw{$VERSION};
|
||||
BEGIN {
|
||||
$VERSION = '1.00';
|
||||
}
|
||||
|
||||
# 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
|
||||
81
api/perl/inc/Module/Install/Can.pm
Normal file
81
api/perl/inc/Module/Install/Can.pm
Normal file
@@ -0,0 +1,81 @@
|
||||
#line 1
|
||||
package Module::Install::Can;
|
||||
|
||||
use strict;
|
||||
use Config ();
|
||||
use File::Spec ();
|
||||
use ExtUtils::MakeMaker ();
|
||||
use Module::Install::Base ();
|
||||
|
||||
use vars qw{$VERSION @ISA $ISCORE};
|
||||
BEGIN {
|
||||
$VERSION = '1.00';
|
||||
@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 '';
|
||||
my $abs = File::Spec->catfile($dir, $_[1]);
|
||||
return $abs if (-x $abs or $abs = MM->maybe_command($abs));
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
# can we locate a (the) C compiler
|
||||
sub can_cc {
|
||||
my $self = shift;
|
||||
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 156
|
||||
93
api/perl/inc/Module/Install/Fetch.pm
Normal file
93
api/perl/inc/Module/Install/Fetch.pm
Normal file
@@ -0,0 +1,93 @@
|
||||
#line 1
|
||||
package Module::Install::Fetch;
|
||||
|
||||
use strict;
|
||||
use Module::Install::Base ();
|
||||
|
||||
use vars qw{$VERSION @ISA $ISCORE};
|
||||
BEGIN {
|
||||
$VERSION = '1.00';
|
||||
@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;
|
||||
34
api/perl/inc/Module/Install/Include.pm
Normal file
34
api/perl/inc/Module/Install/Include.pm
Normal file
@@ -0,0 +1,34 @@
|
||||
#line 1
|
||||
package Module::Install::Include;
|
||||
|
||||
use strict;
|
||||
use Module::Install::Base ();
|
||||
|
||||
use vars qw{$VERSION @ISA $ISCORE};
|
||||
BEGIN {
|
||||
$VERSION = '1.00';
|
||||
@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;
|
||||
415
api/perl/inc/Module/Install/Makefile.pm
Normal file
415
api/perl/inc/Module/Install/Makefile.pm
Normal file
@@ -0,0 +1,415 @@
|
||||
#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.00';
|
||||
@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-seperated 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 ) {
|
||||
# MakeMaker can complain about module versions that include
|
||||
# an underscore, even though its own version may contain one!
|
||||
# Hence the funny regexp to get rid of it. See RT #35800
|
||||
# for details.
|
||||
my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
|
||||
$self->build_requires( 'ExtUtils::MakeMaker' => $v );
|
||||
$self->configure_requires( 'ExtUtils::MakeMaker' => $v );
|
||||
} 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.42 );
|
||||
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
|
||||
}
|
||||
|
||||
# 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
|
||||
|
||||
$DB::single = 1;
|
||||
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> };
|
||||
|
||||
$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 541
|
||||
715
api/perl/inc/Module/Install/Metadata.pm
Normal file
715
api/perl/inc/Module/Install/Metadata.pm
Normal file
@@ -0,0 +1,715 @@
|
||||
#line 1
|
||||
package Module::Install::Metadata;
|
||||
|
||||
use strict 'vars';
|
||||
use Module::Install::Base ();
|
||||
|
||||
use vars qw{$VERSION @ISA $ISCORE};
|
||||
BEGIN {
|
||||
$VERSION = '1.00';
|
||||
@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;
|
||||
unless ( @_ ) {
|
||||
warn "You MUST provide an explicit true/false value to dynamic_config\n";
|
||||
return $self;
|
||||
}
|
||||
$self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
|
||||
return 1;
|
||||
}
|
||||
|
||||
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 reall 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<lt>}{<}g;
|
||||
$author =~ s{E<gt>}{>}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',
|
||||
apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
|
||||
artistic => 'http://opensource.org/licenses/artistic-license.php',
|
||||
artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
|
||||
lgpl => 'http://opensource.org/licenses/lgpl-license.php',
|
||||
lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
|
||||
lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
|
||||
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,
|
||||
);
|
||||
|
||||
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' => '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<(
|
||||
\Qhttp://rt.cpan.org/\E[^>]+|
|
||||
\Qhttp://github.com/\E[\w_]+/[\w_]+/issues|
|
||||
\Qhttp://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+([\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 hashs
|
||||
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;
|
||||
64
api/perl/inc/Module/Install/Win32.pm
Normal file
64
api/perl/inc/Module/Install/Win32.pm
Normal file
@@ -0,0 +1,64 @@
|
||||
#line 1
|
||||
package Module::Install::Win32;
|
||||
|
||||
use strict;
|
||||
use Module::Install::Base ();
|
||||
|
||||
use vars qw{$VERSION @ISA $ISCORE};
|
||||
BEGIN {
|
||||
$VERSION = '1.00';
|
||||
@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;
|
||||
63
api/perl/inc/Module/Install/WriteAll.pm
Normal file
63
api/perl/inc/Module/Install/WriteAll.pm
Normal file
@@ -0,0 +1,63 @@
|
||||
#line 1
|
||||
package Module::Install::WriteAll;
|
||||
|
||||
use strict;
|
||||
use Module::Install::Base ();
|
||||
|
||||
use vars qw{$VERSION @ISA $ISCORE};
|
||||
BEGIN {
|
||||
$VERSION = '1.00';
|
||||
@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;
|
||||
1564
api/perl/lib/Monitoring/Livestatus.pm
Normal file
1564
api/perl/lib/Monitoring/Livestatus.pm
Normal file
File diff suppressed because it is too large
Load Diff
121
api/perl/lib/Monitoring/Livestatus/INET.pm
Normal file
121
api/perl/lib/Monitoring/Livestatus/INET.pm
Normal file
@@ -0,0 +1,121 @@
|
||||
package Monitoring::Livestatus::INET;
|
||||
|
||||
use 5.000000;
|
||||
use strict;
|
||||
use warnings;
|
||||
use IO::Socket::INET;
|
||||
use Socket qw(IPPROTO_TCP TCP_NODELAY);
|
||||
use Carp;
|
||||
use base "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<Monitoring::Livestatus::INET> object. C<new> takes at least the server.
|
||||
Arguments are the same as in C<Monitoring::Livestatus>.
|
||||
If the constructor is only passed a single argument, it is assumed to
|
||||
be a the C<server> specification. Use either socker OR server.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
unshift(@_, "peer") if scalar @_ == 1;
|
||||
my(%options) = @_;
|
||||
$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;
|
||||
my $sock;
|
||||
|
||||
eval {
|
||||
local $SIG{'ALRM'} = sub { die("connection timeout"); };
|
||||
alarm($self->{'connect_timeout'});
|
||||
$sock = IO::Socket::INET->new(
|
||||
PeerAddr => $self->{'peer'},
|
||||
Type => SOCK_STREAM,
|
||||
Timeout => $self->{'connect_timeout'},
|
||||
);
|
||||
if(!defined $sock or !$sock->connected()) {
|
||||
my $msg = "failed to connect to $self->{'peer'} :$!";
|
||||
if($self->{'errors_are_fatal'}) {
|
||||
croak($msg);
|
||||
}
|
||||
$Monitoring::Livestatus::ErrorCode = 500;
|
||||
$Monitoring::Livestatus::ErrorMessage = $msg;
|
||||
alarm(0);
|
||||
return;
|
||||
}
|
||||
|
||||
if(defined $self->{'query_timeout'}) {
|
||||
# set timeout
|
||||
$sock->timeout($self->{'query_timeout'});
|
||||
}
|
||||
|
||||
setsockopt($sock, IPPROTO_TCP, TCP_NODELAY, 1);
|
||||
|
||||
};
|
||||
alarm(0);
|
||||
|
||||
if($@) {
|
||||
$Monitoring::Livestatus::ErrorCode = 500;
|
||||
$Monitoring::Livestatus::ErrorMessage = $@;
|
||||
return;
|
||||
}
|
||||
|
||||
return($sock);
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
sub _close {
|
||||
my $self = shift;
|
||||
my $sock = shift;
|
||||
return unless defined $sock;
|
||||
return close($sock);
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Sven Nierlein, E<lt>nierlein@cpan.orgE<gt>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
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.
|
||||
|
||||
=cut
|
||||
|
||||
__END__
|
||||
922
api/perl/lib/Monitoring/Livestatus/MULTI.pm
Normal file
922
api/perl/lib/Monitoring/Livestatus/MULTI.pm
Normal file
@@ -0,0 +1,922 @@
|
||||
package Monitoring::Livestatus::MULTI;
|
||||
|
||||
use 5.000000;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
use Data::Dumper;
|
||||
use Config;
|
||||
use Time::HiRes qw/gettimeofday tv_interval/;
|
||||
use Scalar::Util qw/looks_like_number/;
|
||||
use Monitoring::Livestatus;
|
||||
use base "Monitoring::Livestatus";
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Monitoring::Livestatus::MULTI - connector with multiple peers
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Monitoring::Livestatus;
|
||||
my $nl = Monitoring::Livestatus::MULTI->new( qw{nagioshost1:9999 nagioshost2:9999 /var/spool/nagios/live.socket} );
|
||||
my $hosts = $nl->selectall_arrayref("GET hosts");
|
||||
|
||||
=head1 CONSTRUCTOR
|
||||
|
||||
=head2 new ( [ARGS] )
|
||||
|
||||
Creates an C<Monitoring::Livestatus::MULTI> object. C<new> takes at least the server.
|
||||
Arguments are the same as in L<Monitoring::Livestatus>.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
unshift(@_, "peer") if scalar @_ == 1;
|
||||
my(%options) = @_;
|
||||
|
||||
$options{'backend'} = $class;
|
||||
my $self = Monitoring::Livestatus->new(%options);
|
||||
bless $self, $class;
|
||||
|
||||
if(!defined $self->{'peers'}) {
|
||||
$self->{'peer'} = $self->_get_peers();
|
||||
|
||||
# set our peer(s) from the options
|
||||
my %peer_options;
|
||||
my $peers;
|
||||
for my $opt_key (keys %options) {
|
||||
$peer_options{$opt_key} = $options{$opt_key};
|
||||
}
|
||||
$peer_options{'errors_are_fatal'} = 0;
|
||||
for my $peer (@{$self->{'peer'}}) {
|
||||
$peer_options{'name'} = $peer->{'name'};
|
||||
$peer_options{'peer'} = $peer->{'peer'};
|
||||
delete $peer_options{'socket'};
|
||||
delete $peer_options{'server'};
|
||||
|
||||
if($peer->{'type'} eq 'UNIX') {
|
||||
push @{$peers}, new Monitoring::Livestatus::UNIX(%peer_options);
|
||||
}
|
||||
elsif($peer->{'type'} eq 'INET') {
|
||||
push @{$peers}, new Monitoring::Livestatus::INET(%peer_options);
|
||||
}
|
||||
}
|
||||
$self->{'peers'} = $peers;
|
||||
delete $self->{'socket'};
|
||||
delete $self->{'server'};
|
||||
}
|
||||
|
||||
if(!defined $self->{'peers'}) {
|
||||
croak('please specify at least one peer, socket or server');
|
||||
}
|
||||
|
||||
# dont use threads with only one peer
|
||||
if(scalar @{$self->{'peers'}} == 1) { $self->{'use_threads'} = 0; }
|
||||
|
||||
# check for threads support
|
||||
if(!defined $self->{'use_threads'}) {
|
||||
$self->{'use_threads'} = 0;
|
||||
if($Config{useithreads}) {
|
||||
$self->{'use_threads'} = 1;
|
||||
}
|
||||
}
|
||||
if($self->{'use_threads'}) {
|
||||
eval {
|
||||
require threads;
|
||||
require Thread::Queue;
|
||||
};
|
||||
if($@) {
|
||||
$self->{'use_threads'} = 0;
|
||||
$self->{'logger'}->debug('error initializing threads: '.$@) if defined $self->{'logger'};
|
||||
} else {
|
||||
$self->_start_worker;
|
||||
}
|
||||
}
|
||||
|
||||
# initialize peer keys
|
||||
$self->{'peer_by_key'} = {};
|
||||
$self->{'peer_by_addr'} = {};
|
||||
for my $peer (@{$self->{'peers'}}) {
|
||||
$self->{'peer_by_key'}->{$peer->peer_key} = $peer;
|
||||
$self->{'peer_by_addr'}->{$peer->peer_addr} = $peer;
|
||||
}
|
||||
|
||||
$self->{'name'} = 'multiple connector' unless defined $self->{'name'};
|
||||
$self->{'logger'}->debug('initialized Monitoring::Livestatus::MULTI '.($self->{'use_threads'} ? 'with' : 'without' ).' threads') if $self->{'verbose'};
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 do
|
||||
|
||||
See L<Monitoring::Livestatus> for more information.
|
||||
|
||||
=cut
|
||||
|
||||
sub do {
|
||||
my $self = shift;
|
||||
my $opts = $self->_lowercase_and_verify_options($_[1]);
|
||||
my $t0 = [gettimeofday];
|
||||
|
||||
$self->_do_on_peers("do", $opts->{'backends'}, @_);
|
||||
my $elapsed = tv_interval ( $t0 );
|
||||
$self->{'logger'}->debug(sprintf('%.4f', $elapsed).' sec for do('.$_[0].') in total') if $self->{'verbose'};
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
=head2 selectall_arrayref
|
||||
|
||||
See L<Monitoring::Livestatus> for more information.
|
||||
|
||||
=cut
|
||||
|
||||
sub selectall_arrayref {
|
||||
my $self = shift;
|
||||
my $opts = $self->_lowercase_and_verify_options($_[1]);
|
||||
my $t0 = [gettimeofday];
|
||||
|
||||
$self->_log_statement($_[0], $opts, 0) if $self->{'verbose'};
|
||||
|
||||
my $return = $self->_merge_answer($self->_do_on_peers("selectall_arrayref", $opts->{'backends'}, @_));
|
||||
my $elapsed = tv_interval ( $t0 );
|
||||
if($self->{'verbose'}) {
|
||||
my $total_results = 0;
|
||||
$total_results = scalar @{$return} if defined $return;
|
||||
$self->{'logger'}->debug(sprintf('%.4f', $elapsed).' sec for selectall_arrayref() in total, results: '.$total_results);
|
||||
}
|
||||
|
||||
return $return;
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
=head2 selectall_hashref
|
||||
|
||||
See L<Monitoring::Livestatus> for more information.
|
||||
|
||||
=cut
|
||||
|
||||
sub selectall_hashref {
|
||||
my $self = shift;
|
||||
my $opts = $self->_lowercase_and_verify_options($_[2]);
|
||||
my $t0 = [gettimeofday];
|
||||
|
||||
my $return = $self->_merge_answer($self->_do_on_peers("selectall_hashref", $opts->{'backends'}, @_));
|
||||
my $elapsed = tv_interval ( $t0 );
|
||||
$self->{'logger'}->debug(sprintf('%.4f', $elapsed).' sec for selectall_hashref() in total') if $self->{'verbose'};
|
||||
|
||||
return $return;
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
=head2 selectcol_arrayref
|
||||
|
||||
See L<Monitoring::Livestatus> for more information.
|
||||
|
||||
=cut
|
||||
|
||||
sub selectcol_arrayref {
|
||||
my $self = shift;
|
||||
my $opts = $self->_lowercase_and_verify_options($_[1]);
|
||||
my $t0 = [gettimeofday];
|
||||
|
||||
my $return = $self->_merge_answer($self->_do_on_peers("selectcol_arrayref", $opts->{'backends'}, @_));
|
||||
my $elapsed = tv_interval ( $t0 );
|
||||
$self->{'logger'}->debug(sprintf('%.4f', $elapsed).' sec for selectcol_arrayref() in total') if $self->{'verbose'};
|
||||
|
||||
return $return;
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
=head2 selectrow_array
|
||||
|
||||
See L<Monitoring::Livestatus> for more information.
|
||||
|
||||
=cut
|
||||
|
||||
sub selectrow_array {
|
||||
my $self = shift;
|
||||
my $statement = $_[0];
|
||||
my $opts = $self->_lowercase_and_verify_options($_[1]);
|
||||
my $t0 = [gettimeofday];
|
||||
my @return;
|
||||
|
||||
if((defined $opts->{'sum'} and $opts->{'sum'} == 1) or (!defined $opts->{'sum'} and $statement =~ m/^Stats:/mx)) {
|
||||
@return = @{$self->_sum_answer($self->_do_on_peers("selectrow_arrayref", $opts->{'backends'}, @_))};
|
||||
} else {
|
||||
if($self->{'warnings'}) {
|
||||
carp("selectrow_arrayref without Stats on multi backend will not work as expected!");
|
||||
}
|
||||
my $rows = $self->_merge_answer($self->_do_on_peers("selectrow_arrayref", $opts->{'backends'}, @_));
|
||||
@return = @{$rows} if defined $rows;
|
||||
}
|
||||
|
||||
my $elapsed = tv_interval ( $t0 );
|
||||
$self->{'logger'}->debug(sprintf('%.4f', $elapsed).' sec for selectrow_array() in total') if $self->{'verbose'};
|
||||
|
||||
return @return;
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
=head2 selectrow_arrayref
|
||||
|
||||
See L<Monitoring::Livestatus> for more information.
|
||||
|
||||
=cut
|
||||
|
||||
sub selectrow_arrayref {
|
||||
my $self = shift;
|
||||
my $statement = $_[0];
|
||||
my $opts = $self->_lowercase_and_verify_options($_[1]);
|
||||
my $t0 = [gettimeofday];
|
||||
my $return;
|
||||
|
||||
if((defined $opts->{'sum'} and $opts->{'sum'} == 1) or (!defined $opts->{'sum'} and $statement =~ m/^Stats:/mx)) {
|
||||
$return = $self->_sum_answer($self->_do_on_peers("selectrow_arrayref", $opts->{'backends'}, @_));
|
||||
} else {
|
||||
if($self->{'warnings'}) {
|
||||
carp("selectrow_arrayref without Stats on multi backend will not work as expected!");
|
||||
}
|
||||
my $rows = $self->_merge_answer($self->_do_on_peers("selectrow_arrayref", $opts->{'backends'}, @_));
|
||||
$return = $rows->[0] if defined $rows->[0];
|
||||
}
|
||||
|
||||
my $elapsed = tv_interval ( $t0 );
|
||||
$self->{'logger'}->debug(sprintf('%.4f', $elapsed).' sec for selectrow_arrayref() in total') if $self->{'verbose'};
|
||||
|
||||
return $return;
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
=head2 selectrow_hashref
|
||||
|
||||
See L<Monitoring::Livestatus> for more information.
|
||||
|
||||
=cut
|
||||
|
||||
sub selectrow_hashref {
|
||||
my $self = shift;
|
||||
my $statement = $_[0];
|
||||
my $opts = $self->_lowercase_and_verify_options($_[1]);
|
||||
|
||||
my $t0 = [gettimeofday];
|
||||
|
||||
my $return;
|
||||
|
||||
if((defined $opts->{'sum'} and $opts->{'sum'} == 1) or (!defined $opts->{'sum'} and $statement =~ m/^Stats:/mx)) {
|
||||
$return = $self->_sum_answer($self->_do_on_peers("selectrow_hashref", $opts->{'backends'}, @_));
|
||||
} else {
|
||||
if($self->{'warnings'}) {
|
||||
carp("selectrow_hashref without Stats on multi backend will not work as expected!");
|
||||
}
|
||||
$return = $self->_merge_answer($self->_do_on_peers("selectrow_hashref", $opts->{'backends'}, @_));
|
||||
}
|
||||
|
||||
my $elapsed = tv_interval ( $t0 );
|
||||
$self->{'logger'}->debug(sprintf('%.4f', $elapsed).' sec for selectrow_hashref() in total') if $self->{'verbose'};
|
||||
|
||||
return $return;
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
=head2 selectscalar_value
|
||||
|
||||
See L<Monitoring::Livestatus> for more information.
|
||||
|
||||
=cut
|
||||
|
||||
sub selectscalar_value {
|
||||
my $self = shift;
|
||||
my $statement = $_[0];
|
||||
my $opts = $self->_lowercase_and_verify_options($_[1]);
|
||||
|
||||
my $t0 = [gettimeofday];
|
||||
|
||||
my $return;
|
||||
|
||||
if((defined $opts->{'sum'} and $opts->{'sum'} == 1) or (!defined $opts->{'sum'} and $statement =~ m/^Stats:/mx)) {
|
||||
return $self->_sum_answer($self->_do_on_peers("selectscalar_value", $opts->{'backends'}, @_));
|
||||
} else {
|
||||
if($self->{'warnings'}) {
|
||||
carp("selectscalar_value without Stats on multi backend will not work as expected!");
|
||||
}
|
||||
my $rows = $self->_merge_answer($self->_do_on_peers("selectscalar_value", $opts->{'backends'}, @_));
|
||||
|
||||
$return = $rows->[0] if defined $rows->[0];
|
||||
}
|
||||
|
||||
my $elapsed = tv_interval ( $t0 );
|
||||
$self->{'logger'}->debug(sprintf('%.4f', $elapsed).' sec for selectscalar_value() in total') if $self->{'verbose'};
|
||||
|
||||
return $return;
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
=head2 errors_are_fatal
|
||||
|
||||
See L<Monitoring::Livestatus> for more information.
|
||||
|
||||
=cut
|
||||
|
||||
sub errors_are_fatal {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
return $self->_change_setting('errors_are_fatal', $value);
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
=head2 warnings
|
||||
|
||||
See L<Monitoring::Livestatus> for more information.
|
||||
|
||||
=cut
|
||||
|
||||
sub warnings {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
return $self->_change_setting('warnings', $value);
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
=head2 verbose
|
||||
|
||||
See L<Monitoring::Livestatus> for more information.
|
||||
|
||||
=cut
|
||||
|
||||
sub verbose {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
return $self->_change_setting('verbose', $value);
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
=head2 peer_addr
|
||||
|
||||
See L<Monitoring::Livestatus> for more information.
|
||||
|
||||
=cut
|
||||
|
||||
sub peer_addr {
|
||||
my $self = shift;
|
||||
|
||||
my @addrs;
|
||||
for my $peer (@{$self->{'peers'}}) {
|
||||
push @addrs, $peer->peer_addr;
|
||||
}
|
||||
|
||||
return wantarray ? @addrs : undef;
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
=head2 peer_name
|
||||
|
||||
See L<Monitoring::Livestatus> for more information.
|
||||
|
||||
=cut
|
||||
|
||||
sub peer_name {
|
||||
my $self = shift;
|
||||
|
||||
my @names;
|
||||
for my $peer (@{$self->{'peers'}}) {
|
||||
push @names, $peer->peer_name;
|
||||
}
|
||||
|
||||
return wantarray ? @names : $self->{'name'};
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
=head2 peer_key
|
||||
|
||||
See L<Monitoring::Livestatus> for more information.
|
||||
|
||||
=cut
|
||||
|
||||
sub peer_key {
|
||||
my $self = shift;
|
||||
|
||||
my @keys;
|
||||
for my $peer (@{$self->{'peers'}}) {
|
||||
push @keys, $peer->peer_key;
|
||||
}
|
||||
|
||||
return wantarray ? @keys : $self->{'key'};
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
=head2 disable
|
||||
|
||||
$ml->disable()
|
||||
|
||||
disables this connection, returns the last state.
|
||||
|
||||
=cut
|
||||
sub disable {
|
||||
my $self = shift;
|
||||
my $peer_key = shift;
|
||||
if(!defined $peer_key) {
|
||||
for my $peer (@{$self->{'peers'}}) {
|
||||
$peer->disable();
|
||||
}
|
||||
return 1;
|
||||
} else {
|
||||
my $peer = $self->_get_peer_by_key($peer_key);
|
||||
my $prev = $peer->{'disabled'};
|
||||
$peer->{'disabled'} = 1;
|
||||
return $prev;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
=head2 enable
|
||||
|
||||
$ml->enable()
|
||||
|
||||
enables this connection, returns the last state.
|
||||
|
||||
=cut
|
||||
sub enable {
|
||||
my $self = shift;
|
||||
my $peer_key = shift;
|
||||
if(!defined $peer_key) {
|
||||
for my $peer (@{$self->{'peers'}}) {
|
||||
$peer->enable();
|
||||
}
|
||||
return 1;
|
||||
} else {
|
||||
my $peer = $self->_get_peer_by_key($peer_key);
|
||||
my $prev = $peer->{'disabled'};
|
||||
$peer->{'disabled'} = 0;
|
||||
return $prev;
|
||||
}
|
||||
}
|
||||
|
||||
########################################
|
||||
# INTERNAL SUBS
|
||||
########################################
|
||||
|
||||
sub _change_setting {
|
||||
my $self = shift;
|
||||
my $key = shift;
|
||||
my $value = shift;
|
||||
my $old = $self->{$key};
|
||||
|
||||
# set new value
|
||||
if(defined $value) {
|
||||
$self->{$key} = $value;
|
||||
for my $peer (@{$self->{'peers'}}) {
|
||||
$peer->{$key} = $value;
|
||||
}
|
||||
|
||||
# restart workers
|
||||
if($self->{'use_threads'}) {
|
||||
_stop_worker();
|
||||
$self->_start_worker();
|
||||
}
|
||||
}
|
||||
|
||||
return $old;
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
sub _start_worker {
|
||||
my $self = shift;
|
||||
|
||||
# create job transports
|
||||
$self->{'WorkQueue'} = Thread::Queue->new;
|
||||
$self->{'WorkResults'} = Thread::Queue->new;
|
||||
|
||||
# set signal handler before thread is started
|
||||
# otherwise they would be killed when started
|
||||
# and stopped immediately after start
|
||||
$SIG{'USR1'} = sub { threads->exit(); };
|
||||
|
||||
# start worker threads
|
||||
our %threads;
|
||||
my $threadcount = scalar @{$self->{'peers'}};
|
||||
for(my $x = 0; $x < $threadcount; $x++) {
|
||||
$self->{'threads'}->[$x] = threads->new(\&_worker_thread, $self->{'peers'}, $self->{'WorkQueue'}, $self->{'WorkResults'}, $self->{'logger'});
|
||||
}
|
||||
|
||||
# restore sig handler as it was only for the threads
|
||||
$SIG{'USR1'} = 'DEFAULT';
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
sub _stop_worker {
|
||||
# try to kill our threads safely
|
||||
eval {
|
||||
for my $thr (threads->list()) {
|
||||
$thr->kill('USR1')->detach();
|
||||
}
|
||||
};
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
sub _worker_thread {
|
||||
local $SIG{'USR1'} = sub { threads->exit(); };
|
||||
|
||||
my $peers = shift;
|
||||
my $workQueue = shift;
|
||||
my $workResults = shift;
|
||||
my $logger = shift;
|
||||
|
||||
while (my $job = $workQueue->dequeue) {
|
||||
my $erg;
|
||||
eval {
|
||||
$erg = _do_wrapper($peers->[$job->{'peer'}], $job->{'sub'}, $logger, @{$job->{'opts'}});
|
||||
};
|
||||
if($@) {
|
||||
warn("Error in Thread ".$job->{'peer'}." :".$@);
|
||||
$job->{'logger'}->error("Error in Thread ".$job->{'peer'}." :".$@) if defined $job->{'logger'};
|
||||
};
|
||||
$workResults->enqueue({ peer => $job->{'peer'}, result => $erg });
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
sub _do_wrapper {
|
||||
my $peer = shift;
|
||||
my $sub = shift;
|
||||
my $logger = shift;
|
||||
my @opts = @_;
|
||||
|
||||
my $t0 = [gettimeofday];
|
||||
|
||||
my $data = $peer->$sub(@opts);
|
||||
|
||||
my $elapsed = tv_interval ( $t0 );
|
||||
$logger->debug(sprintf('%.4f', $elapsed).' sec for fetching data on '.$peer->peer_name.' ('.$peer->peer_addr.')') if defined $logger;
|
||||
|
||||
$Monitoring::Livestatus::ErrorCode = 0 unless defined $Monitoring::Livestatus::ErrorCode;
|
||||
$Monitoring::Livestatus::ErrorMessage = '' unless defined $Monitoring::Livestatus::ErrorMessage;
|
||||
my $return = {
|
||||
'msg' => $Monitoring::Livestatus::ErrorMessage,
|
||||
'code' => $Monitoring::Livestatus::ErrorCode,
|
||||
'data' => $data,
|
||||
};
|
||||
return $return;
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
sub _do_on_peers {
|
||||
my $self = shift;
|
||||
my $sub = shift;
|
||||
my $backends = shift;
|
||||
my @opts = @_;
|
||||
my $statement = $opts[0];
|
||||
my $use_threads = $self->{'use_threads'};
|
||||
my $t0 = [gettimeofday];
|
||||
|
||||
my $return;
|
||||
my %codes;
|
||||
my %messages;
|
||||
my $query_options;
|
||||
if($sub eq 'selectall_hashref') {
|
||||
$query_options = $self->_lowercase_and_verify_options($opts[2]);
|
||||
} else {
|
||||
$query_options = $self->_lowercase_and_verify_options($opts[1]);
|
||||
}
|
||||
|
||||
# which peers affected?
|
||||
my @peers;
|
||||
if(defined $backends) {
|
||||
my @backends;
|
||||
if(ref $backends eq '') {
|
||||
push @backends, $backends;
|
||||
}
|
||||
elsif(ref $backends eq 'ARRAY') {
|
||||
@backends = @{$backends};
|
||||
} else {
|
||||
croak("unsupported type for backend: ".ref($backends));
|
||||
}
|
||||
|
||||
for my $key (@backends) {
|
||||
my $backend = $self->_get_peer_by_key($key);
|
||||
push @peers, $backend unless $backend->{'disabled'};
|
||||
}
|
||||
} else {
|
||||
# use all backends
|
||||
@peers = @{$self->{'peers'}};
|
||||
}
|
||||
|
||||
# its faster without threads for only one peer
|
||||
if(scalar @peers <= 1) { $use_threads = 0; }
|
||||
|
||||
# if we have limits set, we cannot use threads
|
||||
if(defined $query_options->{'limit_start'}) { $use_threads = 0; }
|
||||
|
||||
if($use_threads) {
|
||||
# use the threaded variant
|
||||
$self->{'logger'}->debug('using threads') if $self->{'verbose'};
|
||||
|
||||
my $peers_to_use;
|
||||
for my $peer (@peers) {
|
||||
if($peer->{'disabled'}) {
|
||||
# dont send any query
|
||||
}
|
||||
elsif($peer->marked_bad) {
|
||||
warn($peer->peer_name.' ('.$peer->peer_key.') is marked bad') if $self->{'verbose'};
|
||||
}
|
||||
else {
|
||||
$peers_to_use->{$peer->peer_key} = 1;
|
||||
}
|
||||
}
|
||||
my $x = 0;
|
||||
for my $peer (@{$self->{'peers'}}) {
|
||||
if(defined $peers_to_use->{$peer->peer_key}) {
|
||||
my $job = {
|
||||
'peer' => $x,
|
||||
'sub' => $sub,
|
||||
'opts' => \@opts,
|
||||
};
|
||||
$self->{'WorkQueue'}->enqueue($job);
|
||||
}
|
||||
$x++;
|
||||
}
|
||||
|
||||
for(my $x = 0; $x < scalar keys %{$peers_to_use}; $x++) {
|
||||
my $result = $self->{'WorkResults'}->dequeue;
|
||||
my $peer = $self->{'peers'}->[$result->{'peer'}];
|
||||
if(defined $result->{'result'}) {
|
||||
push @{$codes{$result->{'result'}->{'code'}}}, { 'peer' => $peer->peer_key, 'msg' => $result->{'result'}->{'msg'} };
|
||||
$return->{$peer->peer_key} = $result->{'result'}->{'data'};
|
||||
} else {
|
||||
warn("undefined result for: $statement");
|
||||
}
|
||||
}
|
||||
} else {
|
||||
$self->{'logger'}->debug('not using threads') if $self->{'verbose'};
|
||||
for my $peer (@peers) {
|
||||
if($peer->{'disabled'}) {
|
||||
# dont send any query
|
||||
}
|
||||
elsif($peer->marked_bad) {
|
||||
warn($peer->peer_name.' ('.$peer->peer_key.') is marked bad') if $self->{'verbose'};
|
||||
} else {
|
||||
my $erg = _do_wrapper($peer, $sub, $self->{'logger'}, @opts);
|
||||
$return->{$peer->peer_key} = $erg->{'data'};
|
||||
push @{$codes{$erg->{'code'}}}, { 'peer' => $peer, 'msg' => $erg->{'msg'} };
|
||||
|
||||
# compute limits
|
||||
if(defined $query_options->{'limit_length'} and $peer->{'meta_data'}->{'result_count'}) {
|
||||
last;
|
||||
}
|
||||
# set a new start if we had rows already
|
||||
if(defined $query_options->{'limit_start'}) {
|
||||
$query_options->{'limit_start'} = $query_options->{'limit_start'} - $peer->{'meta_data'}->{'row_count'};
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# check if we different result stati
|
||||
undef $Monitoring::Livestatus::ErrorMessage;
|
||||
$Monitoring::Livestatus::ErrorCode = 0;
|
||||
my @codes = sort keys %codes;
|
||||
if(scalar @codes > 1) {
|
||||
# got different results for our backends
|
||||
if($self->{'verbose'}) {
|
||||
$self->{'logger'}->warn("got different result stati: ".Dumper(\%codes));
|
||||
}
|
||||
} else {
|
||||
# got same result codes for all backend
|
||||
}
|
||||
|
||||
my $failed = 0;
|
||||
my $code = $codes[0];
|
||||
if(defined $code and $code >= 300) {
|
||||
$failed = 1;
|
||||
}
|
||||
|
||||
if($failed) {
|
||||
my $msg = $codes{$code}->[0]->{'msg'};
|
||||
$self->{'logger'}->debug("same: $code -> $msg") if $self->{'verbose'};
|
||||
$Monitoring::Livestatus::ErrorMessage = $msg;
|
||||
$Monitoring::Livestatus::ErrorCode = $code;
|
||||
if($self->{'errors_are_fatal'}) {
|
||||
croak("ERROR ".$code." - ".$Monitoring::Livestatus::ErrorMessage." in query:\n'".$statement."'\n");
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
my $elapsed = tv_interval ( $t0 );
|
||||
$self->{'logger'}->debug(sprintf('%.4f', $elapsed).' sec for fetching all data') if $self->{'verbose'};
|
||||
|
||||
# deep copy result?
|
||||
if($use_threads
|
||||
and (
|
||||
(defined $query_options->{'deepcopy'} and $query_options->{'deepcopy'} == 1)
|
||||
or
|
||||
(defined $self->{'deepcopy'} and $self->{'deepcopy'} == 1)
|
||||
)
|
||||
) {
|
||||
# result has to be cloned to avoid "Invalid value for shared scalar" error
|
||||
|
||||
$return = $self->_clone($return, $self->{'logger'});
|
||||
}
|
||||
|
||||
return($return);
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
sub _merge_answer {
|
||||
my $self = shift;
|
||||
my $data = shift;
|
||||
my $return;
|
||||
|
||||
my $t0 = [gettimeofday];
|
||||
|
||||
# iterate over original peers to retain order
|
||||
for my $peer (@{$self->{'peers'}}) {
|
||||
my $key = $peer->peer_key;
|
||||
next if !defined $data->{$key};
|
||||
|
||||
if(ref $data->{$key} eq 'ARRAY') {
|
||||
$return = [] unless defined $return;
|
||||
$return = [ @{$return}, @{$data->{$key}} ];
|
||||
} elsif(ref $data->{$key} eq 'HASH') {
|
||||
$return = {} unless defined $return;
|
||||
$return = { %{$return}, %{$data->{$key}} };
|
||||
} else {
|
||||
push @{$return}, $data->{$key};
|
||||
}
|
||||
}
|
||||
|
||||
my $elapsed = tv_interval ( $t0 );
|
||||
$self->{'logger'}->debug(sprintf('%.4f', $elapsed).' sec for merging data') if $self->{'verbose'};
|
||||
|
||||
return($return);
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
sub _sum_answer {
|
||||
my $self = shift;
|
||||
my $data = shift;
|
||||
my $return;
|
||||
my $t0 = [gettimeofday];
|
||||
for my $peername (keys %{$data}) {
|
||||
if(ref $data->{$peername} eq 'HASH') {
|
||||
for my $key (keys %{$data->{$peername}}) {
|
||||
if(!defined $return->{$key}) {
|
||||
$return->{$key} = $data->{$peername}->{$key};
|
||||
} elsif(looks_like_number($data->{$peername}->{$key})) {
|
||||
$return->{$key} += $data->{$peername}->{$key};
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif(ref $data->{$peername} eq 'ARRAY') {
|
||||
my $x = 0;
|
||||
for my $val (@{$data->{$peername}}) {
|
||||
if(!defined $return->[$x]) {
|
||||
$return->[$x] = $data->{$peername}->[$x];
|
||||
} else {
|
||||
$return->[$x] += $data->{$peername}->[$x];
|
||||
}
|
||||
$x++;
|
||||
}
|
||||
} elsif(defined $data->{$peername}) {
|
||||
$return = 0 unless defined $return;
|
||||
next unless defined $data->{$peername};
|
||||
$return += $data->{$peername};
|
||||
}
|
||||
}
|
||||
|
||||
my $elapsed = tv_interval ( $t0 );
|
||||
$self->{'logger'}->debug(sprintf('%.4f', $elapsed).' sec for summarizing data') if $self->{'verbose'};
|
||||
|
||||
return $return;
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
sub _clone {
|
||||
my $self = shift;
|
||||
my $data = shift;
|
||||
my $logger = shift;
|
||||
my $t0 = [gettimeofday];
|
||||
|
||||
my $return;
|
||||
if(ref $data eq '') {
|
||||
$return = $data;
|
||||
}
|
||||
elsif(ref $data eq 'ARRAY') {
|
||||
$return = [];
|
||||
for my $dat (@{$data}) {
|
||||
push @{$return}, $self->_clone($dat);
|
||||
}
|
||||
}
|
||||
elsif(ref $data eq 'HASH') {
|
||||
$return = {};
|
||||
for my $key (keys %{$data}) {
|
||||
$return->{$key} = $self->_clone($data->{$key});
|
||||
}
|
||||
}
|
||||
else {
|
||||
croak("cant clone: ".(ref $data));
|
||||
}
|
||||
|
||||
my $elapsed = tv_interval ( $t0 );
|
||||
$logger->debug(sprintf('%.4f', $elapsed).' sec for cloning data') if defined $logger;
|
||||
|
||||
return $return;
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
sub _get_peer_by_key {
|
||||
my $self = shift;
|
||||
my $key = shift;
|
||||
|
||||
return unless defined $key;
|
||||
return unless defined $self->{'peer_by_key'}->{$key};
|
||||
|
||||
return $self->{'peer_by_key'}->{$key};
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
sub _get_peer_by_addr {
|
||||
my $self = shift;
|
||||
my $addr = shift;
|
||||
|
||||
return unless defined $addr;
|
||||
return unless defined $self->{'peer_by_addr'}->{$addr};
|
||||
|
||||
return $self->{'peer_by_addr'}->{$addr};
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
END {
|
||||
# try to kill our threads safely
|
||||
_stop_worker();
|
||||
}
|
||||
|
||||
########################################
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Sven Nierlein, E<lt>nierlein@cpan.orgE<gt>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
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.
|
||||
|
||||
=cut
|
||||
|
||||
__END__
|
||||
112
api/perl/lib/Monitoring/Livestatus/UNIX.pm
Normal file
112
api/perl/lib/Monitoring/Livestatus/UNIX.pm
Normal file
@@ -0,0 +1,112 @@
|
||||
package Monitoring::Livestatus::UNIX;
|
||||
|
||||
use 5.000000;
|
||||
use strict;
|
||||
use warnings;
|
||||
use IO::Socket::UNIX;
|
||||
use Carp;
|
||||
use base "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<Monitoring::Livestatus::UNIX> object. C<new> takes at least the socketpath.
|
||||
Arguments are the same as in C<Monitoring::Livestatus>.
|
||||
If the constructor is only passed a single argument, it is assumed to
|
||||
be a the C<socket> specification. Use either socker OR server.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
unshift(@_, "peer") if scalar @_ == 1;
|
||||
my(%options) = @_;
|
||||
$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'}) {
|
||||
croak($msg);
|
||||
}
|
||||
$Monitoring::Livestatus::ErrorCode = 500;
|
||||
$Monitoring::Livestatus::ErrorMessage = $msg;
|
||||
return;
|
||||
}
|
||||
my $sock = IO::Socket::UNIX->new(
|
||||
Peer => $self->{'peer'},
|
||||
Type => SOCK_STREAM,
|
||||
);
|
||||
if(!defined $sock or !$sock->connected()) {
|
||||
my $msg = "failed to connect to $self->{'peer'} :$!";
|
||||
if($self->{'errors_are_fatal'}) {
|
||||
croak($msg);
|
||||
}
|
||||
$Monitoring::Livestatus::ErrorCode = 500;
|
||||
$Monitoring::Livestatus::ErrorMessage = $msg;
|
||||
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, E<lt>nierlein@cpan.orgE<gt>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
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.
|
||||
|
||||
=cut
|
||||
|
||||
__END__
|
||||
149
api/perl/t/01-Monitoring-Livestatus-basic_tests.t
Normal file
149
api/perl/t/01-Monitoring-Livestatus-basic_tests.t
Normal file
@@ -0,0 +1,149 @@
|
||||
#!/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 => 35;
|
||||
}
|
||||
}
|
||||
|
||||
#########################
|
||||
# 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_seperator = 10;
|
||||
my $column_seperator = 0;
|
||||
$ml = Monitoring::Livestatus->new(
|
||||
verbose => 0,
|
||||
socket => $socket_path,
|
||||
line_seperator => $line_seperator,
|
||||
column_seperator => $column_seperator,
|
||||
);
|
||||
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');
|
||||
|
||||
#########################
|
||||
# create multi object with peers
|
||||
$ml = Monitoring::Livestatus->new(
|
||||
peer => [ $server, $socket_path ],
|
||||
);
|
||||
isa_ok($ml, 'Monitoring::Livestatus', 'peer hash arg multi');
|
||||
my @names = $ml->peer_name();
|
||||
my @addrs = $ml->peer_addr();
|
||||
my $name = $ml->peer_name();
|
||||
my $expect = [ $server, $socket_path ];
|
||||
is_deeply(\@names, $expect, 'list context get peer_name()') or diag("got peer names: ".Dumper(\@names)."but expected: ".Dumper($expect));
|
||||
is($name, 'multiple connector', 'scalar context get peer_name()') or diag("got peer name: ".Dumper($name)."but expected: ".Dumper('multiple connector'));
|
||||
is_deeply(\@addrs, $expect, 'list context get peer_addr()') or diag("got peer addrs: ".Dumper(\@addrs)."but expected: ".Dumper($expect));
|
||||
|
||||
#########################
|
||||
# create multi object with peers and name
|
||||
$ml = Monitoring::Livestatus->new(
|
||||
peer => [ $server, $socket_path ],
|
||||
name => 'test multi',
|
||||
);
|
||||
isa_ok($ml, 'Monitoring::Livestatus', 'peer hash arg multi with name');
|
||||
$name = $ml->peer_name();
|
||||
is($name, 'test multi', 'peer_name()');
|
||||
|
||||
#########################
|
||||
$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);
|
||||
148
api/perl/t/02-Monitoring-Livestatus-internals.t
Normal file
148
api/perl/t/02-Monitoring-Livestatus-internals.t
Normal file
@@ -0,0 +1,148 @@
|
||||
#!/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 @got_keys1 = @{$ml->_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 @got_keys2 = @{$ml->_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);
|
||||
215
api/perl/t/03-Monitoring-Livestatus-MULTI-internals.t
Normal file
215
api/perl/t/03-Monitoring-Livestatus-MULTI-internals.t
Normal file
@@ -0,0 +1,215 @@
|
||||
#!/usr/bin/env perl
|
||||
|
||||
#########################
|
||||
|
||||
use strict;
|
||||
use Test::More;
|
||||
use Data::Dumper;
|
||||
use File::Temp;
|
||||
use IO::Socket::UNIX qw( SOCK_STREAM SOMAXCONN );
|
||||
use_ok('Monitoring::Livestatus::MULTI');
|
||||
|
||||
BEGIN {
|
||||
if( $^O eq 'MSWin32' ) {
|
||||
plan skip_all => 'no sockets on windows';
|
||||
}
|
||||
else {
|
||||
plan tests => 57;
|
||||
}
|
||||
}
|
||||
|
||||
#########################
|
||||
# create 2 test sockets
|
||||
# get a temp file from File::Temp and replace it with our socket
|
||||
my $fh = File::Temp->new(UNLINK => 0);
|
||||
my $socket_path1 = $fh->filename;
|
||||
unlink($socket_path1);
|
||||
my $listener1 = IO::Socket::UNIX->new(
|
||||
Type => SOCK_STREAM,
|
||||
Listen => SOMAXCONN,
|
||||
Local => $socket_path1,
|
||||
) or die("failed to open $socket_path1 as test socket: $!");
|
||||
|
||||
$fh = File::Temp->new(UNLINK => 0);
|
||||
my $socket_path2 = $fh->filename;
|
||||
unlink($socket_path2);
|
||||
my $listener2 = IO::Socket::UNIX->new(
|
||||
Type => SOCK_STREAM,
|
||||
Listen => SOMAXCONN,
|
||||
Local => $socket_path2,
|
||||
) or die("failed to open $socket_path2 as test socket: $!");
|
||||
|
||||
#########################
|
||||
# test the _merge_answer
|
||||
my $mergetests = [
|
||||
{ # simple test for sliced selectall_arrayref
|
||||
in => { '820e03551b95b42ec037c87aed9b8f4a' => [ { 'description' => 'test_flap_07', 'host_name' => 'test_host_000', 'state' => '0' }, { 'description' => 'test_flap_11', 'host_name' => 'test_host_000', 'state' => '0' } ],
|
||||
'35bbb11a888f66131d429efd058fb141' => [ { 'description' => 'test_ok_00', 'host_name' => 'test_host_000', 'state' => '0' }, { 'description' => 'test_ok_01', 'host_name' => 'test_host_000', 'state' => '0' } ],
|
||||
'70ea8fa14abb984761bdd45ef27685b0' => [ { 'description' => 'test_critical_00', 'host_name' => 'test_host_000', 'state' => '2' }, { 'description' => 'test_critical_19', 'host_name' => 'test_host_000', 'state' => '2' } ]
|
||||
},
|
||||
exp => [
|
||||
{ 'description' => 'test_flap_07', 'host_name' => 'test_host_000', 'state' => '0' },
|
||||
{ 'description' => 'test_flap_11', 'host_name' => 'test_host_000', 'state' => '0' },
|
||||
{ 'description' => 'test_ok_00', 'host_name' => 'test_host_000', 'state' => '0' },
|
||||
{ 'description' => 'test_ok_01', 'host_name' => 'test_host_000', 'state' => '0' },
|
||||
{ 'description' => 'test_critical_00', 'host_name' => 'test_host_000', 'state' => '2' },
|
||||
{ 'description' => 'test_critical_19', 'host_name' => 'test_host_000', 'state' => '2' },
|
||||
]
|
||||
},
|
||||
];
|
||||
|
||||
#########################
|
||||
# test object creation
|
||||
my $ml = Monitoring::Livestatus::MULTI->new( [ $socket_path1, $socket_path2 ] );
|
||||
isa_ok($ml, 'Monitoring::Livestatus', 'single args sockets');
|
||||
for my $peer (@{$ml->{'peers'}}) {
|
||||
isa_ok($peer, 'Monitoring::Livestatus::UNIX', 'single args sockets peer');
|
||||
}
|
||||
|
||||
$ml = Monitoring::Livestatus::MULTI->new( [$socket_path1] );
|
||||
isa_ok($ml, 'Monitoring::Livestatus', 'single array args socket');
|
||||
for my $peer (@{$ml->{'peers'}}) {
|
||||
isa_ok($peer, 'Monitoring::Livestatus::UNIX', 'single array args socket peer');
|
||||
is($peer->peer_addr, $socket_path1, 'single arrays args socket peer addr');
|
||||
is($peer->peer_name, $socket_path1, 'single arrays args socket peer name');
|
||||
}
|
||||
|
||||
$ml = Monitoring::Livestatus::MULTI->new( 'localhost:5001' );
|
||||
isa_ok($ml, 'Monitoring::Livestatus', 'single args server');
|
||||
for my $peer (@{$ml->{'peers'}}) {
|
||||
isa_ok($peer, 'Monitoring::Livestatus::INET', 'single args server peer');
|
||||
like($peer->peer_addr, qr/^localhost/, 'single args servers peer addr');
|
||||
like($peer->peer_name, qr/^localhost/, 'single args servers peer name');
|
||||
}
|
||||
|
||||
$ml = Monitoring::Livestatus::MULTI->new( ['localhost:5001'] );
|
||||
isa_ok($ml, 'Monitoring::Livestatus', 'single array args server');
|
||||
for my $peer (@{$ml->{'peers'}}) {
|
||||
isa_ok($peer, 'Monitoring::Livestatus::INET', 'single arrays args server peer');
|
||||
like($peer->peer_addr, qr/^localhost/, 'single arrays args servers peer addr');
|
||||
like($peer->peer_name, qr/^localhost/, 'single arrays args servers peer name');
|
||||
}
|
||||
|
||||
$ml = Monitoring::Livestatus::MULTI->new( [ 'localhost:5001', 'localhost:5002' ] );
|
||||
isa_ok($ml, 'Monitoring::Livestatus', 'single args servers');
|
||||
for my $peer (@{$ml->{'peers'}}) {
|
||||
isa_ok($peer, 'Monitoring::Livestatus::INET', 'single args servers peer');
|
||||
like($peer->peer_addr, qr/^localhost/, 'single args servers peer addr');
|
||||
like($peer->peer_name, qr/^localhost/, 'single args servers peer name');
|
||||
}
|
||||
|
||||
$ml = Monitoring::Livestatus::MULTI->new( peer => [ 'localhost:5001', 'localhost:5002' ] );
|
||||
isa_ok($ml, 'Monitoring::Livestatus', 'hash args servers');
|
||||
for my $peer (@{$ml->{'peers'}}) {
|
||||
isa_ok($peer, 'Monitoring::Livestatus::INET', 'hash args servers peer');
|
||||
like($peer->peer_addr, qr/^localhost/, 'hash args servers peer addr');
|
||||
like($peer->peer_name, qr/^localhost/, 'hash args servers peer name');
|
||||
}
|
||||
|
||||
$ml = Monitoring::Livestatus::MULTI->new( peer => [ $socket_path1, $socket_path2 ] );
|
||||
isa_ok($ml, 'Monitoring::Livestatus', 'hash args sockets');
|
||||
for my $peer (@{$ml->{'peers'}}) {
|
||||
isa_ok($peer, 'Monitoring::Livestatus::UNIX', 'hash args sockets peer');
|
||||
}
|
||||
|
||||
$ml = Monitoring::Livestatus::MULTI->new( peer => { $socket_path1 => 'Location 1', $socket_path2 => 'Location2' } );
|
||||
isa_ok($ml, 'Monitoring::Livestatus', 'hash args hashed sockets');
|
||||
for my $peer (@{$ml->{'peers'}}) {
|
||||
isa_ok($peer, 'Monitoring::Livestatus::UNIX', 'hash args hashed sockets peer');
|
||||
like($peer->peer_name, qr/^Location/, 'hash args hashed sockets peer name');
|
||||
}
|
||||
|
||||
$ml = Monitoring::Livestatus::MULTI->new( peer => { 'localhost:5001' => 'Location 1', 'localhost:5002' => 'Location2' } );
|
||||
isa_ok($ml, 'Monitoring::Livestatus', 'hash args hashed servers');
|
||||
for my $peer (@{$ml->{'peers'}}) {
|
||||
isa_ok($peer, 'Monitoring::Livestatus::INET', 'hash args hashed servers peer');
|
||||
like($peer->peer_addr, qr/^localhost/, 'hash args hashed servers peer addr');
|
||||
like($peer->peer_name, qr/^Location/, 'hash args hashed servers peer name');
|
||||
}
|
||||
|
||||
$ml = Monitoring::Livestatus::MULTI->new( $socket_path1 );
|
||||
isa_ok($ml, 'Monitoring::Livestatus', 'single args socket');
|
||||
for my $peer (@{$ml->{'peers'}}) {
|
||||
isa_ok($peer, 'Monitoring::Livestatus::UNIX', 'single args socket peer');
|
||||
}
|
||||
|
||||
#########################
|
||||
# test internal subs
|
||||
$ml = Monitoring::Livestatus::MULTI->new('peer' => ['192.168.123.2:9996', '192.168.123.2:9997', '192.168.123.2:9998' ] );
|
||||
|
||||
my $x = 0;
|
||||
for my $test (@{$mergetests}) {
|
||||
my $got = $ml->_merge_answer($test->{'in'});
|
||||
is_deeply($got, $test->{'exp'}, '_merge_answer test '.$x)
|
||||
or diag("got: ".Dumper($got)."\nbut expected ".Dumper($test->{'exp'}));
|
||||
$x++;
|
||||
}
|
||||
|
||||
#########################
|
||||
# test the _sum_answer
|
||||
my $sumtests = [
|
||||
{ # hashes
|
||||
in => { '192.168.123.2:9996' => { 'ok' => '12', 'warning' => '8' },
|
||||
'192.168.123.2:9997' => { 'ok' => '17', 'warning' => '7' },
|
||||
'192.168.123.2:9998' => { 'ok' => '13', 'warning' => '2' }
|
||||
},
|
||||
exp => { 'ok' => '42', 'warning' => '17' }
|
||||
},
|
||||
{ # hashes, undefs
|
||||
in => { '192.168.123.2:9996' => { 'ok' => '12', 'warning' => '8' },
|
||||
'192.168.123.2:9997' => undef,
|
||||
'192.168.123.2:9998' => { 'ok' => '13', 'warning' => '2' }
|
||||
},
|
||||
exp => { 'ok' => '25', 'warning' => '10' }
|
||||
},
|
||||
{ # hashes, undefs
|
||||
in => { '192.168.123.2:9996' => { 'ok' => '12', 'warning' => '8' },
|
||||
'192.168.123.2:9997' => {},
|
||||
'192.168.123.2:9998' => { 'ok' => '13', 'warning' => '2' }
|
||||
},
|
||||
exp => { 'ok' => '25', 'warning' => '10' }
|
||||
},
|
||||
{ # arrays
|
||||
in => { '192.168.123.2:9996' => [ '3302', '235' ],
|
||||
'192.168.123.2:9997' => [ '3324', '236' ],
|
||||
'192.168.123.2:9998' => [ '3274', '236' ]
|
||||
},
|
||||
exp => [ 9900, 707 ]
|
||||
},
|
||||
{ # undefs / scalars
|
||||
in => { 'e69322abf0352888e598da3e2514df4a' => undef,
|
||||
'f42530d7e8c2b52732ba427b1e5e0a8e' => '1'
|
||||
},
|
||||
exp => 1,
|
||||
},
|
||||
{ # arrays, undefs
|
||||
in => { '192.168.123.2:9996' => [ '2', '5' ],
|
||||
'192.168.123.2:9997' => [ ],
|
||||
'192.168.123.2:9998' => [ '4', '6' ]
|
||||
},
|
||||
exp => [ 6, 11 ]
|
||||
},
|
||||
{ # arrays, undefs
|
||||
in => { '192.168.123.2:9996' => [ '2', '5' ],
|
||||
'192.168.123.2:9997' => undef,
|
||||
'192.168.123.2:9998' => [ '4', '6' ]
|
||||
},
|
||||
exp => [ 6, 11 ]
|
||||
},
|
||||
];
|
||||
|
||||
$x = 1;
|
||||
for my $test (@{$sumtests}) {
|
||||
my $got = $ml->_sum_answer($test->{'in'});
|
||||
is_deeply($got, $test->{'exp'}, '_sum_answer test '.$x)
|
||||
or diag("got: ".Dumper($got)."\nbut expected ".Dumper($test->{'exp'}));
|
||||
$x++;
|
||||
}
|
||||
|
||||
#########################
|
||||
# clone test
|
||||
my $clone = $ml->_clone($mergetests);
|
||||
is_deeply($clone, $mergetests, 'merge test clone');
|
||||
|
||||
$clone = $ml->_clone($sumtests);
|
||||
is_deeply($clone, $sumtests, 'sum test clone');
|
||||
329
api/perl/t/20-Monitoring-Livestatus-test_socket.t
Normal file
329
api/perl/t/20-Monitoring-Livestatus-test_socket.t
Normal file
@@ -0,0 +1,329 @@
|
||||
#!/usr/bin/env perl
|
||||
|
||||
#########################
|
||||
|
||||
use strict;
|
||||
use Test::More;
|
||||
use IO::Socket::UNIX qw( SOCK_STREAM SOMAXCONN );
|
||||
use Data::Dumper;
|
||||
use 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_seperator = 10;
|
||||
my $column_seperator = 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_seperator => $line_seperator,
|
||||
column_seperator => $column_seperator,
|
||||
),
|
||||
|
||||
# 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_seperator => $line_seperator,
|
||||
column_seperator => $column_seperator,
|
||||
),
|
||||
|
||||
# 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 dont 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);
|
||||
}
|
||||
30
api/perl/t/21-Monitoring-Livestatus-INET.t
Normal file
30
api/perl/t/21-Monitoring-Livestatus-INET.t
Normal file
@@ -0,0 +1,30 @@
|
||||
#!/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_seperator = 10;
|
||||
my $column_seperator = 0;
|
||||
$ml = Monitoring::Livestatus::INET->new(
|
||||
verbose => 0,
|
||||
server => $server,
|
||||
line_seperator => $line_seperator,
|
||||
column_seperator => $column_seperator,
|
||||
);
|
||||
isa_ok($ml, 'Monitoring::Livestatus', 'Monitoring::Livestatus::INET->new(%args)');
|
||||
26
api/perl/t/22-Monitoring-Livestatus-UNIX.t
Normal file
26
api/perl/t/22-Monitoring-Livestatus-UNIX.t
Normal file
@@ -0,0 +1,26 @@
|
||||
#!/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_seperator = 10;
|
||||
my $column_seperator = 0;
|
||||
$ml = Monitoring::Livestatus::UNIX->new(
|
||||
verbose => 0,
|
||||
socket => $socket,
|
||||
line_seperator => $line_seperator,
|
||||
column_seperator => $column_seperator,
|
||||
);
|
||||
isa_ok($ml, 'Monitoring::Livestatus', 'Monitoring::Livestatus::UNIX->new(%args)');
|
||||
472
api/perl/t/30-Monitoring-Livestatus-live-test.t
Normal file
472
api/perl/t/30-Monitoring-Livestatus-live-test.t
Normal file
@@ -0,0 +1,472 @@
|
||||
#!/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 => 727 );
|
||||
}
|
||||
|
||||
# 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');
|
||||
|
||||
#########################
|
||||
my $line_seperator = 10;
|
||||
my $column_seperator = 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_seperator => $line_seperator,
|
||||
column_seperator => $column_seperator,
|
||||
),
|
||||
|
||||
# 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_seperator => $line_seperator,
|
||||
column_seperator => $column_seperator,
|
||||
),
|
||||
|
||||
|
||||
# create inet object with keepalive
|
||||
'06 inet_keepalive' => Monitoring::Livestatus->new(
|
||||
verbose => 0,
|
||||
server => $ENV{TEST_SERVER},
|
||||
keepalive => 1,
|
||||
),
|
||||
|
||||
# create multi single args
|
||||
'07 multi_keepalive' => Monitoring::Livestatus->new( [ $ENV{TEST_SERVER}, $ENV{TEST_SOCKET} ] ),
|
||||
|
||||
# create multi object with keepalive
|
||||
'08 multi_keepalive_hash_args' => Monitoring::Livestatus->new(
|
||||
verbose => 0,
|
||||
peer => [ $ENV{TEST_SERVER}, $ENV{TEST_SOCKET} ],
|
||||
keepalive => 1,
|
||||
),
|
||||
|
||||
# create multi object without keepalive
|
||||
'09 multi_no_keepalive' => Monitoring::Livestatus->new(
|
||||
peer => [ $ENV{TEST_SERVER}, $ENV{TEST_SOCKET} ],
|
||||
keepalive => 0,
|
||||
),
|
||||
|
||||
# create multi object without threads
|
||||
'10 multi_no_threads' => Monitoring::Livestatus->new(
|
||||
peer => [ $ENV{TEST_SERVER}, $ENV{TEST_SOCKET} ],
|
||||
use_threads => 0,
|
||||
),
|
||||
|
||||
# create multi object with only one peer
|
||||
'11 multi_one_peer' => Monitoring::Livestatus::MULTI->new(
|
||||
peer => $ENV{TEST_SERVER},
|
||||
),
|
||||
|
||||
# create multi object without threads
|
||||
'12 multi_two_peers' => Monitoring::Livestatus::MULTI->new(
|
||||
peer => [ $ENV{TEST_SERVER}, $ENV{TEST_SOCKET} ],
|
||||
),
|
||||
};
|
||||
|
||||
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','persistent',
|
||||
'source','type'
|
||||
],
|
||||
'contacts' => [
|
||||
'address1','address2','address3','address4','address5','address6','alias',
|
||||
'can_submit_commands','custom_variable_names','custom_variable_values','email',
|
||||
'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','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_freshness','check_interval',
|
||||
'check_options','check_period','check_type','checks_enabled','childs','comments','comments_with_info',
|
||||
'contacts','current_attempt','current_notification_number','custom_variable_names',
|
||||
'custom_variable_values','display_name','downtimes','downtimes_with_info','event_handler_enabled',
|
||||
'execution_time','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','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','perf_data','plugin_output',
|
||||
'process_performance_data','retry_interval','scheduled_downtime_depth','services','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_interval','check_options','check_period',
|
||||
'check_type','checks_enabled','comments','comments_with_info','contacts','current_attempt',
|
||||
'current_notification_number','custom_variable_names','custom_variable_values',
|
||||
'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','notes','notes_expanded','notes_url','notes_url_expanded',
|
||||
'notification_interval','notification_period','notifications_enabled','obsess_over_service',
|
||||
'percent_state_change','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__'
|
||||
],
|
||||
'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','forks','forks_rate','host_checks','host_checks_rate','interval_length',
|
||||
'last_command_check','last_log_rotation','livestatus_version','log_messages','log_messages_rate','nagios_pid','neb_callbacks',
|
||||
'neb_callbacks_rate','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);
|
||||
|
||||
# dont 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}) {
|
||||
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 dont 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);
|
||||
}
|
||||
95
api/perl/t/31-Monitoring-Livestatus-MULTI-live-test.t
Normal file
95
api/perl/t/31-Monitoring-Livestatus-MULTI-live-test.t
Normal file
@@ -0,0 +1,95 @@
|
||||
#!/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 => 22 );
|
||||
}
|
||||
|
||||
use_ok('Monitoring::Livestatus::MULTI');
|
||||
|
||||
#########################
|
||||
# create new test object
|
||||
my $objects_to_test = {
|
||||
'multi_one' => Monitoring::Livestatus::MULTI->new( peer => [ $ENV{TEST_SERVER} ], warnings => 0 ),
|
||||
'multi_two' => Monitoring::Livestatus::MULTI->new( peer => [ $ENV{TEST_SERVER}, $ENV{TEST_SOCKET} ], warnings => 0 ),
|
||||
'multi_three' => Monitoring::Livestatus::MULTI->new(
|
||||
'verbose' => '0',
|
||||
'warnings' => '0',
|
||||
'timeout' => '10',
|
||||
'peer' => [
|
||||
{ 'name' => 'Mon 1', 'peer' => $ENV{TEST_SERVER} },
|
||||
{ 'name' => 'Mon 2', 'peer' => $ENV{TEST_SOCKET} },
|
||||
],
|
||||
'keepalive' => '1'
|
||||
),
|
||||
};
|
||||
|
||||
# dont die on errors
|
||||
#$ml->errors_are_fatal(0);
|
||||
|
||||
for my $key (keys %{$objects_to_test}) {
|
||||
my $ml = $objects_to_test->{$key};
|
||||
isa_ok($ml, 'Monitoring::Livestatus::MULTI') or BAIL_OUT("no need to continue without a proper Monitoring::Livestatus::MULTI object");
|
||||
|
||||
#########################
|
||||
# DATA INTEGRITY
|
||||
#########################
|
||||
|
||||
my $statement = "GET hosts\nColumns: state name alias\nLimit: 1";
|
||||
my $data1 = $ml->selectall_arrayref($statement, {Slice => 1});
|
||||
my $data2 = $ml->selectall_arrayref($statement, {Slice => 1, AddPeer => 1});
|
||||
for my $data (@{$data2}) {
|
||||
delete $data->{'peer_name'};
|
||||
delete $data->{'peer_addr'};
|
||||
delete $data->{'peer_key'};
|
||||
}
|
||||
is_deeply($data1, $data2, "data integrity with peers added and Column");
|
||||
|
||||
$statement = "GET hosts\nLimit: 1";
|
||||
$data1 = $ml->selectall_arrayref($statement, {Slice => 1, Deepcopy => 1});
|
||||
$data2 = $ml->selectall_arrayref($statement, {Slice => 1, AddPeer => 1, Deepcopy => 1});
|
||||
for my $data (@{$data2}) {
|
||||
delete $data->{'peer_name'};
|
||||
delete $data->{'peer_addr'};
|
||||
delete $data->{'peer_key'};
|
||||
}
|
||||
is_deeply($data1, $data2, "data integrity with peers added without Columns");
|
||||
|
||||
#########################
|
||||
# try to change result set to scalar
|
||||
for my $data (@{$data1}) { $data->{'peer_name'} = 1; }
|
||||
for my $data (@{$data2}) { $data->{'peer_name'} = 1; }
|
||||
is_deeply($data1, $data2, "data integrity with changed result set");
|
||||
|
||||
#########################
|
||||
# try to change result set to hash
|
||||
for my $data (@{$data1}) { $data->{'peer_name'} = {}; }
|
||||
for my $data (@{$data2}) { $data->{'peer_name'} = {}; }
|
||||
is_deeply($data1, $data2, "data integrity with changed result set");
|
||||
|
||||
#########################
|
||||
# BACKENDS
|
||||
#########################
|
||||
my @backends = $ml->peer_key();
|
||||
$data1 = $ml->selectall_arrayref($statement, {Slice => 1});
|
||||
$data2 = $ml->selectall_arrayref($statement, {Slice => 1, Backend => \@backends });
|
||||
is_deeply($data1, $data2, "data integrity with backends");
|
||||
|
||||
#########################
|
||||
# BUGS
|
||||
#########################
|
||||
|
||||
#########################
|
||||
# Bug: Can't use string ("flap") as an ARRAY ref while "strict refs" in use at Monitoring/Livestatus/MULTI.pm line 206.
|
||||
$statement = "GET servicegroups\nColumns: name alias\nFilter: name = flap\nLimit: 1";
|
||||
$data1 = $ml->selectrow_array($statement);
|
||||
isnt($data1, undef, "bug check: Can't use string (\"group\")...");
|
||||
}
|
||||
106
api/perl/t/32-Monitoring-Livestatus-backend-test.t
Normal file
106
api/perl/t/32-Monitoring-Livestatus-backend-test.t
Normal file
@@ -0,0 +1,106 @@
|
||||
#!/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 dont know yet how many tests we got
|
||||
plan( tests => 55237 );
|
||||
}
|
||||
|
||||
# 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} ),
|
||||
|
||||
# MULTI
|
||||
'03 multi_keepalive' => Monitoring::Livestatus->new( [ $ENV{TEST_SERVER}, $ENV{TEST_SOCKET} ] ),
|
||||
};
|
||||
|
||||
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);
|
||||
|
||||
# dont 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) {
|
||||
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);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
74
api/perl/t/33-Monitoring-Livestatus-test_socket_timeout.t
Normal file
74
api/perl/t/33-Monitoring-Livestatus-test_socket_timeout.t
Normal file
@@ -0,0 +1,74 @@
|
||||
#!/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 dont 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);
|
||||
}
|
||||
78
api/perl/t/34-Monitoring-Livestatus-utf8_support.t
Normal file
78
api/perl/t/34-Monitoring-Livestatus-utf8_support.t
Normal file
@@ -0,0 +1,78 @@
|
||||
#!/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 => 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 dont 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));
|
||||
}
|
||||
}
|
||||
53
api/perl/t/35-Monitoring-Livestatus-callbacks_support.t
Normal file
53
api/perl/t/35-Monitoring-Livestatus-callbacks_support.t
Normal file
@@ -0,0 +1,53 @@
|
||||
#!/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');
|
||||
}
|
||||
9
api/perl/t/97-Pod.t
Normal file
9
api/perl/t/97-Pod.t
Normal file
@@ -0,0 +1,9 @@
|
||||
use 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();
|
||||
23
api/perl/t/98-Pod-Coverage.t
Normal file
23
api/perl/t/98-Pod-Coverage.t
Normal file
@@ -0,0 +1,23 @@
|
||||
#!/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();
|
||||
24
api/perl/t/99-Perl-Critic.t
Normal file
24
api/perl/t/99-Perl-Critic.t
Normal file
@@ -0,0 +1,24 @@
|
||||
#!/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();
|
||||
286
api/perl/t/perlcriticrc
Normal file
286
api/perl/t/perlcriticrc
Normal file
@@ -0,0 +1,286 @@
|
||||
##############################################################################
|
||||
# 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 = 4
|
||||
Reference in New Issue
Block a user