1package Object::Container; 2 3use strict; 4use warnings; 5use parent qw(Class::Accessor::Fast); 6use Carp; 7 8our $VERSION = '0.14'; 9 10__PACKAGE__->mk_accessors(qw/registered_classes autoloader_rules objects/); 11 12BEGIN { 13 our $_HAVE_EAC = 1; 14 eval { local $SIG{__DIE__}; require Exporter::AutoClean; }; 15 if ($@) { 16 $_HAVE_EAC = 0; 17 } 18} 19 20do { 21 my @EXPORTS; 22 23 sub import { 24 my ($class, $name) = @_; 25 return unless $name; 26 27 my $caller = caller; 28 { 29 no strict 'refs'; 30 if ($name =~ /^-base$/i) { 31 push @{"${caller}::ISA"}, $class; 32 my $r = $class->can('register'); 33 my $l = $class->can('autoloader'); 34 35 my %exports = ( 36 register => sub { $r->($caller, @_) }, 37 autoloader => sub { $l->($caller, @_) }, 38 preload => sub { 39 $caller->instance->get($_) for @_; 40 }, 41 preload_all_except => sub { 42 $caller->instance->load_all_except(@_); 43 }, 44 preload_all => sub { 45 $caller->instance->load_all; 46 }, 47 ); 48 49 if ($Object::Container::_HAVE_EAC) { 50 Exporter::AutoClean->export( $caller, %exports ); 51 } 52 else { 53 while (my ($name, $fn) = each %exports) { 54 *{"${caller}::${name}"} = $fn; 55 } 56 @EXPORTS = keys %exports; 57 } 58 } 59 else { 60 no strict 'refs'; 61 *{"${caller}::${name}"} = sub { 62 my ($target) = @_; 63 return $target ? $class->get($target) : $class; 64 }; 65 } 66 } 67 } 68 69 sub unimport { 70 my $caller = caller; 71 72 no strict 'refs'; 73 for my $name (@EXPORTS) { 74 delete ${ $caller . '::' }{ $name }; 75 } 76 77 1; # for EOF 78 } 79}; 80 81my %INSTANCES; 82sub instance { 83 my $class = shift; 84 return $INSTANCES{$class} ||= $class->new; 85} 86 87sub has_instance { 88 my $class = shift; 89 $class = ref $class || $class; 90 return $INSTANCES{$class}; 91}; 92 93sub new { 94 $_[0]->SUPER::new( +{ 95 registered_classes => +{}, 96 autoloader_rules => +[], 97 objects => +{}, 98 } ); 99} 100 101sub register { 102 my ($self, $args, @rest) = @_; 103 $self = $self->instance unless ref $self; 104 105 my ($class, $initializer, $is_preload); 106 if (defined $args && !ref $args) { 107 $class = $args; 108 if (@rest == 1 and ref $rest[0] eq 'CODE') { 109 $initializer = $rest[0]; 110 } 111 else { 112 $initializer = sub { 113 $self->ensure_class_loaded($class); 114 $class->new(@rest); 115 }; 116 } 117 } 118 elsif (ref $args eq 'HASH') { 119 $class = $args->{class}; 120 $args->{args} ||= []; 121 if (ref $args->{initializer} eq 'CODE') { 122 $initializer = $args->{initializer}; 123 } 124 else { 125 $initializer = sub { 126 $self->ensure_class_loaded($class); 127 $class->new(@{$args->{args}}); 128 }; 129 } 130 131 $is_preload = 1 if $args->{preload}; 132 } 133 else { 134 croak "Usage: $self->register($class || { class => $class ... })"; 135 } 136 137 $self->registered_classes->{$class} = $initializer; 138 $self->get($class) if $is_preload; 139 140 return $initializer; 141} 142 143sub unregister { 144 my ($self, $class) = @_; 145 $self = $self->instance unless ref $self; 146 147 delete $self->registered_classes->{$class} and $self->remove($class); 148} 149 150sub autoloader { 151 my ($self, $rule, $trigger) = @_; 152 $self = $self->instance unless ref $self; 153 154 push @{ $self->autoloader_rules }, [$rule, $trigger]; 155} 156 157sub get { 158 my ($self, $class) = @_; 159 $self = $self->instance unless ref $self; 160 161 my $obj = $self->objects->{ $class } ||= do { 162 my $initializer = $self->registered_classes->{ $class }; 163 $initializer ? $initializer->($self) : (); 164 }; 165 166 unless ($obj) { 167 # autoloaderer 168 if (my ($trigger) = grep { $class =~ /$_->[0]/ } @{ $self->autoloader_rules }) { 169 $trigger->[1]->($self, $class); 170 } 171 172 $obj = $self->objects->{ $class } ||= do { 173 my $initializer = $self->registered_classes->{ $class }; 174 $initializer ? $initializer->($self) : (); 175 }; 176 } 177 178 $obj or croak qq["$class" is not registered in @{[ ref $self ]}]; 179} 180 181sub remove { 182 my ($self, $class) = @_; 183 $self = $self->instance unless ref $self; 184 delete $self->objects->{ $class }; 185} 186 187sub load_all { 188 my ($self) = @_; 189 $self->load_all_except; 190} 191 192sub load_all_except { 193 my ($self, @except) = @_; 194 $self = $self->instance unless ref $self; 195 196 for my $class (keys %{ $self->registered_classes }) { 197 next if grep { $class eq $_ } @except; 198 $self->get($class); 199 } 200} 201 202# taken from Mouse 203sub _is_class_loaded { 204 my $class = shift; 205 206 return 0 if ref($class) || !defined($class) || !length($class); 207 208 # walk the symbol table tree to avoid autovififying 209 # \*{${main::}{"Foo::"}{"Bar::"}} == \*main::Foo::Bar:: 210 211 my $pack = \%::; 212 foreach my $part (split('::', $class)) { 213 $part .= '::'; 214 return 0 if !exists $pack->{$part}; 215 216 my $entry = \$pack->{$part}; 217 return 0 if ref($entry) ne 'GLOB'; 218 $pack = *{$entry}{HASH}; 219 } 220 221 return 0 if !%{$pack}; 222 223 # check for $VERSION or @ISA 224 return 1 if exists $pack->{VERSION} 225 && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} }; 226 return 1 if exists $pack->{ISA} 227 && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0; 228 229 # check for any method 230 foreach my $name( keys %{$pack} ) { 231 my $entry = \$pack->{$name}; 232 return 1 if ref($entry) ne 'GLOB' || defined *{$entry}{CODE}; 233 } 234 235 # fail 236 return 0; 237} 238 239 240sub _try_load_one_class { 241 my $class = shift; 242 243 return '' if _is_class_loaded($class); 244 my $klass = $class; 245 $klass =~ s{::}{/}g; 246 $klass .= '.pm'; 247 248 return do { 249 local $@; 250 eval { require $klass }; 251 $@; 252 }; 253} 254 255sub ensure_class_loaded { 256 my ($self, $class) = @_; 257 my $e = _try_load_one_class($class); 258 Carp::confess "Could not load class ($class) because : $e" if $e; 259 260 return $class; 261} 262 2631; 264__END__ 265 266=for stopwords DSL OO runtime singletonize unregister preload 267 268=head1 NAME 269 270Object::Container - simple object container 271 272=head1 SYNOPSIS 273 274 use Object::Container; 275 276 # initialize container 277 my $container = Object::Container->new; 278 279 # register class 280 $container->register('HTML::TreeBuilder'); 281 282 # register class with initializer 283 $container->register('WWW::Mechanize', sub { 284 my $mech = WWW::Mechanize->new( stack_depth => 1 ); 285 $mech->agent_alias('Windows IE 6'); 286 return $mech; 287 }); 288 289 # get object 290 my $mech = $container->get('WWW::Mechanize'); 291 292 # also available Singleton interface 293 my $container = Object::Container->instance; 294 295 # With singleton interface, you can use register/get method as class method 296 Object::Container->register('WWW::Mechanize'); 297 my $mech = Object::Container->get('WWW::Mechanize'); 298 299 # Export singleton interface 300 use Object::Container 'container'; 301 container->register('WWW::Mechanize'); 302 my $mech = container->get('WWW::Mechanize'); 303 my $mech = container('WWW::Mechanize'); # save as above 304 305 # Subclassing singleton interface 306 package MyContainer; 307 use Object::Container '-base'; 308 309 register mech => sub { WWW::Mechanize->new }; 310 311 # use it 312 use MyContainer 'con'; 313 314 con('mech')->get('http://example.com'); 315 316=head1 DESCRIPTION 317 318This module is a object container interface which supports both OO interface and Singleton interface. 319 320If you want to use one module from several places, you might use L<Class::Singleton> to access the module from any places. But you should subclass each modules to singletonize. 321 322This module provide singleton container instead of module itself, so it is easy to singleton multiple classes. 323 324L<Object::Registrar> is a similar module to this. But Object::Container has also OO interface and supports lazy initializer. (describing below) 325 326=head2 OO and Singleton interfaces 327 328This module provide two interfaces: OO and Singleton. 329 330OO interface is like this: 331 332 my $container = Object::Container->new; 333 334It is normal object oriented interface. And you can use multiple container at the same Time: 335 336 my $container1 = Object::Container->new; 337 my $container2 = Object::Container->new; 338 339Singleton is also like this: 340 341 my $container = Object::Container->instance; 342 343instance method always returns singleton object. With this interface, you can 'register' and 'get' method as class method: 344 345 Object::Container->register('WWW::Mechanize'); 346 my $mech = Object::Container->get('WWW::Mechanize'); 347 348When you want use multiple container with Singleton interface, you have to create subclass like this: 349 350 MyContainer1->get('WWW::Mechanize'); 351 MyContainer2->get('WWW::Mechanize'); 352 353=head2 Singleton interface with EXPORT function for lazy people 354 355If you are lazy person, and don't want to write something long code like: 356 357 MyContainer->get('WWW::Mechanize'); 358 359This module provide export functions to shorten this. 360If you use your container with function name, the function will be exported and act as container: 361 362 use MyContainer 'container'; 363 364 container->register(...); 365 366 container->get(...); 367 container(...); # shortcut to ->get(...); 368 369=head2 Subclassing singleton interface for lazy people 370 371If you are lazy person, and don't want to write something long code in your subclass like: 372 373 __PACKAGE__->register( ... ); 374 375Instead of above, this module provide subclassing interface. 376To do this, you need to write below code to subclass instead of C<use base>. 377 378 use Object::Container '-base'; 379 380And then you can register your object via DSL functions: 381 382 register ua => sub { LWP::UserAgent->new }; 383 384=head2 lazy loading and resolve dependencies 385 386The object that is registered by 'register' method is not initialized until calling 'get' method. 387 388 Object::Container->register('WWW::Mechanize', sub { WWW::Mechanize->new }); # doesn't initialize here 389 my $mech = Object::Container->get('WWW::Mechanize'); # initialize here 390 391This feature helps you to create less resource and fast runtime script in case of lots of object registered. 392 393And you can resolve dependencies between multiple modules with Singleton interface. 394 395For example: 396 397 Object::Container->register('HTTP::Cookies', sub { HTTP::Cookies->new( file => '/path/to/cookie.dat' ) }); 398 Object::Container->register('LWP::UserAgent', sub { 399 my $cookies = Object::Container->get('HTTP::Cookies'); 400 LWP::UserAgent->new( cookie_jar => $cookies ); 401 }); 402 403You can resolve dependencies by calling 'get' method in initializer like above. 404 405In that case, only LWP::UserAgent and HTTP::Cookies are initialized. 406 407=head1 METHODS 408 409=head2 new 410 411Create new object. 412 413=head2 instance 414 415Create singleton object and return it. 416 417=head2 register( $class, @args ) 418 419=head2 register( $class_or_name, $initialize_code ) 420 421=head2 register( { class => $class_or_name ... } ) 422 423Register classes to container. 424 425Most simple usage is: 426 427 Object::Container->register('WWW::Mechanize'); 428 429First argument is class name to object. In this case, execute 'WWW::Mechanize->new' when first get method call. 430 431 Object::Container->register('WWW::Mechanize', @args ); 432 433is also execute 'WWW::Mechanize->new(@args)'. 434 435If you use different constructor from 'new', want to custom initializer, or want to include dependencies, you can custom initializer to pass a coderef as second argument. 436 437 Object::Container->register('WWW::Mechanize', sub { 438 my $mech = WWW::Mechanize->new( stack_depth ); 439 $mech->agent_alias('Windows IE 6'); 440 return $mech; 441 }); 442 443This coderef (initialize) should return object to contain. 444 445With last way you can pass any name to first argument instead of class name. 446 447 Object::Container->register('ua1', sub { LWP::UserAgent->new }); 448 Object::Container->register('ua2', sub { LWP::UserAgent->new }); 449 450If you want to initialize and register at the same time, the following can. 451 452 Object::Container->register({ class => 'LWP::UserAgent', preload => 1 }); 453 454I<initializer> option can be specified. 455 456 Object::Container->register({ class => 'WWW::Mechanize', initializer => sub { 457 my $mech = WWW::Mechanize->new( stack_depth ); 458 $mech->agent_alias('Windows IE 6'); 459 return $mech; 460 }, preload => 1 }); 461 462This is the same as written below. 463 464 Object::Container->register('WWW::Mechanize', sub { 465 my $mech = WWW::Mechanize->new( stack_depth ); 466 $mech->agent_alias('Windows IE 6'); 467 return $mech; 468 }); 469 Object::Container->get('WWW::Mechanize'); 470 471If you specify I<args> option is: 472 473 Object::Container->register({ class => 'LWP::UserAgent', args => \@args, preload => 1 }); 474 475It is, as you know, the same below. 476 477 Object::Container->register('LWP::UserAgent', @args); 478 Object::Container->get('LWP::UserAgent'); 479 480=head2 unregister($class_or_name) 481 482Unregister classes from container. 483 484=head2 get($class_or_name) 485 486Get the object that registered by 'register' method. 487 488First argument is same as 'register' method. 489 490=head2 remove($class_or_name) 491 492Remove the cached object that is created at C<get> method above. 493 494Return value is the deleted object if it's exists. 495 496=head2 ensure_class_loaded($class) 497 498This is utility method that load $class if $class is not loaded. 499 500It's useful when you want include dependency in initializer and want lazy load the modules. 501 502=head2 load_all 503 504=head2 load_all_except(@classes_or_names) 505 506This module basically does lazy object initializations, but in some situation, for Copy-On-Write or for runtime speed for example, you might want to preload objects. 507For the purpose C<load_all> and C<load_all_except> method are exists. 508 509 Object::Container->load_all; 510 511This method is load all registered object at once. 512 513Also if you have some objects that keeps lazy loading, do like following: 514 515 Object::Container->load_all_except(qw/Foo Bar/); 516 517This means all objects except 'Foo' and 'Bar' are loaded. 518 519=head1 EXPORT FUNCTIONS ON SUBCLASS INTERFACE 520 521Same functions for C<load_all> and C<load_all_except> exists at subclass interface. 522Below is list of these functions. 523 524=head2 preload(@classes_or_names) 525 526=head2 preload_all 527 528=head2 preload_all_except 529 530As predictable by name, C<preload_all> is equals to C<load_all> and C<preload_all_except> is equals to <load_all_except>. 531 532=head1 SEE ALSO 533 534L<Class::Singleton>, L<Object::Registrar>. 535 536=head1 AUTHOR 537 538Daisuke Murase <typester@cpan.org> 539 540=head1 COPYRIGHT & LICENSE 541 542Copyright (c) 2009 KAYAC Inc. All rights reserved. 543 544This program is free software; you can redistribute 545it and/or modify it under the same terms as Perl itself. 546 547The full text of the license can be found in the 548LICENSE file included with this module. 549 550=cut 551 5521; 553