File Coverage

blib/lib/Devel/Command/DBSub/DB_5_8_5.pm

Criterion	Covered	Total	%
statement	9	427	2.1
branch	2	310	0.6
condition	1	85	1.1
subroutine	3	4	75.0
pod	0	1	0.0
total	15	827	1.8

package Devel::Command::DBSub::DB_5_8_5;

sub import {
  if (my($sub_version) =
          # 5.9.1 is also this version of the debugger
          ($] =~ /^5.008(.*)/ or
           $] eq '5.009001'
          )
     ) {
    # This module might work.
    if ($sub_version+0 <= 5) {
      return \&DB::alt_585_DB;
    }
    else {
      # Not 5.8.5 or less.
      return;
    }
  }
  else {
    # not 5.8 at all.
    return;
  }
}

{
no strict;
no warnings;
package DB;

sub alt_585_DB {

    # Check for whether we should be running continuously or not.
    # _After_ the perl program is compiled, $single is set to 1:
    if ( $single and not $second_time++ ) {

        # Options say run non-stop. Run until we get an interrupt.
        if ($runnonstop) {    # Disable until signal
                # If there's any call stack in place, turn off single
                # stepping into subs throughout the stack.
            for ( $i = 0 ; $i <= $stack_depth ; ) {
                $stack[ $i++ ] &= ~1;
            }

            # And we are now no longer in single-step mode.
            $single = 0;

            # If we simply returned at this point, we wouldn't get
            # the trace info. Fall on through.
            # return;
        } ## end if ($runnonstop)

        elsif ($ImmediateStop) {

            # We are supposed to stop here; XXX probably a break.
            $ImmediateStop = 0;    # We've processed it; turn it off
            $signal        = 1;    # Simulate an interrupt to force
                                   # us into the command loop
        }
    } ## end if ($single and not $second_time...

    # If we're in single-step mode, or an interrupt (real or fake)
    # has occurred, turn off non-stop mode.
    $runnonstop = 0 if $single or $signal;

    # Preserve current values of $@, $!, $^E, $,, $/, $\, $^W.
    # The code being debugged may have altered them.
    &save;

    # Since DB::DB gets called after every line, we can use caller() to
    # figure out where we last were executing. Sneaky, eh? This works because
    # caller is returning all the extra information when called from the
    # debugger.
    local ( $package, $filename, $line ) = caller;
    local $filename_ini = $filename;

    # set up the context for DB::eval, so it can properly execute
    # code on behalf of the user. We add the package in so that the
    # code is eval'ed in the proper package (not in the debugger!).
    local $usercontext =
      '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' . "package $package;";

    # Create an alias to the active file magical array to simplify
    # 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;

    # if we have something here, see if we should break.
    if ( $dbline{$line}
        && ( ( $stop, $action ) = split( /\0/, $dbline{$line} ) ) )
    {

        # Stop if the stop criterion says to just stop.
        if ( $stop eq '1' ) {
            $signal |= 1;
        }

        # It's a conditional stop; eval it in the user's context and
        # see if we should stop. If so, remove the one-time sigil.
        elsif ($stop) {
            $evalarg = "\$DB::signal |= 1 if do {$stop}";
            &eval;
            $dbline{$line} =~ s/;9($|\0)/$1/;
        }
    } ## end if ($dbline{$line} && ...

    # Preserve the current stop-or-not, and see if any of the W
    # (watch expressions) has changed.
    my $was_signal = $signal;

    # If we have any watch expressions ...
    if ( $trace & 2 ) {
        for ( my $n = 0 ; $n <= $#to_watch ; $n++ ) {
            $evalarg = $to_watch[$n];
            local $onetimeDump;    # Tell DB::eval() to not output results

            # Fix context DB::eval() wants to return an array, but
            # we need a scalar here.
            my ($val) = join( "', '", &eval );
            $val = ( ( defined $val ) ? "'$val'" : 'undef' );

            # Did it change?
            if ( $val ne $old_watch[$n] ) {

                # Yep! Show the difference, and fake an interrupt.
                $signal = 1;
                print $OUT <
Watchpoint $n:\t$to_watch[$n] changed:
    old value:\t$old_watch[$n]
    new value:\t$val
EOP
                $old_watch[$n] = $val;
            } ## end if ($val ne $old_watch...
        } ## end for (my $n = 0 ; $n <= ...
    } ## end if ($trace & 2)

    # If there's a user-defined DB::watchfunction, call it with the
    # current package, filename, and line. The function executes in
    # the DB:: package.
    if ( $trace & 4 ) {    # User-installed watch
        return
          if watchfunction( $package, $filename, $line )
          and not $single
          and not $was_signal
          and not( $trace & ~4 );
    } ## end if ($trace & 4)

    # Pick up any alteration to $signal in the watchfunction, and
    # turn off the signal now.
    $was_signal = $signal;
    $signal     = 0;

    # Check to see if we should grab control ($single true,
    # trace set appropriately, or we got a signal).
    if ( $single || ( $trace & 1 ) || $was_signal ) {

        # Yes, grab control.
        if ($slave_editor) {

            # Tell the editor to update its position.
            $position = "\032\032$filename:$line:0\n";
            print_lineinfo($position);
        }

        elsif ( $package eq 'DB::fake' ) {

            # Fallen off the end already.
            $term || &setterm;
            print_help(<
Debugged program terminated.  Use B to quit or B to restart,
  use B I to avoid stopping after program termination,
  B, B or B to get additional info.
EOP

            # Set the DB::eval context appropriately.
            $package     = 'main';
            $usercontext =
                '($@, $!, $^E, $,, $/, $\, $^W) = @saved;'
              . "package $package;";    # this won't let them modify, alas
        } ## end elsif ($package eq 'DB::fake')


        else {

            # Still somewhere in the midst of execution. Set up the
            #  debugger prompt.
            $sub =~ s/\'/::/;    # Swap Perl 4 package separators (') to
                                 # Perl 5 ones (sorry, we don't print Klingon
                                 #module names)

            $prefix = $sub =~ /::/ ? "" : "${'package'}::";
            $prefix .= "$sub($filename:";
            $after = ( $dbline[$line] =~ /\n$/ ? '' : "\n" );

            # Break up the prompt if it's really long.
            if ( length($prefix) > 30 ) {
                $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
                $prefix   = "";
                $infix    = ":\t";
            }
            else {
                $infix    = "):\t";
                $position = "$prefix$line$infix$dbline[$line]$after";
            }

            # Print current line info, indenting if necessary.
            if ($frame) {
                print_lineinfo( ' ' x $stack_depth,
                    "$line:\t$dbline[$line]$after" );
            }
            else {
                print_lineinfo($position);
            }

            # Scan forward, stopping at either the end or the next
            # unbreakable line.
            for ( $i = $line + 1 ; $i <= $max && $dbline[$i] == 0 ; ++$i )
            {    #{ vi

                # Drop out on null statements, block closers, and comments.
                last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;

                # Drop out if the user interrupted us.
                last if $signal;

                # Append a newline if the line doesn't have one. Can happen
                # in eval'ed text, for instance.
                $after = ( $dbline[$i] =~ /\n$/ ? '' : "\n" );

                # Next executable line.
                $incr_pos = "$prefix$i$infix$dbline[$i]$after";
                $position .= $incr_pos;
                if ($frame) {

                    # Print it indented if tracing is on.
                    print_lineinfo( ' ' x $stack_depth,
                        "$i:\t$dbline[$i]$after" );
                }
                else {
                    print_lineinfo($incr_pos);
                }
            } ## end for ($i = $line + 1 ; $i...
        } ## end else [ if ($slave_editor)
    } ## end if ($single || ($trace...


    # If there's an action, do it now.
    $evalarg = $action, &eval if $action;

    # Are we nested another level (e.g., did we evaluate a function
    # that had a breakpoint in it at the debugger prompt)?
    if ( $single || $was_signal ) {

        # Yes, go down a level.
        local $level = $level + 1;

        # Do any pre-prompt actions.
        foreach $evalarg (@$pre) {
            &eval;
        }

        # Complain about too much recursion if we passed the limit.
        print $OUT $stack_depth . " levels deep in subroutine calls!\n"
          if $single & 4;

        # The line we're currently on. Set $incr to -1 to stay here
        # until we get a command that tells us to advance.
        $start = $line;
        $incr  = -1;      # for backward motion.

        # Tack preprompt debugger actions ahead of any actual input.
        @typeahead = ( @$pretype, @typeahead );

        # The big command dispatch loop. It keeps running until the
        # user yields up control again.
        #
        # If we have a terminal for input, and we get something back
        # from readline(), keep on processing.
      CMD:
        while (

            # We have a terminal, or can get one ...
            ( $term || &setterm ),

            # ... and it belogs to this PID or we get one for this PID ...
            ( $term_pid == $$ or resetterm(1) ),

            # ... and we got a line of command input ...
            defined(
                $cmd = &readline(
                        "$pidprompt  DB"
                      . ( '<' x $level )
                      . ( $#hist + 1 )
                      . ( '>' x $level ) . " "
                )
            )
          )
        {

            # ... try to execute the input as debugger commands.

            # Don't stop running.
            $single = 0;

            # No signal is active.
            $signal = 0;

            # Handle continued commands (ending with \):
            $cmd =~ s/\\$/\n/ && do {
                $cmd .= &readline("  cont: ");
                redo CMD;
            };

            # Empty input means repeat the last command.
            $cmd =~ /^$/ && ( $cmd = $laststep );
            chomp($cmd);    # get rid of the annoying extra newline
            push( @hist, $cmd ) if length($cmd) > 1;
            push( @truehist, $cmd );

            # This is a restart point for commands that didn't arrive
            # via direct user input. It allows us to 'redo PIPE' to
            # re-execute command processing without reading a new command.
          PIPE: {
                $cmd =~ s/^\s+//s;    # trim annoying leading whitespace
                $cmd =~ s/\s+$//s;    # trim annoying trailing whitespace
                ($i) = split( /\s+/, $cmd );

                # See if there's an alias for the command, and set it up if so.
                if ( $alias{$i} ) {

                    # Squelch signal handling; we want to keep control here
                    # if something goes loco during the alias eval.
                    local $SIG{__DIE__};
                    local $SIG{__WARN__};

                    # This is a command, so we eval it in the DEBUGGER's
                    # scope! Otherwise, we can't see the special debugger
                    # variables, or get to the debugger's subs. (Well, we
                    # _could_, but why make it even more complicated?)
                    eval "\$cmd =~ $alias{$i}";
                    if ($@) {
                        local $\ = '';
                        print $OUT "Couldn't evaluate `$i' alias: $@";
                        next CMD;
                    }
                } ## end if ($alias{$i})

### Extended commands

### Define your extended commands in C<%commands> at the top of the file.
### This section runs them.

               foreach my $do (keys %DB::commands) {
                 next unless $cmd =~ /^$do\s*/;
                 $commands{$do}->($cmd) and next CMD;
                 #  ? next CMD : last CMD;
               }

                $cmd =~ /^q$/ && do {
                    $fall_off_end = 1;
                    clean_ENV();
                    exit $?;
                };

                $cmd =~ /^t$/ && do {
                    $trace ^= 1;
                    local $\ = '';
                    print $OUT "Trace = "
                      . ( ( $trace & 1 ) ? "on" : "off" ) . "\n";
                    next CMD;
                };

                $cmd =~ /^S(\s+(!)?(.+))?$/ && do {

                    $Srev     = defined $2;     # Reverse scan?
                    $Spatt    = $3;             # The pattern (if any) to use.
                    $Snocheck = !defined $1;    # No args - print all subs.

                    # Need to make these sane here.
                    local $\ = '';
                    local $, = '';

                    # Search through the debugger's magical hash of subs.
                    # If $nocheck is true, just print the sub name.
                    # Otherwise, check it against the pattern. We then use
                    # the XOR trick to reverse the condition as required.
                    foreach $subname ( sort( keys %sub ) ) {
                        if ( $Snocheck or $Srev ^ ( $subname =~ /$Spatt/ ) ) {
                            print $OUT $subname, "\n";
                        }
                    }
                    next CMD;
                };


                $cmd =~ s/^X\b/V $package/;


                # Bare V commands get the currently-being-debugged package
                # added.
                $cmd =~ /^V$/ && do {
                    $cmd = "V $package";
                };

                # V - show variables in package.
                $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {

                    # Save the currently selected filehandle and
                    # force output to debugger's filehandle (dumpvar
                    # just does "print" for output).
                    local ($savout) = select($OUT);

                    # Grab package name and variables to dump.
                    $packname = $1;
                    @vars     = split( ' ', $2 );

                    # If main::dumpvar isn't here, get it.
                    do 'dumpvar.pl' unless defined &main::dumpvar;
                    if ( defined &main::dumpvar ) {

                        # We got it. Turn off subroutine entry/exit messages
                        # for the moment, along with return values.
                        local $frame = 0;
                        local $doret = -2;

                        # must detect sigpipe failures  - not catching
                        # then will cause the debugger to die.
                        eval {
                            &main::dumpvar(
                                $packname,
                                defined $option{dumpDepth}
                                ? $option{dumpDepth}
                                : -1,    # assume -1 unless specified
                                @vars
                            );
                        };

                        # The die doesn't need to include the $@, because
                        # it will automatically get propagated for us.
                        if ($@) {
                            die unless $@ =~ /dumpvar print failed/;
                        }
                    } ## end if (defined &main::dumpvar)
                    else {

                        # Couldn't load dumpvar.
                        print $OUT "dumpvar.pl not available.\n";
                    }

                    # Restore the output filehandle, and go round again.
                    select($savout);
                    next CMD;
                };

                $cmd =~ s/^x\b/ / && do {    # Remainder gets done by DB::eval()
                    $onetimeDump = 'dump';    # main::dumpvar shows the output

                    # handle special  "x 3 blah" syntax XXX propagate
                    # doc back to special variables.
                    if ( $cmd =~ s/^\s*(\d+)(?=\s)/ / ) {
                        $onetimedumpDepth = $1;
                    }
                };

                $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
                    methods($1);
                    next CMD;
                };

                # m expr - set up DB::eval to do the work
                $cmd =~ s/^m\b/ / && do {    # Rest gets done by DB::eval()
                    $onetimeDump = 'methods';   #  method output gets used there
                };

                $cmd =~ /^f\b\s*(.*)/ && do {
                    $file = $1;
                    $file =~ s/\s+$//;

                    # help for no arguments (old-style was return from sub).
                    if ( !$file ) {
                        print $OUT
                          "The old f command is now the r command.\n";    # hint
                        print $OUT "The new f command switches filenames.\n";
                        next CMD;
                    } ## end if (!$file)

                    # if not in magic file list, try a close match.
                    if ( !defined $main::{ '_<' . $file } ) {
                        if ( ($try) = grep( m#^_<.*$file#, keys %main:: ) ) {
                            {
                                $try = substr( $try, 2 );
                                print $OUT "Choosing $try matching `$file':\n";
                                $file = $try;
                            }
                        } ## end if (($try) = grep(m#^_<.*$file#...
                    } ## end if (!defined $main::{ ...

                    # If not successfully switched now, we failed.
                    if ( !defined $main::{ '_<' . $file } ) {
                        print $OUT "No file matching `$file' is loaded.\n";
                        next CMD;
                    }

                    # We switched, so switch the debugger internals around.
                    elsif ( $file ne $filename ) {
                        *dbline   = $main::{ '_<' . $file };
                        $max      = $#dbline;
                        $filename = $file;
                        $start    = 1;
                        $cmd      = "l";
                    } ## end elsif ($file ne $filename)

                    # We didn't switch; say we didn't.
                    else {
                        print $OUT "Already in $file.\n";
                        next CMD;
                    }
                };

                # . command.
                $cmd =~ /^\.$/ && do {
                    $incr = -1;    # stay at current line

                    # Reset everything to the old location.
                    $start    = $line;
                    $filename = $filename_ini;
                    *dbline   = $main::{ '_<' . $filename };
                    $max      = $#dbline;

                    # Now where are we?
                    print_lineinfo($position);
                    next CMD;
                };

                # - - back a window.
                $cmd =~ /^-$/ && do {

                    # back up by a window; go to 1 if back too far.
                    $start -= $incr + $window + 1;
                    $start = 1 if $start <= 0;
                    $incr  = $window - 1;

                    # Generate and execute a "l +" command (handled below).
                    $cmd = 'l ' . ($start) . '+';
                };

                # All of these commands were remapped in perl 5.8.0;
                # we send them off to the secondary dispatcher (see below).
                $cmd =~ /^([aAbBhilLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so && do {
                    &cmd_wrapper( $1, $2, $line );
                    next CMD;
                };


                $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/ && do {

                    # See if we've got the necessary support.
                    eval { require PadWalker; PadWalker->VERSION(0.08) }
                      or &warn(
                        $@ =~ /locate/
                        ? "PadWalker module not found - please install\n"
                        : $@
                      )
                      and next CMD;

                    # Load up dumpvar if we don't have it. If we can, that is.
                    do 'dumpvar.pl' unless defined &main::dumpvar;
                    defined &main::dumpvar
                      or print $OUT "dumpvar.pl not available.\n"
                      and next CMD;

                    # Got all the modules we need. Find them and print them.
                    my @vars = split( ' ', $2 || '' );

                    # Find the pad.
                    my $h = eval { PadWalker::peek_my( ( $1 || 0 ) + 1 ) };

                    # Oops. Can't find it.
                    $@ and $@ =~ s/ at .*//, &warn($@), next CMD;

                    # Show the desired vars with dumplex().
                    my $savout = select($OUT);

                    # Have dumplex dump the lexicals.
                    dumpvar::dumplex( $_, $h->{$_},
                        defined $option{dumpDepth} ? $option{dumpDepth} : -1,
                        @vars )
                      for sort keys %$h;
                    select($savout);
                    next CMD;
                };

                # n - next
                $cmd =~ /^n$/ && do {
                    end_report(), next CMD if $finished and $level <= 1;

                    # Single step, but don't enter subs.
                    $single = 2;

                    # Save for empty command (repeat last).
                    $laststep = $cmd;
                    last CMD;
                };

                # s - single step.
                $cmd =~ /^s$/ && do {

                    # Get out and restart the command loop if program
                    # has finished.
                    end_report(), next CMD if $finished and $level <= 1;

                    # Single step should enter subs.
                    $single = 1;

                    # Save for empty command (repeat last).
                    $laststep = $cmd;
                    last CMD;
                };


                # c - start continuous execution.
                $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {

                    # Hey, show's over. The debugged program finished
                    # executing already.
                    end_report(), next CMD if $finished and $level <= 1;

                    # Capture the place to put a one-time break.
                    $subname = $i = $1;

                    #  Probably not needed, since we finish an interactive
                    #  sub-session anyway...
                    # local $filename = $filename;
                    # local *dbline = *dbline; # XXX Would this work?!
                    #
                    # The above question wonders if localizing the alias
                    # to the magic array works or not. Since it's commented
                    # out, we'll just leave that to speculation for now.

                    # If the "subname" isn't all digits, we'll assume it
                    # is a subroutine name, and try to find it.
                    if ( $subname =~ /\D/ ) {    # subroutine name
                            # Qualify it to the current package unless it's
                            # already qualified.
                        $subname = $package . "::" . $subname
                          unless $subname =~ /::/;

                        # find_sub will return "file:line_number" corresponding
                        # to where the subroutine is defined; we call find_sub,
                        # break up the return value, and assign it in one
                        # operation.
                        ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ );

                        # Force the line number to be numeric.
                        $i += 0;

                        # If we got a line number, we found the sub.
                        if ($i) {

                            # Switch all the debugger's internals around so
                            # we're actually working with that file.
                            $filename = $file;
                            *dbline   = $main::{ '_<' . $filename };

                            # Mark that there's a breakpoint in this file.
                            $had_breakpoints{$filename} |= 1;

                            # Scan forward to the first executable line
                            # after the 'sub whatever' line.
                            $max = $#dbline;
                            ++$i while $dbline[$i] == 0 && $i < $max;
                        } ## end if ($i)

                        # We didn't find a sub by that name.
                        else {
                            print $OUT "Subroutine $subname not found.\n";
                            next CMD;
                        }
                    } ## end if ($subname =~ /\D/)

                    # At this point, either the subname was all digits (an
                    # absolute line-break request) or we've scanned through
                    # the code following the definition of the sub, looking
                    # for an executable, which we may or may not have found.
                    #
                    # If $i (which we set $subname from) is non-zero, we
                    # got a request to break at some line somewhere. On
                    # one hand, if there wasn't any real subroutine name
                    # involved, this will be a request to break in the current
                    # file at the specified line, so we have to check to make
                    # sure that the line specified really is breakable.
                    #
                    # On the other hand, if there was a subname supplied, the
                    # preceeding block has moved us to the proper file and
                    # location within that file, and then scanned forward
                    # looking for the next executable line. We have to make
                    # sure that one was found.
                    #
                    # On the gripping hand, we can't do anything unless the
                    # current value of $i points to a valid breakable line.
                    # Check that.
                    if ($i) {

                        # Breakable?
                        if ( $dbline[$i] == 0 ) {
                            print $OUT "Line $i not breakable.\n";
                            next CMD;
                        }

                        # Yes. Set up the one-time-break sigil.
                        $dbline{$i} =~ s/($|\0)/;9$1/;  # add one-time-only b.p.
                    } ## end if ($i)

                    # Turn off stack tracing from here up.
                    for ( $i = 0 ; $i <= $stack_depth ; ) {
                        $stack[ $i++ ] &= ~1;
                    }
                    last CMD;
                };

                # r - return from the current subroutine.
                $cmd =~ /^r$/ && do {

                    # Can't do anythign if the program's over.
                    end_report(), next CMD if $finished and $level <= 1;

                    # Turn on stack trace.
                    $stack[$stack_depth] |= 1;

                    # Print return value unless the stack is empty.
                    $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
                    last CMD;
                };

                $cmd =~ /^T$/ && do {
                    print_trace( $OUT, 1 );    # skip DB
                    next CMD;
                };

                $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w( 'w', $1 ); next CMD; };

                $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W( 'W', $1 ); next CMD; };

                $cmd =~ /^\/(.*)$/ && do {

                    # The pattern as a string.
                    $inpat = $1;

                    # Remove the final slash.
                    $inpat =~ s:([^\\])/$:$1:;

                    # If the pattern isn't null ...
                    if ( $inpat ne "" ) {

                        # Turn of warn and die procesing for a bit.
                        local $SIG{__DIE__};
                        local $SIG{__WARN__};

                        # Create the pattern.
                        eval '$inpat =~ m' . "\a$inpat\a";
                        if ( $@ ne "" ) {

                            # Oops. Bad pattern. No biscuit.
                            # Print the eval error and go back for more
                            # commands.
                            print $OUT "$@";
                            next CMD;
                        }
                        $pat = $inpat;
                    } ## end if ($inpat ne "")

                    # Set up to stop on wrap-around.
                    $end = $start;

                    # Don't move off the current line.
                    $incr = -1;

                    # Done in eval so nothing breaks if the pattern
                    # does something weird.
                    eval '
                        for (;;) {
                            # Move ahead one line.
                            ++$start;

                            # Wrap if we pass the last line.
                            $start = 1 if ($start > $max);

                            # Stop if we have gotten back to this line again,
                            last if ($start == $end);

                            # A hit! (Note, though, that we are doing
                            # case-insensitive matching. Maybe a qr//
                            # expression would be better, so the user could
                            # do case-sensitive matching if desired.
                            if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
                                if ($slave_editor) {
                                    # Handle proper escaping in the slave.
                                    print $OUT "\032\032$filename:$start:0\n";
                                }
                                else {
                                    # Just print the line normally.
                                    print $OUT "$start:\t",$dbline[$start],"\n";
                                }
                                # And quit since we found something.
                                last;
                            }
                         } ';

                    # If we wrapped, there never was a match.
                    print $OUT "/$pat/: not found\n" if ( $start == $end );
                    next CMD;
                };

                # ? - backward pattern search.
                $cmd =~ /^\?(.*)$/ && do {

                    # Get the pattern, remove trailing question mark.
                    $inpat = $1;
                    $inpat =~ s:([^\\])\?$:$1:;

                    # If we've got one ...
                    if ( $inpat ne "" ) {

                        # Turn off die & warn handlers.
                        local $SIG{__DIE__};
                        local $SIG{__WARN__};
                        eval '$inpat =~ m' . "\a$inpat\a";

                        if ( $@ ne "" ) {

                            # Ouch. Not good. Print the error.
                            print $OUT $@;
                            next CMD;
                        }
                        $pat = $inpat;
                    } ## end if ($inpat ne "")

                    # Where we are now is where to stop after wraparound.
                    $end = $start;

                    # Don't move away from this line.
                    $incr = -1;

                    # Search inside the eval to prevent pattern badness
                    # from killing us.
                    eval '
                        for (;;) {
                            # Back up a line.
                            --$start;

                            # Wrap if we pass the first line.

                            $start = $max if ($start <= 0);

                            # Quit if we get back where we started,
                            last if ($start == $end);

                            # Match?
                            if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
                                if ($slave_editor) {
                                    # Yep, follow slave editor requirements.
                                    print $OUT "\032\032$filename:$start:0\n";
                                }
                                else {
                                    # Yep, just print normally.
                                    print $OUT "$start:\t",$dbline[$start],"\n";
                                }

                                # Found, so done.
                                last;
                            }
                        } ';

                    # Say we failed if the loop never found anything,
                    print $OUT "?$pat?: not found\n" if ( $start == $end );
                    next CMD;
                };

                # $rc - recall command.
                $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {

                    # No arguments, take one thing off history.
                    pop(@hist) if length($cmd) > 1;

                    # Relative (- found)?
                    #  Y - index back from most recent (by 1 if bare minus)
                    #  N - go to that particular command slot or the last
                    #      thing if nothing following.
                    $i = $1 ? ( $#hist - ( $2 || 1 ) ) : ( $2 || $#hist );

                    # Pick out the command desired.
                    $cmd = $hist[$i];

                    # Print the command to be executed and restart the loop
                    # with that command in the buffer.
                    print $OUT $cmd, "\n";
                    redo CMD;
                };

                # $sh$sh - run a shell command (if it's all ASCII).
                # Can't run shell commands with Unicode in the debugger, hmm.
                $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {

                    # System it.
                    &system($1);
                    next CMD;
                };

                # $rc pattern $rc - find a command in the history.
                $cmd =~ /^$rc([^$rc].*)$/ && do {

                    # Create the pattern to use.
                    $pat = "^$1";

                    # Toss off last entry if length is >1 (and it always is).
                    pop(@hist) if length($cmd) > 1;

                    # Look backward through the history.
                    for ( $i = $#hist ; $i ; --$i ) {

                        # Stop if we find it.
                        last if $hist[$i] =~ /$pat/;
                    }

                    if ( !$i ) {

                        # Never found it.
                        print $OUT "No such command!\n\n";
                        next CMD;
                    }

                    # Found it. Put it in the buffer, print it, and process it.
                    $cmd = $hist[$i];
                    print $OUT $cmd, "\n";
                    redo CMD;
                };

                # $sh - start a shell.
                $cmd =~ /^$sh$/ && do {

                    # Run the user's shell. If none defined, run Bourne.
                    # We resume execution when the shell terminates.
                    &system( $ENV{SHELL} || "/bin/sh" );
                    next CMD;
                };

                # $sh command - start a shell and run a command in it.
                $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {

                    # XXX: using csh or tcsh destroys sigint retvals!
                    #&system($1);  # use this instead

                    # use the user's shell, or Bourne if none defined.
                    &system( $ENV{SHELL} || "/bin/sh", "-c", $1 );
                    next CMD;
                };

                $cmd =~ /^H\b\s*\*/ && do {
                    @hist = @truehist = ();
                    print $OUT "History cleansed\n";
                    next CMD;
                };

                $cmd =~ /^H\b\s*(-(\d+))?/ && do {

                    # Anything other than negative numbers is ignored by
                    # the (incorrect) pattern, so this test does nothing.
                    $end = $2 ? ( $#hist - $2 ) : 0;

                    # Set to the minimum if less than zero.
                    $hist = 0 if $hist < 0;

                    # Start at the end of the array.
                    # Stay in while we're still above the ending value.
                    # Tick back by one each time around the loop.
                    for ( $i = $#hist ; $i > $end ; $i-- ) {

                        # Print the command  unless it has no arguments.
                        print $OUT "$i: ", $hist[$i], "\n"
                          unless $hist[$i] =~ /^.?$/;
                    }
                    next CMD;
                };

                # man, perldoc, doc - show manual pages.
                $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
                    runman($1);
                    next CMD;
                };

                # p - print (no args): print $_.
                $cmd =~ s/^p$/print {\$DB::OUT} \$_/;

                # p - print the given expression.
                $cmd =~ s/^p\b/print {\$DB::OUT} /;

                # = - set up a command alias.
                $cmd =~ s/^=\s*// && do {
                    my @keys;
                    if ( length $cmd == 0 ) {

                        # No args, get current aliases.
                        @keys = sort keys %alias;
                    }
                    elsif ( my ( $k, $v ) = ( $cmd =~ /^(\S+)\s+(\S.*)/ ) ) {

                        # Creating a new alias. $k is alias name, $v is
                        # alias value.

                        # can't use $_ or kill //g state
                        for my $x ( $k, $v ) {

                            # Escape "alarm" characters.
                            $x =~ s/\a/\\a/g;
                        }

                        # Substitute key for value, using alarm chars
                        # as separators (which is why we escaped them in
                        # the command).
                        $alias{$k} = "s\a$k\a$v\a";

                        # Turn off standard warn and die behavior.
                        local $SIG{__DIE__};
                        local $SIG{__WARN__};

                        # Is it valid Perl?
                        unless ( eval "sub { s\a$k\a$v\a }; 1" ) {

                            # Nope. Bad alias. Say so and get out.
                            print $OUT "Can't alias $k to $v: $@\n";
                            delete $alias{$k};
                            next CMD;
                        }

                        # We'll only list the new one.
                        @keys = ($k);
                    } ## end elsif (my ($k, $v) = ($cmd...

                    # The argument is the alias to list.
                    else {
                        @keys = ($cmd);
                    }

                    # List aliases.
                    for my $k (@keys) {

                        # Messy metaquoting: Trim the substiution 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 ) {

                            # Print the alias.
                            print $OUT "$k\t= $1\n";
                        }
                        elsif ( defined $alias{$k} ) {

                            # Couldn't trim it off; just print the alias code.
                            print $OUT "$k\t$alias{$k}\n";
                        }
                        else {

                            # No such, dude.
                            print "No alias for $k\n";
                        }
                    } ## end for my $k (@keys)
                    next CMD;
                };

                # source - read commands from a file (or pipe!) and execute.
                $cmd =~ /^source\s+(.*\S)/ && do {
                    if ( open my $fh, $1 ) {

                        # Opened OK; stick it in the list of file handles.
                        push @cmdfhs, $fh;
                    }
                    else {

                        # Couldn't open it.
                        &warn("Can't execute `$1': $!\n");
                    }
                    next CMD;
                };

                # save source - write commands to a file for later use
                $cmd =~ /^save\s*(.*)$/ && do {
                    my $file = $1 || '.perl5dbrc';    # default?
                    if ( open my $fh, "> $file" ) {

                       # chomp to remove extraneous newlines from source'd files
                        chomp( my @truelist =
                              map { m/^\s*(save|source)/ ? "#$_" : $_ }
                              @truehist );
                        print $fh join( "\n", @truelist );
                        print "commands saved in $file\n";
                    }
                    else {
                        &warn("Can't save debugger commands in '$1': $!\n");
                    }
                    next CMD;
                };

                # R - restart execution.
                # rerun - controlled restart execution.
                $cmd =~ /^(R|rerun\s*(.*))$/ && do {
                    my @args = ($1 eq 'R' ? restart() : rerun($2));

                    # And run Perl again.  We use exec() to keep the
                    # PID stable (and that way $ini_pids is still valid).
                    exec(@args) || print $OUT "exec failed: $!\n";

                    last CMD;
                };

                # || - run command in the pager, with output to DB::OUT.
                $cmd =~ /^\|\|?\s*[^|]/ && do {
                    if ( $pager =~ /^\|/ ) {

                        # Default pager is into a pipe. Redirect I/O.
                        open( SAVEOUT, ">&STDOUT" )
                          || &warn("Can't save STDOUT");
                        open( STDOUT, ">&OUT" )
                          || &warn("Can't redirect STDOUT");
                    } ## end if ($pager =~ /^\|/)
                    else {

                        # Not into a pipe. STDOUT is safe.
                        open( SAVEOUT, ">&OUT" ) || &warn("Can't save DB::OUT");
                    }

                    # Fix up environment to record we have less if so.
                    fix_less();

                    unless ( $piped = open( OUT, $pager ) ) {

                        # Couldn't open pipe to pager.
                        &warn("Can't pipe output to `$pager'");
                        if ( $pager =~ /^\|/ ) {

                            # Redirect I/O back again.
                            open( OUT, ">&STDOUT" )    # XXX: lost message
                              || &warn("Can't restore DB::OUT");
                            open( STDOUT, ">&SAVEOUT" )
                              || &warn("Can't restore STDOUT");
                            close(SAVEOUT);
                        } ## end if ($pager =~ /^\|/)
                        else {

                            # Redirect I/O. STDOUT already safe.
                            open( OUT, ">&STDOUT" )    # XXX: lost message
                              || &warn("Can't restore DB::OUT");
                        }
                        next CMD;
                    } ## end unless ($piped = open(OUT,...

                    # Set up broken-pipe handler if necessary.
                    $SIG{PIPE} = \&DB::catch
                      if $pager =~ /^\|/
                      && ( "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE} );

                    # Save current filehandle, unbuffer out, and put it back.
                    $selected = select(OUT);
                    $|        = 1;

                    # Don't put it back if pager was a pipe.
                    select($selected), $selected = "" unless $cmd =~ /^\|\|/;

                    # Trim off the pipe symbols and run the command now.
                    $cmd =~ s/^\|+\s*//;
                    redo PIPE;
                };

                # t - turn trace on.
                $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;

                # s - single-step. Remember the last command was 's'.
                $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do { $laststep = 's' };

                # n - single-step, but not into subs. Remember last command
                # was 'n'.
                $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do { $laststep = 'n' };

            }    # PIPE:

            # Make sure the flag that says "the debugger's running" is
            # still on, to make sure we get control again.
            $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd";

            # Run *our* eval that executes in the caller's context.
            &eval;

            # Turn off the one-time-dump stuff now.
            if ($onetimeDump) {
                $onetimeDump      = undef;
                $onetimedumpDepth = undef;
            }
            elsif ( $term_pid == $$ ) {
                STDOUT->flush();
                STDERR->flush();

                # XXX If this is the master pid, print a newline.
                print $OUT "\n";
            }
        } ## end while (($term || &setterm...


        continue {    # CMD:

            # At the end of every command:
            if ($piped) {

                # Unhook the pipe mechanism now.
                if ( $pager =~ /^\|/ ) {

                    # No error from the child.
                    $? = 0;

                    # we cannot warn here: the handle is missing --tchrist
                    close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";

                    # most of the $? crud was coping with broken cshisms
                    # $? is explicitly set to 0, so this never runs.
                    if ($?) {
                        print SAVEOUT "Pager `$pager' failed: ";
                        if ( $? == -1 ) {
                            print SAVEOUT "shell returned -1\n";
                        }
                        elsif ( $? >> 8 ) {
                            print SAVEOUT ( $? & 127 )
                              ? " (SIG#" . ( $? & 127 ) . ")"
                              : "", ( $? & 128 ) ? " -- core dumped" : "", "\n";
                        }
                        else {
                            print SAVEOUT "status ", ( $? >> 8 ), "\n";
                        }
                    } ## end if ($?)

                    # Reopen filehandle for our output (if we can) and
                    # restore STDOUT (if we can).
                    open( OUT, ">&STDOUT" ) || &warn("Can't restore DB::OUT");
                    open( STDOUT, ">&SAVEOUT" )
                      || &warn("Can't restore STDOUT");

                    # Turn off pipe exception handler if necessary.
                    $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;

                    # Will stop ignoring SIGPIPE if done like nohup(1)
                    # does SIGINT but Perl doesn't give us a choice.
                } ## end if ($pager =~ /^\|/)
                else {

                    # Non-piped "pager". Just restore STDOUT.
                    open( OUT, ">&SAVEOUT" ) || &warn("Can't restore DB::OUT");
                }

                # Close filehandle pager was using, restore the normal one
                # if necessary,
                close(SAVEOUT);
                select($selected), $selected = "" unless $selected eq "";

                # No pipes now.
                $piped = "";
            } ## end if ($piped)
        }    # CMD:

        # No more commands? Quit.
        $fall_off_end = 1 unless defined $cmd;    # Emulate `q' on EOF

        # Evaluate post-prompt commands.
        foreach $evalarg (@$post) {
            &eval;
        }
    }    # if ($single || $signal)

    # Put the user's globals back where you found them.
    ( $@, $!, $^E, $,, $/, $\, $^W ) = @saved;
    ();
} ## end sub DB

}

1;
__END__