package Language::INTERCAL::Theft;

# Implementation of "theft protocol" for the INTERcal NETworking

# This file is part of CLC-INTERCAL

# Copyright (c) 2007-2008, 2023 Claudio Calvelli, all rights reserved.

# CLC-INTERCAL is copyrighted software. However, permission to use, modify,
# and distribute it is granted provided that the conditions set out in the
# licence agreement are met. See files README and COPYING in the distribution.

use strict;
use vars qw($VERSION $PERVERSION @EXPORT_OK);
($VERSION) = ($PERVERSION = "CLC-INTERCAL/INET INTERCAL/Theft.pm 1.-94.-2.5") =~ /\s(\S+)$/;

use Carp;
use Socket qw(
    inet_ntoa inet_aton unpack_sockaddr_in
    AF_INET INADDR_ANY INADDR_BROADCAST
);
use FindBin qw($Bin);
use File::Spec::Functions qw(catfile updir splitpath catpath splitdir catdir);
use Language::INTERCAL::Exporter '1.-94.-2.3';
use Language::INTERCAL::Splats '1.-94.-2', qw(faint SP_INTERNAL);
use Language::INTERCAL::Extensions '1.-94.-2.1', qw(load_extension);
use Language::INTERCAL::INET::Constants '1.-94.-2.4', qw(
    SP_CASE SP_IPV6 SP_INTERNET
);
use Language::INTERCAL::INET::Interface '1.-94.-2.3',
    qw(address_multicast6 address_scope ifscope_link);
use Language::INTERCAL::Time '1.-94.-2.3', qw(current_time);
use Language::INTERCAL::Server::IPv6 '1.-94.-2.4', qw(has_ipv6);
use Language::INTERCAL::Server::INET '1.-94.-2.4';

use constant DEFAULT_PORT => 64928;

# used during testing to avoid network access; it could also be used in
# other situations, but this is intentionally undocumented (and unsupported)
our %dns_tests;

my $ipv6 = has_ipv6();
if ($ipv6) {
    import Socket qw(inet_pton inet_ntop getaddrinfo unpack_sockaddr_in6 AF_INET6);
}

sub new {
    @_ >= 4 or croak "Usage: Language::INTERCAL::Theft->new(SERVER, RC, CODE, ARGS...)";
    my ($class, $server, $rc, $code, @args) = @_;
    my $port;
    eval {
	$port = DEFAULT_PORT;
	$port = $rc->getitem('BLURT');
    };
    $port or faint(SP_INTERNET, $server, "INTERNET disabled by configuration");
    my (@mc_groups, @throw);
    if ($ipv6) {
	@mc_groups = $rc->getitem('READ');
	$throw[0] = 0;
	my @t = $rc->getitem('THROW');
	for my $t (@t) {
	    my ($limit, $scope) = @$t;
	    if (defined $scope) {
		defined $throw[$scope] or $throw[$scope] = $limit;
	    } else {
		for my $s (1..15) {
		    defined $throw[$s] or $throw[$s] = $limit;
		}
	    }
	}
	# anything not yet specified goes to system default, which is -1
	for my $s (0..15) {
	    defined $throw[$s] or $throw[$s] = -1;
	}
    }
    $class->_new($server, $port, \@mc_groups, \@throw, $code, @args);
}

sub _new {
    my ($class, $server, $port, $mc_groups, $throw, $code, @args) = @_;
    # for testing, we allow running without a theft server, which means that
    # some operations will fail - the test programs will leave $server undef
    # to tell us that
    my ($id, $host, $testing);
    if (defined $server && ! $server->interfaces_only) {
	# see if there's already a theft server running locally
	Language::INTERCAL::Server::INET->upgrade($server);
	for my $h ($server->localhost_addresses()) {
	    $id = eval { $server->tcp_socket($h, $port) };
	    defined $id or next;
	    $host = $h;
	    last;
	}
	if (! defined $id) {
	    my $tf;
	    # first see if it's in the same place as this script or
	    # somewhere nearby; this is required when we are running
	    # something like "make test" on an uninstalled package,
	    # and... the code looks messy but it's as portable as I
	    # can figure it out, as long as File::Spec knows about
	    # the system we're running on
	    my ($BV, $BD, $BP) = splitpath(catfile($Bin), 'x');
	    my @BD = splitdir($BD);
	    my ($LV, $LD, $LP) = splitpath($INC{'Language/INTERCAL/Theft.pm'});
	    my @LD = splitdir($LD);
	    push @LD, (updir) x 2;
	    for my $try (
		[0],
		[2, qw(blib script)],
		[3, qw(CLC-INTERCAL-INET blib script)],
	    ) {
		my ($up, @down) = @$try;
		if (@BD >= $up) {
		    $BD = catdir(@BD, (updir) x $up, @down);
		    my $ftf = catpath($BV, $BD, 'theft-server');
		    if (-f $ftf) {
			$tf = $ftf;
			last;
		    }
		}
		if (@LD >= $up) {
		    $LD = catdir(@LD, (updir) x $up, @down);
		    my $ftf = catpath($LV, $LD, 'theft-server');
		    if (-f $ftf) {
			$tf = $ftf;
			last;
		    }
		}
	    }
	    defined $tf or $tf = 'theft-server';
	    my @I = map { "-I$_" } @INC;
	    my @G = map { "--group=" . inet_ntop(&AF_INET6, $_->[0]) } @$mc_groups;
	    system $^X, @I, '-S', $tf, "--port=$port", @G;
	    # see if it has actually started
	    my $timeout = 10;
	CHECK_SERVER:
	    while ($timeout-- > 0) {
		select undef, undef, undef, 0.1;
		for my $h ($server->localhost_addresses()) {
		    $id = eval { $server->tcp_socket($h, $port) };
		    defined $id or next;
		    $host = $h;
		    last CHECK_SERVER;
		}
	    }
	    defined $id or faint(SP_INTERNET, "localhost", $!);
	}
	defined $host or faint(SP_INTERNAL, "Something went wrong in Language::INTERCAL::Theft->new");
    } else {
	$testing = 1;
    }
    my $t = bless {
	server => $server,
	id => $id,
	host => $host,
	port => $port,
	mc_groups => $mc_groups,
	throw => $throw,
	code => $code,
	args => \@args,
	ip6index => {},
	ip6value => [],
	mc6index => {},
	mc6value => [''],
	ifcode => {},
	ifname => [''],
	ifidx => [0],
	all_servers => {},
	known_pid => {},
	known_port => {},
	binary => 0,
	testing => $testing,
    }, $class;
    if ($ipv6) {
	$t->encode_address('ff02::1'); # make sure it's always 127.0.1.0
	$t->encode_address('::1'); # make sure it's always 224.0.0.0
	for my $group (@$mc_groups) {
	    $t->encode_address(inet_ntop(&AF_INET6, $group->[0])); # make sure we have space to encode this group
	}
    }
    if (! $testing) {
	my $line = $t->_getline;
	defined $line or faint(SP_INTERNET, $host, "Connection lost");
	$line =~ /^2/ or faint(SP_INTERNET, $host, $line);
	my $lp = $server->tcp_listen(\&_open, \&_line, \&_close, $t);
	$t->{victim_port} = $lp;
	$t->_command("VICTIM $$ ON PORT $lp");
    }
    $t;
}

sub server {
    @_ == 1 or croak "Usage: THEFT->server";
    my ($t) = @_;
    $t->{server};
}

sub victim_port {
    @_ == 1 or croak "Usage: THEFT->victim_port";
    my ($t) = @_;
    $t->{victim_port};
}

# convert a 32 bit number to an IP address
sub decode_address {
    @_ == 2 || @_ == 3 or croak "Usage: THEFT->decode_address(NUMBER, [MAKE BROADCAST?])";
    my ($t, $number, $make_bc) = @_;
    my ($n1, $n2, $n3, $n4) =
	($number >> 24, ($number >> 16) & 0xff, ($number >> 8) & 0xff, $number & 0xff);
    if ($ipv6) {
	if ($n1 == 127 && $n2 + $n3 > 0) {
	    # IPv6 multicast group
	    my $idx = ($n2 << 8) | $n3;
	    $idx < @{$t->{mc6value}} && defined $t->{mc6value}[$idx]
		or faint(SP_IPV6, "No such multicast group: $idx");
	    my $mc = $t->{mc6value}[$idx];
	    if ($n4 > 0) {
		defined $t->{ifname}[$n4] or faint(SP_IPV6, "No such interface index: $n4");
		$mc .= "%$t->{ifname}[$n4]";
	    }
	    return $make_bc ? ($mc, pack('N', $number)) : $mc;
	}
	if ($n1 >= 224 && $number != 0xffffffff) {
	    # IPv6 unicast address
	    my $idx = $number - (224 << 24);
	    $idx < @{$t->{ip6value}} && defined $t->{ip6value}[$idx]
		or faint(SP_IPV6, "No such IPv6 address $n1.$n2.$n3.$n4");
	    return $t->{ip6value}[$idx];
	}
    }
    my $addr = join('.', $n1, $n2, $n3, $n4);
    $make_bc or return $addr;
    $number == 0 || $number == 0xffffffff and return ($addr, pack('N', 0xffffffff));
    my $pack = pack('N', $number);
    # for IPv4, it could be the broadcast address of an interface
    # if we do have a server, it could override interface_has_broadcast() but
    # if we don't we just use the default one from Server::INET
    my $server = $t->{server} || 'Language::INTERCAL::Server::INET';
    $server->interface_has_broadcast($addr) or return $addr;
    ($addr, $pack);
}

# convert interface name to index
sub encode_interface {
    @_ == 2 or croak "Usage: THEFT->encode_interface(NAME)";
    my ($t, $interface) = @_;
    # if we do have a server, it could override interface_index() but
    # if we don't we just use the default one from Server::INET
    my $server = $t->{server} || 'Language::INTERCAL::Server::INET';
    my $if_index = $server->interface_index($interface);
    defined $if_index or faint(SP_IPV6, "Invalid interface $interface");
    exists $t->{ifcode}{$interface} and return $t->{ifcode}{$interface};
    my $idx = @{$t->{ifname}};
    $idx > 255 and faint(SP_IPV6, "Too many interfaces, cannot encode $interface");
    $t->{ifname}[$idx] = $interface;
    $t->{ifcode}{$interface} = $idx;
    $t->{ifidx}[$idx] = $if_index;
    return $idx;
}

# convert an IP address to a 32 bit number
sub encode_address {
    @_ == 2 or croak "Usage: THEFT->encode_address(ADDRESS)";
    my ($t, $address) = @_;
    # if it looks like an IPv4 address, it is an IPv4 address.
    if ($address =~ /^\d+(\.\d+){0,3}$/) {
	my $packed = $ipv6 ? inet_pton(&AF_INET, $address) : inet_aton($address);
	defined $packed or faint(SP_IPV6, "Invalid address: $address");
	return unpack('N', $packed);
    } else {
	$ipv6 or faint(SP_IPV6, "IPv6 not supported on this system");
	my $ifindex;
	$address =~ s/%([^%]+)$// and $ifindex = $t->encode_interface($1);
	my $packed = inet_pton(&AF_INET6, $address);
	defined $packed or faint(SP_IPV6, "Invalid address: $address");
	my $unpacked = inet_ntop(&AF_INET6, $packed);
	defined $unpacked or faint(SP_IPV6, "Invalid address: $address");
	# this is a 128-bit IPv6 address; with a large enough hammer, it
	# will go into a 32-bit register
	my $number;
	# see if we already have the address, and if not create an entry for it
	if (address_multicast6($packed)) {
	    my $idx;
	    if (exists $t->{mc6index}{$packed}) {
		$idx = $t->{mc6index}{$packed};
	    } else {
		$idx = @{$t->{mc6value}};
		$idx >= 65535 and faint(SP_IPV6, "Too many multicast groups");
		$t->{mc6index}{$packed} = $idx;
		push @{$t->{mc6value}}, $unpacked;
	    }
	    return (127 << 24) | ($idx << 8) | ($ifindex || 0);
	} else {
	    my $idx;
	    if (address_scope($packed) == ifscope_link && defined $ifindex) {
		# need to remember the interface index and we add it to the packed address
		$packed .= chr($ifindex || 0);
		$unpacked .= '%' . $t->{ifname}[$ifindex];
	    }
	    if (exists $t->{ip6index}{$packed}) {
		$idx = $t->{ip6index}{$packed};
	    } else {
		$idx = @{$t->{ip6value}};
		$idx >= (256 - 224) << 24 and faint(SP_IPV6, "Too many unicast addresses");
		$t->{ip6index}{$packed} = $idx;
		push @{$t->{ip6value}}, $unpacked;
	    }
	    return (224 << 24) + $idx;
	}
    }
}

sub dns_lookup {
    @_ == 2 or croak "Usage: THEFT->dns_lookup(NAME)";
    my ($t, $name) = @_;
    exists $dns_tests{$name}
	and return map { $t->encode_address($_) } @{$dns_tests{$name}};
    if ($ipv6) {
	my ($err, @result) = getaddrinfo($name, '');
	my @addr;
	my %seen;
	for my $rp (@result) {
	    my $family = $rp->{family};
	    my $packed = $rp->{addr};
	    my ($port, $addr) = $family == &AF_INET6
			      ? unpack_sockaddr_in6($packed)
			      : unpack_sockaddr_in($packed);
	    exists $seen{$addr} and next;
	    $seen{$addr} = 0;
	    $addr = inet_ntop($family, $addr);
	    push @addr, $t->encode_address($addr);
	}
	return @addr;
    } else {
	my ($name, $aliases, $addrtype, $length, @addrs) = gethostbyname($name);
	return map { unpack('N', $_) } @addrs;
    }
}

sub _cleanup {
    my ($t) = @_;
    my $now = time;
    for my $kw (qw(all_servers known_port)) {
	for my $rbc (keys %{$t->{$kw}}) {
	    my $kept = 0;
	    for my $rpid (keys %{$t->{$kw}{$rbc}}) {
		if ($t->{$kw}{$rbc}{$rpid}[0] < $now) {
		    delete $t->{$kw}{$rbc}{$rpid};
		} else {
		    $kept = 1;
		}
	    }
	    $kept or delete $t->{$kw}{$rbc};
	}
    }
    for my $kw (qw(known_pid)) {
	for my $rad (keys %{$t->{$kw}}) {
	    $t->{$kw}{$rad}[0] < $now and delete $t->{$kw}{$rad};
	}
    }
}

sub find_theft_servers {
    @_ >= 1 && @_ <= 3
	or croak "Usage: THEFT->find_theft_servers[(BROADCAST [,PID])]";
    my ($t, $bcast, $pid) = @_;
    my %addresses;
    if (defined $bcast) {
	# see if this is an encoded IPv6 multicast group...
	if ($ipv6 && vec($bcast, 0, 8) == 127 && vec($bcast, 1, 8) + vec($bcast, 2, 8) != 0) {
	    my $ipv6_group = $t->decode_address(unpack('N', $bcast));
	    my $interface = undef;
	    $ipv6_group =~ s/(%[^%]+)$// and $interface = $1;
	    $ipv6_group = inet_pton(&AF_INET6, $ipv6_group);
	    $addresses{&AF_INET6} = [[$ipv6_group, undef, $interface]];
	} elsif ($bcast eq INADDR_ANY || $bcast eq INADDR_BROADCAST) {
	    $addresses{&AF_INET} = [undef];
	} else {
	    $addresses{&AF_INET} = [$bcast];
	}
    } else {
	$addresses{&AF_INET} = [undef];
	if ($ipv6) {
	    # if no broadcast address was specified we also want to send to
	    # all multicast groups defined by configuration
	    $addresses{&AF_INET6} = [map { [$_->[0], $_->[1], undef]} @{$t->{mc_groups}}];
	}
    }
    # clean up cache
    _cleanup($t);
    # now see if the query is cached
    my $bcindex = defined $bcast ? $bcast : '';
    $pid ||= 0;
    exists $t->{all_servers}{$bcindex}{$pid}
	and return @{$t->{all_servers}{$bcindex}{$pid}[1]};
    # need to send a query out
    my $message = $pid ? "$pid x" : 'x';
    if ($ipv6 && $addresses{&AF_INET6}) {
	for my $grp (@{$addresses{&AF_INET6}}) {
	    defined $grp->[1] and next;
	    # figure out a hop limit
	    my $scope = vec($grp->[0], 1, 8) & 0xf;
	    my $limit = $t->{throw}[$scope];
	    defined $limit or $limit = 1; # not supposed to happen
	    $grp->[1] = $limit;
	}
    }
    my $id = $t->{server}->udp_request($message, $t->{port}, %addresses);
    defined $id or faint(SP_CASE, $t->{server}->last_error());
    # now wait for replies
    my %ips = ();
    my $rx = quotemeta($message) . '\s+(\d+)';
    $pid or $rx .= '\s+(\d+)';
    $rx = qr/^$rx$/;
    my $wait = $t->{server}->udp_request_timeout($id);
    my $limit = current_time() + $wait * 1000000;
    my $cache = time + $wait + 10;
    while (1) {
	my $now = current_time();
	$now <= $limit or last;
	my $timeout = ($limit - $now)->numify / 1000000;
	$t->{server}->progress($timeout);
	while (1) {
	    my ($if, $is6, $addr, $message) = $t->{server}->udp_request_reply($id);
	    defined $is6 or last;
	    if ($is6) {
		my ($port, $paddr) = unpack_sockaddr_in6($addr);
		$addr = inet_ntop(&AF_INET6, $paddr);
		address_scope($paddr) == ifscope_link and $addr .= "%$if";
	    } else {
		my ($port, $paddr) = unpack_sockaddr_in($addr);
		$addr = inet_ntoa($paddr);
	    }
	    $ips{$addr} = undef;
	    # if they added some information and sent back the message,
	    # remember the information for later
	    if ($message =~ $rx) {
		if ($pid) {
		    my $rport = $1;
		    $t->{known_port}{$addr}{$pid} = [$cache, $rport];
		} else {
		    my ($rpid, $rport) = ($1, $2);
		    $t->{known_pid}{$addr} = [$cache, $rpid, $rport];
		    $t->{known_port}{$addr}{$rpid} = [$cache, $rport];
		}
	    }
	}
    }
    $t->{server}->udp_request_cancel($id);
    my @s = keys %ips;
    @s = ((grep { /:/ } @s), (grep { ! /:/ } @s));
    $pid or $cache += 20;
    $t->{all_servers}{$bcindex}{$pid} = [$cache, \@s];
    return @s;
}

sub _getline {
    my ($t, $id) = @_;
    my $server = $t->{server};
    $id = $t->{id} if ! defined $id;
    $server->progress(0); # in case I'm talking to myself
    while (1) {
	my $count = $server->data_count($id, 1);
	defined $count or return undef;
	$count and return $server->write_in($id, 0);
	$server->progress(0.01); # in case I'm talking to myself
    }
}

sub _putline {
    my ($t, $line, $id) = @_;
    my $server = $t->{server};
    $id = $t->{id} if ! defined $id;
    $server->read_out($id, $line);
    $server->progress(0); # in case I'm talking to myself
}

sub _command {
    @_ == 2 || @_ == 3
	or croak "Usage: THEFT->_command(COMMAND [, ID])";
    my ($t, $cmd, $id) = @_;
    $t->_putline($cmd, $id);
    my $reply = $t->_getline($id);
    defined $reply or faint(SP_INTERNET, $t->{host}, "($cmd) Connection lost");
    $reply =~ /^2/ or faint(SP_INTERNET, $t->{host}, $reply);
    $reply;
}

sub _getlist {
    @_ == 1 || @_ == 2 or croak "Usage: THEFT->_getlist [(ID)]";
    my ($t, $id) = @_;
    my @list = ();
    while (1) {
	my $r = $t->_getline($id);
	defined $r or faint(SP_INTERNET, $t->{host}, "Connection lost");
	$r eq '.' and last;
	push @list, $r;
    }
    @list;
}

sub _open {
    my ($id, $sockhost, $peerhost, $close, $t) = @_;
    return "201 INTERNET (VICTIM) on $sockhost ($VERSION)";
}

sub _line {
    my ($server, $id, $close, $line, $t) = @_;
    if ($line =~ /^\s*(STEAL|SMUGGLE)\s+(\S+)/i) {
	my $code = $t->{code};
	return $code->(uc($1), $2, $id, $t, @{$t->{args}}, $t->{binary});
    } elsif ($line =~ /^\s*BINARY/i) {
	$t->{binary} = 1;
	return "252 Binary it is then";
    } elsif ($line =~ /^\s*HEX/i) {
	$t->{binary} = 2;
	return "252 Hex it is then";
    } elsif ($line =~ /^\s*THANKS/i) {
	$$close = 1;
	return "251 You are welcome";
    } else {
	return "550 Bad request";
    }
}

sub _close {
    my ($id, $t) = @_;
    # nothing to do here
}

sub pids {
    @_ == 1 || @_ == 2 or croak "Usage: THEFT->pids [(SERVER)]";
    my ($t, $server) = @_;
    # clean up cache
    _cleanup($t);
    my $id = undef;
    if (defined $server) {
	$id = $t->{server}->tcp_socket($server, $t->{port});
	$t->_getline($id);
    }
    $t->_command("CASE PID", $id);
    my @pids = map { /^(\d+)/ ? $1 : () } $t->_getlist($id);
    defined $id and $t->{server}->tcp_socket_close($id);
    @pids;
}

sub pids_and_ports {
    @_ == 1 || @_ == 2 or croak "Usage: THEFT->pids_and_ports [(SERVER)]";
    my ($t, $server) = @_;
    # clean up cache
    _cleanup($t);
    my $id = undef;
    if (defined $server) {
	# this function is only called by STEAL/SMUGGLE and if we get here
	# we'll want just a single pid, so if one is cached we'll use it
	if (exists $t->{known_pid}{$server}) {
	    my $known = $t->{known_pid}{$server};
	    my %pids = ($known->[1] => $known->[2]);
	    return %pids;
	}
	$id = $t->{server}->tcp_socket($server, $t->{port});
	$t->_getline($id);
    }
    $t->_command("CASE PID", $id);
    my %pids = map { /^(\d+)\b.*\b(\d+)\s*$/ ? ($1 => $2) : () } $t->_getlist($id);
    defined $id and $t->{server}->tcp_socket_close($id);
    %pids;
}

sub start_request {
    @_ == 5 or croak "Usage: THEFT->start_request(HOST, PID, PORT, TYPE)";
    my ($t, $host, $pid, $port, $type) = @_;
    $type = uc($type);
    $type eq 'STEAL' || $type eq 'SMUGGLE'
	or faint(SP_INTERNET, $host, "Invalid type $type");
    $t->{req_type} = $type;
    # clean up cache
    _cleanup($t);
    if (! defined $port) {
	# if the port is cached, use it, otherwise ask the remote theft server
	if (exists $t->{known_port}{$host}{$pid}) {
	    $port =  $t->{known_port}{$host}{$pid}[1];
	} else {
	    my $id = $t->{server}->tcp_socket($host, $t->{port});
	    $t->_getline($id);
	    $port = $t->_command("CASE PORT $pid", $id);
	    $t->{server}->tcp_socket_close($id);
	    $port =~ /^520/
		and faint(SP_INTERNET, $host, "No such PID $pid");
	    $port =~ /^2\d+\s+(\d+)/
		or faint(SP_INTERNET, $host, "Invalid reply $port");
	    $port = $1;
	}
    }
    my $request = $t->{server}->tcp_socket($host, $port);
    $t->_getline($request);
    # see if the binary protocol introduced in 1.-94.-2.3 is supported at
    # the other end; if not, it's OK, but we won't be able to support
    # the new features
    eval {
	$t->_putline('BINARY', $request);
	$t->_getline($request);
    };
    $t->{request} = $request;
    $t;
}

sub finish_request {
    @_ == 1 or croak "Usage: THEFT->end_request";
    my ($t) = @_;
    exists $t->{request} or faint(SP_INTERNET, $t->{host}, "Not in request");
    my $request = $t->{request};
    $t->_putline("THANKS", $request);
    $t->{server}->tcp_socket_close($request);
    delete $t->{request};
    $t;
}

sub request {
    @_ == 2 or croak "Usage: THEFT->request(REGISTER)";
    my ($t, $reg) = @_;
    exists $t->{req_type} or faint(SP_INTERNET, $t->{host}, "No TYPE");
    exists $t->{request} or faint(SP_INTERNET, $t->{host}, "Not in request");
    my $request = $t->{request};
    my $ok = $t->_command($t->{req_type} . ' ' . $reg, $request);
    $ok =~ /^250/ and return (undef, $t->_getlist($request));
    $ok =~ /^26([01])\s+(\d+)\s+(\d+)\b/i
	or faint(SP_INTERNET, $t->{host}, $ok);
    my ($hex, $len, $extra) = ($1, $2, $3);
    my $data = $t->{server}->write_binary($request, $len, 1);
    $hex and $data =~ s/([[:xdigit:]]{2})/chr(hex $1)/ge;
    return ($extra, $data);
}

# function called by syscall #900 to set hop limit
sub _hop_limit {
    @_ == 2 or croak "Usage: THEFT->_hop_limit(ENCODED_LIMIT)";
    my ($t, $req) = @_;
    my $server = $t->{server};
    ($req & 0xff000000) == 0x7f000000 && ($req & 0x00ffff00) != 0
	or faint(SP_IPV6, "Not a valid hop limit request");
    my $group = $t->decode_address($req & 0xffffff00);
    my $limit = ($req & 0x000000ff) || 1;
    $server->hop_limit($group, $limit);
}

1;
