File Coverage

blib/lib/Net/Server/INET.pm
Criterion Covered Total %
statement 44 85 51.7
branch 2 14 14.2
condition 4 24 16.6
subroutine 14 33 42.4
pod 5 9 55.5
total 69 165 41.8


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             #
3             # Net::Server::INET - Net::Server personality
4             #
5             # Copyright (C) 2001-2017
6             #
7             # Paul Seamons
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              
18             package Net::Server::INET;
19              
20 2     2   13418 use strict;
  2         8  
  2         94  
21 2     2   10 use base qw(Net::Server);
  2         4  
  2         1276  
22 2     2   18 use Scalar::Util qw(blessed);
  2         4  
  2         788  
23              
24 0     0 0 0 sub net_server_type { __PACKAGE__ }
25              
26             sub post_configure {
27 1     1 1 4 my $self = shift;
28 1         4 $self->{'server'}->{'_is_inet'} = 1;
29 1         34 $self->SUPER::post_configure();
30 1         3 delete $self->{'server'}->{'_is_inet'};
31             }
32              
33       1 1   sub pre_bind {} # no need to prepare bind
34              
35       1 1   sub bind {} # inet has no port to bind
36              
37             sub accept { # connection is already accepted
38 1     1 0 2 my $self = shift;
39 1         3 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 1         2 delete $prop->{'udp_true'}; # not sure if we can do UDP on INET
44              
45 1         5 1;
46             }
47              
48             sub get_client_info {
49 1     1 1 3 my $self = shift;
50 1         4 my $prop = $self->{'server'};
51 1   33     15 my $sock = shift || $prop->{'client'};
52              
53 1 50 33     40 if (blessed($sock) && $sock->can('NS_proto') && $sock->NS_proto eq 'UNIX') {
      33        
54 0         0 $self->log(3, $self->log_time." CONNECT UNIX Socket: \"".$sock->NS_port."\"");
55 0         0 return;
56             }
57              
58 1   50     18 $prop->{'sockaddr'} = $ENV{'REMOTE_HOST'} || '0.0.0.0';
59 1         10 $prop->{'peeraddr'} = '0.0.0.0';
60 1         25 $prop->{'sockhost'} = $prop->{'peerhost'} = 'inetd.server';
61 1         14 $prop->{'sockport'} = $prop->{'peerport'} = 0;
62 1         4 return;
63             }
64              
65              
66 0     0 0 0 sub done { 1 } # accept only one connection per process
67              
68             sub post_accept { # set up handles
69 1     1 1 3 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 1         15 $self->{'server'}->{'client'} = Net::Server::INET::Handle->new();
77              
78             }
79              
80             ### can't hup single process
81       0 0   sub 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             ################################################################
88             package Net::Server::INET::Handle;
89              
90 2     2   14 use base qw(IO::Handle);
  2         4  
  2         190  
91 2     2   12 use strict;
  2         4  
  2         908  
92              
93             sub new {
94 1     1   4 my $class = shift;
95 1         2 local *HAND;
96 1         9 STDIN->autoflush(1);
97 1         48 STDOUT->autoflush(1);
98 1 50       31 tie *HAND, $class, *STDIN, *STDOUT or die "can't tie *HAND: $!";
99 1         3 bless \*HAND, $class;
100 1         15 return \*HAND;
101             }
102              
103 2     2   17 sub NS_proto { '' }
104              
105             sub TIEHANDLE {
106 1     1   14 my ($class, $in, $out) = @_;
107 1         18 bless [ \$in, \$out ], $class;
108             }
109              
110             sub PRINT {
111 0     0     my $handle = shift()->[1];
112 0           local *FH = $$handle;
113 0           CORE::print FH @_;
114             }
115              
116             sub PRINTF {
117 0     0     my $handle = shift()->[1];
118 0           local *FH = $$handle;
119 0           CORE::printf FH @_;
120             }
121              
122             sub WRITE {
123 0     0     my $handle = shift()->[1];
124 0           local *FH = $$handle;
125 0           local ($\) = "";
126 0 0         $_[1] = length($_[0]) unless defined $_[1];
127 0   0       CORE::print FH substr($_[0], $_[2] || 0, $_[1]);
128             }
129              
130             sub READ {
131 0     0     my $handle = shift()->[0];
132 0           local *FH = $$handle;
133 0   0       CORE::read(FH, $_[0], $_[1], $_[2] || 0);
134             }
135              
136             sub READLINE {
137 0     0     my $handle = shift()->[0];
138 0           local *FH = $$handle;
139 0           return scalar ;
140             }
141              
142             sub GETC {
143 0     0     my $handle = shift()->[0];
144 0           local *FH = $$handle;
145 0           return CORE::getc(FH);
146             }
147              
148             sub EOF {
149 0     0     my $handle = shift()->[0];
150 0           local *FH = $$handle;
151 0           return CORE::eof(FH);
152             }
153              
154       0     sub OPEN {}
155              
156             sub CLOSE {
157 0     0     my $self = shift;
158 0           $self = undef;
159             }
160              
161       0     sub BINMODE {}
162              
163       0     sub TELL {}
164              
165       0     sub SEEK {}
166              
167       0     sub DESTROY {}
168              
169       0     sub FILENO {}
170              
171       0     sub FETCH {}
172              
173             sub read_until { # only sips the data - but it allows for compatibility with SSLEAY
174 0     0     my ($client, $bytes, $end_qr) = @_;
175 0 0 0       die "One of bytes or end_qr should be defined for TCP read_until\n" if !defined($bytes) && !defined($end_qr);
176 0           my $content = '';
177 0           my $ok = 0;
178 0           while (1) {
179 0           $client->read($content, 1, length($content));
180 0 0 0       if (defined($bytes) && length($content) >= $bytes) {
    0 0        
181 0           $ok = 2;
182 0           last;
183             }
184             elsif (defined($end_qr) && $content =~ $end_qr) {
185 0           $ok = 1;
186 0           last;
187             }
188             }
189 0 0         return wantarray ? ($ok, $content) : $content;
190             }
191              
192             1;
193              
194              
195             __END__