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(19);
  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     my $target = '../lib/perl5db/t/eval-line-bug';
 102
 103     rc(
 104         <<"EOF",
 105     &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 106
 107     sub afterinit {
 108         push(\@DB::typeahead,
 109             'b 23',
 110             'c',
 111             '\$new_var = "Foo"',
 112             'x "new_var = <\$new_var>\\n";',
 113             'q',
 114         );
 115     }
 116 EOF
 117     );
 118
 119     {
 120         local $ENV{PERLDB_OPTS} = "ReadLine=0";
 121         runperl(switches => [ '-d' ], progfile => $target);
 122     }
 123 }
 124
 125 like(_out_contents(), qr/new_var = <Foo>/,
 126     "no strict 'vars' in evaluated lines.",
 127 );
 128
 129 {
 130     local $ENV{PERLDB_OPTS} = "ReadLine=0";
 131     my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/lvalue-bug');
 132     like($output, qr/foo is defined/, 'lvalue subs work in the debugger');
 133 }
 134
 135 {
 136     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
 137     my $output = runperl(switches => [ '-d' ], progfile => '../lib/perl5db/t/symbol-table-bug');
 138     like($output, qr/Undefined symbols 0/, 'there are no undefined values in the symbol table');
 139 }
 140
 141 SKIP: {
 142     if ( $Config{usethreads} ) {
 143         skip('This perl has threads, skipping non-threaded debugger tests');
 144     } else {
 145         my $error = 'This Perl not built to support threads';
 146         my $output = runperl( switches => [ '-dt' ], stderr => 1 );
 147         like($output, qr/$error/, 'Perl debugger correctly complains that it was not built with threads');
 148     }
 149
 150 }
 151 SKIP: {
 152     if ( $Config{usethreads} ) {
 153         local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
 154         my $output = runperl(switches => [ '-dt' ], progfile => '../lib/perl5db/t/symbol-table-bug');
 155         like($output, qr/Undefined symbols 0/, 'there are no undefined values in the symbol table when running with thread support');
 156     } else {
 157         skip("This perl is not threaded, skipping threaded debugger tests");
 158     }
 159 }
 160
 161
 162 # Test [perl #61222]
 163 {
 164     rc(
 165         <<'EOF',
 166         &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 167
 168         sub afterinit {
 169             push(@DB::typeahead,
 170                 'm Pie',
 171                 'q',
 172             );
 173         }
 174 EOF
 175     );
 176
 177     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-61222');
 178     unlike(_out_contents(), qr/INCORRECT/, "[perl #61222]");
 179 }
 180
 181
 182
 183 # Test for Proxy constants
 184 {
 185     rc(
 186         <<'EOF',
 187
 188 &parse_options("NonStop=0 ReadLine=0 TTY=db.out LineInfo=db.out");
 189
 190 sub afterinit {
 191     push(@DB::typeahead,
 192         'm main->s1',
 193         'q',
 194     );
 195 }
 196
 197 EOF
 198     );
 199
 200     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants');
 201     is($output, "", "proxy constant subroutines");
 202 }
 203
 204 # Testing that we can set a line in the middle of the file.
 205 {
 206     rc(<<'EOF');
 207 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 208
 209 sub afterinit {
 210     push (@DB::typeahead,
 211     'b ../lib/perl5db/t/MyModule.pm:12',
 212     'c',
 213     q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
 214     'c',
 215     'q',
 216     );
 217
 218 }
 219 EOF
 220
 221     my $output = runperl(switches => [ '-d', '-I', '../lib/perl5db/t', ], stderr => 1, progfile => '../lib/perl5db/t/filename-line-breakpoint');
 222
 223     like($output, qr/
 224         ^Var=Bar$
 225             .*
 226         ^In\ MyModule\.$
 227             .*
 228         ^In\ Main\ File\.$
 229             .*
 230         /msx,
 231         "Can set breakpoint in a line in the middle of the file.");
 232 }
 233
 234
 235 # [perl #66110] Call a subroutine inside a regex
 236 {
 237     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
 238     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
 239     like($output, "All tests successful.", "[perl #66110]");
 240 }
 241
 242 # [perl 104168] level option for tracing
 243 {
 244     rc(<<'EOF');
 245 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 246
 247 sub afterinit {
 248     push (@DB::typeahead,
 249     't 2',
 250     'c',
 251     'q',
 252     );
 253
 254 }
 255 EOF
 256
 257     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-104168');
 258     my $contents;
 259     {
 260         local $/;
 261         open I, "<", 'db.out' or die $!;
 262         $contents = <I>;
 263         close(I);
 264     }
 265     like($contents, qr/level 2/, "[perl #104168]");
 266     unlike($contents, qr/baz/, "[perl #104168]");
 267 }
 268
 269 # taint tests
 270
 271 {
 272     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
 273     my $output = runperl(switches => [ '-d', '-T' ], stderr => 1,
 274         progfile => '../lib/perl5db/t/taint');
 275     chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
 276     is($output, '[$^X][done]', "taint");
 277 }
 278
 279 # Testing that we can set a breakpoint
 280 {
 281     rc(<<'EOF');
 282 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 283
 284 sub afterinit {
 285     push (@DB::typeahead,
 286     'b 6',
 287     'c',
 288     q/do { use IO::Handle; STDOUT->autoflush(1); print "X={$x}\n"; }/,
 289     'c',
 290     'q',
 291     );
 292
 293 }
 294 EOF
 295
 296     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/breakpoint-bug');
 297
 298     like($output, qr/
 299         X=\{Two\}
 300         /msx,
 301         "Can set breakpoint in a line.");
 302 }
 303
 304
 305 # Testing that we can disable a breakpoint at a numeric line.
 306 {
 307     rc(<<'EOF');
 308 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 309
 310 sub afterinit {
 311     push (@DB::typeahead,
 312     'b 7',
 313     'b 11',
 314     'disable 7',
 315     'c',
 316     q/print "X={$x}\n";/,
 317     'c',
 318     'q',
 319     );
 320
 321 }
 322 EOF
 323
 324     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-1'); +
 325     like($output, qr/
 326         X=\{SecondVal\}
 327         /msx,
 328         "Can set breakpoint in a line.");
 329 }
 330
 331 # Testing that we can re-enable a breakpoint at a numeric line.
 332 {
 333     rc(<<'EOF');
 334 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 335
 336 sub afterinit {
 337     push (@DB::typeahead,
 338     'b 8',
 339     'b 24',
 340     'disable 24',
 341     'c',
 342     'enable 24',
 343     'c',
 344     q/print "X={$x}\n";/,
 345     'c',
 346     'q',
 347     );
 348
 349 }
 350 EOF
 351
 352     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-2');
 353     like($output, qr/
 354         X=\{SecondValOneHundred\}
 355         /msx,
 356         "Can set breakpoint in a line.");
 357 }
 358 # clean up.
 359
 360 # Disable and enable for breakpoints on outer files.
 361 {
 362     rc(<<'EOF');
 363 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 364
 365 sub afterinit {
 366     push (@DB::typeahead,
 367     'b 10',
 368     'b ../lib/perl5db/t/EnableModule.pm:14',
 369     'disable ../lib/perl5db/t/EnableModule.pm:14',
 370     'c',
 371     'enable ../lib/perl5db/t/EnableModule.pm:14',
 372     'c',
 373     q/print "X={$x}\n";/,
 374     'c',
 375     'q',
 376     );
 377
 378 }
 379 EOF
 380
 381     my $output = runperl(switches => [ '-d', '-I', '../lib/perl5db/t', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-3'); +
 382     like($output, qr/
 383         X=\{SecondValTwoHundred\}
 384         /msx,
 385         "Can set breakpoint in a line.");
 386 }
 387
 388 # Testing that the prompt with the information appears.
 389 {
 390     rc(<<'EOF');
 391 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 392
 393 sub afterinit {
 394     push (@DB::typeahead,
 395     'q',
 396     );
 397
 398 }
 399 EOF
 400
 401     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-1');
 402
 403     like(_out_contents(), qr/
 404         ^main::\([^\)]*\bdisable-breakpoints-1:2\):\n
 405         2:\s+my\ \$x\ =\ "One";\n
 406         /msx,
 407         "Prompt should display the first line of code.");
 408 }
 409
 410 # Testing that R (restart) and "B *" work.
 411 {
 412     rc(<<'EOF');
 413 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 414
 415 sub afterinit {
 416     push (@DB::typeahead,
 417     'b 13',
 418     'c',
 419     'B *',
 420     'b 9',
 421     'R',
 422     'c',
 423     q/print "X={$x};dummy={$dummy}\n";/,
 424     'q',
 425     );
 426
 427 }
 428 EOF
 429
 430     my $output = runperl(switches => [ '-d', ], stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-1');
 431     like($output, qr/
 432         X=\{FirstVal\};dummy=\{1\}
 433         /msx,
 434         "Restart and delete all breakpoints work properly.");
 435 }
 436
 437 END {
 438     1 while unlink ($rc_filename, $out_fn);
 439 }