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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
|
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
use strict;
use warnings;
use Config;
BEGIN {
if (!-c "/dev/null") {
print "1..0 # Skip: no /dev/null\n";
exit 0;
}
my $dev_tty = '/dev/tty';
$dev_tty = 'TT:' if ($^O eq 'VMS');
if (!-c $dev_tty) {
print "1..0 # Skip: no $dev_tty\n";
exit 0;
}
if ($ENV{PERL5DB}) {
print "1..0 # Skip: \$ENV{PERL5DB} is already set to '$ENV{PERL5DB}'\n";
exit 0;
}
}
plan(9);
sub rc {
open RC, ">", ".perldb" or die $!;
print RC @_;
close(RC);
# overly permissive perms gives "Must not source insecure rcfile"
# and hangs at the DB(1> prompt
chmod 0644, ".perldb";
}
my $target = '../lib/perl5db/t/eval-line-bug';
rc(
qq|
&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
\n|,
qq|
sub afterinit {
push(\@DB::typeahead,
'b 23',
'n',
'n',
'n',
'c', # line 23
'n',
"p \\\@{'main::_<$target'}",
'q',
);
}\n|,
);
{
local $ENV{PERLDB_OPTS} = "ReadLine=0";
runperl(switches => [ '-d' ], progfile => $target);
}
my $contents;
{
local $/;
open I, "<", 'db.out' or die $!;
$contents = <I>;
close(I);
}
like($contents, qr/sub factorial/,
'The ${main::_<filename} variable in the debugger was not destroyed'
);
{
local $ENV{PERLDB_OPTS} = "ReadLine=0";
my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/lvalue-bug');
like($output, qr/foo is defined/, 'lvalue subs work in the debugger');
}
{
local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/symbol-table-bug');
like($output, qr/Undefined symbols 0/, 'there are no undefined values in the symbol table');
}
SKIP: {
if ( $Config{usethreads} ) {
skip('This perl has threads, skipping non-threaded debugger tests');
} else {
my $error = 'This Perl not built to support threads';
my $output = runperl( switches => [ '-dt' ], stderr => 1 );
like($output, qr/$error/, 'Perl debugger correctly complains that it was not built with threads');
}
}
SKIP: {
if ( $Config{usethreads} ) {
local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
my $output = runperl(switches => [ '-dt' ], progfile => '../lib/perl5db/t/symbol-table-bug');
like($output, qr/Undefined symbols 0/, 'there are no undefined values in the symbol table when running with thread support');
} else {
skip("This perl is not threaded, skipping threaded debugger tests");
}
}
# Test [perl #61222]
{
rc(
qq|
&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
\n|,
qq|
sub afterinit {
push(\@DB::typeahead,
'm Pie',
'q',
);
}\n|,
);
my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-61222');
my $contents;
{
local $/;
open I, "<", 'db.out' or die $!;
$contents = <I>;
close(I);
}
unlike($contents, qr/INCORRECT/, "[perl #61222]");
}
# Test for Proxy constants
{
rc(
qq|
&parse_options("NonStop=0 ReadLine=0 TTY=db.out LineInfo=db.out");
\n|,
qq|
sub afterinit {
push(\@DB::typeahead,
'm main->s1',
'q',
);
}\n|,
);
my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants');
is($output, "", "proxy constant subroutines");
}
# [perl #66110] Call a subroutine inside a regex
{
local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
like($output, "All tests successful.", "[perl #66110]");
}
# taint tests
{
local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
my $output = runperl(switches => [ '-d', '-T' ], stderr => 1,
progfile => '../lib/perl5db/t/taint');
chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
is($output, '[$^X][done]', "taint");
}
# clean up.
END {
1 while unlink qw(.perldb db.out);
}
|
