This queue is for tickets about the Devel-Gladiator CPAN distribution.

Report information
The Basics
Id:
89921
Status:
new
Priority:
Low/Low

People
Owner:
Nobody in particular
Requestors:
arfreitas [...] cpan.org(email delivery suspended)
Cc:
AdminCc:



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.



This service runs on Request Tracker, is sponsored by The Perl Foundation, and maintained by Best Practical Solutions.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.