RE: Combining UTF-16 output with :crlf is awkward
[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 (draft, subject to
559 change)
560
561 =head1 SYNOPSIS
562
563     package CLIENT;
564     use DB;
565     @ISA = qw(DB);
566
567     # these (inherited) methods can be called by the client
568
569     CLIENT->register()      # register a client package name
570     CLIENT->done()          # de-register from the debugging API
571     CLIENT->skippkg('hide::hide')  # ask DB not to stop in this package
572     CLIENT->cont([WHERE])       # run some more (until BREAK or another breakpt)
573     CLIENT->step()              # single step
574     CLIENT->next()              # step over
575     CLIENT->ret()               # return from current subroutine
576     CLIENT->backtrace()         # return the call stack description
577     CLIENT->ready()             # call when client setup is done
578     CLIENT->trace_toggle()      # toggle subroutine call trace mode
579     CLIENT->subs([SUBS])        # return subroutine information
580     CLIENT->files()             # return list of all files known to DB
581     CLIENT->lines()             # return lines in currently loaded file
582     CLIENT->loadfile(FILE,LINE) # load a file and let other clients know
583     CLIENT->lineevents()        # return info on lines with actions
584     CLIENT->set_break([WHERE],[COND])
585     CLIENT->set_tbreak([WHERE])
586     CLIENT->clr_breaks([LIST])
587     CLIENT->set_action(WHERE,ACTION)
588     CLIENT->clr_actions([LIST])
589     CLIENT->evalcode(STRING)  # eval STRING in executing code's context
590     CLIENT->prestop([STRING]) # execute in code context before stopping
591     CLIENT->poststop([STRING])# execute in code context before resuming
592
593     # These methods will be called at the appropriate times.
594     # Stub versions provided do nothing.
595     # None of these can block.
596
597     CLIENT->init()          # called when debug API inits itself
598     CLIENT->stop(FILE,LINE) # when execution stops
599     CLIENT->idle()          # while stopped (can be a client event loop)
600     CLIENT->cleanup()       # just before exit
601     CLIENT->output(LIST)    # called to print any output that API must show
602
603 =head1 DESCRIPTION
604
605 Perl debug information is frequently required not just by debuggers,
606 but also by modules that need some "special" information to do their
607 job properly, like profilers.
608
609 This module abstracts and provides all of the hooks into Perl internal
610 debugging functionality, so that various implementations of Perl debuggers
611 (or packages that want to simply get at the "privileged" debugging data)
612 can all benefit from the development of this common code.  Currently used
613 by Swat, the perl/Tk GUI debugger.
614
615 Note that multiple "front-ends" can latch into this debugging API
616 simultaneously.  This is intended to facilitate things like
617 debugging with a command line and GUI at the same time, debugging 
618 debuggers etc.  [Sounds nice, but this needs some serious support -- GSAR]
619
620 In particular, this API does B<not> provide the following functions:
621
622 =over 4
623
624 =item *
625
626 data display
627
628 =item *
629
630 command processing
631
632 =item *
633
634 command alias management
635
636 =item *
637
638 user interface (tty or graphical)
639
640 =back
641
642 These are intended to be services performed by the clients of this API.
643
644 This module attempts to be squeaky clean w.r.t C<use strict;> and when
645 warnings are enabled.
646
647
648 =head2 Global Variables
649
650 The following "public" global names can be read by clients of this API.
651 Beware that these should be considered "readonly".
652
653 =over 8
654
655 =item  $DB::sub
656
657 Name of current executing subroutine.
658
659 =item  %DB::sub
660
661 The keys of this hash are the names of all the known subroutines.  Each value
662 is an encoded string that has the sprintf(3) format 
663 C<("%s:%d-%d", filename, fromline, toline)>.
664
665 =item  $DB::single
666
667 Single-step flag.  Will be true if the API will stop at the next statement.
668
669 =item  $DB::signal
670
671 Signal flag. Will be set to a true value if a signal was caught.  Clients may
672 check for this flag to abort time-consuming operations.
673
674 =item  $DB::trace
675
676 This flag is set to true if the API is tracing through subroutine calls.
677
678 =item  @DB::args
679
680 Contains the arguments of current subroutine, or the C<@ARGV> array if in the 
681 toplevel context.
682
683 =item  @DB::dbline
684
685 List of lines in currently loaded file.
686
687 =item  %DB::dbline
688
689 Actions in current file (keys are line numbers).  The values are strings that
690 have the sprintf(3) format C<("%s\000%s", breakcondition, actioncode)>. 
691
692 =item  $DB::package
693
694 Package namespace of currently executing code.
695
696 =item  $DB::filename
697
698 Currently loaded filename.
699
700 =item  $DB::subname
701
702 Fully qualified name of currently executing subroutine.
703
704 =item  $DB::lineno
705
706 Line number that will be executed next.
707
708 =back
709
710 =head2 API Methods
711
712 The following are methods in the DB base class.  A client must
713 access these methods by inheritance (*not* by calling them directly),
714 since the API keeps track of clients through the inheritance
715 mechanism.
716
717 =over 8
718
719 =item CLIENT->register()
720
721 register a client object/package
722
723 =item CLIENT->evalcode(STRING)
724
725 eval STRING in executing code context
726
727 =item CLIENT->skippkg('D::hide')
728
729 ask DB not to stop in these packages
730
731 =item CLIENT->run()
732
733 run some more (until a breakpt is reached)
734
735 =item CLIENT->step()
736
737 single step
738
739 =item CLIENT->next()
740
741 step over
742
743 =item CLIENT->done()
744
745 de-register from the debugging API
746
747 =back
748
749 =head2 Client Callback Methods
750
751 The following "virtual" methods can be defined by the client.  They will
752 be called by the API at appropriate points.  Note that unless specified
753 otherwise, the debug API only defines empty, non-functional default versions
754 of these methods.
755
756 =over 8
757
758 =item CLIENT->init()
759
760 Called after debug API inits itself.
761
762 =item CLIENT->prestop([STRING])
763
764 Usually inherited from DB package.  If no arguments are passed,
765 returns the prestop action string.
766
767 =item CLIENT->stop()
768
769 Called when execution stops (w/ args file, line).
770
771 =item CLIENT->idle()
772
773 Called while stopped (can be a client event loop).
774
775 =item CLIENT->poststop([STRING])
776
777 Usually inherited from DB package.  If no arguments are passed,
778 returns the poststop action string.
779
780 =item CLIENT->evalcode(STRING)
781
782 Usually inherited from DB package.  Ask for a STRING to be C<eval>-ed
783 in executing code context.
784
785 =item CLIENT->cleanup()
786
787 Called just before exit.
788
789 =item CLIENT->output(LIST)
790
791 Called when API must show a message (warnings, errors etc.).
792
793
794 =back
795
796
797 =head1 BUGS
798
799 The interface defined by this module is missing some of the later additions
800 to perl's debugging functionality.  As such, this interface should be considered
801 highly experimental and subject to change.
802
803 =head1 AUTHOR
804
805 Gurusamy Sarathy        gsar@activestate.com
806
807 This code heavily adapted from an early version of perl5db.pl attributable
808 to Larry Wall and the Perl Porters.
809
810 =cut