#!/usr/bin/perl # require 5.002; use strict; BEGIN { $ENV{PATH} = '/usr/ucb:/bin' } use Socket qw( getaddrinfo getnameinfo IN6ADDR_ANY AF_UNSPEC SOCK_STREAM PF_UNSPEC AI_PASSIVE NI_NUMERICHOST NI_NUMERICSERV SOL_SOCKET SO_REUSEADDR SOMAXCONN ); use Carp; use IO::Select; my $myself = "$0 "; sub logmsg { print "$myself $$: @_ at ", scalar localtime, "\n" } my $host = shift || IN6ADDR_ANY; my $port = shift || 2345; my $proto = getprotobyname('tcp'); my $select = &bind_sockets($host,$port); logmsg "server started on port $port"; my %address_list; my $paddr; while(my @ready = $select->can_read()) { for my $socket ( @ready ) { my $paddr = accept(my $client, $socket); next if (! $paddr) ; my ($err,$addr,$m) = getnameinfo($paddr,NI_NUMERICHOST); my ($err,$name,$port) = getnameinfo($paddr,NI_NUMERICSERV); $address_list{$addr} = $name; my $user = <$client>; $user=~ s/[\r\n]//g; logmsg "connection from $user \@ $name [", $addr, "] at port $port"; print $client "Hello there, $name, it's now ", scalar localtime, "\n"; foreach my $k (keys %address_list) { print $client "$k = $address_list{$k}\n"; } close($client); } } sub bind_sockets { my ($host0,$port0) = @_; my $select = IO::Select->new(); my ($err,@res) = getaddrinfo($host0, $port0,{socktype=>SOCK_STREAM, flags=>AI_PASSIVE}); my @socket; my (@host); for my $res (@res) { my ($family, $socktype, $proto, $saddr, $canonname) = ( $res->{family} , $res->{socktype}, $res->{protocol}, $res->{addr}, $res->{canonname} ); my ($host, $port) = getnameinfo($saddr,NI_NUMERICHOST | NI_NUMERICSERV); print STDERR "Trying to bind to $host : $port... "; socket(my $fd, $family, $socktype, $proto) || next; setsockopt($fd, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) || die "setsockopt : $!"; if (bind($fd, $saddr)) { # sockaddr_in($port, INADDR_ANY) listen($fd,SOMAXCONN) || die "listen: $! "; $select->add($fd); print STDERR "connected.\n"; } else { print STDERR "failed.\n"; close($fd); } } if ($select->count == 0) { die "connect attempt failed\n"; } return $select; } sub accepts { my ($c, @sockets) = @_; # $c is dummy }