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