lib/Catalyst/IOC/Container.pm

   1 package Catalyst::IOC::Container;
   2 use Bread::Board;
   3 use Moose;
   4 use Config::Any;
   5 use Data::Visitor::Callback;
   6 use Catalyst::Utils ();
   7 use Devel::InnerPackage ();
   8 use Hash::Util qw/lock_hash/;
   9 use MooseX::Types::LoadableClass qw/ LoadableClass /;
  10 use Moose::Util;
  11 use Catalyst::IOC::BlockInjection;
  12 use Module::Pluggable::Object ();
  13 use namespace::autoclean;
  14
  15 extends 'Bread::Board::Container';
  16
  17 has config_local_suffix => (
  18     is      => 'ro',
  19     isa     => 'Str',
  20     default => 'local',
  21 );
  22
  23 has driver => (
  24     is      => 'ro',
  25     isa     => 'HashRef',
  26     default => sub { +{} },
  27 );
  28
  29 has file => (
  30     is      => 'ro',
  31     isa     => 'Str',
  32     default => '',
  33 );
  34
  35 has substitutions => (
  36     is      => 'ro',
  37     isa     => 'HashRef',
  38     default => sub { +{} },
  39 );
  40
  41 has name => (
  42     is      => 'ro',
  43     isa     => 'Str',
  44     default => 'MyApp',
  45 );
  46
  47 has sub_container_class => (
  48     isa     => LoadableClass,
  49     is      => 'ro',
  50     coerce  => 1,
  51     default => 'Catalyst::IOC::SubContainer',
  52     handles => {
  53         new_sub_container => 'new',
  54     }
  55 );
  56
  57 sub BUILD {
  58     my ( $self, $params ) = @_;
  59
  60     $self->add_service(
  61         $self->${\"build_${_}_service"}
  62     ) for qw/
  63         substitutions
  64         file
  65         driver
  66         name
  67         prefix
  68         extensions
  69         path
  70         config
  71         raw_config
  72         global_files
  73         local_files
  74         global_config
  75         local_config
  76         config_local_suffix
  77         config_path
  78     /;
  79
  80     $self->add_sub_container(
  81         $self->build_controller_subcontainer
  82     );
  83
  84     # FIXME - the config should be merged at this point
  85     my $config        = $self->resolve( service => 'config' );
  86     my $default_view  = $params->{default_view}  || $config->{default_view};
  87     my $default_model = $params->{default_model} || $config->{default_model};
  88
  89     $self->add_sub_container(
  90         $self->build_view_subcontainer(
  91             default_component => $default_view,
  92         )
  93     );
  94
  95     $self->add_sub_container(
  96         $self->build_model_subcontainer(
  97             default_component => $default_model,
  98         )
  99     );
 100 }
 101
 102 sub build_model_subcontainer {
 103     my $self = shift;
 104
 105     return $self->new_sub_container( @_,
 106         name => 'model',
 107     );
 108 }
 109
 110 sub build_view_subcontainer {
 111     my $self = shift;
 112
 113     return $self->new_sub_container( @_,
 114         name => 'view',
 115     );
 116 }
 117
 118 sub build_controller_subcontainer {
 119     my $self = shift;
 120
 121     return $self->new_sub_container(
 122         name => 'controller',
 123     );
 124 }
 125
 126 sub build_name_service {
 127     my $self = shift;
 128
 129     return Bread::Board::Literal->new( name => 'name', value => $self->name );
 130 }
 131
 132 sub build_driver_service {
 133     my $self = shift;
 134
 135     return Bread::Board::Literal->new( name => 'driver', value => $self->driver );
 136 }
 137
 138 sub build_file_service {
 139     my $self = shift;
 140
 141     return Bread::Board::Literal->new( name => 'file', value => $self->file );
 142 }
 143
 144 sub build_substitutions_service {
 145     my $self = shift;
 146
 147     return Bread::Board::Literal->new( name => 'substitutions', value => $self->substitutions );
 148 }
 149
 150 sub build_extensions_service {
 151     my $self = shift;
 152
 153     return Bread::Board::BlockInjection->new(
 154         name => 'extensions',
 155         block => sub {
 156             return \@{Config::Any->extensions};
 157         },
 158     );
 159 }
 160
 161 sub build_prefix_service {
 162     my $self = shift;
 163
 164     return Bread::Board::BlockInjection->new(
 165         name => 'prefix',
 166         block => sub {
 167             return Catalyst::Utils::appprefix( shift->param('name') );
 168         },
 169         dependencies => [ depends_on('name') ],
 170     );
 171 }
 172
 173 sub build_path_service {
 174     my $self = shift;
 175
 176     return Bread::Board::BlockInjection->new(
 177         name => 'path',
 178         block => sub {
 179             my $s = shift;
 180
 181             return Catalyst::Utils::env_value( $s->param('name'), 'CONFIG' )
 182             || $s->param('file')
 183             || $s->param('name')->path_to( $s->param('prefix') );
 184         },
 185         dependencies => [ depends_on('file'), depends_on('name'), depends_on('prefix') ],
 186     );
 187 }
 188
 189 sub build_config_service {
 190     my $self = shift;
 191
 192     return Bread::Board::BlockInjection->new(
 193         name => 'config',
 194         block => sub {
 195             my $s = shift;
 196
 197             my $v = Data::Visitor::Callback->new(
 198                 plain_value => sub {
 199                     return unless defined $_;
 200                     return $self->_config_substitutions( $s->param('name'), $s->param('substitutions'), $_ );
 201                 }
 202
 203             );
 204             $v->visit( $s->param('raw_config') );
 205         },
 206         dependencies => [ depends_on('name'), depends_on('raw_config'), depends_on('substitutions') ],
 207     );
 208 }
 209
 210 sub build_raw_config_service {
 211     my $self = shift;
 212
 213     return Bread::Board::BlockInjection->new(
 214         name => 'raw_config',
 215         block => sub {
 216             my $s = shift;
 217
 218             my @global = @{$s->param('global_config')};
 219             my @locals = @{$s->param('local_config')};
 220
 221             my $config = {};
 222             for my $cfg (@global, @locals) {
 223                 for (keys %$cfg) {
 224                     $config = Catalyst::Utils::merge_hashes( $config, $cfg->{$_} );
 225                 }
 226             }
 227             return $config;
 228         },
 229         dependencies => [ depends_on('global_config'), depends_on('local_config') ],
 230     );
 231 }
 232
 233 sub build_global_files_service {
 234     my $self = shift;
 235
 236     return Bread::Board::BlockInjection->new(
 237         name => 'global_files',
 238         block => sub {
 239             my $s = shift;
 240
 241             my ( $path, $extension ) = @{$s->param('config_path')};
 242
 243             my @extensions = @{$s->param('extensions')};
 244
 245             my @files;
 246             if ( $extension ) {
 247                 die "Unable to handle files with the extension '${extension}'" unless grep { $_ eq $extension } @extensions;
 248                 push @files, $path;
 249             } else {
 250                 @files = map { "$path.$_" } @extensions;
 251             }
 252             return \@files;
 253         },
 254         dependencies => [ depends_on('extensions'), depends_on('config_path') ],
 255     );
 256 }
 257
 258 sub build_local_files_service {
 259     my $self = shift;
 260
 261     return Bread::Board::BlockInjection->new(
 262         name => 'local_files',
 263         block => sub {
 264             my $s = shift;
 265
 266             my ( $path, $extension ) = @{$s->param('config_path')};
 267             my $suffix = $s->param('config_local_suffix');
 268
 269             my @extensions = @{$s->param('extensions')};
 270
 271             my @files;
 272             if ( $extension ) {
 273                 die "Unable to handle files with the extension '${extension}'" unless grep { $_ eq $extension } @extensions;
 274                 $path =~ s{\.$extension}{_$suffix.$extension};
 275                 push @files, $path;
 276             } else {
 277                 @files = map { "${path}_${suffix}.$_" } @extensions;
 278             }
 279             return \@files;
 280         },
 281         dependencies => [ depends_on('extensions'), depends_on('config_path'), depends_on('config_local_suffix') ],
 282     );
 283 }
 284
 285 sub build_global_config_service {
 286     my $self = shift;
 287
 288     return Bread::Board::BlockInjection->new(
 289         name => 'global_config',
 290         block => sub {
 291             my $s = shift;
 292
 293             return Config::Any->load_files({
 294                 files       => $s->param('global_files'),
 295                 filter      => \&_fix_syntax,
 296                 use_ext     => 1,
 297                 driver_args => $s->param('driver'),
 298             });
 299         },
 300         dependencies => [ depends_on('global_files') ],
 301     );
 302 }
 303
 304 sub build_local_config_service {
 305     my $self = shift;
 306
 307     return Bread::Board::BlockInjection->new(
 308         name => 'local_config',
 309         block => sub {
 310             my $s = shift;
 311
 312             return Config::Any->load_files({
 313                 files       => $s->param('local_files'),
 314                 filter      => \&_fix_syntax,
 315                 use_ext     => 1,
 316                 driver_args => $s->param('driver'),
 317             });
 318         },
 319         dependencies => [ depends_on('local_files') ],
 320     );
 321 }
 322
 323 sub build_config_path_service {
 324     my $self = shift;
 325
 326     return Bread::Board::BlockInjection->new(
 327         name => 'config_path',
 328         block => sub {
 329             my $s = shift;
 330
 331             my $path = $s->param('path');
 332             my $prefix = $s->param('prefix');
 333
 334             my ( $extension ) = ( $path =~ m{\.(.{1,4})$} );
 335
 336             if ( -d $path ) {
 337                 $path =~ s{[\/\\]$}{};
 338                 $path .= "/$prefix";
 339             }
 340
 341             return [ $path, $extension ];
 342         },
 343         dependencies => [ depends_on('prefix'), depends_on('path') ],
 344     );
 345 }
 346
 347 sub build_config_local_suffix_service {
 348     my $self = shift;
 349
 350     return Bread::Board::BlockInjection->new(
 351         name => 'config_local_suffix',
 352         block => sub {
 353             my $s = shift;
 354             my $suffix = Catalyst::Utils::env_value( $s->param('name'), 'CONFIG_LOCAL_SUFFIX' ) || $self->config_local_suffix;
 355
 356             return $suffix;
 357         },
 358         dependencies => [ depends_on('name') ],
 359     );
 360 }
 361
 362 sub _fix_syntax {
 363     my $config     = shift;
 364     my @components = (
 365         map +{
 366             prefix => $_ eq 'Component' ? '' : $_ . '::',
 367             values => delete $config->{ lc $_ } || delete $config->{ $_ }
 368         },
 369         grep { ref $config->{ lc $_ } || ref $config->{ $_ } }
 370             qw( Component Model M View V Controller C Plugin )
 371     );
 372
 373     foreach my $comp ( @components ) {
 374         my $prefix = $comp->{ prefix };
 375         foreach my $element ( keys %{ $comp->{ values } } ) {
 376             $config->{ "$prefix$element" } = $comp->{ values }->{ $element };
 377         }
 378     }
 379 }
 380
 381 sub _config_substitutions {
 382     my ( $self, $name, $subs, $arg ) = @_;
 383
 384     $subs->{ HOME } ||= sub { shift->path_to( '' ); };
 385     $subs->{ ENV } ||=
 386         sub {
 387             my ( $c, $v ) = @_;
 388             if (! defined($ENV{$v})) {
 389                 Catalyst::Exception->throw( message =>
 390                     "Missing environment variable: $v" );
 391                 return "";
 392             } else {
 393                 return $ENV{ $v };
 394             }
 395         };
 396     $subs->{ path_to } ||= sub { shift->path_to( @_ ); };
 397     $subs->{ literal } ||= sub { return $_[ 1 ]; };
 398     my $subsre = join( '|', keys %$subs );
 399
 400     $arg =~ s{__($subsre)(?:\((.+?)\))?__}{ $subs->{ $1 }->( $name, $2 ? split( /,/, $2 ) : () ) }eg;
 401     return $arg;
 402 }
 403
 404 sub get_component_from_sub_container {
 405     my ( $self, $sub_container_name, $name, $c, @args ) = @_;
 406
 407     my $sub_container = $self->get_sub_container( $sub_container_name );
 408
 409     if (!$name) {
 410         my $default = $sub_container->default_component;
 411
 412         return $sub_container->get_component( $default, $c, @args )
 413             if $default && $sub_container->has_service( $default );
 414
 415         # FIXME - should I be calling $c->log->warn here?
 416         # this is never a controller, so this is safe
 417         $c->log->warn( "Calling \$c->$sub_container_name() is not supported unless you specify one of:" );
 418         $c->log->warn( "* \$c->config(default_$sub_container_name => 'the name of the default $sub_container_name to use')" );
 419         $c->log->warn( "* \$c->stash->{current_$sub_container_name} # the name of the view to use for this request" );
 420         $c->log->warn( "* \$c->stash->{current_${sub_container_name}_instance} # the instance of the $sub_container_name to use for this request" );
 421
 422         return;
 423     }
 424
 425     return $sub_container->get_component_regexp( $name, $c, @args )
 426         if ref $name;
 427
 428     return $sub_container->get_component( $name, $c, @args )
 429         if $sub_container->has_service( $name );
 430
 431     $c->log->warn(
 432         "Attempted to use $sub_container_name '$name', " .
 433         "but it does not exist"
 434     );
 435
 436     return;
 437 }
 438
 439 sub find_component {
 440     my ( $self, $component, $c, @args ) = @_;
 441     my ( $type, $name ) = _get_component_type_name($component);
 442     my @result;
 443
 444     return $self->get_component_from_sub_container(
 445         $type, $name, $c, @args
 446     ) if $type;
 447
 448     my $query = ref $component
 449               ? $component
 450               : qr{^$component$}
 451               ;
 452
 453     for my $subcontainer_name (qw/model view controller/) {
 454         my $subcontainer = $self->get_sub_container( $subcontainer_name );
 455         my @components   = $subcontainer->get_service_list;
 456         @result          = grep { m{$component} } @components;
 457
 458         return map { $subcontainer->get_component( $_, $c, @args ) } @result
 459             if @result;
 460     }
 461
 462     # FIXME - I guess I shouldn't be calling $c->components here
 463     # one last search for things like $c->comp(qr/::M::/)
 464     @result = $self->find_component_regexp(
 465         $c->components, $component, $c, @args
 466     ) if !@result and ref $component;
 467
 468     # it expects an empty list on failed searches
 469     return @result;
 470 }
 471
 472 sub find_component_regexp {
 473     my ( $self, $components, $component, @args ) = @_;
 474     my @result;
 475
 476     my @components = grep { m{$component} } keys %{ $components };
 477
 478     for (@components) {
 479         my ($type, $name) = _get_component_type_name($_);
 480
 481         push @result, $self->get_component_from_sub_container(
 482             $type, $name, @args
 483         ) if $type;
 484     }
 485
 486     return @result;
 487 }
 488
 489 # FIXME sorry for the name again :)
 490 sub get_components_types {
 491     my ( $self ) = @_;
 492     my @comps_types;
 493
 494     for my $sub_container_name (qw/model view controller/) {
 495         my $sub_container = $self->get_sub_container($sub_container_name);
 496         for my $service ( $sub_container->get_service_list ) {
 497             my $comp     = $self->resolve(service => $service);
 498             my $compname = ref $comp || $comp;
 499             my $type     = ref $comp ? 'instance' : 'class';
 500             push @comps_types, [ $compname, $type ];
 501         }
 502     }
 503
 504     return @comps_types;
 505 }
 506
 507 sub get_all_components {
 508     my $self = shift;
 509     my %components;
 510
 511     my $containers = {
 512         map { $_ => $self->get_sub_container($_) } qw(model view controller)
 513     };
 514
 515     for my $container (keys %$containers) {
 516         for my $component ($containers->{$container}->get_service_list) {
 517             my $comp = $containers->{$container}->resolve(
 518                 service => $component
 519             );
 520             my $comp_name = ref $comp || $comp;
 521             $components{$comp_name} = $comp;
 522         }
 523     }
 524
 525     return lock_hash %components;
 526 }
 527
 528 sub add_component {
 529     my ( $self, $component, $class ) = @_;
 530     my ( $type, $name ) = _get_component_type_name($component);
 531
 532     return unless $type;
 533
 534     $self->get_sub_container($type)->add_service(
 535         Catalyst::IOC::BlockInjection->new(
 536             name  => $name,
 537             block => sub { $self->setup_component( $component, $class ) },
 538         )
 539     );
 540 }
 541
 542 # FIXME: should this sub exist?
 543 # should it be moved to Catalyst::Utils,
 544 # or replaced by something already existing there?
 545 sub _get_component_type_name {
 546     my ( $component ) = @_;
 547
 548     my @parts = split /::/, $component;
 549
 550     while (my $type = shift @parts) {
 551         return ('controller', join '::', @parts)
 552             if $type =~ /^(c|controller)$/i;
 553
 554         return ('model', join '::', @parts)
 555             if $type =~ /^(m|model)$/i;
 556
 557         return ('view', join '::', @parts)
 558             if $type =~ /^(v|view)$/i;
 559     }
 560
 561     return (undef, $component);
 562 }
 563
 564 # FIXME ugly and temporary
 565 # Just moved it here the way it was, so we can work on it here in the container
 566 sub setup_component {
 567     my ( $self, $component, $class ) = @_;
 568
 569     unless ( $component->can( 'COMPONENT' ) ) {
 570         return $component;
 571     }
 572
 573     # FIXME I know this isn't the "Dependency Injection" way of doing things,
 574     # its just temporary
 575     my $suffix = Catalyst::Utils::class2classsuffix( $component );
 576     my $config = $self->resolve(service => 'config')->{ $suffix } || {};
 577
 578     # Stash catalyst_component_name in the config here, so that custom COMPONENT
 579     # methods also pass it. local to avoid pointlessly shitting in config
 580     # for the debug screen, as $component is already the key name.
 581     local $config->{catalyst_component_name} = $component;
 582
 583     my $instance = eval { $component->COMPONENT( $class, $config ); };
 584
 585     if ( my $error = $@ ) {
 586         chomp $error;
 587         Catalyst::Exception->throw(
 588             message => qq/Couldn't instantiate component "$component", "$error"/
 589         );
 590     }
 591     elsif (!blessed $instance) {
 592         my $metaclass = Moose::Util::find_meta($component);
 593         my $method_meta = $metaclass->find_method_by_name('COMPONENT');
 594         my $component_method_from = $method_meta->associated_metaclass->name;
 595         my $value = defined($instance) ? $instance : 'undef';
 596         Catalyst::Exception->throw(
 597             message =>
 598             qq/Couldn't instantiate component "$component", COMPONENT() method (from $component_method_from) didn't return an object-like value (value was $value)./
 599         );
 600     }
 601
 602     return $instance;
 603 }
 604
 605 sub expand_component_module {
 606     my ( $class, $module ) = @_;
 607     return Devel::InnerPackage::list_packages( $module );
 608 }
 609
 610 sub locate_components {
 611     my ( $self, $class, $config ) = @_;
 612
 613     my @paths   = qw( ::Controller ::C ::Model ::M ::View ::V );
 614
 615     my $locator = Module::Pluggable::Object->new(
 616         search_path => [ map { s/^(?=::)/$class/; $_; } @paths ],
 617         %$config
 618     );
 619
 620     # XXX think about ditching this sort entirely
 621     my @comps = sort { length $a <=> length $b } $locator->plugins;
 622
 623     return @comps;
 624 }
 625
 626 1;
 627
 628 __END__
 629
 630 =pod
 631
 632 =head1 NAME
 633
 634 Catalyst::Container - IOC for Catalyst components
 635
 636 =head1 SYNOPSIS
 637
 638 =head1 DESCRIPTION
 639
 640 =head1 METHODS
 641
 642 =head1 Containers
 643
 644 =head2 build_model_subcontainer
 645
 646 Container that stores all models.
 647
 648 =head2 build_view_subcontainer
 649
 650 Container that stores all views.
 651
 652 =head2 build_controller_subcontainer
 653
 654 Container that stores all controllers.
 655
 656 =head1 Services
 657
 658 =head2 build_name_service
 659
 660 Name of the application.
 661
 662 =head2 build_driver_service
 663
 664 Config options passed directly to the driver being used.
 665
 666 =head2 build_file_service
 667
 668 ?
 669
 670 =head2 build_substitutions_service
 671
 672 Executes all the substitutions in config. See L</_config_substitutions> method.
 673
 674 =head2 build_extensions_service
 675
 676 =head2 build_prefix_service
 677
 678 =head2 build_path_service
 679
 680 =head2 build_config_service
 681
 682 =head2 build_raw_config_service
 683
 684 =head2 build_global_files_service
 685
 686 =head2 build_local_files_service
 687
 688 =head2 build_global_config_service
 689
 690 =head2 build_local_config_service
 691
 692 =head2 build_config_path_service
 693
 694 =head2 build_config_local_suffix_service
 695
 696 Determines the suffix of files used to override the main config. By default
 697 this value is C<local>, which will load C<myapp_local.conf>.  The suffix can
 698 be specified in the following order of preference:
 699
 700 =over
 701
 702 =item * C<$ENV{ MYAPP_CONFIG_LOCAL_SUFFIX }>
 703
 704 =item * C<$ENV{ CATALYST_CONFIG_LOCAL_SUFFIX }>
 705
 706 =back
 707
 708 The first one of these values found replaces the default of C<local> in the
 709 name of the local config file to be loaded.
 710
 711 For example, if C< $ENV{ MYAPP_CONFIG_LOCAL_SUFFIX }> is set to C<testing>,
 712 ConfigLoader will try and load C<myapp_testing.conf> instead of
 713 C<myapp_local.conf>.
 714
 715 =head2 get_component_from_sub_container($sub_container, $name, $c, @args)
 716
 717 Looks for components in a given subcontainer (such as controller, model or view), and returns the searched component. If $name is undef, it returns the default component (such as default_view, if $sub_container is 'view'). If $name is a regexp, it returns an array of matching components. Otherwise, it looks for the component with name $name.
 718
 719 =head2 get_components_types
 720
 721 =head2 get_all_components
 722
 723 Fetches all the components, in each of the sub_containers model, view and controller, and returns a readonly hash. The keys are the class names, and the values are the blessed objects. This is what is returned by $c->components.
 724
 725 =head2 add_component
 726
 727 Adds a component to the appropriate subcontainer. The subcontainer is guessed by the component name given.
 728
 729 =head2 find_component
 730
 731 Searches for components in all containers. If $component is the full class name, the subcontainer is guessed, and it gets the searched component in there. Otherwise, it looks for a component with that name in all subcontainers. If $component is a regexp, it calls the method below, find_component_regexp, and matches all components against that regexp.
 732
 733 =head2 find_component_regexp
 734
 735 Finds components that match a given regexp. Used internally, by find_component.
 736
 737 =head2 setup_component
 738
 739 =head2 _fix_syntax
 740
 741 =head2 _config_substitutions
 742
 743 This method substitutes macros found with calls to a function. There are a
 744 number of default macros:
 745
 746 =over
 747
 748 =item * C<__HOME__> - replaced with C<$c-E<gt>path_to('')>
 749
 750 =item * C<__ENV(foo)__> - replaced with the value of C<$ENV{foo}>
 751
 752 =item * C<__path_to(foo/bar)__> - replaced with C<$c-E<gt>path_to('foo/bar')>
 753
 754 =item * C<__literal(__FOO__)__> - leaves __FOO__ alone (allows you to use
 755 C<__DATA__> as a config value, for example)
 756
 757 =back
 758
 759 The parameter list is split on comma (C<,>). You can override this method to
 760 do your own string munging, or you can define your own macros in
 761 C<MyApp-E<gt>config-E<gt>{ 'Plugin::ConfigLoader' }-E<gt>{ substitutions }>.
 762 Example:
 763
 764     MyApp->config->{ 'Plugin::ConfigLoader' }->{ substitutions } = {
 765         baz => sub { my $c = shift; qux( @_ ); }
 766     }
 767
 768 The above will respond to C<__baz(x,y)__> in config strings.
 769
 770 =head2 $c->expand_component_module( $component, $setup_component_config )
 771
 772 Components found by C<locate_components> will be passed to this method, which
 773 is expected to return a list of component (package) names to be set up.
 774
 775 =head2 locate_components( $setup_component_config )
 776
 777 This method is meant to provide a list of component modules that should be
 778 setup for the application.  By default, it will use L<Module::Pluggable>.
 779
 780 Specify a C<setup_components> config option to pass additional options directly
 781 to L<Module::Pluggable>.
 782
 783 =head1 AUTHORS
 784
 785 Catalyst Contributors, see Catalyst.pm
 786
 787 =head1 COPYRIGHT
 788
 789 This library is free software. You can redistribute it and/or modify it under
 790 the same terms as Perl itself.
 791
 792 =cut