Debug-Client-0.29/0002755000175000000500000000000012175567260012400 5ustar kevinsrcDebug-Client-0.29/Changes0000644000175000000500000002373012175567167013704 0ustar kevinsrcChanges for Debug::Client 0.29 2013-07-29 - ouch typo, tab v spaces (BOWTIE) 0.28 2013-07-28 - bump version and release (BOWTIE) 0.27_02 2013-07-10 - remove BEGIN block and force Win32 Term::ReadLine settings (BOWTIE) 0.27_01 2013-07-10 - switch to Term::ReadLine::Gnu or nought (BOWTIE) 0.26 2013-06-03 - bump version and release (BOWTIE) 0.25_10 2013-05-20 - Change the running order of test (BOWTIE) - check testing $ENV{PERL_RL} = ornaments=0 - as we only want to do this when necessary (BOWTIE) 0.25_09 2013-05-15 - fix buffer call to $debugger->get_buffer 0.25_08 2013-05-12 - fix dependency inconsistencies - add new test 00-check-deps.t - add test to see if we invoke $ENV{PERL_RL} (BOWTIE) 0.25_07 2013-05-12 - use M::I to load Term::ReadLine::Gnu (BOWTIE) 0.25_06 2013-05-10 - contradicting module definitions oops (BOWTIE) 0.25_05 2013-05-09 - Tweak 06-term.t to show more info from cpan testers (BOWTIE) - fix missing MANIFEST (BOWTIE) - lower some dependency version dod++ (BOWTIE) 0.25_04 2013-05-05 - Tweak for perl-5.17.11 compatibility (BOWTIE) - test tweaks to hack #1494 (BOWTIE) - Use a more appropriate Term::ReadLine::... (BOWTIE) 0.25 2013-04-17 - bump version and release (BOWTIE) 0.24_04 2013-04-16 - swap out some more localhost for 127.0.0.1 azawawi++ (BOWTIE) 0.24_03 2013-04-16 - my $host = '127.0.0.1'; # instead of localhost (AZAWAWI) - add some 'fudge' to t-lib-debugger for win32 azawawi++ (BOWTIE) 0.24_02 2013-04-16 - lets remove Time-HiRes completely (BOWTIE) 0.24_01 2013-04-16 - tweak t-lib-debugger, adjust sleep to 1 sec (BOWTIE) - update Makefile requirements (BOWTIE) 0.24 2013-02-19 - Tweak for production release to co-inside with Padre 0.98 (BOWTIE) 0.23 2013-02-19 - Add perltidy.LOG to MANIFEST.SKIP (BOWTIE) 0.22 2013-02-08 - Tweak for production release to co-inside with Padre 0.98 (BOWTIE) 0.21_18 2013-01-28 - roll-back Makefile to 0.21_14 and test to complement, andk++ (BOWTIE) 0.21_17 2013-01-27 - POD tweaks, missing # azawawi++ (BOWTIE) - Add back a requirement to Makefile after being heavy handed (BOWTIE) 0.21_16 2013-01-22 - Remove test for a no-longer required module, causing CPAN failures (BOWTIE) 0.21_15 2013-01-22 - add reset to buffer in show help (BOWTIE) - fix bug in set breakpoint that was being confused by 'Already in file-x' (BOWTIE) 0.21_14 2013-01-04 - #This all relates to #1469 - fix Windows hangings (CHORNY) - split and sort out hack into each dev release - the switch to time hiRes & win32::Precess (BOWTIE) - add some tests back-in using Test::Class to see what CPAN::Reporter go to say (BOWTIE) 0.21_13 2013-01-04 - #not released - #This all relates to perl 5.017006 - Crammer tweak rindolf++ (BOWTIE) - y=o is now y=1 for >= 5.017006 (BOWTIE) - https://github.com/shlomif/perl/commit/7a0fe8d157063a5d4017c60814c1ea577 f105a72 tweak to t/40-test_1415.t to better check if watches are working in 5.017006 (BOWTIE) 0.21_12 2012-11-06 - Update Changes to CPAN::Changes::Spec - Tweak tests to handle perl5db version 1.39_04 (perl - 5.17.5) (BOWTIE) 0.21_11 2012-09-09 - Removed Test::Pod and Test::Pod::Coverage dependencies (ADAMK) - Removed the spookily magic strictures.pm dependency (ADAMK) - Switching to #!/usr/bin/perl as the env version is recommended against in tests for reasons I forget but I think were related to tainting (ADAMK) - Devolve v5.10 to 5.010 so older perl can parse far enough to understand that they can't parse the file. (ADAMK) - Slightly better separation of concerns in the early test scripts (ADAMK) 0.21_10 2012-09-06 - Debug::Client's dependency on Test::Class is breaking Strawberry Test::Class has Windows problems adamk++ - Remove Test::Class from Debug::Client (BOWTIE) 0.21_09 2012-09-06 - skipped intentionally 0.21_08 2012-08-20 - correction to parameters for IO::Socket::IP initialisation (BOWTIE) 0.21_07 2012-08-18 - bump IO::Socket::IP to 0.17 (BOWTIE) 0.21_06 2012-08-05 - silly dependency issue, my bad (BOWTIE) - Info: perl5db v1.39_02 yes in perl 5.17.2, O what fun (BOWTIE) 0.21_05 2012-07-26 - remove comments (BOWTIE) - remove un-required dependants from Makefile (BOWTIE) - tweak version requirements for IO::Socket::IP (BOWTIE) 0.21_04 2012-06-23 - re-factor initialize plus test (BOWTIE) - turn off test in io (BOWTIE) 0.21_03 2012-06-09 - Fix displaying watches in ANON sub #1415 (BOWTIE) - some method re-factoring (BOWTIE) - keep test up-to-date (BOWTIE) 0.21_02 2012-05-21 - remove _logger (BOWTIE) - move listener to _init, hence now redundant (BOWTIE) - use IO::Socket::IP (BOWTIE) - tweak tests and Makefile accordingly (BOWTIE) 0.21_01 2012-05-11 - Add Test-Pod to appease Kwalitee (BOWTIE) - change to use $self->{debug} instead of $ENV{DEBUG_LOGGER} (BOWTIE) due to bleeding of env causing tests to fail on win32 against 0.20 (BOWTIE) - keep instep with Padre and use perl 5.10 (BOWTIE) 0.20 2012-04-09 - change carp dependency to 1.20 in test (BOWTIE) 0.19 2012-04-08 - fix for #1415 (WHUMANN, BOWTIE) - drop Carp to 1.20, packaging request (VOEGELAS) - add a README (BOWTIE) - remove dead code (BOWTIE) - re-factor some variables and tidy up (BOWTIE) - fix p|x to display $tring refs x \$tring (BOWTIE) 0.18 2012-03-07 - bumped to 0.18 (BOWTIE) - tweaks to POD (BOWTIE) 0.17_06 2012-02-09 - remove is for cmp_ok where values are numeric - fix 'Free to wrong pool' in tests against win32 - looking to IO::Socket::IP and ipv6 - update Makefile to use M-I-DSL - Tweaks to POD, remove unwanted comments (BOWTIE) 0.17_05 2012-01-11 - Due to issues with perl5db v1.34-5 in Perl 5.15.3-5 very messy this means list context is now naff Modify tests to cater for these anomaly's add Method get_lineinfo so that we can ask where are we! Tweaks to POD (BOWTIE) 0.17_04 2011-12-29 - remove test code in 0.17_03 that was naffing up cpan testers (BOWTIE) 0.17_03 2011-12-29 - vast changes to test files see #1367/8 (BOWTIE) - Patch for 09-io.t ticket #831 (MJGARDNER) 0.17_02 2011-12-08 - vast changes to test files (BOWTIE) 0.17_01 2011-12-06 - adjust required version for 'E' requires 5.8.6 (Note that threading support was built into the debugger as of Perl version 5.8.6 and debugger version 1.2.8.) - Oops requires 'IO::Socket' reset to '1.31' - try some other testing modules Test::Class - Tidy POD (BOWTIE) 0.16 2011-11-30 - Add Methods list_subroutine_names, set_option, get_options, module - tweak to return line & row from dot if all else fails - tweak to Makefile dependence's - Amend POD for above - Amend test to support above (BOWTIE) 0.15 2011-11-24 - removed Method listen - comment out list_subroutine_names & _set_option - Modify Method get_value to accept no values - Modify get_p_exp - Amend test to support above (BOWTIE) 0.14 2011-11-24 - Released 0.13_10 as stable 0.14 (AZAWAWI) 0.13_10 2011-11-20 - rename Method _show_help -> get_h_var rename Method get_p_ext -> get_p_exp Add tests for above (BOWTIE) 0.13_09 2011-11-17 - Add a Method get_p_ext (BOWTIE) 0.13_08 2011-11-13 - No newer ExtUtils::MakeMaker dependency. Removed a couple of unneeded test dependencies (AZAWAWI) 0.13_07 2011-11-09 - Tweaks to tests for above (BOWTIE) 0.13_06 2011-11-09 - Add Method show_view modify method show_line Add Method _show_help Tweaks to tests for above spell check POD (BOWTIE) 0.13_05 2011-11-07 - default port changed to 24642 as port 12345 registered to "Italk Chat System" (BOWTIE) - _process_line is where all the generated errors from cpantesters come from $count = 0; and some tweaks to $line to suppress errors when buffer is empty (BOWTIE) 0.13_04 2011-11-05 - Perl::Critic Error Subroutine "listen" is a homonym for bulletin function listen changed to listener (BOWTIE) - using ReuseAddr as Reuse has bean deprecated (BOWTIE) - Perl::Critic severity => 5, & severity => 4, pass now (BOWTIE) - tweak to test t/02... (BOWTIE) 0.13_03 2011-11-04 - Tweak some tests (BOWTIE) - Updates to POD use $debugger throughout instead of $d (BOWTIE) - Add a test for get_v_vars Add a test for get_y_zero Add a test for list_subroutine_names (BOWTIE) 0.13_02 2011-11-03 - re-factor eg/02-sub.pl, change sub f to sub func1 (BOWTIE) - Add a test for get_y_zero - Add a test for toggle_trace (BOWTIE) - Updates to POD to complement new Methods (BOWTIE) 0.13_01 2011-11-02 - POD add skip for perl -d c [line|sub] for perl5db.pl >= 1.34 (BOWTIE) - skip some tests t/08.... skip some tests t/04.... (BOWTIE) - development upgrade to 0.13_01 for P-P-Debug add several more methods, and t/13.... (BOWTIE) 0.12 2011-07-21 - skip some tests if ~/.perldb exists (GARU) - add an example called debugger.pl 0.11 2009-12-22 - Eliminate most of the list/scalar context separation from methods. 0.10 2009-12-20 - Add some code to debug certain test failures - Turn _prompt and _process_line into method calls - Keep the current file-name and row number in the debugger object 0.09 2009-12-18 - Add case when content of the line is shown on a separate line - Mark when a call has terminated the debugger. 0.08 2009-12-16 - Added more tests. - Fixing some tests. - set_breakpoint now returns true/false - remove_breakpoint added - list_break_watch_action added 0.07 2009-12-15 - Added more test. 0.06 2009-12-14 - Prompt is now the first return parameter - Added more tests - Added more documentation 0.05 2009-12-13 - Try to eliminate infinite loop - Try to make sure tests are not hung by calling quit at the end of each - Put the STDOUT and STDERR files in temp directory - Use Module::Install instead of Module::Build 0.04 2008-09-16 - Add more methods - Add more tests - Rename to Debug::Client - Remove the global $response variable and let users fetch the buffer using $dbg->buffer 0.03 2008-09-13 - Add debug output for tests to better understand test failures. - More tests 0.02 2008-09-13 - Replace step by step_in - Add methods step_out, step_over, get_value - Let those method return detailed data in LIST context 0.01 2008-09-13 - Initial release Debug-Client-0.29/META.yml0000644000175000000500000000231112175567257013652 0ustar kevinsrc--- abstract: 'debugger client side code for Padre, The Perl IDE.' author: - 'Kevin Dawson ' build_requires: Exporter: 5.64 ExtUtils::MakeMaker: 6.59 File::HomeDir: 1 File::Spec: 3.4 File::Temp: 0.2301 Test::CheckDeps: 0.006 Test::Class: 0.39 Test::Deep: 0.11 Test::More: 0.98 Test::Requires: 0.07 parent: 0.225 version: 0.9902 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Debug-Client no_index: directory: - eg - inc - t - xt recommends: ExtUtils::MakeMaker: 6.66 File::Spec::Functions: 3.4 List::Util : 1.27 Test::Pod: 1.48 Test::Pod::Coverage: 1.08 requires: Carp: 1.20 IO::Socket::IP: 0.21 PadWalker: 1.96 Term::ReadLine: 1.1 Term::ReadLine::Gnu: 1.2 constant: 1.21 perl: 5.10.1 resources: bugtracker: http://padre.perlide.org/trac/wiki/Tickets homepage: http://padre.perlide.org/trac/wiki/Features/Perl5Debugger license: http://dev.perl.org/licenses/ repository: http://svn.perlide.org/padre/trunk/Debug-Client/ version: 0.29 Debug-Client-0.29/README0000644000175000000500000000316412106416521013245 0ustar kevinsrcDebug-Client The README is used to introduce the module and provide instructions on how to install the module, any machine dependencies it may have (for example C compilers and installed libraries) and any other information that should be provided before the module is installed. A README file is required for CPAN modules since CPAN extracts the README file from a module distribution so that people browsing the archive can use it to get an idea of the module's uses. It is usually a good idea to provide version information here so that people can decide whether fixes for the module are worth downloading. INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc Debug::Client You can also look for information at: RT, CPAN's request tracker (report bugs here) http://rt.cpan.org/NoAuth/Bugs.html?Dist=Debug-Client AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/Debug-Client CPAN Ratings http://cpanratings.perl.org/d/Debug-Client Search CPAN http://search.cpan.org/dist/Debug-Client/ LICENSE AND COPYRIGHT Copyright (C) 2008-2011 Gabor Szabo Some parts copyright (C) 2011-2013 Kevin Dawson This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information.Debug-Client-0.29/MANIFEST0000644000175000000500000000175612175567260013540 0ustar kevinsrcChanges eg/debugger.pl eg/test17.pl inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Debug/Client.pm Makefile.PL MANIFEST This list of files META.yml README t/00-check-deps.t t/01-compile.t t/02-exports.t t/03-pod.t t/04-pod-coverage.t t/06-term.t t/07-initialize.t t/08-io.t t/10-top_tail.t t/10-top_tail_old.t t/11-add.t t/13-return.t t/14-run.t t/15-run_to_line.t t/16-run_to_sub.t t/17-stepin.t t/18-stepout.t t/19-stepover.t t/20-get_value.t t/21-toggle_trace.t t/22-subnames.t t/23-breakpoints.t t/24-y_zero.t t/25-get_v_vars.t t/26-get_x_vars.t t/27-get_p_exp.t t/28-get_h_var.t t/29-options.t t/40-test_1415-old.t t/40-test_1415.t t/99-perldb.t t/eg/01-add.pl t/eg/02-sub.pl t/eg/03-return.pl t/eg/05-io.pl t/eg/14-y_zero.pl t/eg/test_1415.pl t/lib/Debugger.pm t/lib/Test_1415.pm t/lib/Top_Tail.pm t/report-prereqs.t Debug-Client-0.29/Makefile.PL0000644000175000000500000000275012173536167014354 0ustar kevinsrcuse inc::Module::Install 1.06; name 'Debug-Client'; all_from 'lib/Debug/Client.pm'; requires_from 'lib/Debug/Client.pm'; perl_version '5.010001'; requires 'Carp' => '1.20'; requires 'IO::Socket::IP' => '0.21'; requires 'PadWalker' => '1.96'; if ($^O =~ /Win32/i) { requires 'Term::ReadLine' => '1.1'; } else { requires 'Term::ReadLine' => '1.1'; requires 'Term::ReadLine::Gnu' => '1.2'; } requires 'constant' => '1.21'; test_requires 'Exporter' => '5.64'; test_requires 'File::HomeDir' => '1'; test_requires 'File::Spec' => '3.4'; test_requires 'File::Temp' => '0.2301'; test_requires 'Test::CheckDeps' => '0.006'; test_requires 'Test::Class' => '0.39'; test_requires 'Test::Deep' => '0.11'; test_requires 'Test::More' => '0.98'; test_requires 'Test::Requires' => '0.07'; if ($^O =~ /Win32/i) { test_requires 'Win32' => '0.47'; test_requires 'Win32::Process' => '0.14'; } test_requires 'parent' => '0.225'; test_requires 'version' => '0.9902'; recommends 'ExtUtils::MakeMaker' => '6.66'; recommends 'File::Spec::Functions' => '3.4'; recommends 'List::Util ' => '1.27'; recommends 'Test::Pod' => '1.48'; recommends 'Test::Pod::Coverage' => '1.08'; homepage 'http://padre.perlide.org/trac/wiki/Features/Perl5Debugger'; bugtracker 'http://padre.perlide.org/trac/wiki/Tickets'; repository 'http://svn.perlide.org/padre/trunk/Debug-Client/'; no_index 'directory' => qw{ eg inc t xt }; WriteAll Debug-Client-0.29/lib/0002755000175000000500000000000012175567260013146 5ustar kevinsrcDebug-Client-0.29/lib/Debug/0002755000175000000500000000000012175567260014174 5ustar kevinsrcDebug-Client-0.29/lib/Debug/Client.pm0000644000175000000500000005417612175567213015761 0ustar kevinsrcpackage Debug::Client; use 5.010; use strict; use warnings FATAL => 'all'; # turn of experimental warnings no if $] > 5.017010, warnings => 'experimental::smartmatch'; use English qw( -no_match_vars ); local $OUTPUT_AUTOFLUSH = 1; our $VERSION = '0.29'; use Term::ReadLine; if ( $OSNAME eq 'MSWin32' ) { $ENV{TERM} = 'dumb'; local $ENV{PERL_RL} = ' ornaments=0'; } use utf8; use IO::Socket::IP 0.21; use Carp qw(carp croak); use constant { BLANK => qq{ }, NONE => q{}, }; ####### # new ####### sub new { my ( $class, @args ) = @_; # What class are we constructing? my $self = {}; # Allocate new memory bless $self, $class; # Mark it of the right type $self->_initialize(@args); # Call _initialize with remaining args return $self; } ####### # _initialize ####### sub _initialize { my ( $self, %args ) = @_; $self->{local_host} = $args{host} // '127.0.0.1'; $self->{local_port} = $args{port} // 24_642; #for IO::Socket::IP $self->{porto} = $args{porto} // 'tcp'; $self->{listen} = $args{listen} // 1; $self->{reuse_addr} = $args{reuse} // 1; $self->{buffer} = undef; $self->{module} = undef; # Open the socket the debugger will connect to. my $sock = IO::Socket::IP->new( LocalHost => $self->{local_host}, LocalPort => $self->{local_port}, Proto => $self->{porto}, Listen => $self->{listen}, ReuseAddr => $self->{reuse_addr}, ) or carp "Could not connect to '$self->{local_host}' '$self->{local_port}' no socket :$!"; $self->{socket} = $sock->accept(); return; } ####### # Method get_buffer ####### sub get_buffer { my $self = shift; return $self->{buffer}; } ####### # Method quit ####### sub quit { my $self = shift; return $self->_send('q'); } ####### # Method show_line ####### sub show_line { my $self = shift; $self->_send('.'); $self->_get; $self->_prompt; return $self->{buffer}; } ####### # Method get_lineinfo ####### sub get_lineinfo { my $self = shift; $self->_send('.'); $self->_get; $self->{buffer} =~ m{ ^[\w:]* # module (?:CODE[(].*[)])* # catch CODE(0x9b434a8) [(] (?[^\)]*):(?\d+) [)] # (file):(row) }smx; $self->{filename} = $+{file}; $self->{row} = $+{row}; return; } ####### # Method show_line ####### sub show_view { my $self = shift; $self->_send('v'); $self->_get; $self->_prompt; return $self->{buffer}; } ####### # Method step_in ####### sub step_in { my $self = shift; return $self->_send_get('s'); } ####### # Method step_over ####### sub step_over { my $self = shift; return $self->_send_get('n'); } ####### # Method step_out ####### sub step_out { my $self = shift; return ('Warning: Must call step_out in list context') if not wantarray; return $self->_send_get('r'); } ####### # Accessor Method get_stack_trace ####### sub get_stack_trace { my ($self) = @_; $self->_send('T'); $self->_get; $self->_prompt; return $self->{buffer}; } ####### # sub toggle_trace ####### sub toggle_trace { my ($self) = @_; $self->_send('t'); $self->_get; $self->_prompt; return $self->{buffer}; } ####### # sub list_subroutine_names ####### sub list_subroutine_names { my ( $self, $pattern ) = @_; if ( defined $pattern ) { $self->_send("S $pattern"); } else { $self->_send('S'); } $self->_get; $self->_prompt; return $self->{buffer}; } ####### # sub run ####### sub run { my ( $self, $param ) = @_; if ( defined $param ) { return $self->_send_get("c $param"); } else { return $self->_send_get('c'); } } ####### # sub set_breakpoint ####### sub set_breakpoint { my ( $self, $file, $line, $cond ) = @_; $self->_send("f $file"); $self->_get; $self->_send("b $line"); $self->_get; $self->_prompt; # if it was successful no reply given ( $self->{buffer} ) { when ( $_ =~ /^Subroutine [\w:]+ not found[.]/sxm ) { return 0; } when ( $_ =~ /^Line \d+ not breakable[.]/sxm ) { return 0; } when ( $_ =~ /^\d+ levels deep in subroutine calls!/sxm ) { return 0; } when ( $_ =~ /^Already in/m ) { return 1; } when ( $_ =~ /\S/sxm ) { # say 'Non-whitespace charter found'; return 0; } default { return 1; } } } ####### # method remove_breakpoint ####### # apparently no clear success/error report for this sub remove_breakpoint { my ( $self, $file, $line ) = @_; $self->_send("f $file"); $self->_get; $self->_send("B $line"); $self->_get; return 1; } ####### # show_breakpoints ####### sub show_breakpoints { my $self = shift; $self->_send('L'); $self->_get; $self->_prompt; return $self->{buffer}; } ####### # Accessor get_value ####### sub get_value { my ( $self, $var ) = @_; if ( not defined $var ) { $self->_send('p'); $self->_get; $self->_prompt; return $self->{buffer}; } elsif ( $var =~ /^\@/sxm or $var =~ /^\%/sxm ) { $self->_send("x \\$var"); $self->_get; $self->_prompt; return $self->{buffer}; } else { $self->_send("p $var"); $self->_get; $self->_prompt; if ( $self->{buffer} =~ m/^(?:HASH|ARRAY)/sxm ) { $self->_send("x \\$var"); $self->_get; $self->_prompt; return $self->{buffer}; } else { return $self->{buffer}; } } } ####### # sub get_p_exp ####### sub get_p_exp { my ( $self, $exp ) = @_; $self->_send("p $exp"); $self->_get; $self->_prompt; return $self->{buffer}; } ####### # sub get_y_zero ####### sub get_y_zero { my $self = shift; require PadWalker if 0; #forces PadWalker to be a requires not a test_requires # say 'running on perl '. $PERL_VERSION; if ( $PERL_VERSION >= 5.017006 ) { # say 'using y=1 instead as running on perl ' . $PERL_VERSION; $self->_send('y 1'); } else { $self->_send('y 0'); } # $self->_send('y 0'); $self->_get; $self->_prompt; return $self->{buffer}; } ####### # sub get_v_vars ####### sub get_v_vars { my ( $self, $pattern ) = @_; if ( defined $pattern ) { $self->_send("V $pattern"); } else { $self->_send('V'); } $self->_get; $self->_prompt; return $self->{buffer}; } ####### # sub get_x_vars ####### sub get_x_vars { my ( $self, $pattern ) = @_; if ( defined $pattern ) { $self->_send("X $pattern"); } else { $self->_send('X'); } $self->_get; $self->_prompt; return $self->{buffer}; } ####### # sub get_h_var ####### sub get_h_var { my ( $self, $var ) = @_; #added a flush buffer to stop help appending in an initional case $self->{buffer} = undef; if ( defined $var ) { $self->_send("h $var"); } else { $self->_send('h'); } $self->_get; #Tidy for Padre Output Panel $self->{buffer} =~ s/(\e\[4m|\e\[24m|\e\[1m|\e\[0m)//sxmg; $self->_prompt; return $self->{buffer}; } ####### # Accessor Method set_option ####### sub set_option { my ( $self, $option ) = @_; # unless ( defined $option ) { if ( not defined $option ) { return 'missing option'; } $self->_send("o $option"); $self->_get; $self->_prompt; return $self->{buffer}; } ####### # Accessor Method get_options ####### sub get_options { my $self = shift; $self->_send('o'); $self->_get; $self->_prompt; return $self->{buffer}; } ####### # Method get ####### sub get { my $self = shift; $self->_get; if (wantarray) { $self->_prompt; my ( $module, $file, $row, $content ) = $self->_process_line; return ( $module, $file, $row, $content ); } else { return $self->{buffer}; } } ####### # Method get_filename ####### sub get_filename { my $self = shift; return $self->{filename}; } ####### # Method get_row ####### sub get_row { my $self = shift; return $self->{row}; } ####### # Method module ####### sub module { my $self = shift; return $self->{module}; } ######################################### #### Internal Methods ####### # Internal Method _get ####### # TODO shall we add a time-out and/or a number to count down the number sysread calls that return 0 before deciding it is really done sub _get { my $self = shift; my $buffer = NONE; while ( $buffer !~ /DB<\d+>/ ) { my $ret = $self->{socket}->sysread( $buffer, 1024, length $buffer ); if ( not defined $ret ) { carp $!; # TODO better error handling? } if ( not $ret ) { last; } } $self->{buffer} = $buffer; return; } ####### # Internal Method _process_line ####### # Internal method that receives a reference to a scalar # containing the data printed by the debugger # If the output indicates that the debugger terminated return '' # Otherwise it returns ( $package, $file, $row, $content ); # where # $package is main:: or Some::Module:: (the current package) # $file is the full or relative path to the current file # $row is the current row number # $content is the content of the current row # see 00-internal.t for test cases sub _process_line { my $self = shift; my $buffer = $self->{buffer}; my $line = BLANK; my $module = BLANK; my $file = BLANK; my $row = BLANK; my $content = BLANK; if ( $buffer =~ /Debugged program terminated/ ) { $module = ''; $self->{module} = $module; return $module; } my @parts = split /\n/, $buffer; $line = pop @parts; #TODO $line is where all CPAN_Testers errors come from try to debug some test reports # http://www.nntp.perl.org/group/perl.cpan.testers/2009/12/msg6542852.html if ( not defined $line ) { croak("Debug::Client: Line is undef. Buffer is $self->{buffer}"); } my $cont = 0; if ($line) { if ( $line =~ /^\d+: \s* (.*)$/x ) { $cont = $1; $line = pop @parts; } } if ($line =~ m{^(?[\w:]*) # module [(] (?[^\)]*):(?\d+) [)] # (file:row) :\t? # : (?.*) # content }mx ) { ( $module, $file, $row, $content ) = ( $+{module}, $+{file}, $+{row}, $+{content} ); } # if ( $module eq BLANK || $file eq BLANK || $row eq BLANK ) { # we did not need to test for everthing if ( $module eq BLANK ) { # preserve buffer why we check where we are test_1415.pl my $preserve_buffer = $self->{buffer}; my $current_file = $self->show_line(); # $current_file =~ m/([\w:]*) \( (.*) : (\d+) .* /mgx; $current_file =~ m/(?[\w:]*) [(] (?.*) : (?\d+) .* /mgxs; $module = $+{module}; $file = $+{file}; $row = $+{row}; $self->{buffer} = $preserve_buffer; } if ($cont) { $content = $cont; } $self->{module} = $module; $self->{filename} = $file; $self->{row} = $row; return ( $module, $file, $row, $content ); } ####### # Internal Method _prompt ####### # It takes one argument which is a reference to a scalar that contains the # the text sent by the debugger. # Extracts a prompt that looks like this: DB<3> $ # puts the number from the prompt in $self->{prompt} and also returns it. # See 00-internal.t for test cases sub _prompt { my $self = shift; my $prompt; if ( $self->{buffer} =~ s/\s*DB<(?\d+)>\s*$// ) { $prompt = $+{prompt}; } chomp $self->{buffer}; $self->{prompt} = $prompt; return $self->{prompt}; } ####### # Internal Method _send ####### sub _send { my ( $self, $input ) = @_; $self->{socket}->print( $input . "\n" ); return 1; } ####### # Internal Method _send_get # send then get ####### sub _send_get { my ( $self, $input ) = @_; $self->_send($input); return $self->get; } ####### # Internal Method __send_padre # hidden undocumented, used for dev ###### sub __send { my ( $self, $input ) = @_; $self->_send($input); $self->_get; $self->_prompt; return $self->{buffer}; } ####### # Internal Method __send_np # hidden undocumented, used for dev ###### sub __send_np { my ( $self, $input ) = @_; $self->_send($input); $self->_get; return $self->{buffer}; } 1; __END__ =pod =encoding utf8 =head1 NAME Debug::Client - debugger client side code for Padre, The Perl IDE. =head1 VERSION This document describes Debug::Client version: 0.29 =head1 SYNOPSIS use Debug::Client; my $debugger = Debug::Client->new(host => $host, port => $port); Where $host is the host-name to be used by the script under test (SUT) to access the machine where Debug::Client runs. If they are on the same machine this should be C. $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 was 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 =head2 Example my $script = 'script_to_debug.pl'; my @args = ('param', 'param'); my $perl = $^X; # the perl might be a different perl my $host = '127.0.0.1'; my $port = 24642; 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->listener; my $out = $debugger->get; $out = $debugger->step_in; # ... =head1 DESCRIPTION This is a DEVELOPMENT Release only, you have been warned! The primary use of this module is to provide debugger functionality for Padre 0.98 and beyond, This module has been tested against Perl 5.18.0 =head1 METHODS =over 4 =item new The constructor can get two parameters: host and port. my $debugger = Debug::Client->new; my $debugger = Debug::Client->new(host => 'remote.host.com', port => 24642); =item get_buffer Returns the content of the buffer since the last command $debugger->get_buffer; =item quit $debugger->quit(); =item show_line . (dot) Return the internal debugger pointer to the line last executed, and print out that line. $debugger->show_line(); =item get_lineinfo Return the internal debugger pointer to the line last executed, and generate file-name and row for where are we now. trying to use perl5db line-info in naff way, $debugger->get_lineinfo(); Then use the following as and when. $debugger->get_filename; $debugger->get_row; to get filename and row for ide due to changes in perl5db v1.35 see perl5156delta =item show_view v [line] View a few lines of code around the current line. $debugger->show_view(); =item step_in s [expr] Single step. Executes until the beginning of another statement, descending into subroutine calls. If an expression is supplied that includes function calls, it too will be single-stepped. $debugger->step_in(); Expressions not supported. =item step_over $debugger->step_over(); =item 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 =item get_stack_trace Sends the stack trace command C 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. =item toggle_trace Sends the stack trace command C Toggle trace mode. $debugger->toggle_trace(); =item list_subroutine_names Sends the stack trace command C [[!]pattern] List subroutine names [not] matching pattern. =item run $debugger->run; Will run till the next breakpoint or watch or the end of the script. (Like pressing c in the debugger). $debugger->run($param) =item set_breakpoint $debugger->set_breakpoint($file, $line, $condition); I<$condition is not currently used> =item remove_breakpoint $debugger->remove_breakpoint( $self, $file, $line ); =item show_breakpoints The data as (L) prints in the command line debugger. $debugger->show_breakpoints(); =item get_value my $value = $debugger->get_value($x); If $x is a scalar value, $value will contain that value. If it is a reference to a ARRAY or HASH then $value should be the value of that reference? =item get_p_exp p expr Same as print {$DB::OUT} expr in the current package. In particular, because this is just Perl's own print function, this means that nested data structures and objects are not dumped, unlike with the x command. The DB::OUT filehandle is opened to /dev/tty, regardless of where STDOUT may be redirected to. From perldebug, but defaulted to y 0 $debugger->get_p_exp(); =item get_y_zero From perldebug, but defaulted to y 0 y [level [vars]] Display all (or some) lexical variables (mnemonic: my variables) in the current scope or level scopes higher. You can limit the variables that you see with vars which works exactly as it does for the V and X commands. Requires that the PadWalker module be installed Output is pretty-printed in the same style as for V and the format is controlled by the same options. $debugger->get_y_zero(); which is now y=1 since perl 5.17.6, =item get_v_vars V [pkg [vars]] Display all (or some) variables in package (defaulting to main ) using a data pretty-printer (hashes show their keys and values so you see what's what, control characters are made printable, etc.). Make sure you don't put the type specifier (like $ ) there, just the symbol names, like this: $debugger->get_v_vars(regex); =item get_x_vars X [vars] Same as V currentpackage [vars] $debugger->get_x_vars(regex); =item get_h_var Enter h or `h h' for help, For more help, type h cmd_letter, optional var $debugger->get_h_var(); =item set_option o booloption ... Set each listed Boolean option to the value 1 . o anyoption? ... Print out the value of one or more options. o option=value ... Set the value of one or more options. If the value has internal white-space, it should be quoted. For example, you could set o pager="less -MQeicsNfr" to call less with those specific options. You may use either single or double quotes, but if you do, you must escape any embedded instances of same sort of quote you began with, as well as any escaping any escapes that immediately precede that quote but which are not meant to escape the quote itself. In other words, you follow single-quoting rules irrespective of the quote; eg: o option='this isn\'t bad' or o option="She said, \"Isn't it?\"" . For historical reasons, the =value is optional, but defaults to 1 only where it is safe to do so--that is, mostly for Boolean options. It is always better to assign a specific value using = . The option can be abbreviated, but for clarity probably should not be. Several options can be set together. See Configurable Options for a list of these. $debugger->set_option(); =item get_options o Display all options. $debugger->get_options(); =item 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. =item get_filename $debugger->get_filename(); =item get_row $debugger->get_row(); =item module $debugger->module(); =back =head2 Internal Methods =over 4 =item * _get =item * _process_line =item * _prompt =item * _send =item * _send_get =back =head1 BUGS AND LIMITATIONS If you get any issues installing, try install L first. Warning if you use List request you may get spurious results. When using against perl5db.pl v1.35 list mode gives an undef response, also leading single quote now correct. Tests are skipped for list mode against v1.35 now. Debug::Client 0.12 tests are failing, due to changes in perl debugger, when using perl5db.pl v1.34 Debug::Client 0.13_01 skips added to failing tests. c [line|sub] Continue, optionally inserting a one-time-only breakpoint at the specified line or subroutine. c is now ignoring options [line|sub] and just performing c on it's own I Has bean deprecated since 0.13_04 and all future version starting with v0.14 Perl::Critic Error Subroutine name is a homonym for built-in function Use $debugger->listener instead It will work against perl 5.17.6-7 with rindolf patch 7a0fe8d applied for watches =head1 AUTHORS Kevin Dawson Ebowtie@cpan.orgE Gabor Szabo Egabor@szabgab.comE =head2 CONTRIBUTORS Breno G. de Oliveira Egaru at cpan.orgE Ahmad M. Zawawi Eahmad.zawawi@gmail.comE Mark Gardner Emjgardner@cpan.orgE Wolfram Humann Ewhumann@cpan.orgE Adam Kennedy Eadamk@cpan.orgE Alexandr Ciornii Ealexchorny@gmail.comE =head1 COPYRIGHT Copyright 2008-2011 Gabor Szabo Some parts Copyright E 2011-2013 Kevin Dawson and CONTRIBUTORS as listed above. =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 remote-port.pl script from Pro Perl Debugging written by Richard Foley. =head1 See Also L L L =cut Debug-Client-0.29/t/0002755000175000000500000000000012175567260012643 5ustar kevinsrcDebug-Client-0.29/t/02-exports.t0000644000175000000500000000114112143475061014736 0ustar kevinsrcuse strict; use warnings FATAL => 'all'; use English qw( -no_match_vars ); local $OUTPUT_AUTOFLUSH = 1; use Test::More tests => 2; BEGIN { use_ok( 'Debug::Client' ); } ###### # let's check our subs/methods. ###### my @subs = qw( get_buffer get_filename get get_h_var get_lineinfo get_options get_p_exp get_stack_trace get_v_vars get_value get_x_vars get_y_zero list_subroutine_names module new quit remove_breakpoint get_row run set_breakpoint set_option show_breakpoints show_line show_view show_line step_in step_over toggle_trace ); can_ok( 'Debug::Client', @subs ); done_testing(); __END__ Debug-Client-0.29/t/06-term.t0000644000175000000500000000351412175256505014220 0ustar kevinsrcuse strict; use warnings FATAL => 'all'; use English qw( -no_match_vars ); local $OUTPUT_AUTOFLUSH = 1; use version; use Test::More tests => 7; BEGIN { use_ok( 'Term::ReadLine', '1.07' ); } diag("\nInfo: Perl $PERL_VERSION"); diag("Info: OS $OSNAME"); SKIP: { skip 'Skipping Columns & Lines as we are not running on win32', 2 if $OSNAME ne 'MSWin32'; is( $ENV{COLUMNS}, undef, '$ENV{COLUMS} is undefined' ); is( $ENV{LINES}, undef, '$ENV{LINES} is undefined' ); } is( $ENV{PERL_RL}, undef, '$ENV{PERL_RL} is undefined' ); { eval 'use Term::ReadLine::Gnu'; if ($EVAL_ERROR) { diag 'Info: Term::ReadLine::Gnu is not installed'; } else { diag 'Info: Term::ReadLine::Gnu installed'; } } SKIP: { eval { require Term::ReadLine::Gnu }; skip 'Term::ReadLine::Gnu not installed', 2 if $EVAL_ERROR; use_ok('Term::ReadLine::Gnu'); cmp_ok( version->parse($Term::ReadLine::Gnu::VERSION), 'ge', 0, 'Term::ReadLine::Gnu version = ' . version->parse($Term::ReadLine::Gnu::VERSION) ); } { my $term; eval { $term = Term::ReadLine->new('none') }; if ($EVAL_ERROR) { diag 'Warning: If test fail consider installing Term::ReadLine::Gnu' if $OSNAME ne 'MSWin32'; local $ENV{PERL_RL} = ' ornaments=0'; diag 'INFO: Setting $ENV{PERL_RL} -> ' . $ENV{PERL_RL}; } else { diag 'Info: Using ReadLine implementation -> ' . $term->ReadLine; } } # Patch for Debug::Client ticket #831 (MJGARDNER) # Turn off ReadLine ornaments ##local $ENV{PERL_RL} = ' ornaments=0'; if ( !exists $ENV{TERM} ) { if ( $OSNAME eq 'MSWin32' ) { $ENV{TERM} = 'dumb'; diag 'INFO: Setting $ENV{TERM} -> ' . $ENV{TERM}; } else { local $ENV{PERL_RL} = ' ornaments=0'; diag 'INFO: Setting $ENV{PERL_RL} -> ' . $ENV{PERL_RL}; } } diag 'INFO: $ENV{TERM} -> ' . $ENV{TERM}; ok( $ENV{TERM} !~ /undef/, '$ENV{TERM} is set to -> ' . $ENV{TERM} ); done_testing(); __END__ Debug-Client-0.29/t/14-run.t0000644000175000000500000000225112144675432014051 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use t::lib::Debugger; my ( $dir, $pid ) = start_script('t/eg/02-sub.pl'); use Test::More; use Test::Deep; plan( tests => 3 ); my $debugger = start_debugger(); { my $out = $debugger->get; # Loading DB routines from perl5db.pl version 1.28 # Editor support available. # # Enter h or `h h' for help, or `man perldebug' for more help. # # main::(t/eg/02-sub.pl:4): $| = 1; # DB<1> like( $out, qr/Loading DB routines from perl5db.pl version/, 'loading line' ); like( $out, qr{main::\(t/eg/02-sub.pl:4\):\s*\$\| = 1;}, 'line 4' ); } { my @out = $debugger->step_in; cmp_deeply( \@out, [ 'main::', 't/eg/02-sub.pl', 6, 'my $x = 11;' ], 'line 6' ) or diag( $debugger->get_buffer ); } { # Debugged program terminated. Use q to quit or R to restart, # use o inhibit_exit to avoid stopping after program termination, # h q, h R or h o to get additional info. # DB<1> my $out = $debugger->run; # like( $out, qr/Debugged program terminated/ ); } { my $out = $debugger->quit; # like( $out, qr/1/, 'debugger quit' ); } done_testing(); 1; __END__ Debug-Client-0.29/t/report-prereqs.t0000644000175000000500000000406612175256234016022 0ustar kevinsrcuse strict; use warnings; #BEGIN { # unless ( $ENV{RELEASE_TESTING} ) { # require Test::More; # Test::More::plan( # skip_all => 'these tests are for release candidate testing' ); # } #} our $VERSION = '0.04'; use English qw( -no_match_vars ); local $OUTPUT_AUTOFLUSH = 1; # use Data::Printer {caller_info => 1, colored => 1,}; use Test::More; use Test::Requires { 'ExtUtils::MakeMaker' => 6.64 }; use Test::Requires { 'File::Spec::Functions' => 3.40 }; use Test::Requires { 'List::Util ' => 1.27 }; use List::Util qw/max/; my @modules = qw( Carp Exporter File::HomeDir File::Spec File::Temp IO::Socket::IP List::Util PadWalker Term::ReadLine Test::CheckDeps Test::Class Test::Deep Test::More Test::Requires Win32 Win32::Process parent version ); # replace modules with dynamic results from MYMETA.json if we can # (hide CPAN::Meta from prereq scanner) my $cpan_meta = "CPAN::Meta"; if ( -f "MYMETA.json" && eval "require $cpan_meta" ) { ## no critic if ( my $meta = eval { CPAN::Meta->load_file("MYMETA.json") } ) { my $prereqs = $meta->prereqs; #p $prereqs; my %uniq = map { $_ => 1 } map { keys %$_ } map { values %$_ } values %$prereqs; $uniq{$_} = 1 for @modules; # don't lose any static ones @modules = sort keys %uniq; } } my @reports = [qw/Version Module/]; for my $mod (@modules) { next if $mod eq 'perl'; my $file = $mod; $file =~ s{::}{/}g; $file .= ".pm"; my ($prefix) = grep { -e catfile( $_, $file ) } @INC; if ($prefix) { my $ver = MM->parse_version( catfile( $prefix, $file ) ); $ver = "undef" unless defined $ver; # Newer MM should do this anyway push @reports, [ $ver, $mod ]; } else { push @reports, [ "missing", $mod ]; } } if (@reports) { my $vl = max map { length $_->[0] } @reports; my $ml = max map { length $_->[1] } @reports; splice @reports, 1, 0, [ "-" x $vl, "-" x $ml ]; diag "Prerequisite Report:\n", map { sprintf( "  %*s %*s\n", $vl, $_->[0], -$ml, $_->[1] ) } @reports; } pass; done_testing(); __END__ pass; # vim: ts=2 sts=2 sw=2 et: Debug-Client-0.29/t/00-check-deps.t0000644000175000000500000000042212175255346015246 0ustar kevinsrcuse strict; use warnings FATAL => 'all'; use English qw( -no_match_vars ); local $OUTPUT_AUTOFLUSH = 1; use Test::More; use Test::CheckDeps; check_dependencies(); if (1) { BAIL_OUT("Missing dependencies") if !Test::More->builder->is_passing; } done_testing; __END__ Debug-Client-0.29/t/21-toggle_trace.t0000644000175000000500000000074712142677545015717 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use Test::More; use Test::Deep; plan( tests => 2 ); #Top use t::lib::Debugger; start_script('t/eg/14-y_zero.pl'); my $debugger; $debugger = start_debugger(); my $out = $debugger->get; #Body like( $debugger->toggle_trace, qr/Trace = on/, 'Trace on' ); like( $debugger->toggle_trace, qr/Trace = off/, 'Trace off' ); #Tail $debugger->quit; done_testing(); 1; __END__ Debug-Client-0.29/t/40-test_1415.t0000644000175000000500000000037512145554715014703 0ustar kevinsrcuse strict; use warnings FATAL => 'all'; use English qw( -no_match_vars ); local $OUTPUT_AUTOFLUSH = 1; use FindBin qw($Bin); use lib map "$Bin/$_", 'lib', '../lib'; use t::lib::Test_1415; # run all the test methods Test::Class->runtests; __END__ Debug-Client-0.29/t/11-add.t0000644000175000000500000000444012175263255013774 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use Test::More tests => 10; use Test::Deep; use t::lib::Debugger; # Testing step_in (s) and show_line (.) on a simple script my ( $dir, $pid ) = start_script('t/eg/01-add.pl'); # diag("PID $pid"); my $debugger = start_debugger(); isa_ok( $debugger, 'Debug::Client' ); { my $out = $debugger->get; # Loading DB routines from perl5db.pl version 1.28 # Editor support available. # # Enter h or `h h' for help, or `man perldebug' for more help. # # main::(t/eg/01-add.pl:4): $| = 1; # DB<1> # Loading DB routines from perl5db.pl version 1.32 # Editor support available. # # Enter h or `h h' for help, or `man perldebug' for more help. # # main::(01-add.pl:4): $| = 1; # DB<1> # Loading DB routines from perl5db.pl version 1.33 # Editor support available. # # Enter h or `h h' for help, or `man perldebug' for more help. # # main::(01-add.pl:4): $| = 1; # DB<1> like( $out, qr{Loading DB routines from perl5db.pl version}, 'loading line' ); like( $out, qr{main::\(t/eg/01-add.pl:4\):\s*\$\| = 1;}, 'line 4' ); } { my @out = $debugger->step_in; # diag("@out"); # cmp_deeply( \@out, [ 'main::', 't/eg/01-add.pl', 6, 'my $x = 1;' ], 'line 6' ) # or diag( $debugger->get_buffer ); } { my $out = $debugger->step_in; ok( $out =~ s/DB<\d+> $/DB<> /, 'replace number as it can be different on other versions of perl' ); is( $out, "main::(t/eg/01-add.pl:7):\tmy \$y = 2;\n DB<> ", 'step_in line 7' ) or do { $out =~ s/ /S/g; diag($out); } } { my $out = $debugger->show_line; # diag($out); is( $out, "main::(t/eg/01-add.pl:7):\tmy \$y = 2;", 'show_line line 7' ) or diag( $debugger->get_buffer ); } { my $out = $debugger->show_view; # diag($out); is( $out, "4: \$| = 1; 5 6: my \$x = 1; 7==> my \$y = 2; 8: my \$z = \$x + \$y; 9 10: 1; 11 12 __END__", 'show_view8' ) or diag( $debugger->get_buffer ); } { my $out = $debugger->get_h_var; like( $out, qr{List/search source lines:}, 'get_h_var' ); } { my @out = $debugger->step_in; cmp_deeply( \@out, [ 'main::', 't/eg/01-add.pl', 8, 'my $z = $x + $y;' ], 'line 8' ) or diag( $debugger->get_buffer ); } { my $out = $debugger->quit; like( $out, qr/1/, 'debugger quit' ); } done_testing(); 1; __END__ Debug-Client-0.29/t/22-subnames.t0000644000175000000500000000103512073375225015056 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use Test::More; use Test::Deep; plan( tests => 2 ); #Top use t::lib::Debugger; start_script('t/eg/14-y_zero.pl'); my $debugger; $debugger = start_debugger(); my $out = $debugger->get; #Body like( $debugger->list_subroutine_names(), qr{Term::ReadLine}, 'S module' ); like( $debugger->list_subroutine_names('strict'), qr{strict}, 'S module plus regex' ); #Tail $debugger->quit; done_testing(); 1; __END__ Debug-Client-0.29/t/10-top_tail.t0000644000175000000500000000037412145554755015065 0ustar kevinsrcuse strict; use warnings FATAL => 'all'; use English qw( -no_match_vars ); local $OUTPUT_AUTOFLUSH = 1; use FindBin qw($Bin); use lib map "$Bin/$_", 'lib', '../lib'; use t::lib::Top_Tail; # run all the test methods Test::Class->runtests; __END__ Debug-Client-0.29/t/20-get_value.t0000644000175000000500000000177712022167633015223 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use Test::More; use Test::Deep; plan( tests => 6 ); #Top use t::lib::Debugger; start_script('t/eg/02-sub.pl'); my $debugger; $debugger = start_debugger(); my $out = $debugger->get; #Body my @out; $debugger->step_in; $debugger->step_in; $out = $debugger->get_value(); is( $out, '', 'nought' ); $out = $debugger->get_value('19+23'); cmp_ok( $out, '==', '42', '19+23=42 the answer' ); $debugger->__send('$abc = 23'); $out = $debugger->get_value('$abc'); cmp_ok( $out, '==', '23', 'we just set a variable $abc = 23' ); $debugger->__send('@qwe = (23, 42)'); $out = $debugger->get_value('@qwe'); like( $out, qr/42/, 'get_value of array' ); $out = $debugger->get_value('%h'); like( $out, qr/empty hash/, 'empty hash' ); $debugger->__send_np('%h = (fname => "foo", lname => "bar")'); $out = $debugger->get_value('%h'); like( $out, qr/bar/, 'hash' ); #Tail $debugger->quit; done_testing(); 1; __END__ Debug-Client-0.29/t/01-compile.t0000644000175000000500000000164012175255407014672 0ustar kevinsrcuse strict; use warnings FATAL => 'all'; use English qw( -no_match_vars ); local $OUTPUT_AUTOFLUSH = 1; use Test::More tests => 18; BEGIN { use_ok('Debug::Client'); use_ok('t::lib::Debugger'); use_ok( 'Carp', '1.20' ); use_ok( 'IO::Socket::IP', '0.21' ); use_ok( 'PadWalker', '1.96' ); use_ok( 'Term::ReadLine', '1.1' ); use_ok( 'constant', '1.21' ); use_ok( 'Exporter', '5.64' ); use_ok( 'File::HomeDir', '1' ); use_ok( 'File::Spec', '3.4' ); use_ok( 'File::Temp', '0.2301' ); use_ok( 'Test::CheckDeps', '0.006' ); use_ok( 'Test::Class', '0.39' ); use_ok( 'Test::Deep', '0.11' ); use_ok( 'Test::More', '0.98' ); use_ok( 'Test::Requires', '0.07' ); use_ok( 'parent', '0.225' ); use_ok( 'version', '0.9902' ); } diag("Info: Testing Debug::Client $Debug::Client::VERSION"); diag("Info: Perl $PERL_VERSION"); done_testing(); __END__ Debug-Client-0.29/t/13-return.t0000644000175000000500000000742212144675621014570 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use t::lib::Debugger; my ( $dir, $pid ) = start_script('t/eg/03-return.pl'); use Test::More; use Test::Deep; plan( tests => 12 ); my $debugger = start_debugger(); my $perl5db_ver; { my $out = $debugger->get; $out =~ m/(?1.\d{2})(_\d{2})*$/m; $perl5db_ver = $+{ver} // 0; # Loading DB routines from perl5db.pl version 1.28 # Editor support available. # # Enter h or `h h' for help, or `man perldebug' for more help. # # main::(t/eg/01-add.pl:4): $| = 1; # DB<1> like( $out, qr/Loading DB routines from perl5db.pl version/, 'loading line' ); like( $out, qr{main::\(t/eg/03-return.pl:4\):\s*\$\| = 1;}, 'line 4' ); } { my @out = $debugger->step_in; cmp_deeply( \@out, [ 'main::', 't/eg/03-return.pl', 6, 'my $x = 11;' ], 'line 6' ) or diag( $debugger->get_buffer ); } { my @out = $debugger->step_in; cmp_deeply( \@out, [ 'main::', 't/eg/03-return.pl', 7, 'my $q = f("foo\nbar");' ], 'line 7' ) or diag( $debugger->get_buffer ); } { SKIP: { skip( "perl5db v$perl5db_ver dose not support list context", 1 ) unless $perl5db_ver < 1.35; my @out = $debugger->step_in; cmp_deeply( \@out, [ 'main::f', 't/eg/03-return.pl', 16, ' my ($in) = @_;' ], 'line 16' ) or diag( $debugger->get_buffer ); } } { SKIP: { skip( "perl5db v$perl5db_ver dose not support list context", 1 ) unless $perl5db_ver < 1.35; my @out = $debugger->step_out; cmp_deeply( \@out, [ 'main::', 't/eg/03-return.pl', 8, '$x++;', ], 'line 8' ) or diag( $debugger->get_buffer ); } } { SKIP: { skip( "perl5db v$perl5db_ver dose not support list context", 1 ) unless $perl5db_ver < 1.35; my @out = $debugger->step_in; cmp_deeply( \@out, [ 'main::', 't/eg/03-return.pl', 9, q{my @q = g( 'baz', "foo\nbar", 'moo' );} ], 'line 9' ) or diag( $debugger->get_buffer ); } } { SKIP: { skip( "perl5db v$perl5db_ver dose not support list context", 1 ) unless $perl5db_ver < 1.35; my @out = $debugger->step_in; cmp_deeply( \@out, [ 'main::g', 't/eg/03-return.pl', 22, ' my (@in) = @_;' ], 'line 22' ) or diag( $debugger->get_buffer ); } } { SKIP: { skip( "perl5db v$perl5db_ver dose not support list context", 1 ) unless $perl5db_ver < 1.35; my @out = $debugger->step_out; my $expected = q(0 'baz' 1 'foo bar' 2 'moo'); cmp_deeply( \@out, [ 'main::', 't/eg/03-return.pl', 10, '$x++;' ], 'line 10' ) or diag( $debugger->get_buffer ); } } { SKIP: { skip( "perl5db v$perl5db_ver dose not support list context", 1 ) unless $perl5db_ver < 1.35; my @out = $debugger->step_in; cmp_deeply( \@out, [ 'main::', 't/eg/03-return.pl', 11, q{my %q = h( bar => "foo\nbar", moo => 42 );} ], 'line 11' ) or diag( $debugger->get_buffer ); } } { SKIP: { skip( "perl5db v$perl5db_ver dose not support list context", 1 ) unless $perl5db_ver < 1.35; my @out = $debugger->step_in; cmp_deeply( \@out, [ 'main::h', 't/eg/03-return.pl', 28, ' my (%in) = @_;' ], 'line 28' ) or diag( $debugger->get_buffer ); } } { SKIP: { skip( "perl5db v$perl5db_ver dose not support list context", 1 ) unless $perl5db_ver < 1.35; my @out = $debugger->step_out; my $received = $out[4]; $out[4] = ''; # TODO check how to test the return data in this case as it looks like an array cmp_deeply( \@out, [ 'main::', 't/eg/03-return.pl', 12, '$x++;', '' ], 'line 12' ) or diag( $debugger->get_buffer ); } } { # Debugged program terminated. Use q to quit or R to restart, # use o inhibit_exit to avoid stopping after program termination, # h q, h R or h o to get additional info. # DB<1> my $out = $debugger->step_in; # like( $out, qr/Debugged program terminated/ ); } { my $out = $debugger->quit; # like( $out, qr/1/, 'debugger quit' ); } done_testing(); 1; __END__ Debug-Client-0.29/t/23-breakpoints.t0000644000175000000500000000203212022167633015555 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use Test::More; use Test::Deep; plan( tests => 7 ); #Top use t::lib::Debugger; start_script('t/eg/03-return.pl'); my $debugger; $debugger = start_debugger(); my $out = $debugger->get; #Body $debugger->step_in; ok( $debugger->set_breakpoint( 't/eg/03-return.pl', 'g' ), 'set_breakpoint' ); ok( $debugger->show_breakpoints() =~ m{t/eg/03-return.pl:}, 'show_breakpoints' ); $debugger->run; #lets ask debugger where we are then :) like( $debugger->show_line(), qr/return.pl:22/, 'check breakpoint' ); ok( $debugger->remove_breakpoint( 't/eg/03-return.pl', 'g' ), 'remove breakpoint' ); ok( $debugger->show_breakpoints() =~ m{t/eg/03-return.pl:}, 'show_breakpoints' ); ok( !$debugger->set_breakpoint( 't/eg/03-return.pl', 'missing' ), 'set_breakpoint against missing sub' ); ok( !$debugger->set_breakpoint( 't/eg/03-return.pl', '03' ), 'set_breakpoint line not breakable' ); #Tail $debugger->quit; done_testing(); 1; __END__ Debug-Client-0.29/t/19-stepover.t0000644000175000000500000000176212046207434015121 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use Test::More; use Test::Deep; plan( tests => 3 ); #Top use t::lib::Debugger; start_script('t/eg/02-sub.pl'); my $debugger; $debugger = start_debugger(); my $out = $debugger->get; $out =~ m/(?<=[version])\s*(?1.\d{2})/m; my $perl5db_ver = $+{ver}; #Body $debugger->run(8); my @out = $debugger->step_over; SKIP: { skip( "perl5db $] dose not support c [line|sub]", 1 ) if $] =~ m/5.01500(3|4|5)/; SKIP: { skip( "perl5db v$perl5db_ver dose not support list context", 1 ) if $perl5db_ver == 1.35; cmp_deeply( \@out, [ 'main::', 't/eg/02-sub.pl', 9, 'my $z = $x + $y;' ], 'stepover line 9' ); } } $debugger->get_lineinfo; SKIP: { skip( "perl5db $] dose not support c [line|sub]", 1 ) if $] =~ m/5.01500(3|4|5)/; ok( $debugger->get_row == 9, 'row = 9' ); } ok( $debugger->get_filename =~ m/02-sub/, 'filename = 02-sub.pl' ); #Tail $debugger->quit; done_testing(); 1; __END__ Debug-Client-0.29/t/25-get_v_vars.t0000644000175000000500000000104112022167633015374 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use Test::More; use Test::Deep; plan( tests => 2 ); #Top use t::lib::Debugger; start_script('t/eg/14-y_zero.pl'); my $debugger; $debugger = start_debugger(); $debugger->get; $debugger->set_breakpoint( 't/eg/14-y_zero.pl', '14' ); $debugger->run; #Body ok( $debugger->get_v_vars('$0') =~ m/14-y_zero.pl/, 'V $0' ); ok( $debugger->get_v_vars() =~ m/14-y_zero.pl/, 'V' ); #Tail $debugger->quit; done_testing(); 1; __END__ Debug-Client-0.29/t/29-options.t0000644000175000000500000000162312022167633014742 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use Test::More; use Test::Deep; plan( tests => 4 ); #Top use t::lib::Debugger; start_script('t/eg/14-y_zero.pl'); my $debugger; $debugger = start_debugger(); $debugger->get; #Body my $out; $out = $debugger->get_options(); ok( $out =~ m/CommandSet.=.'(\d+)'/s, 'get options' ); diag("Info: ComamandSet = '$1'"); $debugger->set_breakpoint( 't/eg/14-y_zero.pl', '14' ); $out = $debugger->set_option('frame=2'); like( $out, qr/frame.=.'2'/s, 'set options' ); my @out; eval { $debugger->run }; if ($@) { diag($@); } else { diag(@out); local $TODO = "Array ref request"; } $out = $debugger->set_option('frame=0'); like( $out, qr/frame.=.'0'/s, 'reset options' ); $out = $debugger->set_option(); like( $out, qr/missing/s, 'missing option' ); #Tail $debugger->quit; done_testing(); 1; __END__ Debug-Client-0.29/t/16-run_to_sub.t0000644000175000000500000000216612144675363015436 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use t::lib::Debugger; my $pid = start_script('t/eg/02-sub.pl'); use Test::More; use Test::Deep; plan( tests => 4 ); my $debugger = start_debugger(); my $perl5db_ver; { my $out = $debugger->get; $out =~ m/(?1.\d{2})(?_\d{2})*$/m; $perl5db_ver = $+{ver} // 0; like( $out, qr/Loading DB routines from perl5db.pl version/, 'loading line' ); like( $out, qr{main::\(t/eg/02-sub.pl:4\):\s*\$\| = 1;}, 'line 4' ); } { my @out = $debugger->step_in; cmp_deeply( \@out, [ 'main::', 't/eg/02-sub.pl', 6, 'my $x = 11;' ], 'line 6' ) or diag( $debugger->get_buffer ); } SKIP: { skip( "perl5db $] dose not support c [line|sub]", 1 ) if $] =~ m/5.01500(3|4|5)/; SKIP: { skip( "perl5db v$perl5db_ver dose not support list context", 1 ) if $perl5db_ver == 1.35; my @out = $debugger->run('func1'); cmp_deeply( \@out, [ 'main::func1', 't/eg/02-sub.pl', 16, ' my ( $q, $w ) = @_;' ], 'line 16' ) or diag( $debugger->get_buffer ); } } { $debugger->run; $debugger->quit; } done_testing(); 1; __END__ Debug-Client-0.29/t/26-get_x_vars.t0000644000175000000500000000110612022167633015401 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use Test::More; use Test::Deep; plan( tests => 2 ); #Top use t::lib::Debugger; start_script('t/eg/14-y_zero.pl'); my $debugger; $debugger = start_debugger(); $debugger->get; $debugger->set_breakpoint( 't/eg/14-y_zero.pl', '14' ); $debugger->run; #Body ok( $debugger->get_x_vars('!(ENV|SIG|INC)') =~ m/14-y_zero.pl/, 'X !(ENV|SIG|INC)' ); ok( $debugger->get_x_vars() =~ m/14-y_zero.pl/, 'X' ); #Tail $debugger->quit; done_testing(); 1; __END__ Debug-Client-0.29/t/99-perldb.t0000644000175000000500000000104512142676416014533 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use Test::More tests => 1; use t::lib::Debugger; if (rc_file) { diag(''); diag('***************************************'); diag('** YOU SEEM TO HAVE A ".perldb" FILE **'); diag('** IN YOUR HOME DIRECTORY. IF YOU **'); diag('** SEE TEST FAILURES, PLEASE MOVE IT **'); diag('** SOMEWHERE ELSE, TRY AGAIN AND **'); diag('** RESTORE IT AFTER INSTALLATION. **'); diag('***************************************'); } ok 1; Debug-Client-0.29/t/08-io.t0000644000175000000500000000506112153212657013655 0ustar kevinsrcuse strict; use warnings FATAL => 'all'; use English qw( -no_match_vars ); local $OUTPUT_AUTOFLUSH = 1; use Test::More tests => 12; use Test::Deep; use t::lib::Debugger; my ( $dir, $pid ) = start_script('t/eg/05-io.pl'); my $path = $dir; if ( $OSNAME =~ /Win32/i ) { require Win32; $path = Win32::GetLongPathName($dir); } # Patch for Debug::Client ticket #831 (MJGARDNER) # Turn off ReadLine ornaments ##local $ENV{PERL_RL} = ' ornaments=0'; ##$ENV{TERM} = 'dumb' if ! exists $ENV{TERM}; my $debugger = t::lib::Debugger::start_debugger(); SCOPE:{ my $out = $debugger->get; like( $out, qr/Loading DB routines from perl5db.pl version/, 'loading line' ); like( $out, qr{main::\(t/eg/05-io.pl:4\):\s*\$\| = 1;}, 'line 4' ); } # diag("Info: Perl version '$]'"); old # diag("Info: Perl version '$^V'"); new my $prefix = ( substr( $] , 0, 5 ) eq '5.008006' ) ? "Default die handler restored.\n" : ''; # diag("prefix: $prefix"); # see relevant fail report here: # http://www.nntp.perl.org/group/perl.cpan.testers/2009/12/msg6486949.html # http://www.nntp.perl.org/group/perl.cpan.testers/2009/12/msg6481372.html { my @out = $debugger->step_in; ## diag ( "\n @out" ); cmp_deeply( \@out, [ 'main::', 't/eg/05-io.pl', 6, 'print "One\n";' ], 'line 6' ) or diag( $debugger->get_buffer ); ## diag( $debugger->get_buffer ); } { my @out = $debugger->step_in; cmp_deeply( \@out, [ 'main::', 't/eg/05-io.pl', 7, 'print STDERR "Two\n";' ], 'line 7' ) or diag( $debugger->get_buffer ); } { my $out = slurp("$path/out"); # diag("output: $out"); is( $out, "One\n", 'STDOUT has One' ); my $err = slurp("$path/err"); # diag("error: $err"); # is( $err, 'STDERR is empty' ); is( $err, "${prefix}", 'STDERR is empty' ); } { my @out = $debugger->step_in; cmp_deeply( \@out, [ 'main::', 't/eg/05-io.pl', 8, 'print "Three\n";' ], 'line 8' ) or diag( $debugger->get_buffer ); } { my $out = slurp("$path/out"); # diag("output: $out"); is( $out, "One\n", 'STDOUT has One' ); my $err = slurp("$path/err"); # diag("error: $err"); # is( $err, "Two\n", 'STDERR has Two' ); is( $err, "${prefix}Two\n", 'STDERR has Two' ); } { my @out = $debugger->step_in; cmp_deeply( \@out, [ 'main::', 't/eg/05-io.pl', 9, 'print "Four";' ], 'line 9' ) or diag( $debugger->get_buffer ); } { my $out = slurp("$path/out"); # diag("output: $out"); is( $out, "One\nThree\n", 'STDOUT has One Three' ); my $err = slurp("$path/err"); # diag("error: $err"); # is( $err, "Two\n", 'STDERR has Two' ); is( $err, "${prefix}Two\n", 'STDERR has Two' ); } $debugger->run; $debugger->quit; done_testing(); __END__ Debug-Client-0.29/t/28-get_h_var.t0000644000175000000500000000136412022167633015206 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use Test::More; use Test::Deep; plan( tests => 2 ); #Top use t::lib::Debugger; start_script('t/eg/14-y_zero.pl'); my $debugger; $debugger = start_debugger(); $debugger->get; #Body my $out; $out = $debugger->get_h_var(); like( $out, qr/Control script execution/s, 'h -> help menu' ); $out = $debugger->get_h_var('h'); like( $out, qr/Help.is.currently.only.available.for.the.new.5.8.command.set/s, 'h h -> 5.8 command set' ); #Tail $debugger->quit; done_testing(); 1; __END__ use strict; use warnings; # Turn on $OUTPUT_AUTOFLUSH $| = 1; use t::lib::Get_h_var; # run all the test methods in Example::Test Test::Class->runtests; Debug-Client-0.29/t/27-get_p_exp.t0000644000175000000500000000121112142701416015204 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use Test::More; use Test::Deep; plan( tests => 7 ); #Top use t::lib::Debugger; start_script('t/eg/14-y_zero.pl'); my $debugger; $debugger = start_debugger(); $debugger->get; $debugger->set_breakpoint( 't/eg/14-y_zero.pl', '13' ); $debugger->run; #Body foreach ( 1 .. 3 ) { $debugger->run(); ok( $debugger->get_p_exp('$_') =~ m/$_/, "p \$_ = $_" ); ok( $debugger->get_p_exp('$line') =~ m/$_/, "p \$line = $_" ); } ok( $debugger->get_p_exp('2 + 3') == 5, 'p 2 + 3 = 5' ); #Tail $debugger->quit; done_testing(); 1; __END__ Debug-Client-0.29/t/15-run_to_line.t0000644000175000000500000000250612175263034015561 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use t::lib::Debugger; my ( $dir, $pid ) = start_script('t/eg/02-sub.pl'); use Test::More; use Test::Deep; plan( tests => 4 ); my $debugger = start_debugger(); my $perl5db_ver; my $perl5db_index; { my $out = $debugger->get; $out =~ m/(?1.\d{2})(?_\d{2})*$/m; $perl5db_ver = $+{ver} // 0; $perl5db_index = $+{index} // undef; if ($perl5db_index) { diag("Info: perl5db version $perl5db_ver$perl5db_index"); } else { diag("Info: perl5db version $perl5db_ver"); } like( $out, qr/Loading DB routines from perl5db.pl version/, 'loading line' ); like( $out, qr{main::\(t/eg/02-sub.pl:4\):\s*\$\| = 1;}, 'line 4' ); } { my @out = $debugger->step_in; cmp_deeply( \@out, [ 'main::', 't/eg/02-sub.pl', 6, 'my $x = 11;' ], 'line 6' ) or diag( $debugger->get_buffer ); } SKIP: { skip( "perl5db $] dose not support c [line|sub]", 1 ) if $] =~ m/5.01500(3|4|5)/;SKIP: { skip( "perl5db v$perl5db_ver dose not support list context", 1 ) if $perl5db_ver == 1.35; my @out = $debugger->run(17); cmp_deeply( \@out, [ 'main::func1', 't/eg/02-sub.pl', 17, ' my $multi = $q * $w;' ], 'line 17' ) or diag( $debugger->get_buffer ); } } { $debugger->run; $debugger->quit; } done_testing(); 1; __END__ Debug-Client-0.29/t/04-pod-coverage.t0000644000175000000500000000057412175255370015624 0ustar kevinsrcuse strict; use warnings FATAL => 'all'; use English qw( -no_match_vars ); local $OUTPUT_AUTOFLUSH = 1; BEGIN { unless ( $ENV{RELEASE_TESTING} ) { require Test::More; Test::More::plan( skip_all => 'Author tests, not required for installation.' ); } } use Test::More; use Test::Requires { 'Test::Pod::Coverage' => 1.08 }; all_pod_coverage_ok(); done_testing(); __END__ Debug-Client-0.29/t/18-stepout.t0000644000175000000500000000212412046207424014744 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use Test::More; use Test::Deep; plan( tests => 4 ); #Top use t::lib::Debugger; start_script('t/eg/02-sub.pl'); my $debugger; $debugger = start_debugger(); my $out = $debugger->get; $out =~ m/(?<=[version])\s*(?1.\d{2})/m; my $perl5db_ver = $+{ver}; #Body $debugger->run(18); my @out = $debugger->step_out; SKIP: { skip( "perl5db $] dose not support c [line|sub]", 1 ) if $] =~ m/5.01500(3|4|5)/; SKIP: { skip( "perl5db v$perl5db_ver dose not support list context", 1 ) if $perl5db_ver == 1.35; cmp_deeply( \@out, [ 'main::', 't/eg/02-sub.pl', 9, 'my $z = $x + $y;' ], 'stepover line 9' ); } } $debugger->get_lineinfo; SKIP: { skip( "perl5db $] dose not support c [line|sub]", 1 ) if $] =~ m/5.01500(3|4|5)/; ok( $debugger->get_row == 9, 'row = 9' ); } ok( $debugger->get_filename =~ m/02-sub/, 'filename = 02-sub.pl' ); $out = $debugger->step_out; like( $out, qr/^Warning:.*list/s, 'Warning: failed to make list call' ); #Tail $debugger->quit; done_testing(); 1; __END__ Debug-Client-0.29/t/17-stepin.t0000644000175000000500000000151112046207413014537 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use Test::More; use Test::Deep; plan( tests => 4 ); #Top use t::lib::Debugger; start_script('t/eg/02-sub.pl'); my $debugger; $debugger = start_debugger(); my $out = $debugger->get; $out =~ m/(?<=[version])\s*(?1.\d{2})/m; my $perl5db_ver = $+{ver}; #Body $out = $debugger->step_in; like( $out, qr{sub.pl:6}, 'step to line 6' ); my @out = $debugger->step_in; SKIP: { skip( "perl5db v$perl5db_ver dose not support list context", 1 ) unless $perl5db_ver < 1.35; cmp_deeply( \@out, [ 'main::', 't/eg/02-sub.pl', 7, 'my $y = 22;' ], 'step to line 7' ); } ok( $debugger->get_row == 7, 'row = 7' ); ok( $debugger->get_filename =~ m/02-sub/, 'filename = 02-sub.pl' ); #Tail $debugger->quit; done_testing(); 1; __END__ Debug-Client-0.29/t/03-pod.t0000644000175000000500000000055712175255241014030 0ustar kevinsrcuse strict; use warnings FATAL => 'all'; use English qw( -no_match_vars ); local $OUTPUT_AUTOFLUSH = 1; BEGIN { unless ( $ENV{RELEASE_TESTING} ) { require Test::More; Test::More::plan( skip_all => 'Author tests, not required for installation.' ); } } use Test::More; use Test::Requires { 'Test::Pod' => 1.48 }; all_pod_files_ok(); done_testing(); __END__ Debug-Client-0.29/t/lib/0002755000175000000500000000000012175567260013411 5ustar kevinsrcDebug-Client-0.29/t/lib/Debugger.pm0000644000175000000500000000354312175255463015475 0ustar kevinsrcpackage t::lib::Debugger; use strict; use warnings FATAL => 'all'; use English qw( -no_match_vars ); local $OUTPUT_AUTOFLUSH = 1; use Term::ReadLine; if ( $OSNAME eq 'MSWin32' ) { $ENV{TERM} = 'dumb'; local $ENV{PERL_RL} = ' ornaments=0'; } if ( $OSNAME eq 'MSWin32' ) { require Win32::Process; require Win32; use constant NORMALPRIORITYCLASS => 0x00000020; } #use Data::Printer { caller_info => 1, colored => 1, }; use Exporter (); use File::Temp qw(tempdir); our @ISA = 'Exporter'; our @EXPORT = qw(start_script start_debugger slurp rc_file); my $host = '127.0.0.1'; my $port = 24642 + int rand(1000); sub start_script { my ($file) = @_; my $dir = tempdir( CLEANUP => 0 ); my $path = $dir; my $pid; if ( $OSNAME eq 'MSWin32' ) { $pid = 'fudge'; # as we don't get one from win32 $path = Win32::GetLongPathName($path); local $ENV{PERLDB_OPTS} = "RemotePort=$host:$port"; sleep 1; system( 1, qq($^X -d $file > "$path/out" 2> "$path/err") ); #spawns an external process and immediately returns its process designator, without waiting for it to terminate } else { $pid = fork(); die if not defined $pid; if ( not $pid ) { local $ENV{PERLDB_OPTS} = "RemotePort=$host:$port"; sleep 1; exec qq($EXECUTABLE_NAME -d $file > "$path/out" 2> "$path/err"); exit 0; } } return ( $dir, $pid ); } sub start_debugger { require Debug::Client; my $debugger = Debug::Client->new( host => $host, port => $port, ); return $debugger; } sub slurp { my ($file) = @_; open my $fh, '<', $file or die "Could not open '$file' $!"; local $/ = undef; return <$fh>; } # the debugger loads custom settings from # a .perldb file. If the user has it, some # test outputs might go boo boo. sub rc_file { require File::HomeDir; require File::Spec; return -e File::Spec->catfile( File::HomeDir->my_home, '.perldb' ); } 1; Debug-Client-0.29/t/lib/Test_1415.pm0000644000175000000500000000425512145553570015340 0ustar kevinsrcpackage t::lib::Test_1415; use strict; use warnings FATAL => 'all'; use parent qw(Test::Class); use Test::More; use Test::Deep; use t::lib::Debugger; # setup methods are run before every test method. sub load_debugger : Test(setup) { my $self = shift; start_script('t/eg/test_1415.pl'); $self->{debugger} = start_debugger(); $self->{debugger}->get; } sub t1415 : Test(12) { my $self = shift; $self->{debugger}->__send( 'w ' . '@fonts' ); like( $self->{debugger}->__send('L w'), qr/fonts/, 'set watchpoints for @fonts' ); #this is 'unlike' as it's a side affect of using a wantarry unlike( my @list = $self->{debugger}->run, qr/Watchpoint/, 'Watchpoint value changed' ); like( $self->{debugger}->get_buffer, qr/fonts changed/, 'check buffer' ); unlike( $self->{debugger}->module, qr/TERMINATED/, 'module still alive' ); #tell D::C to get cursor position info_line $self->{debugger}->get_lineinfo; like( $self->{debugger}->get_filename, qr/test_1415/, 'check where we are filename' ); is( $self->{debugger}->get_row, 19, 'check where we are row 19' ); like( $self->{debugger}->get_stack_trace(), qr/ANON/, 'O look, we are in an ANON sub' ); #ToDo need a test for the value of @fonts # like( $self->{debugger}->get_value('@fonts'), qr/fred/, 'view contents of @fonts'); # $self->{debugger}->get_value("@fonts"); # diag( $self->{debugger}->get_buffer ); # cmp_deeply( \@out, [ 'main::', 't/eg/02-sub.pl', 7, 'my $y = 22;' ], 'view contents of @fonts' ); like( $self->{debugger}->run, qr/Watchpoint/, 'stoped for watchpoint' ); # like( $debugger->run, qr/Watchpoint/, 'stoped for watchpoint' ); like( $self->{debugger}->get_buffer, qr/fonts changed/, 'check buffer for fonts changed' ); unlike( $self->{debugger}->module, qr/TERMINATED/, 'module still alive' ); #tell D::C to get cursor position info_line $self->{debugger}->get_lineinfo; like( $self->{debugger}->get_filename, qr/test_1415/, 'check where we are filename' ); is( $self->{debugger}->get_row, 27, 'check where we are row 27' ); } # teardown methods are run after every test method. sub teardown : Test(teardown) { my $self = shift; $self->{debugger}->run; $self->{debugger}->quit; done_testing(); } 1; __END__ Debug-Client-0.29/t/lib/Top_Tail.pm0000644000175000000500000000127112145554540015453 0ustar kevinsrcpackage t::lib::Top_Tail; use strict; use warnings FATAL => 'all'; use parent qw(Test::Class); use Test::More; use Test::Deep; # startup methods are run before every test method. sub startup : Test(4) { my $self = shift; use_ok( 't::lib::Debugger'); ok( start_script('t/eg/14-y_zero.pl'), 'start script' ); ok( $self->{debugger} = start_debugger(), 'start debugger' ); ok( $self->{debugger}->get, 'get debugger' ); } # teardown methods are run after every test method. sub teardown : Test(2) { my $self = shift; like( $self->{debugger}->run, qr/Debugged program terminated/, 'Debugged program terminated' ); like( $self->{debugger}->quit, qr/1/, 'debugger quit' ); } 1; __END__ Debug-Client-0.29/t/07-initialize.t0000644000175000000500000000422712175256105015411 0ustar kevinsrcuse strict; use warnings FATAL => 'all'; use English qw( -no_match_vars ); local $OUTPUT_AUTOFLUSH = 1; use Term::ReadLine; if ( $OSNAME eq 'MSWin32' ) { $ENV{TERM} = 'dumb'; local $ENV{PERL_RL} = ' ornaments=0'; } if ( $OSNAME eq 'MSWin32' ) { require Win32::Process; require Win32; use constant NORMALPRIORITYCLASS => 0x00000020; } use Test::More tests => 4; use Test::Deep; use File::Temp qw(tempdir); my ( $host, $port, $porto, $listen, $reuse_addr ); SCOPE: { $host = '127.0.0.1'; $port = 24_642 + int rand(1000); $porto = 'tcp'; $listen = 1; $reuse_addr = 1; my ( $dir, $pid ) = run_perl5db( 't/eg/05-io.pl', $host, $port ); require Debug::Client; ok( my $debugger = Debug::Client->new( host => $host, port => $port, porto => $porto, listen => $listen, reuse => $reuse_addr ), 'initialize with prams' ); $debugger->run; sleep 1; ok( $debugger->quit, 'quit with prams' ); if ( $OSNAME eq 'MSWin32' ) { $pid->Kill(0) or die "Cannot kill '$pid'"; } } SCOPE: { $host = '127.0.0.1'; $port = 24_642; my ( $dir, $pid ) = run_perl5db( 't/eg/05-io.pl', $host, $port ); require Debug::Client; ok( my $debugger = Debug::Client->new(), 'initialize without prams' ); $debugger->run; sleep 1; ok( $debugger->quit, 'quit witout prams' ); if ( $OSNAME eq 'MSWin32' ) { $pid->Kill(0) or die "Cannot kill '$pid'"; } } sub run_perl5db { my ( $file, $host, $port ) = @_; my $dir = tempdir( CLEANUP => 0 ); my $path = $dir; my $pid; if ( $OSNAME eq 'MSWin32' ) { $path = Win32::GetLongPathName($path); local $ENV{PERLDB_OPTS} = "RemotePort=$host:$port"; sleep 1; Win32::Process::Create( $pid, $EXECUTABLE_NAME, qq(perl -d $file ), 1, NORMALPRIORITYCLASS, '.', ) or die Win32::FormatMessage( Win32::GetLastError() ); } else { my $pid = fork(); die if not defined $pid; if ( not $pid ) { local $ENV{PERLDB_OPTS} = "RemotePort=$host:$port"; sleep 1; exec qq($EXECUTABLE_NAME -d $file > "$path/out" 2> "$path/err"); exit 0; } } return ( $dir, $pid ); } done_testing(); __END__ Info: 06-initialize.t is effectively testing the win32/(linux, osx) bits of t/lib/Debugger.pm Debug-Client-0.29/t/24-y_zero.t0000644000175000000500000000115612144675322014556 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use Test::More; use Test::Deep; plan( tests => 3 ); #Top use t::lib::Debugger; start_script('t/eg/14-y_zero.pl'); my $debugger; $debugger = start_debugger(); $debugger->get; $debugger->set_breakpoint( 't/eg/14-y_zero.pl', '13' ); $debugger->run; #Body my $out; my @out; foreach ( 1 .. 3 ) { $debugger->run(); my @out; @out = $debugger->get_y_zero(); cmp_deeply( \@out, ["\$line = $_"], "y (0) \$line = $_" ) or diag( $debugger->get_buffer ); } #Tail $debugger->quit; done_testing(); 1; __END__ Debug-Client-0.29/t/40-test_1415-old.t0000644000175000000500000000756312110705150015444 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use Test::More; use Test::Deep; plan( tests => 12 ); #Top use t::lib::Debugger; start_script('t/eg/test_1415.pl'); my $debugger; $debugger = start_debugger(); $debugger->get; #Body $debugger->__send( 'w ' . '@fonts' ); #diag('show watches '.$debugger->__send_np('L w') ); # diag('buffer show watches '.$debugger->get_buffer ); #p $debugger->__send_np('L w'); #p $debugger->__send('L w'); #p $debugger->get_buffer; like( $debugger->__send('L w'), qr/fonts/, 'set watchpoints for @fonts' ); #this is 'unlike' as it's a side affect of using a wantarry unlike( my @list = $debugger->run, qr/Watchpoint/, 'Watchpoint value changed' ); like( $debugger->get_buffer, qr/fonts changed/, 'check buffer for fonts changed' ); unlike( $debugger->module, qr/TERMINATED/, 'module still alive' ); #tell D::C to get cursor position info_line $debugger->get_lineinfo; like( $debugger->get_filename, qr/test_1415/, 'check where we are filename' ); is( $debugger->get_row, 19, 'check where we are row 19' ); like( $debugger->get_stack_trace(), qr/ANON/, 'O look, we are in an ANON sub' ); #ToDo test the response, 5.17.6 and 5.16.2 below #p $debugger->get_y_zero; # @fonts = ( # 0 ARRAY(0x9ef7970) # 0 'Helvetica' # 1 14 # 1 HASH(0x9f39d50) # 'Luxi Sans' => 13 # ) # @fonts = ( # 0 ARRAY(0x95709e8) # 0 'Helvetica' # 1 14 # 1 HASH(0x98f3068) # 'Luxi Sans' => 13 # ) #ToDo need a test for the value of @fonts # like( $debugger->get_value('@fonts'), qr/fred/, 'view contents of @fonts'); # $debugger->get_value("@fonts"); # diag( $debugger->get_buffer ); # cmp_deeply( \@out, [ 'main::', 't/eg/02-sub.pl', 7, 'my $y = 22;' ], 'view contents of @fonts' ); like( $debugger->run, qr/Watchpoint/, 'stoped for watchpoint' ); like( $debugger->get_buffer, qr/fonts changed/, 'check buffer for fonts changed' ); unlike( $debugger->module, qr/TERMINATED/, 'module still alive' ); #tell D::C to get cursor position info_line $debugger->get_lineinfo; like( $debugger->get_filename, qr/test_1415/, 'check where we are filename' ); is( $debugger->get_row, 27, 'check where we are row 27' ); #ToDo test the response, 5.17.6 and 5.16.2 below #p $debugger->get_y_zero; # $hw = CODE(0x9570a08) # -> &main::__ANON__[t/eg/test_1415.pl:21] in t/eg/test_1415.pl:13-21 # $hw = CODE(0x9bacc70) # -> &main::__ANON__[t/eg/test_1415.pl:21] in t/eg/test_1415.pl:13-21 #Tail $debugger->run; $debugger->quit; done_testing(); 1; __END__ #!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use Test::More; use Test::Deep; plan( tests => 8 ); #Top use t::lib::Debugger; start_script('t/eg/test_1415.pl'); my $debugger; $debugger = start_debugger(); $debugger->get; #Body $debugger->__send( 'w' . '@fonts' ); # diag( $debugger->__send('L w') ); like( $debugger->__send('L w'), qr/fonts/, 'set watchpoints for @fonts' ); #this is 'unlike' as it's a side affect of using a wantarry unlike( my @list = $debugger->run, qr/Watchpoint/, 'Watchpoint value changed' ); like( $debugger->get_buffer, qr/fonts changed/, 'check buffer' ); unlike( $debugger->module, qr/TERMINATED/, 'module still alive' ); $debugger->get_lineinfo; like( $debugger->get_filename, qr/test_1415/, 'check where we are filename' ); is( $debugger->get_row, 19, 'check where we are row' ); like( $debugger->get_stack_trace(), qr/ANON/, 'O look, we are in an ANON sub' ); #ToDo need a test for the value of @fonts # like( $debugger->get_value('@fonts'), qr/fred/, 'view contents of @fonts'); # $debugger->get_value("@fonts"); # diag( $debugger->get_buffer ); # cmp_deeply( \@out, [ 'main::', 't/eg/02-sub.pl', 7, 'my $y = 22;' ], 'view contents of @fonts' ); like( $debugger->run, qr/Watchpoint/, 'stoped for watchpoint' ); #Tail $debugger->quit; done_testing(); 1; __END__ Debug-Client-0.29/t/eg/0002755000175000000500000000000012175567260013236 5ustar kevinsrcDebug-Client-0.29/t/eg/05-io.pl0000644000175000000500000000023612007503145014405 0ustar kevinsrcuse strict; use warnings; $| = 1; print "One\n"; print STDERR "Two\n"; print "Three\n"; print "Four"; print "\n"; print STDERR "Five"; print STDERR "\n"; Debug-Client-0.29/t/eg/02-sub.pl0000644000175000000500000000036012175263055014573 0ustar kevinsrcuse strict; use warnings; $| = 1; my $x = 11; my $y = 22; my $q = func1( $x, $y ); my $z = $x + $y; my $t = func1( 19, 23 ); $t++; $z++; sub func1 { my ( $q, $w ) = @_; my $multi = $q * $w; my $add = $q + $w; return $multi; } Debug-Client-0.29/t/eg/03-return.pl0000644000175000000500000000055112175567015015327 0ustar kevinsrcuse strict; use warnings; $| = 1; my $x = 11; my $q = f("foo\nbar"); $x++; my @q = g( 'baz', "foo\nbar", 'moo' ); $x++; my %q = h( bar => "foo\nbar", moo => 42 ); $x++; sub f { my ($in) = @_; my $x = 1; return $in; } sub g { my (@in) = @_; my $x = 1; return @in; } sub h { my (%in) = @_; my $x = 1; return %in; } Debug-Client-0.29/t/eg/test_1415.pl0000644000175000000500000000045712022163317015212 0ustar kevinsrc#!/usr/bin/perl use v5.10; use strict; use warnings; # Turn on $OUTPUT_AUTOFLUSH $| = 1; say 'START'; sub re_hw { return sub { say 'hello'; my @fonts = ( [ Helvetica => 14 ], { 'Luxi Sans' => 13 }, ); say @fonts; say 'world'; } } my $hw = re_hw(); &$hw; say 'END'; 1; __END__ Debug-Client-0.29/t/eg/01-add.pl0000644000175000000500000000013012007503145014513 0ustar kevinsrcuse strict; use warnings; $| = 1; my $x = 1; my $y = 2; my $z = $x + $y; 1; __END__ Debug-Client-0.29/t/eg/14-y_zero.pl0000644000175000000500000000030412175256311015307 0ustar kevinsrc#!/usr/bin/perl use 5.008; use strict; use warnings; # Turn on $OUTPUT_AUTOFLUSH $| = 1; foreach ( 0 .. 3 ) { my $line = $_; last unless defined $line; print "$_ : $line \n"; } 1; __END__ Debug-Client-0.29/t/10-top_tail_old.t0000644000175000000500000000076212145550375015716 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use Test::More tests => 5; use Test::Deep; use PadWalker; use t::lib::Debugger; ok( start_script('t/eg/14-y_zero.pl'), 'start script' ); my $debugger; ok( $debugger = start_debugger(), 'start debugger' ); ok( $debugger->get, 'get debugger' ); like( $debugger->run, qr/Debugged program terminated/, 'Debugged program terminated' ); like( $debugger->quit, qr/1/, 'debugger quit' ); Debug-Client-0.29/inc/0002755000175000000500000000000012175567260013151 5ustar kevinsrcDebug-Client-0.29/inc/Module/0002755000175000000500000000000012175567260014376 5ustar kevinsrcDebug-Client-0.29/inc/Module/Install.pm0000644000175000000500000003013512175567231016340 0ustar kevinsrc#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. Debug-Client-0.29/inc/Module/Install/0002755000175000000500000000000012175567260016004 5ustar kevinsrcDebug-Client-0.29/inc/Module/Install/Can.pm0000644000175000000500000000615712175567254017055 0ustar kevinsrc#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 Debug-Client-0.29/inc/Module/Install/Win32.pm0000644000175000000500000000340312175567254017245 0ustar kevinsrc#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Debug-Client-0.29/inc/Module/Install/WriteAll.pm0000644000175000000500000000237612175567254020076 0ustar kevinsrc#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Debug-Client-0.29/inc/Module/Install/Fetch.pm0000644000175000000500000000462712175567254017405 0ustar kevinsrc#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Debug-Client-0.29/inc/Module/Install/Makefile.pm0000644000175000000500000002743712175567254020075 0ustar kevinsrc#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 Debug-Client-0.29/inc/Module/Install/Metadata.pm0000644000175000000500000004327712175567253020077 0ustar kevinsrc#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Debug-Client-0.29/inc/Module/Install/Base.pm0000644000175000000500000000214712175567253017220 0ustar kevinsrc#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Debug-Client-0.29/eg/0002755000175000000500000000000012175567260012773 5ustar kevinsrcDebug-Client-0.29/eg/test17.pl0000644000175000000500000000074012046206072014442 0ustar kevinsrc#!/usr/bin/perl use 5.010; use strict; use warnings FATAL => 'all'; # Turn on $OUTPUT_AUTOFLUSH local $| = 1; use FindBin qw($Bin); use lib map "$Bin/$_", 'lib', '../lib'; #Top use t::lib::Debugger; start_script('t/eg/02-sub.pl'); my $debugger; $debugger = start_debugger(); my $out = $debugger->get; say '$out ' . $out; # (?|_])(?version) $out =~ m/(?<=[version])\s*(?1.\d{2})/m; my $perl5db_ver = $+{ver}; say '$perl5db_ver ' . $perl5db_ver; 1; __END__ Debug-Client-0.29/eg/debugger.pl0000644000175000000500000000515612175256016015113 0ustar kevinsrcuse strict; use warnings; use 5.010; use Cwd qw(cwd); use Getopt::Long qw(GetOptions); use Pod::Usage qw(pod2usage); my %opt = ( port => 12345, perl => $^X, # allow the user to supply the path to another perl host => '127.0.0.1', ); usage() if not @ARGV; GetOptions( \%opt, 'help', 'port=i', 'perl=s', ) or usage(); usage() if $opt{help}; my ( $script, @args ) = @ARGV; my $pid = fork(); die if not defined $pid; if ( not $pid ) { local $ENV{PERLDB_OPTS} = "RemotePort=$opt{host}:$opt{port}"; exec("$opt{perl} -d $script @args"); } say "PID: $pid"; #require IPC::Run; require Debug::Client; my $debugger = Debug::Client->new( host => $opt{host}, port => $opt{port}, ); $debugger->listen; say 'listening'; # my @cmd = ($opt{perl}, '-d', @ARGV); # { # local $ENV{PERLDB_OPTS} = "RemotePort=$opt{host}:$opt{port}"; # IPC::Run::run(\@cmd, sub {}, \&out, \&err); # } # say 'launched'; # sub out { # print "OUT @_"; # } # sub err { # print "ERR @_"; # } # my $process; # if ($^O =~ /win32/i) { # require Win32::Process; # require Win32; # local $ENV{PERLDB_OPTS} = "RemotePort=$opt{host}:$opt{port}"; # Win32::Process::Create($process, $opt{perl}, "-d $script @args", 0, 0, cwd); # } # print "launched " . $process->GetProcessID . "\n"; my $out = $debugger->get; print $out; my $last_step; while (1) { chomp( my $input = ); if ( $input eq '' ) { next if not $last_step; $input = $last_step; } given ($input) { when ( [ 'h', '?' ] ) { help(); } when ('s') { $last_step = 's'; my $out = $debugger->step_in; print $out; } when ('n') { $last_step = 'n'; my $out = $debugger->step_over; print $out; } when ('r') { my $out = $debugger->step_out; print $out; } when ('T') { my $out = $debugger->get_stack_trace; print $out; } when ('.') { my $out = $debugger->show_line; print $out; } when ('q') { last; } when (qr/^c (?:\s+(\w+))? $/x) { my $out = $debugger->run($1); print $out; } default { #my $out = $debugger->execute_code($input); #print $out; print "Invalid command\n"; } } } sub help { print <<'END_HELP' s - step in n - step over r - step out T - stack trace . - show current line c (line|sub) - run till q - quit h or ? - help END_HELP } # ... # On Windows kill() does not seem to have effect # print "Killing the script...\n"; END { kill 9, $pid if $pid; } # Win32::Process #$process->Kill(0); sub usage { pod2usage(); } =head1 SYNOPSIS script param param --port PORT defaults to 12345 --help This help --perl /path/to/other/perl defaults to current perl =cut