Compare the wincred helper against its original in compat.
[msysgit.git] / lib / perl5 / 5.8.8 / DB.pm
bloba12bcd600c777a1259ec34f345d3625db83a56f0
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.01';
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 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;
71 elsif (wantarray) {
72 @DB::ret = &$DB::sub;
73 $DB::single |= pop(@stack);
74 @DB::ret;
76 else {
77 $DB::ret = &$DB::sub;
78 $DB::single |= pop(@stack);
79 $DB::ret;
83 ####
84 # this is called by perl for every statement
86 sub DB {
87 return unless $ready;
88 &save;
89 ($DB::package, $DB::filename, $DB::lineno) = caller;
91 return if @skippkg and grep { $_ eq $DB::package } @skippkg;
93 $usrctxt = "package $DB::package;"; # this won't let them modify, alas
94 local(*DB::dbline) = "::_<$DB::filename";
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";
105 my ($stop, $action);
106 if (($stop,$action) = split(/\0/,$DB::dbline{$DB::lineno})) {
107 if ($stop eq '1') {
108 $DB::signal |= 1;
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
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);
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;
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);
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;
140 } until $running;
142 # perform any client-specific poststop actions
143 &eval if ($evalarg = $c->cpoststop);
145 &eval if ($evalarg = DB->poststop);
147 ($@, $!, $,, $/, $\, $^W) = @saved;
151 ####
152 # this takes its argument via $evalarg to preserve current @_
154 sub eval {
155 ($@, $!, $,, $/, $\, $^W) = @saved;
156 eval "$usrctxt $evalarg; &DB::save";
157 _outputall($@) if $@;
160 ###############################################################################
161 # no compile-time subroutine call allowed before this point #
162 ###############################################################################
164 use strict; # this can run only after DB() and sub() are defined
166 sub save {
167 @saved = ($@, $!, $,, $/, $\, $^W);
168 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
171 sub catch {
172 for (@clients) { $_->awaken; }
173 $DB::signal = 1;
174 $ready = 1;
177 ####
179 # Client callable (read inheritable) methods defined after this point
181 ####
183 sub register {
184 my $s = shift;
185 $s = _clientname($s) if ref($s);
186 push @clients, $s;
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;
198 sub _clientname {
199 my $name = shift;
200 "$name" =~ /^(.+)=[A-Z]+\(.+\)$/;
201 return $1;
204 sub next {
205 my $s = shift;
206 $DB::single = 2;
207 $running = 1;
210 sub step {
211 my $s = shift;
212 $DB::single = 1;
213 $running = 1;
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;
223 $DB::single = 0;
224 $running = 1;
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.
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;
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.
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;
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 {...}";
270 $f = "file `$f'" unless $f eq '-e';
271 push @ret, "$w&$s$a from $f line $l";
272 last if $DB::signal;
274 return @ret;
277 sub _outputall {
278 my $c;
279 for $c (@clients) {
280 $c->output(@_);
284 sub trace_toggle {
285 my $s = shift;
286 $DB::trace = !$DB::trace;
290 ####
291 # without args: returns all defined subroutine names
292 # with subname args: returns a listref [file, start, end]
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};
303 return @ret;
305 return keys %DB::sub;
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.
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;
320 ####
321 # returns a list of all filenames that DB knows about
323 sub files {
324 my $s = shift;
325 my(@f) = grep(m|^_<|, keys %main::);
326 return map { substr($_,2) } @f;
329 ####
330 # returns reference to an array holding the lines in currently
331 # loaded file
333 sub lines {
334 my $s = shift;
335 return \@DB::dbline;
338 ####
339 # loadfile($file, $line)
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);
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);
359 return $file;
361 return undef;
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};
375 return %ret;
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");
390 else {
391 $DB::dbline{$i} =~ s/^[^\0]*/$cond/;
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");
405 else {
406 $DB::dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
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;
422 return undef;
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};
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};
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");
463 else {
464 $DB::dbline{$i} =~ s/\0[^\0]*//;
465 $DB::dbline{$i} .= "\0" . $act;
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?$//;
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?$//;
494 sub prestop {
495 my ($client, $val) = @_;
496 return defined($val) ? $preeval->{$client} = $val : $preeval->{$client};
499 sub poststop {
500 my ($client, $val) = @_;
501 return defined($val) ? $posteval->{$client} = $val : $posteval->{$client};
505 # "pure virtual" methods
508 # client-specific pre/post-stop actions.
509 sub cprestop {}
510 sub cpoststop {}
512 # client complete startup
513 sub awaken {}
515 sub skippkg {
516 my $s = shift;
517 push @skippkg, @_ if @_;
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;
526 return $ineval->{$client};
529 sub ready {
530 my $s = shift;
531 return $ready = 1;
534 # stubs
536 sub init {}
537 sub stop {}
538 sub idle {}
539 sub cleanup {}
540 sub output {}
543 # client init
545 for (@clients) { $_->init }
547 $SIG{'INT'} = \&DB::catch;
549 # disable this if stepping through END blocks is desired
550 # (looks scary and deconstructivist with Swat)
551 END { $ready = 0 }
554 __END__
556 =head1 NAME
558 DB - programmatic interface to the Perl debugging API (draft, subject to
559 change)
561 =head1 SYNOPSIS
563 package CLIENT;
564 use DB;
565 @ISA = qw(DB);
567 # these (inherited) methods can be called by the client
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
593 # These methods will be called at the appropriate times.
594 # Stub versions provided do nothing.
595 # None of these can block.
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
603 =head1 DESCRIPTION
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.
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.
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]
620 In particular, this API does B<not> provide the following functions:
622 =over 4
624 =item *
626 data display
628 =item *
630 command processing
632 =item *
634 command alias management
636 =item *
638 user interface (tty or graphical)
640 =back
642 These are intended to be services performed by the clients of this API.
644 This module attempts to be squeaky clean w.r.t C<use strict;> and when
645 warnings are enabled.
648 =head2 Global Variables
650 The following "public" global names can be read by clients of this API.
651 Beware that these should be considered "readonly".
653 =over 8
655 =item $DB::sub
657 Name of current executing subroutine.
659 =item %DB::sub
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)>.
665 =item $DB::single
667 Single-step flag. Will be true if the API will stop at the next statement.
669 =item $DB::signal
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.
674 =item $DB::trace
676 This flag is set to true if the API is tracing through subroutine calls.
678 =item @DB::args
680 Contains the arguments of current subroutine, or the C<@ARGV> array if in the
681 toplevel context.
683 =item @DB::dbline
685 List of lines in currently loaded file.
687 =item %DB::dbline
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)>.
692 =item $DB::package
694 Package namespace of currently executing code.
696 =item $DB::filename
698 Currently loaded filename.
700 =item $DB::subname
702 Fully qualified name of currently executing subroutine.
704 =item $DB::lineno
706 Line number that will be executed next.
708 =back
710 =head2 API Methods
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.
717 =over 8
719 =item CLIENT->register()
721 register a client object/package
723 =item CLIENT->evalcode(STRING)
725 eval STRING in executing code context
727 =item CLIENT->skippkg('D::hide')
729 ask DB not to stop in these packages
731 =item CLIENT->run()
733 run some more (until a breakpt is reached)
735 =item CLIENT->step()
737 single step
739 =item CLIENT->next()
741 step over
743 =item CLIENT->done()
745 de-register from the debugging API
747 =back
749 =head2 Client Callback Methods
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.
756 =over 8
758 =item CLIENT->init()
760 Called after debug API inits itself.
762 =item CLIENT->prestop([STRING])
764 Usually inherited from DB package. If no arguments are passed,
765 returns the prestop action string.
767 =item CLIENT->stop()
769 Called when execution stops (w/ args file, line).
771 =item CLIENT->idle()
773 Called while stopped (can be a client event loop).
775 =item CLIENT->poststop([STRING])
777 Usually inherited from DB package. If no arguments are passed,
778 returns the poststop action string.
780 =item CLIENT->evalcode(STRING)
782 Usually inherited from DB package. Ask for a STRING to be C<eval>-ed
783 in executing code context.
785 =item CLIENT->cleanup()
787 Called just before exit.
789 =item CLIENT->output(LIST)
791 Called when API must show a message (warnings, errors etc.).
794 =back
797 =head1 BUGS
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.
803 =head1 AUTHOR
805 Gurusamy Sarathy gsar@activestate.com
807 This code heavily adapted from an early version of perl5db.pl attributable
808 to Larry Wall and the Perl Porters.
810 =cut