#!/usr/bin/perl -w

#-----------------------------------------------------------------------------
package utrace;
use strict;
use warnings FATAL => qw(all);
use feature qw(switch);

sub pr { main::pr(@_) }

my $f_ugdb;

use constant {
	# not really needed
	ECHILD		=> 10,
	EAGAIN		=> 11,

	UGDB_ATTACH	=> (0x666 + 1),
	UGDB_DETACH	=> (0x666 + 2),

	UGDB_STOP	=> (0x666 + 3),
	UGDB_CONT	=> (0x666 + 4),

	UGDB_GETEV	=> (0x666 + 5),

	UGDB_PEEKMEM	=> (0x666 + 6),
	UGDB_POKEMEM	=> (0x666 + 7),

# XXX: temporarily hack !!!!!
UGDB_GETREGS => (0x666 + 100),

	UGDB_EV_STOP	=> 0,
	UGDB_EV_EXIT	=> 1,
};

sub create
{
	sysopen $f_ugdb, '/proc/ugdb', 0
		or return;
	return $f_ugdb;
}

sub attach_thread
{
	my ($pid, $tid) = @_;

	defined ioctl $f_ugdb, UGDB_ATTACH, 0+$tid;
}

sub detach_thread
{
	my ($tid) = @_;

	defined ioctl $f_ugdb, UGDB_DETACH, 0+$tid;
}

sub ck_true
{
	defined (my $r = shift) or return;
	$r == 1 or pr "WARN! should be true";
	1;
}

sub stop_thread
{
	my ($tid) = @_;

	ck_true ioctl $f_ugdb, UGDB_STOP, 0+$tid;
}

sub cont_thread
{
	my ($tid) = @_;

	ck_true ioctl $f_ugdb, UGDB_CONT, 0+$tid;
}

sub get_event
{
	defined ioctl $f_ugdb, UGDB_GETEV, my $event = 'x' x 64
		or do {
			# just a sanity check
			return if $! == EAGAIN || $! == ECHILD;
			return (0, 'EV_ERROR', "[errno: $!]");
		};

	my ($tid, $type, $data) = unpack 'i!i!a*', $event;

	my @event;
	given ($type) {
		when (UGDB_EV_STOP)
			{ @event = 'EV_STOP'; }

		when (UGDB_EV_EXIT)
			{ @event = ('EV_EXIT', unpack 'I', $data); }

		@event = ('EV_UNKNOWN', $type);
	}

	$tid, @event;
}

sub read_mem
{
	my ($tid, $addr, $size) = @_;

	my $mbuf = 'x' x $size;
	my $pbuf = unpack 'L!', pack 'P', $mbuf;
	my $xmem = pack 'L!4', 0+$tid, +$addr, 0+$pbuf, $size;

	my $r = ioctl $f_ugdb, UGDB_PEEKMEM, $xmem
		or return;
	substr $mbuf, 0, $r;
}

sub get_regs
{
	my $tid = 0+shift;
	my $regs = 'x' x 216; # struct user_regs_struct

	my $pregs = unpack 'L!', pack 'P', $regs;
	my $xregs = pack 'L!2', 0+$tid, 0+$pregs;
	defined ioctl $f_ugdb, UGDB_GETREGS, $xregs
		or return;
	$regs;
}

#-----------------------------------------------------------------------------
package main;
use strict;
use feature qw(state switch);
use warnings FATAL => qw(all);
no warnings 'portable'; #hex

sub pr { print STDERR "@_\n" }

=pod
	tread:
		T_PID T_TID	pid, tid
		T_XID		pPID.TID

		T_STP		undef, false==pending, or STOP_REPLY

	process:
		P_PID		pid
		P_TID		list of sub-threads

	both:
		S_KEY		= sorting key

=cut
#-----------------------------------------------------------------------------
sub err
{
	pr "ERR!! @_"; return;
}

sub hv($)
{
	sprintf '%02x', 0+shift;
}
sub hs($)
{
	unpack 'H*', shift // return undef;
}

sub shex($)
{
	my $h = shift; ($h =~ s/^-//) ? -hex $h : +hex $h;
}

sub __s_key
{
	sort { $a->{S_KEY} <=> $b->{S_KEY} } values %{+shift}
}

my ($O_NOACK, $O_NOSTOP);
my ($S_KEY, $P_NUM, %P_ALL, %T_ALL) = (0, 0);
my ($G_CURR, $C_CURR);

sub select_threads
{
	my ($pid, $tid) = @_;

	$pid < 0 || $tid < 0 and
		return err "unexpected multi-THREAD-ID"
		unless wantarray;

	return unless %T_ALL;

	if ($tid > 0) {
		my $t = $T_ALL{$tid} || return;
		$t->{T_PID} == $pid || return if $pid > 0;
		return $t;
	}

	my @p;
	if ($pid > 0) {
		@p = $P_ALL{$pid} || return;
	} else {
		@p = __s_key \%P_ALL;
		splice @p, 1 unless $pid;
	}

	my @t = map {
		my @t = __s_key $_->{P_TID} or die;
		splice @t, 1 unless $tid;
		@t;
	} @p;

	die unless @t;

	wantarray ? @t : $t[0];
}

sub select_one_thread
{
	scalar select_threads @_;
}

sub attach_thread
{
	my ($p, $tid) = @_;
	my $pid = $p->{P_PID};

	die if $T_ALL{$tid} || $p->{P_TID}{$tid};

	utrace::attach_thread $pid, $tid
		or return err "attach $tid failed: $!";

	$T_ALL{$tid} = $p->{P_TID}{$tid} = {
		S_KEY => ++$S_KEY,

		T_PID => $pid,
		T_TID => $tid,
		T_XID => sprintf('p%x.%x', $pid, $tid),

		T_STP => undef,
	};
}

sub detach_thread
{
	my ($p, $t) = @_;
	my $tid = $t->{T_TID};

	utrace::detach_thread $tid, $t->{T_STP}
		or err "detach $tid: $!";

	$_ && $_ == $t and undef $_ for $G_CURR, $C_CURR;

	$t == delete $T_ALL{$tid} or die;
	$t == delete $p->{P_TID}{$tid} or die;

	return $t;
}

sub detach_process
{
	my $p = shift;

	detach_thread $p, $_ for values %{$p->{P_TID}};
	$p == delete $P_ALL{$p->{P_PID}} or die;

	if (--$P_NUM <= 0) {
		die if $P_NUM;
		die if %T_ALL;
		die if %P_ALL;
		die if $G_CURR || $C_CURR;
	}

	die if keys %{$p->{P_TID}};
	return $p;
}

sub proc_list_pid
{
	my $pid = shift;
	my @tid = map /(\d+)\z/, glob "/proc/$pid/task/*";
	# do not return an empty list!
	@tid ? @tid : $pid;
}

sub c_attach
{
	# XXX: todo !!!!!!
	$O_NOSTOP || return err "Sorry, all-stop mode is not implemented yet.";

	my $pid = shex shift;

	$P_ALL{$pid} and
		return err "$pid already attached";

	$P_NUM++;
	$P_ALL{$pid} = my $p = {
		S_KEY => ++$S_KEY,

		P_PID => $pid,
	};

	for my $tid (proc_list_pid $pid) {
		attach_thread $p, $tid or do {
			detach_process $p;
			return;
		};
	}

	# seems not strictly necessary ?
	$G_CURR = $p->{P_TID}{$pid} if !$O_NOSTOP;

	$p;
}

sub c_detach
{
	detach_process $P_ALL{shex shift} || return;
}

# for ptrace plugin
sub utrace::stop_pending
{
	my $t = $T_ALL{+shift} || return;
	defined $t->{T_STP} && !$t->{T_STP};
}

sub stop_one_thread
{
	my $t = shift;

	unless (defined $t->{T_STP}) {
		utrace::stop_thread $t->{T_TID}
			or return err "stop $t->{T_TID}: $!";

		$t->{T_STP} = '';
	}

	$t;
}

sub stop_threads
{
	stop_one_thread $_ for @{+shift};
}

sub cont_one_thread
{
	my $t = shift;

	if (defined $t->{T_STP}) {
		utrace::cont_thread $t->{T_TID}, $t->{T_STP}
			or return err "cont $t->{T_TID}: $!";

		undef $t->{T_STP};
	}

	$t;
}

sub cont_threads
{
	cont_one_thread $_ for @{+shift};
}

sub c_thread_info
{
	'm' . join ',', map $_->{T_XID}, select_threads -1, -1;
}

sub c_setcurr
{
	my ($w, $pid, $tid) = @_;

	my $t = select_one_thread shex $pid, shex $tid
		or return;

	$w eq 'g' ? ($G_CURR = $t) :
	$w eq 'c' ? ($C_CURR = $t) :
	err "H$w not implemented";
}

sub c_ck_alive
{
	my ($pid, $tid) = @_;

	my $t = select_one_thread shex $pid, shex $tid
		or return;

	$t;
}

# include/gdb/signals.h:target_signal (incomplete)
my @to_gdb_sigmap = (
	(7, 10),  (10,30),  (12,31),  (17,20),  (18,19),  (19,17),
	(20,18),  (23,16),  (29,23),  (30,32),  (31,12));

sub sig_to_gdb($)
{
	my $sig = shift;
	state $map = {@to_gdb_sigmap};
	$map->{$sig} || $sig;
}

sub sig_from_gdb($)
{
	my $sig = shift;
	state $map = {reverse @to_gdb_sigmap};
	$map->{$sig} || $sig;
}

# gdb-7.1/gdb/gdbserver/linux-x86-low.c
my @x86_64_regmap = (
	10,  5, 11, 12, 13, 14,  4, 19,  9,  8,  7,  6,  3,  2,  1,  0,
	16, 18, 17, 20, 23, 24, 25, 26, -1, -1, -1, -1, -1, -1, -1, -1,
	-1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
	-1, -1, -1, -1, -1, -1, -1, -1, -1, 15);

sub c_get_regs
{
	my $regs = utrace::get_regs $G_CURR->{T_TID}
		or return undef;

	my @regs = unpack 'L!*', $regs;

	hs pack 'L!*', map {
		$_ >= 0
			? $regs[$_] // die
			: 0;
	} @x86_64_regmap;
}

sub c_read_mem
{
	my ($addr, $size) = @_;

	hs utrace::read_mem $G_CURR->{T_TID},
			hex $addr, hex $size;
}

my $RE_HEX = qr/([a-f\d]+)/;
my $RE_PID = qr/(-?[a-f\d]+)/;
my $RE_XID = qr/p$RE_PID.$RE_PID/;

sub c_vcont
{
	my %seen;

	for (split ';', shift) {
		my ($cmd, $pid, $tid) = /^ ([^:]+) (?: : $RE_XID )? \z/x
			or return err "vCont: can't parse '$_'";

		($pid, $tid) = defined $pid
			? (shex $pid, shex $tid)
			: (-1, -1);

		my $handler;
		given ($cmd) {
			when ('t')
				{ $handler = \&stop_threads }
			when ('c')
				{ $handler = \&cont_threads }

			return err "vCont;$cmd is not implemented!";
		}

		my @threads = grep !$seen{$_->{T_XID}}++,
				select_threads $pid, $tid
			or err "vCont: no threads in '$_'";

		$handler->(\@threads);
	}

	scalar %seen;
}

# XXX: this all is wrong. blame gdb!!!
sub hack_exit
{
	my ($tid, $code) = @_;
	my $t = $T_ALL{$tid} || die;
	my $p = $P_ALL{$t->{T_PID}} or die;

	detach_thread $p, $t;

	return unless $p->{P_PID} == $tid;

	# main thread dies. report the group exit.
	detach_process $p;

	my $stp;
	if ($code & 0xff) {
		$stp = 'X' . hv sig_to_gdb($code & 0xff);
	} else {
		$stp = 'W' . hv(($code >> 8) & 0xff);
	}

	my $xid = hv $p->{P_PID};
	$stp .= ";process:$xid";

	return $stp;
}

my ($V_CUR, %V_STP, @V_STP);

sub handle_event
{
	my ($tid, $ev_name, @ev_data) = @_;

	my ($t, $stp);

	given ($ev_name) {
		when ('EV_STOP')
			{ $stp = 'T00' }
		when ('EV_SIGNAL')
			{ $stp = 'T' . hv sig_to_gdb $ev_data[0] }

		when ('EV_EXIT') {
			# XXX!!!!!! I do not know what to do with
			# the current limitations. The dirty hack
			# for now

			$stp = hack_exit $tid, $ev_data[0] or return;
			push @V_STP, +{ T_STP => $stp, };
			return;
		}

		die "unimplemented event: tid=$tid $ev_name, @ev_data";
	}

	$t = $T_ALL{$tid} || die;

	$t->{T_STP} = $stp . "thread:$t->{T_XID};";

	push @V_STP, $t unless $V_STP{$t->{T_XID}}++;
}

sub get_notification
{
	@V_STP && !$V_CUR && $V_STP[0]{T_STP};
}

sub c_vstopped
{
	@V_STP || err 'unexpected vStopped';

	++$V_CUR < @V_STP and
		return $V_STP[$V_CUR]{T_STP} || die;

	($V_CUR, %V_STP, @V_STP) = ();
	return 'OK';
}

sub handle_cmd
{
	given ($_) {
		when (/^qSupported (.*multiprocess\+)?/x) {
			$1 || die "ERR!! need multiprocess\n";
			@_ = join ';', qw{
				PacketSize=400 QStartNoAckMode+
				QNonStop+ multiprocess+};
		}

		when ('vCont?')
			{ @_ = 'vCont;t;c;C;s;S' }

		@_ = 'OK';

		when ('QStartNoAckMode')
			{ $O_NOACK = 1 }
		when (/^QNonStop:([01])/)
			{ $O_NOSTOP = !!$1 }
		when ([qw'!']) {}


		@_ = undef;

		when (/^vAttach; $RE_PID \z/x)
			{ @_ = $O_NOSTOP ? 'OK':'S05' if c_attach $1 }
		when (/^D; $RE_PID \z/x)
			{ @_ = 'OK' if c_detach $1 }

		when (/^H (.) $RE_XID \z/x)
			{ @_ = 'OK' if c_setcurr $1, $2, $3 }
		when ('qC')
			{ @_ = 'QC' . $G_CURR->{T_XID} if $G_CURR }
		when (/^T $RE_XID \z/x)
			{ @_ = 'OK' if c_ck_alive $1, $2 }

		when ('qfThreadInfo')
			{ @_ = c_thread_info if %T_ALL }
		when ('qsThreadInfo')
			{ @_ = 'l' }

		when (/^vCont;(.*)/)
			{ @_ = 'OK' if c_vcont $1 }
		when ('vStopped')
			{ @_ = c_vstopped }

		when ('g')
			{ @_ = c_get_regs if $G_CURR }
		when (/^m $RE_HEX , $RE_HEX \z/x)
			{ @_ = c_read_mem $1, $2 if $G_CURR }

		when (/^[GM]/)
			{ } # uninplemented ...

		@_ = '';

		when ('qTStatus')
			{ @_ = 'T0' }
		when ('?')
			{ @_ = $O_NOSTOP ? 'OK' : 'W00' }
	}

	return @_;
}

#-----------------------------------------------------------------------------
my ($F_UGDB, $F_CONN, $F_OCMD);

use constant {
	# ARCH DEPENDANT
	FIONBIO		=> 0x5421,
	EAGAIN		=> 11,
};

sub echo
{
	my $str = "@_";
	substr($str, 62) = '...' if length $str > 64;
	pr $str;
};

sub __put
{
	# XXX: doesn't support NONBLOCK or short writes
	my $w = syswrite $F_OCMD, my $pkt = join '', @_;
	($w ||= 0) == length $pkt or
		die 'ERR!! conn put(', length $pkt, ')',
			"failed: $w $!\n";
}

sub __put_pkt
{
	my $sym = shift;
	my $pkt = join '', @_;
	my $csm = 0; $csm += ord $1 while $pkt =~ /(.)/sg;
	__put $sym, $pkt, '#', hv $csm % 256;
	echo '<=', $pkt;
}

sub put_p
{
	__put_pkt '$', @_;
}
sub put_n
{
	__put_pkt '%', @_;
}

sub get_p
{
	state $buf = '';

	for (;;) {
		$buf =~ s/^\+*//;
		$buf =~ s/^\$ ([^#]*) \#..//x and $_ = $1, last;

		if ($buf =~ s/^([^\$]+)//s) {
			err "bad cmd or nack: $1";
		} elsif (!sysread $F_CONN, $buf, 4096, length $buf) {
			return if $! == EAGAIN;
			pr 'conn closed:', $! || 'EOF';
			exit;
		}
	}

	__put '+' unless $O_NOACK;
	echo '=>', $_;
	1;
}

sub process_cmds
{
	while (get_p) {
		my ($r, @r) = handle_cmd or next;
		put_p $r // 'E01', @r;
	}
}

sub process_ugdb
{
	while (my @ev = utrace::get_event)
	{
		handle_event @ev;
	}

	my $n = get_notification;
	put_n 'Stop:' . $n if $n;
}

sub main_loop
{
	($F_CONN, $F_OCMD) = @_;

	$F_UGDB = utrace::create
		or die "ERR!! can't create utrace fd: $!\n";

	ioctl $F_CONN, FIONBIO, pack 'i!', 1 or die $!;
	ioctl $F_UGDB, FIONBIO, pack 'i!', 1 or die $!;

	for (my $rfd = '';;) {
		vec($rfd, fileno $F_CONN, 1) = 1;
		vec($rfd, fileno $F_UGDB, 1) = 1;

		0 < select $rfd, undef, undef, undef
			or next; # EINTR

		process_cmds if vec $rfd, fileno $F_CONN, 1;
		process_ugdb if vec $rfd, fileno $F_UGDB, 1;
	}
}

sub wait_for_connect
{
	my $port = 0+shift;

	socket my $sk, 2,1,0
		or return err "sock create: $!";
	defined setsockopt $sk, 1,2,1
		or return err "sock reuseaddr: $!";
	bind $sk, pack 'Sna12', 2, $port, ''
		or return err "sock bind $port port: $!";
	listen $sk, 2
		or return err "sock listen: $!";

	pr "wait for connection on $port port ...";
	accept my $conn, $sk
		or return err "sock accept: $!";

	return $conn;
}

sub main
{
	my $port = 2000;

	if (@_) {
		$port = shift;

		die "Usage: $0 [port]\n"
			if @_ || $port =~ /\D/;
	}

	my $conn = wait_for_connect $port or exit;
	main_loop $conn, $conn;
}

main @ARGV;