1# -*- perl -*- 2# 3# Net::Server::INET - Net::Server personality 4# 5# Copyright (C) 2001-2017 6# 7# Paul Seamons <paul@seamons.com> 8# 9# This package may be distributed under the terms of either the 10# GNU General Public License 11# or the 12# Perl Artistic License 13# 14# All rights reserved. 15# 16################################################################ 17 18package Net::Server::INET; 19 20use strict; 21use base qw(Net::Server); 22use Scalar::Util qw(blessed); 23 24sub net_server_type { __PACKAGE__ } 25 26sub post_configure { 27 my $self = shift; 28 $self->{'server'}->{'_is_inet'} = 1; 29 $self->SUPER::post_configure(); 30 delete $self->{'server'}->{'_is_inet'}; 31} 32 33sub pre_bind {} # no need to prepare bind 34 35sub bind {} # inet has no port to bind 36 37sub accept { # connection is already accepted 38 my $self = shift; 39 my $prop = $self->{'server'}; 40 41 ### Net::Server::INET will not do any determination of TCP,UDP,Unix 42 ### it is up to the programmer to keep these as separate processes 43 delete $prop->{'udp_true'}; # not sure if we can do UDP on INET 44 45 1; 46} 47 48sub get_client_info { 49 my $self = shift; 50 my $prop = $self->{'server'}; 51 my $sock = shift || $prop->{'client'}; 52 53 if (blessed($sock) && $sock->can('NS_proto') && $sock->NS_proto eq 'UNIX') { 54 $self->log(3, $self->log_time." CONNECT UNIX Socket: \"".$sock->NS_port."\""); 55 return; 56 } 57 58 $prop->{'sockaddr'} = $ENV{'REMOTE_HOST'} || '0.0.0.0'; 59 $prop->{'peeraddr'} = '0.0.0.0'; 60 $prop->{'sockhost'} = $prop->{'peerhost'} = 'inetd.server'; 61 $prop->{'sockport'} = $prop->{'peerport'} = 0; 62 return; 63} 64 65 66sub done { 1 } # accept only one connection per process 67 68sub post_accept { # set up handles 69 my $self = shift; 70 71 ### STDIN and STDOUT are already bound 72 73 ### create a handle for those who want to use 74 ### an IO::Socket'ish handle - more portable 75 ### to just use STDIN and STDOUT though 76 $self->{'server'}->{'client'} = Net::Server::INET::Handle->new(); 77 78} 79 80### can't hup single process 81sub hup_server {} 82 83################################################################ 84### the rest are methods to tie STDIN and STDOUT to a GLOB 85### this most likely isn't necessary, but the methods are there 86### support for this is experimental and may go away 87################################################################ 88package Net::Server::INET::Handle; 89 90use base qw(IO::Handle); 91use strict; 92 93sub new { 94 my $class = shift; 95 local *HAND; 96 STDIN->autoflush(1); 97 STDOUT->autoflush(1); 98 tie *HAND, $class, *STDIN, *STDOUT or die "can't tie *HAND: $!"; 99 bless \*HAND, $class; 100 return \*HAND; 101} 102 103sub NS_proto { '' } 104 105sub TIEHANDLE { 106 my ($class, $in, $out) = @_; 107 bless [ \$in, \$out ], $class; 108} 109 110sub PRINT { 111 my $handle = shift()->[1]; 112 local *FH = $$handle; 113 CORE::print FH @_; 114} 115 116sub PRINTF { 117 my $handle = shift()->[1]; 118 local *FH = $$handle; 119 CORE::printf FH @_; 120} 121 122sub WRITE { 123 my $handle = shift()->[1]; 124 local *FH = $$handle; 125 local ($\) = ""; 126 $_[1] = length($_[0]) unless defined $_[1]; 127 CORE::print FH substr($_[0], $_[2] || 0, $_[1]); 128} 129 130sub READ { 131 my $handle = shift()->[0]; 132 local *FH = $$handle; 133 CORE::read(FH, $_[0], $_[1], $_[2] || 0); 134} 135 136sub READLINE { 137 my $handle = shift()->[0]; 138 local *FH = $$handle; 139 return scalar <FH>; 140} 141 142sub GETC { 143 my $handle = shift()->[0]; 144 local *FH = $$handle; 145 return CORE::getc(FH); 146} 147 148sub EOF { 149 my $handle = shift()->[0]; 150 local *FH = $$handle; 151 return CORE::eof(FH); 152} 153 154sub OPEN {} 155 156sub CLOSE { 157 my $self = shift; 158 $self = undef; 159} 160 161sub BINMODE {} 162 163sub TELL {} 164 165sub SEEK {} 166 167sub DESTROY {} 168 169sub FILENO {} 170 171sub FETCH {} 172 173sub read_until { # only sips the data - but it allows for compatibility with SSLEAY 174 my ($client, $bytes, $end_qr) = @_; 175 die "One of bytes or end_qr should be defined for TCP read_until\n" if !defined($bytes) && !defined($end_qr); 176 my $content = ''; 177 my $ok = 0; 178 while (1) { 179 $client->read($content, 1, length($content)); 180 if (defined($bytes) && length($content) >= $bytes) { 181 $ok = 2; 182 last; 183 } 184 elsif (defined($end_qr) && $content =~ $end_qr) { 185 $ok = 1; 186 last; 187 } 188 } 189 return wantarray ? ($ok, $content) : $content; 190} 191 1921; 193 194 195__END__ 196 197=head1 NAME 198 199Net::Server::INET - Net::Server personality 200 201=head1 SYNOPSIS 202 203 use base qw(Net::Server::INET); 204 205 sub process_request { 206 #...code... 207 } 208 209 Net::Server::INET->run(); 210 211=head1 DESCRIPTION 212 213Please read the pod on Net::Server first. This module is a 214personality, or extension, or sub class, of the Net::Server module. 215 216This personality is intended for use with inetd. It offers no methods 217beyond the Net::Server base class. This module operates by overriding 218the pre_bind, bind, accept, and post_accept methods to let all socket 219processing to be done by inetd. 220 221=head1 CONFIGURATION FILE 222 223See L<Net::Server>. 224 225=head1 PROCESS FLOW 226 227See L<Net::Server> 228 229=head1 HOOKS 230 231There are no additional hooks in Net::Server::INET. 232 233=head1 TO DO 234 235See L<Net::Server> 236 237=head1 AUTHOR 238 239Paul T. Seamons paul@seamons.com 240 241=head1 SEE ALSO 242 243Please see also 244L<Net::Server::Fork>, 245L<Net::Server::INET>, 246L<Net::Server::PreFork>, 247L<Net::Server::MultiType>, 248L<Net::Server::Single> 249 250=cut 251 252 253