File Coverage

lib/Devel/Trepan/CmdProcessor/Command/Condition.pm
Criterion Covered Total %
statement 72 122 59.0
branch 0 16 0.0
condition n/a
subroutine 24 26 92.3
pod 0 2 0.0
total 96 166 57.8


line stmt bran cond sub pod time code
1             # -*- coding: utf-8 -*-
2             # Copyright (C) 2011-2012 Rocky Bernstein <rocky@cpan.org>
3 12     12   105 use warnings; no warnings 'redefine';
  12     12   32  
  12     1   489  
  12     1   78  
  12         34  
  12         446  
  1         7  
  1         3  
  1         24  
  1         5  
  1         2  
  1         27  
4 12     12   75 use rlib '../../../..';
  12     1   30  
  12         91  
  1         6  
  1         7  
  1         5  
5              
6             package Devel::Trepan::CmdProcessor::Command::Condition;
7 12     12   4531 use English qw( -no_match_vars );
  12     1   32  
  12         90  
  1         304  
  1         2  
  1         6  
8              
9 12     12   4823 use if !@ISA, Devel::Trepan::Condition ;
  12     1   36  
  12         91  
  1         244  
  1         2  
  1         6  
10 12     12   1120 use if !@ISA, Devel::Trepan::CmdProcessor::Command ;
  12     1   32  
  12         53  
  1         32  
  1         2  
  1         4  
11              
12             unless (@ISA) {
13 12     12   92 eval <<"EOE";
  12     12   33  
  12     12   754  
  12     12   77  
  12     12   31  
  12     12   515  
  12         78  
  12         35  
  12         627  
  12         73  
  12         28  
  12         507  
  12         67  
  12         29  
  12         585  
  12         70  
  12         30  
  12         382  
14             use constant ALIASES => qw(cond);
15             use constant CATEGORY => 'breakpoints';
16             use constant NEED_STACK => 0;
17             use constant SHORT_HELP =>
18             'Specify a condition on a breakpoint';
19             use constant MIN_ARGS => 2; # Need at least this many
20             use constant MAX_ARGS => undef; # Need at most this many - undef -> unlimited.
21             EOE
22             }
23              
24 12     12   1937 use strict; use vars qw(@ISA); @ISA = @CMD_ISA;
  12     12   33  
  12     1   305  
  12     1   60  
  12         30  
  12         617  
  1         56  
  1         2  
  1         18  
  1         6  
  1         2  
  1         49  
25 12     12   78 use vars @CMD_VARS; # Value inherited from parent
  12     1   33  
  12         4717  
  1         5  
  1         2  
  1         295  
26              
27             our $NAME = set_name();
28             =pod
29              
30             =head2 Synopsis:
31              
32             =cut
33             our $HELP = <<'HELP';
34             =pod
35              
36             B<condition> I<bp-number> I<Perl-expression>
37              
38             I<bp-number> is a breakpoint number. I<Perl-expresion> is a Perl
39             expression which must evaluate to true before the breakpoint is
40             honored. If I<perl-expression> is absent, any existing condition is removed;
41             i.e., the breakpoint is made unconditional.
42              
43             =head2 Examples:
44              
45             condition 5 x > 10 # Breakpoint 5 now has condition x > 10
46             condition 5 # Remove above condition
47              
48             =head2 See also:
49              
50             L<C<break>|Devel::Trepan::CmdProcessor::Command::Break>,
51             L<C<enable>|Devel::Trepan::CmdProcessor::Command::Enable> and
52             L<C<disable>|Devel::Trepan::CmdProcessor::Command::Disable>.
53              
54             =cut
55             HELP
56              
57             # This method runs the command
58             sub run($$) {
59 0     0 0   my ($self, $args) = @_;
  0     0 0    
60 0           my $proc = $self->{proc};
  0            
61 0           my $bpnum = $proc->get_an_int($args->[1]);
  0            
62 0 0         return unless defined($bpnum);
  0 0          
63 0           my $bp = $proc->{brkpts}->find($bpnum);
  0            
64 0 0         unless ($bp) {
  0 0          
65 0           $proc->errmsg("No breakpoint number $bpnum");
  0            
66 0           return;
  0            
67             }
68              
69 0           my $condition;
  0            
70 0 0         if (scalar @{$args} > 2) {
  0 0          
  0            
  0            
71 0           my @args = @{$args};
  0            
  0            
  0            
72 0           shift @args; shift @args;
  0            
  0            
  0            
73 0           $condition = join(' ', @args);
  0            
74 0           my $msg = &DB::eval_not_ok($condition);
  0            
75 0 0         if ($msg) {
  0 0          
76 0           $proc->errmsg("Invalid condition: $condition");
  0            
77 0           chomp $msg;
  0            
78 0           $proc->errmsg($msg);
  0            
79             return
80 0           }
  0            
81             } else {
82 0           $condition = '1';
  0            
83 0           $proc->msg('Breakpoint $bp->id is now unconditional.');
  0            
84             }
85 0           $bp->condition($condition);
  0            
86             }
87              
88             unless (caller) {
89             require Devel::Trepan::CmdProcessor::Mock;
90             my $proc = Devel::Trepan::CmdProcessor::Mock::setup();
91             # my $cmd = __PACKAGE__->new($proc);
92             # $cmd->run([$NAME]);
93             }
94              
95             1;