package Enbugger; # COPYRIGHT AND LICENCE # # Copyright (C) 2007,2008,2009 WhitePages.com, Inc. with primary # development by Joshua ben Jore. # # This program is distributed WITHOUT ANY WARRANTY, including but not # limited to the implied warranties of merchantability or fitness for # a particular purpose. # # The program is free software. You may distribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation (either version 2 or any later version) # and the Perl Artistic License as published by O’Reilly Media, Inc. # Please open the files named gpl-2.0.txt and Artistic for a copy of # these licenses. BEGIN { $VERSION = '2.007'; } use XSLoader (); BEGIN { XSLoader::load( 'Enbugger', $VERSION ); # Provide minimal debugger hooks. # # When perl has debugging enabled, it always calls these functions # at hook points. It dies if they're missing. These stub functions # don't do anything except provide something that will keep perl # from dying from lack of hooks. { # Generate needed code for stubs. my $src = "package DB;\n"; my $need_stubs; for my $sub (qw( DB sub )) { my $globref = $DB::{$sub}; # Don't try replacing an existing function. if ( $globref and defined &$globref ) { } else { # Generate a stub method. $src .= "sub $sub {};\n"; $need_stubs = 1; } } # Create stubs. if ( $need_stubs ) { $src .= "return 1;\n"; my $ok = eval $src; die $@ unless $ok; } } # Compile and load everything following w/ debugger hooks. # # That is, everything I'm asking to compile now could possibly be # debugged if we do the loading. Most of everything else in the # Enbugger namespace is explicitly removed from the debugger by # making sure it's COP nodes are compiled with "nextstate" instead # of "dbstate" hooks. Enbugger->_compile_with_dbstate(); } # I don't know the real minimum version. I've gotten failure # reports from 5.5 that show it's missing the COP opcodes I'm # altering. use 5.006_000; use strict; use B::Utils (); use Carp (); use Scalar::Util (); # Public class settings. use vars qw( $DefaultDebugger ); use constant (); # just to load it. BEGIN { # Compile all of Enbugger:: w/o debugger hooks. Enbugger->_compile_with_nextstate(); } our( $DEBUGGER, $DEBUGGER_CLASS, %REGISTERED_DEBUGGERS ); ###################################################################### # Public API BEGIN { my $src = "no warnings 'redefine';\n"; for my $sub (qw( stop write )) { $src .= <<"SRC"; #line @{[__LINE__+1]} "@{[__FILE__]}" sub $sub { my ( \$class ) = \@_; # Fetch and install the real implementation. my \$debuggerSubClass = \$class->DEBUGGER_CLASS; *Enbugger::$sub = \$debuggerSubClass->can('_${sub}'); # Redispatch to the implementation. goto &Enbugger::$sub; }; SRC } $src .= "return 1;\n"; my $ok = eval $src; die $@ unless $ok; } BEGIN { $DefaultDebugger = 'perl5db' } sub DEBUGGER_CLASS () { unless ( defined $DEBUGGER_CLASS ) { Enbugger->load_debugger; } # Install a replacement method that doesn't know how to load # debuggers. # # There's no need to always have a 100% capable function around # once there's no possibility for change. my $ok = eval <<"DEBUGGER_CLASS"; #line @{[__LINE__]} "@{[__FILE__]}" no warnings 'redefine'; sub DEBUGGER_CLASS () { "\Q$DEBUGGER_CLASS\E" } return 1; DEBUGGER_CLASS die $@ unless $ok; goto &Enbugger::DEBUGGER_CLASS; } sub _stop; sub _write; sub _load_debugger; BEGIN { # There is an automatically registered "null" debugger which is # really just a known empty thing that exists only so I can match # against it and thereby know it can be replaced. $REGISTERED_DEBUGGERS{''} = { null => 1, symbols => [qw[ sub DB ]], }; } sub load_debugger { my ( $class, $requested_debugger ) = @_; # Choose a debugger to load if none was specified. if ( not defined $requested_debugger ) { # Don't bother if we've already loaded a debugger. return if $DEBUGGER; # Choose the default. $requested_debugger = $DefaultDebugger; } # Don't load a debugger if there is one loaded already. # # Enbugger already populates %DB:: with &DB and &sub so I'll check # for something that I didn't create. my %debugger_symbols = map {; $_ => 0b01 } keys %DB::; # Compare all registered debuggers to our process. my %debugger_matches; for my $debugger ( keys %REGISTERED_DEBUGGERS ) { # Find the intersection vs the difference. my $intersection = 0; my %match = %debugger_symbols; for my $symbol ( @{$REGISTERED_DEBUGGERS{$debugger}{symbols}} ) { if ( ( $match{$symbol} |= 0b10 ) == 0b11 ) { ++ $intersection; } } # Score. my $difference = keys(%match) - $intersection; my $score = $difference / $intersection; $debugger_matches{$debugger} = $score; } # Select the best matching debugger. my ( $best_debugger ) = sort { $debugger_matches{$a} <=> $debugger_matches{$b} } keys %debugger_matches; # It is ok to replace the null debugger but an error to replace # anything else. Also, there's nothing to do if we've already # loaded the requested debugger. if ( $REGISTERED_DEBUGGERS{$best_debugger}{null} ) { } elsif ( $best_debugger eq $requested_debugger ) { return; } else { Carp::confess("Can't replace the existing $best_debugger debugger with $requested_debugger"); } # Debugger's name -> Debugger's class. $DEBUGGER = $requested_debugger; $DEBUGGER_CLASS = "${class}::$DEBUGGER"; # Debugger's class -> Debugger's .pm file. my $debugger_class_file = $DEBUGGER_CLASS; $debugger_class_file =~ s#::#/#g; $debugger_class_file .= '.pm'; # Load the file. # # Be darn sure we're compiling COP nodes with pp_nextstate # instead of pp_dbstate. It sucks to start debugging your # debugger by accident. Incidentally... this is a great place # to hack if you /do/ want to make debugging a debugger a # possibility. # # Further, note that some debugger supports have already been loaded # by __PACKAGE__->register_debugger(...) below. In general, this # is for things I've needed to use myself. Enbugger->_compile_with_nextstate(); require $debugger_class_file; $DEBUGGER_CLASS->_load_debugger; $DEBUGGER_CLASS->instrument_runtime; # Subsequent compilation will use pp_dbstate like expected. $DEBUGGER_CLASS->_instrumented_ppaddr(); return; } sub _uninstrumented_ppaddr { $_[0]->_compile_with_nextstate() } sub _instrumented_ppaddr { $_[0]->_compile_with_dbstate() } sub _load_debugger; sub register_debugger { my ( $class, $debugger ) = @_; # name -> class my $enbugger_subclass = "Enbugger::$debugger"; # class -> module file my $enbugger_subclass_file = $enbugger_subclass; $enbugger_subclass_file =~ s<::></>g; $enbugger_subclass_file .= '.pm'; # Load it. *Assume* PL_ppaddr[OP_NEXTSTATE] is something # useful like Perl_pp_nextstate still. # # TODO: localize PL_ppaddr[OP_NEXTSTATE] during this compilation to # be Perl_pp_nextstate. require $enbugger_subclass_file; my $src = <<"REGISTER_DEBUGGER"; #line @{[__LINE__]} "@{[__FILE__]}" sub load_$debugger { my ( \$class ) = \@_; \$class->load_debugger( '$debugger' ); return; }; REGISTER_DEBUGGER $src .= "return 1;\n"; my $ok = eval $src; die $@ unless $ok; } sub load_source { my ( $class ) = @_; # Load the original program. $class->load_file($0); # Load all modules. for ( grep { defined and -e } values %INC ) { $class->load_file($_); } $class->initialize_dbline; return; } sub initialize_dbline { my $file; for ( my $cx = 1; my ( $package, $c_file ) = caller $cx; ++ $cx ) { if ( $package !~ /^Enbugger/ ) { $file = $c_file; last; } } if ( not defined $file ) { # WTF? *DB::dbline = []; } else { no strict 'refs'; *DB::dbline = \@{"main::_<$file"}; } } sub load_file { my ($class, $file) = @_; # The symbols by which we'll know ye. my $base_symname = "_<$file"; my $symname = "main::$base_symname"; no strict 'refs'; if ( not @$symname and -f $file ) { # Read the source. # Open the file. my $fh; if ( not open $fh, '<', $file ) { Carp::croak( "Can't open $file for reading: $!" ); } # Load our source code. All source must be installed as at least PVIV or # some asserts in op.c may fail. Later, I'll assign better pointers to each # line in instrument_op. local $/ = "\n"; @$symname = ( undef, map { Scalar::Util::dualvar( 0, $_ ) } readline $fh ); } $$symname ||= $file; return; } sub instrument_runtime { # Now do the *real* work. my ( $class ) = @_; # Load the source code for all loaded files. Too bad about (eval 1) # though. This doesn't work. Why not!?! $class->load_source; B::Utils::walkallops_simple( \ &Enbugger::instrument_op ); } sub instrument_op { my ( $op ) = @_; # Must be a B::COP node. if ( $$op and B::class( $op ) eq 'COP' ) { # @{"_<$file"} entries where there are COP entries are # dualvars of pointers to the COP nodes that will get # OPf_SPECIAL toggled to indicate breakpoints. { my $file = $op->file; my $line = $op->line; my $ptr = $$op; my $source = do { no strict 'refs'; \ @{"main::_<$file"}; }; if ( defined $source->[$line] ) { Scalar::Util::dualvar( $ptr, $source->[$line] ); } } #print $op->file ."\t".$op->line."\t".$o->stash->NAME."\t"; # Disable or enable debugging for this opcode. if ( $op->stash->NAME =~ /^(?=[DE])(?:DB|Enbugger)(?:::|\z)/ ) { #print 'next'; Enbugger::_nextstate_cop( $op ); } else { Enbugger::_dbstate_cop( $op ); } } } sub import { my $class = shift @_; if ( @_ ) { my $selected_debugger = shift @_; $DefaultDebugger = $selected_debugger; } } BEGIN { __PACKAGE__->register_debugger( 'perl5db' ); __PACKAGE__->register_debugger( 'NYTProf' ); } # TODO: __PACKAGE__->register_debugger( 'ebug' ); # TODO: __PACKAGE__->register_debugger( 'sdb' ); # TODO: __PACKAGE__->register_debugger( 'ptkdb' ); # Anything compiled after this statement runs will be debuggable. Enbugger->_compile_with_dbstate(); ## Local Variables: ## mode: cperl ## mode: auto-fill ## cperl-indent-level: 4 ## tab-width: 8 ## End: no warnings 'void'; ## no critic 'But this is the internet, dear, stupid is one of our prime exports.';