File Coverage

blib/lib/Bread/Board/Svc.pm
Criterion Covered Total %
statement 46 47 97.8
branch 21 22 95.4
condition n/a
subroutine 13 13 100.0
pod 2 2 100.0
total 82 84 97.6


line stmt bran cond sub pod time code
1             package Bread::Board::Svc;
2             $Bread::Board::Svc::VERSION = '0.01';
3 1     1   1438137 use strict;
  1         2  
  1         23  
4 1     1   3 use warnings;
  1         1  
  1         21  
5              
6             # ABSTRACT: shortcuts for Bread::Board::service function
7              
8              
9 1     1   3 use Exporter 'import';
  1         4  
  1         23  
10 1     1   3 use Carp qw(confess);
  1         1  
  1         46  
11             use Types::Standard
12 1     1   510 qw(Ref ArrayRef ScalarRef Str Maybe HashRef CodeRef Any Tuple);
  1         44925  
  1         7  
13              
14 1     1   1073 use List::Util qw(pairmap );
  1         1  
  1         445  
15              
16             our @EXPORT_OK = qw(svc svc_singleton);
17              
18             # with reference to arrayref the parameters are passed positional
19             # svc($name, $class, [ \@deps ], $block)
20             my $pos_deps_type = ScalarRef [ArrayRef];
21             my $deps_type = ArrayRef | HashRef | $pos_deps_type;
22              
23             my $params_type
24             = Tuple [ Str, Str, $deps_type, CodeRef ] # $name, $class, $deps, $block
25             | Tuple [ Str, Str, $deps_type ] # $name, $class, $deps,
26             | Tuple [ Str, $deps_type, CodeRef ] # $name, $deps, $block
27             ;
28              
29             # same as service returns literal
30             my $svc_params_type = $params_type | Tuple [ Str, Any ];
31             my $svc_singleton_params_type = $params_type;
32              
33             sub svc {
34 10 50   10 1 20550 confess "svc: invalid args: " . join( ', ', map {"'$_'"} @_ )
  0         0  
35             if !$svc_params_type->( [@_] );
36              
37 10         1561 return _svc( 0, @_ );
38             }
39              
40             sub svc_singleton {
41 2 100   2 1 2934 confess "svc_singleton: invalid args: " . join( ', ', map {"'$_'"} @_ )
  2         1130  
42             if !$svc_singleton_params_type->check( [@_] );
43 1         15 return _svc( 1, @_ );
44             }
45              
46             sub _svc {
47 11     11   18 my ( $singleton, $name, @args ) = @_;
48              
49             # leads to Bread::Board::Service::Literal
50 11 100       22 return Bread::Board::service( $name => $args[0] ) if @args == 1;
51              
52 10 100       20 my $class = !ref $args[0] ? shift @args : ();
53 10         11 my $deps = shift @args;
54 10         12 my $body = shift @args;
55              
56             my $build = sub {
57 10 100   10   31 return Bread::Board::service(
    100          
58             $name,
59             ( $singleton ? ( lifecycle => 'Singleton' ) : () ),
60             ( $class ? ( class => $class ) : () ), @_
61             );
62 10         23 };
63 10 100       29 if ( $pos_deps_type->check($deps) ) {
64              
65             # positional dependencies passed like \ [ path1, path2 ]
66 3         25 my $i = 0;
67 3         3 my @dependencies = map { ( "p" . ++$i => $_ ); } @{$$deps};
  6         14  
  3         5  
68 3     6   23 my @pnames = pairmap {$a} @dependencies;
  6         8  
69              
70             return $build->(
71             dependencies => +{@dependencies},
72             block => sub {
73 3     3   8364 my $s = shift;
74 3         4 my @args = @{ $s->params }{@pnames};
  3         60  
75 3 100       65 return $body
    100          
76             ? $body->( $class ? $s->class : (), @args )
77             : $s->class->new(@args);
78             }
79 3         17 );
80             }
81              
82             # named dependencies, parameters are interpolated
83             # key => value, ... instead of \%params
84             return $build->(
85             dependencies => $deps,
86             ( $body
87             ? ( block => sub {
88 6     6   35249 my $s = shift;
89 6 100       95 $body->( $class ? $s->class : (), %{ $s->params } );
  6         127  
90             }
91             )
92 7 100       70 : ()
93             ),
94             );
95             }
96              
97             1;
98              
99             # vim: expandtab:shiftwidth=4:tabstop=4:softtabstop=0:textwidth=78:
100              
101             __END__
102              
103             =pod
104              
105             =encoding UTF-8
106              
107             =head1 NAME
108              
109             Bread::Board::Svc - shortcuts for Bread::Board::service function
110              
111             =head1 VERSION
112              
113             version 0.01
114              
115             =head1 SYNOPSIS
116              
117             use Bread::Board::Svc qw(svc svc_singleton);
118              
119             # instead of
120             service router => (
121             class => 'Router::Pygmy',
122             dependencies => ['routes'],
123             );
124              
125             # you can write positionally
126             svc 'router', 'Router::Pygmy', ['routes'];
127              
128             # instead of
129             service app_data => (
130             dependencies => ['app_home'],
131             block => sub {
132             my $s = shift;
133             my $p = $s->params;
134             dir( $p->{app_home}, 'var' );
135             }
136             );
137              
138             # you can write
139             svc app_data => ( \['app_home'], sub { dir( shift(), 'var' ) } );
140              
141             # or
142             svc 'app_data', \['app_home'], sub { dir( shift(), 'var' ) };
143              
144             =head1 DESCRIPTION
145              
146             This module provides shortcut for Bread::Board::Service with positional
147             params.
148              
149             =head1 EXPORTED FUNCTIONS
150              
151             All functions are exported on demand.
152              
153             =over 4
154              
155             =item B<svc($name, @args)>
156              
157             Creates service by calling Bread::Board::service internally.
158              
159             =item B<svc_singleton($name, @args)>
160              
161             Same as C<< svc >> but adds C<< lifecycle => 'Singleton' >> to Bread::Board::service params.
162              
163             =back
164              
165             The argument combinations are:
166              
167             =over 4
168              
169             =item B<svc($name, $class, $deps, $body)>
170              
171             =item B<svc($name, $class, $deps)>
172              
173             =item B<svc($name, $deps, $body)>
174              
175             =item B<svc($name, $value)>
176              
177             This combination just passes args to Bread::Board::service.
178              
179             =back
180              
181             When the service is about to be resolved, then C<< $body >> subroutine is called.
182             The arguments are C<< $class >> (if present) and the list of resolved dependencies.
183              
184             If C<< $deps >> is a hashref or an arrayref, it has same meaning as for dependencies
185             and resolved dependencies are passed as << $key => $value >>.
186             If C<< $deps >> is a reference to an arrayref (C<< \ [ $path1, $path2, ... ] >> ),
187             then only the dependency values are passed to block, without the names (the
188             names are constructed artificially).
189              
190             If C<< $body >> is ommitted then the constructor of C<< $class >> is called
191             (see Bread::Board::ConstructorInjection).
192              
193             It should be noted that C<< $class >> is loaded lazily (before first resolution).
194              
195             =head1 AUTHOR
196              
197             Roman Daniel <roman@daniel.cz>
198              
199             =head1 COPYRIGHT AND LICENSE
200              
201             This software is copyright (c) 2016 by Roman Daniel.
202              
203             This is free software; you can redistribute it and/or modify it under
204             the same terms as the Perl 5 programming language system itself.
205              
206             =cut