DragonFlyBSD

#!/usr/bin/env perl -Tw

use strict;

use Socket;

use Carp;

sub spawn;  # forward declaration

sub logmsg { print STDERR "$0 $$: @_ at ", scalar localtime(), "\n" }

my $port  = 3128;

die "invalid port" unless $port =~ /^ \d+ $/x;

my $proto = getprotobyname("tcp");

socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";

setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) || die "setsockopt: $!";

bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!";

listen(Server, SOMAXCONN) || die "listen: $!";

logmsg "server started on port $port";

my $paddr;

use POSIX ":sys_wait_h";

use Errno;

sub REAPER {

	local $!;

	while ((my $pid = waitpid(-1, WNOHANG)) > 0 && WIFEXITED($?)) {

		logmsg "reaped $pid" . ($? ? " with exit $?" : "");

	}

	$SIG{CHLD} = \&REAPER;

}

$SIG{CHLD} = \&REAPER;

for (;;) {

	$paddr = accept(Client, Server) || do {

		next if $!{EINTR};

		die "accept: $!";

	};

	my ($port, $iaddr) = sockaddr_in($paddr);

	my $name = gethostbyaddr($iaddr, AF_INET);

	logmsg "connection from $name [", inet_ntoa($iaddr), "] at port $port";

	spawn sub { $| = 1; while (<>) { print; print STDERR $_; } };

	close Client;

}

sub spawn {

	my $coderef = shift;

	confess "usage: spawn CODEREF" unless @_ == 0 && $coderef && ref($coderef) eq "CODE";

	my $pid;

	unless (defined($pid = fork())) {

		logmsg "cannot fork: $!";

		return;

	}

	if ($pid) {

		logmsg "begat $pid";

		return;

	}

	open(STDIN,  "<&Client") || die "can't dup client to stdin";

	open(STDOUT, ">&Client") || die "can't dup client to stdout";

	exit($coderef->());

}