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