1 | #
|
---|
2 | # Documentation is at the __END__
|
---|
3 | #
|
---|
4 |
|
---|
5 | package DB;
|
---|
6 |
|
---|
7 | # "private" globals
|
---|
8 |
|
---|
9 | my ($running, $ready, $deep, $usrctxt, $evalarg,
|
---|
10 | @stack, @saved, @skippkg, @clients);
|
---|
11 | my $preeval = {};
|
---|
12 | my $posteval = {};
|
---|
13 | my $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 |
|
---|
22 | BEGIN {
|
---|
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.01';
|
---|
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 | #
|
---|
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;
|
---|
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 | #
|
---|
86 | sub 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";
|
---|
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 |
|
---|
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 | #
|
---|
154 | sub 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 |
|
---|
164 | use strict; # this can run only after DB() and sub() are defined
|
---|
165 |
|
---|
166 | sub save {
|
---|
167 | @saved = ($@, $!, $,, $/, $\, $^W);
|
---|
168 | $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
|
---|
169 | }
|
---|
170 |
|
---|
171 | sub 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 |
|
---|
183 | sub register {
|
---|
184 | my $s = shift;
|
---|
185 | $s = _clientname($s) if ref($s);
|
---|
186 | push @clients, $s;
|
---|
187 | }
|
---|
188 |
|
---|
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;
|
---|
196 | }
|
---|
197 |
|
---|
198 | sub _clientname {
|
---|
199 | my $name = shift;
|
---|
200 | "$name" =~ /^(.+)=[A-Z]+\(.+\)$/;
|
---|
201 | return $1;
|
---|
202 | }
|
---|
203 |
|
---|
204 | sub next {
|
---|
205 | my $s = shift;
|
---|
206 | $DB::single = 2;
|
---|
207 | $running = 1;
|
---|
208 | }
|
---|
209 |
|
---|
210 | sub step {
|
---|
211 | my $s = shift;
|
---|
212 | $DB::single = 1;
|
---|
213 | $running = 1;
|
---|
214 | }
|
---|
215 |
|
---|
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;
|
---|
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 | #
|
---|
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;
|
---|
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 | #
|
---|
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;
|
---|
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 |
|
---|
277 | sub _outputall {
|
---|
278 | my $c;
|
---|
279 | for $c (@clients) {
|
---|
280 | $c->output(@_);
|
---|
281 | }
|
---|
282 | }
|
---|
283 |
|
---|
284 | sub 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 | #
|
---|
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};
|
---|
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 | #
|
---|
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;
|
---|
318 | }
|
---|
319 |
|
---|
320 | ####
|
---|
321 | # returns a list of all filenames that DB knows about
|
---|
322 | #
|
---|
323 | sub 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 | #
|
---|
333 | sub lines {
|
---|
334 | my $s = shift;
|
---|
335 | return \@DB::dbline;
|
---|
336 | }
|
---|
337 |
|
---|
338 | ####
|
---|
339 | # loadfile($file, $line)
|
---|
340 | #
|
---|
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);
|
---|
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 |
|
---|
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};
|
---|
374 | }
|
---|
375 | return %ret;
|
---|
376 | }
|
---|
377 |
|
---|
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");
|
---|
389 | }
|
---|
390 | else {
|
---|
391 | $DB::dbline{$i} =~ s/^[^\0]*/$cond/;
|
---|
392 | }
|
---|
393 | }
|
---|
394 | }
|
---|
395 |
|
---|
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");
|
---|
404 | }
|
---|
405 | else {
|
---|
406 | $DB::dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
|
---|
407 | }
|
---|
408 | }
|
---|
409 | }
|
---|
410 |
|
---|
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;
|
---|
421 | }
|
---|
422 | return undef;
|
---|
423 | }
|
---|
424 |
|
---|
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};
|
---|
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 |
|
---|
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");
|
---|
462 | }
|
---|
463 | else {
|
---|
464 | $DB::dbline{$i} =~ s/\0[^\0]*//;
|
---|
465 | $DB::dbline{$i} .= "\0" . $act;
|
---|
466 | }
|
---|
467 | }
|
---|
468 | }
|
---|
469 |
|
---|
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?$//;
|
---|
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 |
|
---|
494 | sub prestop {
|
---|
495 | my ($client, $val) = @_;
|
---|
496 | return defined($val) ? $preeval->{$client} = $val : $preeval->{$client};
|
---|
497 | }
|
---|
498 |
|
---|
499 | sub 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.
|
---|
509 | sub cprestop {}
|
---|
510 | sub cpoststop {}
|
---|
511 |
|
---|
512 | # client complete startup
|
---|
513 | sub awaken {}
|
---|
514 |
|
---|
515 | sub skippkg {
|
---|
516 | my $s = shift;
|
---|
517 | push @skippkg, @_ if @_;
|
---|
518 | }
|
---|
519 |
|
---|
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;
|
---|
525 | }
|
---|
526 | return $ineval->{$client};
|
---|
527 | }
|
---|
528 |
|
---|
529 | sub ready {
|
---|
530 | my $s = shift;
|
---|
531 | return $ready = 1;
|
---|
532 | }
|
---|
533 |
|
---|
534 | # stubs
|
---|
535 |
|
---|
536 | sub init {}
|
---|
537 | sub stop {}
|
---|
538 | sub idle {}
|
---|
539 | sub cleanup {}
|
---|
540 | sub output {}
|
---|
541 |
|
---|
542 | #
|
---|
543 | # client init
|
---|
544 | #
|
---|
545 | for (@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)
|
---|
551 | END { $ready = 0 }
|
---|
552 |
|
---|
553 | 1;
|
---|
554 | __END__
|
---|
555 |
|
---|
556 | =head1 NAME
|
---|
557 |
|
---|
558 | DB - programmatic interface to the Perl debugging API (draft, subject to
|
---|
559 | change)
|
---|
560 |
|
---|
561 | =head1 SYNOPSIS
|
---|
562 |
|
---|
563 | package CLIENT;
|
---|
564 | use DB;
|
---|
565 | @ISA = qw(DB);
|
---|
566 |
|
---|
567 | # these (inherited) methods can be called by the client
|
---|
568 |
|
---|
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
|
---|
592 |
|
---|
593 | # These methods will be called at the appropriate times.
|
---|
594 | # Stub versions provided do nothing.
|
---|
595 | # None of these can block.
|
---|
596 |
|
---|
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
|
---|
602 |
|
---|
603 | =head1 DESCRIPTION
|
---|
604 |
|
---|
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.
|
---|
608 |
|
---|
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.
|
---|
614 |
|
---|
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]
|
---|
619 |
|
---|
620 | In particular, this API does B<not> provide the following functions:
|
---|
621 |
|
---|
622 | =over 4
|
---|
623 |
|
---|
624 | =item *
|
---|
625 |
|
---|
626 | data display
|
---|
627 |
|
---|
628 | =item *
|
---|
629 |
|
---|
630 | command processing
|
---|
631 |
|
---|
632 | =item *
|
---|
633 |
|
---|
634 | command alias management
|
---|
635 |
|
---|
636 | =item *
|
---|
637 |
|
---|
638 | user interface (tty or graphical)
|
---|
639 |
|
---|
640 | =back
|
---|
641 |
|
---|
642 | These are intended to be services performed by the clients of this API.
|
---|
643 |
|
---|
644 | This module attempts to be squeaky clean w.r.t C<use strict;> and when
|
---|
645 | warnings are enabled.
|
---|
646 |
|
---|
647 |
|
---|
648 | =head2 Global Variables
|
---|
649 |
|
---|
650 | The following "public" global names can be read by clients of this API.
|
---|
651 | Beware that these should be considered "readonly".
|
---|
652 |
|
---|
653 | =over 8
|
---|
654 |
|
---|
655 | =item $DB::sub
|
---|
656 |
|
---|
657 | Name of current executing subroutine.
|
---|
658 |
|
---|
659 | =item %DB::sub
|
---|
660 |
|
---|
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)>.
|
---|
664 |
|
---|
665 | =item $DB::single
|
---|
666 |
|
---|
667 | Single-step flag. Will be true if the API will stop at the next statement.
|
---|
668 |
|
---|
669 | =item $DB::signal
|
---|
670 |
|
---|
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.
|
---|
673 |
|
---|
674 | =item $DB::trace
|
---|
675 |
|
---|
676 | This flag is set to true if the API is tracing through subroutine calls.
|
---|
677 |
|
---|
678 | =item @DB::args
|
---|
679 |
|
---|
680 | Contains the arguments of current subroutine, or the C<@ARGV> array if in the
|
---|
681 | toplevel context.
|
---|
682 |
|
---|
683 | =item @DB::dbline
|
---|
684 |
|
---|
685 | List of lines in currently loaded file.
|
---|
686 |
|
---|
687 | =item %DB::dbline
|
---|
688 |
|
---|
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)>.
|
---|
691 |
|
---|
692 | =item $DB::package
|
---|
693 |
|
---|
694 | Package namespace of currently executing code.
|
---|
695 |
|
---|
696 | =item $DB::filename
|
---|
697 |
|
---|
698 | Currently loaded filename.
|
---|
699 |
|
---|
700 | =item $DB::subname
|
---|
701 |
|
---|
702 | Fully qualified name of currently executing subroutine.
|
---|
703 |
|
---|
704 | =item $DB::lineno
|
---|
705 |
|
---|
706 | Line number that will be executed next.
|
---|
707 |
|
---|
708 | =back
|
---|
709 |
|
---|
710 | =head2 API Methods
|
---|
711 |
|
---|
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.
|
---|
716 |
|
---|
717 | =over 8
|
---|
718 |
|
---|
719 | =item CLIENT->register()
|
---|
720 |
|
---|
721 | register a client object/package
|
---|
722 |
|
---|
723 | =item CLIENT->evalcode(STRING)
|
---|
724 |
|
---|
725 | eval STRING in executing code context
|
---|
726 |
|
---|
727 | =item CLIENT->skippkg('D::hide')
|
---|
728 |
|
---|
729 | ask DB not to stop in these packages
|
---|
730 |
|
---|
731 | =item CLIENT->run()
|
---|
732 |
|
---|
733 | run some more (until a breakpt is reached)
|
---|
734 |
|
---|
735 | =item CLIENT->step()
|
---|
736 |
|
---|
737 | single step
|
---|
738 |
|
---|
739 | =item CLIENT->next()
|
---|
740 |
|
---|
741 | step over
|
---|
742 |
|
---|
743 | =item CLIENT->done()
|
---|
744 |
|
---|
745 | de-register from the debugging API
|
---|
746 |
|
---|
747 | =back
|
---|
748 |
|
---|
749 | =head2 Client Callback Methods
|
---|
750 |
|
---|
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.
|
---|
755 |
|
---|
756 | =over 8
|
---|
757 |
|
---|
758 | =item CLIENT->init()
|
---|
759 |
|
---|
760 | Called after debug API inits itself.
|
---|
761 |
|
---|
762 | =item CLIENT->prestop([STRING])
|
---|
763 |
|
---|
764 | Usually inherited from DB package. If no arguments are passed,
|
---|
765 | returns the prestop action string.
|
---|
766 |
|
---|
767 | =item CLIENT->stop()
|
---|
768 |
|
---|
769 | Called when execution stops (w/ args file, line).
|
---|
770 |
|
---|
771 | =item CLIENT->idle()
|
---|
772 |
|
---|
773 | Called while stopped (can be a client event loop).
|
---|
774 |
|
---|
775 | =item CLIENT->poststop([STRING])
|
---|
776 |
|
---|
777 | Usually inherited from DB package. If no arguments are passed,
|
---|
778 | returns the poststop action string.
|
---|
779 |
|
---|
780 | =item CLIENT->evalcode(STRING)
|
---|
781 |
|
---|
782 | Usually inherited from DB package. Ask for a STRING to be C<eval>-ed
|
---|
783 | in executing code context.
|
---|
784 |
|
---|
785 | =item CLIENT->cleanup()
|
---|
786 |
|
---|
787 | Called just before exit.
|
---|
788 |
|
---|
789 | =item CLIENT->output(LIST)
|
---|
790 |
|
---|
791 | Called when API must show a message (warnings, errors etc.).
|
---|
792 |
|
---|
793 |
|
---|
794 | =back
|
---|
795 |
|
---|
796 |
|
---|
797 | =head1 BUGS
|
---|
798 |
|
---|
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.
|
---|
802 |
|
---|
803 | =head1 AUTHOR
|
---|
804 |
|
---|
805 | Gurusamy Sarathy [email protected]
|
---|
806 |
|
---|
807 | This code heavily adapted from an early version of perl5db.pl attributable
|
---|
808 | to Larry Wall and the Perl Porters.
|
---|
809 |
|
---|
810 | =cut
|
---|