X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fperl5db.pl;h=63b4381339ce25b8de4c0112074d65c7022164c0;hb=191740791d4b6865c4f2665c148ea4f4d8ec7cc3;hp=41430ac1885cd92eddd35da3127d98aaf61c917b;hpb=0c01eb4a69fb13dce36ec3b17c3ba06feb0d748b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 41430ac..63b4381 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -25,7 +25,7 @@ $header = "perl5db.pl version $VERSION"; # if caller() is called from the package DB, it provides some # additional data. # -# The array @{$main::{'_<'.$filename} is the line-by-line contents of +# The array @{$main::{'_<'.$filename}} is the line-by-line contents of # $filename. # # The hash %{'_<'.$filename} contains breakpoints and action (it is @@ -401,6 +401,12 @@ if ($notty) { $console = "/dev/tty"; } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') { $console = "con"; + } elsif ($^O eq 'MacOS') { + if ($MacPerl::Version !~ /MPW/) { + $console = "Dev:Console:Perl Debug"; # Separate window for application + } else { + $console = "Dev:Console"; + } } else { $console = "sys\$command"; } @@ -426,7 +432,7 @@ if ($notty) { PeerAddr => $remoteport, Proto => 'tcp', ); - if (!$OUT) { die "Could not create socket to connect to remote host."; } + if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; } $IN = $OUT; } else { @@ -617,7 +623,7 @@ EOP next CMD; } } - $cmd =~ /^q$/ && ($exiting = 1) && exit 0; + $cmd =~ /^q$/ && ($fall_off_end = 1) && exit $?; $cmd =~ /^h$/ && do { print_help($help); next CMD; }; @@ -899,9 +905,9 @@ EOP print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n"; next CMD; }; $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do { - my $cond = $3 || '1'; + my $cond = length $3 ? $3 : '1'; my ($subname, $break) = ($2, $1 eq 'postpone'); - $subname =~ s/\'/::/; + $subname =~ s/\'/::/g; $subname = "${'package'}::" . $subname unless $subname =~ /::/; $subname = "main".$subname if substr($subname,0,2) eq "::"; @@ -910,8 +916,8 @@ EOP next CMD; }; $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do { $subname = $1; - $cond = $2 || '1'; - $subname =~ s/\'/::/; + $cond = length $2 ? $2 : '1'; + $subname =~ s/\'/::/g; $subname = "${'package'}::" . $subname unless $subname =~ /::/; $subname = "main".$subname if substr($subname,0,2) eq "::"; @@ -931,7 +937,7 @@ EOP next CMD; }; $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do { $i = $1 || $line; - $cond = $2 || '1'; + $cond = length $2 ? $2 : '1'; if ($dbline[$i] == 0) { print $OUT "Line $i not breakable.\n"; } else { @@ -941,8 +947,12 @@ EOP next CMD; }; $cmd =~ /^d\b\s*(\d*)/ && do { $i = $1 || $line; - $dbline{$i} =~ s/^[^\0]*//; - delete $dbline{$i} if $dbline{$i} eq ''; + if ($dbline[$i] == 0) { + print $OUT "Line $i not breakable.\n"; + } else { + $dbline{$i} =~ s/^[^\0]*//; + delete $dbline{$i} if $dbline{$i} eq ''; + } next CMD; }; $cmd =~ /^A$/ && do { print $OUT "Deleting all actions...\n"; @@ -980,18 +990,18 @@ EOP next CMD; }; $cmd =~ /^<\s*(.*)/ && do { unless ($1) { - print OUT "All < actions cleared.\n"; + print $OUT "All < actions cleared.\n"; $pre = []; next CMD; } if ($1 eq '?') { unless (@$pre) { - print OUT "No pre-prompt Perl actions.\n"; + print $OUT "No pre-prompt Perl actions.\n"; next CMD; } - print OUT "Perl commands run before each prompt:\n"; + print $OUT "Perl commands run before each prompt:\n"; for my $action ( @$pre ) { - print "\t< -- $action\n"; + print $OUT "\t< -- $action\n"; } next CMD; } @@ -999,18 +1009,18 @@ EOP next CMD; }; $cmd =~ /^>\s*(.*)/ && do { unless ($1) { - print OUT "All > actions cleared.\n"; + print $OUT "All > actions cleared.\n"; $post = []; next CMD; } if ($1 eq '?') { unless (@$post) { - print OUT "No post-prompt Perl actions.\n"; + print $OUT "No post-prompt Perl actions.\n"; next CMD; } - print OUT "Perl commands run after each prompt:\n"; + print $OUT "Perl commands run after each prompt:\n"; for my $action ( @$post ) { - print "\t> -- $action\n"; + print $OUT "\t> -- $action\n"; } next CMD; } @@ -1018,7 +1028,7 @@ EOP next CMD; }; $cmd =~ /^\{\{\s*(.*)/ && do { if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) { - print OUT "{{ is now a debugger command\n", + print $OUT "{{ is now a debugger command\n", "use `;{{' if you mean Perl code\n"; $cmd = "h {{"; redo CMD; @@ -1027,23 +1037,23 @@ EOP next CMD; }; $cmd =~ /^\{\s*(.*)/ && do { unless ($1) { - print OUT "All { actions cleared.\n"; + print $OUT "All { actions cleared.\n"; $pretype = []; next CMD; } if ($1 eq '?') { unless (@$pretype) { - print OUT "No pre-prompt debugger actions.\n"; + print $OUT "No pre-prompt debugger actions.\n"; next CMD; } - print OUT "Debugger commands run before each prompt:\n"; + print $OUT "Debugger commands run before each prompt:\n"; for my $action ( @$pretype ) { - print "\t{ -- $action\n"; + print $OUT "\t{ -- $action\n"; } next CMD; } if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) { - print OUT "{ is now a debugger command\n", + print $OUT "{ is now a debugger command\n", "use `;{' if you mean Perl code\n"; $cmd = "h {"; redo CMD; @@ -1426,7 +1436,7 @@ EOP $piped= ""; } } # CMD: - $exiting = 1 unless defined $cmd; + $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF foreach $evalarg (@$post) { &eval; } @@ -1507,6 +1517,7 @@ sub eval { local $otrace = $trace; local $osingle = $single; local $od = $^D; + { ($evalarg) = $evalarg =~ /(.*)/s; } @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug $trace = $otrace; $single = $osingle; @@ -1814,7 +1825,7 @@ sub readline { local $frame = 0; local $doret = -2; if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) { - print $OUT @_; + $OUT->write(join('', @_)); my $stuff; $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread? $stuff; @@ -2160,8 +2171,8 @@ B Delete all watch-expressions. B [I [I]] List some (default all) variables in package (default current). Use B<~>I and BI for positive and negative regexps. B [I] Same as \"B I [I]\". -B I Evals expression in array context, dumps the result. -B I Evals expression in array context, prints methods callable +B I Evals expression in list context, dumps the result. +B I Evals expression in list context, prints methods callable on the first element of the result. B I Prints methods callable via the given class. @@ -2256,7 +2267,7 @@ I B List break/watch/act B<|>[B<|>]I Send output to pager B<$psh>\[B<$psh>\] I Run cmd in a subprocess B or B<^D> Quit B Attempt a restart I B Execute perl code, also see: B,B,B I - B|B I Evals expr in array context, dumps the result or lists methods. + B|B I Evals expr in list context, dumps the result or lists methods. B

I Print expression (uses script's current package). B [[B]I] List subroutine names [not] matching pattern B [I [I]] List Variables in Package. Vars can be ~pattern or !pattern. @@ -2679,10 +2690,11 @@ sub end_report { } END { - $finished = $inhibit_exit; # So that some keys may be disabled. + $finished = 1 if $inhibit_exit; # So that some keys may be disabled. + $fall_off_end = 1 unless $inhibit_exit; # Do not stop in at_exit() and destructors on exit: - $DB::single = !$exiting && !$runnonstop; - DB::fake::at_exit() unless $exiting or $runnonstop; + $DB::single = !$fall_off_end && !$runnonstop; + DB::fake::at_exit() unless $fall_off_end or $runnonstop; } package DB::fake;