1# $OpenBSD: Client.pm,v 1.5 2017/12/18 17:01:27 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::INET6; 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::INET6->new( 57 Type => $self->{socktype}, 58 Proto => $self->{protocol}, 59 Domain => $self->{domain}, 60 Blocking => ($self->{nonblocking} ? 0 : 1), 61 ) } or die ref($self), " socket connect failed: $!"; 62 do { local $> = 0; $cs->setsockopt(SOL_SOCKET, SO_BINDANY, 1) } 63 or die ref($self), " setsockopt SO_BINDANY failed: $!"; 64 my @rres = getaddrinfo($self->{bindaddr}, $self->{bindport}||0, 65 $self->{domain}, SOCK_STREAM, 0, AI_PASSIVE); 66 $cs->bind($rres[3]) 67 or die ref($self), " bind failed: $!"; 68 } elsif ($self->{bindaddr} || $self->{bindport}) { 69 do { local $> = 0; $cs = IO::Socket::INET6->new( 70 Type => $self->{socktype}, 71 Proto => $self->{protocol}, 72 Domain => $self->{domain}, 73 Blocking => ($self->{nonblocking} ? 0 : 1), 74 LocalAddr => $self->{bindaddr}, 75 LocalPort => $self->{bindport}, 76 ) } or die ref($self), " socket connect failed: $!"; 77 } 78 if ($cs) { 79 $self->{bindaddr} = $cs->sockhost(); 80 $self->{bindport} = $cs->sockport(); 81 $self->{cs} = $cs; 82 } 83 84 if ($self->{ktrace}) { 85 my @cmd = ("ktrace", "-c", "-f", $self->{ktracefile}, "-p", $$); 86 do { local $> = 0; system(@cmd) } 87 and die ref($self), " system '@cmd' failed: $?"; 88 } 89 90 return $self; 91} 92 93sub child { 94 my $self = shift; 95 96 my $cs = $self->{cs} || do { local $> = 0; IO::Socket::INET6->new( 97 Type => $self->{socktype}, 98 Proto => $self->{protocol}, 99 Domain => $self->{domain}, 100 Blocking => ($self->{nonblocking} ? 0 : 1), 101 ) } or die ref($self), " socket connect failed: $!"; 102 if ($self->{oobinline}) { 103 setsockopt($cs, SOL_SOCKET, SO_OOBINLINE, pack('i', 1)) 104 or die ref($self), " set oobinline connect failed: $!"; 105 } 106 if ($self->{sndbuf}) { 107 setsockopt($cs, SOL_SOCKET, SO_SNDBUF, 108 pack('i', $self->{sndbuf})) 109 or die ref($self), " set sndbuf connect failed: $!"; 110 } 111 if ($self->{rcvbuf}) { 112 setsockopt($cs, SOL_SOCKET, SO_RCVBUF, 113 pack('i', $self->{rcvbuf})) 114 or die ref($self), " set rcvbuf connect failed: $!"; 115 } 116 if ($self->{protocol} eq "tcp") { 117 setsockopt($cs, IPPROTO_TCP, TCP_NODELAY, pack('i', 1)) 118 or die ref($self), " set nodelay connect failed: $!"; 119 } 120 my @rres = getaddrinfo($self->{connectaddr}, $self->{connectport}, 121 $self->{domain}, SOCK_STREAM); 122 $cs->connect($rres[3]) 123 or die ref($self), " connect failed: $!"; 124 print STDERR "connect sock: ",$cs->sockhost()," ",$cs->sockport(),"\n"; 125 print STDERR "connect peer: ",$cs->peerhost()," ",$cs->peerport(),"\n"; 126 $self->{bindaddr} = $cs->sockhost(); 127 $self->{bindport} = $cs->sockport(); 128 129 open(STDOUT, '>&', $cs) 130 or die ref($self), " dup STDOUT failed: $!"; 131 open(STDIN, '<&', $cs) 132 or die ref($self), " dup STDIN failed: $!"; 133} 134 1351; 136