| File: | blib/lib/Debug/Client.pm |
| Coverage: | 87.7% |
| line | stmt | bran | cond | sub | pod | time | code |
|---|---|---|---|---|---|---|---|
| 1 | package Debug::Client; | ||||||
| 2 | 15 15 15 | 3458507 46 417 | use strict; | ||||
| 3 | 15 15 15 | 74 46 469 | use warnings; | ||||
| 4 | 15 15 15 | 510 71 988 | use 5.006; | ||||
| 5 | |||||||
| 6 | our $VERSION = '0.12'; | ||||||
| 7 | |||||||
| 8 | 15 15 15 | 5755 334244 151 | use IO::Socket; | ||||
| 9 | 15 15 15 | 10708 38 52246 | use Carp (); | ||||
| 10 | |||||||
| 11 - 108 | =head1 NAME
Debug::Client - client side code for perl debugger
=head1 SYNOPIS
use Debug::Client;
my $debugger = Debug::Client->new(host => $host, port => $port);
$debugger->listen;
Where $host is the hostname to be used by the script under test (SUT)
to acces the machine where Debug::Client runs. If they are on the same machine
this should be C<localhost>.
$port can be any port number where the Debug::Client could listen.
This is the point where the external SUT needs to be launched
by first setting
$ENV{PERLDB_OPTS} = "RemotePort=$host:$port"
then running
perl -d script
Once the script under test wa launched we can call the following:
my $out = $debugger->get;
$out = $debugger->step_in;
$out = $debugger->step_over;
my ($prompt, $module, $file, $row, $content) = $debugger->step_in;
my ($module, $file, $row, $content, $return_value) = $debugger->step_out;
my $value = $debugger->get_value('$x');
$debugger->run(); # run till end of breakpoint or watch
$debugger->run( 42 ); # run till line 42 (c in the debugger)
$debugger->run( 'foo' ); # run till beginning of sub
$debugger->execute_code( '$answer = 42' );
$debugger->execute_code( '@name = qw(foo bar)' );
my $value = $debugger->get_value('@name'); $value is the dumped data?
$debugger->execute_code( '%phone_book = (foo => 123, bar => 456)' );
my $value = $debugger->get_value('%phone_book'); $value is the dumped data?
$debugger->set_breakpoint( "file", 23 ); # set breakpoint on file, line
$debugger->get_stack_trace
Other planned methods:
$debugger->set_breakpoint( "file", 23, COND ); # set breakpoint on file, line, on condition
$debugger->set_breakpoint( "file", subname, [COND] )
$debugger->set_watch
$debugger->remove_watch
$debugger->remove_breakpoint
$debugger->watch_variable (to make it easy to display values of variables)
=head2 example
my $script = 'script_to_debug.pl';
my @args = ('param', 'param');
my $perl = $^X; # the perl might be a different perl
my $host = 'localhost';
my $port = 12345;
my $pid = fork();
die if not defined $pid;
if (not $pid) {
local $ENV{PERLDB_OPTS} = "RemotePort=$host:$port"
exec("$perl -d $script @args");
}
require Debug::Client;
my $debugger = Debug::Client->new(
host => $host,
port => $port,
);
$debugger->listen;
my $out = $debugger->get;
$out = $debugger->step_in;
# ...
=head1 DESCRIPTION
=cut | ||||||
| 109 | |||||||
| 110 - 124 | =head2 new The constructor can get two parameters: host and port. my $d = Debug::Client->new; my $d = Debug::Client->new(host => 'remote.hots.com', port => 4242); Immediately after the object creation one needs to call $d->listen; TODO: Is there any reason to separate the two? =cut | ||||||
| 125 | |||||||
| 126 | sub new { | ||||||
| 127 | 15 | 1 | 201231 | my ( $class, %args ) = @_; | |||
| 128 | 15 | 219 | my $self = bless {}, $class; | ||||
| 129 | |||||||
| 130 | 15 | 134 | %args = ( | ||||
| 131 | host => 'localhost', port => 12345, | ||||||
| 132 | %args | ||||||
| 133 | ); | ||||||
| 134 | |||||||
| 135 | 15 | 69 | $self->{host} = $args{host}; | ||||
| 136 | 15 | 44 | $self->{port} = $args{port}; | ||||
| 137 | |||||||
| 138 | 15 | 133 | return $self; | ||||
| 139 | } | ||||||
| 140 | |||||||
| 141 - 145 | =head2 listen See C<new> =cut | ||||||
| 146 | |||||||
| 147 | sub listen { | ||||||
| 148 | 14 | 1 | 122 | my ($self) = @_; | |||
| 149 | |||||||
| 150 | # Open the socket the debugger will connect to. | ||||||
| 151 | 14 | 197 | my $sock = IO::Socket::INET->new( | ||||
| 152 | LocalHost => $self->{host}, | ||||||
| 153 | LocalPort => $self->{port}, | ||||||
| 154 | Proto => 'tcp', | ||||||
| 155 | Listen => SOMAXCONN, | ||||||
| 156 | Reuse => 1 | ||||||
| 157 | ); | ||||||
| 158 | 14 | 21081 | $sock or die "Could not connect to '$self->{host}' '$self->{port}' no socket :$!"; | ||||
| 159 | 14 | 106 | _logger("listening on '$self->{host}:$self->{port}'"); | ||||
| 160 | 14 | 46 | $self->{sock} = $sock; | ||||
| 161 | |||||||
| 162 | 14 | 193 | $self->{new_sock} = $self->{sock}->accept(); | ||||
| 163 | |||||||
| 164 | 14 | 14782035 | return; | ||||
| 165 | } | ||||||
| 166 | |||||||
| 167 - 173 | =head2 buffer Returns the content of the buffer since the last command $debugger->buffer; =cut | ||||||
| 174 | |||||||
| 175 | sub buffer { | ||||||
| 176 | 6 | 1 | 19751 | my ($self) = @_; | |||
| 177 | 6 | 85 | return $self->{buffer}; | ||||
| 178 | } | ||||||
| 179 | |||||||
| 180 - 182 | =head2 quit =cut | ||||||
| 183 | |||||||
| 184 | 14 | 1 | 58990 | sub quit { $_[0]->_send('q') } | |||
| 185 | |||||||
| 186 - 188 | =head2 show_line =cut | ||||||
| 189 | |||||||
| 190 | 1 | 1 | 2525 | sub show_line { $_[0]->send_get('.') } | |||
| 191 | |||||||
| 192 | |||||||
| 193 - 195 | =head2 step_in =cut | ||||||
| 196 | |||||||
| 197 | 61 | 1 | 356118 | sub step_in { $_[0]->send_get('s') } | |||
| 198 | |||||||
| 199 - 201 | =head2 step_over =cut | ||||||
| 202 | |||||||
| 203 | 4 | 1 | 25026 | sub step_over { $_[0]->send_get('n') } | |||
| 204 | |||||||
| 205 - 220 | =head2 step_out my ($prompt, $module, $file, $row, $content, $return_value) = $debugger->step_out; Where $prompt is just a number, probably useless $return_value will be undef if the function was called in VOID context It will hold a scalar value if called in SCALAR context It will hold a reference to an array if called in LIST context. TODO: check what happens when the return value is a reference to a complex data structure or when some of the elements of the returned array are themselves references =cut | ||||||
| 221 | |||||||
| 222 | sub step_out { | ||||||
| 223 | 8 | 1 | 45611 | my ($self) = @_; | |||
| 224 | |||||||
| 225 | 8 | 67 | Carp::croak('Must call step_out in list context') if not wantarray; | ||||
| 226 | |||||||
| 227 | 8 | 56 | $self->_send('r'); | ||||
| 228 | 8 | 94 | my $buf = $self->_get; | ||||
| 229 | |||||||
| 230 | # void context return from main::f | ||||||
| 231 | # scalar context return from main::f: 242 | ||||||
| 232 | # list context return from main::f: | ||||||
| 233 | # 0 22 | ||||||
| 234 | # 1 34 | ||||||
| 235 | # main::(t/eg/02-sub.pl:9): my $z = $x + $y; | ||||||
| 236 | |||||||
| 237 | # list context return from main::g: | ||||||
| 238 | # 0 'baz' | ||||||
| 239 | # 1 'foo | ||||||
| 240 | # bar' | ||||||
| 241 | # 2 'moo' | ||||||
| 242 | # main::(t/eg/03-return.pl:10): $x++; | ||||||
| 243 | |||||||
| 244 | 8 | 84 | $self->_prompt( \$buf ); | ||||
| 245 | 8 | 66 | my @line = $self->_process_line( \$buf ); | ||||
| 246 | 8 | 43 | my $ret; | ||||
| 247 | 8 | 33 | my $context; | ||||
| 248 | 8 | 160 | if ( $buf =~ /^(scalar|list) context return from (\S+):\s*(.*)/s ) { | ||||
| 249 | 7 | 44 | $context = $1; | ||||
| 250 | 7 | 45 | $ret = $3; | ||||
| 251 | } | ||||||
| 252 | |||||||
| 253 | #if ($context and $context eq 'list') { | ||||||
| 254 | # TODO can we parse this inteligently in the general case? | ||||||
| 255 | #} | ||||||
| 256 | 8 | 203 | return ( @line, $ret ); | ||||
| 257 | } | ||||||
| 258 | |||||||
| 259 | |||||||
| 260 - 267 | =head2 get_stack_trace Sends the stack trace command C<T> to the remote debugger and returns it as a string if called in scalar context. Returns the prompt number and the stack trace string when called in array context. =cut | ||||||
| 268 | |||||||
| 269 | sub get_stack_trace { | ||||||
| 270 | 7 | 1 | 42129 | my ($self) = @_; | |||
| 271 | 7 | 58 | $self->_send('T'); | ||||
| 272 | 7 | 62 | my $buf = $self->_get; | ||||
| 273 | |||||||
| 274 | 7 | 72 | $self->_prompt( \$buf ); | ||||
| 275 | 7 | 153 | return $buf; | ||||
| 276 | } | ||||||
| 277 | |||||||
| 278 - 287 | =head2 run $d->run; Will run till the next breakpoint or watch or the end of the script. (Like pressing c in the debugger). $d->run($param) =cut | ||||||
| 288 | |||||||
| 289 | sub run { | ||||||
| 290 | 14 | 1 | 115685 | my ( $self, $param ) = @_; | |||
| 291 | 14 | 103 | if ( not defined $param ) { | ||||
| 292 | 11 | 78 | $self->send_get('c'); | ||||
| 293 | } else { | ||||||
| 294 | 3 | 24 | $self->send_get("c $param"); | ||||
| 295 | } | ||||||
| 296 | } | ||||||
| 297 | |||||||
| 298 | |||||||
| 299 - 303 | =head2 set_breakpoint $d->set_breakpoint($file, $line, $condition); =cut | ||||||
| 304 | |||||||
| 305 | |||||||
| 306 | sub set_breakpoint { | ||||||
| 307 | 6 | 1 | 30586 | my ( $self, $file, $line, $cond ) = @_; | |||
| 308 | |||||||
| 309 | 6 | 44 | $self->_send("f $file"); | ||||
| 310 | 6 | 45 | my $b = $self->_get; | ||||
| 311 | |||||||
| 312 | # Already in t/eg/02-sub.pl. | ||||||
| 313 | |||||||
| 314 | 6 | 70 | $self->_send("b $line"); | ||||
| 315 | |||||||
| 316 | # if it was successful no reply | ||||||
| 317 | # if it failed we saw two possible replies | ||||||
| 318 | 6 | 61 | my $buf = $self->_get; | ||||
| 319 | 6 | 60 | my $prompt = $self->_prompt( \$buf ); | ||||
| 320 | 6 | 96 | if ( $buf =~ /^Subroutine [\w:]+ not found\./ ) { | ||||
| 321 | |||||||
| 322 | # failed | ||||||
| 323 | 0 | 0 | return 0; | ||||
| 324 | } elsif ( $buf =~ /^Line \d+ not breakable\./ ) { | ||||||
| 325 | |||||||
| 326 | # faild to set on line number | ||||||
| 327 | 1 | 27 | return 0; | ||||
| 328 | } elsif ( $buf =~ /\S/ ) { | ||||||
| 329 | 1 | 22 | return 0; | ||||
| 330 | } | ||||||
| 331 | |||||||
| 332 | 4 | 99 | return 1; | ||||
| 333 | } | ||||||
| 334 | |||||||
| 335 | # apparently no clear success/error report for this | ||||||
| 336 | sub remove_breakpoint { | ||||||
| 337 | 2 | 0 | 5037 | my ( $self, $file, $line ) = @_; | |||
| 338 | |||||||
| 339 | 2 | 25 | $self->_send("f $file"); | ||||
| 340 | 2 | 20 | my $b = $self->_get; | ||||
| 341 | |||||||
| 342 | 2 | 24 | $self->_send("B $line"); | ||||
| 343 | 2 | 19 | my $buf = $self->_get; | ||||
| 344 | 2 | 46 | return 1; | ||||
| 345 | } | ||||||
| 346 | |||||||
| 347 - 363 | =head2 list_break_watch_action In scalar context returns the list of all the breakpoints and watches as a text output. The data as (L) prints in the command line debugger. In list context it returns the promt number, and a list of hashes. Each hash has file => line => cond => to provide the filename, line number and the condition of the breakpoint. In case of no condition the last one will be the number 1. =cut | ||||||
| 364 | |||||||
| 365 | sub list_break_watch_action { | ||||||
| 366 | 7 | 1 | 24203 | my ($self) = @_; | |||
| 367 | |||||||
| 368 | 7 | 48 | my $ret = $self->send_get('L'); | ||||
| 369 | 7 | 44 | if ( not wantarray ) { | ||||
| 370 | 5 | 79 | return $ret; | ||||
| 371 | } | ||||||
| 372 | |||||||
| 373 | # t/eg/04-fib.pl: | ||||||
| 374 | # 17: my $n = shift; | ||||||
| 375 | # break if (1) | ||||||
| 376 | 2 | 14 | my $buf = $self->buffer; | ||||
| 377 | 2 | 15 | my $prompt = $self->_prompt( \$buf ); | ||||
| 378 | |||||||
| 379 | 2 | 9 | my @breakpoints; | ||||
| 380 | 2 | 8 | my %bp; | ||||
| 381 | 2 | 17 | my $PATH = qr{[\w./-]+}; | ||||
| 382 | 2 | 11 | my $LINE = qr{\d+}; | ||||
| 383 | 2 | 11 | my $CODE = qr{.*}s; | ||||
| 384 | 2 | 12 | my $COND = qr{1}; ## TODO !!! | ||||
| 385 | |||||||
| 386 | 2 | 12 | while ($buf) { | ||||
| 387 | 1 | 133 | if ( $buf =~ s{^($PATH):\s*($LINE):\s*($CODE)\s+break if \(($COND)\)s*}{} ) { | ||||
| 388 | 1 | 28 | my %bp = ( | ||||
| 389 | file => $1, | ||||||
| 390 | line => $2, | ||||||
| 391 | cond => $4, | ||||||
| 392 | ); | ||||||
| 393 | 1 | 11 | push @breakpoints, \%bp; | ||||
| 394 | } else { | ||||||
| 395 | 0 | 0 | die "No breakpoint found in '$buf'"; | ||||
| 396 | } | ||||||
| 397 | } | ||||||
| 398 | |||||||
| 399 | 2 | 39 | return ( $prompt, \@breakpoints ); | ||||
| 400 | } | ||||||
| 401 | |||||||
| 402 | |||||||
| 403 - 407 | =head2 execute_code $d->execute_code($some_code_to_execute); =cut | ||||||
| 408 | |||||||
| 409 | sub execute_code { | ||||||
| 410 | 7 | 1 | 26583 | my ( $self, $code ) = @_; | |||
| 411 | |||||||
| 412 | 7 | 57 | return if not defined $code; | ||||
| 413 | |||||||
| 414 | 5 | 32 | $self->_send($code); | ||||
| 415 | 5 | 36 | my $buf = $self->_get; | ||||
| 416 | 5 | 49 | $self->_prompt( \$buf ); | ||||
| 417 | 5 | 109 | return $buf; | ||||
| 418 | } | ||||||
| 419 | |||||||
| 420 - 428 | =head2 get_value my $value = $d->get_value($x); If $x is a scalar value, $value will contain that value. If it is a reference to a SCALAR, ARRAY or HASH then $value should be the value of that reference? =cut | ||||||
| 429 | |||||||
| 430 | # TODO if the given $x is a reference then something (either this module | ||||||
| 431 | # or its user) should actually call x $var | ||||||
| 432 | sub get_value { | ||||||
| 433 | 9 | 1 | 58825 | my ( $self, $var ) = @_; | |||
| 434 | 9 | 77 | die "no parameter given\n" if not defined $var; | ||||
| 435 | |||||||
| 436 | 9 | 112 | if ( $var =~ /^\$/ ) { | ||||
| 437 | 7 | 65 | $self->_send("p $var"); | ||||
| 438 | 7 | 63 | my $buf = $self->_get; | ||||
| 439 | 7 | 74 | $self->_prompt( \$buf ); | ||||
| 440 | 7 | 157 | return $buf; | ||||
| 441 | } elsif ( $var =~ /\@/ or $var =~ /\%/ ) { | ||||||
| 442 | 2 | 18 | $self->_send("x \\$var"); | ||||
| 443 | 2 | 22 | my $buf = $self->_get; | ||||
| 444 | 2 | 23 | $self->_prompt( \$buf ); | ||||
| 445 | 2 | 16 | my $data_ref = _parse_dumper($buf); | ||||
| 446 | 2 | 42 | return $data_ref; | ||||
| 447 | } | ||||||
| 448 | 0 | 0 | die "Unknown parameter '$var'\n"; | ||||
| 449 | } | ||||||
| 450 | |||||||
| 451 | sub _parse_dumper { | ||||||
| 452 | 2 | 15 | my ($str) = @_; | ||||
| 453 | 2 | 12 | return $str; | ||||
| 454 | } | ||||||
| 455 | |||||||
| 456 | # TODO shall we add a timeout and/or a number to count down the number | ||||||
| 457 | # sysread calls that return 0 before deciding it is really done | ||||||
| 458 | sub _get { | ||||||
| 459 | 145 | 628 | my ($self) = @_; | ||||
| 460 | |||||||
| 461 | #my $remote_host = gethostbyaddr($sock->sockaddr(), AF_INET) || 'remote'; | ||||||
| 462 | 145 | 628 | my $buf = ''; | ||||
| 463 | 145 | 1020 | while ( $buf !~ /DB<\d+>/ ) { | ||||
| 464 | 324 | 6469 | my $ret = $self->{new_sock}->sysread( $buf, 1024, length $buf ); | ||||
| 465 | 324 | 5901594 | if ( not defined $ret ) { | ||||
| 466 | 0 | 0 | die $!; # TODO better error handling? | ||||
| 467 | } | ||||||
| 468 | 324 | 3031 | _logger("---- ret '$ret'\n$buf\n---"); | ||||
| 469 | 324 | 4194 | if ( not $ret ) { | ||||
| 470 | 0 | 0 | last; | ||||
| 471 | } | ||||||
| 472 | } | ||||||
| 473 | 145 | 784 | _logger("_get done"); | ||||
| 474 | |||||||
| 475 | 145 | 931 | $self->{buffer} = $buf; | ||||
| 476 | 145 | 1219 | return $buf; | ||||
| 477 | } | ||||||
| 478 | |||||||
| 479 | # This is an internal method. | ||||||
| 480 | # It takes one argument which is a reference to a scalar that contains the | ||||||
| 481 | # the text sent by the debugger. | ||||||
| 482 | # Extracts and prompt that looks like this: DB<3> $ | ||||||
| 483 | # puts the number from the prompt in $self->{prompt} and also returns it. | ||||||
| 484 | # See 00-internal.t for test cases | ||||||
| 485 | sub _prompt { | ||||||
| 486 | 99 | 16925 | my ( $self, $buf ) = @_; | ||||
| 487 | |||||||
| 488 | 99 | 2771 | if ( not defined $buf or not ref $buf or ref $buf ne 'SCALAR' ) { | ||||
| 489 | 2 | 381 | Carp::croak('_prompt should be called with a reference to a scalar'); | ||||
| 490 | } | ||||||
| 491 | |||||||
| 492 | 97 | 377 | my $prompt; | ||||
| 493 | 97 | 2726 | if ( $$buf =~ s/\s*DB<(\d+)>\s*$// ) { | ||||
| 494 | 97 | 986 | $prompt = $1; | ||||
| 495 | } | ||||||
| 496 | 97 | 572 | chomp($$buf); | ||||
| 497 | |||||||
| 498 | 97 | 646 | return $self->{prompt} = $prompt; | ||||
| 499 | } | ||||||
| 500 | |||||||
| 501 | # Internal method that receives a reference to a scalar | ||||||
| 502 | # containing the data printed by the debugger | ||||||
| 503 | # If the output indicates that the debugger terminated return '<TERMINATED>' | ||||||
| 504 | # Otherwise it returns ( $package, $file, $row, $content ); | ||||||
| 505 | # where | ||||||
| 506 | # $package is main:: or Some::Module:: (the current package) | ||||||
| 507 | # $file is the full or relative path to the current file | ||||||
| 508 | # $row is the current row number | ||||||
| 509 | # $content is the content of the current row | ||||||
| 510 | # see 00-internal.t for test cases | ||||||
| 511 | sub _process_line { | ||||||
| 512 | 68 | 478 | my ( $self, $buf ) = @_; | ||||
| 513 | |||||||
| 514 | 68 | 1528 | if ( not defined $buf or not ref $buf or ref $buf ne 'SCALAR' ) { | ||||
| 515 | 0 | 0 | Carp::croak('_process_line should be called with a reference to a scalar'); | ||||
| 516 | } | ||||||
| 517 | |||||||
| 518 | 68 | 640 | if ( $$buf =~ /Debugged program terminated/ ) { | ||||
| 519 | 1 | 8 | return '<TERMINATED>'; | ||||
| 520 | } | ||||||
| 521 | |||||||
| 522 | 67 | 744 | my @parts = split /\n/, $$buf; | ||||
| 523 | 67 | 359 | my $line = pop @parts; | ||||
| 524 | |||||||
| 525 | # try to debug some test reports | ||||||
| 526 | # http://www.nntp.perl.org/group/perl.cpan.testers/2009/12/msg6542852.html | ||||||
| 527 | 67 | 419 | if ( not defined $line ) { | ||||
| 528 | 0 | 0 | Carp::croak("Debug::Client: Line is undef. Buffer is '$$buf'"); | ||||
| 529 | } | ||||||
| 530 | 67 | 528 | _logger("Line: '$line'"); | ||||
| 531 | 67 | 265 | my $cont; | ||||
| 532 | 67 | 588 | if ( $line =~ /^\d+: \s* (.*)$/x ) { | ||||
| 533 | 2 | 7 | $cont = $1; | ||||
| 534 | 2 | 5 | $line = pop @parts; | ||||
| 535 | 2 | 8 | _logger("Line2: '$line'"); | ||||
| 536 | } | ||||||
| 537 | |||||||
| 538 | 67 | 465 | $$buf = join "\n", @parts; | ||||
| 539 | 67 | 304 | my ( $module, $file, $row, $content ); | ||||
| 540 | |||||||
| 541 | # the last line before | ||||||
| 542 | # main::(t/eg/01-add.pl:8): my $z = $x + $y; | ||||||
| 543 | 67 | 1077 | if ($line =~ /^([\w:]*) # module | ||||
| 544 | \( ([^\)]*):(\d+) \) # (file:row) | ||||||
| 545 | :\t? # : | ||||||
| 546 | (.*) # content | ||||||
| 547 | /mx | ||||||
| 548 | ) | ||||||
| 549 | { | ||||||
| 550 | 67 | 889 | ( $module, $file, $row, $content ) = ( $1, $2, $3, $4 ); | ||||
| 551 | } | ||||||
| 552 | 67 | 390 | if ($cont) { | ||||
| 553 | 2 | 4 | $content = $cont; | ||||
| 554 | } | ||||||
| 555 | 67 | 350 | $self->{filename} = $file; | ||||
| 556 | 67 | 305 | $self->{row} = $row; | ||||
| 557 | 67 | 746 | return ( $module, $file, $row, $content ); | ||||
| 558 | } | ||||||
| 559 | |||||||
| 560 - 573 | =head get Actually I think this is an internal method.... In SCALAR context will return all the buffer collected since the last command. In LIST context will return ($prompt, $module, $file, $row, $content) Where $prompt is the what the standard debugger uses for prompt. Probably not too interesting. $file and $row describe the location of the next instructions. $content is the actual line - this is probably not too interesting as it is in the editor. $module is just the name of the module in which the current execution is. =cut | ||||||
| 574 | |||||||
| 575 | sub get { | ||||||
| 576 | 100 | 0 | 1282 | my ($self) = @_; | |||
| 577 | |||||||
| 578 | 100 | 555 | my $buf = $self->_get; | ||||
| 579 | |||||||
| 580 | 100 | 701 | if (wantarray) { | ||||
| 581 | 56 | 549 | $self->_prompt( \$buf ); | ||||
| 582 | 56 | 435 | my ( $module, $file, $row, $content ) = $self->_process_line( \$buf ); | ||||
| 583 | 56 | 1453 | return ( $module, $file, $row, $content ); | ||||
| 584 | } else { | ||||||
| 585 | 44 | 721 | return $buf; | ||||
| 586 | } | ||||||
| 587 | } | ||||||
| 588 | |||||||
| 589 | sub _send { | ||||||
| 590 | 146 | 720 | my ( $self, $input ) = @_; | ||||
| 591 | |||||||
| 592 | #print "Sending '$input'\n"; | ||||||
| 593 | 146 146 | 999 142729 | print { $self->{new_sock} } "$input\n"; | ||||
| 594 | } | ||||||
| 595 | |||||||
| 596 | sub send_get { | ||||||
| 597 | 87 | 0 | 458 | my ( $self, $input ) = @_; | |||
| 598 | 87 | 477 | $self->_send($input); | ||||
| 599 | |||||||
| 600 | 87 | 644 | return $self->get; | ||||
| 601 | } | ||||||
| 602 | |||||||
| 603 | 0 | 0 | 0 | sub filename { return $_[0]->{filename} } | |||
| 604 | 0 | 0 | 0 | sub row { return $_[0]->{row} } | |||
| 605 | |||||||
| 606 | sub _logger { | ||||||
| 607 | 552 | 3816 | print "LOG: $_[0]\n" if $ENV{DEBUG_LOGGER}; | ||||
| 608 | } | ||||||
| 609 | |||||||
| 610 | |||||||
| 611 - 635 | =head1 See Also L<GRID::Machine::remotedebugtut> =head1 COPYRIGHT Copyright 2008-2011 Gabor Szabo. L<http://szabgab.com/> =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5 itself. =head1 WARRANTY There is no warranty whatsoever. If you lose data or your hair because of this program, that's your problem. =head1 CREDITS and THANKS Originally started out from the remoteport.pl script from Pro Perl Debugging written by Richard Foley. =cut | ||||||
| 636 | |||||||
| 637 | 1; | ||||||