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
  19     my $dev_tty = '/dev/tty';
  20     $dev_tty = 'TT:' if ($^O eq 'VMS');
  21     if (! -c $dev_tty) {
  22         print "1..0 # Skip: no $dev_tty\n";
  23         exit 0;
  24     }
  25     if ($ENV{PERL5DB}) {
  26         print "1..0 # Skip: \$ENV{PERL5DB} is already set to '$ENV{PERL5DB}'\n";
  27         exit 0;
  28     }
  29 }
  30
  31 plan(11);
  32
  33 my $rc_filename = '.perldb';
  34
  35 sub rc {
  36     open my $rc_fh, '>', $rc_filename
  37         or die $!;
  38     print {$rc_fh} @_;
  39     close ($rc_fh);
  40
  41     # overly permissive perms gives "Must not source insecure rcfile"
  42     # and hangs at the DB(1> prompt
  43     chmod 0644, $rc_filename;
  44 }
  45
  46 sub _slurp
  47 {
  48     my $filename = shift;
  49
  50     open my $in, '<', $filename
  51         or die "Cannot open '$filename' for slurping - $!";
  52
  53     local $/;
  54     my $contents = <$in>;
  55
  56     close($in);
  57
  58     return $contents;
  59 }
  60
  61 my $out_fn = 'db.out';
  62
  63 sub _out_contents
  64 {
  65     return _slurp($out_fn);
  66 }
  67
  68 {
  69     my $target = '../lib/perl5db/t/eval-line-bug';
  70
  71     rc(
  72         <<"EOF",
  73     &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
  74
  75     sub afterinit {
  76         push(\@DB::typeahead,
  77             'b 23',
  78             'n',
  79             'n',
  80             'n',
  81             'c', # line 23
  82             'n',
  83             "p \\\@{'main::_<$target'}",
  84             'q',
  85         );
  86     }
  87 EOF
  88     );
  89
  90     {
  91         local $ENV{PERLDB_OPTS} = "ReadLine=0";
  92         runperl(switches => [ '-d' ], progfile => $target);
  93     }
  94 }
  95
  96 like(_out_contents(), qr/sub factorial/,
  97     'The ${main::_<filename} variable in the debugger was not destroyed'
  98 );
  99
 100 {
 101     local $ENV{PERLDB_OPTS} = "ReadLine=0";
 102     my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/lvalue-bug');
 103     like($output, qr/foo is defined/, 'lvalue subs work in the debugger');
 104 }
 105
 106 {
 107     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
 108     my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/symbol-table-bug');
 109     like($output, qr/Undefined symbols 0/, 'there are no undefined values in the symbol table');
 110 }
 111
 112 SKIP: {
 113     if ( $Config{usethreads} ) {
 114         skip('This perl has threads, skipping non-threaded debugger tests');
 115     } else {
 116         my $error = 'This Perl not built to support threads';
 117         my $output = runperl( switches => [ '-dt' ], stderr => 1 );
 118         like($output, qr/$error/, 'Perl debugger correctly complains that it was not built with threads');
 119     }
 120
 121 }
 122 SKIP: {
 123     if ( $Config{usethreads} ) {
 124         local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
 125         my $output = runperl(switches => [ '-dt' ], progfile => '../lib/perl5db/t/symbol-table-bug');
 126         like($output, qr/Undefined symbols 0/, 'there are no undefined values in the symbol table when running with thread support');
 127     } else {
 128         skip("This perl is not threaded, skipping threaded debugger tests");
 129     }
 130 }
 131
 132
 133 # Test [perl #61222]
 134 {
 135     rc(
 136         <<'EOF',
 137         &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 138
 139         sub afterinit {
 140             push(@DB::typeahead,
 141                 'm Pie',
 142                 'q',
 143             );
 144         }
 145 EOF
 146     );
 147
 148     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-61222');
 149     unlike(_out_contents(), qr/INCORRECT/, "[perl #61222]");
 150 }
 151
 152
 153
 154 # Test for Proxy constants
 155 {
 156     rc(
 157         <<'EOF',
 158
 159 &parse_options("NonStop=0 ReadLine=0 TTY=db.out LineInfo=db.out");
 160
 161 sub afterinit {
 162     push(@DB::typeahead,
 163         'm main->s1',
 164         'q',
 165     );
 166 }
 167
 168 EOF
 169     );
 170
 171     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants');
 172     is($output, "", "proxy constant subroutines");
 173 }
 174
 175 # Testing that we can set a line in the middle of the file.
 176 {
 177     rc(<<'EOF');
 178 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 179
 180 sub afterinit {
 181     push (@DB::typeahead,
 182     'b ../lib/perl5db/t/MyModule.pm:12',
 183     'c',
 184     q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
 185     'c',
 186     'q',
 187     );
 188
 189 }
 190 EOF
 191
 192     my $output = runperl(switches => [ '-d', '-I', '../lib/perl5db/t', ], stderr => 1, progfile => '../lib/perl5db/t/filename-line-breakpoint');
 193
 194     like($output, qr/
 195         ^Var=Bar$
 196             .*
 197         ^In\ MyModule\.$
 198             .*
 199         ^In\ Main\ File\.$
 200             .*
 201         /msx,
 202         "Can set breakpoint in a line in the middle of the file.");
 203 }
 204
 205
 206 # [perl #66110] Call a subroutine inside a regex
 207 {
 208     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
 209     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
 210     like($output, "All tests successful.", "[perl #66110]");
 211 }
 212
 213 # taint tests
 214
 215 {
 216     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
 217     my $output = runperl(switches => [ '-d', '-T' ], stderr => 1,
 218         progfile => '../lib/perl5db/t/taint');
 219     chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
 220     is($output, '[$^X][done]', "taint");
 221 }
 222
 223 # Testing that we can set a breakpoint
 224 {
 225     rc(<<'EOF');
 226 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 227
 228 sub afterinit {
 229     push (@DB::typeahead,
 230     'b 6',
 231     'c',
 232     q/do { use IO::Handle; STDOUT->autoflush(1); print "X={$x}\n"; }/,
 233     'c',
 234     'q',
 235     );
 236
 237 }
 238 EOF
 239
 240     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/breakpoint-bug');
 241
 242     like($output, qr/
 243         X=\{Two\}
 244         /msx,
 245         "Can set breakpoint in a line.");
 246 }
 247
 248
 249
 250 # clean up.
 251
 252 END {
 253     1 while unlink ($rc_filename, $out_fn);
 254 }