Configure: Discard errors when testing for less -R
[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 (fully qualified name)
42   $DB::lineno = '';     # current line number
43
44   $DB::VERSION = $DB::VERSION = '1.07';
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 #
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   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 #    
145 sub 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
155 use strict;                # this can run only after DB() and sub() are defined
156
157 sub save {
158   @saved = ($@, $!, $,, $/, $\, $^W);
159   $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
160 }
161
162 sub 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
174 sub register {
175   my $s = shift;
176   $s = _clientname($s) if ref($s);
177   push @clients, $s;
178 }
179
180 sub 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
189 sub _clientname {
190   my $name = shift;
191   "$name" =~ /^(.+)=[A-Z]+\(.+\)$/;
192   return $1;
193 }
194
195 sub next {
196   my $s = shift;
197   $DB::single = 2;
198   $running = 1;
199 }
200
201 sub step {
202   my $s = shift;
203   $DB::single = 1;
204   $running = 1;
205 }
206
207 sub 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 #
223 sub 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 #
237 sub 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       s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
248       s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
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
268 sub _outputall {
269   my $c;
270   for $c (@clients) {
271     $c->output(@_);
272   }
273 }
274
275 sub 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 #
285 sub 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 #
304 sub 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 #
314 sub 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 #
324 sub lines {
325   my $s = shift;
326   return \@DB::dbline;
327 }
328
329 ####
330 # loadfile($file, $line)
331 #
332 sub 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
355 sub 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
369 sub 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
387 sub 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
402 sub _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
416 sub 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
444 sub 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
461 sub 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
485 sub prestop {
486   my ($client, $val) = @_;
487   return defined($val) ? $preeval->{$client} = $val : $preeval->{$client};
488 }
489
490 sub 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.
500 sub cprestop {}
501 sub cpoststop {}
502
503 # client complete startup
504 sub awaken {}
505
506 sub skippkg {
507   my $s = shift;
508   push @skippkg, @_ if @_;
509 }
510
511 sub 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
520 sub ready {
521   my $s = shift;
522   return $ready = 1;
523 }
524
525 # stubs
526     
527 sub init {}
528 sub stop {}
529 sub idle {}
530 sub cleanup {}
531 sub output {}
532
533 #
534 # client init
535 #
536 for (@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)
542 END { $ready = 0 }
543
544 1;
545 __END__
546
547 =head1 NAME
548
549 DB - 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
597 Perl debug information is frequently required not just by debuggers,
598 but also by modules that need some "special" information to do their
599 job properly, like profilers.
600
601 This module abstracts and provides all of the hooks into Perl internal
602 debugging functionality, so that various implementations of Perl debuggers
603 (or packages that want to simply get at the "privileged" debugging data)
604 can all benefit from the development of this common code.  Currently used
605 by Swat, the perl/Tk GUI debugger.
606
607 Note that multiple "front-ends" can latch into this debugging API
608 simultaneously.  This is intended to facilitate things like
609 debugging with a command line and GUI at the same time, debugging 
610 debuggers etc.  [Sounds nice, but this needs some serious support -- GSAR]
611
612 In particular, this API does B<not> provide the following functions:
613
614 =over 4
615
616 =item *
617
618 data display
619
620 =item *
621
622 command processing
623
624 =item *
625
626 command alias management
627
628 =item *
629
630 user interface (tty or graphical)
631
632 =back
633
634 These are intended to be services performed by the clients of this API.
635
636 This module attempts to be squeaky clean w.r.t C<use strict;> and when
637 warnings are enabled.
638
639
640 =head2 Global Variables
641
642 The following "public" global names can be read by clients of this API.
643 Beware that these should be considered "readonly".
644
645 =over 8
646
647 =item  $DB::sub
648
649 Name of current executing subroutine.
650
651 =item  %DB::sub
652
653 The keys of this hash are the names of all the known subroutines.  Each value
654 is an encoded string that has the sprintf(3) format 
655 C<("%s:%d-%d", filename, fromline, toline)>.
656
657 =item  $DB::single
658
659 Single-step flag.  Will be true if the API will stop at the next statement.
660
661 =item  $DB::signal
662
663 Signal flag. Will be set to a true value if a signal was caught.  Clients may
664 check for this flag to abort time-consuming operations.
665
666 =item  $DB::trace
667
668 This flag is set to true if the API is tracing through subroutine calls.
669
670 =item  @DB::args
671
672 Contains the arguments of current subroutine, or the C<@ARGV> array if in the 
673 toplevel context.
674
675 =item  @DB::dbline
676
677 List of lines in currently loaded file.
678
679 =item  %DB::dbline
680
681 Actions in current file (keys are line numbers).  The values are strings that
682 have the sprintf(3) format C<("%s\000%s", breakcondition, actioncode)>. 
683
684 =item  $DB::package
685
686 Package namespace of currently executing code.
687
688 =item  $DB::filename
689
690 Currently loaded filename.
691
692 =item  $DB::subname
693
694 Fully qualified name of currently executing subroutine.
695
696 =item  $DB::lineno
697
698 Line number that will be executed next.
699
700 =back
701
702 =head2 API Methods
703
704 The following are methods in the DB base class.  A client must
705 access these methods by inheritance (*not* by calling them directly),
706 since the API keeps track of clients through the inheritance
707 mechanism.
708
709 =over 8
710
711 =item CLIENT->register()
712
713 register a client object/package
714
715 =item CLIENT->evalcode(STRING)
716
717 eval STRING in executing code context
718
719 =item CLIENT->skippkg('D::hide')
720
721 ask DB not to stop in these packages
722
723 =item CLIENT->run()
724
725 run some more (until a breakpt is reached)
726
727 =item CLIENT->step()
728
729 single step
730
731 =item CLIENT->next()
732
733 step over
734
735 =item CLIENT->done()
736
737 de-register from the debugging API
738
739 =back
740
741 =head2 Client Callback Methods
742
743 The following "virtual" methods can be defined by the client.  They will
744 be called by the API at appropriate points.  Note that unless specified
745 otherwise, the debug API only defines empty, non-functional default versions
746 of these methods.
747
748 =over 8
749
750 =item CLIENT->init()
751
752 Called after debug API inits itself.
753
754 =item CLIENT->prestop([STRING])
755
756 Usually inherited from DB package.  If no arguments are passed,
757 returns the prestop action string.
758
759 =item CLIENT->stop()
760
761 Called when execution stops (w/ args file, line).
762
763 =item CLIENT->idle()
764
765 Called while stopped (can be a client event loop).
766
767 =item CLIENT->poststop([STRING])
768
769 Usually inherited from DB package.  If no arguments are passed,
770 returns the poststop action string.
771
772 =item CLIENT->evalcode(STRING)
773
774 Usually inherited from DB package.  Ask for a STRING to be C<eval>-ed
775 in executing code context.
776
777 =item CLIENT->cleanup()
778
779 Called just before exit.
780
781 =item CLIENT->output(LIST)
782
783 Called when API must show a message (warnings, errors etc.).
784
785
786 =back
787
788
789 =head1 BUGS
790
791 The interface defined by this module is missing some of the later additions
792 to perl's debugging functionality.  As such, this interface should be considered
793 highly experimental and subject to change.
794
795 =head1 AUTHOR
796
797 Gurusamy Sarathy        gsar@activestate.com
798
799 This code heavily adapted from an early version of perl5db.pl attributable
800 to Larry Wall and the Perl Porters.
801
802 =cut