diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/perl5db.pl')
-rw-r--r-- | Master/tlpkg/tlperl/lib/perl5db.pl | 150 |
1 files changed, 82 insertions, 68 deletions
diff --git a/Master/tlpkg/tlperl/lib/perl5db.pl b/Master/tlpkg/tlperl/lib/perl5db.pl index b3daaf55abd..ea0d049a789 100644 --- a/Master/tlpkg/tlperl/lib/perl5db.pl +++ b/Master/tlpkg/tlperl/lib/perl5db.pl @@ -173,9 +173,11 @@ Send in a patch if you can clear up, fill out, or clarify an C<XXX>. There are a number of special data structures provided to the debugger by the Perl interpreter. -The array C<@{$main::{'_<'.$filename}}> (aliased locally to C<@dbline> via glob -assignment) contains the text from C<$filename>, with each element -corresponding to a single line of C<$filename>. +The array C<@{$main::{'_<'.$filename}}> (aliased locally to C<@dbline> +via glob assignment) contains the text from C<$filename>, with each +element corresponding to a single line of C<$filename>. Additionally, +breakable lines will be dualvars with the numeric component being the +memory address of a COP node. Non-breakable lines are dualvar to 0. The hash C<%{'_<'.$filename}> (aliased locally to C<%dbline> via glob assignment) contains breakpoints and actions. The keys are line numbers; @@ -888,7 +890,7 @@ sub eval { # + Forgot a my() declaration (Ilya Zakharevich in 11085) # Changes: 1.15: Nov 6, 2001 Michael G Schwern <schwern@pobox.com> # + Updated 1.14 change log -# + Added *dbline explainatory comments +# + Added *dbline explanatory comments # + Mentioning perldebguts man page # Changes: 1.16: Feb 15, 2002 Mark-Jason Dominus <mjd@plover.com> # + $onetimeDump improvements @@ -952,6 +954,18 @@ sub eval { # Changes: 1.32: Jun 03, 2009 Jonathan Leto <jonathan@leto.net> # + Fix bug where a key _< with undefined value was put into the symbol table # + when the $filename variable is not set +# Changes: 1.33: +# + Debugger prints lines to the remote port when it forks and openes a new port (f633fd2) +# + The debugger now continues to use RemotePort when it's been configured to use it. (11653f7) +# + Stop using $ENV{LESS} for parameters not intended for less (d463cf2) +# + Configure has a path to less and perl5db.pl can use it (bf320d6) +# + Die with $@ instead of empty message (86755f4) +# + Remove extra/useless $@ check after eval { require PadWalker } (which is still checked) (dab8d6d) +# + Promote eval( "require ..." ) to eval { require ... } (4a49187) +# + Promote eval { require( ... )} || die to mere require( ... ) (999f23b) +# + Remove indirect object notation from debugger (bee4b46) +# + Document that @{$main::{'_<'.$filename}} lines are dualvar to (COP*). (7e17a74) +# + Remove MacOS classic support from the debugger. (2b894b7) ######################################################################## =head1 DEBUGGER INITIALIZATION @@ -970,7 +984,7 @@ terminates, and defaulting to printing return values for the C<r> command. # Needed for the statement after exec(): # # This BEGIN block is simply used to switch off warnings during debugger -# compiliation. Probably it would be better practice to fix the warnings, +# compilation. Probably it would be better practice to fix the warnings, # but this is how it's done at the moment. BEGIN { @@ -1461,7 +1475,8 @@ if ( defined $ENV{PERLDB_OPTS} ) { The last thing we do during initialization is determine which subroutine is to be used to obtain a new terminal when a new debugger is started. Right now, -the debugger only handles X Windows, OS/2, and Mac OS X (darwin). +the debugger only handles TCP sockets, X Windows, OS/2, amd Mac OS X +(darwin). =cut @@ -1471,7 +1486,11 @@ the debugger only handles X Windows, OS/2, and Mac OS X (darwin). if (not defined &get_fork_TTY) # only if no routine exists { - if (defined $ENV{TERM} # If we know what kind + if ( defined $remoteport ) { + # Expect an inetd-like server + *get_fork_TTY = \&socket_get_fork_TTY; # to listen to us + } + elsif (defined $ENV{TERM} # If we know what kind # of terminal this is, and $ENV{TERM} eq 'xterm' # and it's an xterm, and defined $ENV{DISPLAY} # and what display it's on, @@ -1630,23 +1649,6 @@ We then determine what the console should be on various systems: $console = "con"; } -=item * MacOS - use C<Dev:Console:Perl Debug> if this is the MPW version; C<Dev: -Console> if not. - -Note that Mac OS X returns C<darwin>, not C<MacOS>. Also note that the debugger doesn't do anything special for C<darwin>. Maybe it should. - -=cut - - elsif ( $^O eq 'MacOS' ) { - if ( $MacPerl::Version !~ /MPW/ ) { - $console = - "Dev:Console:Perl Debug"; # Separate window for application - } - else { - $console = "Dev:Console"; - } - } ## end elsif ($^O eq 'MacOS') - =item * VMS - use C<sys$command>. =cut @@ -1716,14 +1718,7 @@ and then tries to connect the input and output filehandles to it. # If RemotePort was defined in the options, connect input and output # to the socket. - require IO::Socket; - $OUT = new IO::Socket::INET( - Timeout => '10', - PeerAddr => $remoteport, - Proto => 'tcp', - ); - if ( !$OUT ) { die "Unable to connect to remote host: $remoteport\n"; } - $IN = $OUT; + $IN = $OUT = connect_remoteport(); } ## end if (defined $remoteport) =pod @@ -1923,13 +1918,6 @@ sub DB { # the code here. local (*dbline) = $main::{ '_<' . $filename }; - # we need to check for pseudofiles on Mac OS (these are files - # not attached to a filename, but instead stored in Dev:Pseudo) - if ( $^O eq 'MacOS' && $#dbline < 0 ) { - $filename_ini = $filename = 'Dev:Pseudo'; - *dbline = $main::{ '_<' . $filename }; - } - # Last line in the program. local $max = $#dbline; @@ -2821,7 +2809,7 @@ appropriately, and force us out of the command loop. # r - return from the current subroutine. $cmd =~ /^r$/ && do { - # Can't do anythign if the program's over. + # Can't do anything if the program's over. end_report(), next CMD if $finished and $level <= 1; # Turn on stack trace. @@ -3237,7 +3225,7 @@ Manipulates C<%alias> to add or list command aliases. # List aliases. for my $k (@keys) { - # Messy metaquoting: Trim the substiution code off. + # Messy metaquoting: Trim the substitution code off. # We use control-G as the delimiter because it's not # likely to appear in the alias. if ( ( my $v = $alias{$k} ) =~ ss\a$k\a(.*)\a$1 ) { @@ -3696,7 +3684,7 @@ sub sub { ) if $frame; - # Determine the sub's return type,and capture approppriately. + # Determine the sub's return type, and capture appropriately. if (wantarray) { # Called in array context. call sub and capture output. @@ -3760,7 +3748,7 @@ sub sub { # If we're doing exit messages... ( - $frame & 4 # Extended messsages + $frame & 4 # Extended messages ? ( print_lineinfo( ' ' x $stack_depth, "out " ), print_trace( $LINEINFO, -1, 1, 1, "$sub$al" ) @@ -5524,7 +5512,7 @@ sub postponed { # Yes. Mark this file as having breakpoints. $had_breakpoints{$filename} |= 1; - # "Cannot be done: unsufficient magic" - we can't just put the + # "Cannot be done: insufficient magic" - we can't just put the # breakpoints saved in %postponed_file into %dbline by assigning # the whole hash; we have to do it one item at a time for the # breakpoints to be set properly. @@ -6022,7 +6010,7 @@ sub setterm { # Load Term::Readline, but quietly; don't debug it and don't trace it. local $frame = 0; local $doret = -2; - eval { require Term::ReadLine } or die $@; + require Term::ReadLine; # If noTTY is set, but we have a TTY name, go ahead and hook up to it. if ($notty) { @@ -6040,14 +6028,14 @@ sub setterm { # We don't have a TTY - try to find one via Term::Rendezvous. else { - eval "require Term::Rendezvous;" or die; + require Term::Rendezvous; # See if we have anything to pass to Term::Rendezvous. # Use $HOME/.perldbtty$$ if not. my $rv = $ENV{PERLDB_NOTTY} || "$ENV{HOME}/.perldbtty$$"; # Rendezvous and get the filehandles. - my $term_rv = new Term::Rendezvous $rv; + my $term_rv = Term::Rendezvous->new( $rv ); $IN = $term_rv->IN; $OUT = $term_rv->OUT; } ## end else [ if ($tty) @@ -6060,12 +6048,12 @@ sub setterm { # If we shouldn't use Term::ReadLine, don't. if ( !$rl ) { - $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT; + $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT ); } # We're using Term::ReadLine. Get all the attributes for this terminal. else { - $term = new Term::ReadLine 'perldb', $IN, $OUT; + $term = Term::ReadLine->new( 'perldb', $IN, $OUT ); $rl_attribs = $term->Attribs; $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}' @@ -6135,10 +6123,37 @@ is tasked with doing all the necessary operating system mojo to get a new TTY (and probably another window) and to direct the new debugger to read and write there. -The debugger provides C<get_fork_TTY> functions which work for X Windows, -OS/2, and Mac OS X. Other systems are not supported. You are encouraged -to write C<get_fork_TTY> functions which work for I<your> platform -and contribute them. +The debugger provides C<get_fork_TTY> functions which work for TCP +socket servers, X Windows, OS/2, and Mac OS X. Other systems are not +supported. You are encouraged to write C<get_fork_TTY> functions which +work for I<your> platform and contribute them. + +=head3 C<socket_get_fork_TTY> + +=cut + +sub connect_remoteport { + require IO::Socket; + + my $socket = IO::Socket::INET->new( + Timeout => '10', + PeerAddr => $remoteport, + Proto => 'tcp', + ); + if ( ! $socket ) { + die "Unable to connect to remote host: $remoteport\n"; + } + return $socket; +} + +sub socket_get_fork_TTY { + $tty = $LINEINFO = $IN = $OUT = connect_remoteport(); + + # Do I need to worry about setting $term? + + reset_IN_OUT( $IN, $OUT ); + return ''; +} =head3 C<xterm_get_fork_TTY> @@ -6172,12 +6187,12 @@ qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\ # We need $term defined or we can not switch to the newly created xterm if ($tty ne '' && !defined $term) { - eval { require Term::ReadLine } or die $@; + require Term::ReadLine; if ( !$rl ) { - $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT; + $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT ); } else { - $term = new Term::ReadLine 'perldb', $IN, $OUT; + $term = Term::ReadLine->new( 'perldb', $IN, $OUT ); } } # There's our new TTY. @@ -6473,7 +6488,7 @@ sub readline { # Nothing on the filehandle stack. Socket? if ( ref $OUT and UNIVERSAL::isa( $OUT, 'IO::Socket::INET' ) ) { - # Send anyting we have to send. + # Send anything we have to send. $OUT->write( join( '', @_ ) ); # Receive anything there is to receive. @@ -6682,7 +6697,7 @@ sub parse_options { local \$doret = -2; require '$optionRequire{$option}'; 1; - } || die # XXX: shouldn't happen + } || die $@ # XXX: shouldn't happen if defined $optionRequire{$option} && defined $val; @@ -7274,7 +7289,7 @@ B<H> I<-number> Display last number commands (default all). B<H> I<*> Delete complete history. B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package. B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager. -B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well. +B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarily select()ed as well. B<\=> [I<alias> I<value>] Define a command alias, or list current aliases. I<command> Execute as a perl statement in current package. B<R> Pure-man-restart of debugger, some of debugger state @@ -7599,14 +7614,14 @@ sub print_help { This routine does a lot of gyrations to be sure that the pager is C<less>. It checks for C<less> masquerading as C<more> and records the result in -C<$ENV{LESS}> so we don't have to go through doing the stats again. +C<$fixed_less> so we don't have to go through doing the stats again. =cut sub fix_less { # We already know if this is set. - return if defined $ENV{LESS} && $ENV{LESS} =~ /r/; + return if $fixed_less; # Pager is less for sure. my $is_less = $pager =~ /\bless\b/; @@ -7625,7 +7640,7 @@ sub fix_less { # changes environment! # 'r' added so we don't do (slow) stats again. - $ENV{LESS} .= 'r' if $is_less; + $fixed_less = 1 if $is_less; } ## end sub fix_less =head1 DIE AND WARN MANAGEMENT @@ -7759,7 +7774,7 @@ sub dbdie { die @_ if $^S; # in eval propagate } - # The code used to check $^S to see if compiliation of the current thing + # The code used to check $^S to see if compilation of the current thing # hadn't finished. We don't do it anymore, figuring eval is pretty stable. eval { require Carp }; @@ -8040,7 +8055,7 @@ Just checks the contents of C<$^O> and sets the C<$doccmd> global accordingly. =cut sub setman { - $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s + $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|NetWare)\z/s ? "man" # O Happy Day! : "perldoc"; # Alas, poor unfortunates } ## end sub setman @@ -8115,7 +8130,6 @@ my @pods = qw( amiga apio api - apollo artistic beos book @@ -8639,7 +8653,7 @@ if PadWalker could be loaded. =cut - if (not $text =~ /::/ and eval "require PadWalker; 1" and not $@ ) { + if (not $text =~ /::/ and eval { require PadWalker } ) { my $level = 1; while (1) { my @info = caller($level); @@ -8866,7 +8880,7 @@ Rerun the current session to: rerun -4 current command minus 4 (go back 4 steps) Whether this always makes sense, in the current context is unknowable, and is -in part left as a useful exersize for the reader. This sub returns the +in part left as a useful exercise for the reader. This sub returns the appropriate arguments to rerun the current session. =cut @@ -9060,7 +9074,7 @@ variable via C<DB::set_list>. set_list( "PERLDB_POST", @$post ); set_list( "PERLDB_TYPEAHEAD", @typeahead ); - # We are oficially restarting. + # We are officially restarting. $ENV{PERLDB_RESTART} = 1; # We are junking all child debuggers. |