1# -*-Perl-*- 2################################################################ 3### 4### TcpTransaction.pm 5### 6### Author: Internet Message Group <img@mew.org> 7### Created: Apr 23, 1997 8### Revised: Apr 23, 2007 9### 10 11my $PM_VERSION = "IM::TcpTransaction.pm version 20161010(IM153)"; 12 13package IM::TcpTransaction; 14require 5.003; 15require Exporter; 16use IM::Config qw(dns_timeout connect_timeout command_timeout rcv_buf_siz); 17use Socket; 18BEGIN { 19 eval 'use Socket6' unless (eval '&AF_INET6'); # IPv6 patched Perl 20} 21use IM::Util; 22use IM::Ssh; 23use integer; 24use strict; 25use vars qw(@ISA @EXPORT); 26 27@ISA = qw(Exporter); 28@EXPORT = qw(log_transaction 29 connect_server tcp_command send_command next_response send_data 30 command_response set_command_response tcp_logging 31 get_session_log set_cur_server get_cur_server get_cur_server_original_form 32 pool_priv_sock); 33 34use vars qw($Cur_server $Cur_server_original_form $Session_log $TcpSockName 35 $SOCK @Response $Logging @SockPool @Sock6Pool); 36BEGIN { 37 $Cur_server = ''; 38 $Session_log = ''; 39 $TcpSockName = 'tcp00'; 40} 41 42sub log_transaction() { 43 use IM::Log; 44} 45 46##### MAKE TCP CONNECTION TO SPECIFIED SERVER ##### 47# 48# connect_server(server_list, protocol, root) 49# server_list: comma separated server list 50# protocol: protocol name to be used with the servers 51# root: privilidge port required 52# return value: handle if success 53# 54sub connect_server($$$) { 55 my($servers, $serv, $root) = @_; 56 57 if ($#$servers < 0) { 58 im_err("no server specified for $serv\n"); 59 return ''; 60 } 61 62 $SIG{'ALRM'} = \&alarm_func; 63 64 no strict 'refs'; # XXX 65 local(*SOCK) = \*{$TcpSockName}; 66 $SOCK = $serv; 67 @Response = (); 68 my(@he_infos); 69 my($s, $localport, $remoteport); 70 foreach $s (@$servers) { 71 $Cur_server_original_form = $s; 72 my($r) = ($#$servers >= 0) ? 'skipped' : 'failed'; 73 # manage server[/remoteport]%localport 74 if ($s =~ s/\%(\d+)$//) { 75 $localport = $1; 76 $Cur_server = $s; 77 if ($s =~ s/\/(\d+)$//) { 78 $remoteport = $1; 79 } else { 80 next unless ($remoteport = getserv($serv, 'tcp')); 81 } 82 if ($main::SSH_server eq 'localhost') { 83 im_warn("Don't use port-forwarding to `localhost'.\n"); 84 $Cur_server = "$s/$remoteport"; 85 } else { 86 if ($remoteport = &ssh_proxy($s,$remoteport,$localport,$main::SSH_server)) { 87 $s = 'localhost'; 88 $Cur_server = "$Cur_server%$remoteport"; 89 } else { # Connection failed. 90 im_warn("Can't login to $main::SSH_server\n"); 91 if ($serv eq 'smtp') { 92 &log_action($serv, $Cur_server, 93 join(',', @main::Recipients), $r, @Response); 94 } else { # NNTP 95 &log_action($serv, $Cur_server, 96 $main::Newsgroups, $r, @Response); 97 } 98 next; 99 } 100 } 101 } 102 # manage server[/remoteport] notation 103 elsif ($s =~ /([^\/]*)\/(\d+)$/) { 104 $remoteport = $2; 105 $s = $1; 106 $Cur_server = "$s/$remoteport"; 107 } else { 108 $remoteport = $serv; 109 $Cur_server = $s; 110 } 111 $0 = progname() . ": im_getaddrinfo($s)"; 112 @he_infos = im_getaddrinfo($s, $remoteport, AF_UNSPEC, SOCK_STREAM); 113 if ($#he_infos < 1) { 114 im_warn("address unknown for $s\n"); 115 @Response = ("address unknown for $s"); 116 if ($serv eq 'smtp') { 117 &log_action($serv, $Cur_server, 118 join(',', @main::Recipients), $r, @Response); 119 } else { # NNTP 120 &log_action($serv, $Cur_server, 121 $main::Newsgroups, $r, @Response); 122 } 123 next; 124 } 125 while ($#he_infos >= 0) { 126 my($family, $socktype, $proto, $sin, $canonname) 127 = splice(@he_infos, 0, 5); 128 if ($root && unixp()) { 129 my $name = priv_sock($family); 130 my $port; 131 if ($name eq '') { 132 im_err("privilege port pool is empty.\n"); 133 return ''; 134 } 135 if ($family == AF_INET) { 136 $port = (unpack_sockaddr_in($sin))[0]; 137 } else { 138 $port = (unpack_sockaddr_in6($sin))[0]; 139 } 140 *SOCK = \*{$name}; 141 $SOCK = $port; 142 } else { 143 unless (socket(SOCK, $family, $socktype, $proto)) { 144 im_err("socket creation failed: $!.\n"); 145 return ''; 146 } 147 if (defined(rcv_buf_siz())) { 148 unless (setsockopt(SOCK, SOL_SOCKET, SO_RCVBUF, int(rcv_buf_siz()))) { 149 im_err("setsockopt failed: $!.\n"); 150 return ''; 151 } 152 } 153 } 154 155 im_notice("opening $serv session to $s($remoteport).\n"); 156 alarm(connect_timeout()) unless win95p(); 157 $0 = progname() . ": connecting to $s with $serv"; 158 if (connect (SOCK, $sin)) { 159 alarm(0) unless win95p(); 160 select (SOCK); $| = 1; select (STDOUT); 161 $Session_log .= 162 "Transcription of $serv session follows:\n" if ($Logging); 163 im_debug("handle $TcpSockName allocated.\n") 164 if (&debug('tcp')); 165 $TcpSockName++; 166 return *SOCK; 167 } 168 @Response = ($!); 169 alarm(0) unless win95p(); 170 close(SOCK); 171 } 172 im_notice("$serv server $s($remoteport) did not respond.\n"); 173 if ($serv eq 'smtp') { 174 &log_action($serv, $Cur_server, 175 join(',', @main::Recipients), $r, @Response); 176 } else { # NNTP 177 &log_action($serv, $Cur_server, 178 $main::Newsgroups, $r, @Response); 179 } 180 } 181 im_warn("WARNING: $serv connection was not established.\n"); 182 return ''; 183} 184 185##### CLIENT-SERVER HANDSHAKE ##### 186# 187# tcp_command(channel, command, fake_message) 188# channel: socket descriptor to send the command 189# command: command string to be sent 190# return value: 191# 0: success 192# 1: recoverable error (should be retried) 193# -1: unrecoverable error 194# 195sub tcp_command($$$) { 196 my($CHAN, $command, $fake) = @_; 197 my($resp, $stat, $rcode, $logcmd); 198 199 @Response = (); 200 $stat = ''; 201 if ($fake) { 202 $logcmd = $fake; 203 } else { 204 $logcmd = $command; 205 } 206 if ($command) { 207 im_notice("<<< $logcmd\n"); 208 $Session_log .= "<<< $logcmd\n" if ($Logging); 209 unless (print $CHAN "$command\r\n") { 210 # may be channel trouble 211 @Response = ($!); 212 return 1; 213 } 214 $0 = progname() . ": $logcmd ($Cur_server)"; 215 } else { 216## if you have mysterious TCP/IP bug on IRIX/SGI 217# print $CHAN ' '; 218## endif 219 $0 = progname() . ": greeting ($Cur_server)"; 220 } 221 do { 222 alarm(command_timeout()) unless win95p(); 223 $resp = <$CHAN>; 224 if (!defined($resp)) { 225 # may be channel trouble 226 @Response = ("$!"); 227 } 228 alarm(0) unless win95p(); 229 if (!defined($resp)) { 230 # may be channel trouble 231 return 1; 232 } 233 $resp =~ s/[\r\n]+$//; 234 if ($resp =~ /^([0-9][0-9][0-9])/) { 235 $rcode = $1; 236 if ($stat eq '' && $rcode !~ /^0/) { 237 $stat = $rcode; 238 } 239 push(@Response, $resp) if ($rcode !~ /^0/); # XXX 240 } 241 im_notice(">>> $resp\n"); 242 $Session_log .= ">>> $resp\n" if ($Logging); 243 last if ($resp =~ /^\.$/); 244 } while ($resp =~ /^...-/ || $resp =~ /^[^1-9]/); 245 return 0 if ($stat =~ /^[23]../); 246 return 1 if ($stat =~ /^4../); 247 return -1; 248} 249 250##### CLIENT-SERVER HANDSHAKE ##### 251# 252# send_command(channel, command, fake_message) 253# return value: the first line of responses 254# 255sub send_command($$$) { 256 my($CHAN, $command, $fake) = @_; 257 my($resp, $logcmd); 258 if ($command) { 259 print $CHAN "$command\r\n"; 260 if ($fake) { 261 $logcmd = $fake; 262 } else { 263 $logcmd = $command; 264 } 265 im_notice("<<< $logcmd\n"); 266 $Session_log .= "<<< $logcmd\n" if ($Logging); 267 $0 = progname() . ": $logcmd ($Cur_server)"; 268 } else { 269 $0 = progname() . ": greeting ($Cur_server)"; 270 } 271 alarm(command_timeout()) unless win95p(); 272 $resp = <$CHAN>; 273 if (!defined($resp)) { 274 # may be channel trouble 275 im_notice("$!\n"); 276 } 277 alarm(0) unless win95p(); 278 if (!defined($resp)) { 279 # may be channel trouble 280 return ''; 281 } 282 $resp =~ s/[\r\n]+/\n/; 283 im_notice(">>> $resp"); 284 $Session_log .= ">>> $resp" if ($Logging); 285 chomp $resp; 286 return $resp; 287} 288 289sub send_data($$$) { 290 my($CHAN, $data, $fake) = @_; 291 my($logdata); 292 $data =~ s/\r?\n?$//; 293 print $CHAN "$data\r\n"; 294 if ($fake) { 295 $logdata = $fake; 296 } else { 297 $logdata = $data; 298 } 299 im_notice("<<< $logdata\n"); 300 $Session_log .= "<<< $logdata\n" if ($Logging); 301} 302 303sub next_response($) { 304 my $CHAN = shift; 305 my $resp; 306 307 alarm(command_timeout()) unless win95p(); 308 $resp = <$CHAN>; 309 if (!defined($resp)) { 310 # may be channel trouble 311 im_notice("$!\n"); 312 } 313 alarm(0) unless win95p(); 314 if (!defined($resp)) { 315 # may be channel trouble 316 return ''; 317 } 318 $resp =~ s/[\r\n]+/\n/; 319 im_notice(">>> $resp"); 320 $Session_log .= ">>> $resp" if ($Logging); 321 chomp $resp; 322 return $resp; 323} 324 325sub command_response() { 326 return @Response; 327} 328 329sub set_command_response(@) { 330 @Response = @_; 331} 332 333sub tcp_logging($) { 334# conversations are saved in $Session_log if true 335 $Logging = shift; 336} 337 338sub get_session_log() { 339 return $Session_log; 340} 341 342sub set_cur_server($) { 343 $Cur_server = shift; 344} 345 346sub get_cur_server() { 347 return $Cur_server; 348} 349 350sub get_cur_server_original_form() { 351 return $Cur_server_original_form; 352} 353 354sub pool_priv_sock($) { 355 my $count = shift; 356 357 pool_priv_sock_af($count, AF_INET); 358 if (eval 'pack_sockaddr_in6(110, pack("N4", 0, 0, 0, 0))') { 359 no strict 'subs'; # XXX for AF_INET6 360 pool_priv_sock_af($count, AF_INET6); 361 } 362} 363 364sub pool_priv_sock_af($$) { 365 my($count, $family) = @_; 366 my $privport = 1023; 367 368 no strict 'refs'; # XXX 369 my($pe_name, $pe_aliases, $pe_proto); 370 ($pe_name, $pe_aliases, $pe_proto) = getprotobyname ('tcp'); 371 unless ($pe_name) { 372 $pe_proto = 6; 373 } 374 while ($count--) { 375 unless (socket(*{$TcpSockName}, $family, SOCK_STREAM, $pe_proto)) { 376 im_err("socket creation failed: $!.\n"); 377 return -1; 378 } 379 while ($privport > 0) { 380 my($ANYADDR, $psin); 381 382 im_debug("binding port $privport.\n") if (&debug('tcp')); 383 if ($family == AF_INET) { 384 $ANYADDR = pack('C4', 0, 0, 0, 0); 385 $psin = pack_sockaddr_in($privport, $ANYADDR); 386 } else { 387 $ANYADDR = pack('N4', 0, 0, 0, 0); 388 $psin = pack_sockaddr_in6($privport, $ANYADDR); 389 } 390 last if (bind (*{$TcpSockName}, $psin)); 391 im_warn("privileged socket binding failed: $!.\n") 392 if (&debug('tcp')); 393 $privport--; 394 } 395 if ($privport == 0) { 396 im_err("binding to privileged port failed: $!.\n"); 397 return -1; 398 } 399 im_notice("pool_priv_sock: $TcpSockName got\n"); 400 if ($family == AF_INET) { 401 push(@SockPool, $TcpSockName); 402 } else { 403 push(@Sock6Pool, $TcpSockName); 404 } 405 $TcpSockName++; 406 } 407 return 0; 408} 409 410sub priv_sock($) { 411 my($family) = shift; 412 my($sock_name); 413 414 if ($family == AF_INET) { 415 return '' if ($#SockPool < 0); 416 $sock_name = shift(@SockPool); 417 } else { 418 return '' if ($#Sock6Pool < 0); 419 $sock_name = shift(@Sock6Pool); 420 } 421 im_notice("priv_sock: $sock_name\n"); 422 return $sock_name; 423} 424 425sub alarm_func { 426 im_die("connection error\n"); 427} 428 429sub im_getaddrinfo($$;$$$$) { 430 return getaddrinfo(@_) if (defined &getaddrinfo); 431 432 my($node, $serv, $family, $socktype, $proto, $flags) = @_; 433 434 my($pe_name, $pe_aliases, $pe_proto, $se_port); 435 if (unixp()) { 436 $proto = 'tcp' unless ($proto); 437 ($pe_name, $pe_aliases, $pe_proto) = getprotobyname($proto); 438 } 439 $pe_proto = 6 unless ($pe_name); 440 return unless ($se_port = getserv($serv, $proto)); 441 442 my($he_name, $he_alias, $he_type, $he_len, @he_addrs); 443 if ($node =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) { 444 @he_addrs = (pack('C4', $1, $2, $3, $4)); 445 } else { 446 alarm(dns_timeout()) unless win95p(); 447 ($he_name, $he_alias, $he_type, $he_len, @he_addrs) 448 = gethostbyname($node); 449 alarm(0) unless win95p(); 450 return unless ($he_name); 451 } 452 453 my($he_addr, @infos); 454 foreach $he_addr (@he_addrs) { 455 push(@infos, AF_INET, $socktype, $pe_proto, 456 pack_sockaddr_in($se_port, $he_addr), $he_name); 457 } 458 @infos; 459} 460 461sub getserv($$) { 462 my($serv, $proto) = @_; 463 464 my($se_port); 465 if ($serv =~ /^\d+$/o) { 466 $se_port = $serv; 467 } else { 468 my($se_name, $se_aliases); 469 ($se_name, $se_aliases, $se_port) = getservbyname($serv, $proto) 470 if (unixp()); 471 unless ($se_name) { 472 if ($serv eq 'smtp') { 473 $se_port = 25; 474 } elsif ($serv eq 'http') { 475 $se_port = 80; 476 } elsif ($serv eq 'nntp') { 477 $se_port = 119; 478 } elsif ($serv eq 'pop3') { 479 $se_port = 110; 480 } elsif ($serv eq 'imap') { 481 $se_port = 143; 482 } else { 483 im_err("unknown service: $serv\n"); 484 return undef; 485 } 486 } 487 } 488 $se_port; 489} 490 4911; 492 493__END__ 494 495=head1 NAME 496 497IM::TcpTransaction - TCP transaction processing interface for SMTP and NNTP 498 499=head1 SYNOPSIS 500 501 use IM::TcpTransaction; 502 503 $socket = &connect_server(server_list, protocol, log_flag); 504 $return_code = &tcp_command(socket, command_string, log_flag); 505 @response = &command_response; 506 &set_command_response(response_string_list); 507 508=head1 DESCRIPTION 509 510The I<IM::TcpTransaction> module handles TCP transaction for SMTP and NNTP. 511 512This modules is provided by IM (Internet Message). 513 514=head1 COPYRIGHT 515 516IM (Internet Message) is copyrighted by IM developing team. 517You can redistribute it and/or modify it under the modified BSD 518license. See the copyright file for more details. 519 520=cut 521 522### Copyright (C) 1997, 1998, 1999 IM developing team 523### All rights reserved. 524### 525### Redistribution and use in source and binary forms, with or without 526### modification, are permitted provided that the following conditions 527### are met: 528### 529### 1. Redistributions of source code must retain the above copyright 530### notice, this list of conditions and the following disclaimer. 531### 2. Redistributions in binary form must reproduce the above copyright 532### notice, this list of conditions and the following disclaimer in the 533### documentation and/or other materials provided with the distribution. 534### 3. Neither the name of the team nor the names of its contributors 535### may be used to endorse or promote products derived from this software 536### without specific prior written permission. 537### 538### THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND 539### ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 540### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 541### PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE 542### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 543### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 544### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR 545### BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 546### WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 547### OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN 548### IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 549