From 564896f87312f8355039c487bf5de3b20f108f1c Mon Sep 17 00:00:00 2001 From: Doug Bell Date: Sat, 27 Feb 2016 21:49:28 -0600 Subject: [PATCH] add bare services Bare services allow us to interleave metadata and arguments when a class takes a hash: object: $class: Class arg: value This makes it easier to provide a "default" class: use Scalar::Util qw( blessed ); my $obj = $wire->get( 'object' ); if ( !blessed $obj ) { $obj = Class->new( %$obj ); } Bare services also allow us to have arrays and hashes of objects: array: - $class: Class arg: value - $class: Class arg: value hash: key: $class: Class arg: value key: $class: Class arg: value Fixes #43 --- lib/Beam/Wire.pm | 148 +++++++++++++++++++++++++++------- lib/Beam/Wire/Help/Config.pod | 98 +++++++++++++++++++--- t/service/class_args.t | 31 +++++++ t/service/extends.t | 26 ++++++ t/service/value.t | 78 ++++++++++++++++++ 5 files changed, 343 insertions(+), 38 deletions(-) diff --git a/lib/Beam/Wire.pm b/lib/Beam/Wire.pm index 0c1451f..57333f3 100644 --- a/lib/Beam/Wire.pm +++ b/lib/Beam/Wire.pm @@ -10,6 +10,10 @@ package Beam::Wire; args: name: Malcolm Reynolds rank: Captain + first_officer: + $class: Person + name: Zoë Alleyne Washburne + rank: Commander # script.pl use Beam::Wire; @@ -206,9 +210,11 @@ sub get { my ( $container_name, $service ) = split m{/}, $name, 2; return $self->get( $container_name )->get( $service, %override ); } + if ( keys %override ) { return $self->create_service( "\$anonymous extends $name", %override, extends => $name ); } + my $service = $self->services->{$name}; if ( !$service ) { my $config_ref = $self->get_config($name); @@ -218,12 +224,19 @@ sub get { file => $self->file, ); } - my %config = %{ $config_ref }; - $service = $self->create_service( $name, %config ); - if ( !$config{lifecycle} || lc $config{lifecycle} ne 'factory' ) { - $self->services->{$name} = $service; + + if ( ref $config_ref eq 'HASH' && $self->is_meta( $config_ref ) ) { + my %config = %{ $self->normalize_config( $config_ref ) }; + $service = $self->create_service( $name, %config ); + if ( !$config{lifecycle} || lc $config{lifecycle} ne 'factory' ) { + $self->services->{$name} = $service; + } + } + else { + $self->services->{$name} = $service = $self->find_refs( $name, $config_ref ); } } + return $service; } @@ -273,6 +286,52 @@ sub get_config { return $self->config->{$name}; } +=method normalize_config + + my $out_conf = $self->normalize_config( $in_conf ); + +Normalize the given C<$in_conf> into to hash that L expects. This method allows a service to be +defined with prefixed meta-names (C<$class> instead of C) and +the arguments specified without prefixes. + +For example, these two services are identical. + + foo: + class: Foo + args: + fizz: buzz + + foo: + $class: Foo + fizz: buzz + +The C<$in_conf> must be a hash, and must already pass L. + +=cut + +sub normalize_config { + my ( $self, $conf ) = @_; + + my %meta = reverse $self->get_meta_names; + + # Confs without prefixed keys can be used as-is + return $conf if !grep { $meta{ $_ } } keys %$conf; + + my %out_conf; + for my $key ( keys %$conf ) { + if ( $meta{ $key } ) { + $out_conf{ $meta{ $key } } = $conf->{ $key }; + } + else { + $out_conf{ args }{ $key } = $conf->{ $key }; + } + } + + return \%out_conf; +} + =method create_service my $service = $wire->create_service( $name, %config ); @@ -374,8 +433,10 @@ L as needed. sub create_service { my ( $self, $name, %service_info ) = @_; + # Compose the parent ref into the copy, in case the parent changes %service_info = $self->merge_config( %service_info ); + # value and class/extends are mutually exclusive # must check after merge_config in case parent config has class/value if ( exists $service_info{value} && ( @@ -488,7 +549,7 @@ sub merge_config { file => $self->file, ); } - my %base_config = %{$base_config_ref}; + my %base_config = %{ $self->normalize_config( $base_config_ref ) }; # Merge the args separately, to be a bit nicer about hashes of arguments my $args; if ( ref $service_info{args} eq 'HASH' && ref $base_config{args} eq 'HASH' ) { @@ -583,6 +644,7 @@ dependencies are created first. sub find_refs { my ( $self, $for, @args ) = @_; + my @out; my %meta = $self->get_meta_names; for my $arg ( @args ) { @@ -592,13 +654,7 @@ sub find_refs { push @out, $self->resolve_ref( $for, $arg ); } else { # Try to treat it as a service to create - my %service_info; - my $prefix = $self->meta_prefix; - for my $arg_key ( keys %{$arg} ) { - my $info_key = $arg_key; - $info_key =~ s/^\Q$prefix//; - $service_info{ $info_key } = $arg->{ $arg_key }; - } + my %service_info = %{ $self->normalize_config( $arg ) }; push @out, $self->create_service( '$anonymous', %service_info ); } } @@ -613,7 +669,9 @@ sub find_refs { push @out, $arg; # simple scalars } } - return @out; + + # In case we only pass in one argument and want one return value + return wantarray ? @out : $out[-1]; } =method is_meta @@ -624,17 +682,40 @@ Returns true if the given hash reference describes some kind of Beam::Wire service. This is used to identify service configuration hashes inside of larger data structures. -A service hash reference must contain at least one key, and must not -contain any keys that are not meta-keys (as returned by L). +A service hash reference must contain at least one key, and must either +be made completely of meta keys (as returned by L), or contain a L key that +could create or reference an object (one of C, C, +C, C, or C); =cut sub is_meta { my ( $self, $arg ) = @_; - my $prefix = $self->meta_prefix; - my @keys = keys %{ $arg }; - return @keys && !grep { !/^\Q$prefix/ } @keys; + + # Only a hashref can be meta + return unless ref $arg eq 'HASH'; + + my @keys = keys %$arg; + return unless @keys; + + my %meta = $self->get_meta_names; + my %meta_names = map { $_ => 1 } values %meta; + + # A regular service does not need the prefix, but must consist + # only of meta keys + return 1 if scalar @keys eq grep { $meta{ $_ } } @keys; + + # A meta service contains at least one of these keys, as these are + # the keys that can create a service. All other keys are + # modifiers + return 1 + if grep { exists $arg->{ $_ } } + map { $meta{ $_ } } + qw( ref class extends config value ); + + # Must not be meta + return; } =method get_meta_names @@ -650,14 +731,19 @@ sub get_meta_names { my ( $self ) = @_; my $prefix = $self->meta_prefix; my %meta = ( - ref => "${prefix}ref", - path => "${prefix}path", - method => "${prefix}method", - args => "${prefix}args", - class => "${prefix}class", - extends => "${prefix}extends", - sub => "${prefix}sub", - call => "${prefix}call", + ref => "${prefix}ref", + path => "${prefix}path", + method => "${prefix}method", + args => "${prefix}args", + class => "${prefix}class", + extends => "${prefix}extends", + sub => "${prefix}sub", + call => "${prefix}call", + lifecycle => "${prefix}lifecycle", + on => "${prefix}on", + with => "${prefix}with", + value => "${prefix}value", + config => "${prefix}config", ); return wantarray ? %meta : \%meta; } @@ -831,10 +917,14 @@ sub BUILD { } # Create all the eager services + my %meta = $self->get_meta_names; for my $key ( keys %{ $self->config } ) { my $config = $self->config->{$key}; - if ( $config->{lifecycle} && $config->{lifecycle} eq 'eager' ) { - $self->get($key); + if ( ref $config eq 'HASH' ) { + my $lifecycle = $config->{lifecycle} || $config->{ $meta{lifecycle} }; + if ( $lifecycle && $lifecycle eq 'eager' ) { + $self->get($key); + } } } return; diff --git a/lib/Beam/Wire/Help/Config.pod b/lib/Beam/Wire/Help/Config.pod index 2eae4a1..cfd0467 100644 --- a/lib/Beam/Wire/Help/Config.pod +++ b/lib/Beam/Wire/Help/Config.pod @@ -145,6 +145,44 @@ Which is the same as: rank => 'Pilot', } ); +=head2 Prefixed Metadata + +For brevity's sake, if your constructor takes a hash of arguments, you +can configure your service using C<$class> instead: + + # container.yml + simon: + $class: Person + name: Simon Tam + rank: Doctor + + # container.pl + my $config = { + simon => { + '$class' => 'Person', + name => 'Simon Tam', + rank => 'Doctor', + }, + }; + +Which is the same as: + + my $simon = Person->new( { + name => 'Simon Tam', + rank => 'Doctor', + } ); + +This makes it easy to make a "default class" in your config file: + + use Scalar::Util qw( blessed ); + my $person = $wire->get( 'person' ); + if ( !blessed $person ) { + $person = Person->new( %$person ); + } + +By prefixing any metadata with the prefix character (default: C<$>), you +can interleave your args and your metadata. + =head1 OBJECT LIFECYCLE By default, services are lazy and cached. They are not created until @@ -206,19 +244,16 @@ C to C. # container.yml black_box: - class: Logger - lifecycle: eager - args: - log_level: warn + $class: Logger + $lifecycle: eager + log_level: warn # container.pl my $config = { black_box => { - class => 'Logger', - lifecycle => 'eager', - args => { - log_level => 'warn', - }, + '$class' => 'Logger', + '$lifecycle' => 'eager', + log_level => 'warn', }, }; @@ -486,6 +521,51 @@ object. cargo: $config: manifest.yml +=head2 Bare Services + +Additionally, any service that does not look like an object config (does +not pass L) will be treated like +a bare service. A bare service is like a value service, except that +references inside are resolved. With this, you can set up arrays and +hashes of objects. + + # container.yml + crew_list: + - $ref: malcolm + - $ref: zoe + - $ref: wash + - $ref: kaylee + - $ref: jayne + crew_manifest: + captain: + $ref: malcolm + pilot: + $ref: wash + engineer: + $ref: kaylee + + # container.pl + my $config = { + crew_list => [ + { '$ref' => 'malcolm' }, + { '$ref' => 'zoe' }, + { '$ref' => 'wash' }, + { '$ref' => 'kaylee' }, + { '$ref' => 'jayne' }, + ], + crew_manifest => { + captain => { + '$ref' => 'malcolm', + }, + pilot => { + '$ref' => 'wash', + }, + engineer => { + '$ref' => 'kaylee', + }, + }, + }; + =head1 ADVANCED FEATURES =head2 Nested Containers diff --git a/t/service/class_args.t b/t/service/class_args.t index cbaa513..7722b0b 100644 --- a/t/service/class_args.t +++ b/t/service/class_args.t @@ -119,4 +119,35 @@ subtest 'class args: scalar' => sub { cmp_deeply $foo->got_args, [ 'foo' ]; }; +subtest 'class args (raw): hashref' => sub { + my $wire = Beam::Wire->new( + config => { + foo => { + '$class' => 'My::ArgsTest', + foo => 'bar', + }, + }, + ); + + my $foo; + lives_ok { $foo = $wire->get( 'foo' ) }; + cmp_deeply $foo->got_args, [ foo => 'bar' ]; +}; + +subtest 'class args (raw): with method' => sub { + my $wire = Beam::Wire->new( + config => { + foo => { + '$class' => 'My::ArgsTest', + '$method' => 'new', + foo => 'bar', + }, + }, + ); + + my $foo; + lives_ok { $foo = $wire->get( 'foo' ) }; + cmp_deeply $foo->got_args, [ foo => 'bar' ]; +}; + done_testing; diff --git a/t/service/extends.t b/t/service/extends.t index f0d4b34..d279d05 100644 --- a/t/service/extends.t +++ b/t/service/extends.t @@ -136,6 +136,32 @@ subtest 'hash args' => sub { cmp_deeply $wire->get_config( 'base_hash' ), $expect_base_hash, 'extends does not modify original config'; }; + +}; + +subtest 'extends (raw): hash' => sub { + my $wire = Beam::Wire->new( + config => { + base_hash => { + '$class' => 'My::ArgsTest', + hello => 'Hello', + who => 'World', + }, + hash => { + '$extends' => 'base_hash', + who => 'Everyone', + }, + }, + ); + + my $expect_base_hash = $wire->get_config( 'base_hash' ); + + my $svc; + lives_ok { $svc = $wire->get( 'hash' ) }; + isa_ok $svc, 'My::ArgsTest'; + cmp_deeply $svc->got_args_hash, { hello => 'Hello', who => 'Everyone' }; + cmp_deeply $wire->get_config( 'base_hash' ), $expect_base_hash, + 'extends does not modify original config'; }; subtest 'nested data structures' => sub { diff --git a/t/service/value.t b/t/service/value.t index edb9c03..1c9e917 100644 --- a/t/service/value.t +++ b/t/service/value.t @@ -20,4 +20,82 @@ subtest 'value service: simple scalar' => sub { is $greeting, 'Hello, World'; }; +subtest 'value service (raw): array ref' => sub { + my $wire = Beam::Wire->new( + config => { + greeting => [ 'Hello, World' ], + }, + ); + + my $greeting; + lives_ok { $greeting = $wire->get( 'greeting' ) }; + is ref $greeting, 'ARRAY', 'got an array ref'; + is scalar @$greeting, 1, 'arrayref has 1 element'; + is $greeting->[0], 'Hello, World'; + + subtest 'with $ref' => sub { + my $wire = Beam::Wire->new( + config => { + greeting => [ 'Hello, World', { '$ref' => 'other' } ], + other => 'Hello, Others!', + }, + ); + + my $greeting; + lives_ok { $greeting = $wire->get( 'greeting' ) }; + is ref $greeting, 'ARRAY', 'got an array ref'; + is scalar @$greeting, 2, 'arrayref has 1 element'; + is $greeting->[0], 'Hello, World'; + is $greeting->[1], 'Hello, Others!'; + }; +}; + +subtest 'value service (raw): hash ref' => sub { + my $wire = Beam::Wire->new( + config => { + greeting => { + hello => 'Hello', + who => 'World', + }, + }, + ); + + my $greeting; + lives_ok { $greeting = $wire->get( 'greeting' ) }; + is ref $greeting, 'HASH', 'got a hash ref'; + is $greeting->{hello}, 'Hello'; + is $greeting->{who}, 'World'; + + subtest 'with $ref' => sub { + my $wire = Beam::Wire->new( + config => { + greeting => { + hello => 'Hello', + who => { '$ref' => 'others' }, + }, + others => 'Others', + }, + ); + + my $greeting; + lives_ok { $greeting = $wire->get( 'greeting' ) }; + is ref $greeting, 'HASH', 'got a hash ref'; + is $greeting->{hello}, 'Hello'; + is $greeting->{who}, 'Others'; + }; +}; + +subtest 'value service (raw): scalar' => sub { + my $wire = Beam::Wire->new( + config => { + greeting => 'Hello, World', + }, + ); + + my $greeting; + lives_ok { $greeting = $wire->get( 'greeting' ) }; + ok !ref $greeting, 'got a simple scalar'; + is $greeting, 'Hello, World'; +}; + done_testing;