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