File Coverage

blib/lib/Net/Server/MultiType.pm

Criterion	Covered	Total	%
statement	35	51	68.6
branch	9	30	30.0
condition	3	10	30.0
subroutine	6	7	85.7
pod	1	3	33.3
total	54	101	53.4

# -*- perl -*-
#
#  Net::Server::MultiType - Net::Server personality
#
#  Copyright (C) 2001-2022
#
#    Paul Seamons
#
#  This package may be distributed under the terms of either the
#  GNU General Public License
#    or the
#  Perl Artistic License
#
#  All rights reserved.
#
################################################################

package Net::Server::MultiType;

use strict;
use Carp qw(croak);
use base qw(Net::Server);

#sub net_server_type { shift->SUPER::net_server_type }; # not-needed

sub options {
    my $self = shift;
    my $ref  = $self->SUPER::options(@_);
    $ref->{'server_type'} = $self->{'server'}->{'server_type'} ||= [];
    return $ref;
}

sub default_server_type { 'Fork' }

sub run {
    my $self = ref($_[0]) ? shift() : shift->new;
    $self->{'server'}->{'_run_args'} = [@_ == 1 ? %{$_[0]} : @_];
    $self->_initialize;
    my $prop = $self->{'server'};

    if (!defined $prop->{'server_type'} || ! @{ $prop->{'server_type'} }) {
        if (my $ref = $self->can('default_server_type') && $self->default_server_type) {
            $prop->{'server_type'} = ref($ref) ? $ref : [$ref];
        }
    }
    foreach my $type (@{ $prop->{'server_type'} || []}) {
        next if $type eq 'MultiType';
        $type = ($type =~ /^(\w+)$/) ? $1 : next; # satisfy taint

        my $pkg = ($type =~ /::/) ? $type : "Net::Server::$type";
        (my $file = "$pkg.pm") =~ s{::}{/}g;
        eval { require $file };
        if ($@){
            warn "Couldn't become server type \"$pkg\" [$@]\n";
            next;
        }

        # handle items like HTTP and PSGI that aren't true Net::Server flavors, but themselves are MultiType
        if ($pkg->isa(__PACKAGE__)) {
            my $type = $self->default_server_type || 'Single';
            $type = ($type =~ /^(\w+)$/) ? $1 : next; # satisfy taint
            my $_pkg = ($type =~ /::/) ? $type : "Net::Server::$type";
            $prop->{'_recursive_multitype'} = $_pkg;
            (my $file = "$_pkg.pm") =~ s{::}{/}g;
            eval { require $file } or croak "Trouble becoming server type $pkg while loading default package $_pkg: $@";
            croak "Recursive inheritance - Package $pkg inherits from $_pkg" if $_pkg->isa($pkg);
            no strict 'refs';
            @{"${pkg}::ISA"} = ($_pkg);
        }

        # kludgy - doesn't allow multiple Net::Server::MultiType servers within same process
        # but it is probably better than modifying our child's class for it
        @Net::Server::MultiType::ISA = ($pkg);
        last;
    }

    # now run as the new type of thingy
    # passing self, instead of package, doesn't instantiate a new object
    $self->SUPER::run(@_);
}

1;

__END__