| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  |  | 
| 2 |  |  |  |  |  |  | package IOC::Container; | 
| 3 |  |  |  |  |  |  |  | 
| 4 | 22 |  |  | 22 |  | 321579 | use strict; | 
|  | 22 |  |  |  |  | 50 |  | 
|  | 22 |  |  |  |  | 888 |  | 
| 5 | 22 |  |  | 22 |  | 266 | use warnings; | 
|  | 22 |  |  |  |  | 40 |  | 
|  | 22 |  |  |  |  | 1108 |  | 
| 6 |  |  |  |  |  |  |  | 
| 7 |  |  |  |  |  |  | our $VERSION = '0.14'; | 
| 8 |  |  |  |  |  |  |  | 
| 9 | 22 |  |  | 22 |  | 156 | use Scalar::Util qw(blessed); | 
|  | 22 |  |  |  |  | 45 |  | 
|  | 22 |  |  |  |  | 3210 |  | 
| 10 |  |  |  |  |  |  |  | 
| 11 | 22 |  |  | 22 |  | 11772 | use IOC::Interfaces; | 
|  | 22 |  |  |  |  | 60 |  | 
|  | 22 |  |  |  |  | 621 |  | 
| 12 | 22 |  |  | 22 |  | 3996 | use IOC::Exceptions; | 
|  | 22 |  |  |  |  | 60 |  | 
|  | 22 |  |  |  |  | 770 |  | 
| 13 |  |  |  |  |  |  |  | 
| 14 | 22 |  |  | 22 |  | 22074 | use IOC::Visitor::ServiceLocator; | 
|  | 22 |  |  |  |  | 154 |  | 
|  | 22 |  |  |  |  | 706 |  | 
| 15 |  |  |  |  |  |  |  | 
| 16 | 22 |  |  | 22 |  | 156 | use base 'IOC::Visitable'; | 
|  | 22 |  |  |  |  | 41 |  | 
|  | 22 |  |  |  |  | 68452 |  | 
| 17 |  |  |  |  |  |  |  | 
| 18 |  |  |  |  |  |  | sub new { | 
| 19 | 90 |  |  | 90 | 1 | 37747 | my ($_class, $name) = @_; | 
| 20 | 90 |  | 33 |  |  | 529 | my $class = ref($_class) || $_class; | 
| 21 | 90 |  |  |  |  | 180 | my $container = {}; | 
| 22 | 90 |  |  |  |  | 229 | bless($container, $class); | 
| 23 | 90 |  |  |  |  | 362 | $container->_init($name); | 
| 24 | 90 |  |  |  |  | 364 | return $container; | 
| 25 |  |  |  |  |  |  | } | 
| 26 |  |  |  |  |  |  |  | 
| 27 |  |  |  |  |  |  | sub _init { | 
| 28 | 90 |  |  | 90 |  | 222 | my ($self, $name) = @_; | 
| 29 | 90 |  |  |  |  | 404 | $self->{services} = {}; | 
| 30 | 90 |  |  |  |  | 247 | $self->{service_locks} = {}; | 
| 31 | 90 |  |  |  |  | 228 | $self->{proxies} = {}; | 
| 32 | 90 |  |  |  |  | 300 | $self->{sub_containers} = {}; | 
| 33 | 90 |  |  |  |  | 630 | $self->{parent_container} = undef; | 
| 34 | 90 |  | 100 |  |  | 587 | $self->{name} = $name || 'default'; | 
| 35 |  |  |  |  |  |  | } | 
| 36 |  |  |  |  |  |  |  | 
| 37 |  |  |  |  |  |  | sub name { | 
| 38 | 68 |  |  | 68 | 1 | 4882 | my ($self) = @_; | 
| 39 | 68 |  |  |  |  | 348 | return $self->{name}; | 
| 40 |  |  |  |  |  |  | } | 
| 41 |  |  |  |  |  |  |  | 
| 42 |  |  |  |  |  |  | # parent containers | 
| 43 |  |  |  |  |  |  |  | 
| 44 |  |  |  |  |  |  | sub setParentContainer { | 
| 45 | 32 |  |  | 32 | 1 | 321 | my ($self, $parent_container) = @_; | 
| 46 | 32 | 100 | 100 |  |  | 425 | (blessed($parent_container) && $parent_container->isa('IOC::Container')) | 
| 47 |  |  |  |  |  |  | || throw IOC::InsufficientArguments "You must provide an IOC::Container object as a parent container"; | 
| 48 | 28 |  |  |  |  | 68 | $self->{parent_container} = $parent_container; | 
| 49 |  |  |  |  |  |  | } | 
| 50 |  |  |  |  |  |  |  | 
| 51 |  |  |  |  |  |  | sub getParentContainer { | 
| 52 | 9 |  |  | 9 | 1 | 22 | my ($self) = @_; | 
| 53 | 9 |  |  |  |  | 46 | return $self->{parent_container}; | 
| 54 |  |  |  |  |  |  | } | 
| 55 |  |  |  |  |  |  |  | 
| 56 |  |  |  |  |  |  | sub isRootContainer { | 
| 57 | 30 |  |  | 30 | 1 | 48 | my ($self) = @_; | 
| 58 | 30 | 100 |  |  |  | 221 | return defined($self->{parent_container}) ? 0 : 1; | 
| 59 |  |  |  |  |  |  | } | 
| 60 |  |  |  |  |  |  |  | 
| 61 |  |  |  |  |  |  | sub findRootContainer { | 
| 62 | 13 |  |  | 13 | 1 | 27 | my ($self) = @_; | 
| 63 | 13 | 100 |  |  |  | 52 | return $self if $self->isRootContainer(); | 
| 64 | 4 |  |  |  |  | 7 | my $current = $self; | 
| 65 | 4 |  |  |  |  | 10 | $current = $current->getParentContainer() until $current->isRootContainer(); | 
| 66 | 4 |  |  |  |  | 11 | return $current; | 
| 67 |  |  |  |  |  |  | } | 
| 68 |  |  |  |  |  |  |  | 
| 69 |  |  |  |  |  |  | # sub containers | 
| 70 |  |  |  |  |  |  |  | 
| 71 |  |  |  |  |  |  | sub addSubContainer { | 
| 72 | 33 |  |  | 33 | 1 | 239 | my ($self, $container) = @_; | 
| 73 | 33 | 100 | 100 |  |  | 409 | (blessed($container) && $container->isa('IOC::Container')) | 
| 74 |  |  |  |  |  |  | || throw IOC::InsufficientArguments "You must provide an IOC::Container object as a sub-container"; | 
| 75 | 29 |  |  |  |  | 93 | my $name = $container->name(); | 
| 76 | 29 | 100 |  |  |  | 43 | (!exists ${$self->{sub_containers}}{$name}) | 
|  | 29 |  |  |  |  | 122 |  | 
| 77 |  |  |  |  |  |  | || throw IOC::ContainerAlreadyExists "Duplicate Sub-Container Name '${name}' in container '" . $self->{name} . "'"; | 
| 78 | 28 |  |  |  |  | 110 | $self->{sub_containers}->{$name} = $container; | 
| 79 | 28 |  |  |  |  | 90 | $container->setParentContainer($self); | 
| 80 | 28 |  |  |  |  | 84 | $self; | 
| 81 |  |  |  |  |  |  | } | 
| 82 |  |  |  |  |  |  |  | 
| 83 |  |  |  |  |  |  | sub addSubContainers { | 
| 84 | 7 |  |  | 7 | 1 | 53 | my ($self, @containers) = @_; | 
| 85 | 7 | 100 |  |  |  | 31 | (@containers) || throw IOC::InsufficientArguments "You must provide at least one IOC::Container to add"; | 
| 86 | 6 |  |  |  |  | 27 | $self->addSubContainer($_) foreach @containers; | 
| 87 | 6 |  |  |  |  | 23 | $self; | 
| 88 |  |  |  |  |  |  | } | 
| 89 |  |  |  |  |  |  |  | 
| 90 |  |  |  |  |  |  | sub hasSubContainer { | 
| 91 | 12 |  |  | 12 | 1 | 356 | my ($self, $name) = @_; | 
| 92 | 12 | 100 |  |  |  | 41 | (defined($name)) || throw IOC::InsufficientArguments "You must supply a name of a sub-container"; | 
| 93 | 11 | 100 |  |  |  | 12 | return (exists ${$self->{sub_containers}}{$name}) ? 1 : 0; | 
|  | 11 |  |  |  |  | 63 |  | 
| 94 |  |  |  |  |  |  | } | 
| 95 |  |  |  |  |  |  |  | 
| 96 |  |  |  |  |  |  | sub hasSubContainers { | 
| 97 | 35 |  |  | 35 | 1 | 5860 | my ($self) = @_; | 
| 98 | 35 | 100 |  |  |  | 32 | return scalar(keys(%{$self->{sub_containers}})) ? 1 : 0; | 
|  | 35 |  |  |  |  | 191 |  | 
| 99 |  |  |  |  |  |  | } | 
| 100 |  |  |  |  |  |  |  | 
| 101 |  |  |  |  |  |  | sub getSubContainerList { | 
| 102 | 11 |  |  | 11 | 1 | 892 | my ($self) = @_; | 
| 103 | 11 |  |  |  |  | 17 | return keys %{$self->{sub_containers}}; | 
|  | 11 |  |  |  |  | 72 |  | 
| 104 |  |  |  |  |  |  | } | 
| 105 |  |  |  |  |  |  |  | 
| 106 |  |  |  |  |  |  | sub getSubContainer { | 
| 107 | 49 |  |  | 49 | 1 | 2190 | my ($self, $name) = @_; | 
| 108 | 49 | 100 |  |  |  | 131 | (defined($name)) || throw IOC::InsufficientArguments "You must supply a name of a sub-container"; | 
| 109 | 48 | 100 |  |  |  | 80 | (exists ${$self->{sub_containers}}{$name}) | 
|  | 48 |  |  |  |  | 323 |  | 
| 110 |  |  |  |  |  |  | || throw IOC::ContainerNotFound "There is no subcontainer by the name '${name}' in container '" . $self->{name} . "'"; | 
| 111 | 45 |  |  |  |  | 182 | return $self->{sub_containers}->{$name}; | 
| 112 |  |  |  |  |  |  | } | 
| 113 |  |  |  |  |  |  |  | 
| 114 |  |  |  |  |  |  | sub getAllSubContainers { | 
| 115 | 9 |  |  | 9 | 1 | 12 | my ($self) = @_; | 
| 116 | 9 |  |  |  |  | 10 | return values %{$self->{sub_containers}}; | 
|  | 9 |  |  |  |  | 43 |  | 
| 117 |  |  |  |  |  |  | } | 
| 118 |  |  |  |  |  |  |  | 
| 119 |  |  |  |  |  |  | sub accept { | 
| 120 | 54 |  |  | 54 | 1 | 13548 | my ($self, $visitor) = @_; | 
| 121 | 54 | 100 | 100 |  |  | 552 | (blessed($visitor) && $visitor->isa('IOC::Visitor')) | 
| 122 |  |  |  |  |  |  | || throw IOC::InsufficientArguments "You must pass an IOC::Visitor object to the visit method"; | 
| 123 | 50 |  |  |  |  | 193 | return $visitor->visit($self); | 
| 124 |  |  |  |  |  |  | } | 
| 125 |  |  |  |  |  |  |  | 
| 126 |  |  |  |  |  |  | # services | 
| 127 |  |  |  |  |  |  |  | 
| 128 |  |  |  |  |  |  | sub register { | 
| 129 | 101 |  |  | 101 | 1 | 5585 | my ($self, $service) = @_; | 
| 130 | 101 | 100 | 100 |  |  | 5140 | (blessed($service) && $service->isa('IOC::Service')) | 
| 131 |  |  |  |  |  |  | || throw IOC::InsufficientArguments "You must provide a valid IOC::Service object to register"; | 
| 132 | 97 |  |  |  |  | 429 | my $name = $service->name(); | 
| 133 | 97 | 100 |  |  |  | 162 | (!exists ${$self->{services}}{$name}) | 
|  | 97 |  |  |  |  | 461 |  | 
| 134 |  |  |  |  |  |  | || throw IOC::ServiceAlreadyExists "Duplicate Service Name '${name}'"; | 
| 135 | 96 |  |  |  |  | 383 | $service->setContainer($self); | 
| 136 | 96 |  |  |  |  | 273 | $self->{services}->{$name} = $service; | 
| 137 | 96 |  |  |  |  | 303 | $self; | 
| 138 |  |  |  |  |  |  | } | 
| 139 |  |  |  |  |  |  |  | 
| 140 |  |  |  |  |  |  | sub unregister { | 
| 141 | 3 |  |  | 3 | 1 | 100 | my ($self, $name) = @_; | 
| 142 | 3 | 100 |  |  |  | 22 | (defined($name)) || throw IOC::InsufficientArguments "You must provide a service name to unregister"; | 
| 143 | 2 | 100 |  |  |  | 3 | (exists ${$self->{services}}{$name}) | 
|  | 2 |  |  |  |  | 18 |  | 
| 144 |  |  |  |  |  |  | || throw IOC::ServiceNotFound "Unknown Service '${name}'"; | 
| 145 | 1 |  |  |  |  | 3 | my $service = $self->{services}->{$name}; | 
| 146 | 1 |  |  |  |  | 7 | $service->removeContainer(); | 
| 147 | 1 |  |  |  |  | 3 | delete $self->{services}->{$name}; | 
| 148 | 1 |  |  |  |  | 14 | return $service; | 
| 149 |  |  |  |  |  |  | } | 
| 150 |  |  |  |  |  |  |  | 
| 151 |  |  |  |  |  |  | sub registerWithProxy { | 
| 152 | 1 |  |  | 1 | 1 | 2 | my ($self, $service, $proxy) = @_; | 
| 153 | 1 |  |  |  |  | 5 | $self->register($service); | 
| 154 | 1 |  |  |  |  | 3 | $self->addProxy($service->name(), $proxy); | 
| 155 | 1 |  |  |  |  | 5 | $self; | 
| 156 |  |  |  |  |  |  | } | 
| 157 |  |  |  |  |  |  |  | 
| 158 |  |  |  |  |  |  | sub addProxy { | 
| 159 | 8 |  |  | 8 | 1 | 2940 | my ($self, $name, $proxy) = @_; | 
| 160 | 8 | 100 |  |  |  | 31 | (defined($name)) || throw IOC::InsufficientArguments "You must provide a valid service name"; | 
| 161 | 7 | 100 | 100 |  |  | 74 | (blessed($proxy) && $proxy->isa('IOC::Proxy')) | 
| 162 |  |  |  |  |  |  | || throw IOC::InsufficientArguments "You must provide a valid IOC::Proxy object to register"; | 
| 163 | 3 | 100 |  |  |  | 4 | (exists ${$self->{services}}{$name}) | 
|  | 3 |  |  |  |  | 23 |  | 
| 164 |  |  |  |  |  |  | || throw IOC::ServiceNotFound "Unknown Service '${name}'"; | 
| 165 | 2 |  |  |  |  | 5 | $self->{proxies}->{$name} = $proxy; | 
| 166 | 2 |  |  |  |  | 7 | $self; | 
| 167 |  |  |  |  |  |  | } | 
| 168 |  |  |  |  |  |  |  | 
| 169 |  |  |  |  |  |  | sub get { | 
| 170 | 131 |  |  | 131 | 1 | 12906 | my ($self, $name, %params) = @_; | 
| 171 | 131 | 100 |  |  |  | 393 | (defined($name)) || throw IOC::InsufficientArguments "You must provide a name of the service"; | 
| 172 | 130 | 100 |  |  |  | 163 | (exists ${$self->{services}}{$name}) | 
|  | 130 |  |  |  |  | 472 |  | 
| 173 |  |  |  |  |  |  | || throw IOC::ServiceNotFound "Unknown Service '${name}'"; | 
| 174 |  |  |  |  |  |  | # a literal object can have no dependencies, | 
| 175 |  |  |  |  |  |  | # and therefore can have no circular refs, so | 
| 176 |  |  |  |  |  |  | # we can optimize their usage there as well | 
| 177 | 128 | 100 |  |  |  | 1067 | return $self->{services}->{$name}->instance() | 
| 178 |  |  |  |  |  |  | if $self->{services}->{$name}->isa('IOC::Service::Literal'); | 
| 179 | 103 | 100 |  |  |  | 7485 | if ($self->_isServiceLocked($name)) { | 
| 180 |  |  |  |  |  |  | # NOTE: | 
| 181 |  |  |  |  |  |  | # if the service is parameterized | 
| 182 |  |  |  |  |  |  | # then we cannot defer it - SL | 
| 183 | 7 | 50 |  |  |  | 46 | ($self->{services}->{$name}->isa('IOC::Service::Parameterized')) | 
| 184 |  |  |  |  |  |  | && throw IOC::IllegalOperation "The service '$name' is locked, cannot defer a parameterized instance"; | 
| 185 |  |  |  |  |  |  | # otherwise ... | 
| 186 | 7 |  |  |  |  | 33 | return $self->{services}->{$name}->deferred(); | 
| 187 |  |  |  |  |  |  | } | 
| 188 | 96 |  |  |  |  | 309 | $self->_lockService($name); | 
| 189 | 96 |  |  |  |  | 504 | my $instance = $self->{services}->{$name}->instance(%params); | 
| 190 | 96 |  |  |  |  | 624 | $self->_unlockService($name); | 
| 191 | 96 | 100 | 100 |  |  | 667 | if (blessed($instance) && ref($instance) !~ /\:\:\_\:\:Proxy$/) { | 
| 192 | 69 | 100 |  |  |  | 131 | return $self->{proxies}->{$name}->wrap($instance) if exists ${$self->{proxies}}{$name}; | 
|  | 69 |  |  |  |  | 369 |  | 
| 193 |  |  |  |  |  |  | } | 
| 194 | 94 |  |  |  |  | 450 | return $instance; | 
| 195 |  |  |  |  |  |  | } | 
| 196 |  |  |  |  |  |  |  | 
| 197 |  |  |  |  |  |  | sub find { | 
| 198 | 33 |  |  | 33 | 1 | 6560 | my ($self, $path, $extra_args) = @_; | 
| 199 | 33 | 100 |  |  |  | 107 | (defined($path)) | 
| 200 |  |  |  |  |  |  | || throw IOC::InsufficientArguments "You must provide a path of find a service"; | 
| 201 | 32 |  |  |  |  | 183 | return $self->accept(IOC::Visitor::ServiceLocator->new($path, $extra_args)); | 
| 202 |  |  |  |  |  |  | } | 
| 203 |  |  |  |  |  |  |  | 
| 204 |  |  |  |  |  |  | sub hasService { | 
| 205 | 28 |  |  | 28 | 1 | 76 | my ($self, $name) = @_; | 
| 206 | 28 | 100 |  |  |  | 67 | (defined($name)) || throw IOC::InsufficientArguments "You must provide a name of the service"; | 
| 207 | 27 | 100 |  |  |  | 28 | return (exists ${$self->{services}}{$name}) ? 1 : 0; | 
|  | 27 |  |  |  |  | 147 |  | 
| 208 |  |  |  |  |  |  | } | 
| 209 |  |  |  |  |  |  |  | 
| 210 |  |  |  |  |  |  | sub getServiceList { | 
| 211 | 6 |  |  | 6 | 1 | 1974 | my ($self) = @_; | 
| 212 | 6 |  |  |  |  | 13 | return keys %{$self->{services}}; | 
|  | 6 |  |  |  |  | 75 |  | 
| 213 |  |  |  |  |  |  | } | 
| 214 |  |  |  |  |  |  |  | 
| 215 |  |  |  |  |  |  | sub DESTROY { | 
| 216 | 78 |  |  | 78 |  | 1853 | my ($self) = @_; | 
| 217 |  |  |  |  |  |  | # this will not DESTROY all the | 
| 218 |  |  |  |  |  |  | # sub-containers it holds, since | 
| 219 |  |  |  |  |  |  | # a sub-container might be still | 
| 220 |  |  |  |  |  |  | # refered to elsewhere. | 
| 221 | 78 |  |  |  |  | 168 | $self->{sub_containers} = undef; | 
| 222 |  |  |  |  |  |  | # and the same with the parent | 
| 223 | 78 |  |  |  |  | 142 | $self->{parent_container} = undef; | 
| 224 |  |  |  |  |  |  | # this will DESTROY all the | 
| 225 |  |  |  |  |  |  | # services it holds, since | 
| 226 |  |  |  |  |  |  | # a service can only have one | 
| 227 |  |  |  |  |  |  | # container, then this is okay | 
| 228 |  |  |  |  |  |  | # to do that, otherwise we would | 
| 229 |  |  |  |  |  |  | # need to deal with that. | 
| 230 | 78 |  |  |  |  | 117 | foreach my $service (values %{$self->{services}}) { | 
|  | 78 |  |  |  |  | 1087 |  | 
| 231 | 40 | 50 |  |  |  | 208 | defined $service && $service->DESTROY; | 
| 232 |  |  |  |  |  |  | } | 
| 233 |  |  |  |  |  |  | } | 
| 234 |  |  |  |  |  |  |  | 
| 235 |  |  |  |  |  |  | # private methods | 
| 236 |  |  |  |  |  |  |  | 
| 237 |  |  |  |  |  |  | sub _lockService { | 
| 238 | 96 |  |  | 96 |  | 153 | my ($self, $name) = @_; | 
| 239 | 96 |  |  |  |  | 174 | $self->{lock_level}++; | 
| 240 | 96 |  |  |  |  | 297 | $self->{service_locks}->{$name} = $self->{lock_level}; | 
| 241 |  |  |  |  |  |  | #     use Data::Dumper; | 
| 242 |  |  |  |  |  |  | #     print "locking '$name' -> our locks are: " . Dumper($self->{service_locks}); | 
| 243 |  |  |  |  |  |  | } | 
| 244 |  |  |  |  |  |  |  | 
| 245 |  |  |  |  |  |  | sub _unlockService { | 
| 246 | 96 |  |  | 96 |  | 157 | my ($self, $name) = @_; | 
| 247 | 96 |  |  |  |  | 168 | $self->{lock_level}--; | 
| 248 | 96 |  |  |  |  | 345 | delete $self->{service_locks}->{$name}; | 
| 249 |  |  |  |  |  |  | } | 
| 250 |  |  |  |  |  |  |  | 
| 251 |  |  |  |  |  |  | sub _isServiceLocked { | 
| 252 | 103 |  |  | 103 |  | 184 | my ($self, $name) = @_; | 
| 253 | 103 |  |  |  |  | 129 | return (exists ${$self->{service_locks}}{$name}); | 
|  | 103 |  |  |  |  | 495 |  | 
| 254 |  |  |  |  |  |  | } | 
| 255 |  |  |  |  |  |  |  | 
| 256 |  |  |  |  |  |  | 1; | 
| 257 |  |  |  |  |  |  |  | 
| 258 |  |  |  |  |  |  | __END__ |