use warnings;
use strict;
use Test::More;
use Test::Moose qw(has_attribute_ok);
use Test::TempDir::Tiny;
use File::Spec;
use Siebel::Srvrmgr::Log::Enterprise::Parser::Comp_alias;
use lib 't';
use Test::Siebel::Srvrmgr::Fixtures qw(create_ent_log);
eval "use Siebel::Srvrmgr::OS::Unix";
plan skip_all =>
"Siebel::Srvrmgr::OS::Unix is required for running these tests: $@"
if $@;
use constant TMP_DIR => tempdir();
use constant ENTERPRISE_LOG =>
File::Spec->catfile( TMP_DIR, 'foobar.foobar666.log' );
# :WORKAROUND:22-03-2015 19:58:18:: setting to this hardcode because the hack to define $0 for a running process
# set both fname and cmndline attributes of Proc::ProcessTable::Process
use constant PROC_NAME => 'siebmtshmw';
use constant TOTAL_TESTS => 16;
plan tests => TOTAL_TESTS;
if ( $] >= 5.012_005 ) {
SKIP: {
eval
q{use Proc::Daemon; die "This test is not supported at this version of perl ($])" unless $] > 5.012_005};
skip "Cannot run this test because of \"$@\"", TOTAL_TESTS, if $@;
my $daemon = Proc::Daemon->new();
my $kid = $daemon->init();
unless ($kid) {
local $0 = PROC_NAME;
#let's put child to do something
while (1) {
my $a = 0;
my $b = 1;
my $n = 2000;
for ( 0 .. ( $n - 1 ) ) {
my $sum = $a + $b;
$a = $b;
$b = $sum;
}
sleep 1;
}
}
else {
my $procs = fixtures($kid);
test_attributes($procs);
test_methods($procs);
test_operations($procs);
$daemon->Kill_Daemon($kid);
}
}
}
else {
SKIP: {
# :REMARK:23-03-2015 02:23:56:: perl 5.8.9 does not allow the change of fname in /proc by changing $0
eval q{use Proc::Background};
skip "Cannot run this test because of \"$@\"", TOTAL_TESTS, if $@;
my $proc_path = File::Spec->catfile( TMP_DIR, PROC_NAME );
open( my $script, '>', $proc_path )
or die "Cannot create $$proc_path: $!";
my $code = q(#!/usr/bin/perl
#let's put child to do something
while (1) {
my $a = 0;
my $b = 1;
my $n = 2000;
for ( 0 .. ( $n - 1 ) ) {
my $sum = $a + $b;
$a = $b;
$b = $sum;
}
sleep 1;
});
print $script $code;
close($script);
chmod 0700, $proc_path;
my $siebel_proc = Proc::Background->new($proc_path);
my $procs = fixtures( $siebel_proc->pid );
test_attributes($procs);
test_methods($procs);
test_operations($procs);
$siebel_proc->die;
}
}
###################################################
# SUBS
#
sub fixtures {
my $pid = shift;
note("Running tests against perl $], child PID is $pid");
# giving some time to get data into /proc
sleep 3;
create_ent_log( $pid, ENTERPRISE_LOG );
return Siebel::Srvrmgr::OS::Unix->new(
{
cmd_regex => ( PROC_NAME . '$' ),
comps_source =>
Siebel::Srvrmgr::Log::Enterprise::Parser::Comp_alias->new(
{
#ServerLog ProcessCreate 1 0000149754f82575:0 2015-03-05 13:15:41 Created multithreaded server process (OS pid = 9644 ) for SRProc
process_regex =>
'Created(\smultithreaded)?\sserver\sprocess',
log_path => ENTERPRISE_LOG,
}
)
}
);
}
END {
unlink ENTERPRISE_LOG
or note( 'Failed to remove ' . ENTERPRISE_LOG . ": $!" );
rmdir TMP_DIR or note( 'Failed to remove ' . TMP_DIR . ": $!" );
}
sub test_operations {
my $procs = shift;
my $procs_ref = $procs->get_procs();
is( ref($procs_ref), 'HASH', 'get_procs returns a hash reference' );
# :WORKAROUND:21-06-2015 12:53:45:: avoid getting other undesired process beside the one we are forcing as "Siebel process"
# :WORKAROUND:03-12-2015 13:31:44:: avoid problems with concurrent tests on the same OS
foreach my $pid ( keys( %{$procs_ref} ) ) {
if ( ( $procs_ref->{$pid}->{comp_alias} eq 'N/A' )
or ( $procs_ref->{$pid}->{comp_alias} eq 'unknown' ) )
{
delete $procs_ref->{$pid};
}
}
is( scalar( keys( %{$procs_ref} ) ),
1, 'get_procs returns a single process' )
or diag( explain($procs_ref) );
my $pid = ( keys( %{$procs_ref} ) )[0];
isa_ok(
$procs_ref->{$pid},
'Siebel::Srvrmgr::OS::Process',
"reference of $pid key"
);
is( $procs_ref->{$pid}->get_comp_alias,
'EAIObjMgr_enu', 'process has the correct component alias associated' );
is( $procs_ref->{$pid}->get_fname,
'siebmtshmw', 'process has the correct process name' );
ok( $procs_ref->{$pid}->is_comp, 'is_comp returns true' );
my $float = qr/\d+(\.\d+)?/;
my $integer = qr/\d+/;
like( $procs_ref->{$pid}->get_pctcpu, $float, 'process %CPU is a float' );
like( $procs_ref->{$pid}->get_pctmem, $float,
'process %memory is a float' );
like( $procs_ref->{$pid}->get_rss, $integer, 'process RSS is a integer' );
like( $procs_ref->{$pid}->get_vsz, $integer, 'process VSZ is a integer' );
}
sub test_methods {
my $procs = shift;
my @methods = (
'get_cmd', 'set_cmd',
'get_mem_limit', 'set_mem_limit',
'find_comps', 'get_procs',
'get_cpu_limit', 'set_cpu_limit',
'get_comps_source'
);
can_ok( $procs, @methods );
}
sub test_attributes {
my $procs = shift;
my @attribs =
(qw(comps_source cmd_regex mem_limit cpu_limit limits_callback));
foreach my $attrib (@attribs) {
has_attribute_ok( $procs, $attrib );
}
}