-
Notifications
You must be signed in to change notification settings - Fork 8
/
Quit.pm
100 lines (83 loc) · 2.65 KB
/
Quit.pm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
# Copyright (C) 2011, 2012 Rocky Bernstein <rocky@cpan.org>
use warnings; no warnings 'redefine';
use rlib '../../../..';
package Devel::Trepan::CmdProcessor::Command::Quit;
use if !@ISA, Devel::Trepan::CmdProcessor::Command ;
unless (@ISA) {
eval <<'EOE';
use constant ALIASES => ('quit!', 'q', 'q!');
use constant CATEGORY => 'support';
use constant SHORT_HELP => 'Quit program - gently';
use constant MIN_ARGS => 0; # Need at least this many
use constant MAX_ARGS => 2; # Need at most this many - undef -> unlimited.
EOE
}
use strict;
use vars qw(@ISA); @ISA = @CMD_ISA;
use vars @CMD_VARS; # Value inherited from parent
our $NAME = set_name();
our $HELP = <<'HELP';
=pod
B<quit>[B<!>] [B<unconditionally>] [I<exit-code>]
Gently exit the debugger and debugged program.
The program being debugged is exited via I<exit()> which runs the
Kernel I<at_exit()> finalizers. If a return code is given, that is the
return code passed to I<exit()> - presumably the return code that will
be passed back to the OS. If no exit code is given, 0 is used.
=head2 Examples:
quit # quit prompting if we are interactive
quit unconditionally # quit without prompting
quit! # same as above
quit 0 # same as "quit"
quit! 1 # unconditional quit setting exit code 1
See also C<set confirm> and
L<C<kill>|Devel::Trepan::CmdProcessor::Command::Kill>.
=cut
HELP
# This method runs the command
sub run($$)
{
my ($self, $args) = @_;
my $proc = $self->{proc};
my @args = @$args;
my $unconditional = 0;
if (scalar(@args) > 1 && $args->[-1] eq 'unconditionally') {
pop @args;
$unconditional = 1;
} elsif (substr($args[0], -1) eq '!') {
$unconditional = 1;
}
unless ($unconditional || $proc->{terminated} ||
$proc->confirm('Really quit?', 0)) {
$self->msg('Quit not confirmed.');
return;
}
my $exitrc = 0;
if (scalar(@args) > 1) {
if ($args[1] =~ /\d+/) {
$exitrc = $args[1];
} else {
$self->errmsg("Bad an Integer return type \"$args[1]\"");
return;
}
}
no warnings 'once';
$DB::single = 0;
$DB::fall_off_on_end = 1;
$self->{proc}->{interfaces} = [];
# No graceful way to stop threads...
exit $exitrc;
}
unless (caller) {
require Devel::Trepan::CmdProcessor::Mock;
my $proc = Devel::Trepan::CmdProcessor->new(undef, 'bogus');
my $cmd = __PACKAGE__->new($proc);
my $child_pid = fork;
if ($child_pid == 0) {
$cmd->run([$NAME, 'unconditionally']);
} else {
wait;
}
$cmd->run([$NAME, '5', 'unconditionally']);
}
1;