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