view release on metacpan or  search on metacpan

lib/Devel/DebugHooks.pm  view on Meta::CPAN

    }
    return $name;
}



# We define posponed/sub as soon as possible to be able watch whole process
# NOTICE: At this sub we reenter debugger
sub postponed {
	#TODO: implement local_state to localize debugger state values
	my $old_inDB =  DB::state( 'inDB' );
	DB::state( 'inDB', 1 );
	#FIX: process exceptions
	emit( 'trace_load', @_ );

	# When we are in debugger and we require module the execution will be
	# interrupted and we REENTER debugger
	# TODO: study this case and IT:
	# T: We are { dd } and run command that 'require'
	DB::state( 'inDB', $old_inDB );
}



our %sig =  (()
	,trap    =>  \&trap
	,untrap  =>  \&untrap
);


mutate_sub_is_debuggable( \&reg, 0 );
sub reg {
	my( $sig, $name, @extra ) =  @_;

	if( exists $DB::sig{ $sig } ) {
		return $DB::sig{ $sig }->( $name, @extra );
	}
	else {
		return default_handler( $sig, $name, @extra );
	}
}



sub unreg {
	my( $sig, $name, @extra ) =  @_;

	if( exists $DB::sig{ $sig } ) {
		return $DB::sig{ "un$sig" }->( $name, @extra );
	}
	else {
		return default_unhandler( $sig, $name, @extra );
	}
}



sub emit {
	my( $name ) =  ( shift );

	print $DB::OUT "Emit event '$name' from ", (caller)[1,2], "\n"   if DB::state( 'ddd' );

	# Get subscribers for the event
	my $ev; {
		no strict 'refs';
		$ev =  defined &{ "${name}_info" }
			? &{ "${name}_info" }( @_ )
			: default_handler_info( $name )
		;
	}

	my $res =  [];
	# Events are emitted in context of handler. Event handler should be at least
	# HASHREF with key 'code' having CODEREF to sub which will process event
	push @$res, process( $ev->{ $_ }, @_ )   for keys %$ev;

	print $DB::OUT "Event '$name' DONE\n"   if DB::state( 'ddd' );

	return $res;
}



sub default_handler_info {
	return DB::state( "on_$_[0]" ) // {};
}



sub default_handler {
	my( $sig, $name ) =  @_;
	my $subscribers =  DB::state( "on_$sig" );
	$subscribers =  DB::state( "on_$sig", {} )   unless $subscribers;

	# HACK: Autovivify subscriber if it does not exists yet
	# Glory Perl. I love it!
	return \$subscribers->{ $name };
}



sub default_unhandler {
	my( $sig, $name ) =  @_;
	my $subscribers =  DB::state( "on_$sig" );

	delete $subscribers->{ $name };
	DB::state( "on_$sig", undef )   unless keys %$subscribers;
}



sub trap_info {
	my( $file, $line ) =  @_;

	return DB::traps( $file )->{ $line };
}



sub trap {
	my( $name, $file, $line ) =  @_;