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