1# $OpenBSD: Client.pm,v 1.6 2021/12/12 21:16:53 bluhm Exp $ 2 3# Copyright (c) 2010-2017 Alexander Bluhm <bluhm@openbsd.org> 4# 5# Permission to use, copy, modify, and distribute this software for any 6# purpose with or without fee is hereby granted, provided that the above 7# copyright notice and this permission notice appear in all copies. 8# 9# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 17use strict; 18use warnings; 19 20package Client; 21use parent 'Proc'; 22use Carp; 23use Socket qw(IPPROTO_TCP TCP_NODELAY); 24use Socket6; 25use IO::Socket; 26use IO::Socket::IP -register; 27use constant SO_BINDANY => 0x1000; 28 29sub new { 30 my $class = shift; 31 my %args = @_; 32 $args{ktracefile} ||= "client.ktrace"; 33 $args{logfile} ||= "client.log"; 34 $args{up} ||= "Connected"; 35 $args{down} ||= $args{alarm} ? "Alarm $class" : 36 "Shutdown $class|Broken pipe|Connection reset by peer"; 37 my $self = Proc::new($class, %args); 38 $self->{domain} 39 or croak "$class domain not given"; 40 $self->{protocol} 41 or croak "$class protocol not given"; 42 $self->{connectaddr} 43 or croak "$class connect addr not given"; 44 $self->{connectport} || $self->{protocol} !~ /^(tcp|udp)$/ 45 or croak "$class connect port not given"; 46 47 if ($self->{ktrace}) { 48 unlink $self->{ktracefile}; 49 my @cmd = ("ktrace", "-f", $self->{ktracefile}, "-p", $$); 50 do { local $> = 0; system(@cmd) } 51 and die ref($self), " system '@cmd' failed: $?"; 52 } 53 54 my $cs; 55 if ($self->{bindany}) { 56 do { local $> = 0; $cs = IO::Socket->new( 57 Type => $self->{socktype}, 58 Proto => $self->{protocol}, 59 Domain => $self->{domain}, 60 ) } or die ref($self), " socket connect failed: $!"; 61 do { local $> = 0; $cs->setsockopt(SOL_SOCKET, SO_BINDANY, 1) } 62 or die ref($self), " setsockopt SO_BINDANY failed: $!"; 63 my @rres = getaddrinfo($self->{bindaddr}, $self->{bindport}||0, 64 $self->{domain}, SOCK_STREAM, 0, AI_PASSIVE); 65 $cs->bind($rres[3]) 66 or die ref($self), " bind failed: $!"; 67 } elsif ($self->{bindaddr} || $self->{bindport}) { 68 do { local $> = 0; $cs = IO::Socket->new( 69 Type => $self->{socktype}, 70 Proto => $self->{protocol}, 71 Domain => $self->{domain}, 72 LocalAddr => $self->{bindaddr}, 73 LocalPort => $self->{bindport}, 74 ) } or die ref($self), " socket connect failed: $!"; 75 } 76 if ($cs) { 77 $self->{bindaddr} = $cs->sockhost(); 78 $self->{bindport} = $cs->sockport(); 79 $self->{cs} = $cs; 80 } 81 82 if ($self->{ktrace}) { 83 my @cmd = ("ktrace", "-c", "-f", $self->{ktracefile}, "-p", $$); 84 do { local $> = 0; system(@cmd) } 85 and die ref($self), " system '@cmd' failed: $?"; 86 } 87 88 return $self; 89} 90 91sub child { 92 my $self = shift; 93 94 my $cs = $self->{cs} || do { local $> = 0; IO::Socket->new( 95 Type => $self->{socktype}, 96 Proto => $self->{protocol}, 97 Domain => $self->{domain}, 98 ) } or die ref($self), " socket connect failed: $!"; 99 if ($self->{oobinline}) { 100 setsockopt($cs, SOL_SOCKET, SO_OOBINLINE, pack('i', 1)) 101 or die ref($self), " set oobinline connect failed: $!"; 102 } 103 if ($self->{sndbuf}) { 104 setsockopt($cs, SOL_SOCKET, SO_SNDBUF, 105 pack('i', $self->{sndbuf})) 106 or die ref($self), " set sndbuf connect failed: $!"; 107 } 108 if ($self->{rcvbuf}) { 109 setsockopt($cs, SOL_SOCKET, SO_RCVBUF, 110 pack('i', $self->{rcvbuf})) 111 or die ref($self), " set rcvbuf connect failed: $!"; 112 } 113 if ($self->{protocol} eq "tcp") { 114 setsockopt($cs, IPPROTO_TCP, TCP_NODELAY, pack('i', 1)) 115 or die ref($self), " set nodelay connect failed: $!"; 116 } 117 my @rres = getaddrinfo($self->{connectaddr}, $self->{connectport}, 118 $self->{domain}, SOCK_STREAM); 119 $cs->connect($rres[3]) 120 or die ref($self), " connect failed: $!"; 121 print STDERR "connect sock: ",$cs->sockhost()," ",$cs->sockport(),"\n"; 122 print STDERR "connect peer: ",$cs->peerhost()," ",$cs->peerport(),"\n"; 123 $self->{bindaddr} = $cs->sockhost(); 124 $self->{bindport} = $cs->sockport(); 125 if ($self->{nonblocking}) { 126 $cs->blocking(0) 127 or die ref($self), " set non-blocking connect failed: $!"; 128 } 129 130 open(STDOUT, '>&', $cs) 131 or die ref($self), " dup STDOUT failed: $!"; 132 open(STDIN, '<&', $cs) 133 or die ref($self), " dup STDIN failed: $!"; 134} 135 1361; 137