our $TODO should be local $::TODO, revealing a bug in the de-commenting regexp.
[perl.git] / lib / DB.pm
1 #
2 # Documentation is at the __END__
3 #
4
5 package DB;
6
7 # "private" globals
8
9 my ($running, $ready, $deep, $usrctxt, $evalarg, 
10     @stack, @saved, @skippkg, @clients);
11 my $preeval = {};
12 my $posteval = {};
13 my $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
22 BEGIN {
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.01';
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 #
62 sub 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 #
86 sub 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 #    
154 sub 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
164 use strict;                # this can run only after DB() and sub() are defined
165
166 sub save {
167   @saved = ($@, $!, $,, $/, $\, $^W);
168   $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
169 }
170
171 sub 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
183 sub register {
184   my $s = shift;
185   $s = _clientname($s) if ref($s);
186   push @clients, $s;
187 }
188
189 sub 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
198 sub _clientname {
199   my $name = shift;
200   "$name" =~ /^(.+)=[A-Z]+\(.+\)$/;
201   return $1;
202 }
203
204 sub next {
205   my $s = shift;
206   $DB::single = 2;
207   $running = 1;
208 }
209
210 sub step {
211   my $s = shift;
212   $DB::single = 1;
213   $running = 1;
214 }
215
216 sub 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 #
232 sub 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 #
246 sub 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
277 sub _outputall {
278   my $c;
279   for $c (@clients) {
280     $c->output(@_);
281   }
282 }
283
284 sub 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 #
294 sub 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 #
313 sub 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 #
323 sub 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 #
333 sub lines {
334   my $s = shift;
335   return \@DB::dbline;
336 }
337
338 ####
339 # loadfile($file, $line)
340 #
341 sub 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
364 sub 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
378 sub 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
396 sub 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
411 sub _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
425 sub 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
453 sub 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
470 sub 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
494 sub prestop {
495   my ($client, $val) = @_;
496   return defined($val) ? $preeval->{$client} = $val : $preeval->{$client};
497 }
498
499 sub 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.
509 sub cprestop {}
510 sub cpoststop {}
511
512 # client complete startup
513 sub awaken {}
514
515 sub skippkg {
516   my $s = shift;
517   push @skippkg, @_ if @_;
518 }
519
520 sub 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
529 sub ready {
530   my $s = shift;
531   return $ready = 1;
532 }
533
534 # stubs
535     
536 sub init {}
537 sub stop {}
538 sub idle {}
539 sub cleanup {}
540 sub output {}
541
542 #
543 # client init
544 #
545 for (@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)
551 END { $ready = 0 }
552
553 1;
554 __END__
555
556 =head1 NAME
557
558 DB - 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
604 Perl debug information is frequently required not just by debuggers,
605 but also by modules that need some "special" information to do their
606 job properly, like profilers.
607
608 This module abstracts and provides all of the hooks into Perl internal
609 debugging functionality, so that various implementations of Perl debuggers
610 (or packages that want to simply get at the "privileged" debugging data)
611 can all benefit from the development of this common code.  Currently used
612 by Swat, the perl/Tk GUI debugger.
613
614 Note that multiple "front-ends" can latch into this debugging API
615 simultaneously.  This is intended to facilitate things like
616 debugging with a command line and GUI at the same time, debugging 
617 debuggers etc.  [Sounds nice, but this needs some serious support -- GSAR]
618
619 In particular, this API does B<not> provide the following functions:
620
621 =over 4
622
623 =item *
624
625 data display
626
627 =item *
628
629 command processing
630
631 =item *
632
633 command alias management
634
635 =item *
636
637 user interface (tty or graphical)
638
639 =back
640
641 These are intended to be services performed by the clients of this API.
642
643 This module attempts to be squeaky clean w.r.t C<use strict;> and when
644 warnings are enabled.
645
646
647 =head2 Global Variables
648
649 The following "public" global names can be read by clients of this API.
650 Beware that these should be considered "readonly".
651
652 =over 8
653
654 =item  $DB::sub
655
656 Name of current executing subroutine.
657
658 =item  %DB::sub
659
660 The keys of this hash are the names of all the known subroutines.  Each value
661 is an encoded string that has the sprintf(3) format 
662 C<("%s:%d-%d", filename, fromline, toline)>.
663
664 =item  $DB::single
665
666 Single-step flag.  Will be true if the API will stop at the next statement.
667
668 =item  $DB::signal
669
670 Signal flag. Will be set to a true value if a signal was caught.  Clients may
671 check for this flag to abort time-consuming operations.
672
673 =item  $DB::trace
674
675 This flag is set to true if the API is tracing through subroutine calls.
676
677 =item  @DB::args
678
679 Contains the arguments of current subroutine, or the C<@ARGV> array if in the 
680 toplevel context.
681
682 =item  @DB::dbline
683
684 List of lines in currently loaded file.
685
686 =item  %DB::dbline
687
688 Actions in current file (keys are line numbers).  The values are strings that
689 have the sprintf(3) format C<("%s\000%s", breakcondition, actioncode)>. 
690
691 =item  $DB::package
692
693 Package namespace of currently executing code.
694
695 =item  $DB::filename
696
697 Currently loaded filename.
698
699 =item  $DB::subname
700
701 Fully qualified name of currently executing subroutine.
702
703 =item  $DB::lineno
704
705 Line number that will be executed next.
706
707 =back
708
709 =head2 API Methods
710
711 The following are methods in the DB base class.  A client must
712 access these methods by inheritance (*not* by calling them directly),
713 since the API keeps track of clients through the inheritance
714 mechanism.
715
716 =over 8
717
718 =item CLIENT->register()
719
720 register a client object/package
721
722 =item CLIENT->evalcode(STRING)
723
724 eval STRING in executing code context
725
726 =item CLIENT->skippkg('D::hide')
727
728 ask DB not to stop in these packages
729
730 =item CLIENT->run()
731
732 run some more (until a breakpt is reached)
733
734 =item CLIENT->step()
735
736 single step
737
738 =item CLIENT->next()
739
740 step over
741
742 =item CLIENT->done()
743
744 de-register from the debugging API
745
746 =back
747
748 =head2 Client Callback Methods
749
750 The following "virtual" methods can be defined by the client.  They will
751 be called by the API at appropriate points.  Note that unless specified
752 otherwise, the debug API only defines empty, non-functional default versions
753 of these methods.
754
755 =over 8
756
757 =item CLIENT->init()
758
759 Called after debug API inits itself.
760
761 =item CLIENT->prestop([STRING])
762
763 Usually inherited from DB package.  If no arguments are passed,
764 returns the prestop action string.
765
766 =item CLIENT->stop()
767
768 Called when execution stops (w/ args file, line).
769
770 =item CLIENT->idle()
771
772 Called while stopped (can be a client event loop).
773
774 =item CLIENT->poststop([STRING])
775
776 Usually inherited from DB package.  If no arguments are passed,
777 returns the poststop action string.
778
779 =item CLIENT->evalcode(STRING)
780
781 Usually inherited from DB package.  Ask for a STRING to be C<eval>-ed
782 in executing code context.
783
784 =item CLIENT->cleanup()
785
786 Called just before exit.
787
788 =item CLIENT->output(LIST)
789
790 Called when API must show a message (warnings, errors etc.).
791
792
793 =back
794
795
796 =head1 BUGS
797
798 The interface defined by this module is missing some of the later additions
799 to perl's debugging functionality.  As such, this interface should be considered
800 highly experimental and subject to change.
801
802 =head1 AUTHOR
803
804 Gurusamy Sarathy        gsar@activestate.com
805
806 This code heavily adapted from an early version of perl5db.pl attributable
807 to Larry Wall and the Perl Porters.
808
809 =cut