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