1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8 9use strict; 10use warnings; 11use Config; 12 13delete $ENV{PERLDB_OPTS}; 14 15BEGIN { 16 if (! -c "/dev/null") { 17 print "1..0 # Skip: no /dev/null\n"; 18 exit 0; 19 } 20 21 my $dev_tty = '/dev/tty'; 22 $dev_tty = 'TT:' if ($^O eq 'VMS'); 23 if (! -c $dev_tty) { 24 print "1..0 # Skip: no $dev_tty\n"; 25 exit 0; 26 } 27 if ($ENV{PERL5DB}) { 28 print "1..0 # Skip: \$ENV{PERL5DB} is already set to '$ENV{PERL5DB}'\n"; 29 exit 0; 30 } 31 $ENV{PERL_RL} = 'Perl'; # Suppress system Term::ReadLine::Gnu 32} 33 34my $rc_filename = '.perldb'; 35 36sub 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 47sub _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 62my $out_fn = 'db.out'; 63 64sub _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 77sub afterinit { 78 push(@DB::typeahead, 79 'm main->s1', 80 'q', 81 ); 82} 83 84EOF 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, qr/\bAll 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 qq{success\n}' ); 101 is( $?, 0, '[perl #116769] frame=2 does not crash debugger, exit == 0' ); 102 is( $output, "success\n" , '[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 qq{success\n}' ); 108 is( $?, 0, '[perl #116771] autotrace does not crash debugger, exit == 0' ); 109 is( $output, "success\n" , '[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 qq{success\n}' ); 116 is( $?, 0, '[perl #41461] frame=2 noTTY does not crash debugger, exit == 0' ); 117 is( $output, "success\n" , '[perl #41461] code is run' ); 118} 119 120package DebugWrap; 121 122sub new { 123 my $class = shift; 124 125 my $self = bless {}, $class; 126 127 $self->_init(@_); 128 129 return $self; 130} 131 132sub _cmds { 133 my $self = shift; 134 135 if (@_) { 136 $self->{_cmds} = shift; 137 } 138 139 return $self->{_cmds}; 140} 141 142sub _prog { 143 my $self = shift; 144 145 if (@_) { 146 $self->{_prog} = shift; 147 } 148 149 return $self->{_prog}; 150} 151 152sub _output { 153 my $self = shift; 154 155 if (@_) { 156 $self->{_output} = shift; 157 } 158 159 return $self->{_output}; 160} 161 162sub _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 174sub _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 186sub field 187{ 188 my $self = shift; 189 190 if (@_) 191 { 192 $self->{field} = shift; 193 } 194 195 return $self->{field}; 196} 197 198sub _switches 199{ 200 my $self = shift; 201 202 if (@_) 203 { 204 $self->{_switches} = shift; 205 } 206 207 return $self->{_switches}; 208} 209 210sub _contents 211{ 212 my $self = shift; 213 214 if (@_) 215 { 216 $self->{_contents} = shift; 217 } 218 219 return $self->{_contents}; 220} 221 222sub _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 256sub _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 267sub _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 307sub get_output 308{ 309 return shift->_output(); 310} 311 312sub output_like { 313 my ($self, $re, $msg) = @_; 314 315 local $::Level = $::Level + 1; 316 ::like($self->_output(), $re, $msg); 317} 318 319sub output_unlike { 320 my ($self, $re, $msg) = @_; 321 322 local $::Level = $::Level + 1; 323 ::unlike($self->_output(), $re, $msg); 324} 325 326sub contents_like { 327 my ($self, $re, $msg) = @_; 328 329 local $::Level = $::Level + 1; 330 ::like($self->_contents(), $re, $msg); 331} 332 333sub contents_unlike { 334 my ($self, $re, $msg) = @_; 335 336 local $::Level = $::Level + 1; 337 ::unlike($self->_contents(), $re, $msg); 338} 339 340package 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 367sub _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 383sub _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 401sub _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 447SKIP: 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 465SKIP: 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 499sub _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 1041DebugWrap->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 my $nl = $^O eq 'VMS' ? "" : "\\\n"; 1509 $wrapper->output_like(qr# 1510 \nVar<Q>=1$nl 1511 \nVar<Q>=2$nl 1512 \nVar<Q>=3 1513 #msx, 1514 "a command is working", 1515 ); 1516} 1517 1518# Test the 'a' command with no line number. 1519{ 1520 my $wrapper = DebugWrap->new( 1521 { 1522 cmds => 1523 [ 1524 'n', 1525 q/a print "Hello " . (3 * 4) . "\n";/, 1526 'c', 1527 'q', 1528 ], 1529 prog => '../lib/perl5db/t/test-a-statement-1', 1530 } 1531 ); 1532 1533 $wrapper->output_like(qr# 1534 (?:^Hello\ 12\n.*?){4} 1535 #msx, 1536 "a command with no line number is working", 1537 ); 1538} 1539 1540# Test the 'A' command 1541{ 1542 my $wrapper = DebugWrap->new( 1543 { 1544 cmds => 1545 [ 1546 'a 13 print "\nVar<Q>=$q\n"', 1547 'A 13', 1548 'c', 1549 'q', 1550 ], 1551 prog => '../lib/perl5db/t/eval-line-bug', 1552 } 1553 ); 1554 1555 $wrapper->output_like( 1556 qr#\A\z#msx, # The empty string. 1557 "A command (for removing actions) is working", 1558 ); 1559} 1560 1561# Test the 'A *' command 1562{ 1563 my $wrapper = DebugWrap->new( 1564 { 1565 cmds => 1566 [ 1567 'a 6 print "\nFail!\n"', 1568 'a 13 print "\nVar<Q>=$q\n"', 1569 'A *', 1570 'c', 1571 'q', 1572 ], 1573 prog => '../lib/perl5db/t/eval-line-bug', 1574 } 1575 ); 1576 1577 $wrapper->output_like( 1578 qr#\A\z#msx, # The empty string. 1579 "'A *' command (for removing all actions) is working", 1580 ); 1581} 1582 1583{ 1584 my $wrapper = DebugWrap->new( 1585 { 1586 cmds => 1587 [ 1588 'n', 1589 'w $foo', 1590 'c', 1591 'print "\nIDX=<$idx>\n"', 1592 'q', 1593 ], 1594 prog => '../lib/perl5db/t/test-w-statement-1', 1595 } 1596 ); 1597 1598 1599 $wrapper->contents_like(qr# 1600 \$foo\ changed:\n 1601 \s+old\ value:\s+'1'\n 1602 \s+new\ value:\s+'2'\n 1603 #msx, 1604 'w command - watchpoint changed', 1605 ); 1606 $wrapper->output_like(qr# 1607 \nIDX=<20>\n 1608 #msx, 1609 "w command - correct output from IDX", 1610 ); 1611} 1612 1613{ 1614 my $wrapper = DebugWrap->new( 1615 { 1616 cmds => 1617 [ 1618 'n', 1619 'w $foo', 1620 'W $foo', 1621 'c', 1622 'print "\nIDX=<$idx>\n"', 1623 'q', 1624 ], 1625 prog => '../lib/perl5db/t/test-w-statement-1', 1626 } 1627 ); 1628 1629 $wrapper->contents_unlike(qr# 1630 \$foo\ changed: 1631 #msx, 1632 'W command - watchpoint was deleted', 1633 ); 1634 1635 $wrapper->output_like(qr# 1636 \nIDX=<>\n 1637 #msx, 1638 "W command - stopped at end.", 1639 ); 1640} 1641 1642# Test the W * command. 1643{ 1644 my $wrapper = DebugWrap->new( 1645 { 1646 cmds => 1647 [ 1648 'n', 1649 'w $foo', 1650 'w ($foo*$foo)', 1651 'W *', 1652 'c', 1653 'print "\nIDX=<$idx>\n"', 1654 'q', 1655 ], 1656 prog => '../lib/perl5db/t/test-w-statement-1', 1657 } 1658 ); 1659 1660 $wrapper->contents_unlike(qr# 1661 \$foo\ changed: 1662 #msx, 1663 '"W *" command - watchpoint was deleted', 1664 ); 1665 1666 $wrapper->output_like(qr# 1667 \nIDX=<>\n 1668 #msx, 1669 '"W *" command - stopped at end.', 1670 ); 1671} 1672 1673# Test the 'o' command (without further arguments). 1674{ 1675 my $wrapper = DebugWrap->new( 1676 { 1677 cmds => 1678 [ 1679 'o', 1680 'q', 1681 ], 1682 prog => '../lib/perl5db/t/test-w-statement-1', 1683 } 1684 ); 1685 1686 $wrapper->contents_like(qr# 1687 ^\s*warnLevel\ =\ '1'\n 1688 #msx, 1689 q#"o" command (without arguments) displays warnLevel#, 1690 ); 1691 1692 $wrapper->contents_like(qr# 1693 ^\s*signalLevel\ =\ '1'\n 1694 #msx, 1695 q#"o" command (without arguments) displays signalLevel#, 1696 ); 1697 1698 $wrapper->contents_like(qr# 1699 ^\s*dieLevel\ =\ '1'\n 1700 #msx, 1701 q#"o" command (without arguments) displays dieLevel#, 1702 ); 1703 1704 $wrapper->contents_like(qr# 1705 ^\s*hashDepth\ =\ 'N/A'\n 1706 #msx, 1707 q#"o" command (without arguments) displays hashDepth#, 1708 ); 1709} 1710 1711# Test the 'o' query command. 1712{ 1713 my $wrapper = DebugWrap->new( 1714 { 1715 cmds => 1716 [ 1717 'o hashDepth? signalLevel?', 1718 'q', 1719 ], 1720 prog => '../lib/perl5db/t/test-w-statement-1', 1721 } 1722 ); 1723 1724 $wrapper->contents_unlike(qr#warnLevel#, 1725 q#"o" query command does not display warnLevel#, 1726 ); 1727 1728 $wrapper->contents_like(qr# 1729 ^\s*signalLevel\ =\ '1'\n 1730 #msx, 1731 q#"o" query command displays signalLevel#, 1732 ); 1733 1734 $wrapper->contents_unlike(qr#dieLevel#, 1735 q#"o" query command does not display dieLevel#, 1736 ); 1737 1738 $wrapper->contents_like(qr# 1739 ^\s*hashDepth\ =\ 'N/A'\n 1740 #msx, 1741 q#"o" query command displays hashDepth#, 1742 ); 1743} 1744 1745# Test the 'o' set command. 1746{ 1747 my $wrapper = DebugWrap->new( 1748 { 1749 cmds => 1750 [ 1751 'o signalLevel=0', 1752 'o', 1753 'q', 1754 ], 1755 prog => '../lib/perl5db/t/test-w-statement-1', 1756 } 1757 ); 1758 1759 $wrapper->contents_like(qr/ 1760 ^\s*(signalLevel\ =\ '0'\n) 1761 .*? 1762 ^\s*\1 1763 /msx, 1764 q#o set command works#, 1765 ); 1766 1767 $wrapper->contents_like(qr# 1768 ^\s*hashDepth\ =\ 'N/A'\n 1769 #msx, 1770 q#o set command - hashDepth#, 1771 ); 1772} 1773 1774# Test the '<' and "< ?" commands. 1775{ 1776 my $wrapper = DebugWrap->new( 1777 { 1778 cmds => 1779 [ 1780 q/< print "\nX=<$x>\n"/, 1781 q/b 7/, 1782 q/< ?/, 1783 'c', 1784 'q', 1785 ], 1786 prog => '../lib/perl5db/t/disable-breakpoints-1', 1787 } 1788 ); 1789 1790 $wrapper->contents_like(qr/ 1791 ^pre-perl\ commands:\n 1792 \s*<\ --\ print\ "\\nX=<\$x>\\n"\n 1793 /msx, 1794 q#Test < and < ? commands - contents.#, 1795 ); 1796 1797 $wrapper->output_like(qr# 1798 ^X=<FirstVal>\n 1799 #msx, 1800 q#Test < and < ? commands - output.#, 1801 ); 1802} 1803 1804# Test the '< *' command. 1805{ 1806 my $wrapper = DebugWrap->new( 1807 { 1808 cmds => 1809 [ 1810 q/< print "\nX=<$x>\n"/, 1811 q/b 7/, 1812 q/< */, 1813 'c', 1814 'q', 1815 ], 1816 prog => '../lib/perl5db/t/disable-breakpoints-1', 1817 } 1818 ); 1819 1820 $wrapper->output_unlike(qr/FirstVal/, 1821 q#Test the '< *' command.#, 1822 ); 1823} 1824 1825# Test the '>' and "> ?" commands. 1826{ 1827 my $wrapper = DebugWrap->new( 1828 { 1829 cmds => 1830 [ 1831 q/$::foo = 500;/, 1832 q/> print "\nFOO=<$::foo>\n"/, 1833 q/b 7/, 1834 q/> ?/, 1835 'c', 1836 'q', 1837 ], 1838 prog => '../lib/perl5db/t/disable-breakpoints-1', 1839 } 1840 ); 1841 1842 $wrapper->contents_like(qr/ 1843 ^post-perl\ commands:\n 1844 \s*>\ --\ print\ "\\nFOO=<\$::foo>\\n"\n 1845 /msx, 1846 q#Test > and > ? commands - contents.#, 1847 ); 1848 1849 $wrapper->output_like(qr# 1850 ^FOO=<500>\n 1851 #msx, 1852 q#Test > and > ? commands - output.#, 1853 ); 1854} 1855 1856# Test the '> *' command. 1857{ 1858 my $wrapper = DebugWrap->new( 1859 { 1860 cmds => 1861 [ 1862 q/> print "\nFOO=<$::foo>\n"/, 1863 q/b 7/, 1864 q/> */, 1865 'c', 1866 'q', 1867 ], 1868 prog => '../lib/perl5db/t/disable-breakpoints-1', 1869 } 1870 ); 1871 1872 $wrapper->output_unlike(qr/FOO=/, 1873 q#Test the '> *' command.#, 1874 ); 1875} 1876 1877# Test the < and > commands together 1878{ 1879 my $wrapper = DebugWrap->new( 1880 { 1881 cmds => 1882 [ 1883 q/$::lorem = 0;/, 1884 q/< $::lorem += 10;/, 1885 q/> print "\nLOREM=<$::lorem>\n"/, 1886 q/b 7/, 1887 q/b 5/, 1888 'c', 1889 'c', 1890 'q', 1891 ], 1892 prog => '../lib/perl5db/t/disable-breakpoints-1', 1893 } 1894 ); 1895 1896 $wrapper->output_like(qr# 1897 ^LOREM=<10>\n 1898 #msx, 1899 q#Test < and > commands. #, 1900 ); 1901} 1902 1903# Test the { ? and { [command] commands. 1904{ 1905 my $wrapper = DebugWrap->new( 1906 { 1907 cmds => 1908 [ 1909 '{ ?', 1910 '{ l', 1911 '{ ?', 1912 q/b 5/, 1913 q/c/, 1914 q/q/, 1915 ], 1916 prog => '../lib/perl5db/t/disable-breakpoints-1', 1917 } 1918 ); 1919 1920 $wrapper->contents_like(qr# 1921 ^No\ pre-debugger\ actions\.\n 1922 .*? 1923 ^pre-debugger\ commands:\n 1924 \s+\{\ --\ l\n 1925 .*? 1926 ^5==>b\s+\$x\ =\ "FirstVal";\n 1927 6\s*\n 1928 7:\s+\$dummy\+\+;\n 1929 8\s*\n 1930 9:\s+\$x\ =\ "SecondVal";\n 1931 1932 #msx, 1933 'Test the pre-prompt debugger commands', 1934 ); 1935} 1936 1937# Test the { * command. 1938{ 1939 my $wrapper = DebugWrap->new( 1940 { 1941 cmds => 1942 [ 1943 '{ q', 1944 '{ *', 1945 q/b 5/, 1946 q/c/, 1947 q/print (("One" x 5), "\n");/, 1948 q/q/, 1949 ], 1950 prog => '../lib/perl5db/t/disable-breakpoints-1', 1951 } 1952 ); 1953 1954 $wrapper->contents_like(qr# 1955 ^All\ \{\ actions\ cleared\.\n 1956 #msx, 1957 'Test the { * command', 1958 ); 1959 1960 $wrapper->output_like(qr/OneOneOneOneOne/, 1961 '{ * test - output is OK.', 1962 ); 1963} 1964 1965# Test the ! command. 1966{ 1967 my $wrapper = DebugWrap->new( 1968 { 1969 cmds => 1970 [ 1971 'l 3-5', 1972 '!', 1973 'q', 1974 ], 1975 prog => '../lib/perl5db/t/disable-breakpoints-1', 1976 } 1977 ); 1978 1979 $wrapper->contents_like(qr# 1980 (^3:\s+my\ \$dummy\ =\ 0;\n 1981 4\s*\n 1982 5:\s+\$x\ =\ "FirstVal";)\n 1983 .*? 1984 ^l\ 3-5\n 1985 \1 1986 #msx, 1987 'Test the ! command (along with l 3-5)', 1988 ); 1989} 1990 1991# Test the ! -number command. 1992{ 1993 my $wrapper = DebugWrap->new( 1994 { 1995 cmds => 1996 [ 1997 'l 3-5', 1998 'l 2', 1999 '! -1', 2000 'q', 2001 ], 2002 prog => '../lib/perl5db/t/disable-breakpoints-1', 2003 } 2004 ); 2005 2006 $wrapper->contents_like(qr# 2007 (^3:\s+my\ \$dummy\ =\ 0;\n 2008 4\s*\n 2009 5:\s+\$x\ =\ "FirstVal";)\n 2010 .*? 2011 ^2==\>\s+my\ \$x\ =\ "One";\n 2012 .*? 2013 ^l\ 3-5\n 2014 \1 2015 #msx, 2016 'Test the ! -n command (along with l)', 2017 ); 2018} 2019 2020# Test the 'source' command. 2021{ 2022 my $wrapper = DebugWrap->new( 2023 { 2024 cmds => 2025 [ 2026 'source ../lib/perl5db/t/source-cmd-test.perldb', 2027 # If we have a 'q' here, then the typeahead will override the 2028 # input, and so it won't be reached - solution: 2029 # put a q inside the .perldb commands. 2030 # ( This may be a bug or a misfeature. ) 2031 ], 2032 prog => '../lib/perl5db/t/disable-breakpoints-1', 2033 } 2034 ); 2035 2036 $wrapper->contents_like(qr# 2037 ^3:\s+my\ \$dummy\ =\ 0;\n 2038 4\s*\n 2039 5:\s+\$x\ =\ "FirstVal";\n 2040 6\s*\n 2041 7:\s+\$dummy\+\+;\n 2042 8\s*\n 2043 9:\s+\$x\ =\ "SecondVal";\n 2044 10\s*\n 2045 #msx, 2046 'Test the source command (along with l)', 2047 ); 2048} 2049 2050# Test the 'source' command being traversed from withing typeahead. 2051{ 2052 my $wrapper = DebugWrap->new( 2053 { 2054 cmds => 2055 [ 2056 'source ../lib/perl5db/t/source-cmd-test-no-q.perldb', 2057 'q', 2058 ], 2059 prog => '../lib/perl5db/t/disable-breakpoints-1', 2060 } 2061 ); 2062 2063 $wrapper->contents_like(qr# 2064 ^3:\s+my\ \$dummy\ =\ 0;\n 2065 4\s*\n 2066 5:\s+\$x\ =\ "FirstVal";\n 2067 6\s*\n 2068 7:\s+\$dummy\+\+;\n 2069 8\s*\n 2070 9:\s+\$x\ =\ "SecondVal";\n 2071 10\s*\n 2072 #msx, 2073 'Test the source command inside a typeahead', 2074 ); 2075} 2076 2077# Test the 'H -number' command. 2078{ 2079 my $wrapper = DebugWrap->new( 2080 { 2081 cmds => 2082 [ 2083 'l 1-10', 2084 'l 5-10', 2085 'x "Hello World"', 2086 'l 1-5', 2087 'b 3', 2088 'x (20+4)', 2089 'H -7', 2090 'q', 2091 ], 2092 prog => '../lib/perl5db/t/disable-breakpoints-1', 2093 } 2094 ); 2095 2096 $wrapper->contents_like(qr# 2097 ^\d+:\s+H\ -7\n 2098 \d+:\s+x\ \(20\+4\)\n 2099 \d+:\s+b\ 3\n 2100 \d+:\s+l\ 1-5\n 2101 \d+:\s+x\ "Hello\ World"\n 2102 \d+:\s+l\ 5-10\n 2103 \d+:\s+l\ 1-10\n 2104 #msx, 2105 'Test the H -num command', 2106 ); 2107} 2108 2109# Add a test for H (without arguments) 2110{ 2111 my $wrapper = DebugWrap->new( 2112 { 2113 cmds => 2114 [ 2115 'l 1-10', 2116 'l 5-10', 2117 'x "Hello World"', 2118 'l 1-5', 2119 'b 3', 2120 'x (20+4)', 2121 'H', 2122 'q', 2123 ], 2124 prog => '../lib/perl5db/t/disable-breakpoints-1', 2125 } 2126 ); 2127 2128 $wrapper->contents_like(qr# 2129 ^\d+:\s+x\ \(20\+4\)\n 2130 \d+:\s+b\ 3\n 2131 \d+:\s+l\ 1-5\n 2132 \d+:\s+x\ "Hello\ World"\n 2133 \d+:\s+l\ 5-10\n 2134 \d+:\s+l\ 1-10\n 2135 #msx, 2136 'Test the H command (without a number.)', 2137 ); 2138} 2139 2140{ 2141 my $wrapper = DebugWrap->new( 2142 { 2143 cmds => 2144 [ 2145 '= quit q', 2146 '= foobar l', 2147 'foobar', 2148 'quit', 2149 ], 2150 prog => '../lib/perl5db/t/test-l-statement-1', 2151 } 2152 ); 2153 2154 $wrapper->contents_like( 2155 qr/ 2156 ^1==>\s+\$x\ =\ 1;\n 2157 2:\s+print\ "1\\n";\n 2158 3\s*\n 2159 4:\s+\$x\ =\ 2;\n 2160 5:\s+print\ "2\\n";\n 2161 /msx, 2162 'Test the = (command alias) command.', 2163 ); 2164} 2165 2166# Test the m statement. 2167{ 2168 my $wrapper = DebugWrap->new( 2169 { 2170 cmds => 2171 [ 2172 'm main', 2173 'q', 2174 ], 2175 prog => '../lib/perl5db/t/disable-breakpoints-1', 2176 } 2177 ); 2178 2179 $wrapper->contents_like(qr# 2180 ^via\ UNIVERSAL:\ DOES$ 2181 #msx, 2182 "Test m for main - 1", 2183 ); 2184 2185 $wrapper->contents_like(qr# 2186 ^via\ UNIVERSAL:\ can$ 2187 #msx, 2188 "Test m for main - 2", 2189 ); 2190} 2191 2192# Test the m statement. 2193{ 2194 my $wrapper = DebugWrap->new( 2195 { 2196 cmds => 2197 [ 2198 'b 41', 2199 'c', 2200 'm $obj', 2201 'q', 2202 ], 2203 prog => '../lib/perl5db/t/test-m-statement-1', 2204 } 2205 ); 2206 2207 $wrapper->contents_like(qr#^greet$#ms, 2208 "Test m for obj - 1", 2209 ); 2210 2211 $wrapper->contents_like(qr#^via UNIVERSAL: can$#ms, 2212 "Test m for obj - 1", 2213 ); 2214} 2215 2216# Test the M command. 2217{ 2218 my $wrapper = DebugWrap->new( 2219 { 2220 cmds => 2221 [ 2222 'M', 2223 'q', 2224 ], 2225 prog => '../lib/perl5db/t/test-m-statement-1', 2226 } 2227 ); 2228 2229 $wrapper->contents_like(qr# 2230 ^'strict\.pm'\ =>\ '\d+\.\d+\ from 2231 #msx, 2232 "Test M", 2233 ); 2234 2235} 2236 2237# Test the recallCommand option. 2238{ 2239 my $wrapper = DebugWrap->new( 2240 { 2241 cmds => 2242 [ 2243 'o recallCommand=%', 2244 'l 3-5', 2245 'l 2', 2246 '% -1', 2247 'q', 2248 ], 2249 prog => '../lib/perl5db/t/disable-breakpoints-1', 2250 } 2251 ); 2252 2253 $wrapper->contents_like(qr# 2254 (^3:\s+my\ \$dummy\ =\ 0;\n 2255 4\s*\n 2256 5:\s+\$x\ =\ "FirstVal";)\n 2257 .*? 2258 ^2==\>\s+my\ \$x\ =\ "One";\n 2259 .*? 2260 ^l\ 3-5\n 2261 \1 2262 #msx, 2263 'Test the o recallCommand option', 2264 ); 2265} 2266 2267# Test the dieLevel option 2268{ 2269 my $wrapper = DebugWrap->new( 2270 { 2271 cmds => 2272 [ 2273 q/o dieLevel='1'/, 2274 q/c/, 2275 'q', 2276 ], 2277 prog => '../lib/perl5db/t/test-dieLevel-option-1', 2278 } 2279 ); 2280 2281 $wrapper->output_like(qr# 2282 ^This\ program\ dies\.\ at\ \S+\ line\ 18\N*\.\n 2283 .*? 2284 ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n 2285 \s+main::bar\(\)\ called\ at\ \S+\ line\ 7\n 2286 \s+main::foo\(\)\ called\ at\ \S+\ line\ 21\n 2287 #msx, 2288 'Test the o dieLevel option', 2289 ); 2290} 2291 2292# Test the warnLevel option 2293{ 2294 my $wrapper = DebugWrap->new( 2295 { 2296 cmds => 2297 [ 2298 q/o warnLevel='1'/, 2299 q/c/, 2300 'q', 2301 ], 2302 prog => '../lib/perl5db/t/test-warnLevel-option-1', 2303 } 2304 ); 2305 2306 $wrapper->contents_like(qr# 2307 ^This\ is\ not\ a\ warning\.\ at\ \S+\ line\ 18\N*\.\n 2308 .*? 2309 ^\s+main::baz\(\)\ called\ at\ \S+\ line\ 13\n 2310 \s+main::bar\(\)\ called\ at\ \S+\ line\ 25\n 2311 \s+main::myfunc\(\)\ called\ at\ \S+\ line\ 28\n 2312 #msx, 2313 'Test the o warnLevel option', 2314 ); 2315} 2316 2317# Test the t command 2318{ 2319 my $wrapper = DebugWrap->new( 2320 { 2321 cmds => 2322 [ 2323 't', 2324 'c', 2325 'q', 2326 ], 2327 prog => '../lib/perl5db/t/disable-breakpoints-1', 2328 } 2329 ); 2330 2331 $wrapper->contents_like(qr/ 2332 ^main::\([^:]+:15\):\n 2333 15:\s+\$dummy\+\+;\n 2334 main::\([^:]+:17\):\n 2335 17:\s+\$x\ =\ "FourthVal";\n 2336 /msx, 2337 'Test the t command (without a number.)', 2338 ); 2339} 2340 2341# Test the o AutoTrace command 2342{ 2343 my $wrapper = DebugWrap->new( 2344 { 2345 cmds => 2346 [ 2347 'o AutoTrace', 2348 'c', 2349 'q', 2350 ], 2351 prog => '../lib/perl5db/t/disable-breakpoints-1', 2352 } 2353 ); 2354 2355 $wrapper->contents_like(qr/ 2356 ^main::\([^:]+:15\):\n 2357 15:\s+\$dummy\+\+;\n 2358 main::\([^:]+:17\):\n 2359 17:\s+\$x\ =\ "FourthVal";\n 2360 /msx, 2361 'Test the o AutoTrace command', 2362 ); 2363} 2364 2365# Test the t command with function calls 2366{ 2367 my $wrapper = DebugWrap->new( 2368 { 2369 cmds => 2370 [ 2371 't', 2372 'b 18', 2373 'c', 2374 'x ["foo"]', 2375 'x ["bar"]', 2376 'q', 2377 ], 2378 prog => '../lib/perl5db/t/test-warnLevel-option-1', 2379 } 2380 ); 2381 2382 $wrapper->contents_like(qr/ 2383 ^main::\([^:]+:28\):\n 2384 28:\s+myfunc\(\);\n 2385 auto\(-\d+\)\s+DB<1>\s+t\n 2386 Trace\ =\ on\n 2387 auto\(-\d+\)\s+DB<1>\s+b\ 18\n 2388 auto\(-\d+\)\s+DB<2>\s+c\n 2389 main::myfunc\([^:]+:25\):\n 2390 25:\s+bar\(\);\n 2391 /msx, 2392 'Test the t command with function calls.', 2393 ); 2394} 2395 2396# Test the o AutoTrace command with function calls 2397{ 2398 my $wrapper = DebugWrap->new( 2399 { 2400 cmds => 2401 [ 2402 'o AutoTrace', 2403 'b 18', 2404 'c', 2405 'x ["foo"]', 2406 'x ["bar"]', 2407 'q', 2408 ], 2409 prog => '../lib/perl5db/t/test-warnLevel-option-1', 2410 } 2411 ); 2412 2413 $wrapper->contents_like(qr/ 2414 ^main::\([^:]+:28\):\n 2415 28:\s+myfunc\(\);\n 2416 auto\(-\d+\)\s+DB<1>\s+o\ AutoTrace\n 2417 \s+AutoTrace\s+=\s+'1'\n 2418 auto\(-\d+\)\s+DB<2>\s+b\ 18\n 2419 auto\(-\d+\)\s+DB<3>\s+c\n 2420 main::myfunc\([^:]+:25\):\n 2421 25:\s+bar\(\);\n 2422 /msx, 2423 'Test the o AutoTrace command with function calls.', 2424 ); 2425} 2426 2427# Test the final message. 2428{ 2429 my $wrapper = DebugWrap->new( 2430 { 2431 cmds => 2432 [ 2433 'c', 2434 'q', 2435 ], 2436 prog => '../lib/perl5db/t/test-warnLevel-option-1', 2437 } 2438 ); 2439 2440 $wrapper->contents_like(qr/ 2441 ^Debugged\ program\ terminated\. 2442 /msx, 2443 'Test the final "Debugged program terminated" message.', 2444 ); 2445} 2446 2447# Test the o inhibit_exit=0 command 2448{ 2449 my $wrapper = DebugWrap->new( 2450 { 2451 cmds => 2452 [ 2453 'o inhibit_exit=0', 2454 'n', 2455 'n', 2456 'n', 2457 'n', 2458 'q', 2459 ], 2460 prog => '../lib/perl5db/t/test-warnLevel-option-1', 2461 } 2462 ); 2463 2464 $wrapper->contents_unlike(qr/ 2465 ^Debugged\ program\ terminated\. 2466 /msx, 2467 'Test the o inhibit_exit=0 command.', 2468 ); 2469} 2470 2471# Test the o PrintRet=1 option 2472{ 2473 my $wrapper = DebugWrap->new( 2474 { 2475 cmds => 2476 [ 2477 'o PrintRet=1', 2478 'b 29', 2479 'c', 2480 q/$x = 's';/, 2481 'b 10', 2482 'c', 2483 'r', 2484 'q', 2485 ], 2486 prog => '../lib/perl5db/t/test-PrintRet-option-1', 2487 } 2488 ); 2489 2490 $wrapper->contents_like( 2491 qr/scalar context return from main::return_scalar: 20024/, 2492 "Test o PrintRet=1", 2493 ); 2494} 2495 2496# Test the o PrintRet=0 option 2497{ 2498 my $wrapper = DebugWrap->new( 2499 { 2500 cmds => 2501 [ 2502 'o PrintRet=0', 2503 'b 29', 2504 'c', 2505 q/$x = 's';/, 2506 'b 10', 2507 'c', 2508 'r', 2509 'q', 2510 ], 2511 prog => '../lib/perl5db/t/test-PrintRet-option-1', 2512 } 2513 ); 2514 2515 $wrapper->contents_unlike( 2516 qr/scalar context/, 2517 "Test o PrintRet=0", 2518 ); 2519} 2520 2521# Test the o PrintRet=1 option in list context 2522{ 2523 my $wrapper = DebugWrap->new( 2524 { 2525 cmds => 2526 [ 2527 'o PrintRet=1', 2528 'b 29', 2529 'c', 2530 q/$x = 'l';/, 2531 'b 17', 2532 'c', 2533 'r', 2534 'q', 2535 ], 2536 prog => '../lib/perl5db/t/test-PrintRet-option-1', 2537 } 2538 ); 2539 2540 $wrapper->contents_like( 2541 qr/list context return from main::return_list:\n0\s*'Foo'\n1\s*'Bar'\n2\s*'Baz'\n/, 2542 "Test o PrintRet=1 in list context", 2543 ); 2544} 2545 2546# Test the o PrintRet=0 option in list context 2547{ 2548 my $wrapper = DebugWrap->new( 2549 { 2550 cmds => 2551 [ 2552 'o PrintRet=0', 2553 'b 29', 2554 'c', 2555 q/$x = 'l';/, 2556 'b 17', 2557 'c', 2558 'r', 2559 'q', 2560 ], 2561 prog => '../lib/perl5db/t/test-PrintRet-option-1', 2562 } 2563 ); 2564 2565 $wrapper->contents_unlike( 2566 qr/list context/, 2567 "Test o PrintRet=0 in list context", 2568 ); 2569} 2570 2571# Test the o PrintRet=1 option in void context 2572{ 2573 my $wrapper = DebugWrap->new( 2574 { 2575 cmds => 2576 [ 2577 'o PrintRet=1', 2578 'b 29', 2579 'c', 2580 q/$x = 'v';/, 2581 'b 24', 2582 'c', 2583 'r', 2584 'q', 2585 ], 2586 prog => '../lib/perl5db/t/test-PrintRet-option-1', 2587 } 2588 ); 2589 2590 $wrapper->contents_like( 2591 qr/void context return from main::return_void/, 2592 "Test o PrintRet=1 in void context", 2593 ); 2594} 2595 2596# Test the o PrintRet=1 option in void context 2597{ 2598 my $wrapper = DebugWrap->new( 2599 { 2600 cmds => 2601 [ 2602 'o PrintRet=0', 2603 'b 29', 2604 'c', 2605 q/$x = 'v';/, 2606 'b 24', 2607 'c', 2608 'r', 2609 'q', 2610 ], 2611 prog => '../lib/perl5db/t/test-PrintRet-option-1', 2612 } 2613 ); 2614 2615 $wrapper->contents_unlike( 2616 qr/void context/, 2617 "Test o PrintRet=0 in void context", 2618 ); 2619} 2620 2621# Test the o frame option. 2622{ 2623 my $wrapper = DebugWrap->new( 2624 { 2625 cmds => 2626 [ 2627 # This is to avoid getting the "Debugger program terminated" 2628 # junk that interferes with the normal output. 2629 'o inhibit_exit=0', 2630 'b 10', 2631 'c', 2632 'o frame=255', 2633 'c', 2634 'q', 2635 ], 2636 prog => '../lib/perl5db/t/test-frame-option-1', 2637 } 2638 ); 2639 2640 $wrapper->contents_like( 2641 qr/ 2642 in\s*\.=main::my_other_func\(3,\ 1200\)\ from.*? 2643 out\s*\.=main::my_other_func\(3,\ 1200\)\ from 2644 /msx, 2645 "Test o PrintRet=0 in void context", 2646 ); 2647} 2648 2649{ # test t expr 2650 my $wrapper = DebugWrap->new( 2651 { 2652 cmds => 2653 [ 2654 # This is to avoid getting the "Debugger program terminated" 2655 # junk that interferes with the normal output. 2656 'o inhibit_exit=0', 2657 't fact(3)', 2658 'q', 2659 ], 2660 prog => '../lib/perl5db/t/fact', 2661 } 2662 ); 2663 2664 $wrapper->contents_like( 2665 qr/ 2666 (?:^main::fact.*return\ \$n\ \*\ fact\(\$n\ -\ 1\);.*) 2667 /msx, 2668 "Test t expr", 2669 ); 2670} 2671 2672# Test the w for lexical variables expression. 2673{ 2674 my $wrapper = DebugWrap->new( 2675 { 2676 cmds => 2677 [ 2678 # This is to avoid getting the "Debugger program terminated" 2679 # junk that interferes with the normal output. 2680 'w $exp', 2681 'n', 2682 'n', 2683 'n', 2684 'n', 2685 'q', 2686 ], 2687 prog => '../lib/perl5db/t/break-on-dot', 2688 } 2689 ); 2690 2691 $wrapper->contents_like( 2692 qr/ 2693\s+old\ value:\s+'1'\n 2694\s+new\ value:\s+'2'\n 2695 /msx, 2696 "Test w for lexical values.", 2697 ); 2698} 2699 2700# perl 5 RT #121509 regression bug. 2701# “perl debugger doesn't save starting dir to restart from” 2702# Thanks to Linda Walsh for reporting it. 2703{ 2704 use File::Temp qw/tempdir/; 2705 2706 my $temp_dir = tempdir( CLEANUP => 1 ); 2707 2708 local $ENV{__PERLDB_TEMP_DIR} = $temp_dir; 2709 my $wrapper = DebugWrap->new( 2710 { 2711 cmds => 2712 [ 2713 # This is to avoid getting the "Debugger program terminated" 2714 # junk that interferes with the normal output. 2715 'b _after_chdir', 2716 'c', 2717 'R', 2718 'b _finale', 2719 'c', 2720 'n', 2721 'n', 2722 'n', 2723 'n', 2724 'n', 2725 'n', 2726 'n', 2727 'n', 2728 'n', 2729 'n', 2730 'n', 2731 'n', 2732 'q', 2733 ], 2734 prog => '../lib/perl5db/t/rt-121509-restart-after-chdir', 2735 } 2736 ); 2737 2738 $wrapper->output_like( 2739 qr/ 2740In\ _finale\ No\ 1 2741 .*? 2742In\ _finale\ No\ 2 2743 .*? 2744In\ _finale\ No\ 3 2745 /msx, 2746 "Test that the debugger chdirs to the initial directory after a restart.", 2747 ); 2748} 2749# Test the perldoc command 2750# We don't actually run the program, but we need to provide one to the wrapper. 2751SKIP: 2752{ 2753 $^O eq "linux" 2754 or skip "man errors aren't especially portable", 1; 2755 -x '/usr/bin/man' 2756 or skip "man command seems to be missing", 1; 2757 local $ENV{LANG} = "C"; 2758 local $ENV{LC_MESSAGES} = "C"; 2759 local $ENV{LC_ALL} = "C"; 2760 my $wrapper = DebugWrap->new( 2761 { 2762 cmds => 2763 [ 2764 'perldoc perlrules', 2765 'q', 2766 ], 2767 prog => '../lib/perl5db/t/fact', 2768 } 2769 ); 2770 2771 $wrapper->output_like( 2772 qr/No (?:manual )?entry for perlrules/, 2773 'perldoc command works fine', 2774 ); 2775} 2776 2777# [perl #71678] debugger bug in evaluation of user actions ('a' command) 2778# Still evaluated after the script finishes. 2779{ 2780 my $wrapper = DebugWrap->new( 2781 { 2782 cmds => 2783 [ 2784 q#a 9 print " \$arg = $arg\n"#, 2785 'c 9', 2786 's', 2787 'q', 2788 ], 2789 prog => '../lib/perl5db/t/test-a-statement-2', 2790 switches => [ '-dw', ], 2791 stderr => 1, 2792 } 2793 ); 2794 2795 $wrapper->contents_unlike(qr/ 2796 Use\ of\ uninitialized\ value\ \$arg\ in\ concatenation\ [\S ]+\ or\ string\ at 2797 /msx, 2798 'Test that the a command does not emit warnings on program exit.', 2799 ); 2800} 2801 2802{ 2803 # perl 5 RT #126735 regression bug. 2804 local $ENV{PERLDB_OPTS} = "NonStop=0 RemotePort=non-existent-host.tld:9001"; 2805 my $output = runperl( stdin => "q\n", stderr => 1, switches => [ '-d' ], prog => '../lib/perl5db/t/fact' ); 2806 like( 2807 $output, 2808 qr/^Unable to connect to remote host:/ms, 2809 'Tried to connect.', 2810 ); 2811 unlike( 2812 $output, 2813 qr/syntax error/, 2814 'Can quit from the debugger after a wrong RemotePort', 2815 ); 2816} 2817 2818{ 2819 # perl 5 RT #120174 - 'p' command 2820 my $wrapper = DebugWrap->new( 2821 { 2822 cmds => 2823 [ 2824 'b 2', 2825 'c', 2826 'p@abc', 2827 'q', 2828 ], 2829 prog => '../lib/perl5db/t/rt-120174', 2830 } 2831 ); 2832 2833 $wrapper->contents_like( 2834 qr/1234/, 2835 q/RT 120174: p command can be invoked without space after 'p'/, 2836 ); 2837} 2838 2839{ 2840 # perl 5 RT #120174 - 'x' command on array 2841 my $wrapper = DebugWrap->new( 2842 { 2843 cmds => 2844 [ 2845 'b 2', 2846 'c', 2847 'x@abc', 2848 'q', 2849 ], 2850 prog => '../lib/perl5db/t/rt-120174', 2851 } 2852 ); 2853 2854 $wrapper->contents_like( 2855 qr/0\s+1\n1\s+2\n2\s+3\n3\s+4/ms, 2856 q/RT 120174: x command can be invoked without space after 'x' before array/, 2857 ); 2858} 2859 2860{ 2861 # perl 5 RT #120174 - 'x' command on array ref 2862 my $wrapper = DebugWrap->new( 2863 { 2864 cmds => 2865 [ 2866 'b 2', 2867 'c', 2868 'x\@abc', 2869 'q', 2870 ], 2871 prog => '../lib/perl5db/t/rt-120174', 2872 } 2873 ); 2874 2875 $wrapper->contents_like( 2876 qr/\s+0\s+1\n\s+1\s+2\n\s+2\s+3\n\s+3\s+4/ms, 2877 q/RT 120174: x command can be invoked without space after 'x' before array ref/, 2878 ); 2879} 2880 2881{ 2882 # perl 5 RT #120174 - 'x' command on hash ref 2883 my $wrapper = DebugWrap->new( 2884 { 2885 cmds => 2886 [ 2887 'b 4', 2888 'c', 2889 'x\%xyz', 2890 'q', 2891 ], 2892 prog => '../lib/perl5db/t/rt-120174', 2893 } 2894 ); 2895 2896 $wrapper->contents_like( 2897 qr/\s+'alpha'\s+=>\s+'beta'\n\s+'gamma'\s+=>\s+'delta'/ms, 2898 q/RT 120174: x command can be invoked without space after 'x' before hash ref/, 2899 ); 2900} 2901 2902SKIP: 2903{ 2904 $Config{usethreads} 2905 or skip "need threads to test debugging threads", 1; 2906 my $wrapper = DebugWrap->new( 2907 { 2908 cmds => 2909 [ 2910 'c', 2911 'q', 2912 ], 2913 prog => '../lib/perl5db/t/rt-124203', 2914 } 2915 ); 2916 2917 $wrapper->output_like(qr/In the thread/, "[perl #124203] the thread ran"); 2918 2919 $wrapper->output_like(qr/Finished/, "[perl #124203] debugger didn't deadlock"); 2920 2921 $wrapper = DebugWrap->new( 2922 { 2923 cmds => 2924 [ 2925 'c', 2926 'q', 2927 ], 2928 prog => '../lib/perl5db/t/rt-124203b', 2929 } 2930 ); 2931 2932 $wrapper->output_like(qr/In the thread/, "[perl #124203] the thread ran (lvalue)"); 2933 2934 $wrapper->output_like(qr/Finished One/, "[perl #124203] debugger didn't deadlock (lvalue)"); 2935} 2936 2937done_testing(); 2938 2939END { 2940 1 while unlink ($rc_filename, $out_fn); 2941} 2942