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