Rename tied_handle_method() to tied_method(), and make it non-static.
[perl.git] / lib / perl5db.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require './test.pl';
7 }
8
9 use strict;
10 use warnings;
11 use Config;
12
13 BEGIN {
14     if (!-c "/dev/null") {
15         print "1..0 # Skip: no /dev/null\n";
16         exit 0;
17     }
18 my $dev_tty = '/dev/tty';
19    $dev_tty = 'TT:' if ($^O eq 'VMS');
20     if (!-c $dev_tty) {
21         print "1..0 # Skip: no $dev_tty\n";
22         exit 0;
23     }
24     if ($ENV{PERL5DB}) {
25         print "1..0 # Skip: \$ENV{PERL5DB} is already set to '$ENV{PERL5DB}'\n";
26         exit 0;
27     }
28 }
29
30 plan(9);
31
32 sub rc {
33     open RC, ">", ".perldb" or die $!;
34     print RC @_;
35     close(RC);
36     # overly permissive perms gives "Must not source insecure rcfile"
37     # and hangs at the DB(1> prompt
38     chmod 0644, ".perldb";
39 }
40
41 my $target = '../lib/perl5db/t/eval-line-bug';
42
43 rc(
44     qq|
45     &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
46     \n|,
47
48     qq|
49     sub afterinit {
50         push(\@DB::typeahead,
51             'b 23',
52             'n',
53             'n',
54             'n',
55             'c', # line 23
56             'n',
57             "p \\\@{'main::_<$target'}",
58             'q',
59         );
60     }\n|,
61 );
62
63 {
64     local $ENV{PERLDB_OPTS} = "ReadLine=0";
65     runperl(switches => [ '-d' ], progfile => $target);
66 }
67
68 my $contents;
69 {
70     local $/;
71     open I, "<", 'db.out' or die $!;
72     $contents = <I>;
73     close(I);
74 }
75
76 like($contents, qr/sub factorial/,
77     'The ${main::_<filename} variable in the debugger was not destroyed'
78 );
79
80 {
81     local $ENV{PERLDB_OPTS} = "ReadLine=0";
82     my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/lvalue-bug');
83     like($output, qr/foo is defined/, 'lvalue subs work in the debugger');
84 }
85
86 {
87     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
88     my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/symbol-table-bug');
89     like($output, qr/Undefined symbols 0/, 'there are no undefined values in the symbol table');
90 }
91
92 SKIP: {
93     if ( $Config{usethreads} ) {
94         skip('This perl has threads, skipping non-threaded debugger tests');
95     } else {
96         my $error = 'This Perl not built to support threads';
97         my $output = runperl( switches => [ '-dt' ], stderr => 1 );
98         like($output, qr/$error/, 'Perl debugger correctly complains that it was not built with threads');
99     }
100
101 }
102 SKIP: {
103     if ( $Config{usethreads} ) {
104         local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
105         my $output = runperl(switches => [ '-dt' ], progfile => '../lib/perl5db/t/symbol-table-bug');
106         like($output, qr/Undefined symbols 0/, 'there are no undefined values in the symbol table when running with thread support');
107     } else {
108         skip("This perl is not threaded, skipping threaded debugger tests");
109     }
110 }
111
112
113 # Test [perl #61222]
114 {
115     rc(
116         qq|
117         &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
118         \n|,
119
120         qq|
121         sub afterinit {
122             push(\@DB::typeahead,
123                 'm Pie',
124                 'q',
125             );
126         }\n|,
127     );
128
129     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-61222');
130     my $contents;
131     {
132         local $/;
133         open I, "<", 'db.out' or die $!;
134         $contents = <I>;
135         close(I);
136     }
137     unlike($contents, qr/INCORRECT/, "[perl #61222]");
138 }
139
140
141
142 # Test for Proxy constants
143 {
144     rc(
145         qq|
146         &parse_options("NonStop=0 ReadLine=0 TTY=db.out LineInfo=db.out");
147         \n|,
148
149         qq|
150         sub afterinit {
151             push(\@DB::typeahead,
152                 'm main->s1',
153                 'q',
154             );
155         }\n|,
156     );
157
158     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants');
159     is($output, "", "proxy constant subroutines");
160 }
161
162
163 # [perl #66110] Call a subroutine inside a regex
164 {
165     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
166     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
167     like($output, "All tests successful.", "[perl #66110]");
168 }
169
170 # taint tests
171
172 {
173     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
174     my $output = runperl(switches => [ '-d', '-T' ], stderr => 1,
175                         progfile => '../lib/perl5db/t/taint');
176     chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
177     is($output, '[$^X][done]', "taint");
178 }
179
180
181 # clean up.
182
183 END {
184     1 while unlink qw(.perldb db.out);
185 }