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