Skip Menu |
 

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

Report information
The Basics
Id: 89921
Status: new
Priority: 0/
Queue: Devel-Gladiator

People
Owner: Nobody in particular
Requestors: arfreitas [...] cpan.org
Cc:
AdminCc:

Bug Information
Severity: Wishlist
Broken in: 0.04
Fixed in: (no value)



Subject: a better description of how to interpret report results
Download (untitled) / with headers
text/plain 1.1k
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
Download ComplexInstance.pm
text/x-perl 11.6k
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
Download Gladiator.pm
text/x-perl 1.4k
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
Download leak.t
text/x-perl 175.5k

Message body is not shown because it is too large.



This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

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