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