xref: /openbsd/gnu/usr.bin/perl/lib/DB.pm (revision 17df1aa7) 
1#
2# Documentation is at the __END__
3#
4
5package DB;
6
7# "private" globals
8
9my ($running, $ready, $deep, $usrctxt, $evalarg,
10    @stack, @saved, @skippkg, @clients);
11my $preeval = {};
12my $posteval = {};
13my $ineval = {};
14
15####
16#
17# Globals - must be defined at startup so that clients can refer to
18# them right after a C<require DB;>
19#
20####
21
22BEGIN {
23
24  # these are hardcoded in perl source (some are magical)
25
26  $DB::sub = '';        # name of current subroutine
27  %DB::sub = ();        # "filename:fromline-toline" for every known sub
28  $DB::single = 0;      # single-step flag (set it to 1 to enable stops in BEGIN/use)
29  $DB::signal = 0;      # signal flag (will cause a stop at the next line)
30  $DB::trace = 0;       # are we tracing through subroutine calls?
31  @DB::args = ();       # arguments of current subroutine or @ARGV array
32  @DB::dbline = ();     # list of lines in currently loaded file
33  %DB::dbline = ();     # actions in current file (keyed by line number)
34  @DB::ret = ();        # return value of last sub executed in list context
35  $DB::ret = '';        # return value of last sub executed in scalar context
36
37  # other "public" globals
38
39  $DB::package = '';    # current package space
40  $DB::filename = '';   # current filename
41  $DB::subname = '';    # currently executing sub (fullly qualified name)
42  $DB::lineno = '';     # current line number
43
44  $DB::VERSION = $DB::VERSION = '1.02';
45
46  # initialize private globals to avoid warnings
47
48  $running = 1;         # are we running, or are we stopped?
49  @stack = (0);
50  @clients = ();
51  $deep = 100;
52  $ready = 0;
53  @saved = ();
54  @skippkg = ();
55  $usrctxt = '';
56  $evalarg = '';
57}
58
59####
60# entry point for all subroutine calls
61#
62sub sub {
63  push(@stack, $DB::single);
64  $DB::single &= 1;
65  $DB::single |= 4 if $#stack == $deep;
66  if ($DB::sub eq 'DESTROY' or substr($DB::sub, -9) eq '::DESTROY' or not defined wantarray) {
67    &$DB::sub;
68    $DB::single |= pop(@stack);
69    $DB::ret = undef;
70  }
71  elsif (wantarray) {
72    @DB::ret = &$DB::sub;
73    $DB::single |= pop(@stack);
74    @DB::ret;
75  }
76  else {
77    $DB::ret = &$DB::sub;
78    $DB::single |= pop(@stack);
79    $DB::ret;
80  }
81}
82
83####
84# this is called by perl for every statement
85#
86sub DB {
87  return unless $ready;
88  &save;
89  ($DB::package, $DB::filename, $DB::lineno) = caller;
90
91  return if @skippkg and grep { $_ eq $DB::package } @skippkg;
92
93  $usrctxt = "package $DB::package;";		# this won't let them modify, alas
94  local(*DB::dbline) = "::_<$DB::filename";
95
96  # we need to check for pseudofiles on Mac OS (these are files
97  # not attached to a filename, but instead stored in Dev:Pseudo)
98  # since this is done late, $DB::filename will be "wrong" after
99  # skippkg
100  if ($^O eq 'MacOS' && $#DB::dbline < 0) {
101    $DB::filename = 'Dev:Pseudo';
102    *DB::dbline = "::_<$DB::filename";
103  }
104
105  my ($stop, $action);
106  if (($stop,$action) = split(/\0/,$DB::dbline{$DB::lineno})) {
107    if ($stop eq '1') {
108      $DB::signal |= 1;
109    }
110    else {
111      $stop = 0 unless $stop;			# avoid un_init warning
112      $evalarg = "\$DB::signal |= do { $stop; }"; &eval;
113      $DB::dbline{$DB::lineno} =~ s/;9($|\0)/$1/;    # clear any temp breakpt
114    }
115  }
116  if ($DB::single || $DB::trace || $DB::signal) {
117    $DB::subname = ($DB::sub =~ /\'|::/) ? $DB::sub : "${DB::package}::$DB::sub"; #';
118    DB->loadfile($DB::filename, $DB::lineno);
119  }
120  $evalarg = $action, &eval if $action;
121  if ($DB::single || $DB::signal) {
122    _outputall($#stack . " levels deep in subroutine calls.\n") if $DB::single & 4;
123    $DB::single = 0;
124    $DB::signal = 0;
125    $running = 0;
126
127    &eval if ($evalarg = DB->prestop);
128    my $c;
129    for $c (@clients) {
130      # perform any client-specific prestop actions
131      &eval if ($evalarg = $c->cprestop);
132
133      # Now sit in an event loop until something sets $running
134      do {
135	$c->idle;                     # call client event loop; must not block
136	if ($running == 2) {          # client wants something eval-ed
137	  &eval if ($evalarg = $c->evalcode);
138	  $running = 0;
139	}
140      } until $running;
141
142      # perform any client-specific poststop actions
143      &eval if ($evalarg = $c->cpoststop);
144    }
145    &eval if ($evalarg = DB->poststop);
146  }
147  ($@, $!, $,, $/, $\, $^W) = @saved;
148  ();
149}
150
151####
152# this takes its argument via $evalarg to preserve current @_
153#
154sub eval {
155  ($@, $!, $,, $/, $\, $^W) = @saved;
156  eval "$usrctxt $evalarg; &DB::save";
157  _outputall($@) if $@;
158}
159
160###############################################################################
161#         no compile-time subroutine call allowed before this point           #
162###############################################################################
163
164use strict;                # this can run only after DB() and sub() are defined
165
166sub save {
167  @saved = ($@, $!, $,, $/, $\, $^W);
168  $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
169}
170
171sub catch {
172  for (@clients) { $_->awaken; }
173  $DB::signal = 1;
174  $ready = 1;
175}
176
177####
178#
179# Client callable (read inheritable) methods defined after this point
180#
181####
182
183sub register {
184  my $s = shift;
185  $s = _clientname($s) if ref($s);
186  push @clients, $s;
187}
188
189sub done {
190  my $s = shift;
191  $s = _clientname($s) if ref($s);
192  @clients = grep {$_ ne $s} @clients;
193  $s->cleanup;
194#  $running = 3 unless @clients;
195  exit(0) unless @clients;
196}
197
198sub _clientname {
199  my $name = shift;
200  "$name" =~ /^(.+)=[A-Z]+\(.+\)$/;
201  return $1;
202}
203
204sub next {
205  my $s = shift;
206  $DB::single = 2;
207  $running = 1;
208}
209
210sub step {
211  my $s = shift;
212  $DB::single = 1;
213  $running = 1;
214}
215
216sub cont {
217  my $s = shift;
218  my $i = shift;
219  $s->set_tbreak($i) if $i;
220  for ($i = 0; $i <= $#stack;) {
221	$stack[$i++] &= ~1;
222  }
223  $DB::single = 0;
224  $running = 1;
225}
226
227####
228# XXX caller must experimentally determine $i (since it depends
229# on how many client call frames are between this call and the DB call).
230# Such is life.
231#
232sub ret {
233  my $s = shift;
234  my $i = shift;      # how many levels to get to DB sub
235  $i = 0 unless defined $i;
236  $stack[$#stack-$i] |= 1;
237  $DB::single = 0;
238  $running = 1;
239}
240
241####
242# XXX caller must experimentally determine $start (since it depends
243# on how many client call frames are between this call and the DB call).
244# Such is life.
245#
246sub backtrace {
247  my $self = shift;
248  my $start = shift;
249  my($p,$f,$l,$s,$h,$w,$e,$r,$a, @a, @ret,$i);
250  $start = 1 unless $start;
251  for ($i = $start; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) {
252    @a = @DB::args;
253    for (@a) {
254      s/'/\\'/g;
255      s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
256      s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
257      s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
258    }
259    $w = $w ? '@ = ' : '$ = ';
260    $a = $h ? '(' . join(', ', @a) . ')' : '';
261    $e =~ s/\n\s*\;\s*\Z// if $e;
262    $e =~ s/[\\\']/\\$1/g if $e;
263    if ($r) {
264      $s = "require '$e'";
265    } elsif (defined $r) {
266      $s = "eval '$e'";
267    } elsif ($s eq '(eval)') {
268      $s = "eval {...}";
269    }
270    $f = "file `$f'" unless $f eq '-e';
271    push @ret, "$w&$s$a from $f line $l";
272    last if $DB::signal;
273  }
274  return @ret;
275}
276
277sub _outputall {
278  my $c;
279  for $c (@clients) {
280    $c->output(@_);
281  }
282}
283
284sub trace_toggle {
285  my $s = shift;
286  $DB::trace = !$DB::trace;
287}
288
289
290####
291# without args: returns all defined subroutine names
292# with subname args: returns a listref [file, start, end]
293#
294sub subs {
295  my $s = shift;
296  if (@_) {
297    my(@ret) = ();
298    while (@_) {
299      my $name = shift;
300      push @ret, [$DB::sub{$name} =~ /^(.*)\:(\d+)-(\d+)$/]
301	if exists $DB::sub{$name};
302    }
303    return @ret;
304  }
305  return keys %DB::sub;
306}
307
308####
309# first argument is a filename whose subs will be returned
310# if a filename is not supplied, all subs in the current
311# filename are returned.
312#
313sub filesubs {
314  my $s = shift;
315  my $fname = shift;
316  $fname = $DB::filename unless $fname;
317  return grep { $DB::sub{$_} =~ /^$fname/ } keys %DB::sub;
318}
319
320####
321# returns a list of all filenames that DB knows about
322#
323sub files {
324  my $s = shift;
325  my(@f) = grep(m|^_<|, keys %main::);
326  return map { substr($_,2) } @f;
327}
328
329####
330# returns reference to an array holding the lines in currently
331# loaded file
332#
333sub lines {
334  my $s = shift;
335  return \@DB::dbline;
336}
337
338####
339# loadfile($file, $line)
340#
341sub loadfile {
342  my $s = shift;
343  my($file, $line) = @_;
344  if (!defined $main::{'_<' . $file}) {
345    my $try;
346    if (($try) = grep(m|^_<.*$file|, keys %main::)) {
347      $file = substr($try,2);
348    }
349  }
350  if (defined($main::{'_<' . $file})) {
351    my $c;
352#    _outputall("Loading file $file..");
353    *DB::dbline = "::_<$file";
354    $DB::filename = $file;
355    for $c (@clients) {
356#      print "2 ", $file, '|', $line, "\n";
357      $c->showfile($file, $line);
358    }
359    return $file;
360  }
361  return undef;
362}
363
364sub lineevents {
365  my $s = shift;
366  my $fname = shift;
367  my(%ret) = ();
368  my $i;
369  $fname = $DB::filename unless $fname;
370  local(*DB::dbline) = "::_<$fname";
371  for ($i = 1; $i <= $#DB::dbline; $i++) {
372    $ret{$i} = [$DB::dbline[$i], split(/\0/, $DB::dbline{$i})]
373      if defined $DB::dbline{$i};
374  }
375  return %ret;
376}
377
378sub set_break {
379  my $s = shift;
380  my $i = shift;
381  my $cond = shift;
382  $i ||= $DB::lineno;
383  $cond ||= '1';
384  $i = _find_subline($i) if ($i =~ /\D/);
385  $s->output("Subroutine not found.\n") unless $i;
386  if ($i) {
387    if ($DB::dbline[$i] == 0) {
388      $s->output("Line $i not breakable.\n");
389    }
390    else {
391      $DB::dbline{$i} =~ s/^[^\0]*/$cond/;
392    }
393  }
394}
395
396sub set_tbreak {
397  my $s = shift;
398  my $i = shift;
399  $i = _find_subline($i) if ($i =~ /\D/);
400  $s->output("Subroutine not found.\n") unless $i;
401  if ($i) {
402    if ($DB::dbline[$i] == 0) {
403      $s->output("Line $i not breakable.\n");
404    }
405    else {
406      $DB::dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
407    }
408  }
409}
410
411sub _find_subline {
412  my $name = shift;
413  $name =~ s/\'/::/;
414  $name = "${DB::package}\:\:" . $name if $name !~ /::/;
415  $name = "main" . $name if substr($name,0,2) eq "::";
416  my($fname, $from, $to) = ($DB::sub{$name} =~ /^(.*):(\d+)-(\d+)$/);
417  if ($from) {
418    local *DB::dbline = "::_<$fname";
419    ++$from while $DB::dbline[$from] == 0 && $from < $to;
420    return $from;
421  }
422  return undef;
423}
424
425sub clr_breaks {
426  my $s = shift;
427  my $i;
428  if (@_) {
429    while (@_) {
430      $i = shift;
431      $i = _find_subline($i) if ($i =~ /\D/);
432      $s->output("Subroutine not found.\n") unless $i;
433      if (defined $DB::dbline{$i}) {
434        $DB::dbline{$i} =~ s/^[^\0]+//;
435        if ($DB::dbline{$i} =~ s/^\0?$//) {
436          delete $DB::dbline{$i};
437        }
438      }
439    }
440  }
441  else {
442    for ($i = 1; $i <= $#DB::dbline ; $i++) {
443      if (defined $DB::dbline{$i}) {
444        $DB::dbline{$i} =~ s/^[^\0]+//;
445        if ($DB::dbline{$i} =~ s/^\0?$//) {
446          delete $DB::dbline{$i};
447        }
448      }
449    }
450  }
451}
452
453sub set_action {
454  my $s = shift;
455  my $i = shift;
456  my $act = shift;
457  $i = _find_subline($i) if ($i =~ /\D/);
458  $s->output("Subroutine not found.\n") unless $i;
459  if ($i) {
460    if ($DB::dbline[$i] == 0) {
461      $s->output("Line $i not actionable.\n");
462    }
463    else {
464      $DB::dbline{$i} =~ s/\0[^\0]*//;
465      $DB::dbline{$i} .= "\0" . $act;
466    }
467  }
468}
469
470sub clr_actions {
471  my $s = shift;
472  my $i;
473  if (@_) {
474    while (@_) {
475      my $i = shift;
476      $i = _find_subline($i) if ($i =~ /\D/);
477      $s->output("Subroutine not found.\n") unless $i;
478      if ($i && $DB::dbline[$i] != 0) {
479	$DB::dbline{$i} =~ s/\0[^\0]*//;
480	delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//;
481      }
482    }
483  }
484  else {
485    for ($i = 1; $i <= $#DB::dbline ; $i++) {
486      if (defined $DB::dbline{$i}) {
487	$DB::dbline{$i} =~ s/\0[^\0]*//;
488	delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//;
489      }
490    }
491  }
492}
493
494sub prestop {
495  my ($client, $val) = @_;
496  return defined($val) ? $preeval->{$client} = $val : $preeval->{$client};
497}
498
499sub poststop {
500  my ($client, $val) = @_;
501  return defined($val) ? $posteval->{$client} = $val : $posteval->{$client};
502}
503
504#
505# "pure virtual" methods
506#
507
508# client-specific pre/post-stop actions.
509sub cprestop {}
510sub cpoststop {}
511
512# client complete startup
513sub awaken {}
514
515sub skippkg {
516  my $s = shift;
517  push @skippkg, @_ if @_;
518}
519
520sub evalcode {
521  my ($client, $val) = @_;
522  if (defined $val) {
523    $running = 2;    # hand over to DB() to evaluate in its context
524    $ineval->{$client} = $val;
525  }
526  return $ineval->{$client};
527}
528
529sub ready {
530  my $s = shift;
531  return $ready = 1;
532}
533
534# stubs
535
536sub init {}
537sub stop {}
538sub idle {}
539sub cleanup {}
540sub output {}
541
542#
543# client init
544#
545for (@clients) { $_->init }
546
547$SIG{'INT'} = \&DB::catch;
548
549# disable this if stepping through END blocks is desired
550# (looks scary and deconstructivist with Swat)
551END { $ready = 0 }
552
5531;
554__END__
555
556=head1 NAME
557
558DB - programmatic interface to the Perl debugging API
559
560=head1 SYNOPSIS
561
562    package CLIENT;
563    use DB;
564    @ISA = qw(DB);
565
566    # these (inherited) methods can be called by the client
567
568    CLIENT->register()      # register a client package name
569    CLIENT->done()          # de-register from the debugging API
570    CLIENT->skippkg('hide::hide')  # ask DB not to stop in this package
571    CLIENT->cont([WHERE])       # run some more (until BREAK or another breakpt)
572    CLIENT->step()              # single step
573    CLIENT->next()              # step over
574    CLIENT->ret()               # return from current subroutine
575    CLIENT->backtrace()         # return the call stack description
576    CLIENT->ready()             # call when client setup is done
577    CLIENT->trace_toggle()      # toggle subroutine call trace mode
578    CLIENT->subs([SUBS])        # return subroutine information
579    CLIENT->files()             # return list of all files known to DB
580    CLIENT->lines()             # return lines in currently loaded file
581    CLIENT->loadfile(FILE,LINE) # load a file and let other clients know
582    CLIENT->lineevents()        # return info on lines with actions
583    CLIENT->set_break([WHERE],[COND])
584    CLIENT->set_tbreak([WHERE])
585    CLIENT->clr_breaks([LIST])
586    CLIENT->set_action(WHERE,ACTION)
587    CLIENT->clr_actions([LIST])
588    CLIENT->evalcode(STRING)  # eval STRING in executing code's context
589    CLIENT->prestop([STRING]) # execute in code context before stopping
590    CLIENT->poststop([STRING])# execute in code context before resuming
591
592    # These methods will be called at the appropriate times.
593    # Stub versions provided do nothing.
594    # None of these can block.
595
596    CLIENT->init()          # called when debug API inits itself
597    CLIENT->stop(FILE,LINE) # when execution stops
598    CLIENT->idle()          # while stopped (can be a client event loop)
599    CLIENT->cleanup()       # just before exit
600    CLIENT->output(LIST)    # called to print any output that API must show
601
602=head1 DESCRIPTION
603
604Perl debug information is frequently required not just by debuggers,
605but also by modules that need some "special" information to do their
606job properly, like profilers.
607
608This module abstracts and provides all of the hooks into Perl internal
609debugging functionality, so that various implementations of Perl debuggers
610(or packages that want to simply get at the "privileged" debugging data)
611can all benefit from the development of this common code.  Currently used
612by Swat, the perl/Tk GUI debugger.
613
614Note that multiple "front-ends" can latch into this debugging API
615simultaneously.  This is intended to facilitate things like
616debugging with a command line and GUI at the same time, debugging
617debuggers etc.  [Sounds nice, but this needs some serious support -- GSAR]
618
619In particular, this API does B<not> provide the following functions:
620
621=over 4
622
623=item *
624
625data display
626
627=item *
628
629command processing
630
631=item *
632
633command alias management
634
635=item *
636
637user interface (tty or graphical)
638
639=back
640
641These are intended to be services performed by the clients of this API.
642
643This module attempts to be squeaky clean w.r.t C<use strict;> and when
644warnings are enabled.
645
646
647=head2 Global Variables
648
649The following "public" global names can be read by clients of this API.
650Beware that these should be considered "readonly".
651
652=over 8
653
654=item  $DB::sub
655
656Name of current executing subroutine.
657
658=item  %DB::sub
659
660The keys of this hash are the names of all the known subroutines.  Each value
661is an encoded string that has the sprintf(3) format
662C<("%s:%d-%d", filename, fromline, toline)>.
663
664=item  $DB::single
665
666Single-step flag.  Will be true if the API will stop at the next statement.
667
668=item  $DB::signal
669
670Signal flag. Will be set to a true value if a signal was caught.  Clients may
671check for this flag to abort time-consuming operations.
672
673=item  $DB::trace
674
675This flag is set to true if the API is tracing through subroutine calls.
676
677=item  @DB::args
678
679Contains the arguments of current subroutine, or the C<@ARGV> array if in the
680toplevel context.
681
682=item  @DB::dbline
683
684List of lines in currently loaded file.
685
686=item  %DB::dbline
687
688Actions in current file (keys are line numbers).  The values are strings that
689have the sprintf(3) format C<("%s\000%s", breakcondition, actioncode)>.
690
691=item  $DB::package
692
693Package namespace of currently executing code.
694
695=item  $DB::filename
696
697Currently loaded filename.
698
699=item  $DB::subname
700
701Fully qualified name of currently executing subroutine.
702
703=item  $DB::lineno
704
705Line number that will be executed next.
706
707=back
708
709=head2 API Methods
710
711The following are methods in the DB base class.  A client must
712access these methods by inheritance (*not* by calling them directly),
713since the API keeps track of clients through the inheritance
714mechanism.
715
716=over 8
717
718=item CLIENT->register()
719
720register a client object/package
721
722=item CLIENT->evalcode(STRING)
723
724eval STRING in executing code context
725
726=item CLIENT->skippkg('D::hide')
727
728ask DB not to stop in these packages
729
730=item CLIENT->run()
731
732run some more (until a breakpt is reached)
733
734=item CLIENT->step()
735
736single step
737
738=item CLIENT->next()
739
740step over
741
742=item CLIENT->done()
743
744de-register from the debugging API
745
746=back
747
748=head2 Client Callback Methods
749
750The following "virtual" methods can be defined by the client.  They will
751be called by the API at appropriate points.  Note that unless specified
752otherwise, the debug API only defines empty, non-functional default versions
753of these methods.
754
755=over 8
756
757=item CLIENT->init()
758
759Called after debug API inits itself.
760
761=item CLIENT->prestop([STRING])
762
763Usually inherited from DB package.  If no arguments are passed,
764returns the prestop action string.
765
766=item CLIENT->stop()
767
768Called when execution stops (w/ args file, line).
769
770=item CLIENT->idle()
771
772Called while stopped (can be a client event loop).
773
774=item CLIENT->poststop([STRING])
775
776Usually inherited from DB package.  If no arguments are passed,
777returns the poststop action string.
778
779=item CLIENT->evalcode(STRING)
780
781Usually inherited from DB package.  Ask for a STRING to be C<eval>-ed
782in executing code context.
783
784=item CLIENT->cleanup()
785
786Called just before exit.
787
788=item CLIENT->output(LIST)
789
790Called when API must show a message (warnings, errors etc.).
791
792
793=back
794
795
796=head1 BUGS
797
798The interface defined by this module is missing some of the later additions
799to perl's debugging functionality.  As such, this interface should be considered
800highly experimental and subject to change.
801
802=head1 AUTHOR
803
804Gurusamy Sarathy	gsar@activestate.com
805
806This code heavily adapted from an early version of perl5db.pl attributable
807to Larry Wall and the Perl Porters.
808
809=cut
810