lib/perl5db.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 use strict;
  10 use warnings;
  11 use Config;
  12
  13 BEGIN {
  14     if (! -c "/dev/null") {
  15         print "1..0 # Skip: no /dev/null\n";
  16         exit 0;
  17     }
  18
  19     my $dev_tty = '/dev/tty';
  20     $dev_tty = 'TT:' if ($^O eq 'VMS');
  21     if (! -c $dev_tty) {
  22         print "1..0 # Skip: no $dev_tty\n";
  23         exit 0;
  24     }
  25     if ($ENV{PERL5DB}) {
  26         print "1..0 # Skip: \$ENV{PERL5DB} is already set to '$ENV{PERL5DB}'\n";
  27         exit 0;
  28     }
  29 }
  30
  31 plan(80);
  32
  33 my $rc_filename = '.perldb';
  34
  35 sub rc {
  36     open my $rc_fh, '>', $rc_filename
  37         or die $!;
  38     print {$rc_fh} @_;
  39     close ($rc_fh);
  40
  41     # overly permissive perms gives "Must not source insecure rcfile"
  42     # and hangs at the DB(1> prompt
  43     chmod 0644, $rc_filename;
  44 }
  45
  46 sub _slurp
  47 {
  48     my $filename = shift;
  49
  50     open my $in, '<', $filename
  51         or die "Cannot open '$filename' for slurping - $!";
  52
  53     local $/;
  54     my $contents = <$in>;
  55
  56     close($in);
  57
  58     return $contents;
  59 }
  60
  61 my $out_fn = 'db.out';
  62
  63 sub _out_contents
  64 {
  65     return _slurp($out_fn);
  66 }
  67
  68
  69 # Test for Proxy constants
  70 {
  71     rc(
  72         <<'EOF',
  73
  74 &parse_options("NonStop=0 ReadLine=0 TTY=db.out LineInfo=db.out");
  75
  76 sub afterinit {
  77     push(@DB::typeahead,
  78         'm main->s1',
  79         'q',
  80     );
  81 }
  82
  83 EOF
  84     );
  85
  86     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/proxy-constants');
  87     is($output, "", "proxy constant subroutines");
  88 }
  89
  90 # [perl #66110] Call a subroutine inside a regex
  91 {
  92     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
  93     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
  94     like($output, "All tests successful.", "[perl #66110]");
  95 }
  96
  97 {
  98     rc(<<'EOF');
  99 &parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
 100
 101 sub afterinit {
 102     push (@DB::typeahead,
 103     't 2',
 104     'c',
 105     'q',
 106     );
 107
 108 }
 109 EOF
 110 }
 111
 112 package DebugWrap;
 113
 114 sub new {
 115     my $class = shift;
 116
 117     my $self = bless {}, $class;
 118
 119     $self->_init(@_);
 120
 121     return $self;
 122 }
 123
 124 sub _cmds {
 125     my $self = shift;
 126
 127     if (@_) {
 128         $self->{_cmds} = shift;
 129     }
 130
 131     return $self->{_cmds};
 132 }
 133
 134 sub _prog {
 135     my $self = shift;
 136
 137     if (@_) {
 138         $self->{_prog} = shift;
 139     }
 140
 141     return $self->{_prog};
 142 }
 143
 144 sub _output {
 145     my $self = shift;
 146
 147     if (@_) {
 148         $self->{_output} = shift;
 149     }
 150
 151     return $self->{_output};
 152 }
 153
 154 sub _include_t
 155 {
 156     my $self = shift;
 157
 158     if (@_)
 159     {
 160         $self->{_include_t} = shift;
 161     }
 162
 163     return $self->{_include_t};
 164 }
 165
 166 sub _stderr_val
 167 {
 168     my $self = shift;
 169
 170     if (@_)
 171     {
 172         $self->{_stderr_val} = shift;
 173     }
 174
 175     return $self->{_stderr_val};
 176 }
 177
 178 sub field
 179 {
 180     my $self = shift;
 181
 182     if (@_)
 183     {
 184         $self->{field} = shift;
 185     }
 186
 187     return $self->{field};
 188 }
 189
 190 sub _switches
 191 {
 192     my $self = shift;
 193
 194     if (@_)
 195     {
 196         $self->{_switches} = shift;
 197     }
 198
 199     return $self->{_switches};
 200 }
 201
 202 sub _contents
 203 {
 204     my $self = shift;
 205
 206     if (@_)
 207     {
 208         $self->{_contents} = shift;
 209     }
 210
 211     return $self->{_contents};
 212 }
 213
 214 sub _init
 215 {
 216     my ($self, $args) = @_;
 217
 218     my $cmds = $args->{cmds};
 219
 220     if (ref($cmds) ne 'ARRAY') {
 221         die "cmds must be an array of commands.";
 222     }
 223
 224     $self->_cmds($cmds);
 225
 226     my $prog = $args->{prog};
 227
 228     if (ref($prog) ne '' or !defined($prog)) {
 229         die "prog should be a path to a program file.";
 230     }
 231
 232     $self->_prog($prog);
 233
 234     $self->_include_t($args->{include_t} ? 1 : 0);
 235
 236     $self->_stderr_val(exists($args->{stderr}) ? $args->{stderr} : 1);
 237
 238     if (exists($args->{switches}))
 239     {
 240         $self->_switches($args->{switches});
 241     }
 242
 243     $self->_run();
 244
 245     return;
 246 }
 247
 248 sub _quote
 249 {
 250     my ($self, $str) = @_;
 251
 252     $str =~ s/(["\@\$\\])/\\$1/g;
 253     $str =~ s/\n/\\n/g;
 254     $str =~ s/\r/\\r/g;
 255
 256     return qq{"$str"};
 257 }
 258
 259 sub _run {
 260     my $self = shift;
 261
 262     my $rc = qq{&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");\n};
 263
 264     $rc .= join('',
 265         map { "$_\n"}
 266         (q#sub afterinit {#,
 267          q#push (@DB::typeahead,#,
 268          (map { $self->_quote($_) . "," } @{$self->_cmds()}),
 269          q#);#,
 270          q#}#,
 271         )
 272     );
 273
 274     # I guess two objects like that cannot be used at the same time.
 275     # Oh well.
 276     ::rc($rc);
 277
 278     my $output =
 279         ::runperl(
 280             switches =>
 281             [
 282                 ($self->_switches ? (@{$self->_switches()}) : ('-d')),
 283                 ($self->_include_t ? ('-I', '../lib/perl5db/t') : ())
 284             ],
 285             (defined($self->_stderr_val())
 286                 ? (stderr => $self->_stderr_val())
 287                 : ()
 288             ),
 289             progfile => $self->_prog()
 290         );
 291
 292     $self->_output($output);
 293
 294     $self->_contents(::_out_contents());
 295
 296     return;
 297 }
 298
 299 sub get_output
 300 {
 301     return shift->_output();
 302 }
 303
 304 sub output_like {
 305     my ($self, $re, $msg) = @_;
 306
 307     local $::Level = $::Level + 1;
 308     ::like($self->_output(), $re, $msg);
 309 }
 310
 311 sub output_unlike {
 312     my ($self, $re, $msg) = @_;
 313
 314     local $::Level = $::Level + 1;
 315     ::unlike($self->_output(), $re, $msg);
 316 }
 317
 318 sub contents_like {
 319     my ($self, $re, $msg) = @_;
 320
 321     local $::Level = $::Level + 1;
 322     ::like($self->_contents(), $re, $msg);
 323 }
 324
 325 sub contents_unlike {
 326     my ($self, $re, $msg) = @_;
 327
 328     local $::Level = $::Level + 1;
 329     ::unlike($self->_contents(), $re, $msg);
 330 }
 331
 332 package main;
 333
 334 {
 335     local $ENV{PERLDB_OPTS} = "ReadLine=0";
 336     my $target = '../lib/perl5db/t/eval-line-bug';
 337     my $wrapper = DebugWrap->new(
 338         {
 339             cmds =>
 340             [
 341                 'b 23',
 342                 'n',
 343                 'n',
 344                 'n',
 345                 'c', # line 23
 346                 'n',
 347                 "p \@{'main::_<$target'}",
 348                 'q',
 349             ],
 350             prog => $target,
 351         }
 352     );
 353     $wrapper->contents_like(
 354         qr/sub factorial/,
 355         'The ${main::_<filename} variable in the debugger was not destroyed',
 356     );
 357 }
 358
 359 sub _calc_generic_wrapper
 360 {
 361     my $args = shift;
 362
 363     my $extra_opts = delete($args->{extra_opts});
 364     $extra_opts ||= '';
 365     local $ENV{PERLDB_OPTS} = "ReadLine=0" . $extra_opts;
 366     return DebugWrap->new(
 367         {
 368             cmds => delete($args->{cmds}),
 369             prog => delete($args->{prog}),
 370             %$args,
 371         }
 372     );
 373 }
 374
 375 sub _calc_new_var_wrapper
 376 {
 377     my ($args) = @_;
 378     return _calc_generic_wrapper(
 379         {
 380             cmds =>
 381             [
 382                 'b 23',
 383                 'c',
 384                 '$new_var = "Foo"',
 385                 'x "new_var = <$new_var>\\n"',
 386                 'q',
 387             ],
 388             %$args,
 389         }
 390     );
 391 }
 392
 393 sub _calc_threads_wrapper
 394 {
 395     my $args = shift;
 396
 397     return _calc_new_var_wrapper(
 398         {
 399             switches => [ '-dt', ],
 400             stderr => 1,
 401             %$args
 402         }
 403     );
 404 }
 405
 406 {
 407     _calc_new_var_wrapper({ prog => '../lib/perl5db/t/eval-line-bug'})
 408         ->contents_like(
 409             qr/new_var = <Foo>/,
 410             "no strict 'vars' in evaluated lines.",
 411         );
 412 }
 413
 414 {
 415     _calc_new_var_wrapper(
 416         {
 417             prog => '../lib/perl5db/t/lvalue-bug',
 418             stderr => undef(),
 419         },
 420     )->output_like(
 421             qr/foo is defined/,
 422              'lvalue subs work in the debugger',
 423          );
 424 }
 425
 426 {
 427     _calc_new_var_wrapper(
 428         {
 429             prog =>  '../lib/perl5db/t/symbol-table-bug',
 430             extra_opts => "NonStop=1",
 431             stderr => undef(),
 432         }
 433     )->output_like(
 434         qr/Undefined symbols 0/,
 435         'there are no undefined values in the symbol table',
 436     );
 437 }
 438
 439 SKIP:
 440 {
 441     if ( $Config{usethreads} ) {
 442         skip('This perl has threads, skipping non-threaded debugger tests');
 443     }
 444     else {
 445         my $error = 'This Perl not built to support threads';
 446         _calc_threads_wrapper(
 447             {
 448                 prog => '../lib/perl5db/t/eval-line-bug',
 449             }
 450         )->output_like(
 451             qr/\Q$error\E/,
 452             'Perl debugger correctly complains that it was not built with threads',
 453         );
 454     }
 455 }
 456
 457 SKIP:
 458 {
 459     if ( $Config{usethreads} ) {
 460         _calc_threads_wrapper(
 461             {
 462                 prog =>  '../lib/perl5db/t/symbol-table-bug',
 463             }
 464         )->output_like(
 465             qr/Undefined symbols 0/,
 466             'there are no undefined values in the symbol table when running with thread support',
 467         );
 468     }
 469     else {
 470         skip("This perl is not threaded, skipping threaded debugger tests");
 471     }
 472 }
 473
 474 # Test [perl #61222]
 475 {
 476     local $ENV{PERLDB_OPTS};
 477     my $wrapper = DebugWrap->new(
 478         {
 479             cmds =>
 480             [
 481                 'm Pie',
 482                 'q',
 483             ],
 484             prog => '../lib/perl5db/t/rt-61222',
 485         }
 486     );
 487
 488     $wrapper->contents_unlike(qr/INCORRECT/, "[perl #61222]");
 489 }
 490
 491 sub _calc_trace_wrapper
 492 {
 493     my ($args) = @_;
 494
 495     return _calc_generic_wrapper(
 496         {
 497             cmds =>
 498             [
 499                 't 2',
 500                 'c',
 501                 'q',
 502             ],
 503             %$args,
 504         }
 505     );
 506 }
 507
 508 # [perl 104168] level option for tracing
 509 {
 510     my $wrapper = _calc_trace_wrapper({ prog =>  '../lib/perl5db/t/rt-104168' });
 511     $wrapper->contents_like(qr/level 2/, "[perl #104168] - level 2 appears");
 512     $wrapper->contents_unlike(qr/baz/, "[perl #104168] - no 'baz'");
 513 }
 514
 515 # taint tests
 516 {
 517     my $wrapper = _calc_trace_wrapper(
 518         {
 519             prog => '../lib/perl5db/t/taint',
 520             extra_opts => ' NonStop=1',
 521             switches => [ '-d', '-T', ],
 522         }
 523     );
 524
 525     my $output = $wrapper->get_output();
 526     chomp $output if $^O eq 'VMS'; # newline guaranteed at EOF
 527     is($output, '[$^X][done]', "taint");
 528 }
 529
 530 # Testing that we can set a line in the middle of the file.
 531 {
 532     my $wrapper = DebugWrap->new(
 533         {
 534             cmds =>
 535             [
 536                 'b ../lib/perl5db/t/MyModule.pm:12',
 537                 'c',
 538                 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
 539                 'c',
 540                 'q',
 541             ],
 542             include_t => 1,
 543             prog => '../lib/perl5db/t/filename-line-breakpoint'
 544         }
 545     );
 546
 547     $wrapper->output_like(qr/
 548         ^Var=Bar$
 549             .*
 550         ^In\ MyModule\.$
 551             .*
 552         ^In\ Main\ File\.$
 553             .*
 554         /msx,
 555         "Can set breakpoint in a line in the middle of the file.");
 556 }
 557
 558 # Testing that we can set a breakpoint
 559 {
 560     my $wrapper = DebugWrap->new(
 561         {
 562             prog => '../lib/perl5db/t/breakpoint-bug',
 563             cmds =>
 564             [
 565                 'b 6',
 566                 'c',
 567                 q/do { use IO::Handle; STDOUT->autoflush(1); print "X={$x}\n"; }/,
 568                 'c',
 569                 'q',
 570             ],
 571         },
 572     );
 573
 574     $wrapper->output_like(
 575         qr/X=\{Two\}/msx,
 576         "Can set breakpoint in a line."
 577     );
 578 }
 579
 580 # Testing that we can disable a breakpoint at a numeric line.
 581 {
 582     my $wrapper = DebugWrap->new(
 583         {
 584             prog =>  '../lib/perl5db/t/disable-breakpoints-1',
 585             cmds =>
 586             [
 587                 'b 7',
 588                 'b 11',
 589                 'disable 7',
 590                 'c',
 591                 q/print "X={$x}\n";/,
 592                 'c',
 593                 'q',
 594             ],
 595         }
 596     );
 597
 598     $wrapper->output_like(qr/X=\{SecondVal\}/ms,
 599         "Can set breakpoint in a line.");
 600 }
 601
 602 # Testing that we can re-enable a breakpoint at a numeric line.
 603 {
 604     my $wrapper = DebugWrap->new(
 605         {
 606             prog =>  '../lib/perl5db/t/disable-breakpoints-2',
 607             cmds =>
 608             [
 609                 'b 8',
 610                 'b 24',
 611                 'disable 24',
 612                 'c',
 613                 'enable 24',
 614                 'c',
 615                 q/print "X={$x}\n";/,
 616                 'c',
 617                 'q',
 618             ],
 619         },
 620     );
 621
 622     $wrapper->output_like(
 623         qr/
 624         X=\{SecondValOneHundred\}
 625         /msx,
 626         "Can set breakpoint in a line."
 627     );
 628 }
 629 # clean up.
 630
 631 # Disable and enable for breakpoints on outer files.
 632 {
 633     my $wrapper = DebugWrap->new(
 634         {
 635             cmds =>
 636             [
 637                 'b 10',
 638                 'b ../lib/perl5db/t/EnableModule.pm:14',
 639                 'disable ../lib/perl5db/t/EnableModule.pm:14',
 640                 'c',
 641                 'enable ../lib/perl5db/t/EnableModule.pm:14',
 642                 'c',
 643                 q/print "X={$x}\n";/,
 644                 'c',
 645                 'q',
 646             ],
 647             prog =>  '../lib/perl5db/t/disable-breakpoints-3',
 648             include_t => 1,
 649         }
 650     );
 651
 652     $wrapper->output_like(qr/
 653         X=\{SecondValTwoHundred\}
 654         /msx,
 655         "Can set breakpoint in a line.");
 656 }
 657
 658 # Testing that the prompt with the information appears.
 659 {
 660     my $wrapper = DebugWrap->new(
 661         {
 662             cmds => ['q'],
 663             prog => '../lib/perl5db/t/disable-breakpoints-1',
 664         }
 665     );
 666
 667     $wrapper->contents_like(qr/
 668         ^main::\([^\)]*\bdisable-breakpoints-1:2\):\n
 669         2:\s+my\ \$x\ =\ "One";\n
 670         /msx,
 671         "Prompt should display the first line of code.");
 672 }
 673
 674 # Testing that R (restart) and "B *" work.
 675 {
 676     my $wrapper = DebugWrap->new(
 677         {
 678             cmds =>
 679             [
 680                 'b 13',
 681                 'c',
 682                 'B *',
 683                 'b 9',
 684                 'R',
 685                 'c',
 686                 q/print "X={$x};dummy={$dummy}\n";/,
 687                 'q',
 688             ],
 689             prog =>  '../lib/perl5db/t/disable-breakpoints-1',
 690         }
 691     );
 692
 693     $wrapper->output_like(qr/
 694         X=\{FirstVal\};dummy=\{1\}
 695         /msx,
 696         "Restart and delete all breakpoints work properly.");
 697 }
 698
 699 {
 700     my $wrapper = DebugWrap->new(
 701         {
 702             cmds =>
 703             [
 704                 'c 15',
 705                 q/print "X={$x}\n";/,
 706                 'c',
 707                 'q',
 708             ],
 709             prog =>  '../lib/perl5db/t/disable-breakpoints-1',
 710         }
 711     );
 712
 713     $wrapper->output_like(qr/
 714         X=\{ThirdVal\}
 715         /msx,
 716         "'c line_num' is working properly.");
 717 }
 718
 719 {
 720     my $wrapper = DebugWrap->new(
 721         {
 722             cmds =>
 723             [
 724                 'n',
 725                 'n',
 726                 'b . $exp > 200',
 727                 'c',
 728                 q/print "Exp={$exp}\n";/,
 729                 'q',
 730             ],
 731             prog => '../lib/perl5db/t/break-on-dot',
 732         }
 733     );
 734
 735     $wrapper->output_like(qr/
 736         Exp=\{256\}
 737         /msx,
 738         "'b .' is working correctly.");
 739 }
 740
 741 # Testing that the prompt with the information appears inside a subroutine call.
 742 # See https://rt.perl.org/rt3/Ticket/Display.html?id=104820
 743 {
 744     my $wrapper = DebugWrap->new(
 745         {
 746             cmds =>
 747             [
 748                 'c back',
 749                 'q',
 750             ],
 751             prog => '../lib/perl5db/t/with-subroutine',
 752         }
 753     );
 754
 755     $wrapper->contents_like(
 756         qr/
 757         ^main::back\([^\)\n]*\bwith-subroutine:15\):[\ \t]*\n
 758         ^15:\s*print\ "hello\ back\\n";
 759         /msx,
 760         "Prompt should display the line of code inside a subroutine.");
 761 }
 762
 763 # Checking that the p command works.
 764 {
 765     my $wrapper = DebugWrap->new(
 766         {
 767             cmds =>
 768             [
 769                 'p "<<<" . (4*6) . ">>>"',
 770                 'q',
 771             ],
 772             prog => '../lib/perl5db/t/with-subroutine',
 773         }
 774     );
 775
 776     $wrapper->contents_like(
 777         qr/<<<24>>>/,
 778         "p command works.");
 779 }
 780
 781 # Tests for x.
 782 {
 783     my $wrapper = DebugWrap->new(
 784         {
 785             cmds =>
 786             [
 787                 q/x {500 => 600}/,
 788                 'q',
 789             ],
 790             prog => '../lib/perl5db/t/with-subroutine',
 791         }
 792     );
 793
 794     $wrapper->contents_like(
 795         # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
 796         qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/ms,
 797         "x command test."
 798     );
 799 }
 800
 801 # Tests for "T" (stack trace).
 802 {
 803     my $prog_fn = '../lib/perl5db/t/rt-104168';
 804     my $wrapper = DebugWrap->new(
 805         {
 806             prog => $prog_fn,
 807             cmds =>
 808             [
 809                 'c baz',
 810                 'T',
 811                 'q',
 812             ],
 813         }
 814     );
 815     my $re_text = join('',
 816         map {
 817         sprintf(
 818             "%s = %s\\(\\) called from file " .
 819             "'" . quotemeta($prog_fn) . "' line %s\\n",
 820             (map { quotemeta($_) } @$_)
 821             )
 822         }
 823         (
 824             ['.', 'main::baz', 14,],
 825             ['.', 'main::bar', 9,],
 826             ['.', 'main::foo', 6],
 827         )
 828     );
 829     $wrapper->contents_like(
 830         # qr/^0\s+HASH\([^\)]+\)\n\s+500 => 600\n/,
 831         qr/^$re_text/ms,
 832         "T command test."
 833     );
 834 }
 835
 836 # Test for s.
 837 {
 838     my $wrapper = DebugWrap->new(
 839         {
 840             cmds =>
 841             [
 842                 'b 9',
 843                 'c',
 844                 's',
 845                 q/print "X={$x};dummy={$dummy}\n";/,
 846                 'q',
 847             ],
 848             prog => '../lib/perl5db/t/disable-breakpoints-1'
 849         }
 850     );
 851
 852     $wrapper->output_like(qr/
 853         X=\{SecondVal\};dummy=\{1\}
 854         /msx,
 855         'test for s - single step',
 856     );
 857 }
 858
 859 {
 860     my $wrapper = DebugWrap->new(
 861         {
 862             cmds =>
 863             [
 864                 'n',
 865                 'n',
 866                 'b . $exp > 200',
 867                 'c',
 868                 q/print "Exp={$exp}\n";/,
 869                 'q',
 870             ],
 871             prog => '../lib/perl5db/t/break-on-dot'
 872         }
 873     );
 874
 875     $wrapper->output_like(qr/
 876         Exp=\{256\}
 877         /msx,
 878         "'b .' is working correctly.");
 879 }
 880
 881 {
 882     my $prog_fn = '../lib/perl5db/t/rt-104168';
 883     my $wrapper = DebugWrap->new(
 884         {
 885             cmds =>
 886             [
 887                 's',
 888                 'q',
 889             ],
 890             prog => $prog_fn,
 891         }
 892     );
 893
 894     $wrapper->contents_like(
 895         qr/
 896         ^main::foo\([^\)\n]*\brt-104168:9\):[\ \t]*\n
 897         ^9:\s*bar\(\);
 898         /msx,
 899         'Test for the s command.',
 900     );
 901 }
 902
 903 {
 904     my $wrapper = DebugWrap->new(
 905         {
 906             cmds =>
 907             [
 908                 's uncalled_subroutine()',
 909                 'c',
 910                 'q',
 911             ],
 912
 913             prog => '../lib/perl5db/t/uncalled-subroutine'}
 914     );
 915
 916     $wrapper->output_like(
 917         qr/<1,2,3,4,5>\n/,
 918         'uncalled_subroutine was called after s EXPR()',
 919         );
 920 }
 921
 922 {
 923     my $wrapper = DebugWrap->new(
 924         {
 925             cmds =>
 926             [
 927                 'n uncalled_subroutine()',
 928                 'c',
 929                 'q',
 930             ],
 931             prog => '../lib/perl5db/t/uncalled-subroutine',
 932         }
 933     );
 934
 935     $wrapper->output_like(
 936         qr/<1,2,3,4,5>\n/,
 937         'uncalled_subroutine was called after n EXPR()',
 938         );
 939 }
 940
 941 {
 942     my $wrapper = DebugWrap->new(
 943         {
 944             cmds =>
 945             [
 946                 'b fact',
 947                 'c',
 948                 'c',
 949                 'c',
 950                 'n',
 951                 'print "<$n>"',
 952                 'q',
 953             ],
 954             prog => '../lib/perl5db/t/fact',
 955         }
 956     );
 957
 958     $wrapper->output_like(
 959         qr/<3>/,
 960         'b subroutine works fine',
 961     );
 962 }
 963
 964 # Test for 'M' (module list).
 965 {
 966     my $wrapper = DebugWrap->new(
 967         {
 968             cmds =>
 969             [
 970                 'M',
 971                 'q',
 972             ],
 973             prog => '../lib/perl5db/t/load-modules'
 974         }
 975     );
 976
 977     $wrapper->contents_like(
 978         qr[Scalar/Util\.pm],
 979         'M (module list) works fine',
 980     );
 981 }
 982
 983 {
 984     my $wrapper = DebugWrap->new(
 985         {
 986             cmds =>
 987             [
 988                 'b 14',
 989                 'c',
 990                 '$flag = 1;',
 991                 'r',
 992                 'print "Var=$var\n";',
 993                 'q',
 994             ],
 995             prog => '../lib/perl5db/t/test-r-statement',
 996         }
 997     );
 998
 999     $wrapper->output_like(
1000         qr/
1001             ^Foo$
1002                 .*?
1003             ^Bar$
1004                 .*?
1005             ^Var=Test$
1006         /msx,
1007         'r statement is working properly.',
1008     );
1009 }
1010
1011 {
1012     my $wrapper = DebugWrap->new(
1013         {
1014             cmds =>
1015             [
1016                 'l',
1017                 'q',
1018             ],
1019             prog => '../lib/perl5db/t/test-l-statement-1',
1020         }
1021     );
1022
1023     $wrapper->contents_like(
1024         qr/
1025             ^1==>\s+\$x\ =\ 1;\n
1026             2:\s+print\ "1\\n";\n
1027             3\s*\n
1028             4:\s+\$x\ =\ 2;\n
1029             5:\s+print\ "2\\n";\n
1030         /msx,
1031         'l statement is working properly (test No. 1).',
1032     );
1033 }
1034
1035 {
1036     my $wrapper = DebugWrap->new(
1037         {
1038             cmds =>
1039             [
1040                 'l',
1041                 q/# After l 1/,
1042                 'l',
1043                 q/# After l 2/,
1044                 '-',
1045                 q/# After -/,
1046                 'q',
1047             ],
1048             prog => '../lib/perl5db/t/test-l-statement-1',
1049         }
1050     );
1051
1052     my $first_l_out = qr/
1053         1==>\s+\$x\ =\ 1;\n
1054         2:\s+print\ "1\\n";\n
1055         3\s*\n
1056         4:\s+\$x\ =\ 2;\n
1057         5:\s+print\ "2\\n";\n
1058         6\s*\n
1059         7:\s+\$x\ =\ 3;\n
1060         8:\s+print\ "3\\n";\n
1061         9\s*\n
1062         10:\s+\$x\ =\ 4;\n
1063     /msx;
1064
1065     my $second_l_out = qr/
1066         11:\s+print\ "4\\n";\n
1067         12\s*\n
1068         13:\s+\$x\ =\ 5;\n
1069         14:\s+print\ "5\\n";\n
1070         15\s*\n
1071         16:\s+\$x\ =\ 6;\n
1072         17:\s+print\ "6\\n";\n
1073         18\s*\n
1074         19:\s+\$x\ =\ 7;\n
1075         20:\s+print\ "7\\n";\n
1076     /msx;
1077     $wrapper->contents_like(
1078         qr/
1079             ^$first_l_out
1080             [^\n]*?DB<\d+>\ \#\ After\ l\ 1\n
1081             [\ \t]*\n
1082             [^\n]*?DB<\d+>\ l\s*\n
1083             $second_l_out
1084             [^\n]*?DB<\d+>\ \#\ After\ l\ 2\n
1085             [\ \t]*\n
1086             [^\n]*?DB<\d+>\ -\s*\n
1087             $first_l_out
1088             [^\n]*?DB<\d+>\ \#\ After\ -\n
1089         /msx,
1090         'l followed by l and then followed by -',
1091     );
1092 }
1093
1094 {
1095     my $wrapper = DebugWrap->new(
1096         {
1097             cmds =>
1098             [
1099                 'l fact',
1100                 'q',
1101             ],
1102             prog => '../lib/perl5db/t/test-l-statement-2',
1103         }
1104     );
1105
1106     my $first_l_out = qr/
1107         6\s+sub\ fact\ \{\n
1108         7:\s+my\ \$n\ =\ shift;\n
1109         8:\s+if\ \(\$n\ >\ 1\)\ \{\n
1110         9:\s+return\ \$n\ \*\ fact\(\$n\ -\ 1\);
1111     /msx;
1112
1113     $wrapper->contents_like(
1114         qr/
1115             DB<1>\s+l\ fact\n
1116             $first_l_out
1117         /msx,
1118         'l subroutine_name',
1119     );
1120 }
1121
1122 {
1123     my $wrapper = DebugWrap->new(
1124         {
1125             cmds =>
1126             [
1127                 'b fact',
1128                 'c',
1129                 # Repeat several times to avoid @typeahead problems.
1130                 '.',
1131                 '.',
1132                 '.',
1133                 '.',
1134                 'q',
1135             ],
1136             prog => '../lib/perl5db/t/test-l-statement-2',
1137         }
1138     );
1139
1140     my $line_out = qr /
1141         ^main::fact\([^\n]*?:7\):\n
1142         ^7:\s+my\ \$n\ =\ shift;\n
1143     /msx;
1144
1145     $wrapper->contents_like(
1146         qr/
1147             $line_out
1148             $line_out
1149         /msx,
1150         'Test the "." command',
1151     );
1152 }
1153
1154 # Testing that the f command works.
1155 {
1156     my $wrapper = DebugWrap->new(
1157         {
1158             cmds =>
1159             [
1160                 'f ../lib/perl5db/t/MyModule.pm',
1161                 'b 12',
1162                 'c',
1163                 q/do { use IO::Handle; STDOUT->autoflush(1); print "Var=$var\n"; }/,
1164                 'c',
1165                 'q',
1166             ],
1167             include_t => 1,
1168             prog => '../lib/perl5db/t/filename-line-breakpoint'
1169         }
1170     );
1171
1172     $wrapper->output_like(qr/
1173         ^Var=Bar$
1174             .*
1175         ^In\ MyModule\.$
1176             .*
1177         ^In\ Main\ File\.$
1178             .*
1179         /msx,
1180         "f command is working.",
1181     );
1182 }
1183
1184 # We broke the /pattern/ command because apparently the CORE::eval-s inside
1185 # lib/perl5db.pl cannot handle lexical variable properly. So we now fix this
1186 # bug.
1187 #
1188 # TODO :
1189 #
1190 # 1. Go over the rest of the "eval"s in lib/perl5db.t and see if they cause
1191 # problems.
1192 {
1193     my $wrapper = DebugWrap->new(
1194         {
1195             cmds =>
1196             [
1197                 '/for/',
1198                 'q',
1199             ],
1200             prog => '../lib/perl5db/t/eval-line-bug',
1201         }
1202     );
1203
1204     $wrapper->contents_like(
1205         qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1206         "/pat/ command is working and found a match.",
1207     );
1208 }
1209
1210 {
1211     my $wrapper = DebugWrap->new(
1212         {
1213             cmds =>
1214             [
1215                 'b 22',
1216                 'c',
1217                 '?for?',
1218                 'q',
1219             ],
1220             prog => '../lib/perl5db/t/eval-line-bug',
1221         }
1222     );
1223
1224     $wrapper->contents_like(
1225         qr/12: \s* for\ my\ \$q\ \(1\ \.\.\ 10\)\ \{/msx,
1226         "?pat? command is working and found a match.",
1227     );
1228 }
1229
1230 # Test the L command.
1231 {
1232     my $wrapper = DebugWrap->new(
1233         {
1234             cmds =>
1235             [
1236                 'b 6',
1237                 'b 13 ($q == 5)',
1238                 'L',
1239                 'q',
1240             ],
1241             prog => '../lib/perl5db/t/eval-line-bug',
1242         }
1243     );
1244
1245     $wrapper->contents_like(
1246         qr#
1247         ^\S*?eval-line-bug:\n
1248         \s*6:\s*my\ \$i\ =\ 5;\n
1249         \s*break\ if\ \(1\)\n
1250         \s*13:\s*\$i\ \+=\ \$q;\n
1251         \s*break\ if\ \(\(\$q\ ==\ 5\)\)\n
1252         #msx,
1253         "L command is listing breakpoints",
1254     );
1255 }
1256
1257 # Test the L command for watch expressions.
1258 {
1259     my $wrapper = DebugWrap->new(
1260         {
1261             cmds =>
1262             [
1263                 'w (5+6)',
1264                 'L',
1265                 'q',
1266             ],
1267             prog => '../lib/perl5db/t/eval-line-bug',
1268         }
1269     );
1270
1271     $wrapper->contents_like(
1272         qr#
1273         ^Watch-expressions:\n
1274         \s*\(5\+6\)\n
1275         #msx,
1276         "L command is listing watch expressions",
1277     );
1278 }
1279
1280 {
1281     my $wrapper = DebugWrap->new(
1282         {
1283             cmds =>
1284             [
1285                 'w (5+6)',
1286                 'w (11*23)',
1287                 'W (5+6)',
1288                 'L',
1289                 'q',
1290             ],
1291             prog => '../lib/perl5db/t/eval-line-bug',
1292         }
1293     );
1294
1295     $wrapper->contents_like(
1296         qr#
1297         ^Watch-expressions:\n
1298         \s*\(11\*23\)\n
1299         ^auto\(
1300         #msx,
1301         "L command is not listing deleted watch expressions",
1302     );
1303 }
1304
1305 # Test the L command.
1306 {
1307     my $wrapper = DebugWrap->new(
1308         {
1309             cmds =>
1310             [
1311                 'b 6',
1312                 'a 13 print $i',
1313                 'L',
1314                 'q',
1315             ],
1316             prog => '../lib/perl5db/t/eval-line-bug',
1317         }
1318     );
1319
1320     $wrapper->contents_like(
1321         qr#
1322         ^\S*?eval-line-bug:\n
1323         \s*6:\s*my\ \$i\ =\ 5;\n
1324         \s*break\ if\ \(1\)\n
1325         \s*13:\s*\$i\ \+=\ \$q;\n
1326         \s*action:\s+print\ \$i\n
1327         #msx,
1328         "L command is listing actions and breakpoints",
1329     );
1330 }
1331
1332 {
1333     my $wrapper = DebugWrap->new(
1334         {
1335             cmds =>
1336             [
1337                 'S',
1338                 'q',
1339             ],
1340             prog =>  '../lib/perl5db/t/rt-104168',
1341         }
1342     );
1343
1344     $wrapper->contents_like(
1345         qr#
1346         ^main::bar\n
1347         main::baz\n
1348         main::foo\n
1349         #msx,
1350         "S command - 1",
1351     );
1352 }
1353
1354 {
1355     my $wrapper = DebugWrap->new(
1356         {
1357             cmds =>
1358             [
1359                 'S ^main::ba',
1360                 'q',
1361             ],
1362             prog =>  '../lib/perl5db/t/rt-104168',
1363         }
1364     );
1365
1366     $wrapper->contents_like(
1367         qr#
1368         ^main::bar\n
1369         main::baz\n
1370         auto\(
1371         #msx,
1372         "S command with regex",
1373     );
1374 }
1375
1376 {
1377     my $wrapper = DebugWrap->new(
1378         {
1379             cmds =>
1380             [
1381                 'S !^main::ba',
1382                 'q',
1383             ],
1384             prog =>  '../lib/perl5db/t/rt-104168',
1385         }
1386     );
1387
1388     $wrapper->contents_unlike(
1389         qr#
1390         ^main::ba
1391         #msx,
1392         "S command with negative regex",
1393     );
1394
1395     $wrapper->contents_like(
1396         qr#
1397         ^main::foo\n
1398         #msx,
1399         "S command with negative regex - what it still matches",
1400     );
1401 }
1402
1403 # Test the a command.
1404 {
1405     my $wrapper = DebugWrap->new(
1406         {
1407             cmds =>
1408             [
1409                 'a 13 print "\nVar<Q>=$q\n"',
1410                 'c',
1411                 'q',
1412             ],
1413             prog => '../lib/perl5db/t/eval-line-bug',
1414         }
1415     );
1416
1417     $wrapper->output_like(qr#
1418         \nVar<Q>=1\n
1419         \nVar<Q>=2\n
1420         \nVar<Q>=3\n
1421         #msx,
1422         "a command is working",
1423     );
1424 }
1425
1426 # Test the 'A' command
1427 {
1428     my $wrapper = DebugWrap->new(
1429         {
1430             cmds =>
1431             [
1432                 'a 13 print "\nVar<Q>=$q\n"',
1433                 'A 13',
1434                 'c',
1435                 'q',
1436             ],
1437             prog => '../lib/perl5db/t/eval-line-bug',
1438         }
1439     );
1440
1441     $wrapper->output_like(
1442         qr#\A\z#msx, # The empty string.
1443         "A command (for removing actions) is working",
1444     );
1445 }
1446
1447 # Test the 'A *' command
1448 {
1449     my $wrapper = DebugWrap->new(
1450         {
1451             cmds =>
1452             [
1453                 'a 6 print "\nFail!\n"',
1454                 'a 13 print "\nVar<Q>=$q\n"',
1455                 'A *',
1456                 'c',
1457                 'q',
1458             ],
1459             prog => '../lib/perl5db/t/eval-line-bug',
1460         }
1461     );
1462
1463     $wrapper->output_like(
1464         qr#\A\z#msx, # The empty string.
1465         "'A *' command (for removing all actions) is working",
1466     );
1467 }
1468
1469 {
1470     my $wrapper = DebugWrap->new(
1471         {
1472             cmds =>
1473             [
1474                 'n',
1475                 'w $foo',
1476                 'c',
1477                 'print "\nIDX=<$idx>\n"',
1478                 'q',
1479             ],
1480             prog => '../lib/perl5db/t/test-w-statement-1',
1481         }
1482     );
1483
1484
1485     $wrapper->contents_like(qr#
1486         \$foo\ changed:\n
1487         \s+old\ value:\s+'1'\n
1488         \s+new\ value:\s+'2'\n
1489         #msx,
1490         'w command - watchpoint changed',
1491     );
1492     $wrapper->output_like(qr#
1493         \nIDX=<20>\n
1494         #msx,
1495         "w command - correct output from IDX",
1496     );
1497 }
1498
1499 {
1500     my $wrapper = DebugWrap->new(
1501         {
1502             cmds =>
1503             [
1504                 'n',
1505                 'w $foo',
1506                 'W $foo',
1507                 'c',
1508                 'print "\nIDX=<$idx>\n"',
1509                 'q',
1510             ],
1511             prog => '../lib/perl5db/t/test-w-statement-1',
1512         }
1513     );
1514
1515     $wrapper->contents_unlike(qr#
1516         \$foo\ changed:
1517         #msx,
1518         'W command - watchpoint was deleted',
1519     );
1520
1521     $wrapper->output_like(qr#
1522         \nIDX=<>\n
1523         #msx,
1524         "W command - stopped at end.",
1525     );
1526 }
1527
1528 # Test the W * command.
1529 {
1530     my $wrapper = DebugWrap->new(
1531         {
1532             cmds =>
1533             [
1534                 'n',
1535                 'w $foo',
1536                 'w ($foo*$foo)',
1537                 'W *',
1538                 'c',
1539                 'print "\nIDX=<$idx>\n"',
1540                 'q',
1541             ],
1542             prog => '../lib/perl5db/t/test-w-statement-1',
1543         }
1544     );
1545
1546     $wrapper->contents_unlike(qr#
1547         \$foo\ changed:
1548         #msx,
1549         '"W *" command - watchpoint was deleted',
1550     );
1551
1552     $wrapper->output_like(qr#
1553         \nIDX=<>\n
1554         #msx,
1555         '"W *" command - stopped at end.',
1556     );
1557 }
1558
1559 # Test the 'o' command (without further arguments).
1560 {
1561     my $wrapper = DebugWrap->new(
1562         {
1563             cmds =>
1564             [
1565                 'o',
1566                 'q',
1567             ],
1568             prog => '../lib/perl5db/t/test-w-statement-1',
1569         }
1570     );
1571
1572     $wrapper->contents_like(qr#
1573         ^\s*warnLevel\ =\ '1'\n
1574         #msx,
1575         q#"o" command (without arguments) displays warnLevel#,
1576     );
1577
1578     $wrapper->contents_like(qr#
1579         ^\s*signalLevel\ =\ '1'\n
1580         #msx,
1581         q#"o" command (without arguments) displays signalLevel#,
1582     );
1583
1584     $wrapper->contents_like(qr#
1585         ^\s*dieLevel\ =\ '1'\n
1586         #msx,
1587         q#"o" command (without arguments) displays dieLevel#,
1588     );
1589
1590     $wrapper->contents_like(qr#
1591         ^\s*hashDepth\ =\ 'N/A'\n
1592         #msx,
1593         q#"o" command (without arguments) displays hashDepth#,
1594     );
1595 }
1596
1597 # Test the 'o' query command.
1598 {
1599     my $wrapper = DebugWrap->new(
1600         {
1601             cmds =>
1602             [
1603                 'o hashDepth? signalLevel?',
1604                 'q',
1605             ],
1606             prog => '../lib/perl5db/t/test-w-statement-1',
1607         }
1608     );
1609
1610     $wrapper->contents_unlike(qr#warnLevel#,
1611         q#"o" query command does not display warnLevel#,
1612     );
1613
1614     $wrapper->contents_like(qr#
1615         ^\s*signalLevel\ =\ '1'\n
1616         #msx,
1617         q#"o" query command displays signalLevel#,
1618     );
1619
1620     $wrapper->contents_unlike(qr#dieLevel#,
1621         q#"o" query command does not display dieLevel#,
1622     );
1623
1624     $wrapper->contents_like(qr#
1625         ^\s*hashDepth\ =\ 'N/A'\n
1626         #msx,
1627         q#"o" query command displays hashDepth#,
1628     );
1629 }
1630
1631 # Test the 'o' set command.
1632 {
1633     my $wrapper = DebugWrap->new(
1634         {
1635             cmds =>
1636             [
1637                 'o signalLevel=0',
1638                 'o',
1639                 'q',
1640             ],
1641             prog => '../lib/perl5db/t/test-w-statement-1',
1642         }
1643     );
1644
1645     $wrapper->contents_like(qr/
1646         ^\s*(signalLevel\ =\ '0'\n)
1647         .*?
1648         ^\s*\1
1649         /msx,
1650         q#o set command works#,
1651     );
1652
1653     $wrapper->contents_like(qr#
1654         ^\s*hashDepth\ =\ 'N/A'\n
1655         #msx,
1656         q#o set command - hashDepth#,
1657     );
1658 }
1659
1660 # Test the '<' and "< ?" commands.
1661 {
1662     my $wrapper = DebugWrap->new(
1663         {
1664             cmds =>
1665             [
1666                 q/< print "\nX=<$x>\n"/,
1667                 q/b 7/,
1668                 q/< ?/,
1669                 'c',
1670                 'q',
1671             ],
1672             prog => '../lib/perl5db/t/disable-breakpoints-1',
1673         }
1674     );
1675
1676     $wrapper->contents_like(qr/
1677         ^pre-perl\ commands:\n
1678         \s*<\ --\ print\ "\\nX=<\$x>\\n"\n
1679         /msx,
1680         q#Test < and < ? commands - contents.#,
1681     );
1682
1683     $wrapper->output_like(qr#
1684         ^X=<FirstVal>\n
1685         #msx,
1686         q#Test < and < ? commands - output.#,
1687     );
1688 }
1689
1690 # Test the '< *' command.
1691 {
1692     my $wrapper = DebugWrap->new(
1693         {
1694             cmds =>
1695             [
1696                 q/< print "\nX=<$x>\n"/,
1697                 q/b 7/,
1698                 q/< */,
1699                 'c',
1700                 'q',
1701             ],
1702             prog => '../lib/perl5db/t/disable-breakpoints-1',
1703         }
1704     );
1705
1706     $wrapper->output_unlike(qr/FirstVal/,
1707         q#Test the '< *' command.#,
1708     );
1709 }
1710
1711 # Test the '>' and "> ?" commands.
1712 {
1713     my $wrapper = DebugWrap->new(
1714         {
1715             cmds =>
1716             [
1717                 q/$::foo = 500;/,
1718                 q/> print "\nFOO=<$::foo>\n"/,
1719                 q/b 7/,
1720                 q/> ?/,
1721                 'c',
1722                 'q',
1723             ],
1724             prog => '../lib/perl5db/t/disable-breakpoints-1',
1725         }
1726     );
1727
1728     $wrapper->contents_like(qr/
1729         ^post-perl\ commands:\n
1730         \s*>\ --\ print\ "\\nFOO=<\$::foo>\\n"\n
1731         /msx,
1732         q#Test > and > ? commands - contents.#,
1733     );
1734
1735     $wrapper->output_like(qr#
1736         ^FOO=<500>\n
1737         #msx,
1738         q#Test > and > ? commands - output.#,
1739     );
1740 }
1741
1742 # Test the '> *' command.
1743 {
1744     my $wrapper = DebugWrap->new(
1745         {
1746             cmds =>
1747             [
1748                 q/> print "\nFOO=<$::foo>\n"/,
1749                 q/b 7/,
1750                 q/> */,
1751                 'c',
1752                 'q',
1753             ],
1754             prog => '../lib/perl5db/t/disable-breakpoints-1',
1755         }
1756     );
1757
1758     $wrapper->output_unlike(qr/FOO=/,
1759         q#Test the '> *' command.#,
1760     );
1761 }
1762
1763 # Test the < and > commands together
1764 {
1765     my $wrapper = DebugWrap->new(
1766         {
1767             cmds =>
1768             [
1769                 q/$::lorem = 0;/,
1770                 q/< $::lorem += 10;/,
1771                 q/> print "\nLOREM=<$::lorem>\n"/,
1772                 q/b 7/,
1773                 q/b 5/,
1774                 'c',
1775                 'c',
1776                 'q',
1777             ],
1778             prog => '../lib/perl5db/t/disable-breakpoints-1',
1779         }
1780     );
1781
1782     $wrapper->output_like(qr#
1783         ^LOREM=<10>\n
1784         #msx,
1785         q#Test < and > commands. #,
1786     );
1787 }
1788
1789 # Test the { ? and { [command] commands.
1790 {
1791     my $wrapper = DebugWrap->new(
1792         {
1793             cmds =>
1794             [
1795                 '{ ?',
1796                 '{ l',
1797                 '{ ?',
1798                 q/b 5/,
1799                 q/c/,
1800                 q/q/,
1801             ],
1802             prog => '../lib/perl5db/t/disable-breakpoints-1',
1803         }
1804     );
1805
1806     $wrapper->contents_like(qr#
1807         ^No\ pre-debugger\ actions\.\n
1808         .*?
1809         ^pre-debugger\ commands:\n
1810         \s+\{\ --\ l\n
1811         .*?
1812         ^5==>b\s+\$x\ =\ "FirstVal";\n
1813         6\s*\n
1814         7:\s+\$dummy\+\+;\n
1815         8\s*\n
1816         9:\s+\$x\ =\ "SecondVal";\n
1817
1818         #msx,
1819         'Test the pre-prompt debugger commands',
1820     );
1821 }
1822
1823 # Test the { * command.
1824 {
1825     my $wrapper = DebugWrap->new(
1826         {
1827             cmds =>
1828             [
1829                 '{ q',
1830                 '{ *',
1831                 q/b 5/,
1832                 q/c/,
1833                 q/print (("One" x 5), "\n");/,
1834                 q/q/,
1835             ],
1836             prog => '../lib/perl5db/t/disable-breakpoints-1',
1837         }
1838     );
1839
1840     $wrapper->contents_like(qr#
1841         ^All\ \{\ actions\ cleared\.\n
1842         #msx,
1843         'Test the { * command',
1844     );
1845
1846     $wrapper->output_like(qr/OneOneOneOneOne/,
1847         '{ * test - output is OK.',
1848     );
1849 }
1850
1851 # Test the ! command.
1852 {
1853     my $wrapper = DebugWrap->new(
1854         {
1855             cmds =>
1856             [
1857                 'l 3-5',
1858                 '!',
1859                 'q',
1860             ],
1861             prog => '../lib/perl5db/t/disable-breakpoints-1',
1862         }
1863     );
1864
1865     $wrapper->contents_like(qr#
1866         (^3:\s+my\ \$dummy\ =\ 0;\n
1867         4\s*\n
1868         5:\s+\$x\ =\ "FirstVal";)\n
1869         .*?
1870         ^l\ 3-5\n
1871         \1
1872         #msx,
1873         'Test the ! command (along with l 3-5)',
1874     );
1875 }
1876
1877 # Test the ! -number command.
1878 {
1879     my $wrapper = DebugWrap->new(
1880         {
1881             cmds =>
1882             [
1883                 'l 3-5',
1884                 'l 2',
1885                 '! -1',
1886                 'q',
1887             ],
1888             prog => '../lib/perl5db/t/disable-breakpoints-1',
1889         }
1890     );
1891
1892     $wrapper->contents_like(qr#
1893         (^3:\s+my\ \$dummy\ =\ 0;\n
1894         4\s*\n
1895         5:\s+\$x\ =\ "FirstVal";)\n
1896         .*?
1897         ^2==\>\s+my\ \$x\ =\ "One";\n
1898         .*?
1899         ^l\ 3-5\n
1900         \1
1901         #msx,
1902         'Test the ! -n command (along with l)',
1903     );
1904 }
1905
1906 # Test the 'source' command.
1907 {
1908     my $wrapper = DebugWrap->new(
1909         {
1910             cmds =>
1911             [
1912                 'source ../lib/perl5db/t/source-cmd-test.perldb',
1913                 # If we have a 'q' here, then the typeahead will override the
1914                 # input, and so it won't be reached - solution:
1915                 # put a q inside the .perldb commands.
1916                 # ( This may be a bug or a misfeature. )
1917             ],
1918             prog => '../lib/perl5db/t/disable-breakpoints-1',
1919         }
1920     );
1921
1922     $wrapper->contents_like(qr#
1923         ^3:\s+my\ \$dummy\ =\ 0;\n
1924         4\s*\n
1925         5:\s+\$x\ =\ "FirstVal";\n
1926         6\s*\n
1927         7:\s+\$dummy\+\+;\n
1928         8\s*\n
1929         9:\s+\$x\ =\ "SecondVal";\n
1930         10\s*\n
1931         #msx,
1932         'Test the source command (along with l)',
1933     );
1934
1935     print $wrapper->get_output(), "\n";
1936 }
1937
1938 END {
1939     1 while unlink ($rc_filename, $out_fn);
1940 }