package Enbugger;

BEGIN {
    $Enbugger::VERSION = '2.000';

    require XSLoader;
    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.
    require 5.006_000;


    require strict;
    strict->import;
    require warnings;
    warnings->import;

    require B::Utils;
    require Carp;
    Carp->import;

    require vars;
    vars->import(
		 # Public class settings.
		 qw( $DefaultDebugger )
		);

    require constant;

    # Compile all of Enbugger:: w/o debugger hooks.
    Enbugger::_compile_with_nextstate();
}

my( $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;
}





$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;
}




__PACKAGE__->register_debugger( 'perl5db' );





# TODO: __PACKAGE__->register_debugger( 'ebug' );





# TODO: __PACKAGE__->register_debugger( 'sdb' );





# TODO: __PACKAGE__->register_debugger( 'ptkdb' );





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.
    Enbugger::_compile_with_nextstate();
    require $debugger_class_file;
    $DEBUGGER_CLASS->_load_debugger;
    Enbugger->instrument_runtime;


    # Subsequent compilation will use pp_dbstate like expected.
    Enbugger::_compile_with_dbstate();

    return;
}





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.
    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($_);
    }

    return;
}






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: $!" );
	}
	
	# TODO: every string here ought to also be a dualvar where the
	# IV (integer) value is also the pointer to a COP node. I
	# /guess/ this helps some other things later go vivify breakpoints.
	local $/ = "\n";
	@$symname = undef;
	push @$symname, 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' ) {

	#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;
    }
}

Enbugger::_compile_with_dbstate();

## Local Variables:
## mode: cperl
## mode: auto-fill
## cperl-indent-level: 4
## End:

no warnings 'void';		## no critic
'But this is the internet, dear, stupid is one of our prime exports.';

