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