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