This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #48489] patch to fix perl bug #7013
[perl5.git] / lib / perl5db.t
1 #!/usr/bin/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
12 BEGIN {
13     if (!-c "/dev/null") {
14         print "1..0 # Skip: no /dev/null\n";
15         exit 0;
16     }
17 my $dev_tty = '/dev/tty';
18    $dev_tty = 'TT:' if ($^O eq 'VMS');
19     if (!-c $dev_tty) {
20         print "1..0 # Skip: no $dev_tty\n";
21         exit 0;
22     }
23     if ($ENV{PERL5DB}) {
24         print "1..0 # Skip: \$ENV{PERL5DB} is already set to '$ENV{PERL5DB}'\n";
25         exit 0;
26     }
27 }
28
29 plan(2);
30
31 sub rc {
32     open RC, ">", ".perldb" or die $!;
33     print RC @_;
34     close(RC);
35     # overly permissive perms gives "Must not source insecure rcfile"
36     # and hangs at the DB(1> prompt
37     chmod 0644, ".perldb";
38 }
39
40 my $target = '../lib/perl5db/t/eval-line-bug';
41
42 rc(
43     qq|
44     &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
45     \n|,
46
47     qq|
48     sub afterinit {
49         push(\@DB::typeahead,
50             'b 23',
51             'n',
52             'n',
53             'n',
54             'c', # line 23
55             'n',
56             "p \\\@{'main::_<$target'}",
57             'q',
58         );
59     }\n|,
60 );
61
62 {
63     local $ENV{PERLDB_OPTS} = "ReadLine=0";
64     runperl(switches => [ '-d' ], progfile => $target);
65 }
66
67 my $contents;
68 {
69     local $/;
70     open I, "<", 'db.out' or die $!;
71     $contents = <I>;
72     close(I);
73 }
74
75 like($contents, qr/sub factorial/,
76     'The ${main::_<filename} variable in the debugger was not destroyed'
77 );
78
79 {
80     local $ENV{PERLDB_OPTS} = "ReadLine=0";
81     my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/lvalue-bug');
82     like($output, qr/foo is defined/, 'lvalue subs work in the debugger');
83 }
84
85 # clean up.
86
87 END {
88     unlink qw(.perldb db.out);
89 }