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