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