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 Moose::Util;
  10 use Catalyst::IOC::BlockInjection;
  11 use namespace::autoclean;
  12
  13 extends 'Bread::Board::Container';
  14
  15 has config_local_suffix => (
  16     is      => 'ro',
  17     isa     => 'Str',
  18     default => 'local',
  19 );
  20
  21 has driver => (
  22     is      => 'ro',
  23     isa     => 'HashRef',
  24     default => sub { +{} },
  25 );
  26
  27 has file => (
  28     is      => 'ro',
  29     isa     => 'Str',
  30     default => '',
  31 );
  32
  33 has substitutions => (
  34     is      => 'ro',
  35     isa     => 'HashRef',
  36     default => sub { +{} },
  37 );
  38
  39 has name => (
  40     is      => 'ro',
  41     isa     => 'Str',
  42     default => 'TestApp',
  43 );
  44
  45 has sub_container_class => (
  46     isa     => LoadableClass,
  47     is      => 'ro',
  48     coerce  => 1,
  49     default => 'Catalyst::IOC::SubContainer',
  50     handles => {
  51         new_sub_container => 'new',
  52     }
  53 );
  54
  55 sub BUILD {
  56     my ( $self, $params ) = @_;
  57
  58     $self->add_service(
  59         $self->${\"build_${_}_service"}
  60     ) for qw/
  61         substitutions
  62         file
  63         driver
  64         name
  65         prefix
  66         extensions
  67         path
  68         config
  69         raw_config
  70         global_files
  71         local_files
  72         global_config
  73         local_config
  74         config_local_suffix
  75         config_path
  76     /;
  77
  78     $self->add_sub_container(
  79         $self->build_controller_subcontainer
  80     );
  81
  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         # this is never a controller, so this is safe
 413         $c->log->warn( "Calling \$c->$sub_container_name() is not supported unless you specify one of:" );
 414         $c->log->warn( "* \$c->config(default_$sub_container_name => 'the name of the default $sub_container_name to use')" );
 415         $c->log->warn( "* \$c->stash->{current_$sub_container_name} # the name of the view to use for this request" );
 416         $c->log->warn( "* \$c->stash->{current_${sub_container_name}_instance} # the instance of the $sub_container_name to use for this request" );
 417
 418         return;
 419     }
 420
 421     return $sub_container->get_component_regexp( $name, $c, @args )
 422         if ref $name;
 423
 424     return $sub_container->get_component( $name, $c, @args )
 425         if $sub_container->has_service( $name );
 426
 427     $c->log->warn(
 428         "Attempted to use $sub_container_name '$name', " .
 429         "but it does not exist"
 430     );
 431
 432     return;
 433 }
 434
 435 sub find_component {
 436     my ( $self, $component, $c, @args ) = @_;
 437     my ( $type, $name ) = _get_component_type_name($component);
 438     my @result;
 439
 440     return $self->get_component_from_sub_container(
 441         $type, $name, $c, @args
 442     ) if $type;
 443
 444     my $query = ref $component
 445               ? $component
 446               : qr{^$component$}
 447               ;
 448
 449     for my $subcontainer_name (qw/model view controller/) {
 450         my $subcontainer = $self->get_sub_container($subcontainer_name);
 451         my @components   = $subcontainer->get_service_list;
 452         @result          = grep { m{$component} } @components;
 453
 454         return map { $subcontainer->get_component( $_, $c, @args ) } @result
 455             if @result;
 456     }
 457
 458     # one last search for things like $c->comp(qr/::M::/)
 459     @result = $self->find_component_regexp(
 460         $c->components, $component, $c, @args
 461     ) if !@result and ref $component;
 462
 463     # it expects an empty list on failed searches
 464     return @result;
 465 }
 466
 467 sub find_component_regexp {
 468     my ( $self, $components, $component, @args ) = @_;
 469     my @result;
 470
 471     my @components = grep { m{$component} } keys %{ $components };
 472
 473     for (@components) {
 474         my ($type, $name) = _get_component_type_name($_);
 475
 476         push @result, $self->get_component_from_sub_container(
 477             $type, $name, @args
 478         ) if $type;
 479     }
 480
 481     return @result;
 482 }
 483
 484 # FIXME sorry for the name again :)
 485 sub get_components_types {
 486     my ( $self ) = @_;
 487     my @comps_types;
 488
 489     for my $sub_container_name (qw/model view controller/) {
 490         my $sub_container = $self->get_sub_container($sub_container_name);
 491         for my $service ( $sub_container->get_service_list ) {
 492             my $comp     = $self->resolve(service => $service);
 493             my $compname = ref $comp || $comp;
 494             my $type     = ref $comp ? 'instance' : 'class';
 495             push @comps_types, [ $compname, $type ];
 496         }
 497     }
 498
 499     return @comps_types;
 500 }
 501
 502 sub get_all_components {
 503     my $self = shift;
 504     my %components;
 505
 506     my $containers = {
 507         map { $_ => $self->get_sub_container($_) } qw(model view controller)
 508     };
 509
 510     for my $container (keys %$containers) {
 511         for my $component ($containers->{$container}->get_service_list) {
 512             my $comp = $containers->{$container}->resolve(
 513                 service => $component
 514             );
 515             my $comp_name = ref $comp || $comp;
 516             $components{$comp_name} = $comp;
 517         }
 518     }
 519
 520     return lock_hash %components;
 521 }
 522
 523 sub add_component {
 524     my ( $self, $component, $class ) = @_;
 525     my ( $type, $name ) = _get_component_type_name($component);
 526
 527     return unless $type;
 528
 529     $self->get_sub_container($type)->add_service(
 530         Catalyst::IOC::BlockInjection->new(
 531             name  => $name,
 532             block => sub { $self->setup_component( $component, $class ) },
 533         )
 534     );
 535 }
 536
 537 # FIXME: should this sub exist?
 538 # should it be moved to Catalyst::Utils,
 539 # or replaced by something already existing there?
 540 sub _get_component_type_name {
 541     my ( $component ) = @_;
 542
 543     my @parts = split /::/, $component;
 544
 545     while (my $type = shift @parts) {
 546         return ('controller', join '::', @parts)
 547             if $type =~ /^(c|controller)$/i;
 548
 549         return ('model', join '::', @parts)
 550             if $type =~ /^(m|model)$/i;
 551
 552         return ('view', join '::', @parts)
 553             if $type =~ /^(v|view)$/i;
 554     }
 555
 556     return (undef, $component);
 557 }
 558
 559 # FIXME ugly and temporary
 560 # Just moved it here the way it was, so we can work on it here in the container
 561 sub setup_component {
 562     my ( $self, $component, $class ) = @_;
 563
 564     unless ( $component->can( 'COMPONENT' ) ) {
 565         return $component;
 566     }
 567
 568     # FIXME I know this isn't the "Dependency Injection" way of doing things,
 569     # its just temporary
 570     my $suffix = Catalyst::Utils::class2classsuffix( $component );
 571     my $config = $self->resolve(service => 'config')->{ $suffix } || {};
 572
 573     # Stash catalyst_component_name in the config here, so that custom COMPONENT
 574     # methods also pass it. local to avoid pointlessly shitting in config
 575     # for the debug screen, as $component is already the key name.
 576     local $config->{catalyst_component_name} = $component;
 577
 578     my $instance = eval { $component->COMPONENT( $class, $config ); };
 579
 580     if ( my $error = $@ ) {
 581         chomp $error;
 582         Catalyst::Exception->throw(
 583             message => qq/Couldn't instantiate component "$component", "$error"/
 584         );
 585     }
 586     elsif (!blessed $instance) {
 587         my $metaclass = Moose::Util::find_meta($component);
 588         my $method_meta = $metaclass->find_method_by_name('COMPONENT');
 589         my $component_method_from = $method_meta->associated_metaclass->name;
 590         my $value = defined($instance) ? $instance : 'undef';
 591         Catalyst::Exception->throw(
 592             message =>
 593             qq/Couldn't instantiate component "$component", COMPONENT() method (from $component_method_from) didn't return an object-like value (value was $value)./
 594         );
 595     }
 596
 597     return $instance;
 598 }
 599
 600
 601 1;
 602
 603 __END__
 604
 605 =pod
 606
 607 =head1 NAME
 608
 609 Catalyst::Container - IOC for Catalyst components
 610
 611 =head1 METHODS
 612
 613 =head2 build_model_subcontainer
 614
 615 =head2 build_view_subcontainer
 616
 617 =head2 build_controller_subcontainer
 618
 619 =head2 build_name_service
 620
 621 =head2 build_driver_service
 622
 623 =head2 build_file_service
 624
 625 =head2 build_substitutions_service
 626
 627 =head2 build_extensions_service
 628
 629 =head2 build_prefix_service
 630
 631 =head2 build_path_service
 632
 633 =head2 build_config_service
 634
 635 =head2 build_raw_config_service
 636
 637 =head2 build_global_files_service
 638
 639 =head2 build_local_files_service
 640
 641 =head2 build_global_config_service
 642
 643 =head2 build_local_config_service
 644
 645 =head2 build_config_path_service
 646
 647 =head2 build_config_local_suffix_service
 648
 649 =head2 get_component_from_sub_container
 650
 651 =head2 get_components_types
 652
 653 =head2 get_all_components
 654
 655 =head2 add_component
 656
 657 =head2 find_component
 658
 659 =head2 find_component_regexp
 660
 661 =head2 setup_component
 662
 663 =head2 _fix_syntax
 664
 665 =head2 _config_substitutions
 666
 667 =head1 AUTHORS
 668
 669 Catalyst Contributors, see Catalyst.pm
 670
 671 =head1 COPYRIGHT
 672
 673 This library is free software. You can redistribute it and/or modify it under
 674 the same terms as Perl itself.
 675
 676 =cut