1#!/usr/local/bin/perl
2
3# tlink.pl: runs as a cgi program and passes request to Interchange server
4#
5# $Id: mod_perl_tlink.pl,v 2.4 2007-08-09 13:40:52 pajamian Exp $
6#
7# Copyright (C) 2002-2007 Interchange Development Group
8# Copyright (C) 1996-2002 Red Hat, Inc.
9#
10# This program is free software; you can redistribute it and/or
11# modify it under the terms of the GNU General Public License as
12# published by the Free Software Foundation; either version 2 of the
13# License, or (at your option) any later version.
14#
15# This program is distributed in the hope that it will be useful,
16# but WITHOUT ANY WARRANTY; without even the implied warranty of
17# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18# General Public License for more details.
19#
20# You should have received a copy of the GNU General Public License
21# along with this program; if not, write to the Free Software
22# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
23
24require 5.005;
25use strict;
26use Apache::Registry;
27use Socket;
28my @port_pool = (
29	7786,
30);
31
32my $LINK_TIMEOUT = 10;
33#my $LINK_TIMEOUT = ~_~LINK_TIMEOUT~_~;
34my $LINK_PORT    = $ENV{MINIVEND_PORT} || 7786;
35#my $LINK_PORT    = $ENV{MINIVEND_PORT} || ~_~LINK_HOST~_~;
36my $LINK_HOST    = 'localhost';
37#my $LINK_HOST    = '~_~LINK_HOST~_~';
38my $ERROR_ACTION = "-notify";
39
40# Uncomment this if you want to rotate ports....set port_pool above.
41# Will increase MV performance if you use multiple ports.
42#my $LINK_PORT    = $port_pool[ int( rand (scalar @port_pool) ) ];
43
44$ENV{PATH} = "/bin:/usr/bin";
45$ENV{IFS} = " ";
46
47my (%exclude_header) = qw/
48		SERVER_SIGNATURE    1
49		HTTP_ACCEPT_CHARSET 1
50		HTTP_ACCEPT         1
51		PATH                1
52		IFS                 1
53/;
54
55my $r = Apache->request();
56my $arg;
57my $env;
58my $ent;
59
60
61# Return this message to the browser when the server is not running.
62# Log an error log entry if set to notify
63
64sub server_not_running {
65
66	my $msg;
67
68	if($ERROR_ACTION =~ /not/i) {
69		warn "ALERT: Interchange server not running for $ENV{SCRIPT_NAME}\n";
70	}
71
72	$| = 1;
73	$r->content_type ("text/html");
74	$r->send_http_header("text/html");
75	$r->print (<<EOF);
76<HTML><HEAD><TITLE>Interchange server not running</TITLE></HEAD>
77<BODY BGCOLOR="#FFFFFF">
78<H3>We're sorry, the Interchange server was not running...</H3>
79<P>
80We are out of service or may be experiencing high system demand.
81Please try again soon.
82
83<H3>This is it:</H3>
84<PRE>
85$arg
86$env
87$ent
88</PRE>
89
90</BODY></HTML>
91EOF
92
93}
94
95# Return this message to the browser when a system error occurs.
96#
97sub die_page {
98  $r->print("Content-type: text/plain\r\n\r\n");
99  $r->print("We are sorry, but the Interchange server is unavailable due to a\r\n");
100  $r->print("system error.\r\n\r\n");
101  $r->print(sprintf "%s: %s (%d)\r\n", $_[0], $!, $?);
102  if($ERROR_ACTION =~ /not/i) {
103	warn "ALERT: Interchange $ENV{SCRIPT_NAME} $_[0]: $! ($?)\n";
104  }
105  Apache::exit(1);
106}
107
108
109# Read the entity from stdin if present.
110
111sub send_arguments {
112
113	my $count = @ARGV;
114	my $val = "arg $count\n";
115	for(@ARGV) {
116		$val .= length($_);
117		$val .= " $_\n";
118	}
119	return $val;
120}
121
122sub send_environment () {
123	my (@tmp) = keys %ENV;
124	my $count = @tmp;
125	my ($str);
126	my $val = "";
127	for(@tmp) {
128		($count--, next) if defined $exclude_header{$_};
129		$str = "$_=$ENV{$_}";
130		$val .= length($str);
131		$val .= " $str\n";
132	}
133	$val = "env $count\n$val";
134	return $val;
135}
136
137sub send_entity {
138	return '' unless defined $ENV{CONTENT_LENGTH};
139	my $len = $ENV{CONTENT_LENGTH};
140	return '' unless $len > 0;
141
142	my $val = "entity\n";
143	$val .= "$len ";
144	return $val . $r->content() . "\n";
145}
146
147$arg = send_arguments();
148$env = send_environment();
149$ent = send_entity();
150
151$SIG{PIPE} = sub { die_page("signal"); };
152$SIG{ALRM} = sub { server_not_running(); exit 1; };
153
154alarm $LINK_TIMEOUT;
155
156my ($remote, $port, $iaddr, $paddr, $proto, $line);
157
158$remote = $LINK_HOST;
159$port   = $LINK_PORT;
160
161if ($port =~ /\D/) { $port = getservbyname($port, 'tcp'); }
162
163die_page("no port") unless $port;
164
165$iaddr = inet_aton($remote);
166$paddr = sockaddr_in($port,$iaddr);
167
168$proto = getprotobyname('tcp');
169
170local(*SOCK);
171socket(SOCK, PF_INET, SOCK_STREAM, $proto)	or die "socket: $!\n";
172
173my $ok;
174
175do {
176   $ok = connect(SOCK, $paddr);
177} while ( ! defined $ok and $! =~ /interrupt/i);
178
179my $def = defined $ok;
180die "ok=$ok def: $def connect port=$LINK_PORT: $!\n" if ! $ok;
181
182use vars qw/$in $l/;
183
184select SOCK;
185$| = 1;
186
187alarm 0;
188for ( $arg, $env, $ent, "end\n" ) {
189	print $_;
190}
191
192while( <SOCK> ) {
193	$r->print($_);
194}
195
196close (SOCK)								or die "close: $!\n";
197Apache::exit();
198