lib/Catalyst/Container.pm

   1 package Catalyst::Container;
   2 use Bread::Board;
   3 use Moose;
   4 use Config::Any;
   5 use Data::Visitor::Callback;
   6 use Catalyst::Utils ();
   7 use MooseX::Types::LoadableClass qw/ LoadableClass /;
   8 use Catalyst::BlockInjection;
   9 use namespace::autoclean;
  10
  11 extends 'Bread::Board::Container';
  12
  13 # FIXME - Why do any of these attributes need to be rw?
  14 has config_local_suffix => (
  15     is      => 'rw',
  16     isa     => 'Str',
  17     default => 'local',
  18 );
  19
  20 has driver => (
  21     is      => 'rw',
  22     isa     => 'HashRef',
  23     default => sub { +{} },
  24 );
  25
  26 has file => (
  27     is      => 'rw',
  28     isa     => 'Str',
  29     default => '',
  30 );
  31
  32 has substitutions => (
  33     is      => 'rw',
  34     isa     => 'HashRef',
  35     default => sub { +{} },
  36 );
  37
  38 has name => (
  39     is      => 'rw',
  40     isa     => 'Str',
  41     default => 'TestApp',
  42 );
  43
  44 has sub_container_class => (
  45     isa     => LoadableClass,
  46     is      => 'ro',
  47     coerce  => 1,
  48     default => 'Catalyst::SubContainer',
  49     handles => {
  50         new_sub_container => 'new',
  51     }
  52 );
  53
  54 # FIXME - Move all the Pod to the bottom!
  55
  56 =head1 NAME
  57
  58 Catalyst::Container - IOC for Catalyst components
  59
  60 =head1 METHODS
  61
  62 =cut
  63
  64 sub BUILD {
  65     my $self = shift;
  66
  67     $self->add_service(
  68         $self->${\"build_${_}_service"}
  69     ) for qw/
  70         substitutions
  71         file
  72         driver
  73         name
  74         prefix
  75         extensions
  76         path
  77         config
  78         raw_config
  79         global_files
  80         local_files
  81         global_config
  82         local_config
  83         config_local_suffix
  84         config_path
  85     /;
  86
  87     $self->add_sub_container(
  88         $self->${ \"build_${_}_subcontainer" }
  89     ) for qw/ model view controller /;
  90 }
  91
  92 =head2 build_model_subcontainer
  93
  94 =cut
  95
  96 sub build_model_subcontainer {
  97     my $self = shift;
  98
  99     return $self->new_sub_container( name => 'model' );
 100 }
 101
 102 =head2 build_view_subcontainer
 103
 104 =cut
 105
 106 sub build_view_subcontainer {
 107     my $self = shift;
 108
 109     return $self->new_sub_container( name => 'view' );
 110 }
 111
 112 =head2 build_controller_subcontainer
 113
 114 =cut
 115
 116 sub build_controller_subcontainer {
 117     my $self = shift;
 118
 119     return $self->new_sub_container( name => 'controller' );
 120 }
 121
 122 =head2 build_name_service
 123
 124 =cut
 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 =head2 build_driver_service
 133
 134 =cut
 135
 136 sub build_driver_service {
 137     my $self = shift;
 138
 139     return Bread::Board::Literal->new( name => 'driver', value => $self->driver );
 140 }
 141
 142 =head2 build_file_service
 143
 144 =cut
 145
 146 sub build_file_service {
 147     my $self = shift;
 148
 149     return Bread::Board::Literal->new( name => 'file', value => $self->file );
 150 }
 151
 152 =head2 build_substitutions_service
 153
 154 =cut
 155
 156 sub build_substitutions_service {
 157     my $self = shift;
 158
 159     return Bread::Board::Literal->new( name => 'substitutions', value => $self->substitutions );
 160 }
 161
 162 =head2 build_extensions_service
 163
 164 =cut
 165
 166 sub build_extensions_service {
 167     my $self = shift;
 168
 169     return Bread::Board::BlockInjection->new(
 170         name => 'extensions',
 171         block => sub {
 172             return \@{Config::Any->extensions};
 173         },
 174     );
 175 }
 176
 177 =head2 build_prefix_service
 178
 179 =cut
 180
 181 sub build_prefix_service {
 182     my $self = shift;
 183
 184     return Bread::Board::BlockInjection->new(
 185         name => 'prefix',
 186         block => sub {
 187             return Catalyst::Utils::appprefix( shift->param('name') );
 188         },
 189         dependencies => [ depends_on('name') ],
 190     );
 191 }
 192
 193 =head2 build_path_service
 194
 195 =cut
 196
 197 sub build_path_service {
 198     my $self = shift;
 199
 200     return Bread::Board::BlockInjection->new(
 201         name => 'path',
 202         block => sub {
 203             my $s = shift;
 204
 205             return Catalyst::Utils::env_value( $s->param('name'), 'CONFIG' )
 206             || $s->param('file')
 207             || $s->param('name')->path_to( $s->param('prefix') );
 208         },
 209         dependencies => [ depends_on('file'), depends_on('name'), depends_on('prefix') ],
 210     );
 211 }
 212
 213 =head2 build_config_service
 214
 215 =cut
 216
 217 sub build_config_service {
 218     my $self = shift;
 219
 220     return Bread::Board::BlockInjection->new(
 221         name => 'config',
 222         block => sub {
 223             my $s = shift;
 224
 225             my $v = Data::Visitor::Callback->new(
 226                 plain_value => sub {
 227                     return unless defined $_;
 228                     return $self->_config_substitutions( $s->param('name'), $s->param('substitutions'), $_ );
 229                 }
 230
 231             );
 232             $v->visit( $s->param('raw_config') );
 233         },
 234         dependencies => [ depends_on('name'), depends_on('raw_config'), depends_on('substitutions') ],
 235     );
 236 }
 237
 238 =head2 build_raw_config_service
 239
 240 =cut
 241
 242 sub build_raw_config_service {
 243     my $self = shift;
 244
 245     return Bread::Board::BlockInjection->new(
 246         name => 'raw_config',
 247         block => sub {
 248             my $s = shift;
 249
 250             my @global = @{$s->param('global_config')};
 251             my @locals = @{$s->param('local_config')};
 252
 253             my $config = {};
 254             for my $cfg (@global, @locals) {
 255                 for (keys %$cfg) {
 256                     $config = Catalyst::Utils::merge_hashes( $config, $cfg->{$_} );
 257                 }
 258             }
 259             return $config;
 260         },
 261         dependencies => [ depends_on('global_config'), depends_on('local_config') ],
 262     );
 263 }
 264
 265 =head2 build_global_files_service
 266
 267 =cut
 268
 269 sub build_global_files_service {
 270     my $self = shift;
 271
 272     return Bread::Board::BlockInjection->new(
 273         name => 'global_files',
 274         block => sub {
 275             my $s = shift;
 276
 277             my ( $path, $extension ) = @{$s->param('config_path')};
 278
 279             my @extensions = @{$s->param('extensions')};
 280
 281             my @files;
 282             if ( $extension ) {
 283                 die "Unable to handle files with the extension '${extension}'" unless grep { $_ eq $extension } @extensions;
 284                 push @files, $path;
 285             } else {
 286                 @files = map { "$path.$_" } @extensions;
 287             }
 288             return \@files;
 289         },
 290         dependencies => [ depends_on('extensions'), depends_on('config_path') ],
 291     );
 292 }
 293
 294 =head2 build_local_files_service
 295
 296 =cut
 297
 298 sub build_local_files_service {
 299     my $self = shift;
 300
 301     return Bread::Board::BlockInjection->new(
 302         name => 'local_files',
 303         block => sub {
 304             my $s = shift;
 305
 306             my ( $path, $extension ) = @{$s->param('config_path')};
 307             my $suffix = $s->param('config_local_suffix');
 308
 309             my @extensions = @{$s->param('extensions')};
 310
 311             my @files;
 312             if ( $extension ) {
 313                 die "Unable to handle files with the extension '${extension}'" unless grep { $_ eq $extension } @extensions;
 314                 $path =~ s{\.$extension}{_$suffix.$extension};
 315                 push @files, $path;
 316             } else {
 317                 @files = map { "${path}_${suffix}.$_" } @extensions;
 318             }
 319             return \@files;
 320         },
 321         dependencies => [ depends_on('extensions'), depends_on('config_path'), depends_on('config_local_suffix') ],
 322     );
 323 }
 324
 325 =head2 build_global_config_service
 326
 327 =cut
 328
 329 sub build_global_config_service {
 330     my $self = shift;
 331
 332     return Bread::Board::BlockInjection->new(
 333         name => 'global_config',
 334         block => sub {
 335             my $s = shift;
 336
 337             return Config::Any->load_files({
 338                 files       => $s->param('global_files'),
 339                 filter      => \&_fix_syntax,
 340                 use_ext     => 1,
 341                 driver_args => $s->param('driver'),
 342             });
 343         },
 344         dependencies => [ depends_on('global_files') ],
 345     );
 346 }
 347
 348 =head2 build_local_config_service
 349
 350 =cut
 351
 352 sub build_local_config_service {
 353     my $self = shift;
 354
 355     return Bread::Board::BlockInjection->new(
 356         name => 'local_config',
 357         block => sub {
 358             my $s = shift;
 359
 360             return Config::Any->load_files({
 361                 files       => $s->param('local_files'),
 362                 filter      => \&_fix_syntax,
 363                 use_ext     => 1,
 364                 driver_args => $s->param('driver'),
 365             });
 366         },
 367         dependencies => [ depends_on('local_files') ],
 368     );
 369 }
 370
 371 =head2 build_config_path_service
 372
 373 =cut
 374
 375 sub build_config_path_service {
 376     my $self = shift;
 377
 378     return Bread::Board::BlockInjection->new(
 379         name => 'config_path',
 380         block => sub {
 381             my $s = shift;
 382
 383             my $path = $s->param('path');
 384             my $prefix = $s->param('prefix');
 385
 386             my ( $extension ) = ( $path =~ m{\.(.{1,4})$} );
 387
 388             if ( -d $path ) {
 389                 $path =~ s{[\/\\]$}{};
 390                 $path .= "/$prefix";
 391             }
 392
 393             return [ $path, $extension ];
 394         },
 395         dependencies => [ depends_on('prefix'), depends_on('path') ],
 396     );
 397 }
 398
 399 =head2 build_config_local_suffix_service
 400
 401 =cut
 402
 403 sub build_config_local_suffix_service {
 404     my $self = shift;
 405
 406     return Bread::Board::BlockInjection->new(
 407         name => 'config_local_suffix',
 408         block => sub {
 409             my $s = shift;
 410             my $suffix = Catalyst::Utils::env_value( $s->param('name'), 'CONFIG_LOCAL_SUFFIX' ) || $self->config_local_suffix;
 411
 412             return $suffix;
 413         },
 414         dependencies => [ depends_on('name') ],
 415     );
 416 }
 417
 418 =head2 _fix_syntax
 419
 420 =cut
 421
 422 sub _fix_syntax {
 423     my $config     = shift;
 424     my @components = (
 425         map +{
 426             prefix => $_ eq 'Component' ? '' : $_ . '::',
 427             values => delete $config->{ lc $_ } || delete $config->{ $_ }
 428         },
 429         grep { ref $config->{ lc $_ } || ref $config->{ $_ } }
 430             qw( Component Model M View V Controller C Plugin )
 431     );
 432
 433     foreach my $comp ( @components ) {
 434         my $prefix = $comp->{ prefix };
 435         foreach my $element ( keys %{ $comp->{ values } } ) {
 436             $config->{ "$prefix$element" } = $comp->{ values }->{ $element };
 437         }
 438     }
 439 }
 440
 441 =head2 _config_substitutions
 442
 443 =cut
 444
 445 sub _config_substitutions {
 446     my ( $self, $name, $subs, $arg ) = @_;
 447
 448     $subs->{ HOME } ||= sub { shift->path_to( '' ); };
 449     $subs->{ ENV } ||=
 450         sub {
 451             my ( $c, $v ) = @_;
 452             if (! defined($ENV{$v})) {
 453                 Catalyst::Exception->throw( message =>
 454                     "Missing environment variable: $v" );
 455                 return "";
 456             } else {
 457                 return $ENV{ $v };
 458             }
 459         };
 460     $subs->{ path_to } ||= sub { shift->path_to( @_ ); };
 461     $subs->{ literal } ||= sub { return $_[ 1 ]; };
 462     my $subsre = join( '|', keys %$subs );
 463
 464     $arg =~ s{__($subsre)(?:\((.+?)\))?__}{ $subs->{ $1 }->( $name, $2 ? split( /,/, $2 ) : () ) }eg;
 465     return $arg;
 466 }
 467
 468 =head1 AUTHORS
 469
 470 Catalyst Contributors, see Catalyst.pm
 471
 472 =head1 COPYRIGHT
 473
 474 This library is free software. You can redistribute it and/or modify it under
 475 the same terms as Perl itself.
 476
 477 =cut
 478
 479 1;