| Subject: | a better description of how to interpret report results |
Hello,
Devel::Gladiator is great, but the results are a bit difficult to understand without an understanding of Perl internals. For example, the output below (with results rearranged to references counts per object and counting for each iteration of an application, separated by pipe):
ARRAY|1321|1465|1573
CODE|536|551|566
FSA::State|20|30|40
GLOB|953|954|954
HASH|274|313|352
REF|566|798|994
REF-ARRAY|158|272|350
REF-CODE|97|142|187
REF-FSA::State|56|84|112
REF-HASH|90|129|168
REF-Regexp|12|18|24
Regexp|12|18|24
SCALAR|10156|10303|10447
While it is easy to spot the package named objects (as "FSA::State") and try to remove the circular references, how should I deal with the objects SCALAR, Regexp, GLOB, CODE and ARRAY? Are they all related to the main package? So, the correct way to make those tests is to run everything inside a sub, giving the perl interpreter a chance to reclaim they from memory?
It would be great with the Pod include more information on this or a reference to anything that helps go through the details.
I attached the test example that generates the output as an example.
Thank you,
Alceu
| Subject: | ComplexInstance.pm |
package Test::ComplexInstance;
use warnings;
use strict;
use FSA::Rules;
sub get {
my $ls_params_regex =
qr/list\sparams(\sfor\sserver\s\w+\sfor\scomponent\s\w+)?/;
my $ls_tasks_regex =
qr/list\stasks(\sfor\sserver\s\w+\scomponent\sgroup?\s\w+)?/;
my $ls_servers_regex = qr/list\sserver(s)?.*/;
my $ls_comp_defs_regex = qr/list\scomp\sdefs?(\s\w+)?/;
my $conn_greet =
qr/^Siebel\sEnterprise\sApplications\sSiebel\sServer\sManager\,\sVersion.*/;
my $srvrmgr_prompt = qr/^srvrmgr(\:[\w\_\-]+)?>\s(.*)?$/;
my %params = (
done => sub {
my $self = shift;
my $curr_line = shift( @{ $self->notes('all_data') } );
$self->notes( 'line_num' => ( $self->notes('line_num') + 1 ) );
if ( defined($curr_line) ) {
if ( defined( $self->notes('last_command') )
and ( $self->notes('last_command') eq 'exit' ) )
{
return 1;
}
else {
$self->notes( line => $curr_line );
return 0;
}
}
else {
return 1;
}
}
);
my $fsa = FSA::Rules->new(
\%params,
no_data => {
rules => [
greetings => sub {
my $state = shift;
if ( defined( $state->notes('line') ) ) {
return ( $state->notes('line') =~ $conn_greet );
}
else {
return 0;
}
},
command_submission => sub {
my $state = shift;
if ( defined( $state->notes('line') ) ) {
return ( $state->notes('line') =~ $srvrmgr_prompt );
}
else {
return 0;
}
},
no_data => sub { return 1 }
],
message => 'Line read'
},
greetings => {
label => 'greetings message from srvrmgr',
on_enter => sub {
my $state = shift;
$state->notes( is_cmd_changed => 0 );
$state->notes( is_data_wanted => 1 );
$state->notes( 'create_greetings' => 1 )
unless ( $state->notes('greetings_created') );
},
on_exit => sub {
my $state = shift;
$state->notes( is_data_wanted => 0 );
},
rules => [
command_submission => sub {
my $state = shift;
return ( $state->notes('line') =~ $srvrmgr_prompt );
},
greetings => sub { return 1 }
],
message => 'prompt found'
},
end => {
rules => [
no_data => sub {
return 1;
}
],
message => 'EOF'
},
list_comp => {
label => 'parses output from a list comp command',
on_enter => sub {
my $state = shift;
$state->notes( is_cmd_changed => 0 );
$state->notes( is_data_wanted => 1 );
},
on_exit => sub {
my $state = shift;
$state->notes( is_data_wanted => 0 );
},
rules => [
command_submission => sub {
my $state = shift;
return ( $state->notes('line') =~ $srvrmgr_prompt );
},
list_comp => sub { return 1; }
],
message => 'prompt found'
},
list_comp_types => {
label => 'parses output from a list comp types command',
on_enter => sub {
my $state = shift;
$state->notes( is_cmd_changed => 0 );
$state->notes( is_data_wanted => 1 );
},
on_exit => sub {
my $state = shift;
$state->notes( is_data_wanted => 0 );
},
rules => [
command_submission => sub {
my $state = shift;
return ( $state->notes('line') =~ $srvrmgr_prompt );
},
list_comp_types => sub { return 1; }
],
message => 'prompt found'
},
list_params => {
label => 'parses output from a list params command',
on_enter => sub {
my $state = shift;
$state->notes( is_cmd_changed => 0 );
$state->notes( is_data_wanted => 1 );
},
on_exit => sub {
my $state = shift;
$state->notes( is_data_wanted => 0 );
},
rules => [
command_submission => sub {
my $state = shift;
return ( $state->notes('line') =~ $srvrmgr_prompt );
},
list_params => sub { return 1; }
],
message => 'prompt found'
},
list_comp_def => {
label => 'parses output from a list comp def command',
on_enter => sub {
my $state = shift;
$state->notes( is_cmd_changed => 0 );
$state->notes( is_data_wanted => 1 );
},
on_exit => sub {
my $state = shift;
$state->notes( is_data_wanted => 0 );
},
rules => [
command_submission => sub {
my $state = shift;
return ( $state->notes('line') =~ $srvrmgr_prompt );
},
list_comp_def => sub { return 1; }
],
message => 'prompt found'
},
list_tasks => {
label => 'parses output from a list tasks command',
on_enter => sub {
my $state = shift;
$state->notes( is_cmd_changed => 0 );
$state->notes( is_data_wanted => 1 );
},
on_exit => sub {
my $state = shift;
$state->notes( is_data_wanted => 0 );
},
rules => [
command_submission => sub {
my $state = shift;
return ( $state->notes('line') =~ $srvrmgr_prompt );
},
list_tasks => sub { return 1; }
],
message => 'prompt found'
},
list_servers => {
label => 'parses output from a list servers command',
on_enter => sub {
my $state = shift;
$state->notes( is_cmd_changed => 0 );
$state->notes( is_data_wanted => 1 );
},
on_exit => sub {
my $state = shift;
$state->notes( is_data_wanted => 0 );
},
rules => [
command_submission => sub {
my $state = shift;
return ( $state->notes('line') =~ $srvrmgr_prompt );
},
list_servers => sub { return 1; }
],
message => 'prompt found'
},
load_preferences => {
label => 'parses output from a load preferences command',
on_enter => sub {
my $state = shift;
$state->notes( is_cmd_changed => 0 );
$state->notes( is_data_wanted => 1 );
},
on_exit => sub {
my $state = shift;
$state->notes( is_data_wanted => 0 );
},
rules => [
command_submission => sub {
my $state = shift;
return ( $state->notes('line') =~ $srvrmgr_prompt );
},
load_preferences => sub { return 1; }
],
message => 'prompt found'
},
command_submission => {
do => sub {
my $state = shift;
my $cmd = ( $state->notes('line') =~ $srvrmgr_prompt )[1];
if ( ( defined($cmd) ) and ( $cmd ne '' ) ) {
# removing spaces from command
$cmd =~ s/^\s+//;
$cmd =~ s/\s+$//;
$state->notes( last_command => $cmd );
$state->notes( is_cmd_changed => 1 );
}
else {
$state->notes( last_command => '' );
$state->notes( is_cmd_changed => 1 );
}
},
rules => [
list_comp => sub {
my $state = shift;
if ( $state->notes('last_command') eq 'list comp' ) {
return 1;
}
else {
return 0;
}
},
list_comp_types => sub {
my $state = shift;
if ( ( $state->notes('last_command') eq 'list comp types' )
or
( $state->notes('last_command') eq 'list comp type' ) )
{
return 1;
}
else {
return 0;
}
},
list_params => sub {
my $state = shift;
if ( $state->notes('last_command') =~ $ls_params_regex ) {
return 1;
}
else {
return 0;
}
},
list_tasks => sub {
my $state = shift;
if ( $state->notes('last_command') =~ $ls_tasks_regex ) {
return 1;
}
else {
return 0;
}
},
list_servers => sub {
my $state = shift;
if ( $state->notes('last_command') =~ $ls_servers_regex ) {
return 1;
}
else {
return 0;
}
},
list_comp_def => sub {
my $state = shift;
if ( $state->notes('last_command') =~ $ls_comp_defs_regex )
{
return 1;
}
else {
return 0;
}
},
load_preferences => sub {
my $state = shift;
if ( $state->notes('last_command') eq 'load preferences' ) {
return 1;
}
else {
return 0;
}
},
no_data => sub {
my $state = shift;
if ( $state->notes('last_command') eq '' ) {
return 1;
}
else {
return 0;
}
},
# add other possibilities here of list commands
command_submission =>
sub { return 1; } # this must be the last item
],
message => 'command submitted'
}
);
return $fsa;
}
1;
| Subject: | Gladiator.pm |
package Test::Gladiator;
use Scalar::Util qw(weaken);
use Cwd;
use File::Spec;
sub new {
my $class = shift;
my $file = File::Spec->catfile( getcwd(), 'gladiator_output.txt' );
open( my $out, '>', $file ) or die "Cannot create $file: $!";
my $self = { counting => {}, out_h => $out };
return bless $self, $class;
}
sub DESTROY {
my $self = shift;
close( $self->{out_h} ) or die $!;
}
sub show_accounting {
my $self = shift;
my $out = $self->{out_h};
foreach my $key ( sort( keys( %{ $self->{counting} } ) ) ) {
print $out $key, '|', join( '|', @{ $self->{counting}->{$key} } ),
"\n"
if (
$self->{counting}->{$key}->[1] > $self->{counting}->{$key}->[0] );
}
}
sub count_leaks {
my $self = shift;
my $total = 0;
foreach my $key ( keys( %{ $self->{counting} } ) ) {
my $last = $#{ $self->{counting}->{$key} };
$total++
if ( $self->{counting}->{$key}->[$last] >
$self->{counting}->{$key}->[ $last - 1 ] );
}
return $total;
}
sub increment_count {
my $self = shift;
my $current = shift;
weaken($current);
foreach my $key ( keys( %{$current} ) ) {
if ( exists( $self->{counting}->{$key} ) ) {
push( @{ $self->{counting}->{$key} }, $current->{$key} );
}
else {
$self->{counting}->{$key} = [ $current->{$key} ];
}
}
}
1;
| Subject: | leak.t |
Message body is not shown because it is too large.