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