Initial bulk commit for "Git on MSys"
[msysgit/historical-msysgit.git] / lib / perl5 / 5.6.1 / DB.pm
blob711acc085d12123a0a8ac547ab0bfb9d7f774cd4
2 # Documentation is at the __END__
5 package DB;
7 # "private" globals
9 my ($running, $ready, $deep, $usrctxt, $evalarg,
10 @stack, @saved, @skippkg, @clients);
11 my $preeval = {};
12 my $posteval = {};
13 my $ineval = {};
15 ####
17 # Globals - must be defined at startup so that clients can refer to
18 # them right after a C<require DB;>
20 ####
22 BEGIN {
24 # these are hardcoded in perl source (some are magical)
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
37 # other "public" globals
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
44 $DB::VERSION = $DB::VERSION = '1.0';
46 # initialize private globals to avoid warnings
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 = '';
59 ####
60 # entry point for all subroutine calls
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;
72 elsif (wantarray) {
73 @DB::ret = &$DB::sub;
74 $DB::single |= pop(@stack);
75 @DB::ret;
77 else {
78 $DB::ret = &$DB::sub;
79 $DB::single |= pop(@stack);
80 $DB::ret;
84 ####
85 # this is called by perl for every statement
87 sub DB {
88 return unless $ready;
89 &save;
90 ($DB::package, $DB::filename, $DB::lineno) = caller;
92 return if @skippkg and grep { $_ eq $DB::package } @skippkg;
94 $usrctxt = "package $DB::package;"; # this won't let them modify, alas
95 local(*DB::dbline) = "::_<$DB::filename";
96 my ($stop, $action);
97 if (($stop,$action) = split(/\0/,$DB::dbline{$DB::lineno})) {
98 if ($stop eq '1') {
99 $DB::signal |= 1;
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
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);
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;
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);
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;
131 } until $running;
133 # perform any client-specific poststop actions
134 &eval if ($evalarg = $c->cpoststop);
136 &eval if ($evalarg = DB->poststop);
138 ($@, $!, $,, $/, $\, $^W) = @saved;
142 ####
143 # this takes its argument via $evalarg to preserve current @_
145 sub eval {
146 ($@, $!, $,, $/, $\, $^W) = @saved;
147 eval "$usrctxt $evalarg; &DB::save";
148 _outputall($@) if $@;
151 ###############################################################################
152 # no compile-time subroutine call allowed before this point #
153 ###############################################################################
155 use strict; # this can run only after DB() and sub() are defined
157 sub save {
158 @saved = ($@, $!, $,, $/, $\, $^W);
159 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
162 sub catch {
163 for (@clients) { $_->awaken; }
164 $DB::signal = 1;
165 $ready = 1;
168 ####
170 # Client callable (read inheritable) methods defined after this point
172 ####
174 sub register {
175 my $s = shift;
176 $s = _clientname($s) if ref($s);
177 push @clients, $s;
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;
189 sub _clientname {
190 my $name = shift;
191 "$name" =~ /^(.+)=[A-Z]+\(.+\)$/;
192 return $1;
195 sub next {
196 my $s = shift;
197 $DB::single = 2;
198 $running = 1;
201 sub step {
202 my $s = shift;
203 $DB::single = 1;
204 $running = 1;
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;
214 $DB::single = 0;
215 $running = 1;
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.
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;
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.
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;
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 {...}";
261 $f = "file `$f'" unless $f eq '-e';
262 push @ret, "$w&$s$a from $f line $l";
263 last if $DB::signal;
265 return @ret;
268 sub _outputall {
269 my $c;
270 for $c (@clients) {
271 $c->output(@_);
275 sub trace_toggle {
276 my $s = shift;
277 $DB::trace = !$DB::trace;
281 ####
282 # without args: returns all defined subroutine names
283 # with subname args: returns a listref [file, start, end]
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};
294 return @ret;
296 return keys %DB::sub;
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.
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;
311 ####
312 # returns a list of all filenames that DB knows about
314 sub files {
315 my $s = shift;
316 my(@f) = grep(m|^_<|, keys %main::);
317 return map { substr($_,2) } @f;
320 ####
321 # returns reference to an array holding the lines in currently
322 # loaded file
324 sub lines {
325 my $s = shift;
326 return \@DB::dbline;
329 ####
330 # loadfile($file, $line)
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);
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);
350 return $file;
352 return undef;
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};
366 return %ret;
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");
381 else {
382 $DB::dbline{$i} =~ s/^[^\0]*/$cond/;
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");
396 else {
397 $DB::dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
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 # XXX this needs local()-ization of some sort
410 *DB::dbline = "::_<$fname";
411 ++$from while $DB::dbline[$from] == 0 && $from < $to;
412 return $from;
414 return undef;
417 sub clr_breaks {
418 my $s = shift;
419 my $i;
420 if (@_) {
421 while (@_) {
422 $i = shift;
423 $i = _find_subline($i) if ($i =~ /\D/);
424 $s->output("Subroutine not found.\n") unless $i;
425 if (defined $DB::dbline{$i}) {
426 $DB::dbline{$i} =~ s/^[^\0]+//;
427 if ($DB::dbline{$i} =~ s/^\0?$//) {
428 delete $DB::dbline{$i};
433 else {
434 for ($i = 1; $i <= $#DB::dbline ; $i++) {
435 if (defined $DB::dbline{$i}) {
436 $DB::dbline{$i} =~ s/^[^\0]+//;
437 if ($DB::dbline{$i} =~ s/^\0?$//) {
438 delete $DB::dbline{$i};
445 sub set_action {
446 my $s = shift;
447 my $i = shift;
448 my $act = shift;
449 $i = _find_subline($i) if ($i =~ /\D/);
450 $s->output("Subroutine not found.\n") unless $i;
451 if ($i) {
452 if ($DB::dbline[$i] == 0) {
453 $s->output("Line $i not actionable.\n");
455 else {
456 $DB::dbline{$i} =~ s/\0[^\0]*//;
457 $DB::dbline{$i} .= "\0" . $act;
462 sub clr_actions {
463 my $s = shift;
464 my $i;
465 if (@_) {
466 while (@_) {
467 my $i = shift;
468 $i = _find_subline($i) if ($i =~ /\D/);
469 $s->output("Subroutine not found.\n") unless $i;
470 if ($i && $DB::dbline[$i] != 0) {
471 $DB::dbline{$i} =~ s/\0[^\0]*//;
472 delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//;
476 else {
477 for ($i = 1; $i <= $#DB::dbline ; $i++) {
478 if (defined $DB::dbline{$i}) {
479 $DB::dbline{$i} =~ s/\0[^\0]*//;
480 delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//;
486 sub prestop {
487 my ($client, $val) = @_;
488 return defined($val) ? $preeval->{$client} = $val : $preeval->{$client};
491 sub poststop {
492 my ($client, $val) = @_;
493 return defined($val) ? $posteval->{$client} = $val : $posteval->{$client};
497 # "pure virtual" methods
500 # client-specific pre/post-stop actions.
501 sub cprestop {}
502 sub cpoststop {}
504 # client complete startup
505 sub awaken {}
507 sub skippkg {
508 my $s = shift;
509 push @skippkg, @_ if @_;
512 sub evalcode {
513 my ($client, $val) = @_;
514 if (defined $val) {
515 $running = 2; # hand over to DB() to evaluate in its context
516 $ineval->{$client} = $val;
518 return $ineval->{$client};
521 sub ready {
522 my $s = shift;
523 return $ready = 1;
526 # stubs
528 sub init {}
529 sub stop {}
530 sub idle {}
531 sub cleanup {}
532 sub output {}
535 # client init
537 for (@clients) { $_->init }
539 $SIG{'INT'} = \&DB::catch;
541 # disable this if stepping through END blocks is desired
542 # (looks scary and deconstructivist with Swat)
543 END { $ready = 0 }
546 __END__
548 =head1 NAME
550 DB - programmatic interface to the Perl debugging API (draft, subject to
551 change)
553 =head1 SYNOPSIS
555 package CLIENT;
556 use DB;
557 @ISA = qw(DB);
559 # these (inherited) methods can be called by the client
561 CLIENT->register() # register a client package name
562 CLIENT->done() # de-register from the debugging API
563 CLIENT->skippkg('hide::hide') # ask DB not to stop in this package
564 CLIENT->cont([WHERE]) # run some more (until BREAK or another breakpt)
565 CLIENT->step() # single step
566 CLIENT->next() # step over
567 CLIENT->ret() # return from current subroutine
568 CLIENT->backtrace() # return the call stack description
569 CLIENT->ready() # call when client setup is done
570 CLIENT->trace_toggle() # toggle subroutine call trace mode
571 CLIENT->subs([SUBS]) # return subroutine information
572 CLIENT->files() # return list of all files known to DB
573 CLIENT->lines() # return lines in currently loaded file
574 CLIENT->loadfile(FILE,LINE) # load a file and let other clients know
575 CLIENT->lineevents() # return info on lines with actions
576 CLIENT->set_break([WHERE],[COND])
577 CLIENT->set_tbreak([WHERE])
578 CLIENT->clr_breaks([LIST])
579 CLIENT->set_action(WHERE,ACTION)
580 CLIENT->clr_actions([LIST])
581 CLIENT->evalcode(STRING) # eval STRING in executing code's context
582 CLIENT->prestop([STRING]) # execute in code context before stopping
583 CLIENT->poststop([STRING])# execute in code context before resuming
585 # These methods will be called at the appropriate times.
586 # Stub versions provided do nothing.
587 # None of these can block.
589 CLIENT->init() # called when debug API inits itself
590 CLIENT->stop(FILE,LINE) # when execution stops
591 CLIENT->idle() # while stopped (can be a client event loop)
592 CLIENT->cleanup() # just before exit
593 CLIENT->output(LIST) # called to print any output that API must show
595 =head1 DESCRIPTION
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.
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.
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]
612 In particular, this API does B<not> provide the following functions:
614 =over 4
616 =item *
618 data display
620 =item *
622 command processing
624 =item *
626 command alias management
628 =item *
630 user interface (tty or graphical)
632 =back
634 These are intended to be services performed by the clients of this API.
636 This module attempts to be squeaky clean w.r.t C<use strict;> and when
637 warnings are enabled.
640 =head2 Global Variables
642 The following "public" global names can be read by clients of this API.
643 Beware that these should be considered "readonly".
645 =over 8
647 =item $DB::sub
649 Name of current executing subroutine.
651 =item %DB::sub
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)>.
657 =item $DB::single
659 Single-step flag. Will be true if the API will stop at the next statement.
661 =item $DB::signal
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.
666 =item $DB::trace
668 This flag is set to true if the API is tracing through subroutine calls.
670 =item @DB::args
672 Contains the arguments of current subroutine, or the C<@ARGV> array if in the
673 toplevel context.
675 =item @DB::dbline
677 List of lines in currently loaded file.
679 =item %DB::dbline
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)>.
684 =item $DB::package
686 Package namespace of currently executing code.
688 =item $DB::filename
690 Currently loaded filename.
692 =item $DB::subname
694 Fully qualified name of currently executing subroutine.
696 =item $DB::lineno
698 Line number that will be executed next.
700 =back
702 =head2 API Methods
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.
709 =over 8
711 =item CLIENT->register()
713 register a client object/package
715 =item CLIENT->evalcode(STRING)
717 eval STRING in executing code context
719 =item CLIENT->skippkg('D::hide')
721 ask DB not to stop in these packages
723 =item CLIENT->run()
725 run some more (until a breakpt is reached)
727 =item CLIENT->step()
729 single step
731 =item CLIENT->next()
733 step over
735 =item CLIENT->done()
737 de-register from the debugging API
739 =back
741 =head2 Client Callback Methods
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.
748 =over 8
750 =item CLIENT->init()
752 Called after debug API inits itself.
754 =item CLIENT->prestop([STRING])
756 Usually inherited from DB package. If no arguments are passed,
757 returns the prestop action string.
759 =item CLIENT->stop()
761 Called when execution stops (w/ args file, line).
763 =item CLIENT->idle()
765 Called while stopped (can be a client event loop).
767 =item CLIENT->poststop([STRING])
769 Usually inherited from DB package. If no arguments are passed,
770 returns the poststop action string.
772 =item CLIENT->evalcode(STRING)
774 Usually inherited from DB package. Ask for a STRING to be C<eval>-ed
775 in executing code context.
777 =item CLIENT->cleanup()
779 Called just before exit.
781 =item CLIENT->output(LIST)
783 Called when API must show a message (warnings, errors etc.).
786 =back
789 =head1 BUGS
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.
795 =head1 AUTHOR
797 Gurusamy Sarathy gsar@activestate.com
799 This code heavily adapted from an early version of perl5db.pl attributable
800 to Larry Wall and the Perl Porters.
802 =cut