1package DB; 2 3# Debugger for Perl 5.00x; perl5db.pl patch level: 4 5$VERSION = 1.07; 6$header = "perl5db.pl version $VERSION"; 7 8# 9# This file is automatically included if you do perl -d. 10# It's probably not useful to include this yourself. 11# 12# Perl supplies the values for %sub. It effectively inserts 13# a &DB'DB(); in front of every place that can have a 14# breakpoint. Instead of a subroutine call it calls &DB::sub with 15# $DB::sub being the called subroutine. It also inserts a BEGIN 16# {require 'perl5db.pl'} before the first line. 17# 18# After each `require'd file is compiled, but before it is executed, a 19# call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the 20# $filename is the expanded name of the `require'd file (as found as 21# value of %INC). 22# 23# Additional services from Perl interpreter: 24# 25# if caller() is called from the package DB, it provides some 26# additional data. 27# 28# The array @{$main::{'_<'.$filename}} is the line-by-line contents of 29# $filename. 30# 31# The hash %{'_<'.$filename} contains breakpoints and action (it is 32# keyed by line number), and individual entries are settable (as 33# opposed to the whole hash). Only true/false is important to the 34# interpreter, though the values used by perl5db.pl have the form 35# "$break_condition\0$action". Values are magical in numeric context. 36# 37# The scalar ${'_<'.$filename} contains $filename. 38# 39# Note that no subroutine call is possible until &DB::sub is defined 40# (for subroutines defined outside of the package DB). In fact the same is 41# true if $deep is not defined. 42# 43# $Log: perldb.pl,v $ 44 45# 46# At start reads $rcfile that may set important options. This file 47# may define a subroutine &afterinit that will be executed after the 48# debugger is initialized. 49# 50# After $rcfile is read reads environment variable PERLDB_OPTS and parses 51# it as a rest of `O ...' line in debugger prompt. 52# 53# The options that can be specified only at startup: 54# [To set in $rcfile, call &parse_options("optionName=new_value").] 55# 56# TTY - the TTY to use for debugging i/o. 57# 58# noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set 59# uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using 60# Term::Rendezvous. Current variant is to have the name of TTY in this 61# file. 62# 63# ReadLine - If false, dummy ReadLine is used, so you can debug 64# ReadLine applications. 65# 66# NonStop - if true, no i/o is performed until interrupt. 67# 68# LineInfo - file or pipe to print line number info to. If it is a 69# pipe, a short "emacs like" message is used. 70# 71# RemotePort - host:port to connect to on remote host for remote debugging. 72# 73# Example $rcfile: (delete leading hashes!) 74# 75# &parse_options("NonStop=1 LineInfo=db.out"); 76# sub afterinit { $trace = 1; } 77# 78# The script will run without human intervention, putting trace 79# information into db.out. (If you interrupt it, you would better 80# reset LineInfo to something "interactive"!) 81# 82################################################################## 83 84# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) 85# Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl 86 87# modified Perl debugger, to be run from Emacs in perldb-mode 88# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 89# Johan Vromans -- upgrade to 4.0 pl 10 90# Ilya Zakharevich -- patches after 5.001 (and some before ;-) 91 92# Changelog: 93 94# A lot of things changed after 0.94. First of all, core now informs 95# debugger about entry into XSUBs, overloaded operators, tied operations, 96# BEGIN and END. Handy with `O f=2'. 97 98# This can make debugger a little bit too verbose, please be patient 99# and report your problems promptly. 100 101# Now the option frame has 3 values: 0,1,2. 102 103# Note that if DESTROY returns a reference to the object (or object), 104# the deletion of data may be postponed until the next function call, 105# due to the need to examine the return value. 106 107# Changes: 0.95: `v' command shows versions. 108# Changes: 0.96: `v' command shows version of readline. 109# primitive completion works (dynamic variables, subs for `b' and `l', 110# options). Can `p %var' 111# Better help (`h <' now works). New commands <<, >>, {, {{. 112# {dump|print}_trace() coded (to be able to do it from <<cmd). 113# `c sub' documented. 114# At last enough magic combined to stop after the end of debuggee. 115# !! should work now (thanks to Emacs bracket matching an extra 116# `]' in a regexp is caught). 117# `L', `D' and `A' span files now (as documented). 118# Breakpoints in `require'd code are possible (used in `R'). 119# Some additional words on internal work of debugger. 120# `b load filename' implemented. 121# `b postpone subr' implemented. 122# now only `q' exits debugger (overwriteable on $inhibit_exit). 123# When restarting debugger breakpoints/actions persist. 124# Buglet: When restarting debugger only one breakpoint/action per 125# autoloaded function persists. 126# Changes: 0.97: NonStop will not stop in at_exit(). 127# Option AutoTrace implemented. 128# Trace printed differently if frames are printed too. 129# new `inhibitExit' option. 130# printing of a very long statement interruptible. 131# Changes: 0.98: New command `m' for printing possible methods 132# 'l -' is a synonim for `-'. 133# Cosmetic bugs in printing stack trace. 134# `frame' & 8 to print "expanded args" in stack trace. 135# Can list/break in imported subs. 136# new `maxTraceLen' option. 137# frame & 4 and frame & 8 granted. 138# new command `m' 139# nonstoppable lines do not have `:' near the line number. 140# `b compile subname' implemented. 141# Will not use $` any more. 142# `-' behaves sane now. 143# Changes: 0.99: Completion for `f', `m'. 144# `m' will remove duplicate names instead of duplicate functions. 145# `b load' strips trailing whitespace. 146# completion ignores leading `|'; takes into account current package 147# when completing a subroutine name (same for `l'). 148# Changes: 1.07: Many fixed by tchrist 13-March-2000 149# BUG FIXES: 150# + Added bare mimimal security checks on perldb rc files, plus 151# comments on what else is needed. 152# + Fixed the ornaments that made "|h" completely unusable. 153# They are not used in print_help if they will hurt. Strip pod 154# if we're paging to less. 155# + Fixed mis-formatting of help messages caused by ornaments 156# to restore Larry's original formatting. 157# + Fixed many other formatting errors. The code is still suboptimal, 158# and needs a lot of work at restructuing. It's also misindented 159# in many places. 160# + Fixed bug where trying to look at an option like your pager 161# shows "1". 162# + Fixed some $? processing. Note: if you use csh or tcsh, you will 163# lose. You should consider shell escapes not using their shell, 164# or else not caring about detailed status. This should really be 165# unified into one place, too. 166# + Fixed bug where invisible trailing whitespace on commands hoses you, 167# tricking Perl into thinking you wern't calling a debugger command! 168# + Fixed bug where leading whitespace on commands hoses you. (One 169# suggests a leading semicolon or any other irrelevant non-whitespace 170# to indicate literal Perl code.) 171# + Fixed bugs that ate warnings due to wrong selected handle. 172# + Fixed a precedence bug on signal stuff. 173# + Fixed some unseemly wording. 174# + Fixed bug in help command trying to call perl method code. 175# + Fixed to call dumpvar from exception handler. SIGPIPE killed us. 176# ENHANCEMENTS: 177# + Added some comments. This code is still nasty spaghetti. 178# + Added message if you clear your pre/post command stacks which was 179# very easy to do if you just typed a bare >, <, or {. (A command 180# without an argument should *never* be a destructive action; this 181# API is fundamentally screwed up; likewise option setting, which 182# is equally buggered.) 183# + Added command stack dump on argument of "?" for >, <, or {. 184# + Added a semi-built-in doc viewer command that calls man with the 185# proper %Config::Config path (and thus gets caching, man -k, etc), 186# or else perldoc on obstreperous platforms. 187# + Added to and rearranged the help information. 188# + Detected apparent misuse of { ... } to declare a block; this used 189# to work but now is a command, and mysteriously gave no complaint. 190 191#################################################################### 192 193# Needed for the statement after exec(): 194 195BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN. 196local($^W) = 0; # Switch run-time warnings off during init. 197warn ( # Do not ;-) 198 $dumpvar::hashDepth, 199 $dumpvar::arrayDepth, 200 $dumpvar::dumpDBFiles, 201 $dumpvar::dumpPackages, 202 $dumpvar::quoteHighBit, 203 $dumpvar::printUndef, 204 $dumpvar::globPrint, 205 $dumpvar::usageOnly, 206 @ARGS, 207 $Carp::CarpLevel, 208 $panic, 209 $second_time, 210 ) if 0; 211 212# Command-line + PERLLIB: 213@ini_INC = @INC; 214 215# $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?! 216 217$trace = $signal = $single = 0; # Uninitialized warning suppression 218 # (local $^W cannot help - other packages!). 219$inhibit_exit = $option{PrintRet} = 1; 220 221@options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused 222 compactDump veryCompact quote HighBit undefPrint 223 globPrint PrintRet UsageOnly frame AutoTrace 224 TTY noTTY ReadLine NonStop LineInfo maxTraceLen 225 recallCommand ShellBang pager tkRunning ornaments 226 signalLevel warnLevel dieLevel inhibit_exit 227 ImmediateStop bareStringify 228 RemotePort); 229 230%optionVars = ( 231 hashDepth => \$dumpvar::hashDepth, 232 arrayDepth => \$dumpvar::arrayDepth, 233 DumpDBFiles => \$dumpvar::dumpDBFiles, 234 DumpPackages => \$dumpvar::dumpPackages, 235 DumpReused => \$dumpvar::dumpReused, 236 HighBit => \$dumpvar::quoteHighBit, 237 undefPrint => \$dumpvar::printUndef, 238 globPrint => \$dumpvar::globPrint, 239 UsageOnly => \$dumpvar::usageOnly, 240 bareStringify => \$dumpvar::bareStringify, 241 frame => \$frame, 242 AutoTrace => \$trace, 243 inhibit_exit => \$inhibit_exit, 244 maxTraceLen => \$maxtrace, 245 ImmediateStop => \$ImmediateStop, 246 RemotePort => \$remoteport, 247); 248 249%optionAction = ( 250 compactDump => \&dumpvar::compactDump, 251 veryCompact => \&dumpvar::veryCompact, 252 quote => \&dumpvar::quote, 253 TTY => \&TTY, 254 noTTY => \&noTTY, 255 ReadLine => \&ReadLine, 256 NonStop => \&NonStop, 257 LineInfo => \&LineInfo, 258 recallCommand => \&recallCommand, 259 ShellBang => \&shellBang, 260 pager => \&pager, 261 signalLevel => \&signalLevel, 262 warnLevel => \&warnLevel, 263 dieLevel => \&dieLevel, 264 tkRunning => \&tkRunning, 265 ornaments => \&ornaments, 266 RemotePort => \&RemotePort, 267 ); 268 269%optionRequire = ( 270 compactDump => 'dumpvar.pl', 271 veryCompact => 'dumpvar.pl', 272 quote => 'dumpvar.pl', 273 ); 274 275# These guys may be defined in $ENV{PERL5DB} : 276$rl = 1 unless defined $rl; 277$warnLevel = 0 unless defined $warnLevel; 278$dieLevel = 0 unless defined $dieLevel; 279$signalLevel = 1 unless defined $signalLevel; 280$pre = [] unless defined $pre; 281$post = [] unless defined $post; 282$pretype = [] unless defined $pretype; 283 284warnLevel($warnLevel); 285dieLevel($dieLevel); 286signalLevel($signalLevel); 287 288&pager( 289 (defined($ENV{PAGER}) 290 ? $ENV{PAGER} 291 : ($^O eq 'os2' 292 ? 'cmd /c more' 293 : 'more'))) unless defined $pager; 294setman(); 295&recallCommand("!") unless defined $prc; 296&shellBang("!") unless defined $psh; 297$maxtrace = 400 unless defined $maxtrace; 298 299if (-e "/dev/tty") { # this is the wrong metric! 300 $rcfile=".perldb"; 301} else { 302 $rcfile="perldb.ini"; 303} 304 305# This isn't really safe, because there's a race 306# between checking and opening. The solution is to 307# open and fstat the handle, but then you have to read and 308# eval the contents. But then the silly thing gets 309# your lexical scope, which is unfortunately at best. 310sub safe_do { 311 my $file = shift; 312 313 # Just exactly what part of the word "CORE::" don't you understand? 314 local $SIG{__WARN__}; 315 local $SIG{__DIE__}; 316 317 unless (is_safe_file($file)) { 318 CORE::warn <<EO_GRIPE; 319perldb: Must not source insecure rcfile $file. 320 You or the superuser must be the owner, and it must not 321 be writable by anyone but its owner. 322EO_GRIPE 323 return; 324 } 325 326 do $file; 327 CORE::warn("perldb: couldn't parse $file: $@") if $@; 328} 329 330 331# Verifies that owner is either real user or superuser and that no 332# one but owner may write to it. This function is of limited use 333# when called on a path instead of upon a handle, because there are 334# no guarantees that filename (by dirent) whose file (by ino) is 335# eventually accessed is the same as the one tested. 336# Assumes that the file's existence is not in doubt. 337sub is_safe_file { 338 my $path = shift; 339 stat($path) || return; # mysteriously vaporized 340 my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_); 341 342 return 0 if $uid != 0 && $uid != $<; 343 return 0 if $mode & 022; 344 return 1; 345} 346 347if (-f $rcfile) { 348 safe_do("./$rcfile"); 349} 350elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") { 351 safe_do("$ENV{HOME}/$rcfile"); 352} 353elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") { 354 safe_do("$ENV{LOGDIR}/$rcfile"); 355} 356 357if (defined $ENV{PERLDB_OPTS}) { 358 parse_options($ENV{PERLDB_OPTS}); 359} 360 361# Here begin the unreadable code. It needs fixing. 362 363if (exists $ENV{PERLDB_RESTART}) { 364 delete $ENV{PERLDB_RESTART}; 365 # $restart = 1; 366 @hist = get_list('PERLDB_HIST'); 367 %break_on_load = get_list("PERLDB_ON_LOAD"); 368 %postponed = get_list("PERLDB_POSTPONE"); 369 my @had_breakpoints= get_list("PERLDB_VISITED"); 370 for (0 .. $#had_breakpoints) { 371 my %pf = get_list("PERLDB_FILE_$_"); 372 $postponed_file{$had_breakpoints[$_]} = \%pf if %pf; 373 } 374 my %opt = get_list("PERLDB_OPT"); 375 my ($opt,$val); 376 while (($opt,$val) = each %opt) { 377 $val =~ s/[\\\']/\\$1/g; 378 parse_options("$opt'$val'"); 379 } 380 @INC = get_list("PERLDB_INC"); 381 @ini_INC = @INC; 382 $pretype = [get_list("PERLDB_PRETYPE")]; 383 $pre = [get_list("PERLDB_PRE")]; 384 $post = [get_list("PERLDB_POST")]; 385 @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead); 386} 387 388if ($notty) { 389 $runnonstop = 1; 390} else { 391 # Is Perl being run from a slave editor or graphical debugger? 392 $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs')); 393 $rl = 0, shift(@main::ARGV) if $slave_editor; 394 395 #require Term::ReadLine; 396 397 if ($^O eq 'cygwin') { 398 # /dev/tty is binary. use stdin for textmode 399 undef $console; 400 } elsif (-e "/dev/tty") { 401 $console = "/dev/tty"; 402 } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') { 403 $console = "con"; 404 } elsif ($^O eq 'MacOS') { 405 if ($MacPerl::Version !~ /MPW/) { 406 $console = "Dev:Console:Perl Debug"; # Separate window for application 407 } else { 408 $console = "Dev:Console"; 409 } 410 } else { 411 $console = "sys\$command"; 412 } 413 414 if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) { 415 $console = undef; 416 } 417 418 # Around a bug: 419 if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2 420 $console = undef; 421 } 422 423 if ($^O eq 'epoc') { 424 $console = undef; 425 } 426 427 $console = $tty if defined $tty; 428 429 if (defined $remoteport) { 430 require IO::Socket; 431 $OUT = new IO::Socket::INET( Timeout => '10', 432 PeerAddr => $remoteport, 433 Proto => 'tcp', 434 ); 435 if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; } 436 $IN = $OUT; 437 } 438 else { 439 if (defined $console) { 440 open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN"); 441 open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR") 442 || open(OUT,">&STDOUT"); # so we don't dongle stdout 443 } else { 444 open(IN,"<&STDIN"); 445 open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout 446 $console = 'STDIN/OUT'; 447 } 448 # so open("|more") can read from STDOUT and so we don't dingle stdin 449 $IN = \*IN; 450 451 $OUT = \*OUT; 452 } 453 select($OUT); 454 $| = 1; # for DB::OUT 455 select(STDOUT); 456 457 $LINEINFO = $OUT unless defined $LINEINFO; 458 $lineinfo = $console unless defined $lineinfo; 459 460 $| = 1; # for real STDOUT 461 462 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; 463 unless ($runnonstop) { 464 print $OUT "\nLoading DB routines from $header\n"; 465 print $OUT ("Editor support ", 466 $slave_editor ? "enabled" : "available", 467 ".\n"); 468 print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n"; 469 } 470} 471 472@ARGS = @ARGV; 473for (@args) { 474 s/\'/\\\'/g; 475 s/(.*)/'$1'/ unless /^-?[\d.]+$/; 476} 477 478if (defined &afterinit) { # May be defined in $rcfile 479 &afterinit(); 480} 481 482$I_m_init = 1; 483 484############################################################ Subroutines 485 486sub DB { 487 # _After_ the perl program is compiled, $single is set to 1: 488 if ($single and not $second_time++) { 489 if ($runnonstop) { # Disable until signal 490 for ($i=0; $i <= $stack_depth; ) { 491 $stack[$i++] &= ~1; 492 } 493 $single = 0; 494 # return; # Would not print trace! 495 } elsif ($ImmediateStop) { 496 $ImmediateStop = 0; 497 $signal = 1; 498 } 499 } 500 $runnonstop = 0 if $single or $signal; # Disable it if interactive. 501 &save; 502 ($package, $filename, $line) = caller; 503 $filename_ini = $filename; 504 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' . 505 "package $package;"; # this won't let them modify, alas 506 local(*dbline) = $main::{'_<' . $filename}; 507 $max = $#dbline; 508 if (($stop,$action) = split(/\0/,$dbline{$line})) { 509 if ($stop eq '1') { 510 $signal |= 1; 511 } elsif ($stop) { 512 $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval; 513 $dbline{$line} =~ s/;9($|\0)/$1/; 514 } 515 } 516 my $was_signal = $signal; 517 if ($trace & 2) { 518 for (my $n = 0; $n <= $#to_watch; $n++) { 519 $evalarg = $to_watch[$n]; 520 local $onetimeDump; # Do not output results 521 my ($val) = &eval; # Fix context (&eval is doing array)? 522 $val = ( (defined $val) ? "'$val'" : 'undef' ); 523 if ($val ne $old_watch[$n]) { 524 $signal = 1; 525 print $OUT <<EOP; 526Watchpoint $n:\t$to_watch[$n] changed: 527 old value:\t$old_watch[$n] 528 new value:\t$val 529EOP 530 $old_watch[$n] = $val; 531 } 532 } 533 } 534 if ($trace & 4) { # User-installed watch 535 return if watchfunction($package, $filename, $line) 536 and not $single and not $was_signal and not ($trace & ~4); 537 } 538 $was_signal = $signal; 539 $signal = 0; 540 if ($single || ($trace & 1) || $was_signal) { 541 if ($slave_editor) { 542 $position = "\032\032$filename:$line:0\n"; 543 print $LINEINFO $position; 544 } elsif ($package eq 'DB::fake') { 545 $term || &setterm; 546 print_help(<<EOP); 547Debugged program terminated. Use B<q> to quit or B<R> to restart, 548 use B<O> I<inhibit_exit> to avoid stopping after program termination, 549 B<h q>, B<h R> or B<h O> to get additional info. 550EOP 551 $package = 'main'; 552 $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' . 553 "package $package;"; # this won't let them modify, alas 554 } else { 555 $sub =~ s/\'/::/; 556 $prefix = $sub =~ /::/ ? "" : "${'package'}::"; 557 $prefix .= "$sub($filename:"; 558 $after = ($dbline[$line] =~ /\n$/ ? '' : "\n"); 559 if (length($prefix) > 30) { 560 $position = "$prefix$line):\n$line:\t$dbline[$line]$after"; 561 $prefix = ""; 562 $infix = ":\t"; 563 } else { 564 $infix = "):\t"; 565 $position = "$prefix$line$infix$dbline[$line]$after"; 566 } 567 if ($frame) { 568 print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after"; 569 } else { 570 print $LINEINFO $position; 571 } 572 for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi 573 last if $dbline[$i] =~ /^\s*[\;\}\#\n]/; 574 last if $signal; 575 $after = ($dbline[$i] =~ /\n$/ ? '' : "\n"); 576 $incr_pos = "$prefix$i$infix$dbline[$i]$after"; 577 $position .= $incr_pos; 578 if ($frame) { 579 print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after"; 580 } else { 581 print $LINEINFO $incr_pos; 582 } 583 } 584 } 585 } 586 $evalarg = $action, &eval if $action; 587 if ($single || $was_signal) { 588 local $level = $level + 1; 589 foreach $evalarg (@$pre) { 590 &eval; 591 } 592 print $OUT $stack_depth . " levels deep in subroutine calls!\n" 593 if $single & 4; 594 $start = $line; 595 $incr = -1; # for backward motion. 596 @typeahead = (@$pretype, @typeahead); 597 CMD: 598 while (($term || &setterm), 599 ($term_pid == $$ or &resetterm), 600 defined ($cmd=&readline(" DB" . ('<' x $level) . 601 ($#hist+1) . ('>' x $level) . 602 " "))) 603 { 604 $single = 0; 605 $signal = 0; 606 $cmd =~ s/\\$/\n/ && do { 607 $cmd .= &readline(" cont: "); 608 redo CMD; 609 }; 610 $cmd =~ /^$/ && ($cmd = $laststep); 611 push(@hist,$cmd) if length($cmd) > 1; 612 PIPE: { 613 $cmd =~ s/^\s+//s; # trim annoying leading whitespace 614 $cmd =~ s/\s+$//s; # trim annoying trailing whitespace 615 ($i) = split(/\s+/,$cmd); 616 if ($alias{$i}) { 617 # squelch the sigmangler 618 local $SIG{__DIE__}; 619 local $SIG{__WARN__}; 620 eval "\$cmd =~ $alias{$i}"; 621 if ($@) { 622 print $OUT "Couldn't evaluate `$i' alias: $@"; 623 next CMD; 624 } 625 } 626 $cmd =~ /^q$/ && ($fall_off_end = 1) && exit $?; 627 $cmd =~ /^h$/ && do { 628 print_help($help); 629 next CMD; }; 630 $cmd =~ /^h\s+h$/ && do { 631 print_help($summary); 632 next CMD; }; 633 # support long commands; otherwise bogus errors 634 # happen when you ask for h on <CR> for example 635 $cmd =~ /^h\s+(\S.*)$/ && do { 636 my $asked = $1; # for proper errmsg 637 my $qasked = quotemeta($asked); # for searching 638 # XXX: finds CR but not <CR> 639 if ($help =~ /^<?(?:[IB]<)$qasked/m) { 640 while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) { 641 print_help($1); 642 } 643 } else { 644 print_help("B<$asked> is not a debugger command.\n"); 645 } 646 next CMD; }; 647 $cmd =~ /^t$/ && do { 648 $trace ^= 1; 649 print $OUT "Trace = " . 650 (($trace & 1) ? "on" : "off" ) . "\n"; 651 next CMD; }; 652 $cmd =~ /^S(\s+(!)?(.+))?$/ && do { 653 $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1; 654 foreach $subname (sort(keys %sub)) { 655 if ($Snocheck or $Srev^($subname =~ /$Spatt/)) { 656 print $OUT $subname,"\n"; 657 } 658 } 659 next CMD; }; 660 $cmd =~ /^v$/ && do { 661 list_versions(); next CMD}; 662 $cmd =~ s/^X\b/V $package/; 663 $cmd =~ /^V$/ && do { 664 $cmd = "V $package"; }; 665 $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do { 666 local ($savout) = select($OUT); 667 $packname = $1; 668 @vars = split(' ',$2); 669 do 'dumpvar.pl' unless defined &main::dumpvar; 670 if (defined &main::dumpvar) { 671 local $frame = 0; 672 local $doret = -2; 673 # must detect sigpipe failures 674 eval { &main::dumpvar($packname,@vars) }; 675 if ($@) { 676 die unless $@ =~ /dumpvar print failed/; 677 } 678 } else { 679 print $OUT "dumpvar.pl not available.\n"; 680 } 681 select ($savout); 682 next CMD; }; 683 $cmd =~ s/^x\b/ / && do { # So that will be evaled 684 $onetimeDump = 'dump'; }; 685 $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do { 686 methods($1); next CMD}; 687 $cmd =~ s/^m\b/ / && do { # So this will be evaled 688 $onetimeDump = 'methods'; }; 689 $cmd =~ /^f\b\s*(.*)/ && do { 690 $file = $1; 691 $file =~ s/\s+$//; 692 if (!$file) { 693 print $OUT "The old f command is now the r command.\n"; 694 print $OUT "The new f command switches filenames.\n"; 695 next CMD; 696 } 697 if (!defined $main::{'_<' . $file}) { 698 if (($try) = grep(m#^_<.*$file#, keys %main::)) {{ 699 $try = substr($try,2); 700 print $OUT "Choosing $try matching `$file':\n"; 701 $file = $try; 702 }} 703 } 704 if (!defined $main::{'_<' . $file}) { 705 print $OUT "No file matching `$file' is loaded.\n"; 706 next CMD; 707 } elsif ($file ne $filename) { 708 *dbline = $main::{'_<' . $file}; 709 $max = $#dbline; 710 $filename = $file; 711 $start = 1; 712 $cmd = "l"; 713 } else { 714 print $OUT "Already in $file.\n"; 715 next CMD; 716 } 717 }; 718 $cmd =~ s/^l\s+-\s*$/-/; 719 $cmd =~ /^([lb])\b\s*(\$.*)/s && do { 720 $evalarg = $2; 721 my ($s) = &eval; 722 print($OUT "Error: $@\n"), next CMD if $@; 723 $s = CvGV_name($s); 724 print($OUT "Interpreted as: $1 $s\n"); 725 $cmd = "$1 $s"; 726 }; 727 $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do { 728 $subname = $1; 729 $subname =~ s/\'/::/; 730 $subname = $package."::".$subname 731 unless $subname =~ /::/; 732 $subname = "main".$subname if substr($subname,0,2) eq "::"; 733 @pieces = split(/:/,find_sub($subname) || $sub{$subname}); 734 $subrange = pop @pieces; 735 $file = join(':', @pieces); 736 if ($file ne $filename) { 737 print $OUT "Switching to file '$file'.\n" 738 unless $slave_editor; 739 *dbline = $main::{'_<' . $file}; 740 $max = $#dbline; 741 $filename = $file; 742 } 743 if ($subrange) { 744 if (eval($subrange) < -$window) { 745 $subrange =~ s/-.*/+/; 746 } 747 $cmd = "l $subrange"; 748 } else { 749 print $OUT "Subroutine $subname not found.\n"; 750 next CMD; 751 } }; 752 $cmd =~ /^\.$/ && do { 753 $incr = -1; # for backward motion. 754 $start = $line; 755 $filename = $filename_ini; 756 *dbline = $main::{'_<' . $filename}; 757 $max = $#dbline; 758 print $LINEINFO $position; 759 next CMD }; 760 $cmd =~ /^w\b\s*(\d*)$/ && do { 761 $incr = $window - 1; 762 $start = $1 if $1; 763 $start -= $preview; 764 #print $OUT 'l ' . $start . '-' . ($start + $incr); 765 $cmd = 'l ' . $start . '-' . ($start + $incr); }; 766 $cmd =~ /^-$/ && do { 767 $start -= $incr + $window + 1; 768 $start = 1 if $start <= 0; 769 $incr = $window - 1; 770 $cmd = 'l ' . ($start) . '+'; }; 771 $cmd =~ /^l$/ && do { 772 $incr = $window - 1; 773 $cmd = 'l ' . $start . '-' . ($start + $incr); }; 774 $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do { 775 $start = $1 if $1; 776 $incr = $2; 777 $incr = $window - 1 unless $incr; 778 $cmd = 'l ' . $start . '-' . ($start + $incr); }; 779 $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do { 780 $end = (!defined $2) ? $max : ($4 ? $4 : $2); 781 $end = $max if $end > $max; 782 $i = $2; 783 $i = $line if $i eq '.'; 784 $i = 1 if $i < 1; 785 $incr = $end - $i; 786 if ($slave_editor) { 787 print $OUT "\032\032$filename:$i:0\n"; 788 $i = $end; 789 } else { 790 for (; $i <= $end; $i++) { 791 ($stop,$action) = split(/\0/, $dbline{$i}); 792 $arrow = ($i==$line 793 and $filename eq $filename_ini) 794 ? '==>' 795 : ($dbline[$i]+0 ? ':' : ' ') ; 796 $arrow .= 'b' if $stop; 797 $arrow .= 'a' if $action; 798 print $OUT "$i$arrow\t", $dbline[$i]; 799 $i++, last if $signal; 800 } 801 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/; 802 } 803 $start = $i; # remember in case they want more 804 $start = $max if $start > $max; 805 next CMD; }; 806 $cmd =~ /^D$/ && do { 807 print $OUT "Deleting all breakpoints...\n"; 808 my $file; 809 for $file (keys %had_breakpoints) { 810 local *dbline = $main::{'_<' . $file}; 811 my $max = $#dbline; 812 my $was; 813 814 for ($i = 1; $i <= $max ; $i++) { 815 if (defined $dbline{$i}) { 816 $dbline{$i} =~ s/^[^\0]+//; 817 if ($dbline{$i} =~ s/^\0?$//) { 818 delete $dbline{$i}; 819 } 820 } 821 } 822 823 if (not $had_breakpoints{$file} &= ~1) { 824 delete $had_breakpoints{$file}; 825 } 826 } 827 undef %postponed; 828 undef %postponed_file; 829 undef %break_on_load; 830 next CMD; }; 831 $cmd =~ /^L$/ && do { 832 my $file; 833 for $file (keys %had_breakpoints) { 834 local *dbline = $main::{'_<' . $file}; 835 my $max = $#dbline; 836 my $was; 837 838 for ($i = 1; $i <= $max; $i++) { 839 if (defined $dbline{$i}) { 840 print $OUT "$file:\n" unless $was++; 841 print $OUT " $i:\t", $dbline[$i]; 842 ($stop,$action) = split(/\0/, $dbline{$i}); 843 print $OUT " break if (", $stop, ")\n" 844 if $stop; 845 print $OUT " action: ", $action, "\n" 846 if $action; 847 last if $signal; 848 } 849 } 850 } 851 if (%postponed) { 852 print $OUT "Postponed breakpoints in subroutines:\n"; 853 my $subname; 854 for $subname (keys %postponed) { 855 print $OUT " $subname\t$postponed{$subname}\n"; 856 last if $signal; 857 } 858 } 859 my @have = map { # Combined keys 860 keys %{$postponed_file{$_}} 861 } keys %postponed_file; 862 if (@have) { 863 print $OUT "Postponed breakpoints in files:\n"; 864 my ($file, $line); 865 for $file (keys %postponed_file) { 866 my $db = $postponed_file{$file}; 867 print $OUT " $file:\n"; 868 for $line (sort {$a <=> $b} keys %$db) { 869 print $OUT " $line:\n"; 870 my ($stop,$action) = split(/\0/, $$db{$line}); 871 print $OUT " break if (", $stop, ")\n" 872 if $stop; 873 print $OUT " action: ", $action, "\n" 874 if $action; 875 last if $signal; 876 } 877 last if $signal; 878 } 879 } 880 if (%break_on_load) { 881 print $OUT "Breakpoints on load:\n"; 882 my $file; 883 for $file (keys %break_on_load) { 884 print $OUT " $file\n"; 885 last if $signal; 886 } 887 } 888 if ($trace & 2) { 889 print $OUT "Watch-expressions:\n"; 890 my $expr; 891 for $expr (@to_watch) { 892 print $OUT " $expr\n"; 893 last if $signal; 894 } 895 } 896 next CMD; }; 897 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do { 898 my $file = $1; $file =~ s/\s+$//; 899 { 900 $break_on_load{$file} = 1; 901 $break_on_load{$::INC{$file}} = 1 if $::INC{$file}; 902 $file .= '.pm', redo unless $file =~ /\./; 903 } 904 $had_breakpoints{$file} |= 1; 905 print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n"; 906 next CMD; }; 907 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do { 908 my $cond = length $3 ? $3 : '1'; 909 my ($subname, $break) = ($2, $1 eq 'postpone'); 910 $subname =~ s/\'/::/g; 911 $subname = "${'package'}::" . $subname 912 unless $subname =~ /::/; 913 $subname = "main".$subname if substr($subname,0,2) eq "::"; 914 $postponed{$subname} = $break 915 ? "break +0 if $cond" : "compile"; 916 next CMD; }; 917 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do { 918 $subname = $1; 919 $cond = length $2 ? $2 : '1'; 920 $subname =~ s/\'/::/g; 921 $subname = "${'package'}::" . $subname 922 unless $subname =~ /::/; 923 $subname = "main".$subname if substr($subname,0,2) eq "::"; 924 # Filename below can contain ':' 925 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/); 926 $i += 0; 927 if ($i) { 928 local $filename = $file; 929 local *dbline = $main::{'_<' . $filename}; 930 $had_breakpoints{$filename} |= 1; 931 $max = $#dbline; 932 ++$i while $dbline[$i] == 0 && $i < $max; 933 $dbline{$i} =~ s/^[^\0]*/$cond/; 934 } else { 935 print $OUT "Subroutine $subname not found.\n"; 936 } 937 next CMD; }; 938 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do { 939 $i = $1 || $line; 940 $cond = length $2 ? $2 : '1'; 941 if ($dbline[$i] == 0) { 942 print $OUT "Line $i not breakable.\n"; 943 } else { 944 $had_breakpoints{$filename} |= 1; 945 $dbline{$i} =~ s/^[^\0]*/$cond/; 946 } 947 next CMD; }; 948 $cmd =~ /^d\b\s*(\d*)/ && do { 949 $i = $1 || $line; 950 if ($dbline[$i] == 0) { 951 print $OUT "Line $i not breakable.\n"; 952 } else { 953 $dbline{$i} =~ s/^[^\0]*//; 954 delete $dbline{$i} if $dbline{$i} eq ''; 955 } 956 next CMD; }; 957 $cmd =~ /^A$/ && do { 958 print $OUT "Deleting all actions...\n"; 959 my $file; 960 for $file (keys %had_breakpoints) { 961 local *dbline = $main::{'_<' . $file}; 962 my $max = $#dbline; 963 my $was; 964 965 for ($i = 1; $i <= $max ; $i++) { 966 if (defined $dbline{$i}) { 967 $dbline{$i} =~ s/\0[^\0]*//; 968 delete $dbline{$i} if $dbline{$i} eq ''; 969 } 970 } 971 972 unless ($had_breakpoints{$file} &= ~2) { 973 delete $had_breakpoints{$file}; 974 } 975 } 976 next CMD; }; 977 $cmd =~ /^O\s*$/ && do { 978 for (@options) { 979 &dump_option($_); 980 } 981 next CMD; }; 982 $cmd =~ /^O\s*(\S.*)/ && do { 983 parse_options($1); 984 next CMD; }; 985 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE 986 push @$pre, action($1); 987 next CMD; }; 988 $cmd =~ /^>>\s*(.*)/ && do { 989 push @$post, action($1); 990 next CMD; }; 991 $cmd =~ /^<\s*(.*)/ && do { 992 unless ($1) { 993 print $OUT "All < actions cleared.\n"; 994 $pre = []; 995 next CMD; 996 } 997 if ($1 eq '?') { 998 unless (@$pre) { 999 print $OUT "No pre-prompt Perl actions.\n"; 1000 next CMD; 1001 } 1002 print $OUT "Perl commands run before each prompt:\n"; 1003 for my $action ( @$pre ) { 1004 print $OUT "\t< -- $action\n"; 1005 } 1006 next CMD; 1007 } 1008 $pre = [action($1)]; 1009 next CMD; }; 1010 $cmd =~ /^>\s*(.*)/ && do { 1011 unless ($1) { 1012 print $OUT "All > actions cleared.\n"; 1013 $post = []; 1014 next CMD; 1015 } 1016 if ($1 eq '?') { 1017 unless (@$post) { 1018 print $OUT "No post-prompt Perl actions.\n"; 1019 next CMD; 1020 } 1021 print $OUT "Perl commands run after each prompt:\n"; 1022 for my $action ( @$post ) { 1023 print $OUT "\t> -- $action\n"; 1024 } 1025 next CMD; 1026 } 1027 $post = [action($1)]; 1028 next CMD; }; 1029 $cmd =~ /^\{\{\s*(.*)/ && do { 1030 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) { 1031 print $OUT "{{ is now a debugger command\n", 1032 "use `;{{' if you mean Perl code\n"; 1033 $cmd = "h {{"; 1034 redo CMD; 1035 } 1036 push @$pretype, $1; 1037 next CMD; }; 1038 $cmd =~ /^\{\s*(.*)/ && do { 1039 unless ($1) { 1040 print $OUT "All { actions cleared.\n"; 1041 $pretype = []; 1042 next CMD; 1043 } 1044 if ($1 eq '?') { 1045 unless (@$pretype) { 1046 print $OUT "No pre-prompt debugger actions.\n"; 1047 next CMD; 1048 } 1049 print $OUT "Debugger commands run before each prompt:\n"; 1050 for my $action ( @$pretype ) { 1051 print $OUT "\t{ -- $action\n"; 1052 } 1053 next CMD; 1054 } 1055 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) { 1056 print $OUT "{ is now a debugger command\n", 1057 "use `;{' if you mean Perl code\n"; 1058 $cmd = "h {"; 1059 redo CMD; 1060 } 1061 $pretype = [$1]; 1062 next CMD; }; 1063 $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do { 1064 $i = $1 || $line; $j = $2; 1065 if (length $j) { 1066 if ($dbline[$i] == 0) { 1067 print $OUT "Line $i may not have an action.\n"; 1068 } else { 1069 $had_breakpoints{$filename} |= 2; 1070 $dbline{$i} =~ s/\0[^\0]*//; 1071 $dbline{$i} .= "\0" . action($j); 1072 } 1073 } else { 1074 $dbline{$i} =~ s/\0[^\0]*//; 1075 delete $dbline{$i} if $dbline{$i} eq ''; 1076 } 1077 next CMD; }; 1078 $cmd =~ /^n$/ && do { 1079 end_report(), next CMD if $finished and $level <= 1; 1080 $single = 2; 1081 $laststep = $cmd; 1082 last CMD; }; 1083 $cmd =~ /^s$/ && do { 1084 end_report(), next CMD if $finished and $level <= 1; 1085 $single = 1; 1086 $laststep = $cmd; 1087 last CMD; }; 1088 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do { 1089 end_report(), next CMD if $finished and $level <= 1; 1090 $subname = $i = $1; 1091 # Probably not needed, since we finish an interactive 1092 # sub-session anyway... 1093 # local $filename = $filename; 1094 # local *dbline = *dbline; # XXX Would this work?! 1095 if ($i =~ /\D/) { # subroutine name 1096 $subname = $package."::".$subname 1097 unless $subname =~ /::/; 1098 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/); 1099 $i += 0; 1100 if ($i) { 1101 $filename = $file; 1102 *dbline = $main::{'_<' . $filename}; 1103 $had_breakpoints{$filename} |= 1; 1104 $max = $#dbline; 1105 ++$i while $dbline[$i] == 0 && $i < $max; 1106 } else { 1107 print $OUT "Subroutine $subname not found.\n"; 1108 next CMD; 1109 } 1110 } 1111 if ($i) { 1112 if ($dbline[$i] == 0) { 1113 print $OUT "Line $i not breakable.\n"; 1114 next CMD; 1115 } 1116 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p. 1117 } 1118 for ($i=0; $i <= $stack_depth; ) { 1119 $stack[$i++] &= ~1; 1120 } 1121 last CMD; }; 1122 $cmd =~ /^r$/ && do { 1123 end_report(), next CMD if $finished and $level <= 1; 1124 $stack[$stack_depth] |= 1; 1125 $doret = $option{PrintRet} ? $stack_depth - 1 : -2; 1126 last CMD; }; 1127 $cmd =~ /^R$/ && do { 1128 print $OUT "Warning: some settings and command-line options may be lost!\n"; 1129 my (@script, @flags, $cl); 1130 push @flags, '-w' if $ini_warn; 1131 # Put all the old includes at the start to get 1132 # the same debugger. 1133 for (@ini_INC) { 1134 push @flags, '-I', $_; 1135 } 1136 # Arrange for setting the old INC: 1137 set_list("PERLDB_INC", @ini_INC); 1138 if ($0 eq '-e') { 1139 for (1..$#{'::_<-e'}) { # The first line is PERL5DB 1140 chomp ($cl = ${'::_<-e'}[$_]); 1141 push @script, '-e', $cl; 1142 } 1143 } else { 1144 @script = $0; 1145 } 1146 set_list("PERLDB_HIST", 1147 $term->Features->{getHistory} 1148 ? $term->GetHistory : @hist); 1149 my @had_breakpoints = keys %had_breakpoints; 1150 set_list("PERLDB_VISITED", @had_breakpoints); 1151 set_list("PERLDB_OPT", %option); 1152 set_list("PERLDB_ON_LOAD", %break_on_load); 1153 my @hard; 1154 for (0 .. $#had_breakpoints) { 1155 my $file = $had_breakpoints[$_]; 1156 *dbline = $main::{'_<' . $file}; 1157 next unless %dbline or $postponed_file{$file}; 1158 (push @hard, $file), next 1159 if $file =~ /^\(eval \d+\)$/; 1160 my @add; 1161 @add = %{$postponed_file{$file}} 1162 if $postponed_file{$file}; 1163 set_list("PERLDB_FILE_$_", %dbline, @add); 1164 } 1165 for (@hard) { # Yes, really-really... 1166 # Find the subroutines in this eval 1167 *dbline = $main::{'_<' . $_}; 1168 my ($quoted, $sub, %subs, $line) = quotemeta $_; 1169 for $sub (keys %sub) { 1170 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/; 1171 $subs{$sub} = [$1, $2]; 1172 } 1173 unless (%subs) { 1174 print $OUT 1175 "No subroutines in $_, ignoring breakpoints.\n"; 1176 next; 1177 } 1178 LINES: for $line (keys %dbline) { 1179 # One breakpoint per sub only: 1180 my ($offset, $sub, $found); 1181 SUBS: for $sub (keys %subs) { 1182 if ($subs{$sub}->[1] >= $line # Not after the subroutine 1183 and (not defined $offset # Not caught 1184 or $offset < 0 )) { # or badly caught 1185 $found = $sub; 1186 $offset = $line - $subs{$sub}->[0]; 1187 $offset = "+$offset", last SUBS if $offset >= 0; 1188 } 1189 } 1190 if (defined $offset) { 1191 $postponed{$found} = 1192 "break $offset if $dbline{$line}"; 1193 } else { 1194 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n"; 1195 } 1196 } 1197 } 1198 set_list("PERLDB_POSTPONE", %postponed); 1199 set_list("PERLDB_PRETYPE", @$pretype); 1200 set_list("PERLDB_PRE", @$pre); 1201 set_list("PERLDB_POST", @$post); 1202 set_list("PERLDB_TYPEAHEAD", @typeahead); 1203 $ENV{PERLDB_RESTART} = 1; 1204 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS"; 1205 exec $^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS; 1206 print $OUT "exec failed: $!\n"; 1207 last CMD; }; 1208 $cmd =~ /^T$/ && do { 1209 print_trace($OUT, 1); # skip DB 1210 next CMD; }; 1211 $cmd =~ /^W\s*$/ && do { 1212 $trace &= ~2; 1213 @to_watch = @old_watch = (); 1214 next CMD; }; 1215 $cmd =~ /^W\b\s*(.*)/s && do { 1216 push @to_watch, $1; 1217 $evalarg = $1; 1218 my ($val) = &eval; 1219 $val = (defined $val) ? "'$val'" : 'undef' ; 1220 push @old_watch, $val; 1221 $trace |= 2; 1222 next CMD; }; 1223 $cmd =~ /^\/(.*)$/ && do { 1224 $inpat = $1; 1225 $inpat =~ s:([^\\])/$:$1:; 1226 if ($inpat ne "") { 1227 # squelch the sigmangler 1228 local $SIG{__DIE__}; 1229 local $SIG{__WARN__}; 1230 eval '$inpat =~ m'."\a$inpat\a"; 1231 if ($@ ne "") { 1232 print $OUT "$@"; 1233 next CMD; 1234 } 1235 $pat = $inpat; 1236 } 1237 $end = $start; 1238 $incr = -1; 1239 eval ' 1240 for (;;) { 1241 ++$start; 1242 $start = 1 if ($start > $max); 1243 last if ($start == $end); 1244 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) { 1245 if ($slave_editor) { 1246 print $OUT "\032\032$filename:$start:0\n"; 1247 } else { 1248 print $OUT "$start:\t", $dbline[$start], "\n"; 1249 } 1250 last; 1251 } 1252 } '; 1253 print $OUT "/$pat/: not found\n" if ($start == $end); 1254 next CMD; }; 1255 $cmd =~ /^\?(.*)$/ && do { 1256 $inpat = $1; 1257 $inpat =~ s:([^\\])\?$:$1:; 1258 if ($inpat ne "") { 1259 # squelch the sigmangler 1260 local $SIG{__DIE__}; 1261 local $SIG{__WARN__}; 1262 eval '$inpat =~ m'."\a$inpat\a"; 1263 if ($@ ne "") { 1264 print $OUT $@; 1265 next CMD; 1266 } 1267 $pat = $inpat; 1268 } 1269 $end = $start; 1270 $incr = -1; 1271 eval ' 1272 for (;;) { 1273 --$start; 1274 $start = $max if ($start <= 0); 1275 last if ($start == $end); 1276 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) { 1277 if ($slave_editor) { 1278 print $OUT "\032\032$filename:$start:0\n"; 1279 } else { 1280 print $OUT "$start:\t", $dbline[$start], "\n"; 1281 } 1282 last; 1283 } 1284 } '; 1285 print $OUT "?$pat?: not found\n" if ($start == $end); 1286 next CMD; }; 1287 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do { 1288 pop(@hist) if length($cmd) > 1; 1289 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist); 1290 $cmd = $hist[$i]; 1291 print $OUT $cmd, "\n"; 1292 redo CMD; }; 1293 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do { 1294 &system($1); 1295 next CMD; }; 1296 $cmd =~ /^$rc([^$rc].*)$/ && do { 1297 $pat = "^$1"; 1298 pop(@hist) if length($cmd) > 1; 1299 for ($i = $#hist; $i; --$i) { 1300 last if $hist[$i] =~ /$pat/; 1301 } 1302 if (!$i) { 1303 print $OUT "No such command!\n\n"; 1304 next CMD; 1305 } 1306 $cmd = $hist[$i]; 1307 print $OUT $cmd, "\n"; 1308 redo CMD; }; 1309 $cmd =~ /^$sh$/ && do { 1310 &system($ENV{SHELL}||"/bin/sh"); 1311 next CMD; }; 1312 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do { 1313 # XXX: using csh or tcsh destroys sigint retvals! 1314 #&system($1); # use this instead 1315 &system($ENV{SHELL}||"/bin/sh","-c",$1); 1316 next CMD; }; 1317 $cmd =~ /^H\b\s*(-(\d+))?/ && do { 1318 $end = $2 ? ($#hist-$2) : 0; 1319 $hist = 0 if $hist < 0; 1320 for ($i=$#hist; $i>$end; $i--) { 1321 print $OUT "$i: ",$hist[$i],"\n" 1322 unless $hist[$i] =~ /^.?$/; 1323 }; 1324 next CMD; }; 1325 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do { 1326 runman($1); 1327 next CMD; }; 1328 $cmd =~ s/^p$/print {\$DB::OUT} \$_/; 1329 $cmd =~ s/^p\b/print {\$DB::OUT} /; 1330 $cmd =~ s/^=\s*// && do { 1331 my @keys; 1332 if (length $cmd == 0) { 1333 @keys = sort keys %alias; 1334 } 1335 elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) { 1336 # can't use $_ or kill //g state 1337 for my $x ($k, $v) { $x =~ s/\a/\\a/g } 1338 $alias{$k} = "s\a$k\a$v\a"; 1339 # squelch the sigmangler 1340 local $SIG{__DIE__}; 1341 local $SIG{__WARN__}; 1342 unless (eval "sub { s\a$k\a$v\a }; 1") { 1343 print $OUT "Can't alias $k to $v: $@\n"; 1344 delete $alias{$k}; 1345 next CMD; 1346 } 1347 @keys = ($k); 1348 } 1349 else { 1350 @keys = ($cmd); 1351 } 1352 for my $k (@keys) { 1353 if ((my $v = $alias{$k}) =~ ss\a$k\a(.*)\a$1) { 1354 print $OUT "$k\t= $1\n"; 1355 } 1356 elsif (defined $alias{$k}) { 1357 print $OUT "$k\t$alias{$k}\n"; 1358 } 1359 else { 1360 print "No alias for $k\n"; 1361 } 1362 } 1363 next CMD; }; 1364 $cmd =~ /^\|\|?\s*[^|]/ && do { 1365 if ($pager =~ /^\|/) { 1366 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT"); 1367 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT"); 1368 } else { 1369 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT"); 1370 } 1371 fix_less(); 1372 unless ($piped=open(OUT,$pager)) { 1373 &warn("Can't pipe output to `$pager'"); 1374 if ($pager =~ /^\|/) { 1375 open(OUT,">&STDOUT") # XXX: lost message 1376 || &warn("Can't restore DB::OUT"); 1377 open(STDOUT,">&SAVEOUT") 1378 || &warn("Can't restore STDOUT"); 1379 close(SAVEOUT); 1380 } else { 1381 open(OUT,">&STDOUT") # XXX: lost message 1382 || &warn("Can't restore DB::OUT"); 1383 } 1384 next CMD; 1385 } 1386 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/ 1387 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE}); 1388 $selected= select(OUT); 1389 $|= 1; 1390 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/; 1391 $cmd =~ s/^\|+\s*//; 1392 redo PIPE; 1393 }; 1394 # XXX Local variants do not work! 1395 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/; 1396 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'}; 1397 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'}; 1398 } # PIPE: 1399 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval; 1400 if ($onetimeDump) { 1401 $onetimeDump = undef; 1402 } elsif ($term_pid == $$) { 1403 print $OUT "\n"; 1404 } 1405 } continue { # CMD: 1406 if ($piped) { 1407 if ($pager =~ /^\|/) { 1408 $? = 0; 1409 # we cannot warn here: the handle is missing --tchrist 1410 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n"; 1411 1412 # most of the $? crud was coping with broken cshisms 1413 if ($?) { 1414 print SAVEOUT "Pager `$pager' failed: "; 1415 if ($? == -1) { 1416 print SAVEOUT "shell returned -1\n"; 1417 } elsif ($? >> 8) { 1418 print SAVEOUT 1419 ( $? & 127 ) ? " (SIG#".($?&127).")" : "", 1420 ( $? & 128 ) ? " -- core dumped" : "", "\n"; 1421 } else { 1422 print SAVEOUT "status ", ($? >> 8), "\n"; 1423 } 1424 } 1425 1426 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT"); 1427 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT"); 1428 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch; 1429 # Will stop ignoring SIGPIPE if done like nohup(1) 1430 # does SIGINT but Perl doesn't give us a choice. 1431 } else { 1432 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT"); 1433 } 1434 close(SAVEOUT); 1435 select($selected), $selected= "" unless $selected eq ""; 1436 $piped= ""; 1437 } 1438 } # CMD: 1439 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF 1440 foreach $evalarg (@$post) { 1441 &eval; 1442 } 1443 } # if ($single || $signal) 1444 ($@, $!, $^E, $,, $/, $\, $^W) = @saved; 1445 (); 1446} 1447 1448# The following code may be executed now: 1449# BEGIN {warn 4} 1450 1451sub sub { 1452 my ($al, $ret, @ret) = ""; 1453 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') { 1454 $al = " for $$sub"; 1455 } 1456 local $stack_depth = $stack_depth + 1; # Protect from non-local exits 1457 $#stack = $stack_depth; 1458 $stack[-1] = $single; 1459 $single &= 1; 1460 $single |= 4 if $stack_depth == $deep; 1461 ($frame & 4 1462 ? ( (print $LINEINFO ' ' x ($stack_depth - 1), "in "), 1463 # Why -1? But it works! :-( 1464 print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) 1465 : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame; 1466 if (wantarray) { 1467 @ret = &$sub; 1468 $single |= $stack[$stack_depth--]; 1469 ($frame & 4 1470 ? ( (print $LINEINFO ' ' x $stack_depth, "out "), 1471 print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) 1472 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2; 1473 if ($doret eq $stack_depth or $frame & 16) { 1474 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO); 1475 print $fh ' ' x $stack_depth if $frame & 16; 1476 print $fh "list context return from $sub:\n"; 1477 dumpit($fh, \@ret ); 1478 $doret = -2; 1479 } 1480 @ret; 1481 } else { 1482 if (defined wantarray) { 1483 $ret = &$sub; 1484 } else { 1485 &$sub; undef $ret; 1486 }; 1487 $single |= $stack[$stack_depth--]; 1488 ($frame & 4 1489 ? ( (print $LINEINFO ' ' x $stack_depth, "out "), 1490 print_trace($LINEINFO, -1, 1, 1, "$sub$al") ) 1491 : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2; 1492 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) { 1493 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO); 1494 print $fh (' ' x $stack_depth) if $frame & 16; 1495 print $fh (defined wantarray 1496 ? "scalar context return from $sub: " 1497 : "void context return from $sub\n"); 1498 dumpit( $fh, $ret ) if defined wantarray; 1499 $doret = -2; 1500 } 1501 $ret; 1502 } 1503} 1504 1505sub save { 1506 @saved = ($@, $!, $^E, $,, $/, $\, $^W); 1507 $, = ""; $/ = "\n"; $\ = ""; $^W = 0; 1508} 1509 1510# The following takes its argument via $evalarg to preserve current @_ 1511 1512sub eval { 1513 # 'my' would make it visible from user code 1514 # but so does local! --tchrist 1515 local @res; 1516 { 1517 local $otrace = $trace; 1518 local $osingle = $single; 1519 local $od = $^D; 1520 { ($evalarg) = $evalarg =~ /(.*)/s; } 1521 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug 1522 $trace = $otrace; 1523 $single = $osingle; 1524 $^D = $od; 1525 } 1526 my $at = $@; 1527 local $saved[0]; # Preserve the old value of $@ 1528 eval { &DB::save }; 1529 if ($at) { 1530 print $OUT $at; 1531 } elsif ($onetimeDump eq 'dump') { 1532 dumpit($OUT, \@res); 1533 } elsif ($onetimeDump eq 'methods') { 1534 methods($res[0]); 1535 } 1536 @res; 1537} 1538 1539sub postponed_sub { 1540 my $subname = shift; 1541 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) { 1542 my $offset = $1 || 0; 1543 # Filename below can contain ':' 1544 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/); 1545 if ($i) { 1546 $i += $offset; 1547 local *dbline = $main::{'_<' . $file}; 1548 local $^W = 0; # != 0 is magical below 1549 $had_breakpoints{$file} |= 1; 1550 my $max = $#dbline; 1551 ++$i until $dbline[$i] != 0 or $i >= $max; 1552 $dbline{$i} = delete $postponed{$subname}; 1553 } else { 1554 print $OUT "Subroutine $subname not found.\n"; 1555 } 1556 return; 1557 } 1558 elsif ($postponed{$subname} eq 'compile') { $signal = 1 } 1559 #print $OUT "In postponed_sub for `$subname'.\n"; 1560} 1561 1562sub postponed { 1563 if ($ImmediateStop) { 1564 $ImmediateStop = 0; 1565 $signal = 1; 1566 } 1567 return &postponed_sub 1568 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled. 1569 # Cannot be done before the file is compiled 1570 local *dbline = shift; 1571 my $filename = $dbline; 1572 $filename =~ s/^_<//; 1573 $signal = 1, print $OUT "'$filename' loaded...\n" 1574 if $break_on_load{$filename}; 1575 print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame; 1576 return unless $postponed_file{$filename}; 1577 $had_breakpoints{$filename} |= 1; 1578 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic 1579 my $key; 1580 for $key (keys %{$postponed_file{$filename}}) { 1581 $dbline{$key} = ${$postponed_file{$filename}}{$key}; 1582 } 1583 delete $postponed_file{$filename}; 1584} 1585 1586sub dumpit { 1587 local ($savout) = select(shift); 1588 my $osingle = $single; 1589 my $otrace = $trace; 1590 $single = $trace = 0; 1591 local $frame = 0; 1592 local $doret = -2; 1593 unless (defined &main::dumpValue) { 1594 do 'dumpvar.pl'; 1595 } 1596 if (defined &main::dumpValue) { 1597 &main::dumpValue(shift); 1598 } else { 1599 print $OUT "dumpvar.pl not available.\n"; 1600 } 1601 $single = $osingle; 1602 $trace = $otrace; 1603 select ($savout); 1604} 1605 1606# Tied method do not create a context, so may get wrong message: 1607 1608sub print_trace { 1609 my $fh = shift; 1610 my @sub = dump_trace($_[0] + 1, $_[1]); 1611 my $short = $_[2]; # Print short report, next one for sub name 1612 my $s; 1613 for ($i=0; $i <= $#sub; $i++) { 1614 last if $signal; 1615 local $" = ', '; 1616 my $args = defined $sub[$i]{args} 1617 ? "(@{ $sub[$i]{args} })" 1618 : '' ; 1619 $args = (substr $args, 0, $maxtrace - 3) . '...' 1620 if length $args > $maxtrace; 1621 my $file = $sub[$i]{file}; 1622 $file = $file eq '-e' ? $file : "file `$file'" unless $short; 1623 $s = $sub[$i]{sub}; 1624 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace; 1625 if ($short) { 1626 my $sub = @_ >= 4 ? $_[3] : $s; 1627 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n"; 1628 } else { 1629 print $fh "$sub[$i]{context} = $s$args" . 1630 " called from $file" . 1631 " line $sub[$i]{line}\n"; 1632 } 1633 } 1634} 1635 1636sub dump_trace { 1637 my $skip = shift; 1638 my $count = shift || 1e9; 1639 $skip++; 1640 $count += $skip; 1641 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context); 1642 my $nothard = not $frame & 8; 1643 local $frame = 0; # Do not want to trace this. 1644 my $otrace = $trace; 1645 $trace = 0; 1646 for ($i = $skip; 1647 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i); 1648 $i++) { 1649 @a = (); 1650 for $arg (@args) { 1651 my $type; 1652 if (not defined $arg) { 1653 push @a, "undef"; 1654 } elsif ($nothard and tied $arg) { 1655 push @a, "tied"; 1656 } elsif ($nothard and $type = ref $arg) { 1657 push @a, "ref($type)"; 1658 } else { 1659 local $_ = "$arg"; # Safe to stringify now - should not call f(). 1660 s/([\'\\])/\\$1/g; 1661 s/(.*)/'$1'/s 1662 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; 1663 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; 1664 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; 1665 push(@a, $_); 1666 } 1667 } 1668 $context = $context ? '@' : (defined $context ? "\$" : '.'); 1669 $args = $h ? [@a] : undef; 1670 $e =~ s/\n\s*\;\s*\Z// if $e; 1671 $e =~ s/([\\\'])/\\$1/g if $e; 1672 if ($r) { 1673 $sub = "require '$e'"; 1674 } elsif (defined $r) { 1675 $sub = "eval '$e'"; 1676 } elsif ($sub eq '(eval)') { 1677 $sub = "eval {...}"; 1678 } 1679 push(@sub, {context => $context, sub => $sub, args => $args, 1680 file => $file, line => $line}); 1681 last if $signal; 1682 } 1683 $trace = $otrace; 1684 @sub; 1685} 1686 1687sub action { 1688 my $action = shift; 1689 while ($action =~ s/\\$//) { 1690 #print $OUT "+ "; 1691 #$action .= "\n"; 1692 $action .= &gets; 1693 } 1694 $action; 1695} 1696 1697sub unbalanced { 1698 # i hate using globals! 1699 $balanced_brace_re ||= qr{ 1700 ^ \{ 1701 (?: 1702 (?> [^{}] + ) # Non-parens without backtracking 1703 | 1704 (??{ $balanced_brace_re }) # Group with matching parens 1705 ) * 1706 \} $ 1707 }x; 1708 return $_[0] !~ m/$balanced_brace_re/; 1709} 1710 1711sub gets { 1712 &readline("cont: "); 1713} 1714 1715sub system { 1716 # We save, change, then restore STDIN and STDOUT to avoid fork() since 1717 # some non-Unix systems can do system() but have problems with fork(). 1718 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN"); 1719 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT"); 1720 open(STDIN,"<&IN") || &warn("Can't redirect STDIN"); 1721 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT"); 1722 1723 # XXX: using csh or tcsh destroys sigint retvals! 1724 system(@_); 1725 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN"); 1726 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT"); 1727 close(SAVEIN); 1728 close(SAVEOUT); 1729 1730 1731 # most of the $? crud was coping with broken cshisms 1732 if ($? >> 8) { 1733 &warn("(Command exited ", ($? >> 8), ")\n"); 1734 } elsif ($?) { 1735 &warn( "(Command died of SIG#", ($? & 127), 1736 (($? & 128) ? " -- core dumped" : "") , ")", "\n"); 1737 } 1738 1739 return $?; 1740 1741} 1742 1743sub setterm { 1744 local $frame = 0; 1745 local $doret = -2; 1746 eval { require Term::ReadLine } or die $@; 1747 if ($notty) { 1748 if ($tty) { 1749 open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!"; 1750 open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!"; 1751 $IN = \*IN; 1752 $OUT = \*OUT; 1753 my $sel = select($OUT); 1754 $| = 1; 1755 select($sel); 1756 } else { 1757 eval "require Term::Rendezvous;" or die; 1758 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$"; 1759 my $term_rv = new Term::Rendezvous $rv; 1760 $IN = $term_rv->IN; 1761 $OUT = $term_rv->OUT; 1762 } 1763 } 1764 if (!$rl) { 1765 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT; 1766 } else { 1767 $term = new Term::ReadLine 'perldb', $IN, $OUT; 1768 1769 $rl_attribs = $term->Attribs; 1770 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}' 1771 if defined $rl_attribs->{basic_word_break_characters} 1772 and index($rl_attribs->{basic_word_break_characters}, ":") == -1; 1773 $rl_attribs->{special_prefixes} = '$@&%'; 1774 $rl_attribs->{completer_word_break_characters} .= '$@&%'; 1775 $rl_attribs->{completion_function} = \&db_complete; 1776 } 1777 $LINEINFO = $OUT unless defined $LINEINFO; 1778 $lineinfo = $console unless defined $lineinfo; 1779 $term->MinLine(2); 1780 if ($term->Features->{setHistory} and "@hist" ne "?") { 1781 $term->SetHistory(@hist); 1782 } 1783 ornaments($ornaments) if defined $ornaments; 1784 $term_pid = $$; 1785} 1786 1787sub resetterm { # We forked, so we need a different TTY 1788 $term_pid = $$; 1789 if (defined &get_fork_TTY) { 1790 &get_fork_TTY; 1791 } elsif (not defined $fork_TTY 1792 and defined $ENV{TERM} and $ENV{TERM} eq 'xterm' 1793 and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) { 1794 # Possibly _inside_ XTERM 1795 open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\ 1796 sleep 10000000' |]; 1797 $fork_TTY = <XT>; 1798 chomp $fork_TTY; 1799 } 1800 if (defined $fork_TTY) { 1801 TTY($fork_TTY); 1802 undef $fork_TTY; 1803 } else { 1804 print_help(<<EOP); 1805I<#########> Forked, but do not know how to change a B<TTY>. I<#########> 1806 Define B<\$DB::fork_TTY> 1807 - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>. 1808 The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use. 1809 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window 1810 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>. 1811EOP 1812 } 1813} 1814 1815sub readline { 1816 local $.; 1817 if (@typeahead) { 1818 my $left = @typeahead; 1819 my $got = shift @typeahead; 1820 print $OUT "auto(-$left)", shift, $got, "\n"; 1821 $term->AddHistory($got) 1822 if length($got) > 1 and defined $term->Features->{addHistory}; 1823 return $got; 1824 } 1825 local $frame = 0; 1826 local $doret = -2; 1827 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) { 1828 $OUT->write(join('', @_)); 1829 my $stuff; 1830 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread? 1831 $stuff; 1832 } 1833 else { 1834 $term->readline(@_); 1835 } 1836} 1837 1838sub dump_option { 1839 my ($opt, $val)= @_; 1840 $val = option_val($opt,'N/A'); 1841 $val =~ s/([\\\'])/\\$1/g; 1842 printf $OUT "%20s = '%s'\n", $opt, $val; 1843} 1844 1845sub option_val { 1846 my ($opt, $default)= @_; 1847 my $val; 1848 if (defined $optionVars{$opt} 1849 and defined ${$optionVars{$opt}}) { 1850 $val = ${$optionVars{$opt}}; 1851 } elsif (defined $optionAction{$opt} 1852 and defined &{$optionAction{$opt}}) { 1853 $val = &{$optionAction{$opt}}(); 1854 } elsif (defined $optionAction{$opt} 1855 and not defined $option{$opt} 1856 or defined $optionVars{$opt} 1857 and not defined ${$optionVars{$opt}}) { 1858 $val = $default; 1859 } else { 1860 $val = $option{$opt}; 1861 } 1862 $val 1863} 1864 1865sub parse_options { 1866 local($_)= @_; 1867 # too dangerous to let intuitive usage overwrite important things 1868 # defaultion should never be the default 1869 my %opt_needs_val = map { ( $_ => 1 ) } qw{ 1870 arrayDepth hashDepth LineInfo maxTraceLen ornaments 1871 pager quote ReadLine recallCommand RemotePort ShellBang TTY 1872 }; 1873 while (length) { 1874 my $val_defaulted; 1875 s/^\s+// && next; 1876 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last; 1877 my ($opt,$sep) = ($1,$2); 1878 my $val; 1879 if ("?" eq $sep) { 1880 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last 1881 if /^\S/; 1882 #&dump_option($opt); 1883 } elsif ($sep !~ /\S/) { 1884 $val_defaulted = 1; 1885 $val = "1"; # this is an evil default; make 'em set it! 1886 } elsif ($sep eq "=") { 1887 1888 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) { 1889 my $quote = $1; 1890 ($val = $2) =~ s/\\([$quote\\])/$1/g; 1891 } else { 1892 s/^(\S*)//; 1893 $val = $1; 1894 print OUT qq(Option better cleared using $opt=""\n) 1895 unless length $val; 1896 } 1897 1898 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>." 1899 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #} 1900 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or 1901 print($OUT "Unclosed option value `$opt$sep$_'\n"), last; 1902 ($val = $1) =~ s/\\([\\$end])/$1/g; 1903 } 1904 1905 my $option; 1906 my $matches = grep( /^\Q$opt/ && ($option = $_), @options ) 1907 || grep( /^\Q$opt/i && ($option = $_), @options ); 1908 1909 print($OUT "Unknown option `$opt'\n"), next unless $matches; 1910 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1; 1911 1912 if ($opt_needs_val{$option} && $val_defaulted) { 1913 print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n"; 1914 next; 1915 } 1916 1917 $option{$option} = $val if defined $val; 1918 1919 eval qq{ 1920 local \$frame = 0; 1921 local \$doret = -2; 1922 require '$optionRequire{$option}'; 1923 1; 1924 } || die # XXX: shouldn't happen 1925 if defined $optionRequire{$option} && 1926 defined $val; 1927 1928 ${$optionVars{$option}} = $val 1929 if defined $optionVars{$option} && 1930 defined $val; 1931 1932 &{$optionAction{$option}} ($val) 1933 if defined $optionAction{$option} && 1934 defined &{$optionAction{$option}} && 1935 defined $val; 1936 1937 # Not $rcfile 1938 dump_option($option) unless $OUT eq \*STDERR; 1939 } 1940} 1941 1942sub set_list { 1943 my ($stem,@list) = @_; 1944 my $val; 1945 $ENV{"${stem}_n"} = @list; 1946 for $i (0 .. $#list) { 1947 $val = $list[$i]; 1948 $val =~ s/\\/\\\\/g; 1949 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg; 1950 $ENV{"${stem}_$i"} = $val; 1951 } 1952} 1953 1954sub get_list { 1955 my $stem = shift; 1956 my @list; 1957 my $n = delete $ENV{"${stem}_n"}; 1958 my $val; 1959 for $i (0 .. $n - 1) { 1960 $val = delete $ENV{"${stem}_$i"}; 1961 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge; 1962 push @list, $val; 1963 } 1964 @list; 1965} 1966 1967sub catch { 1968 $signal = 1; 1969 return; # Put nothing on the stack - malloc/free land! 1970} 1971 1972sub warn { 1973 my($msg)= join("",@_); 1974 $msg .= ": $!\n" unless $msg =~ /\n$/; 1975 print $OUT $msg; 1976} 1977 1978sub TTY { 1979 if (@_ and $term and $term->Features->{newTTY}) { 1980 my ($in, $out) = shift; 1981 if ($in =~ /,/) { 1982 ($in, $out) = split /,/, $in, 2; 1983 } else { 1984 $out = $in; 1985 } 1986 open IN, $in or die "cannot open `$in' for read: $!"; 1987 open OUT, ">$out" or die "cannot open `$out' for write: $!"; 1988 $term->newTTY(\*IN, \*OUT); 1989 $IN = \*IN; 1990 $OUT = \*OUT; 1991 return $tty = $in; 1992 } elsif ($term and @_) { 1993 &warn("Too late to set TTY, enabled on next `R'!\n"); 1994 } 1995 $tty = shift if @_; 1996 $tty or $console; 1997} 1998 1999sub noTTY { 2000 if ($term) { 2001 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_; 2002 } 2003 $notty = shift if @_; 2004 $notty; 2005} 2006 2007sub ReadLine { 2008 if ($term) { 2009 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_; 2010 } 2011 $rl = shift if @_; 2012 $rl; 2013} 2014 2015sub RemotePort { 2016 if ($term) { 2017 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_; 2018 } 2019 $remoteport = shift if @_; 2020 $remoteport; 2021} 2022 2023sub tkRunning { 2024 if (${$term->Features}{tkRunning}) { 2025 return $term->tkRunning(@_); 2026 } else { 2027 print $OUT "tkRunning not supported by current ReadLine package.\n"; 2028 0; 2029 } 2030} 2031 2032sub NonStop { 2033 if ($term) { 2034 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_; 2035 } 2036 $runnonstop = shift if @_; 2037 $runnonstop; 2038} 2039 2040sub pager { 2041 if (@_) { 2042 $pager = shift; 2043 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/; 2044 } 2045 $pager; 2046} 2047 2048sub shellBang { 2049 if (@_) { 2050 $sh = quotemeta shift; 2051 $sh .= "\\b" if $sh =~ /\w$/; 2052 } 2053 $psh = $sh; 2054 $psh =~ s/\\b$//; 2055 $psh =~ s/\\(.)/$1/g; 2056 &sethelp; 2057 $psh; 2058} 2059 2060sub ornaments { 2061 if (defined $term) { 2062 local ($warnLevel,$dieLevel) = (0, 1); 2063 return '' unless $term->Features->{ornaments}; 2064 eval { $term->ornaments(@_) } || ''; 2065 } else { 2066 $ornaments = shift; 2067 } 2068} 2069 2070sub recallCommand { 2071 if (@_) { 2072 $rc = quotemeta shift; 2073 $rc .= "\\b" if $rc =~ /\w$/; 2074 } 2075 $prc = $rc; 2076 $prc =~ s/\\b$//; 2077 $prc =~ s/\\(.)/$1/g; 2078 &sethelp; 2079 $prc; 2080} 2081 2082sub LineInfo { 2083 return $lineinfo unless @_; 2084 $lineinfo = shift; 2085 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo"; 2086 $slave_editor = ($stream =~ /^\|/); 2087 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write"); 2088 $LINEINFO = \*LINEINFO; 2089 my $save = select($LINEINFO); 2090 $| = 1; 2091 select($save); 2092 $lineinfo; 2093} 2094 2095sub list_versions { 2096 my %version; 2097 my $file; 2098 for (keys %INC) { 2099 $file = $_; 2100 s,\.p[lm]$,,i ; 2101 s,/,::,g ; 2102 s/^perl5db$/DB/; 2103 s/^Term::ReadLine::readline$/readline/; 2104 if (defined ${ $_ . '::VERSION' }) { 2105 $version{$file} = "${ $_ . '::VERSION' } from "; 2106 } 2107 $version{$file} .= $INC{$file}; 2108 } 2109 dumpit($OUT,\%version); 2110} 2111 2112sub sethelp { 2113 # XXX: make sure these are tabs between the command and explantion, 2114 # or print_help will screw up your formatting if you have 2115 # eeevil ornaments enabled. This is an insane mess. 2116 2117 $help = " 2118B<T> Stack trace. 2119B<s> [I<expr>] Single step [in I<expr>]. 2120B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>]. 2121<B<CR>> Repeat last B<n> or B<s> command. 2122B<r> Return from current subroutine. 2123B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint 2124 at the specified position. 2125B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>. 2126B<l> I<min>B<->I<max> List lines I<min> through I<max>. 2127B<l> I<line> List single I<line>. 2128B<l> I<subname> List first window of lines from subroutine. 2129B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>. 2130B<l> List next window of lines. 2131B<-> List previous window of lines. 2132B<w> [I<line>] List window around I<line>. 2133B<.> Return to the executed line. 2134B<f> I<filename> Switch to viewing I<filename>. File must be already loaded. 2135 I<filename> may be either the full name of the file, or a regular 2136 expression matching the full file name: 2137 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file. 2138 Evals (with saved bodies) are considered to be filenames: 2139 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval 2140 (in the order of execution). 2141B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional. 2142B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional. 2143B<L> List all breakpoints and actions. 2144B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>. 2145B<t> Toggle trace mode. 2146B<t> I<expr> Trace through execution of I<expr>. 2147B<b> [I<line>] [I<condition>] 2148 Set breakpoint; I<line> defaults to the current execution line; 2149 I<condition> breaks if it evaluates to true, defaults to '1'. 2150B<b> I<subname> [I<condition>] 2151 Set breakpoint at first line of subroutine. 2152B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>. 2153B<b> B<load> I<filename> Set breakpoint on `require'ing the given file. 2154B<b> B<postpone> I<subname> [I<condition>] 2155 Set breakpoint at first line of subroutine after 2156 it is compiled. 2157B<b> B<compile> I<subname> 2158 Stop after the subroutine is compiled. 2159B<d> [I<line>] Delete the breakpoint for I<line>. 2160B<D> Delete all breakpoints. 2161B<a> [I<line>] I<command> 2162 Set an action to be done before the I<line> is executed; 2163 I<line> defaults to the current execution line. 2164 Sequence is: check for breakpoint/watchpoint, print line 2165 if necessary, do action, prompt user if necessary, 2166 execute line. 2167B<a> [I<line>] Delete the action for I<line>. 2168B<A> Delete all actions. 2169B<W> I<expr> Add a global watch-expression. 2170B<W> Delete all watch-expressions. 2171B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current). 2172 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps. 2173B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\". 2174B<x> I<expr> Evals expression in list context, dumps the result. 2175B<m> I<expr> Evals expression in list context, prints methods callable 2176 on the first element of the result. 2177B<m> I<class> Prints methods callable via the given class. 2178 2179B<<> ? List Perl commands to run before each prompt. 2180B<<> I<expr> Define Perl command to run before each prompt. 2181B<<<> I<expr> Add to the list of Perl commands to run before each prompt. 2182B<>> ? List Perl commands to run after each prompt. 2183B<>> I<expr> Define Perl command to run after each prompt. 2184B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt. 2185B<{> I<db_command> Define debugger command to run before each prompt. 2186B<{> ? List debugger commands to run before each prompt. 2187B<<> I<expr> Define Perl command to run before each prompt. 2188B<{{> I<db_command> Add to the list of debugger commands to run before each prompt. 2189B<$prc> I<number> Redo a previous command (default previous command). 2190B<$prc> I<-number> Redo number'th-to-last command. 2191B<$prc> I<pattern> Redo last command that started with I<pattern>. 2192 See 'B<O> I<recallCommand>' too. 2193B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" 2194 . ( $rc eq $sh ? "" : " 2195B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . " 2196 See 'B<O> I<shellBang>' too. 2197B<H> I<-number> Display last number commands (default all). 2198B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package. 2199B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager. 2200B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well. 2201B<\=> [I<alias> I<value>] Define a command alias, or list current aliases. 2202I<command> Execute as a perl statement in current package. 2203B<v> Show versions of loaded modules. 2204B<R> Pure-man-restart of debugger, some of debugger state 2205 and command-line options may be lost. 2206 Currently the following setting are preserved: 2207 history, breakpoints and actions, debugger B<O>ptions 2208 and the following command-line options: I<-w>, I<-I>, I<-e>. 2209 2210B<O> [I<opt>] ... Set boolean option to true 2211B<O> [I<opt>B<?>] Query options 2212B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ... 2213 Set options. Use quotes in spaces in value. 2214 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell; 2215 I<pager> program for output of \"|cmd\"; 2216 I<tkRunning> run Tk while prompting (with ReadLine); 2217 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity; 2218 I<inhibit_exit> Allows stepping off the end of the script. 2219 I<ImmediateStop> Debugger should stop as early as possible. 2220 I<RemotePort> Remote hostname:port for remote debugging 2221 The following options affect what happens with B<V>, B<X>, and B<x> commands: 2222 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all); 2223 I<compactDump>, I<veryCompact> change style of array and hash dump; 2224 I<globPrint> whether to print contents of globs; 2225 I<DumpDBFiles> dump arrays holding debugged files; 2226 I<DumpPackages> dump symbol tables of packages; 2227 I<DumpReused> dump contents of \"reused\" addresses; 2228 I<quote>, I<HighBit>, I<undefPrint> change style of string dump; 2229 I<bareStringify> Do not print the overload-stringified value; 2230 Other options include: 2231 I<PrintRet> affects printing of return value after B<r> command, 2232 I<frame> affects printing messages on entry and exit from subroutines. 2233 I<AutoTrace> affects printing messages on every possible breaking point. 2234 I<maxTraceLen> gives maximal length of evals/args listed in stack trace. 2235 I<ornaments> affects screen appearance of the command line. 2236 During startup options are initialized from \$ENV{PERLDB_OPTS}. 2237 You can put additional initialization options I<TTY>, I<noTTY>, 2238 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use 2239 `B<R>' after you set them). 2240 2241B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. 2242B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page. 2243B<h h> Summary of debugger commands. 2244B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the 2245 named Perl I<manpage>, or on B<$doccmd> itself if omitted. 2246 Set B<\$DB::doccmd> to change viewer. 2247 2248Type `|h' for a paged display if this was too hard to read. 2249 2250"; # Fix balance of vi % matching: } }} 2251 2252 $summary = <<"END_SUM"; 2253I<List/search source lines:> I<Control script execution:> 2254 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace 2255 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr] 2256 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs 2257 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s> 2258 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine 2259 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position 2260I<Debugger controls:> B<L> List break/watch/actions 2261 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr] 2262 B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I<cmd>] Do pre/post-prompt B<b> [I<ln>|I<event>|I<sub>] [I<cnd>] Set breakpoint 2263 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints 2264 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line 2265 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression 2266 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch 2267 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess 2268 B<q> or B<^D> Quit B<R> Attempt a restart 2269I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr> 2270 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods. 2271 B<p> I<expr> Print expression (uses script's current package). 2272 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern 2273 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern. 2274 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\". 2275For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs. 2276END_SUM 2277 # ')}}; # Fix balance of vi % matching 2278} 2279 2280sub print_help { 2281 local $_ = shift; 2282 2283 # Restore proper alignment destroyed by eeevil I<> and B<> 2284 # ornaments: A pox on both their houses! 2285 # 2286 # A help command will have everything up to and including 2287 # the first tab sequence paddeed into a field 16 (or if indented 20) 2288 # wide. If it's wide than that, an extra space will be added. 2289 s{ 2290 ^ # only matters at start of line 2291 ( \040{4} | \t )* # some subcommands are indented 2292 ( < ? # so <CR> works 2293 [BI] < [^\t\n] + ) # find an eeevil ornament 2294 ( \t+ ) # original separation, discarded 2295 ( .* ) # this will now start (no earlier) than 2296 # column 16 2297 } { 2298 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4); 2299 my $clean = $command; 2300 $clean =~ s/[BI]<([^>]*)>/$1/g; 2301 # replace with this whole string: 2302 (length($leadwhite) ? " " x 4 : "") 2303 . $command 2304 . ((" " x (16 + (length($leadwhite) ? 4 : 0) - length($clean))) || " ") 2305 . $text; 2306 2307 }mgex; 2308 2309 s{ # handle bold ornaments 2310 B < ( [^>] + | > ) > 2311 } { 2312 $Term::ReadLine::TermCap::rl_term_set[2] 2313 . $1 2314 . $Term::ReadLine::TermCap::rl_term_set[3] 2315 }gex; 2316 2317 s{ # handle italic ornaments 2318 I < ( [^>] + | > ) > 2319 } { 2320 $Term::ReadLine::TermCap::rl_term_set[0] 2321 . $1 2322 . $Term::ReadLine::TermCap::rl_term_set[1] 2323 }gex; 2324 2325 print $OUT $_; 2326} 2327 2328sub fix_less { 2329 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/; 2330 my $is_less = $pager =~ /\bless\b/; 2331 if ($pager =~ /\bmore\b/) { 2332 my @st_more = stat('/usr/bin/more'); 2333 my @st_less = stat('/usr/bin/less'); 2334 $is_less = @st_more && @st_less 2335 && $st_more[0] == $st_less[0] 2336 && $st_more[1] == $st_less[1]; 2337 } 2338 # changes environment! 2339 $ENV{LESS} .= 'r' if $is_less; 2340} 2341 2342sub diesignal { 2343 local $frame = 0; 2344 local $doret = -2; 2345 $SIG{'ABRT'} = 'DEFAULT'; 2346 kill 'ABRT', $$ if $panic++; 2347 if (defined &Carp::longmess) { 2348 local $SIG{__WARN__} = ''; 2349 local $Carp::CarpLevel = 2; # mydie + confess 2350 &warn(Carp::longmess("Signal @_")); 2351 } 2352 else { 2353 print $DB::OUT "Got signal @_\n"; 2354 } 2355 kill 'ABRT', $$; 2356} 2357 2358sub dbwarn { 2359 local $frame = 0; 2360 local $doret = -2; 2361 local $SIG{__WARN__} = ''; 2362 local $SIG{__DIE__} = ''; 2363 eval { require Carp } if defined $^S; # If error/warning during compilation, 2364 # require may be broken. 2365 warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"), 2366 return unless defined &Carp::longmess; 2367 my ($mysingle,$mytrace) = ($single,$trace); 2368 $single = 0; $trace = 0; 2369 my $mess = Carp::longmess(@_); 2370 ($single,$trace) = ($mysingle,$mytrace); 2371 &warn($mess); 2372} 2373 2374sub dbdie { 2375 local $frame = 0; 2376 local $doret = -2; 2377 local $SIG{__DIE__} = ''; 2378 local $SIG{__WARN__} = ''; 2379 my $i = 0; my $ineval = 0; my $sub; 2380 if ($dieLevel > 2) { 2381 local $SIG{__WARN__} = \&dbwarn; 2382 &warn(@_); # Yell no matter what 2383 return; 2384 } 2385 if ($dieLevel < 2) { 2386 die @_ if $^S; # in eval propagate 2387 } 2388 eval { require Carp } if defined $^S; # If error/warning during compilation, 2389 # require may be broken. 2390 2391 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack") 2392 unless defined &Carp::longmess; 2393 2394 # We do not want to debug this chunk (automatic disabling works 2395 # inside DB::DB, but not in Carp). 2396 my ($mysingle,$mytrace) = ($single,$trace); 2397 $single = 0; $trace = 0; 2398 my $mess = Carp::longmess(@_); 2399 ($single,$trace) = ($mysingle,$mytrace); 2400 die $mess; 2401} 2402 2403sub warnLevel { 2404 if (@_) { 2405 $prevwarn = $SIG{__WARN__} unless $warnLevel; 2406 $warnLevel = shift; 2407 if ($warnLevel) { 2408 $SIG{__WARN__} = \&DB::dbwarn; 2409 } else { 2410 $SIG{__WARN__} = $prevwarn; 2411 } 2412 } 2413 $warnLevel; 2414} 2415 2416sub dieLevel { 2417 if (@_) { 2418 $prevdie = $SIG{__DIE__} unless $dieLevel; 2419 $dieLevel = shift; 2420 if ($dieLevel) { 2421 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2; 2422 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2; 2423 print $OUT "Stack dump during die enabled", 2424 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n" 2425 if $I_m_init; 2426 print $OUT "Dump printed too.\n" if $dieLevel > 2; 2427 } else { 2428 $SIG{__DIE__} = $prevdie; 2429 print $OUT "Default die handler restored.\n"; 2430 } 2431 } 2432 $dieLevel; 2433} 2434 2435sub signalLevel { 2436 if (@_) { 2437 $prevsegv = $SIG{SEGV} unless $signalLevel; 2438 $prevbus = $SIG{BUS} unless $signalLevel; 2439 $signalLevel = shift; 2440 if ($signalLevel) { 2441 $SIG{SEGV} = \&DB::diesignal; 2442 $SIG{BUS} = \&DB::diesignal; 2443 } else { 2444 $SIG{SEGV} = $prevsegv; 2445 $SIG{BUS} = $prevbus; 2446 } 2447 } 2448 $signalLevel; 2449} 2450 2451sub CvGV_name { 2452 my $in = shift; 2453 my $name = CvGV_name_or_bust($in); 2454 defined $name ? $name : $in; 2455} 2456 2457sub CvGV_name_or_bust { 2458 my $in = shift; 2459 return if $skipCvGV; # Backdoor to avoid problems if XS broken... 2460 $in = \&$in; # Hard reference... 2461 eval {require Devel::Peek; 1} or return; 2462 my $gv = Devel::Peek::CvGV($in) or return; 2463 *$gv{PACKAGE} . '::' . *$gv{NAME}; 2464} 2465 2466sub find_sub { 2467 my $subr = shift; 2468 $sub{$subr} or do { 2469 return unless defined &$subr; 2470 my $name = CvGV_name_or_bust($subr); 2471 my $data; 2472 $data = $sub{$name} if defined $name; 2473 return $data if defined $data; 2474 2475 # Old stupid way... 2476 $subr = \&$subr; # Hard reference 2477 my $s; 2478 for (keys %sub) { 2479 $s = $_, last if $subr eq \&$_; 2480 } 2481 $sub{$s} if $s; 2482 } 2483} 2484 2485sub methods { 2486 my $class = shift; 2487 $class = ref $class if ref $class; 2488 local %seen; 2489 local %packs; 2490 methods_via($class, '', 1); 2491 methods_via('UNIVERSAL', 'UNIVERSAL', 0); 2492} 2493 2494sub methods_via { 2495 my $class = shift; 2496 return if $packs{$class}++; 2497 my $prefix = shift; 2498 my $prepend = $prefix ? "via $prefix: " : ''; 2499 my $name; 2500 for $name (grep {defined &{${"${class}::"}{$_}}} 2501 sort keys %{"${class}::"}) { 2502 next if $seen{ $name }++; 2503 print $DB::OUT "$prepend$name\n"; 2504 } 2505 return unless shift; # Recurse? 2506 for $name (@{"${class}::ISA"}) { 2507 $prepend = $prefix ? $prefix . " -> $name" : $name; 2508 methods_via($name, $prepend, 1); 2509 } 2510} 2511 2512sub setman { 2513 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS)\z/s 2514 ? "man" # O Happy Day! 2515 : "perldoc"; # Alas, poor unfortunates 2516} 2517 2518sub runman { 2519 my $page = shift; 2520 unless ($page) { 2521 &system("$doccmd $doccmd"); 2522 return; 2523 } 2524 # this way user can override, like with $doccmd="man -Mwhatever" 2525 # or even just "man " to disable the path check. 2526 unless ($doccmd eq 'man') { 2527 &system("$doccmd $page"); 2528 return; 2529 } 2530 2531 $page = 'perl' if lc($page) eq 'help'; 2532 2533 require Config; 2534 my $man1dir = $Config::Config{'man1dir'}; 2535 my $man3dir = $Config::Config{'man3dir'}; 2536 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ } 2537 my $manpath = ''; 2538 $manpath .= "$man1dir:" if $man1dir =~ /\S/; 2539 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir; 2540 chop $manpath if $manpath; 2541 # harmless if missing, I figure 2542 my $oldpath = $ENV{MANPATH}; 2543 $ENV{MANPATH} = $manpath if $manpath; 2544 my $nopathopt = $^O =~ /dunno what goes here/; 2545 if (system($doccmd, 2546 # I just *know* there are men without -M 2547 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()), 2548 split ' ', $page) ) 2549 { 2550 unless ($page =~ /^perl\w/) { 2551 if (grep { $page eq $_ } qw{ 2552 5004delta 5005delta amiga api apio book boot bot call compile 2553 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed 2554 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork 2555 form func guts hack hist hpux intern ipc lexwarn locale lol mod 2556 modinstall modlib number obj op opentut os2 os390 pod port 2557 ref reftut run sec style sub syn thrtut tie toc todo toot tootc 2558 trap unicode var vms win32 xs xstut 2559 }) 2560 { 2561 $page =~ s/^/perl/; 2562 system($doccmd, 2563 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()), 2564 $page); 2565 } 2566 } 2567 } 2568 if (defined $oldpath) { 2569 $ENV{MANPATH} = $manpath; 2570 } else { 2571 delete $ENV{MANPATH}; 2572 } 2573} 2574 2575# The following BEGIN is very handy if debugger goes havoc, debugging debugger? 2576 2577BEGIN { # This does not compile, alas. 2578 $IN = \*STDIN; # For bugs before DB::OUT has been opened 2579 $OUT = \*STDERR; # For errors before DB::OUT has been opened 2580 $sh = '!'; 2581 $rc = ','; 2582 @hist = ('?'); 2583 $deep = 100; # warning if stack gets this deep 2584 $window = 10; 2585 $preview = 3; 2586 $sub = ''; 2587 $SIG{INT} = \&DB::catch; 2588 # This may be enabled to debug debugger: 2589 #$warnLevel = 1 unless defined $warnLevel; 2590 #$dieLevel = 1 unless defined $dieLevel; 2591 #$signalLevel = 1 unless defined $signalLevel; 2592 2593 $db_stop = 0; # Compiler warning 2594 $db_stop = 1 << 30; 2595 $level = 0; # Level of recursive debugging 2596 # @stack and $doret are needed in sub sub, which is called for DB::postponed. 2597 # Triggers bug (?) in perl is we postpone this until runtime: 2598 @postponed = @stack = (0); 2599 $stack_depth = 0; # Localized $#stack 2600 $doret = -2; 2601 $frame = 0; 2602} 2603 2604BEGIN {$^W = $ini_warn;} # Switch warnings back 2605 2606#use Carp; # This did break, left for debuggin 2607 2608sub db_complete { 2609 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah 2610 my($text, $line, $start) = @_; 2611 my ($itext, $search, $prefix, $pack) = 2612 ($text, "^\Q${'package'}::\E([^:]+)\$"); 2613 2614 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines 2615 (map { /$search/ ? ($1) : () } keys %sub) 2616 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/; 2617 return sort grep /^\Q$text/, values %INC # files 2618 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/; 2619 return sort map {($_, db_complete($_ . "::", "V ", 2))} 2620 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages 2621 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/; 2622 return sort map {($_, db_complete($_ . "::", "V ", 2))} 2623 grep !/^main::/, 2624 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'} 2625 # packages 2626 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ 2627 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1; 2628 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files 2629 # We may want to complete to (eval 9), so $text may be wrong 2630 $prefix = length($1) - length($text); 2631 $text = $1; 2632 return sort 2633 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0 2634 } 2635 if ((substr $text, 0, 1) eq '&') { # subroutines 2636 $text = substr $text, 1; 2637 $prefix = "&"; 2638 return sort map "$prefix$_", 2639 grep /^\Q$text/, 2640 (keys %sub), 2641 (map { /$search/ ? ($1) : () } 2642 keys %sub); 2643 } 2644 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package 2645 $pack = ($1 eq 'main' ? '' : $1) . '::'; 2646 $prefix = (substr $text, 0, 1) . $1 . '::'; 2647 $text = $2; 2648 my @out 2649 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ; 2650 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) { 2651 return db_complete($out[0], $line, $start); 2652 } 2653 return sort @out; 2654 } 2655 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main) 2656 $pack = ($package eq 'main' ? '' : $package) . '::'; 2657 $prefix = substr $text, 0, 1; 2658 $text = substr $text, 1; 2659 my @out = map "$prefix$_", grep /^\Q$text/, 2660 (grep /^_?[a-zA-Z]/, keys %$pack), 2661 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ; 2662 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) { 2663 return db_complete($out[0], $line, $start); 2664 } 2665 return sort @out; 2666 } 2667 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space 2668 my @out = grep /^\Q$text/, @options; 2669 my $val = option_val($out[0], undef); 2670 my $out = '? '; 2671 if (not defined $val or $val =~ /[\n\r]/) { 2672 # Can do nothing better 2673 } elsif ($val =~ /\s/) { 2674 my $found; 2675 foreach $l (split //, qq/\"\'\#\|/) { 2676 $out = "$l$val$l ", last if (index $val, $l) == -1; 2677 } 2678 } else { 2679 $out = "=$val "; 2680 } 2681 # Default to value if one completion, to question if many 2682 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? '); 2683 return sort @out; 2684 } 2685 return $term->filename_list($text); # filenames 2686} 2687 2688sub end_report { 2689 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n" 2690} 2691 2692END { 2693 $finished = 1 if $inhibit_exit; # So that some keys may be disabled. 2694 $fall_off_end = 1 unless $inhibit_exit; 2695 # Do not stop in at_exit() and destructors on exit: 2696 $DB::single = !$fall_off_end && !$runnonstop; 2697 DB::fake::at_exit() unless $fall_off_end or $runnonstop; 2698} 2699 2700package DB::fake; 2701 2702sub at_exit { 2703 "Debugged program terminated. Use `q' to quit or `R' to restart."; 2704} 2705 2706package DB; # Do not trace this 1; below! 2707 27081; 2709