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