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.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 | # |
---|
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; |
---|
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 | # |
---|
87 | sub 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"; |
---|
96 | my ($stop, $action); |
---|
97 | if (($stop,$action) = split(/\0/,$DB::dbline{$DB::lineno})) { |
---|
98 | if ($stop eq '1') { |
---|
99 | $DB::signal |= 1; |
---|
100 | } |
---|
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 |
---|
105 | } |
---|
106 | } |
---|
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); |
---|
110 | } |
---|
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; |
---|
117 | |
---|
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); |
---|
123 | |
---|
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; |
---|
130 | } |
---|
131 | } until $running; |
---|
132 | |
---|
133 | # perform any client-specific poststop actions |
---|
134 | &eval if ($evalarg = $c->cpoststop); |
---|
135 | } |
---|
136 | &eval if ($evalarg = DB->poststop); |
---|
137 | } |
---|
138 | ($@, $!, $,, $/, $\, $^W) = @saved; |
---|
139 | (); |
---|
140 | } |
---|
141 | |
---|
142 | #### |
---|
143 | # this takes its argument via $evalarg to preserve current @_ |
---|
144 | # |
---|
145 | sub eval { |
---|
146 | ($@, $!, $,, $/, $\, $^W) = @saved; |
---|
147 | eval "$usrctxt $evalarg; &DB::save"; |
---|
148 | _outputall($@) if $@; |
---|
149 | } |
---|
150 | |
---|
151 | ############################################################################### |
---|
152 | # no compile-time subroutine call allowed before this point # |
---|
153 | ############################################################################### |
---|
154 | |
---|
155 | use strict; # this can run only after DB() and sub() are defined |
---|
156 | |
---|
157 | sub save { |
---|
158 | @saved = ($@, $!, $,, $/, $\, $^W); |
---|
159 | $, = ""; $/ = "\n"; $\ = ""; $^W = 0; |
---|
160 | } |
---|
161 | |
---|
162 | sub catch { |
---|
163 | for (@clients) { $_->awaken; } |
---|
164 | $DB::signal = 1; |
---|
165 | $ready = 1; |
---|
166 | } |
---|
167 | |
---|
168 | #### |
---|
169 | # |
---|
170 | # Client callable (read inheritable) methods defined after this point |
---|
171 | # |
---|
172 | #### |
---|
173 | |
---|
174 | sub register { |
---|
175 | my $s = shift; |
---|
176 | $s = _clientname($s) if ref($s); |
---|
177 | push @clients, $s; |
---|
178 | } |
---|
179 | |
---|
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; |
---|
187 | } |
---|
188 | |
---|
189 | sub _clientname { |
---|
190 | my $name = shift; |
---|
191 | "$name" =~ /^(.+)=[A-Z]+\(.+\)$/; |
---|
192 | return $1; |
---|
193 | } |
---|
194 | |
---|
195 | sub next { |
---|
196 | my $s = shift; |
---|
197 | $DB::single = 2; |
---|
198 | $running = 1; |
---|
199 | } |
---|
200 | |
---|
201 | sub step { |
---|
202 | my $s = shift; |
---|
203 | $DB::single = 1; |
---|
204 | $running = 1; |
---|
205 | } |
---|
206 | |
---|
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; |
---|
213 | } |
---|
214 | $DB::single = 0; |
---|
215 | $running = 1; |
---|
216 | } |
---|
217 | |
---|
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. |
---|
222 | # |
---|
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; |
---|
230 | } |
---|
231 | |
---|
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. |
---|
236 | # |
---|
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; |
---|
249 | } |
---|
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 {...}"; |
---|
260 | } |
---|
261 | $f = "file `$f'" unless $f eq '-e'; |
---|
262 | push @ret, "$w&$s$a from $f line $l"; |
---|
263 | last if $DB::signal; |
---|
264 | } |
---|
265 | return @ret; |
---|
266 | } |
---|
267 | |
---|
268 | sub _outputall { |
---|
269 | my $c; |
---|
270 | for $c (@clients) { |
---|
271 | $c->output(@_); |
---|
272 | } |
---|
273 | } |
---|
274 | |
---|
275 | sub trace_toggle { |
---|
276 | my $s = shift; |
---|
277 | $DB::trace = !$DB::trace; |
---|
278 | } |
---|
279 | |
---|
280 | |
---|
281 | #### |
---|
282 | # without args: returns all defined subroutine names |
---|
283 | # with subname args: returns a listref [file, start, end] |
---|
284 | # |
---|
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}; |
---|
293 | } |
---|
294 | return @ret; |
---|
295 | } |
---|
296 | return keys %DB::sub; |
---|
297 | } |
---|
298 | |
---|
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. |
---|
303 | # |
---|
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; |
---|
309 | } |
---|
310 | |
---|
311 | #### |
---|
312 | # returns a list of all filenames that DB knows about |
---|
313 | # |
---|
314 | sub files { |
---|
315 | my $s = shift; |
---|
316 | my(@f) = grep(m|^_<|, keys %main::); |
---|
317 | return map { substr($_,2) } @f; |
---|
318 | } |
---|
319 | |
---|
320 | #### |
---|
321 | # returns reference to an array holding the lines in currently |
---|
322 | # loaded file |
---|
323 | # |
---|
324 | sub lines { |
---|
325 | my $s = shift; |
---|
326 | return \@DB::dbline; |
---|
327 | } |
---|
328 | |
---|
329 | #### |
---|
330 | # loadfile($file, $line) |
---|
331 | # |
---|
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); |
---|
339 | } |
---|
340 | } |
---|
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); |
---|
349 | } |
---|
350 | return $file; |
---|
351 | } |
---|
352 | return undef; |
---|
353 | } |
---|
354 | |
---|
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}; |
---|
365 | } |
---|
366 | return %ret; |
---|
367 | } |
---|
368 | |
---|
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"); |
---|
380 | } |
---|
381 | else { |
---|
382 | $DB::dbline{$i} =~ s/^[^\0]*/$cond/; |
---|
383 | } |
---|
384 | } |
---|
385 | } |
---|
386 | |
---|
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"); |
---|
395 | } |
---|
396 | else { |
---|
397 | $DB::dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p. |
---|
398 | } |
---|
399 | } |
---|
400 | } |
---|
401 | |
---|
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; |
---|
413 | } |
---|
414 | return undef; |
---|
415 | } |
---|
416 | |
---|
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}; |
---|
429 | } |
---|
430 | } |
---|
431 | } |
---|
432 | } |
---|
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}; |
---|
439 | } |
---|
440 | } |
---|
441 | } |
---|
442 | } |
---|
443 | } |
---|
444 | |
---|
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"); |
---|
454 | } |
---|
455 | else { |
---|
456 | $DB::dbline{$i} =~ s/\0[^\0]*//; |
---|
457 | $DB::dbline{$i} .= "\0" . $act; |
---|
458 | } |
---|
459 | } |
---|
460 | } |
---|
461 | |
---|
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?$//; |
---|
473 | } |
---|
474 | } |
---|
475 | } |
---|
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?$//; |
---|
481 | } |
---|
482 | } |
---|
483 | } |
---|
484 | } |
---|
485 | |
---|
486 | sub prestop { |
---|
487 | my ($client, $val) = @_; |
---|
488 | return defined($val) ? $preeval->{$client} = $val : $preeval->{$client}; |
---|
489 | } |
---|
490 | |
---|
491 | sub poststop { |
---|
492 | my ($client, $val) = @_; |
---|
493 | return defined($val) ? $posteval->{$client} = $val : $posteval->{$client}; |
---|
494 | } |
---|
495 | |
---|
496 | # |
---|
497 | # "pure virtual" methods |
---|
498 | # |
---|
499 | |
---|
500 | # client-specific pre/post-stop actions. |
---|
501 | sub cprestop {} |
---|
502 | sub cpoststop {} |
---|
503 | |
---|
504 | # client complete startup |
---|
505 | sub awaken {} |
---|
506 | |
---|
507 | sub skippkg { |
---|
508 | my $s = shift; |
---|
509 | push @skippkg, @_ if @_; |
---|
510 | } |
---|
511 | |
---|
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; |
---|
517 | } |
---|
518 | return $ineval->{$client}; |
---|
519 | } |
---|
520 | |
---|
521 | sub ready { |
---|
522 | my $s = shift; |
---|
523 | return $ready = 1; |
---|
524 | } |
---|
525 | |
---|
526 | # stubs |
---|
527 | |
---|
528 | sub init {} |
---|
529 | sub stop {} |
---|
530 | sub idle {} |
---|
531 | sub cleanup {} |
---|
532 | sub output {} |
---|
533 | |
---|
534 | # |
---|
535 | # client init |
---|
536 | # |
---|
537 | for (@clients) { $_->init } |
---|
538 | |
---|
539 | $SIG{'INT'} = \&DB::catch; |
---|
540 | |
---|
541 | # disable this if stepping through END blocks is desired |
---|
542 | # (looks scary and deconstructivist with Swat) |
---|
543 | END { $ready = 0 } |
---|
544 | |
---|
545 | 1; |
---|
546 | __END__ |
---|
547 | |
---|
548 | =head1 NAME |
---|
549 | |
---|
550 | DB - programmatic interface to the Perl debugging API (draft, subject to |
---|
551 | change) |
---|
552 | |
---|
553 | =head1 SYNOPSIS |
---|
554 | |
---|
555 | package CLIENT; |
---|
556 | use DB; |
---|
557 | @ISA = qw(DB); |
---|
558 | |
---|
559 | # these (inherited) methods can be called by the client |
---|
560 | |
---|
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 |
---|
584 | |
---|
585 | # These methods will be called at the appropriate times. |
---|
586 | # Stub versions provided do nothing. |
---|
587 | # None of these can block. |
---|
588 | |
---|
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 |
---|
594 | |
---|
595 | =head1 DESCRIPTION |
---|
596 | |
---|
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. |
---|
600 | |
---|
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. |
---|
606 | |
---|
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] |
---|
611 | |
---|
612 | In particular, this API does B<not> provide the following functions: |
---|
613 | |
---|
614 | =over 4 |
---|
615 | |
---|
616 | =item * |
---|
617 | |
---|
618 | data display |
---|
619 | |
---|
620 | =item * |
---|
621 | |
---|
622 | command processing |
---|
623 | |
---|
624 | =item * |
---|
625 | |
---|
626 | command alias management |
---|
627 | |
---|
628 | =item * |
---|
629 | |
---|
630 | user interface (tty or graphical) |
---|
631 | |
---|
632 | =back |
---|
633 | |
---|
634 | These are intended to be services performed by the clients of this API. |
---|
635 | |
---|
636 | This module attempts to be squeaky clean w.r.t C<use strict;> and when |
---|
637 | warnings are enabled. |
---|
638 | |
---|
639 | |
---|
640 | =head2 Global Variables |
---|
641 | |
---|
642 | The following "public" global names can be read by clients of this API. |
---|
643 | Beware that these should be considered "readonly". |
---|
644 | |
---|
645 | =over 8 |
---|
646 | |
---|
647 | =item $DB::sub |
---|
648 | |
---|
649 | Name of current executing subroutine. |
---|
650 | |
---|
651 | =item %DB::sub |
---|
652 | |
---|
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)>. |
---|
656 | |
---|
657 | =item $DB::single |
---|
658 | |
---|
659 | Single-step flag. Will be true if the API will stop at the next statement. |
---|
660 | |
---|
661 | =item $DB::signal |
---|
662 | |
---|
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. |
---|
665 | |
---|
666 | =item $DB::trace |
---|
667 | |
---|
668 | This flag is set to true if the API is tracing through subroutine calls. |
---|
669 | |
---|
670 | =item @DB::args |
---|
671 | |
---|
672 | Contains the arguments of current subroutine, or the C<@ARGV> array if in the |
---|
673 | toplevel context. |
---|
674 | |
---|
675 | =item @DB::dbline |
---|
676 | |
---|
677 | List of lines in currently loaded file. |
---|
678 | |
---|
679 | =item %DB::dbline |
---|
680 | |
---|
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)>. |
---|
683 | |
---|
684 | =item $DB::package |
---|
685 | |
---|
686 | Package namespace of currently executing code. |
---|
687 | |
---|
688 | =item $DB::filename |
---|
689 | |
---|
690 | Currently loaded filename. |
---|
691 | |
---|
692 | =item $DB::subname |
---|
693 | |
---|
694 | Fully qualified name of currently executing subroutine. |
---|
695 | |
---|
696 | =item $DB::lineno |
---|
697 | |
---|
698 | Line number that will be executed next. |
---|
699 | |
---|
700 | =back |
---|
701 | |
---|
702 | =head2 API Methods |
---|
703 | |
---|
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. |
---|
708 | |
---|
709 | =over 8 |
---|
710 | |
---|
711 | =item CLIENT->register() |
---|
712 | |
---|
713 | register a client object/package |
---|
714 | |
---|
715 | =item CLIENT->evalcode(STRING) |
---|
716 | |
---|
717 | eval STRING in executing code context |
---|
718 | |
---|
719 | =item CLIENT->skippkg('D::hide') |
---|
720 | |
---|
721 | ask DB not to stop in these packages |
---|
722 | |
---|
723 | =item CLIENT->run() |
---|
724 | |
---|
725 | run some more (until a breakpt is reached) |
---|
726 | |
---|
727 | =item CLIENT->step() |
---|
728 | |
---|
729 | single step |
---|
730 | |
---|
731 | =item CLIENT->next() |
---|
732 | |
---|
733 | step over |
---|
734 | |
---|
735 | =item CLIENT->done() |
---|
736 | |
---|
737 | de-register from the debugging API |
---|
738 | |
---|
739 | =back |
---|
740 | |
---|
741 | =head2 Client Callback Methods |
---|
742 | |
---|
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. |
---|
747 | |
---|
748 | =over 8 |
---|
749 | |
---|
750 | =item CLIENT->init() |
---|
751 | |
---|
752 | Called after debug API inits itself. |
---|
753 | |
---|
754 | =item CLIENT->prestop([STRING]) |
---|
755 | |
---|
756 | Usually inherited from DB package. If no arguments are passed, |
---|
757 | returns the prestop action string. |
---|
758 | |
---|
759 | =item CLIENT->stop() |
---|
760 | |
---|
761 | Called when execution stops (w/ args file, line). |
---|
762 | |
---|
763 | =item CLIENT->idle() |
---|
764 | |
---|
765 | Called while stopped (can be a client event loop). |
---|
766 | |
---|
767 | =item CLIENT->poststop([STRING]) |
---|
768 | |
---|
769 | Usually inherited from DB package. If no arguments are passed, |
---|
770 | returns the poststop action string. |
---|
771 | |
---|
772 | =item CLIENT->evalcode(STRING) |
---|
773 | |
---|
774 | Usually inherited from DB package. Ask for a STRING to be C<eval>-ed |
---|
775 | in executing code context. |
---|
776 | |
---|
777 | =item CLIENT->cleanup() |
---|
778 | |
---|
779 | Called just before exit. |
---|
780 | |
---|
781 | =item CLIENT->output(LIST) |
---|
782 | |
---|
783 | Called when API must show a message (warnings, errors etc.). |
---|
784 | |
---|
785 | |
---|
786 | =back |
---|
787 | |
---|
788 | |
---|
789 | =head1 BUGS |
---|
790 | |
---|
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. |
---|
794 | |
---|
795 | =head1 AUTHOR |
---|
796 | |
---|
797 | Gurusamy Sarathy gsar@activestate.com |
---|
798 | |
---|
799 | This code heavily adapted from an early version of perl5db.pl attributable |
---|
800 | to Larry Wall and the Perl Porters. |
---|
801 | |
---|
802 | =cut |
---|