+# PERLDBf_... flag names from perl.h
+our ( %DollarCaretP_flags, %DollarCaretP_flags_r );
+
+BEGIN {
+ %DollarCaretP_flags = (
+ PERLDBf_SUB => 0x01, # Debug sub enter/exit
+ PERLDBf_LINE => 0x02, # Keep line #
+ PERLDBf_NOOPT => 0x04, # Switch off optimizations
+ PERLDBf_INTER => 0x08, # Preserve more data
+ PERLDBf_SUBLINE => 0x10, # Keep subr source lines
+ PERLDBf_SINGLE => 0x20, # Start with single-step on
+ PERLDBf_NONAME => 0x40, # For _SUB: no name of the subr
+ PERLDBf_GOTO => 0x80, # Report goto: call DB::goto
+ PERLDBf_NAMEEVAL => 0x100, # Informative names for evals
+ PERLDBf_NAMEANON => 0x200, # Informative names for anon subs
+ PERLDB_ALL => 0x33f, # No _NONAME, _GOTO
+ );
+
+ %DollarCaretP_flags_r = reverse %DollarCaretP_flags;
+}
+
+sub parse_DollarCaretP_flags {
+ my $flags = shift;
+ $flags =~ s/^\s+//;
+ $flags =~ s/\s+$//;
+ my $acu = 0;
+ foreach my $f ( split /\s*\|\s*/, $flags ) {
+ my $value;
+ if ( $f =~ /^0x([[:xdigit:]]+)$/ ) {
+ $value = hex $1;
+ }
+ elsif ( $f =~ /^(\d+)$/ ) {
+ $value = int $1;
+ }
+ elsif ( $f =~ /^DEFAULT$/i ) {
+ $value = $DollarCaretP_flags{PERLDB_ALL};
+ }
+ else {
+ $f =~ /^(?:PERLDBf_)?(.*)$/i;
+ $value = $DollarCaretP_flags{ 'PERLDBf_' . uc($1) };
+ unless ( defined $value ) {
+ print $OUT (
+ "Unrecognized \$^P flag '$f'!\n",
+ "Acceptable flags are: "
+ . join( ', ', sort keys %DollarCaretP_flags ),
+ ", and hexadecimal and decimal numbers.\n"
+ );
+ return undef;
+ }
+ }
+ $acu |= $value;
+ }
+ $acu;
+}
+
+sub expand_DollarCaretP_flags {
+ my $DollarCaretP = shift;
+ my @bits = (
+ map {
+ my $n = ( 1 << $_ );
+ ( $DollarCaretP & $n )
+ ? ( $DollarCaretP_flags_r{$n}
+ || sprintf( '0x%x', $n ) )
+ : ()
+ } 0 .. 31
+ );
+ return @bits ? join( '|', @bits ) : 0;
+}
+
+=over 4
+
+=item rerun
+
+Rerun the current session to:
+
+ rerun current position
+
+ rerun 4 command number 4
+
+ 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
+appropriate arguments to rerun the current session.
+
+=cut
+
+sub rerun {
+ my $i = shift;
+ my @args;
+ pop(@truehist); # strim
+ unless (defined $truehist[$i]) {
+ print "Unable to return to non-existent command: $i\n";
+ } else {
+ $#truehist = ($i < 0 ? $#truehist + $i : $i > 0 ? $i : $#truehist);
+ my @temp = @truehist; # store
+ push(@DB::typeahead, @truehist); # saved
+ @truehist = @hist = (); # flush
+ @args = &restart(); # setup
+ &get_list("PERLDB_HIST"); # clean
+ &set_list("PERLDB_HIST", @temp); # reset
+ }
+ return @args;
+}
+
+=item restart
+
+Restarting the debugger is a complex operation that occurs in several phases.
+First, we try to reconstruct the command line that was used to invoke Perl
+and the debugger.
+
+=cut
+
+sub restart {
+ # I may not be able to resurrect you, but here goes ...
+ print $OUT
+"Warning: some settings and command-line options may be lost!\n";
+ my ( @script, @flags, $cl );
+
+ # If warn was on before, turn it on again.
+ push @flags, '-w' if $ini_warn;
+
+ # Rebuild the -I flags that were on the initial
+ # command line.
+ for (@ini_INC) {
+ push @flags, '-I', $_;
+ }
+
+ # Turn on taint if it was on before.
+ push @flags, '-T' if ${^TAINT};
+
+ # Arrange for setting the old INC:
+ # Save the current @init_INC in the environment.
+ set_list( "PERLDB_INC", @ini_INC );
+
+ # If this was a perl one-liner, go to the "file"
+ # corresponding to the one-liner read all the lines
+ # out of it (except for the first one, which is going
+ # to be added back on again when 'perl -d' runs: that's
+ # the 'require perl5db.pl;' line), and add them back on
+ # to the command line to be executed.
+ if ( $0 eq '-e' ) {
+ for ( 1 .. $#{'::_<-e'} ) { # The first line is PERL5DB
+ chomp( $cl = ${'::_<-e'}[$_] );
+ push @script, '-e', $cl;
+ }
+ } ## end if ($0 eq '-e')
+
+ # Otherwise we just reuse the original name we had
+ # before.
+ else {
+ @script = $0;
+ }
+
+=pod
+
+After the command line has been reconstructed, the next step is to save
+the debugger's status in environment variables. The C<DB::set_list> routine
+is used to save aggregate variables (both hashes and arrays); scalars are
+just popped into environment variables directly.
+
+=cut
+
+ # If the terminal supported history, grab it and
+ # save that in the environment.
+ set_list( "PERLDB_HIST",
+ $term->Features->{getHistory}
+ ? $term->GetHistory
+ : @hist );
+
+ # Find all the files that were visited during this
+ # session (i.e., the debugger had magic hashes
+ # corresponding to them) and stick them in the environment.
+ my @had_breakpoints = keys %had_breakpoints;
+ set_list( "PERLDB_VISITED", @had_breakpoints );
+
+ # Save the debugger options we chose.
+ set_list( "PERLDB_OPT", %option );
+ # set_list( "PERLDB_OPT", options2remember() );
+
+ # Save the break-on-loads.
+ set_list( "PERLDB_ON_LOAD", %break_on_load );
+
+=pod
+
+The most complex part of this is the saving of all of the breakpoints. They
+can live in an awful lot of places, and we have to go through all of them,
+find the breakpoints, and then save them in the appropriate environment
+variable via C<DB::set_list>.
+
+=cut
+
+ # Go through all the breakpoints and make sure they're
+ # still valid.
+ my @hard;
+ for ( 0 .. $#had_breakpoints ) {
+
+ # We were in this file.
+ my $file = $had_breakpoints[$_];
+
+ # Grab that file's magic line hash.
+ *dbline = $main::{ '_<' . $file };
+
+ # Skip out if it doesn't exist, or if the breakpoint
+ # is in a postponed file (we'll do postponed ones
+ # later).
+ next unless %dbline or $postponed_file{$file};
+
+ # In an eval. This is a little harder, so we'll
+ # do more processing on that below.
+ ( push @hard, $file ), next
+ if $file =~ /^\(\w*eval/;
+
+ # XXX I have no idea what this is doing. Yet.
+ my @add;
+ @add = %{ $postponed_file{$file} }
+ if $postponed_file{$file};
+
+ # Save the list of all the breakpoints for this file.
+ set_list( "PERLDB_FILE_$_", %dbline, @add );
+ } ## end for (0 .. $#had_breakpoints)
+
+ # The breakpoint was inside an eval. This is a little
+ # more difficult. XXX and I don't understand it.
+ for (@hard) {
+ # Get over to the eval in question.
+ *dbline = $main::{ '_<' . $_ };
+ my ( $quoted, $sub, %subs, $line ) = quotemeta $_;
+ for $sub ( keys %sub ) {
+ next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
+ $subs{$sub} = [ $1, $2 ];
+ }
+ unless (%subs) {
+ print $OUT
+ "No subroutines in $_, ignoring breakpoints.\n";
+ next;
+ }
+ LINES: for $line ( keys %dbline ) {
+
+ # One breakpoint per sub only:
+ my ( $offset, $sub, $found );
+ SUBS: for $sub ( keys %subs ) {
+ if (
+ $subs{$sub}->[1] >=
+ $line # Not after the subroutine
+ and (
+ not defined $offset # Not caught
+ or $offset < 0
+ )
+ )
+ { # or badly caught
+ $found = $sub;
+ $offset = $line - $subs{$sub}->[0];
+ $offset = "+$offset", last SUBS
+ if $offset >= 0;
+ } ## end if ($subs{$sub}->[1] >=...
+ } ## end for $sub (keys %subs)
+ if ( defined $offset ) {
+ $postponed{$found} =
+ "break $offset if $dbline{$line}";
+ }
+ else {
+ print $OUT
+"Breakpoint in $_:$line ignored: after all the subroutines.\n";
+ }
+ } ## end for $line (keys %dbline)
+ } ## end for (@hard)
+
+ # Save the other things that don't need to be
+ # processed.
+ set_list( "PERLDB_POSTPONE", %postponed );
+ set_list( "PERLDB_PRETYPE", @$pretype );
+ set_list( "PERLDB_PRE", @$pre );
+ set_list( "PERLDB_POST", @$post );
+ set_list( "PERLDB_TYPEAHEAD", @typeahead );
+
+ # We are oficially restarting.
+ $ENV{PERLDB_RESTART} = 1;
+
+ # We are junking all child debuggers.
+ delete $ENV{PERLDB_PIDS}; # Restore ini state
+
+ # Set this back to the initial pid.
+ $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
+
+=pod
+
+After all the debugger status has been saved, we take the command we built up
+and then return it, so we can C<exec()> it. The debugger will spot the
+C<PERLDB_RESTART> environment variable and realize it needs to reload its state
+from the environment.
+
+=cut
+
+ # And run Perl again. Add the "-d" flag, all the
+ # flags we built up, the script (whether a one-liner
+ # or a file), add on the -emacs flag for a slave editor,
+ # and then the old arguments.
+
+ return ($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS);
+
+}; # end restart
+
+=back
+
https://perl5.git.perl.org / perl5.git / blobdiff