#!/usr/bin/perl 

###############################################################################
# cgi2vw.pl - Perl version of cgi2vw relay
#
# $Id: cgi2vw.pl,v 1.10 2007/03/21 18:25:15 phatch Exp $
#
###############################################################################

###############################################################################
##                                                                           ##
##                   ---==User configurable variables==---                   ##
##                                                                           ##
###############################################################################
# Name or IP address of the host running VisualWorks
my $VWSERVER		= 'localhost';

# Port number on the above host where VisualWorks is listening
my $VWPORT			= 2223;

# For machines with multiple host interfaces or virtual interfaces, sometimes
# firewall rules will only allow certain connections between the relay host
# and the host that's running the VisualWorks server.
# Values:
#   'any'     - bind to 0.0.0.0 (INADDR_ANY)
#   'cgi-env' - bind to an address obtained from the CGI environment.  The
#               following variables are checked:
#                   SERVER_ADDR   (apache)
#                   LOCAL_ADDR       (iis)
#                   SERVER_NAME (standard)
#               Sometimes the contents of SERVER_NAME doesn't resolve to
#               an IP address.  If the first two variables aren't present,
#               and SERVER_NAME doesn't resolve, then the 'x.y.z.w' value
#               format must be used.
#   'x.y.z.w' - The IP address of the local interface to use for the source
#               address.
my $relay_src_addr = 'any';

# Perform data transfers in blocks of $block_size bytes.
my $block_size= 8192;

###############################################################################
##                ---==End of user configurable variables==---               ##
###############################################################################

use Socket;
use strict;

binmode STDIN;
binmode STDOUT;

sub openSock {
	my ($laddr, $lport, $host, $port) = @_;
	local(*SOCK);

	$laddr = sockaddr_in($lport, inet_aton($laddr));
	my $paddr = sockaddr_in($port, inet_aton($host));
	my $proto = getprotobyname 'tcp';

	socket SOCK, PF_INET, SOCK_STREAM, $proto
		or die "Couldn't create socket, $!";

	setsockopt SOCK, SOL_SOCKET, SO_REUSEADDR, 1
		or die "Couldn't set socket option, $!";

	bind SOCK, $laddr
		or die "Couldn't bind socket, $!";

	connect SOCK, $paddr
		or die "Couldn't connect to peer, $!";

	select(SOCK); $| = 1; select(STDOUT);

	return *SOCK;
}

sub passEnv {
	my $sock = shift;
	# IIS has a broken PATH_INFO that needs to be fixed.
	# If we find the name of this script in PATH_INFO, then
	# this isn't a Virtual Directory invocation and we set
	# the PATH_INFO variable to be everything following the
	# script's name.
	if ($ENV{'SERVER_SOFTWARE'} =~ /IIS/) {
		my ($bn) = $0 =~ m#([^/\\]+)$#;
		if ($ENV{'PATH_INFO'} =~ m#^.*?/\Q$bn\E(/.*)?$#) {
			$ENV{'PATH_INFO'} = $1 || '/';
		}
	}
	print $sock map { "$_=$ENV{$_}\n" } keys %ENV;
	print $sock "\%\n";
}

sub passPost {
	return unless $ENV{'REQUEST_METHOD'} eq "POST";
	my $sock = shift;
	my $content_length = $ENV{'CONTENT_LENGTH'};
	my ($data, $res);
	if ( defined $content_length ) {
		my $remaining = $content_length;
		my $bytes;
		while ($remaining > 0) {
			$bytes = $remaining > $block_size ? $block_size : $remaining;
			$res = read STDIN, $data, $bytes;
			die "Read from STDIN failed: $!"
				unless defined $res;
			print $sock $data;
			$remaining -= $res;
		}
	} else {
		# Apache doesn't define CONTENT_LENGTH and passes dechunked
		# POST bodies on STDIN.  Apache closes script's STDIN to
		# signify end-of-data.
		local $/ = \$block_size;
		while (<STDIN>) { print $sock $_ }
	}
	shutdown $sock, 1;
}

sub sendResponse {
	my $sock = shift;
	local $/ = \$block_size;
	while(<$sock>) {
		print;
	}
}

sub closeSock {
	close shift
		or die "Couldn't close socket, $!";
	return 1;
}

sub Main {
	my ($host, $port) = ($VWSERVER, $VWPORT);
	my ($sock, $laddr);
	if ($relay_src_addr eq 'cgi-env') {
		$laddr   = $ENV{'SERVER_ADDR'};
		$laddr ||= $ENV{'LOCAL_ADDR'};
		$laddr ||= $ENV{'SERVER_NAME'};
	} elsif ($relay_src_addr eq 'any') {
		$laddr = '0.0.0.0';
	} else {
		$laddr = $relay_src_addr;
	}
	$laddr ||= '0.0.0.0';

	# Allow overriding hostname and port number if user abides by
	# the same naming convention used by the C relay.
	if ( $0 =~ m#([^/\\]+)@(\d+)(?:\.pl)?$# ) {
		$host = $1;
		$port = $2;
	}

	$sock = openSock($laddr, 0, $host, $port);
	passEnv($sock);
	passPost($sock);
	sendResponse($sock);
	closeSock($sock);
	return 0;
}

Main();

