File Coverage

blib/lib/Net/Server/MultiType.pm
Criterion Covered Total %
statement 32 48 66.6
branch 9 30 30.0
condition 3 10 30.0
subroutine 5 6 83.3
pod 1 3 33.3
total 50 97 51.5


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             #
3             # Net::Server::MultiType - 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::MultiType;
19              
20 6     6   9208 use strict;
  6         14  
  6         162  
21 6     6   24 use base qw(Net::Server);
  6         18  
  6         2310  
22              
23             #sub net_server_type { shift->SUPER::net_server_type }; # not-needed
24              
25             sub options {
26 6     6 0 11 my $self = shift;
27 6         50 my $ref = $self->SUPER::options(@_);
28 6   100     53 $ref->{'server_type'} = $self->{'server'}->{'server_type'} ||= [];
29 6         14 return $ref;
30             }
31              
32 0     0 0 0 sub default_server_type { 'Fork' }
33              
34             sub run {
35 3 50   3 1 3389 my $self = ref($_[0]) ? shift() : shift->new;
36 3 50       241 $self->{'server'}->{'_run_args'} = [@_ == 1 ? %{$_[0]} : @_];
  0         0  
37 3         105 $self->_initialize;
38 3         21 my $prop = $self->{'server'};
39              
40 3 50 33     114 if (!defined $prop->{'server_type'} || ! @{ $prop->{'server_type'} }) {
  3         21  
41 0 0 0     0 if (my $ref = $self->can('default_server_type') && $self->default_server_type) {
42 0 0       0 $prop->{'server_type'} = ref($ref) ? $ref : [$ref];
43             }
44             }
45 3 50       11 foreach my $type (@{ $prop->{'server_type'} || []}) {
  3         24  
46 3 50       12 next if $type eq 'MultiType';
47 3 50       47 $type = ($type =~ /^(\w+)$/) ? $1 : next; # satisfy taint
48              
49 3 50       32 my $pkg = ($type =~ /::/) ? $type : "Net::Server::$type";
50 3         26 (my $file = "$pkg.pm") =~ s{::}{/}g;
51 3         7 eval { require $file };
  3         2569  
52 3 50       13 if ($@){
53 0         0 warn "Couldn't become server type \"$pkg\" [$@]\n";
54 0         0 next;
55             }
56              
57             # handle items like HTTP and PSGI that aren't true Net::Server flavors, but themselves are MultiType
58 3 50       34 if ($pkg->isa(__PACKAGE__)) {
59 0   0     0 my $type = $self->default_server_type || 'Single';
60 0 0       0 $type = ($type =~ /^(\w+)$/) ? $1 : next; # satisfy taint
61 0 0       0 my $_pkg = ($type =~ /::/) ? $type : "Net::Server::$type";
62 0         0 $prop->{'_recursive_multitype'} = $_pkg;
63 0         0 (my $file = "$_pkg.pm") =~ s{::}{/}g;
64 0 0       0 eval { require $file } or die "Trouble becoming server type $pkg while loading default package $_pkg: $@\n";
  0         0  
65 0 0       0 die "Recursive inheritance - Package $pkg inherits from $_pkg.\n" if $_pkg->isa($pkg);
66 6     6   58 no strict 'refs';
  6         14  
  6         594  
67 0         0 @{"${pkg}::ISA"} = ($_pkg);
  0         0  
68             }
69              
70             # cludgy - doesn't allow multiple Net::Server::MultiType servers within same process
71             # but it is probably better than modifying our child's class for it
72 3         186 @Net::Server::MultiType::ISA = ($pkg);
73 3         23 last;
74             }
75              
76             # now run as the new type of thingy
77             # passing self, instead of package, doesn't instantiate a new object
78 3         27 $self->SUPER::run(@_);
79             }
80              
81             1;
82              
83             __END__