File Coverage

blib/lib/AxKit2/Config/Server.pm
Criterion Covered Total %
statement 9 55 16.3
branch 0 24 0.0
condition 0 2 0.0
subroutine 3 15 20.0
pod 0 12 0.0
total 12 108 11.1


line stmt bran cond sub pod time code
1             # Copyright 2001-2006 The Apache Software Foundation
2             #
3             # Licensed under the Apache License, Version 2.0 (the "License");
4             # you may not use this file except in compliance with the License.
5             # You may obtain a copy of the License at
6             #
7             # http://www.apache.org/licenses/LICENSE-2.0
8             #
9             # Unless required by applicable law or agreed to in writing, software
10             # distributed under the License is distributed on an "AS IS" BASIS,
11             # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12             # See the License for the specific language governing permissions and
13             # limitations under the License.
14             #
15              
16             package AxKit2::Config::Server;
17              
18             # Configuration for a server (aka listening port/service/vhost)
19              
20 9     9   49 use strict;
  9         16  
  9         297  
21 9     9   48 use warnings;
  9         18  
  9         259  
22              
23             # we don't use the Location class directly, but we call its methods so
24             # this use() is here to show the dependency
25 9     9   6406 use AxKit2::Config::Location;
  9         25  
  9         5185  
26              
27             sub new {
28 0     0 0   my $class = shift;
29 0           my $global = shift;
30 0           my $name = shift;
31            
32 0           my %defaults = (
33             Port => 8000,
34             Plugins => [],
35             Locations => [],
36             Notes => {},
37             CachedHooks => {},
38             );
39              
40 0           my %args = ( __global => $global, %defaults, @_ );
41            
42 0           return bless \%args, $class;
43             }
44              
45             sub global {
46 0     0 0   my $self = shift;
47 0           $self->{__global};
48             }
49              
50             sub path {
51 0     0 0   my $self = shift;
52 0           return "/";
53             }
54              
55             sub port {
56 0     0 0   my $self = shift;
57 0 0         @_ and $self->{Port} = shift;
58 0           $self->{Port};
59             }
60              
61             sub docroot {
62 0     0 0   my $self = shift;
63 0 0         @_ and $self->{DocumentRoot} = shift;
64 0 0         $self->{DocumentRoot} || $self->global->docroot;
65             }
66              
67             sub add_plugin {
68 0     0 0   my $self = shift;
69 0           push @{$self->{Plugins}}, shift;
  0            
70             }
71              
72             sub plugins {
73 0     0 0   my $self = shift;
74 0           @{$self->{Plugins}}, $self->global->plugins;
  0            
75             }
76              
77             sub plugin_dir {
78 0     0 0   my $self = shift;
79 0 0         @_ and $self->{PluginDir} = shift;
80 0 0         $self->{PluginDir} || $self->global->plugin_dir;
81             }
82              
83             sub add_location {
84 0     0 0   my $self = shift;
85 0           push @{$self->{Locations}}, shift;
  0            
86             }
87              
88             sub cached_hooks {
89 0     0 0   my $self = shift;
90 0           my $hook = shift;
91 0 0         @_ and $self->{CachedHooks}{$hook} = shift;
92 0           $self->{CachedHooks}{$hook};
93             }
94              
95             # given a path, find the config related to it
96             # sometimes this is a Location config, sometimes Server (i.e. $self)
97             sub get_config {
98 0     0 0   my $self = shift;
99 0           my $path = shift;
100            
101 0           for my $loc (reverse @{$self->{Locations}}) {
  0            
102 0 0         return $loc if $loc->matches($path);
103             }
104            
105 0           return $self;
106             }
107              
108             sub notes {
109 0     0 0   my $self = shift;
110 0   0       my $key = shift || die "notes() requires a key";
111            
112 0 0         @_ and $self->{Notes}{$key} = [ @_ ];
113 0 0         return $self->global->notes($key) if !exists $self->{Notes}{$key};
114 0 0         return @{ $self->{Notes}{$key} || [] } if wantarray;
  0 0          
115 0 0         ${ $self->{Notes}{$key} || [] }[0];
  0            
116             }
117              
118             1;