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