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 delete $ENV{PERLDB_OPTS};
  14
  15 BEGIN {
  16     if (! -c "/dev/null") {
  17         print "1..0 # Skip: no /dev/null\n";
  18         exit 0;
  19     }
  20
  21     my $dev_tty = '/dev/tty';
  22     $dev_tty = 'TT:' if ($^O eq 'VMS');
  23     if (! -c $dev_tty) {
  24         print "1..0 # Skip: no $dev_tty\n";
  25         exit 0;
  26     }
  27     if ($ENV{PERL5DB}) {
  28         print "1..0 # Skip: \$ENV{PERL5DB} is already set to '$ENV{PERL5DB}'\n";
  29         exit 0;
  30     }
  31     $ENV{PERL_RL} = 'Perl'; # Suppress system Term::ReadLine::Gnu
  32 }
  33
  34 my $rc_filename = '.perldb';
  35
  36 sub rc {
  37     open my $rc_fh, '>', $rc_filename
  38         or die $!;
  39     print {$rc_fh} @_;
  40     close ($rc_fh);
  41
  42     # overly permissive perms gives "Must not source insecure rcfile"
  43     # and hangs at the DB(1> prompt
  44     chmod 0644, $rc_filename;
  45 }
  46
  47 sub _slurp
  48 {
  49     my $filename = shift;
  50
  51     open my $in, '<', $filename
  52         or die "Cannot open '$filename' for slurping - $!";
  53
  54     local $/;
  55     my $contents = <$in>;
  56
  57     close($in);
  58
  59     return $contents;
  60 }
  61
  62 my $out_fn = 'db.out';
  63
  64 sub _out_contents
  65 {
  66     return _slurp($out_fn);
  67 }
  68
  69
  70 # Test for Proxy constants
  71 {
  72     rc(
  73         <<'EOF',
  74
  75 &parse_options("NonStop=0 ReadLine=0 TTY=db.out");
  76
  77 sub afterinit {
  78     push(@DB::typeahead,
  79         'm main->s1',
  80         'q',
  81     );
  82 }
  83
  84 EOF
  85     );
  86
  87     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants');
  88     is($output, "", "proxy constant subroutines");
  89 }
  90
  91 # [perl #66110] Call a subroutine inside a regex
  92 {
  93     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
  94     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
  95     like($output, qr/\bAll tests successful\.$/, "[perl #66110]");
  96 }
  97 # [ perl #116769] Frame=2
  98 {
  99     local $ENV{PERLDB_OPTS} = "frame=2 nonstop";
 100     my $output = runperl( switches => [ '-d' ], prog => 'print qq{success\n}' );
 101     is( $?, 0, '[perl #116769] frame=2 does not crash debugger, exit == 0' );
 102     is( $output, "success\n" , '[perl #116769] code is run' );
 103 }
 104 # [ perl #116771] autotrace
 105 {
 106     local $ENV{PERLDB_OPTS} = "autotrace nonstop";
 107     my $output = runperl( switches => [ '-d' ], prog => 'print qq{success\n}' );
 108     is( $?, 0, '[perl #116771] autotrace does not crash debugger, exit == 0' );
 109     is( $output, "success\n" , '[perl #116771] code is run' );
 110 }
 111 # [ perl #41461] Frame=2 noTTY
 112 {
 113     local $ENV{PERLDB_OPTS} = "frame=2 noTTY nonstop";
 114     rc('');
 115     my $output = runperl( switches => [ '-d' ], prog => 'print qq{success\n}' );
 116     is( $?, 0, '[perl #41461] frame=2 noTTY does not crash debugger, exit == 0' );
 117     is( $output, "success\n" , '[perl #41461] code is run' );
 118 }
 119
 120 package DebugWrap;
 121
 122 sub new {
 123     my $class = shift;
 124
 125     my $self = bless {}, $class;
 126
 127     $self->_init(@_);
 128
 129     return $self;
 130 }
 131
 132 sub _cmds {
 133     my $self = shift;
 134
 135     if (@_) {
 136         $self->{_cmds} = shift;
 137     }
 138
 139     return $self->{_cmds};
 140 }
 141
 142 sub _prog {
 143     my $self = shift;
 144
 145     if (@_) {
 146         $self->{_prog} = shift;
 147     }
 148
 149     return $self->{_prog};
 150 }
 151
 152 sub _output {
 153     my $self = shift;
 154
 155     if (@_) {
 156         $self->{_output} = shift;
 157     }
 158
 159     return $self->{_output};
 160 }
 161
 162 sub _include_t
 163 {
 164     my $self = shift;
 165
 166     if (@_)
 167     {
 168         $self->{_include_t} = shift;
 169     }
 170
 171     return $self->{_include_t};
 172 }
 173
 174 sub _stderr_val
 175 {
 176     my $self = shift;
 177
 178     if (@_)
 179     {
 180         $self->{_stderr_val} = shift;
 181     }
 182
 183     return $self->{_stderr_val};
 184 }
 185
 186 sub field
 187 {
 188     my $self = shift;
 189
 190     if (@_)
 191     {
 192         $self->{field} = shift;
 193     }
 194
 195     return $self->{field};
 196 }
 197
 198 sub _switches
 199 {
 200     my $self = shift;
 201
 202     if (@_)
 203     {
 204         $self->{_switches} = shift;
 205     }
 206
 207     return $self->{_switches};
 208 }
 209
 210 sub _contents
 211 {
 212     my $self = shift;
 213
 214     if (@_)
 215     {
 216         $self->{_contents} = shift;
 217     }
 218
 219     return $self->{_contents};
 220 }
 221
 222 # object for prog temporary file
 223 sub _tempprog
 224 {
 225     my $self = shift;
 226
 227     if (@_)
 228     {
 229         $self->{_tempprog} = shift;
 230     }
 231
 232     return $self->{_tempprog};
 233 }
 234
 235 sub _init
 236 {
 237     my ($self, $args) = @_;
 238
 239     my $cmds = $args->{cmds};
 240
 241     if (ref($cmds) ne 'ARRAY') {
 242         die "cmds must be an array of commands.";
 243     }
 244
 245     $self->_cmds($cmds);
 246
 247     my $prog = $args->{prog};
 248
 249     if (ref($prog) eq 'SCALAR') {
 250         use File::Temp;
 251         my $fh = File::Temp->new;
 252         $self->_tempprog($fh);
 253         print $fh $$prog;
 254         $prog = $fh->filename;
 255     }
 256     elsif (ref($prog) ne '' or !defined($prog)) {
 257         die "prog should be a path to a program file.";
 258     }
 259
 260     $self->_prog($prog);
 261
 262     $self->_include_t($args->{include_t} ? 1 : 0);
 263
 264     $self->_stderr_val(exists($args->{stderr}) ? $args->{stderr} : 1);
 265
 266     if (exists($args->{switches}))
 267     {
 268         $self->_switches($args->{switches});
 269     }
 270
 271     $self->_run();
 272
 273     return;
 274 }
 275
 276 sub _quote
 277 {
 278     my ($self, $str) = @_;
 279
 280     $str =~ s/(["\@\$\\])/\\$1/g;
 281     $str =~ s/\n/\\n/g;
 282     $str =~ s/\r/\\r/g;
 283
 284     return qq{"$str"};
 285 }
 286
 287 sub _run {
 288     my $self = shift;
 289
 290     my $rc = qq{&parse_options("NonStop=0 TTY=db.out");\n};
 291
 292     $rc .= join('',
 293         map { "$_\n"}
 294         (q#sub afterinit {#,
 295          q#push (@DB::typeahead,#,
 296          (map { $self->_quote($_) . "," } @{$self->_cmds()}),
 297          q#);#,
 298          q#}#,
 299         )
 300     );
 301
 302     # I guess two objects like that cannot be used at the same time.
 303     # Oh well.
 304     ::rc($rc);
 305
 306     my $output =
 307         ::runperl(
 308             switches =>
 309             [
 310                 ($self->_switches ? (@{$self->_switches()}) : ('-d')),
 311                 ($self->_include_t ? ('-I', '../lib/perl5db/t') : ())
 312             ],
 313             (defined($self->_stderr_val())
 314                 ? (stderr => $self->_stderr_val())
 315                 : ()
 316             ),
 317             progfile => $self->_prog()
 318         );
 319
 320     $self->_output($output);
 321
 322     $self->_contents(::_out_contents());
 323
 324     return;
 325 }
 326
 327 sub get_output
 328 {
 329     return shift->_output();
 330 }
 331
 332 sub output_like {
 333     my ($self, $re, $msg) = @_;
 334
 335     local $::Level = $::Level + 1;
 336     ::like($self->_output(), $re, $msg);
 337 }
 338
 339 sub output_unlike {
 340     my ($self, $re, $msg) = @_;
 341
 342     local $::Level = $::Level + 1;
 343     ::unlike($self->_output(), $re, $msg);
 344 }
 345
 346 sub get_contents {
 347     return shift->_contents();
 348 }
 349
 350 sub contents_like {
 351     my ($self, $re, $msg) = @_;
 352
 353     local $::Level = $::Level + 1;
 354     ::like($self->_contents(), $re, $msg);
 355 }
 356
 357 sub contents_unlike {
 358     my ($self, $re, $msg) = @_;
 359
 360     local $::Level = $::Level + 1;
 361     ::unlike($self->_contents(), $re, $msg);
 362 }
 363
 364 =head1 NAME
 365
 366 DebugWrap - wrapper to execute code under the debugger and examine the
 367 results.
 368
 369 =head1 SYNOPSIS
 370
 371     my $wrapper = DebugWrap->new(
 372         {
 373             cmds =>
 374             [
 375                 # list of commands supplied to the debugger
 376             ],
 377             prog => 'filename_of_code_to_debug.pl',
 378             # and some optional arguments
 379         }
 380     );
 381
 382     my $wrapper = DebugWrap->new(
 383         {
 384             cmds =>
 385             [
 386                 # list of commands supplied to the debugger
 387             ],
 388             prog => \<<'EOS',
 389     # perl code to debug
 390     EOS
 391             # and some optional arguments
 392         }
 393     );
 394
 395     # test the output from the program being debugged
 396     $wrapper->output_like(qr/.../, "describe the test");
 397     $wrapper->output_unlike(qr/.../, "describe the test");
 398     my $output = $wrapper->get_output; # for more sophisticated checks
 399
 400     # test the output from the debugger
 401     $wrapper->contents_like(qr/.../, "describe the test");
 402     $wrapper->contents_unlike(qr/.../, "describe the test");
 403     my $contents = $wrapper->get_contents; # for more sophisticated checks
 404
 405 =head1 DESCRIPTION
 406
 407 DebugWrap is a simple class that executes a set of debugger commands
 408 against a program under the debugger and provides some simple methods
 409 to examine the results.
 410
 411 =head2 Creating a DebugWrap object
 412
 413 The constructor new() accepts a hash of arguments, with the following
 414 possible members:
 415
 416 =over
 417
 418 =item cmds
 419
 420 An array of commands to execute, one command per element.  Required.
 421
 422 =item prog
 423
 424 Either the name of a perl program to test under the debugger, or a
 425 reference to a scalar containing the text of the program to test.
 426 Required.
 427
 428 =item stderr
 429
 430 If this is a true value capture standard error, which is the default.
 431 Optional.
 432
 433 =item include_t
 434
 435 Add F<lib/perl5db/t> to the perl search path, as with C<-I>
 436
 437 =item switches
 438
 439 An arrayref of switches to supply to perl.  This should include the
 440 C<-d> switch needed to invoke the debugger.  If C<switches> is not
 441 supplied then C<-d> only is supplied.  The C<-I> for C<include_t> is
 442 added after these switches.
 443
 444 =back
 445
 446 =head2 Other methods
 447
 448 The other methods intended for test usage are:
 449
 450 =over
 451
 452 =item $wrapper->get_contents
 453
 454 Fetch the debugger output from the debugger run.  This does not
 455 include the output from the program under test.
 456
 457 =item $wrapper->contents_like($re, $test_name)
 458
 459 Test that the debugger output matches the given regular expression
 460 object (as with qr//).
 461
 462 Equivelent to:
 463
 464   like($wrapper->get_contents, $re, $test_name);
 465
 466 =item $wrapper->contents_unlike($re, $test_name)
 467
 468 Test that the debugger output does not match the given regular
 469 expression object (as with qr//).
 470
 471 Equivelent to:
 472
 473   unlike($wrapper->get_contents, $re, $test_name);
 474
 475 =item $wrapper->get_output
 476
 477 Fetch the program output from the debugger run.  This does not include
 478 the output from the debugger itself, it does include the output
 479 generated by C<valgrind> or ASAN, assuming you haven't disabled
 480 capturing stderr.
 481
 482 =item $wrapper->output_like($re, $test_name);
 483
 484 Test that the program output matches the given regular expression
 485 object (as with qr//).
 486
 487 Equivelent to:
 488
 489   like($wrapper->get_output, $re, $test_name);
 490
 491 =item $wrapper->output_unlike($re, $test_name);
 492
 493 Test that the program output does not match the given regular
 494 expression object (as with qr//).
 495
 496 Equivelent to:
 497
 498   unlike($wrapper->get_output, $re, $test_name);
 499
 500 =back
 501
 502 =cut
 503
 504 package main;
 505
 506 {
 507     local $ENV{PERLDB_OPTS} = "ReadLine=0";
 508     my $target = '../lib/perl5db/t/eval-line-bug';
 509     my $wrapper = DebugWrap->new(
 510         {
 511             cmds =>
 512             [
 513                 'b 23',
 514                 'n',
 515                 'n',
 516                 'n',
 517                 'c', # line 23
 518                 'n',
 519                 "p \@{'main::_<$target'}",
 520                 'q',
 521             ],
 522             prog => $target,
 523         }
 524     );
 525     $wrapper->contents_like(
 526         qr/sub factorial/,
 527         'The ${main::_<filename} variable in the debugger was not destroyed',
 528     );
 529 }
 530
 531 sub _calc_generic_wrapper
 532 {
 533     my $args = shift;
 534
 535     my $extra_opts = delete($args->{extra_opts});
 536     $extra_opts ||= '';
 537     local $ENV{PERLDB_OPTS} = "ReadLine=0" . $extra_opts;
 538     return DebugWrap->new(
 539         {
 540             cmds => delete($args->{cmds}),
 541             prog => delete($args->{prog}),
 542             %$args,
 543         }
 544     );
 545 }
 546
 547 sub _calc_new_var_wrapper
 548 {
 549     my ($args) = @_;
 550     return _calc_generic_wrapper(
 551         {
 552             cmds =>
 553             [
 554                 'b 23',
 555                 'c',
 556                 '$new_var = "Foo"',
 557                 'x "new_var = <$new_var>\\n"',
 558                 'q',
 559             ],
 560             %$args,
 561         }
 562     );
 563 }
 564
 565 sub _calc_threads_wrapper
 566 {
 567     my $args = shift;
 568
 569     return _calc_new_var_wrapper(
 570         {
 571             switches => [ '-dt', ],
 572             stderr => 1,
 573             %$args
 574         }
 575     );
 576 }
 577
 578 {
 579     _calc_new_var_wrapper({ prog => '../lib/perl5db/t/eval-line-bug'})
 580         ->contents_like(
 581             qr/new_var = <Foo>/,
 582             "no strict 'vars' in evaluated lines.",
 583         );
 584 }
 585
 586 {
 587     _calc_new_var_wrapper(
 588         {
 589             prog => '../lib/perl5db/t/lvalue-bug',
 590             stderr => undef(),
 591         },
 592     )->output_like(
 593             qr/foo is defined/,
 594              'lvalue subs work in the debugger',
 595          );
 596 }
 597
 598 {
 599     _calc_new_var_wrapper(
 600         {
 601             prog =>  '../lib/perl5db/t/symbol-table-bug',
 602             extra_opts => "NonStop=1",
 603             stderr => undef(),
 604         }
 605     )->output_like(
 606         qr/Undefined symbols 0/,
 607         'there are no undefined values in the symbol table',
 608     );
 609 }
 610
 611 SKIP:
 612 {
 613     if ( $Config{usethreads} ) {
 614         skip('This perl has threads, skipping non-threaded debugger tests');
 615     }
 616     else {
 617         my $error = 'This Perl not built to support threads';
 618         _calc_threads_wrapper(
 619             {
 620                 prog => '../lib/perl5db/t/eval-line-bug',
 621             }
 622         )->output_like(
 623             qr/\Q$error\E/,
 624             'Perl debugger correctly complains that it was not built with threads',
 625         );
 626     }
 627 }
 628
 629 SKIP:
 630 {
 631     if ( $Config{usethreads} ) {
 632         _calc_threads_wrapper(
 633             {
 634                 prog =>  '../lib/perl5db/t/symbol-table-bug',
 635             }
 636         )->output_like(
 637             qr/Undefined symbols 0/,
 638             'there are no undefined values in the symbol table when running with thread support',
 639         );
 640     }
 641     else {
 642         skip("This perl is not threaded, skipping threaded debugger tests");
 643     }
 644 }
 645
 646 # Test [perl #61222]
 647 {
 648     local $ENV{PERLDB_OPTS};
 649     my $wrapper = DebugWrap->new(
 650         {
 651             cmds =>
 652             [
 653                 'm Pie',
 654                 'q',
 655             ],
 656             prog => '../lib/perl5db/t/rt-61222',
 657         }
 658     );
 659
 660     $wrapper->contents_unlike(qr/INCORRECT/, "[perl #61222]");
 661 }
 662
 663 sub _calc_trace_wrapper
 664 {
 665     my ($args) = @_;
 666
 667     return _calc_generic_wrapper(
 668         {
 669             cmds =>
 670             [
 671                 't 2',
 672                 'c',
 673                 'q',
 674             ],
 675             %$args,
 676         }
 677     );
 678 }
 679
 680 # [perl 104168] level option for tracing
 681 {
 682     my $wrapper = _calc_trace_wrapper({ prog =>  '../lib/perl5db/t/rt-104168' });
 683     $wrapper->contents_like(qr/level 2/, "[perl #104168] - level 2 appears");
 684     $wrapper->contents_unlike(qr/baz/, "[perl #104168] - no 'baz'");
 685 }
 686
 687 # taint tests
 688 if (!exists($Config{taint_support}) || $Config{taint_support})
 689 {
 690     my $wrapper = _calc_trace_wrapper(
 691         {
 692             prog => '../lib/perl5db/t/taint',
 693             extra_opts => ' NonStop=1',
 694             switches => [ '-d', '-T', ],
 695         }
 696     );
 697
 698     my $output = $wrapper->get_output();
 699     chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
 700     is($output, '[$^X][done]', "taint");
 701 }
 702
 703 # Testing that we can set a line in the middle of the file.
 704 {
 705     my $wrapper = DebugWrap->new(
 706         {
 707             cmds =>
 708             [
 709                 'b ../lib/perl5db/t/MyModule.pm:12',
 710                 'c',
 711                 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
 712                 'c',
 713                 'q',
 714             ],
 715             include_t => 1,
 716             prog => '../lib/perl5db/t/filename-line-breakpoint'
 717         }
 718     );
 719
 720     $wrapper->output_like(qr/
 721         ^Var=Bar$
 722             .*
 723         ^In\ MyModule\.$
 724             .*
 725         ^In\ Main\ File\.$
 726             .*
 727         /msx,
 728         "Can set breakpoint in a line in the middle of the file.");
 729 }
 730
 731 # Testing that we can set a breakpoint
 732 {
 733     my $wrapper = DebugWrap->new(
 734         {
 735             prog => '../lib/perl5db/t/breakpoint-bug',
 736             cmds =>
 737             [
 738                 'b 6',
 739                 'c',
 740                 q/do { use IO::Handle; STDOUT->autoflush(1); print "X={$x}\n"; }/,
 741                 'c',
 742                 'q',
 743             ],
 744         },
 745     );
 746
 747     $wrapper->output_like(
 748         qr/X=\{Two\}/msx,
 749         "Can set breakpoint in a line."
 750     );
 751 }
 752
 753 # Testing that we can disable a breakpoint at a numeric line.
 754 {
 755     my $wrapper = DebugWrap->new(
 756         {
 757             prog =>  '../lib/perl5db/t/disable-breakpoints-1',
 758             cmds =>
 759             [
 760                 'b 7',
 761                 'b 11',
 762                 'disable 7',
 763                 'c',
 764                 q/print "X={$x}\n";/,
 765                 'c',
 766                 'q',
 767             ],
 768         }
 769     );
 770
 771     $wrapper->output_like(qr/X=\{SecondVal\}/ms,
 772         "Can set breakpoint in a line.");
 773 }
 774
 775 # Testing that we can re-enable a breakpoint at a numeric line.
 776 {
 777     my $wrapper = DebugWrap->new(
 778         {
 779             prog =>  '../lib/perl5db/t/disable-breakpoints-2',
 780             cmds =>
 781             [
 782                 'b 8',
 783                 'b 24',
 784                 'disable 24',
 785                 'c',
 786                 'enable 24',
 787                 'c',
 788                 q/print "X={$x}\n";/,
 789                 'c',
 790                 'q',
 791             ],
 792         },
 793     );
 794
 795     $wrapper->output_like(
 796         qr/
 797         X=\{SecondValOneHundred\}
 798         /msx,
 799         "Can set breakpoint in a line."
 800     );
 801 }
 802 # clean up.
 803
 804 # Disable and enable for breakpoints on outer files.
 805 {
 806     my $wrapper = DebugWrap->new(
 807         {
 808             cmds =>
 809             [
 810                 'b 10',
 811                 'b ../lib/perl5db/t/EnableModule.pm:14',
 812                 'disable ../lib/perl5db/t/EnableModule.pm:14',
 813                 'c',
 814                 'enable ../lib/perl5db/t/EnableModule.pm:14',
 815                 'c',
 816                 q/print "X={$x}\n";/,
 817                 'c',
 818                 'q',
 819             ],
 820             prog =>  '../lib/perl5db/t/disable-breakpoints-3',
 821             include_t => 1,
 822         }
 823     );
 824
 825     $wrapper->output_like(qr/
 826         X=\{SecondValTwoHundred\}
 827         /msx,
 828         "Can set breakpoint in a line.");
 829 }
 830
 831 # Testing that the prompt with the information appears.
 832 {
 833     my $wrapper = DebugWrap->new(
 834         {
 835             cmds => ['q'],
 836             prog => '../lib/perl5db/t/disable-breakpoints-1',
 837         }
 838     );
 839
 840     $wrapper->contents_like(qr/
 841         ^main::\([^\)]*\bdisable-breakpoints-1:2\):\n
 842         2:\s+my\ \$x\ =\ "One";\n
 843         /msx,
 844         "Prompt should display the first line of code.");
 845 }
 846
 847 # Testing that R (restart) and "B *" work.
 848 {
 849     my $wrapper = DebugWrap->new(
 850         {
 851             cmds =>
 852             [
 853                 'b 13',
 854                 'c',
 855                 'B *',
 856                 'b 9',
 857                 'R',
 858                 'c',
 859                 q/print "X={$x};dummy={$dummy}\n";/,
 860                 'q',
 861             ],
 862             prog =>  '../lib/perl5db/t/disable-breakpoints-1',
 863         }
 864     );
 865
 866     $wrapper->output_like(qr/
 867         X=\{FirstVal\};dummy=\{1\}
 868         /msx,
 869         "Restart and delete all breakpoints work properly.");
 870 }
 871
 872 {
 873     my $wrapper = DebugWrap->new(
 874         {
 875             cmds =>
 876             [
 877                 'c 15',
 878                 q/print "X={$x}\n";/,
 879                 'c',
 880                 'q',
 881             ],
 882             prog =>  '../lib/perl5db/t/disable-breakpoints-1',
 883         }
 884     );
 885
 886     $wrapper->output_like(qr/
 887         X=\{ThirdVal\}
 888         /msx,
 889         "'c line_num' is working properly.");
 890 }
 891
 892 {
 893     my $wrapper = DebugWrap->new(
 894         {
 895             cmds =>
 896             [
 897                 'n',
 898                 'n',
 899                 'b . $exp > 200',
 900                 'c',
 901                 q/print "Exp={$exp}\n";/,
 902                 'q',
 903             ],
 904             prog => '../lib/perl5db/t/break-on-dot',
 905         }
 906     );
 907
 908     $wrapper->output_like(qr/
 909         Exp=\{256\}
 910         /msx,
 911         "'b .' is working correctly.");
 912 }
 913
 914 # Testing that the prompt with the information appears inside a subroutine call.
 915 # See https://rt.perl.org/rt3/Ticket/Display.html?id=104820
 916 {
 917     my $wrapper = DebugWrap->new(
 918         {
 919             cmds =>
 920             [
 921                 'c back',
 922                 'q',
 923             ],
 924             prog => '../lib/perl5db/t/with-subroutine',
 925         }
 926     );
 927
 928     $wrapper->contents_like(
 929         qr/
 930         ^main::back\([^\)\n]*\bwith-subroutine:15\):[\ \t]*\n
 931         ^15:\s*print\ "hello\ back\\n";
 932         /msx,
 933         "Prompt should display the line of code inside a subroutine.");
 934 }
 935
 936 # Checking that the p command works.
 937 {
 938     my $wrapper = DebugWrap->new(
 939         {
 940             cmds =>
 941             [
 942                 'p "<<<" . (4*6) . ">>>"',
 943                 'q',
 944             ],
 945             prog => '../lib/perl5db/t/with-subroutine',
 946         }
 947     );
 948
 949     $wrapper->contents_like(
 950         qr/<<<24>>>/,
 951         "p command works.");
 952 }
 953
 954 # Tests for x.
 955 {
 956     my $wrapper = DebugWrap->new(
 957         {
 958             cmds =>
 959             [
 960                 q/x {500 => 600}/,
 961                 'q',
 962             ],
 963             prog => '../lib/perl5db/t/with-subroutine',
 964         }
 965     );
 966
 967     $wrapper->contents_like(
 968         # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
 969         qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/ms,
 970         "x command test."
 971     );
 972 }
 973
 974 # Tests for x with @_
 975 {
 976     my $wrapper = DebugWrap->new(
 977         {
 978             cmds =>
 979             [
 980                 'b 10',
 981                 'c',
 982                 'x @_',
 983                 'q',
 984             ],
 985             prog => '../lib/perl5db/t/test-passing-at-underscore-to-x-etc',
 986         }
 987     );
 988
 989     $wrapper->contents_like(
 990         # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
 991         qr/Arg1.*?Capsula.*GreekHumor.*Socrates/ms,
 992         q/x command test with '@_'./,
 993     );
 994 }
 995
 996 # Tests for mutating @_
 997 {
 998     my $wrapper = DebugWrap->new(
 999         {
1000             cmds =>
1001             [
1002                 'b 10',
1003                 'c',
1004                 'shift(@_)',
1005                 'print "\n\n\n(((" . join(",", @_) . ")))\n\n\n"',
1006                 'q',
1007             ],
1008             prog => '../lib/perl5db/t/test-passing-at-underscore-to-x-etc',
1009         }
1010     );
1011
1012     $wrapper->output_like(
1013         qr/^\(\(\(Capsula,GreekHumor,Socrates\)\)\)$/ms,
1014         q/Mutating '@_'./,
1015     );
1016 }
1017
1018 # Tests for x with AutoTrace=1.
1019 {
1020     my $wrapper = DebugWrap->new(
1021         {
1022             cmds =>
1023             [
1024                 'n',
1025                 'o AutoTrace=1',
1026                 # So it may fail.
1027                 q/x "failure"/,
1028                 q/x \$x/,
1029                 'q',
1030             ],
1031             prog => '../lib/perl5db/t/with-subroutine',
1032         }
1033     );
1034
1035     $wrapper->contents_like(
1036         # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
1037         qr/^0\s+SCALAR\([^\)]+\)\n\s+-> 'hello world'\n/ms,
1038         "x after AutoTrace=1 command is working."
1039     );
1040 }
1041
1042 # Tests for "T" (stack trace).
1043 {
1044     my $prog_fn = '../lib/perl5db/t/rt-104168';
1045     my $wrapper = DebugWrap->new(
1046         {
1047             prog => $prog_fn,
1048             cmds =>
1049             [
1050                 'c baz',
1051                 'T',
1052                 'q',
1053             ],
1054         }
1055     );
1056     my $re_text = join('',
1057         map {
1058         sprintf(
1059             "%s = %s\\(\\) called from file " .
1060             "'" . quotemeta($prog_fn) . "' line %s\\n",
1061             (map { quotemeta($_) } @$_)
1062             )
1063         }
1064         (
1065             ['.', 'main::baz', 14,],
1066             ['.', 'main::bar', 9,],
1067             ['.', 'main::foo', 6],
1068         )
1069     );
1070     $wrapper->contents_like(
1071         # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
1072         qr/^$re_text/ms,
1073         "T command test."
1074     );
1075 }
1076
1077 # Test for s.
1078 {
1079     my $wrapper = DebugWrap->new(
1080         {
1081             cmds =>
1082             [
1083                 'b 9',
1084                 'c',
1085                 's',
1086                 q/print "X={$x};dummy={$dummy}\n";/,
1087                 'q',
1088             ],
1089             prog => '../lib/perl5db/t/disable-breakpoints-1'
1090         }
1091     );
1092
1093     $wrapper->output_like(qr/
1094         X=\{SecondVal\};dummy=\{1\}
1095         /msx,
1096         'test for s - single step',
1097     );
1098 }
1099
1100 {
1101     my $wrapper = DebugWrap->new(
1102         {
1103             cmds =>
1104             [
1105                 'n',
1106                 'n',
1107                 'b . $exp > 200',
1108                 'c',
1109                 q/print "Exp={$exp}\n";/,
1110                 'q',
1111             ],
1112             prog => '../lib/perl5db/t/break-on-dot'
1113         }
1114     );
1115
1116     $wrapper->output_like(qr/
1117         Exp=\{256\}
1118         /msx,
1119         "'b .' is working correctly.");
1120 }
1121
1122 {
1123     my $prog_fn = '../lib/perl5db/t/rt-104168';
1124     my $wrapper = DebugWrap->new(
1125         {
1126             cmds =>
1127             [
1128                 's',
1129                 'q',
1130             ],
1131             prog => $prog_fn,
1132         }
1133     );
1134
1135     $wrapper->contents_like(
1136         qr/
1137         ^main::foo\([^\)\n]*\brt-104168:9\):[\ \t]*\n
1138         ^9:\s*bar\(\);
1139         /msx,
1140         'Test for the s command.',
1141     );
1142 }
1143
1144 {
1145     my $wrapper = DebugWrap->new(
1146         {
1147             cmds =>
1148             [
1149                 's uncalled_subroutine()',
1150                 'c',
1151                 'q',
1152             ],
1153
1154             prog => '../lib/perl5db/t/uncalled-subroutine'}
1155     );
1156
1157     $wrapper->output_like(
1158         qr/<1,2,3,4,5>\n/,
1159         'uncalled_subroutine was called after s EXPR()',
1160         );
1161 }
1162
1163 {
1164     my $wrapper = DebugWrap->new(
1165         {
1166             cmds =>
1167             [
1168                 'n uncalled_subroutine()',
1169                 'c',
1170                 'q',
1171             ],
1172             prog => '../lib/perl5db/t/uncalled-subroutine',
1173         }
1174     );
1175
1176     $wrapper->output_like(
1177         qr/<1,2,3,4,5>\n/,
1178         'uncalled_subroutine was called after n EXPR()',
1179         );
1180 }
1181
1182 {
1183     my $wrapper = DebugWrap->new(
1184         {
1185             cmds =>
1186             [
1187                 'b fact',
1188                 'c',
1189                 'c',
1190                 'c',
1191                 'n',
1192                 'print "<$n>"',
1193                 'q',
1194             ],
1195             prog => '../lib/perl5db/t/fact',
1196         }
1197     );
1198
1199     $wrapper->output_like(
1200         qr/<3>/,
1201         'b subroutine works fine',
1202     );
1203 }
1204
1205 # Test for n with lvalue subs
1206 DebugWrap->new({
1207     cmds =>
1208     [
1209         'n', 'print "<$x>\n"',
1210         'n', 'print "<$x>\n"',
1211         'q',
1212     ],
1213     prog => '../lib/perl5db/t/lsub-n',
1214 })->output_like(
1215     qr/<1>\n<11>\n/,
1216     'n steps over lvalue subs',
1217 );
1218
1219 # Test for 'M' (module list).
1220 {
1221     my $wrapper = DebugWrap->new(
1222         {
1223             cmds =>
1224             [
1225                 'M',
1226                 'q',
1227             ],
1228             prog => '../lib/perl5db/t/load-modules'
1229         }
1230     );
1231
1232     $wrapper->contents_like(
1233         qr[Scalar/Util\.pm],
1234         'M (module list) works fine',
1235     );
1236 }
1237
1238 {
1239     my $wrapper = DebugWrap->new(
1240         {
1241             cmds =>
1242             [
1243                 'b 14',
1244                 'c',
1245                 '$flag = 1;',
1246                 'r',
1247                 'print "Var=$var\n";',
1248                 'q',
1249             ],
1250             prog => '../lib/perl5db/t/test-r-statement',
1251         }
1252     );
1253
1254     $wrapper->output_like(
1255         qr/
1256             ^Foo$
1257                 .*?
1258             ^Bar$
1259                 .*?
1260             ^Var=Test$
1261         /msx,
1262         'r statement is working properly.',
1263     );
1264 }
1265
1266 {
1267     my $wrapper = DebugWrap->new(
1268         {
1269             cmds =>
1270             [
1271                 'l',
1272                 'q',
1273             ],
1274             prog => '../lib/perl5db/t/test-l-statement-1',
1275         }
1276     );
1277
1278     $wrapper->contents_like(
1279         qr/
1280             ^1==>\s+\$x\ =\ 1;\n
1281             2:\s+print\ "1\\n";\n
1282             3\s*\n
1283             4:\s+\$x\ =\ 2;\n
1284             5:\s+print\ "2\\n";\n
1285         /msx,
1286         'l statement is working properly (test No. 1).',
1287     );
1288 }
1289
1290 {
1291     my $wrapper = DebugWrap->new(
1292         {
1293             cmds =>
1294             [
1295                 'l',
1296                 q/# After l 1/,
1297                 'l',
1298                 q/# After l 2/,
1299                 '-',
1300                 q/# After -/,
1301                 'q',
1302             ],
1303             prog => '../lib/perl5db/t/test-l-statement-1',
1304         }
1305     );
1306
1307     my $first_l_out = qr/
1308         1==>\s+\$x\ =\ 1;\n
1309         2:\s+print\ "1\\n";\n
1310         3\s*\n
1311         4:\s+\$x\ =\ 2;\n
1312         5:\s+print\ "2\\n";\n
1313         6\s*\n
1314         7:\s+\$x\ =\ 3;\n
1315         8:\s+print\ "3\\n";\n
1316         9\s*\n
1317         10:\s+\$x\ =\ 4;\n
1318     /msx;
1319
1320     my $second_l_out = qr/
1321         11:\s+print\ "4\\n";\n
1322         12\s*\n
1323         13:\s+\$x\ =\ 5;\n
1324         14:\s+print\ "5\\n";\n
1325         15\s*\n
1326         16:\s+\$x\ =\ 6;\n
1327         17:\s+print\ "6\\n";\n
1328         18\s*\n
1329         19:\s+\$x\ =\ 7;\n
1330         20:\s+print\ "7\\n";\n
1331     /msx;
1332     $wrapper->contents_like(
1333         qr/
1334             ^$first_l_out
1335             [^\n]*?DB<\d+>\ \#\ After\ l\ 1\n
1336             [\ \t]*\n
1337             [^\n]*?DB<\d+>\ l\s*\n
1338             $second_l_out
1339             [^\n]*?DB<\d+>\ \#\ After\ l\ 2\n
1340             [\ \t]*\n
1341             [^\n]*?DB<\d+>\ -\s*\n
1342             $first_l_out
1343             [^\n]*?DB<\d+>\ \#\ After\ -\n
1344         /msx,
1345         'l followed by l and then followed by -',
1346     );
1347 }
1348
1349 {
1350     my $wrapper = DebugWrap->new(
1351         {
1352             cmds =>
1353             [
1354                 'v',
1355                 'q',
1356             ],
1357             prog => '../lib/perl5db/t/test-l-statement-1',
1358         }
1359        );
1360     $wrapper->contents_like(
1361         qr/
1362           1==>\s+\$x\ =\ 1;\n
1363           2:\s+print\ "1\\n";\n
1364           3\s+\n
1365           4:\s+\$x\ =\ 2;\n
1366           5:\s+print\ "2\\n";\n
1367           6\s*\n
1368           7:\s+\$x\ =\ 3;\n
1369           /msx,
1370         "test plain v"
1371         );
1372 }
1373
1374 {
1375     my $wrapper = DebugWrap->new(
1376         {
1377             cmds =>
1378             [
1379                 'v 10',
1380                 'q',
1381             ],
1382             prog => '../lib/perl5db/t/test-l-statement-1',
1383         }
1384        );
1385
1386     $wrapper->contents_like(
1387         qr/
1388           7:\s+\$x\ =\ 3;\n
1389           8:\s+print\ "3\\n";\n
1390           9\s*\n
1391           10:\s+\$x\ =\ 4;\n
1392           11:\s+print\ "4\\n";\n
1393           12\s*\n
1394           13:\s+\$x\ =\ 5;\n
1395           14:\s+print\ "5\\n";\n
1396           15\s*\n
1397           16:\s+\$x\ =\ 6;\n
1398           /msx,
1399         "test v with line"
1400         );
1401 }
1402
1403 {
1404     my $wrapper = DebugWrap->new(
1405         {
1406             cmds =>
1407             [
1408                 'l fact',
1409                 'q',
1410             ],
1411             prog => '../lib/perl5db/t/test-l-statement-2',
1412         }
1413     );
1414
1415     my $first_l_out = qr/
1416         6\s+sub\ fact\ \{\n
1417         7:\s+my\ \$n\ =\ shift;\n
1418         8:\s+if\ \(\$n\ >\ 1\)\ \{\n
1419         9:\s+return\ \$n\ \*\ fact\(\$n\ -\ 1\);
1420     /msx;
1421
1422     $wrapper->contents_like(
1423         qr/
1424             DB<1>\s+l\ fact\n
1425             $first_l_out
1426         /msx,
1427         'l subroutine_name',
1428     );
1429 }
1430
1431 {
1432     my $wrapper = DebugWrap->new(
1433         {
1434             cmds =>
1435             [
1436                 'b fact',
1437                 'c',
1438                 # Repeat several times to avoid @typeahead problems.
1439                 '.',
1440                 '.',
1441                 '.',
1442                 '.',
1443                 'q',
1444             ],
1445             prog => '../lib/perl5db/t/test-l-statement-2',
1446         }
1447     );
1448
1449     my $line_out = qr /
1450         ^main::fact\([^\n]*?:7\):\n
1451         ^7:\s+my\ \$n\ =\ shift;\n
1452     /msx;
1453
1454     $wrapper->contents_like(
1455         qr/
1456             $line_out
1457             auto\(-\d+\)\s+DB<\d+>\s+\.\n
1458             $line_out
1459         /msx,
1460         'Test the "." command',
1461     );
1462 }
1463
1464 # Testing that the f command works.
1465 {
1466     my $wrapper = DebugWrap->new(
1467         {
1468             cmds =>
1469             [
1470                 'f ../lib/perl5db/t/MyModule.pm',
1471                 'b 12',
1472                 'c',
1473                 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
1474                 'c',
1475                 'q',
1476             ],
1477             include_t => 1,
1478             prog => '../lib/perl5db/t/filename-line-breakpoint'
1479         }
1480     );
1481
1482     $wrapper->output_like(qr/
1483         ^Var=Bar$
1484             .*
1485         ^In\ MyModule\.$
1486             .*
1487         ^In\ Main\ File\.$
1488             .*
1489         /msx,
1490         "f command is working.",
1491     );
1492 }
1493
1494 # We broke the /pattern/ command because apparently the CORE::eval-s inside
1495 # lib/perl5db.pl cannot handle lexical variable properly. So we now fix this
1496 # bug.
1497 #
1498 # TODO :
1499 #
1500 # 1. Go over the rest of the "eval"s in lib/perl5db.t and see if they cause
1501 # problems.
1502 {
1503     my $wrapper = DebugWrap->new(
1504         {
1505             cmds =>
1506             [
1507                 '/for/',
1508                 'q',
1509             ],
1510             prog => '../lib/perl5db/t/eval-line-bug',
1511         }
1512     );
1513
1514     $wrapper->contents_like(
1515         qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1516         "/pat/ command is working and found a match.",
1517     );
1518 }
1519
1520 {
1521     my $wrapper = DebugWrap->new(
1522         {
1523             cmds =>
1524             [
1525                 'b 22',
1526                 'c',
1527                 '?for?',
1528                 'q',
1529             ],
1530             prog => '../lib/perl5db/t/eval-line-bug',
1531         }
1532     );
1533
1534     $wrapper->contents_like(
1535         qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1536         "?pat? command is working and found a match.",
1537     );
1538 }
1539
1540 # Test the L command.
1541 {
1542     my $wrapper = DebugWrap->new(
1543         {
1544             cmds =>
1545             [
1546                 'b 6',
1547                 'b 13 ($q == 5)',
1548                 'L',
1549                 'q',
1550             ],
1551             prog => '../lib/perl5db/t/eval-line-bug',
1552         }
1553     );
1554
1555     $wrapper->contents_like(
1556         qr#
1557         ^\S*?eval-line-bug:\n
1558         \s*6:\s*my\ \$i\ =\ 5;\n
1559         \s*break\ if\ \(1\)\n
1560         \s*13:\s*\$i\ \+=\ \$q;\n
1561         \s*break\ if\ \(\(\$q\ ==\ 5\)\)\n
1562         #msx,
1563         "L command is listing breakpoints",
1564     );
1565 }
1566
1567 # Test the L command for watch expressions.
1568 {
1569     my $wrapper = DebugWrap->new(
1570         {
1571             cmds =>
1572             [
1573                 'w (5+6)',
1574                 'L',
1575                 'q',
1576             ],
1577             prog => '../lib/perl5db/t/eval-line-bug',
1578         }
1579     );
1580
1581     $wrapper->contents_like(
1582         qr#
1583         ^Watch-expressions:\n
1584         \s*\(5\+6\)\n
1585         #msx,
1586         "L command is listing watch expressions",
1587     );
1588 }
1589
1590 {
1591     my $wrapper = DebugWrap->new(
1592         {
1593             cmds =>
1594             [
1595                 'w (5+6)',
1596                 'w (11*23)',
1597                 'W (5+6)',
1598                 'L',
1599                 'q',
1600             ],
1601             prog => '../lib/perl5db/t/eval-line-bug',
1602         }
1603     );
1604
1605     $wrapper->contents_like(
1606         qr#
1607         ^Watch-expressions:\n
1608         \s*\(11\*23\)\n
1609         ^auto\(
1610         #msx,
1611         "L command is not listing deleted watch expressions",
1612     );
1613 }
1614
1615 # Test the L command.
1616 {
1617     my $wrapper = DebugWrap->new(
1618         {
1619             cmds =>
1620             [
1621                 'b 6',
1622                 'a 13 print $i',
1623                 'L',
1624                 'q',
1625             ],
1626             prog => '../lib/perl5db/t/eval-line-bug',
1627         }
1628     );
1629
1630     $wrapper->contents_like(
1631         qr#
1632         ^\S*?eval-line-bug:\n
1633         \s*6:\s*my\ \$i\ =\ 5;\n
1634         \s*break\ if\ \(1\)\n
1635         \s*13:\s*\$i\ \+=\ \$q;\n
1636         \s*action:\s+print\ \$i\n
1637         #msx,
1638         "L command is listing actions and breakpoints",
1639     );
1640 }
1641
1642 {
1643     my $wrapper = DebugWrap->new(
1644         {
1645             cmds =>
1646             [
1647                 'S',
1648                 'q',
1649             ],
1650             prog =>  '../lib/perl5db/t/rt-104168',
1651         }
1652     );
1653
1654     $wrapper->contents_like(
1655         qr#
1656         ^main::bar\n
1657         main::baz\n
1658         main::foo\n
1659         #msx,
1660         "S command - 1",
1661     );
1662 }
1663
1664 {
1665     my $wrapper = DebugWrap->new(
1666         {
1667             cmds =>
1668             [
1669                 'S ^main::ba',
1670                 'q',
1671             ],
1672             prog =>  '../lib/perl5db/t/rt-104168',
1673         }
1674     );
1675
1676     $wrapper->contents_like(
1677         qr#
1678         ^main::bar\n
1679         main::baz\n
1680         auto\(
1681         #msx,
1682         "S command with regex",
1683     );
1684 }
1685
1686 {
1687     my $wrapper = DebugWrap->new(
1688         {
1689             cmds =>
1690             [
1691                 'S !^main::ba',
1692                 'q',
1693             ],
1694             prog =>  '../lib/perl5db/t/rt-104168',
1695         }
1696     );
1697
1698     $wrapper->contents_unlike(
1699         qr#
1700         ^main::ba
1701         #msx,
1702         "S command with negative regex",
1703     );
1704
1705     $wrapper->contents_like(
1706         qr#
1707         ^main::foo\n
1708         #msx,
1709         "S command with negative regex - what it still matches",
1710     );
1711 }
1712
1713 # Test the 'a' command.
1714 {
1715     my $wrapper = DebugWrap->new(
1716         {
1717             cmds =>
1718             [
1719                 'a 13 print "\nVar<Q>=$q\n"',
1720                 'c',
1721                 'q',
1722             ],
1723             prog => '../lib/perl5db/t/eval-line-bug',
1724         }
1725     );
1726
1727     my $nl = $^O eq 'VMS' ? "" : "\\\n";
1728     $wrapper->output_like(qr#
1729         \nVar<Q>=1$nl
1730         \nVar<Q>=2$nl
1731         \nVar<Q>=3
1732         #msx,
1733         "a command is working",
1734     );
1735 }
1736
1737 # Test the 'a' command with no line number.
1738 {
1739     my $wrapper = DebugWrap->new(
1740         {
1741             cmds =>
1742             [
1743                 'n',
1744                 q/a print "Hello " . (3 * 4) . "\n";/,
1745                 'c',
1746                 'q',
1747             ],
1748             prog => '../lib/perl5db/t/test-a-statement-1',
1749         }
1750     );
1751
1752     $wrapper->output_like(qr#
1753         (?:^Hello\ 12\n.*?){4}
1754         #msx,
1755         "a command with no line number is working",
1756     );
1757 }
1758
1759 # Test the 'A' command
1760 {
1761     my $wrapper = DebugWrap->new(
1762         {
1763             cmds =>
1764             [
1765                 'a 13 print "\nVar<Q>=$q\n"',
1766                 'A 13',
1767                 'c',
1768                 'q',
1769             ],
1770             prog => '../lib/perl5db/t/eval-line-bug',
1771         }
1772     );
1773
1774     $wrapper->output_like(
1775         qr#\A\z#msx, # The empty string.
1776         "A command (for removing actions) is working",
1777     );
1778 }
1779
1780 # Test the 'A *' command
1781 {
1782     my $wrapper = DebugWrap->new(
1783         {
1784             cmds =>
1785             [
1786                 'a 6 print "\nFail!\n"',
1787                 'a 13 print "\nVar<Q>=$q\n"',
1788                 'A *',
1789                 'c',
1790                 'q',
1791             ],
1792             prog => '../lib/perl5db/t/eval-line-bug',
1793         }
1794     );
1795
1796     $wrapper->output_like(
1797         qr#\A\z#msx, # The empty string.
1798         "'A *' command (for removing all actions) is working",
1799     );
1800 }
1801
1802 {
1803     my $wrapper = DebugWrap->new(
1804         {
1805             cmds =>
1806             [
1807                 'n',
1808                 'w $foo',
1809                 'c',
1810                 'print "\nIDX=<$idx>\n"',
1811                 'q',
1812             ],
1813             prog => '../lib/perl5db/t/test-w-statement-1',
1814         }
1815     );
1816
1817
1818     $wrapper->contents_like(qr#
1819         \$foo\ changed:\n
1820         \s+old\ value:\s+'1'\n
1821         \s+new\ value:\s+'2'\n
1822         #msx,
1823         'w command - watchpoint changed',
1824     );
1825     $wrapper->output_like(qr#
1826         \nIDX=<20>\n
1827         #msx,
1828         "w command - correct output from IDX",
1829     );
1830 }
1831
1832 {
1833     my $wrapper = DebugWrap->new(
1834         {
1835             cmds =>
1836             [
1837                 'n',
1838                 'w $foo',
1839                 'W $foo',
1840                 'c',
1841                 'print "\nIDX=<$idx>\n"',
1842                 'q',
1843             ],
1844             prog => '../lib/perl5db/t/test-w-statement-1',
1845         }
1846     );
1847
1848     $wrapper->contents_unlike(qr#
1849         \$foo\ changed:
1850         #msx,
1851         'W command - watchpoint was deleted',
1852     );
1853
1854     $wrapper->output_like(qr#
1855         \nIDX=<>\n
1856         #msx,
1857         "W command - stopped at end.",
1858     );
1859 }
1860
1861 # Test the W * command.
1862 {
1863     my $wrapper = DebugWrap->new(
1864         {
1865             cmds =>
1866             [
1867                 'n',
1868                 'w $foo',
1869                 'w ($foo*$foo)',
1870                 'W *',
1871                 'c',
1872                 'print "\nIDX=<$idx>\n"',
1873                 'q',
1874             ],
1875             prog => '../lib/perl5db/t/test-w-statement-1',
1876         }
1877     );
1878
1879     $wrapper->contents_unlike(qr#
1880         \$foo\ changed:
1881         #msx,
1882         '"W *" command - watchpoint was deleted',
1883     );
1884
1885     $wrapper->output_like(qr#
1886         \nIDX=<>\n
1887         #msx,
1888         '"W *" command - stopped at end.',
1889     );
1890 }
1891
1892 # Test the 'o' command (without further arguments).
1893 {
1894     my $wrapper = DebugWrap->new(
1895         {
1896             cmds =>
1897             [
1898                 'o',
1899                 'q',
1900             ],
1901             prog => '../lib/perl5db/t/test-w-statement-1',
1902         }
1903     );
1904
1905     $wrapper->contents_like(qr#
1906         ^\s*warnLevel\ =\ '1'\n
1907         #msx,
1908         q#"o" command (without arguments) displays warnLevel#,
1909     );
1910
1911     $wrapper->contents_like(qr#
1912         ^\s*signalLevel\ =\ '1'\n
1913         #msx,
1914         q#"o" command (without arguments) displays signalLevel#,
1915     );
1916
1917     $wrapper->contents_like(qr#
1918         ^\s*dieLevel\ =\ '1'\n
1919         #msx,
1920         q#"o" command (without arguments) displays dieLevel#,
1921     );
1922
1923     $wrapper->contents_like(qr#
1924         ^\s*hashDepth\ =\ 'N/A'\n
1925         #msx,
1926         q#"o" command (without arguments) displays hashDepth#,
1927     );
1928 }
1929
1930 # Test the 'o' query command.
1931 {
1932     my $wrapper = DebugWrap->new(
1933         {
1934             cmds =>
1935             [
1936                 'o hashDepth? signalLevel?',
1937                 'q',
1938             ],
1939             prog => '../lib/perl5db/t/test-w-statement-1',
1940         }
1941     );
1942
1943     $wrapper->contents_unlike(qr#warnLevel#,
1944         q#"o" query command does not display warnLevel#,
1945     );
1946
1947     $wrapper->contents_like(qr#
1948         ^\s*signalLevel\ =\ '1'\n
1949         #msx,
1950         q#"o" query command displays signalLevel#,
1951     );
1952
1953     $wrapper->contents_unlike(qr#dieLevel#,
1954         q#"o" query command does not display dieLevel#,
1955     );
1956
1957     $wrapper->contents_like(qr#
1958         ^\s*hashDepth\ =\ 'N/A'\n
1959         #msx,
1960         q#"o" query command displays hashDepth#,
1961     );
1962 }
1963
1964 # Test the 'o' set command.
1965 {
1966     my $wrapper = DebugWrap->new(
1967         {
1968             cmds =>
1969             [
1970                 'o signalLevel=0',
1971                 'o',
1972                 'q',
1973             ],
1974             prog => '../lib/perl5db/t/test-w-statement-1',
1975         }
1976     );
1977
1978     $wrapper->contents_like(qr/
1979         ^\s*(signalLevel\ =\ '0'\n)
1980         .*?
1981         ^\s*\1
1982         /msx,
1983         q#o set command works#,
1984     );
1985
1986     $wrapper->contents_like(qr#
1987         ^\s*hashDepth\ =\ 'N/A'\n
1988         #msx,
1989         q#o set command - hashDepth#,
1990     );
1991 }
1992
1993 # Test the '<' and "< ?" commands.
1994 {
1995     my $wrapper = DebugWrap->new(
1996         {
1997             cmds =>
1998             [
1999                 q/< print "\nX=<$x>\n"/,
2000                 q/b 7/,
2001                 q/< ?/,
2002                 'c',
2003                 'q',
2004             ],
2005             prog => '../lib/perl5db/t/disable-breakpoints-1',
2006         }
2007     );
2008
2009     $wrapper->contents_like(qr/
2010         ^pre-perl\ commands:\n
2011         \s*<\ --\ print\ "\\nX=<\$x>\\n"\n
2012         /msx,
2013         q#Test < and < ? commands - contents.#,
2014     );
2015
2016     $wrapper->output_like(qr#
2017         ^X=<FirstVal>\n
2018         #msx,
2019         q#Test < and < ? commands - output.#,
2020     );
2021 }
2022
2023 # Test the '< *' command.
2024 {
2025     my $wrapper = DebugWrap->new(
2026         {
2027             cmds =>
2028             [
2029                 q/< print "\nX=<$x>\n"/,
2030                 q/b 7/,
2031                 q/< */,
2032                 'c',
2033                 'q',
2034             ],
2035             prog => '../lib/perl5db/t/disable-breakpoints-1',
2036         }
2037     );
2038
2039     $wrapper->output_unlike(qr/FirstVal/,
2040         q#Test the '< *' command.#,
2041     );
2042 }
2043
2044 # Test the '>' and "> ?" commands.
2045 {
2046     my $wrapper = DebugWrap->new(
2047         {
2048             cmds =>
2049             [
2050                 q/$::foo = 500;/,
2051                 q/> print "\nFOO=<$::foo>\n"/,
2052                 q/b 7/,
2053                 q/> ?/,
2054                 'c',
2055                 'q',
2056             ],
2057             prog => '../lib/perl5db/t/disable-breakpoints-1',
2058         }
2059     );
2060
2061     $wrapper->contents_like(qr/
2062         ^post-perl\ commands:\n
2063         \s*>\ --\ print\ "\\nFOO=<\$::foo>\\n"\n
2064         /msx,
2065         q#Test > and > ? commands - contents.#,
2066     );
2067
2068     $wrapper->output_like(qr#
2069         ^FOO=<500>\n
2070         #msx,
2071         q#Test > and > ? commands - output.#,
2072     );
2073 }
2074
2075 # Test the '> *' command.
2076 {
2077     my $wrapper = DebugWrap->new(
2078         {
2079             cmds =>
2080             [
2081                 q/> print "\nFOO=<$::foo>\n"/,
2082                 q/b 7/,
2083                 q/> */,
2084                 'c',
2085                 'q',
2086             ],
2087             prog => '../lib/perl5db/t/disable-breakpoints-1',
2088         }
2089     );
2090
2091     $wrapper->output_unlike(qr/FOO=/,
2092         q#Test the '> *' command.#,
2093     );
2094 }
2095
2096 # Test the < and > commands together
2097 {
2098     my $wrapper = DebugWrap->new(
2099         {
2100             cmds =>
2101             [
2102                 q/$::lorem = 0;/,
2103                 q/< $::lorem += 10;/,
2104                 q/> print "\nLOREM=<$::lorem>\n"/,
2105                 q/b 7/,
2106                 q/b 5/,
2107                 'c',
2108                 'c',
2109                 'q',
2110             ],
2111             prog => '../lib/perl5db/t/disable-breakpoints-1',
2112         }
2113     );
2114
2115     $wrapper->output_like(qr#
2116         ^LOREM=<10>\n
2117         #msx,
2118         q#Test < and > commands. #,
2119     );
2120 }
2121
2122 # Test the { ? and { [command] commands.
2123 {
2124     my $wrapper = DebugWrap->new(
2125         {
2126             cmds =>
2127             [
2128                 '{ ?',
2129                 '{ l',
2130                 '{ ?',
2131                 q/b 5/,
2132                 q/c/,
2133                 q/q/,
2134             ],
2135             prog => '../lib/perl5db/t/disable-breakpoints-1',
2136         }
2137     );
2138
2139     $wrapper->contents_like(qr#
2140         ^No\ pre-debugger\ actions\.\n
2141         .*?
2142         ^pre-debugger\ commands:\n
2143         \s+\{\ --\ l\n
2144         .*?
2145         ^5==>b\s+\$x\ =\ "FirstVal";\n
2146         6\s*\n
2147         7:\s+\$dummy\+\+;\n
2148         8\s*\n
2149         9:\s+\$x\ =\ "SecondVal";\n
2150
2151         #msx,
2152         'Test the pre-prompt debugger commands',
2153     );
2154 }
2155
2156 # Test the { * command.
2157 {
2158     my $wrapper = DebugWrap->new(
2159         {
2160             cmds =>
2161             [
2162                 '{ q',
2163                 '{ *',
2164                 q/b 5/,
2165                 q/c/,
2166                 q/print (("One" x 5), "\n");/,
2167                 q/q/,
2168             ],
2169             prog => '../lib/perl5db/t/disable-breakpoints-1',
2170         }
2171     );
2172
2173     $wrapper->contents_like(qr#
2174         ^All\ \{\ actions\ cleared\.\n
2175         #msx,
2176         'Test the { * command',
2177     );
2178
2179     $wrapper->output_like(qr/OneOneOneOneOne/,
2180         '{ * test - output is OK.',
2181     );
2182 }
2183
2184 # Test the ! command.
2185 {
2186     my $wrapper = DebugWrap->new(
2187         {
2188             cmds =>
2189             [
2190                 'l 3-5',
2191                 '!',
2192                 'q',
2193             ],
2194             prog => '../lib/perl5db/t/disable-breakpoints-1',
2195         }
2196     );
2197
2198     $wrapper->contents_like(qr#
2199         (^3:\s+my\ \$dummy\ =\ 0;\n
2200         4\s*\n
2201         5:\s+\$x\ =\ "FirstVal";)\n
2202         .*?
2203         ^l\ 3-5\n
2204         \1
2205         #msx,
2206         'Test the ! command (along with l 3-5)',
2207     );
2208 }
2209
2210 # Test the ! -number command.
2211 {
2212     my $wrapper = DebugWrap->new(
2213         {
2214             cmds =>
2215             [
2216                 'l 3-5',
2217                 'l 2',
2218                 '! -1',
2219                 'q',
2220             ],
2221             prog => '../lib/perl5db/t/disable-breakpoints-1',
2222         }
2223     );
2224
2225     $wrapper->contents_like(qr#
2226         (^3:\s+my\ \$dummy\ =\ 0;\n
2227         4\s*\n
2228         5:\s+\$x\ =\ "FirstVal";)\n
2229         .*?
2230         ^2==\>\s+my\ \$x\ =\ "One";\n
2231         .*?
2232         ^l\ 3-5\n
2233         \1
2234         #msx,
2235         'Test the ! -n command (along with l)',
2236     );
2237 }
2238
2239 # Test the 'source' command.
2240 {
2241     my $wrapper = DebugWrap->new(
2242         {
2243             cmds =>
2244             [
2245                 'source ../lib/perl5db/t/source-cmd-test.perldb',
2246                 # If we have a 'q' here, then the typeahead will override the
2247                 # input, and so it won't be reached - solution:
2248                 # put a q inside the .perldb commands.
2249                 # ( This may be a bug or a misfeature. )
2250             ],
2251             prog => '../lib/perl5db/t/disable-breakpoints-1',
2252         }
2253     );
2254
2255     $wrapper->contents_like(qr#
2256         ^3:\s+my\ \$dummy\ =\ 0;\n
2257         4\s*\n
2258         5:\s+\$x\ =\ "FirstVal";\n
2259         6\s*\n
2260         7:\s+\$dummy\+\+;\n
2261         8\s*\n
2262         9:\s+\$x\ =\ "SecondVal";\n
2263         10\s*\n
2264         #msx,
2265         'Test the source command (along with l)',
2266     );
2267 }
2268
2269 # Test the 'source' command being traversed from withing typeahead.
2270 {
2271     my $wrapper = DebugWrap->new(
2272         {
2273             cmds =>
2274             [
2275                 'source ../lib/perl5db/t/source-cmd-test-no-q.perldb',
2276                 'q',
2277             ],
2278             prog => '../lib/perl5db/t/disable-breakpoints-1',
2279         }
2280     );
2281
2282     $wrapper->contents_like(qr#
2283         ^3:\s+my\ \$dummy\ =\ 0;\n
2284         4\s*\n
2285         5:\s+\$x\ =\ "FirstVal";\n
2286         6\s*\n
2287         7:\s+\$dummy\+\+;\n
2288         8\s*\n
2289         9:\s+\$x\ =\ "SecondVal";\n
2290         10\s*\n
2291         #msx,
2292         'Test the source command inside a typeahead',
2293     );
2294 }
2295
2296 # Test the 'H -number' command.
2297 {
2298     my $wrapper = DebugWrap->new(
2299         {
2300             cmds =>
2301             [
2302                 'l 1-10',
2303                 'l 5-10',
2304                 'x "Hello World"',
2305                 'l 1-5',
2306                 'b 3',
2307                 'x (20+4)',
2308                 'H -7',
2309                 'q',
2310             ],
2311             prog => '../lib/perl5db/t/disable-breakpoints-1',
2312         }
2313     );
2314
2315     $wrapper->contents_like(qr#
2316         ^\d+:\s+H\ -7\n
2317         \d+:\s+x\ \(20\+4\)\n
2318         \d+:\s+b\ 3\n
2319         \d+:\s+l\ 1-5\n
2320         \d+:\s+x\ "Hello\ World"\n
2321         \d+:\s+l\ 5-10\n
2322         \d+:\s+l\ 1-10\n
2323         #msx,
2324         'Test the H -num command',
2325     );
2326 }
2327
2328 # Add a test for H (without arguments)
2329 {
2330     my $wrapper = DebugWrap->new(
2331         {
2332             cmds =>
2333             [
2334                 'l 1-10',
2335                 'l 5-10',
2336                 'x "Hello World"',
2337                 'l 1-5',
2338                 'b 3',
2339                 'x (20+4)',
2340                 'H',
2341                 'q',
2342             ],
2343             prog => '../lib/perl5db/t/disable-breakpoints-1',
2344         }
2345     );
2346
2347     $wrapper->contents_like(qr#
2348         ^\d+:\s+x\ \(20\+4\)\n
2349         \d+:\s+b\ 3\n
2350         \d+:\s+l\ 1-5\n
2351         \d+:\s+x\ "Hello\ World"\n
2352         \d+:\s+l\ 5-10\n
2353         \d+:\s+l\ 1-10\n
2354         #msx,
2355         'Test the H command (without a number.)',
2356     );
2357 }
2358
2359 {
2360     my $wrapper = DebugWrap->new(
2361         {
2362             cmds =>
2363             [
2364                 '= quit q',
2365                 '= foobar l',
2366                 '= .hello print "hellox\n"',
2367                 '= -goodbye print "goodbyex\n"',
2368                 'foobar',
2369                 '.hello',
2370                 '-goodbye',
2371                 'quit',
2372             ],
2373             prog => '../lib/perl5db/t/test-l-statement-1',
2374         }
2375     );
2376
2377     $wrapper->contents_like(
2378         qr/
2379             ^1==>\s+\$x\ =\ 1;\n
2380             2:\s+print\ "1\\n";\n
2381             3\s*\n
2382             4:\s+\$x\ =\ 2;\n
2383             5:\s+print\ "2\\n";\n
2384         /msx,
2385         'Test the = (command alias) command.',
2386        );
2387     $wrapper->output_like(qr/hellox.*goodbyex/xs,
2388                           "check . and - can start alias name");
2389 }
2390
2391 # Test the m statement.
2392 {
2393     my $wrapper = DebugWrap->new(
2394         {
2395             cmds =>
2396             [
2397                 'm main',
2398                 'q',
2399             ],
2400             prog => '../lib/perl5db/t/disable-breakpoints-1',
2401         }
2402     );
2403
2404     $wrapper->contents_like(qr#
2405         ^via\ UNIVERSAL:\ DOES$
2406         #msx,
2407         "Test m for main - 1",
2408     );
2409
2410     $wrapper->contents_like(qr#
2411         ^via\ UNIVERSAL:\ can$
2412         #msx,
2413         "Test m for main - 2",
2414     );
2415 }
2416
2417 # Test the m statement.
2418 {
2419     my $wrapper = DebugWrap->new(
2420         {
2421             cmds =>
2422             [
2423                 'b 41',
2424                 'c',
2425                 'm $obj',
2426                 'q',
2427             ],
2428             prog => '../lib/perl5db/t/test-m-statement-1',
2429         }
2430     );
2431
2432     $wrapper->contents_like(qr#^greet$#ms,
2433         "Test m for obj - 1",
2434     );
2435
2436     $wrapper->contents_like(qr#^via UNIVERSAL: can$#ms,
2437         "Test m for obj - 1",
2438     );
2439 }
2440
2441 # Test the M command.
2442 {
2443     my $wrapper = DebugWrap->new(
2444         {
2445             cmds =>
2446             [
2447                 'M',
2448                 'q',
2449             ],
2450             prog => '../lib/perl5db/t/test-m-statement-1',
2451         }
2452     );
2453
2454     $wrapper->contents_like(qr#
2455         ^'strict\.pm'\ =>\ '\d+\.\d+\ from
2456         #msx,
2457         "Test M",
2458     );
2459
2460 }
2461
2462 # Test the recallCommand option.
2463 {
2464     my $wrapper = DebugWrap->new(
2465         {
2466             cmds =>
2467             [
2468                 'o recallCommand=%',
2469                 'l 3-5',
2470                 'l 2',
2471                 '% -1',
2472                 'q',
2473             ],
2474             prog => '../lib/perl5db/t/disable-breakpoints-1',
2475         }
2476     );
2477
2478     $wrapper->contents_like(qr#
2479         (^3:\s+my\ \$dummy\ =\ 0;\n
2480         4\s*\n
2481         5:\s+\$x\ =\ "FirstVal";)\n
2482         .*?
2483         ^2==\>\s+my\ \$x\ =\ "One";\n
2484         .*?
2485         ^l\ 3-5\n
2486         \1
2487         #msx,
2488         'Test the o recallCommand option',
2489     );
2490 }
2491
2492 # Test the dieLevel option
2493 {
2494     my $wrapper = DebugWrap->new(
2495         {
2496             cmds =>
2497             [
2498                 q/o dieLevel='1'/,
2499                 q/c/,
2500                 'q',
2501             ],
2502             prog => '../lib/perl5db/t/test-dieLevel-option-1',
2503         }
2504     );
2505
2506     $wrapper->output_like(qr#
2507         ^This\ program\ dies\.\ at\ \S+\ line\ 18\N*\.\n
2508         .*?
2509         ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
2510         \s+main::bar\(\)\ called\ at\ \S+\ line\ 7\n
2511         \s+main::foo\(\)\ called\ at\ \S+\ line\ 21\n
2512         #msx,
2513         'Test the o dieLevel option',
2514     );
2515 }
2516
2517 # Test the warnLevel option
2518 {
2519     my $wrapper = DebugWrap->new(
2520         {
2521             cmds =>
2522             [
2523                 q/o warnLevel='1'/,
2524                 q/c/,
2525                 'q',
2526             ],
2527             prog => '../lib/perl5db/t/test-warnLevel-option-1',
2528         }
2529     );
2530
2531     $wrapper->contents_like(qr#
2532         ^This\ is\ not\ a\ warning\.\ at\ \S+\ line\ 18\N*\.\n
2533         .*?
2534         ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n
2535         \s+main::bar\(\)\ called\ at\ \S+\ line\ 25\n
2536         \s+main::myfunc\(\)\ called\ at\ \S+\ line\ 28\n
2537         #msx,
2538         'Test the o warnLevel option',
2539     );
2540 }
2541
2542 # Test the t command
2543 {
2544     my $wrapper = DebugWrap->new(
2545         {
2546             cmds =>
2547             [
2548                 't',
2549                 'c',
2550                 'q',
2551             ],
2552             prog => '../lib/perl5db/t/disable-breakpoints-1',
2553         }
2554     );
2555
2556     $wrapper->contents_like(qr/
2557         ^main::\([^:]+:15\):\n
2558         15:\s+\$dummy\+\+;\n
2559         main::\([^:]+:17\):\n
2560         17:\s+\$x\ =\ "FourthVal";\n
2561         /msx,
2562         'Test the t command (without a number.)',
2563     );
2564 }
2565
2566 # Test the o AutoTrace command
2567 {
2568     my $wrapper = DebugWrap->new(
2569         {
2570             cmds =>
2571             [
2572                 'o AutoTrace',
2573                 'c',
2574                 'q',
2575             ],
2576             prog => '../lib/perl5db/t/disable-breakpoints-1',
2577         }
2578     );
2579
2580     $wrapper->contents_like(qr/
2581         ^main::\([^:]+:15\):\n
2582         15:\s+\$dummy\+\+;\n
2583         main::\([^:]+:17\):\n
2584         17:\s+\$x\ =\ "FourthVal";\n
2585         /msx,
2586         'Test the o AutoTrace command',
2587     );
2588 }
2589
2590 # Test the t command with function calls
2591 {
2592     my $wrapper = DebugWrap->new(
2593         {
2594             cmds =>
2595             [
2596                 't',
2597                 'b 18',
2598                 'c',
2599                 'x ["foo"]',
2600                 'x ["bar"]',
2601                 'q',
2602             ],
2603             prog => '../lib/perl5db/t/test-warnLevel-option-1',
2604         }
2605     );
2606
2607     $wrapper->contents_like(qr/
2608         ^main::\([^:]+:28\):\n
2609         28:\s+myfunc\(\);\n
2610         auto\(-\d+\)\s+DB<1>\s+t\n
2611         Trace\ =\ on\n
2612         auto\(-\d+\)\s+DB<1>\s+b\ 18\n
2613         auto\(-\d+\)\s+DB<2>\s+c\n
2614         main::myfunc\([^:]+:25\):\n
2615         25:\s+bar\(\);\n
2616         /msx,
2617         'Test the t command with function calls.',
2618     );
2619 }
2620
2621 # Test the o AutoTrace command with function calls
2622 {
2623     my $wrapper = DebugWrap->new(
2624         {
2625             cmds =>
2626             [
2627                 'o AutoTrace',
2628                 'b 18',
2629                 'c',
2630                 'x ["foo"]',
2631                 'x ["bar"]',
2632                 'q',
2633             ],
2634             prog => '../lib/perl5db/t/test-warnLevel-option-1',
2635         }
2636     );
2637
2638     $wrapper->contents_like(qr/
2639         ^main::\([^:]+:28\):\n
2640         28:\s+myfunc\(\);\n
2641         auto\(-\d+\)\s+DB<1>\s+o\ AutoTrace\n
2642         \s+AutoTrace\s+=\s+'1'\n
2643         auto\(-\d+\)\s+DB<2>\s+b\ 18\n
2644         auto\(-\d+\)\s+DB<3>\s+c\n
2645         main::myfunc\([^:]+:25\):\n
2646         25:\s+bar\(\);\n
2647         /msx,
2648         'Test the o AutoTrace command with function calls.',
2649     );
2650 }
2651
2652 # Test the final message.
2653 {
2654     my $wrapper = DebugWrap->new(
2655         {
2656             cmds =>
2657             [
2658                 'c',
2659                 'q',
2660             ],
2661             prog => '../lib/perl5db/t/test-warnLevel-option-1',
2662         }
2663     );
2664
2665     $wrapper->contents_like(qr/
2666         ^Debugged\ program\ terminated\.
2667         /msx,
2668         'Test the final "Debugged program terminated" message.',
2669     );
2670 }
2671
2672 # Test the o inhibit_exit=0 command
2673 {
2674     my $wrapper = DebugWrap->new(
2675         {
2676             cmds =>
2677             [
2678                 'o inhibit_exit=0',
2679                 'n',
2680                 'n',
2681                 'n',
2682                 'n',
2683                 'q',
2684             ],
2685             prog => '../lib/perl5db/t/test-warnLevel-option-1',
2686         }
2687     );
2688
2689     $wrapper->contents_unlike(qr/
2690         ^Debugged\ program\ terminated\.
2691         /msx,
2692         'Test the o inhibit_exit=0 command.',
2693     );
2694 }
2695
2696 # Test the o PrintRet=1 option
2697 {
2698     my $wrapper = DebugWrap->new(
2699         {
2700             cmds =>
2701             [
2702                 'o PrintRet=1',
2703                 'b 29',
2704                 'c',
2705                 q/$x = 's';/,
2706                 'b 10',
2707                 'c',
2708                 'r',
2709                 'q',
2710             ],
2711             prog => '../lib/perl5db/t/test-PrintRet-option-1',
2712         }
2713     );
2714
2715     $wrapper->contents_like(
2716         qr/scalar context return from main::return_scalar: 20024/,
2717         "Test o PrintRet=1",
2718     );
2719 }
2720
2721 # Test the o PrintRet=0 option
2722 {
2723     my $wrapper = DebugWrap->new(
2724         {
2725             cmds =>
2726             [
2727                 'o PrintRet=0',
2728                 'b 29',
2729                 'c',
2730                 q/$x = 's';/,
2731                 'b 10',
2732                 'c',
2733                 'r',
2734                 'q',
2735             ],
2736             prog => '../lib/perl5db/t/test-PrintRet-option-1',
2737         }
2738     );
2739
2740     $wrapper->contents_unlike(
2741         qr/scalar context/,
2742         "Test o PrintRet=0",
2743     );
2744 }
2745
2746 # Test the o PrintRet=1 option in list context
2747 {
2748     my $wrapper = DebugWrap->new(
2749         {
2750             cmds =>
2751             [
2752                 'o PrintRet=1',
2753                 'b 29',
2754                 'c',
2755                 q/$x = 'l';/,
2756                 'b 17',
2757                 'c',
2758                 'r',
2759                 'q',
2760             ],
2761             prog => '../lib/perl5db/t/test-PrintRet-option-1',
2762         }
2763     );
2764
2765     $wrapper->contents_like(
2766         qr/list context return from main::return_list:\n0\s*'Foo'\n1\s*'Bar'\n2\s*'Baz'\n/,
2767         "Test o PrintRet=1 in list context",
2768     );
2769 }
2770
2771 # Test the o PrintRet=0 option in list context
2772 {
2773     my $wrapper = DebugWrap->new(
2774         {
2775             cmds =>
2776             [
2777                 'o PrintRet=0',
2778                 'b 29',
2779                 'c',
2780                 q/$x = 'l';/,
2781                 'b 17',
2782                 'c',
2783                 'r',
2784                 'q',
2785             ],
2786             prog => '../lib/perl5db/t/test-PrintRet-option-1',
2787         }
2788     );
2789
2790     $wrapper->contents_unlike(
2791         qr/list context/,
2792         "Test o PrintRet=0 in list context",
2793     );
2794 }
2795
2796 # Test the o PrintRet=1 option in void context
2797 {
2798     my $wrapper = DebugWrap->new(
2799         {
2800             cmds =>
2801             [
2802                 'o PrintRet=1',
2803                 'b 29',
2804                 'c',
2805                 q/$x = 'v';/,
2806                 'b 24',
2807                 'c',
2808                 'r',
2809                 'q',
2810             ],
2811             prog => '../lib/perl5db/t/test-PrintRet-option-1',
2812         }
2813     );
2814
2815     $wrapper->contents_like(
2816         qr/void context return from main::return_void/,
2817         "Test o PrintRet=1 in void context",
2818     );
2819 }
2820
2821 # Test the o PrintRet=1 option in void context
2822 {
2823     my $wrapper = DebugWrap->new(
2824         {
2825             cmds =>
2826             [
2827                 'o PrintRet=0',
2828                 'b 29',
2829                 'c',
2830                 q/$x = 'v';/,
2831                 'b 24',
2832                 'c',
2833                 'r',
2834                 'q',
2835             ],
2836             prog => '../lib/perl5db/t/test-PrintRet-option-1',
2837         }
2838     );
2839
2840     $wrapper->contents_unlike(
2841         qr/void context/,
2842         "Test o PrintRet=0 in void context",
2843     );
2844 }
2845
2846 # Test the o frame option.
2847 {
2848     my $wrapper = DebugWrap->new(
2849         {
2850             cmds =>
2851             [
2852                 # This is to avoid getting the "Debugger program terminated"
2853                 # junk that interferes with the normal output.
2854                 'o inhibit_exit=0',
2855                 'b 10',
2856                 'c',
2857                 'o frame=255',
2858                 'c',
2859                 'q',
2860             ],
2861             prog => '../lib/perl5db/t/test-frame-option-1',
2862         }
2863     );
2864
2865     $wrapper->contents_like(
2866         qr/
2867             in\s*\.=main::my_other_func\(3,\ 1200\)\ from.*?
2868             out\s*\.=main::my_other_func\(3,\ 1200\)\ from
2869         /msx,
2870         "Test o PrintRet=0 in void context",
2871     );
2872 }
2873
2874 { # test t expr
2875     my $wrapper = DebugWrap->new(
2876         {
2877             cmds =>
2878             [
2879                 # This is to avoid getting the "Debugger program terminated"
2880                 # junk that interferes with the normal output.
2881                 'o inhibit_exit=0',
2882                 't fact(3)',
2883                 'q',
2884             ],
2885             prog => '../lib/perl5db/t/fact',
2886         }
2887     );
2888
2889     $wrapper->contents_like(
2890         qr/
2891             (?:^main::fact.*return\ \$n\ \*\ fact\(\$n\ -\ 1\);.*)
2892         /msx,
2893         "Test t expr",
2894     );
2895 }
2896
2897 # Test the w for lexical variables expression.
2898 {
2899     my $wrapper = DebugWrap->new(
2900         {
2901             cmds =>
2902             [
2903                 # This is to avoid getting the "Debugger program terminated"
2904                 # junk that interferes with the normal output.
2905                 'w $exp',
2906                 'n',
2907                 'n',
2908                 'n',
2909                 'n',
2910                 'q',
2911             ],
2912             prog => '../lib/perl5db/t/break-on-dot',
2913         }
2914     );
2915
2916     $wrapper->contents_like(
2917         qr/
2918 \s+old\ value:\s+'1'\n
2919 \s+new\ value:\s+'2'\n
2920         /msx,
2921         "Test w for lexical values.",
2922     );
2923 }
2924
2925 # perl 5 RT #121509 regression bug.
2926 # “perl debugger doesn't save starting dir to restart from”
2927 # Thanks to Linda Walsh for reporting it.
2928 {
2929     use File::Temp qw/tempdir/;
2930
2931     my $temp_dir = tempdir( CLEANUP => 1 );
2932
2933     local $ENV{__PERLDB_TEMP_DIR} = $temp_dir;
2934     my $wrapper = DebugWrap->new(
2935         {
2936             cmds =>
2937             [
2938                 # This is to avoid getting the "Debugger program terminated"
2939                 # junk that interferes with the normal output.
2940                 'b _after_chdir',
2941                 'c',
2942                 'R',
2943                 'b _finale',
2944                 'c',
2945                 'n',
2946                 'n',
2947                 'n',
2948                 'n',
2949                 'n',
2950                 'n',
2951                 'n',
2952                 'n',
2953                 'n',
2954                 'n',
2955                 'n',
2956                 'n',
2957                 'q',
2958             ],
2959             prog => '../lib/perl5db/t/rt-121509-restart-after-chdir',
2960         }
2961     );
2962
2963     $wrapper->output_like(
2964         qr/
2965 In\ _finale\ No\ 1
2966     .*?
2967 In\ _finale\ No\ 2
2968     .*?
2969 In\ _finale\ No\ 3
2970         /msx,
2971         "Test that the debugger chdirs to the initial directory after a restart.",
2972     );
2973 }
2974 # Test the perldoc command
2975 # We don't actually run the program, but we need to provide one to the wrapper.
2976 SKIP:
2977 {
2978     $^O eq "linux"
2979         or skip "man errors aren't especially portable", 1;
2980     -x '/usr/bin/man'
2981         or skip "man command seems to be missing", 1;
2982     local $ENV{LANG} = "C";
2983     local $ENV{LC_MESSAGES} = "C";
2984     local $ENV{LC_ALL} = "C";
2985     my $wrapper = DebugWrap->new(
2986         {
2987             cmds =>
2988             [
2989                 'perldoc perlrules',
2990                 'q',
2991             ],
2992             prog => '../lib/perl5db/t/fact',
2993         }
2994     );
2995
2996     $wrapper->output_like(
2997         qr/No (?:manual )?entry for perlrules/,
2998         'perldoc command works fine',
2999     );
3000 }
3001
3002 # [perl #71678] debugger bug in evaluation of user actions ('a' command)
3003 # Still evaluated after the script finishes.
3004 {
3005     my $wrapper = DebugWrap->new(
3006         {
3007             cmds =>
3008             [
3009                 q#a 9 print " \$arg = $arg\n"#,
3010                 'c 9',
3011                 's',
3012                 'q',
3013             ],
3014             prog => '../lib/perl5db/t/test-a-statement-2',
3015             switches => [ '-dw', ],
3016             stderr => 1,
3017         }
3018     );
3019
3020     $wrapper->contents_unlike(qr/
3021         Use\ of\ uninitialized\ value\ \$arg\ in\ concatenation\ [\S ]+\ or\ string\ at
3022         /msx,
3023         'Test that the a command does not emit warnings on program exit.',
3024     );
3025 }
3026
3027 {
3028     # GitHub #17901
3029     my $wrapper = DebugWrap->new(
3030         {
3031             cmds =>
3032             [
3033                 'a 4 $s++',
3034                 ('s') x 5,
3035                 'x $s',
3036                 'q'
3037             ],
3038             prog => '../lib/perl5db/t/test-a-statement-3',
3039             switches => [ '-d' ],
3040             stderr => 0,
3041         }
3042     );
3043     $wrapper->contents_like(
3044         qr/^0 +2$/m,
3045         'Test that the a command runs only on the given lines.',
3046     );
3047 }
3048
3049 {
3050     # perl 5 RT #126735 regression bug.
3051     local $ENV{PERLDB_OPTS} = "NonStop=0 RemotePort=non-existent-host.tld:9001";
3052     my $output = runperl( stdin => "q\n", stderr => 1, switches => [ '-d' ], prog => '../lib/perl5db/t/fact' );
3053     like(
3054         $output,
3055         qr/^Unable to connect to remote host:/ms,
3056         'Tried to connect.',
3057     );
3058     unlike(
3059         $output,
3060         qr/syntax error/,
3061         'Can quit from the debugger after a wrong RemotePort',
3062     );
3063 }
3064
3065 {
3066     # perl 5 RT #120174 - 'p' command
3067     my $wrapper = DebugWrap->new(
3068         {
3069             cmds =>
3070             [
3071                 'b 2',
3072                 'c',
3073                 'p@abc',
3074                 'q',
3075             ],
3076             prog => '../lib/perl5db/t/rt-120174',
3077         }
3078     );
3079
3080     $wrapper->contents_like(
3081         qr/1234/,
3082         q/RT 120174: p command can be invoked without space after 'p'/,
3083     );
3084 }
3085
3086 {
3087     # perl 5 RT #120174 - 'x' command on array
3088     my $wrapper = DebugWrap->new(
3089         {
3090             cmds =>
3091             [
3092                 'b 2',
3093                 'c',
3094                 'x@abc',
3095                 'q',
3096             ],
3097             prog => '../lib/perl5db/t/rt-120174',
3098         }
3099     );
3100
3101     $wrapper->contents_like(
3102         qr/0\s+1\n1\s+2\n2\s+3\n3\s+4/ms,
3103         q/RT 120174: x command can be invoked without space after 'x' before array/,
3104     );
3105 }
3106
3107 {
3108     # perl 5 RT #120174 - 'x' command on array ref
3109     my $wrapper = DebugWrap->new(
3110         {
3111             cmds =>
3112             [
3113                 'b 2',
3114                 'c',
3115                 'x\@abc',
3116                 'q',
3117             ],
3118             prog => '../lib/perl5db/t/rt-120174',
3119         }
3120     );
3121
3122     $wrapper->contents_like(
3123         qr/\s+0\s+1\n\s+1\s+2\n\s+2\s+3\n\s+3\s+4/ms,
3124         q/RT 120174: x command can be invoked without space after 'x' before array ref/,
3125     );
3126 }
3127
3128 {
3129     # perl 5 RT #120174 - 'x' command on hash ref
3130     my $wrapper = DebugWrap->new(
3131         {
3132             cmds =>
3133             [
3134                 'b 4',
3135                 'c',
3136                 'x\%xyz',
3137                 'q',
3138             ],
3139             prog => '../lib/perl5db/t/rt-120174',
3140         }
3141     );
3142
3143     $wrapper->contents_like(
3144         qr/\s+'alpha'\s+=>\s+'beta'\n\s+'gamma'\s+=>\s+'delta'/ms,
3145         q/RT 120174: x command can be invoked without space after 'x' before hash ref/,
3146     );
3147 }
3148
3149 {
3150     # gh #17660
3151     my $wrapper = DebugWrap->new(
3152         {
3153             cmds =>
3154             [
3155                 'b 13',
3156                 'c',
3157                 'i Foo',
3158                 'q',
3159             ],
3160             prog => '../lib/perl5db/t/gh-17660',
3161         }
3162     );
3163
3164     $wrapper->output_unlike(
3165         qr/Undefined subroutine &mro::get_linear_isa/ms,
3166         q/mro needs to be loaded/,
3167        );
3168     $wrapper->output_like(
3169         qr/Foo 1.000, Bar 2.000/,
3170         q/check for reasonable result/,
3171        );
3172 }
3173
3174 {
3175     # gh #17661
3176     my $wrapper = DebugWrap->new(
3177         {
3178             cmds =>
3179             [
3180                 'c',
3181                 'i $obj',
3182                 'q',
3183             ],
3184             prog => '../lib/perl5db/t/gh-17661',
3185         }
3186     );
3187
3188     $wrapper->output_like(
3189         qr/C5, C1, C2, C3, C4/,
3190         q/check for reasonable result/,
3191        );
3192 }
3193
3194 {
3195     # gh #17661 related - C<l $var> where $var is lexical
3196     my $wrapper = DebugWrap->new(
3197         {
3198             cmds =>
3199             [
3200                 'c',
3201                 'l $x',
3202                 'l $y',
3203                 'q',
3204             ],
3205             prog => '../lib/perl5db/t/gh-17661b',
3206         }
3207     );
3208
3209     $wrapper->contents_like(
3210         qr/sub bar/,
3211         q/check bar was listed/,
3212        );
3213     $wrapper->contents_like(
3214         qr/sub foo/,
3215         q/check foo was listed/,
3216        );
3217 }
3218
3219 SKIP:
3220 {
3221     $Config{usethreads}
3222       or skip "need threads to test debugging threads", 1;
3223     my $wrapper = DebugWrap->new(
3224         {
3225             cmds =>
3226             [
3227                 'c',
3228                 'q',
3229             ],
3230             prog => '../lib/perl5db/t/rt-124203',
3231         }
3232     );
3233
3234     $wrapper->output_like(qr/In the thread/, "[perl #124203] the thread ran");
3235
3236     $wrapper->output_like(qr/Finished/, "[perl #124203] debugger didn't deadlock");
3237
3238     $wrapper = DebugWrap->new(
3239         {
3240             cmds =>
3241             [
3242                 'c',
3243                 'q',
3244             ],
3245             prog => '../lib/perl5db/t/rt-124203b',
3246         }
3247     );
3248
3249     $wrapper->output_like(qr/In the thread/, "[perl #124203] the thread ran (lvalue)");
3250
3251     $wrapper->output_like(qr/Finished One/, "[perl #124203] debugger didn't deadlock (lvalue)");
3252 }
3253
3254 {
3255     # https://github.com/Perl/perl5/issues/19198
3256     # this isn't a debugger bug, but a bug in the way perl itself stores cop
3257     # information for lines
3258     my $wrapper = DebugWrap->new(
3259         {
3260             cmds =>
3261             [
3262                 'b Test::AUTOLOAD', # this would crash on ASAN
3263                 'c', # this would fail to stop at the breakpoint
3264                 'q'
3265             ],
3266             prog => \<<'EOS',
3267 package Test;
3268
3269 sub AUTOLOAD {
3270     use vars '$AUTOLOAD';
3271     my $sub = $AUTOLOAD;
3272     return 1;
3273 }
3274
3275 package main;
3276
3277
3278 sub test
3279 {
3280     Test::test();
3281 }
3282
3283 sub test_test
3284 {
3285     eval { test() };
3286 }
3287
3288 test_test();
3289 EOS
3290            }
3291     );
3292     $wrapper->output_unlike(qr/AddressSanitizer/, "[github #19198] no bad access");
3293     $wrapper->contents_like(qr/^Test::AUTOLOAD\(.*?\):\s+\d+:\s+my \$sub = \$AUTOLOAD;/m,
3294                           "[github #19198] check we stopped correctly");
3295 }
3296
3297 done_testing();
3298
3299 END {
3300     1 while unlink ($rc_filename, $out_fn);
3301 }