File Coverage

blib/lib/Object/Depot/Role.pm
Criterion Covered Total %
statement 58 61 95.0
branch 5 12 41.6
condition 5 12 41.6
subroutine 28 28 100.0
pod 15 15 100.0
total 111 128 86.7


line stmt bran cond sub pod time code
1             package Object::Depot::Role;
2 2     2   15449 use strictures 2;
  2         13  
  2         73  
3              
4             =encoding utf8
5              
6             =head1 NAME
7              
8             Object::Depot::Role - Expose Object::Depot as a global singleton.
9              
10             =head1 SYNOPSIS
11              
12             See L.
13              
14             =head1 DESCRIPTION
15              
16             This role rolls up an L into a singleton available to
17             all code in your application. This role is ideal for creating global,
18             simplified, and centralized access to shared resources such as
19             connections to internal and cloud services.
20              
21             =cut
22              
23 2     2   388 use Carp qw( croak );
  2         4  
  2         72  
24 2     2   764 use Object::Depot;
  2         7  
  2         69  
25 2     2   15 use Scalar::Util qw( blessed );
  2         5  
  2         82  
26 2     2   11 use Sub::Name qw( subname );
  2         4  
  2         66  
27              
28 2     2   11 use Role::Tiny;
  2         4  
  2         14  
29 2     2   304 use namespace::clean;
  2         3  
  2         15  
30              
31             my %DEPOTS;
32              
33             sub import {
34 4     4   5332 my $class = shift;
35 4         10 my $target = caller();
36 4         9 my $depot = $class->depot();
37              
38 4 50       30 return if !$depot->_has_export_name();
39              
40 4         10 my $name = $depot->export_name();
41 4         7 my $do_it = $depot->always_export();
42              
43 4         7 foreach my $arg (@_) {
44 2 50 33     13 if (defined($arg) and $arg eq $name) {
45 2         5 $do_it = 1;
46 2         4 next;
47             }
48              
49 0 0       0 croak sprintf(
50             'Unknown export, %s, passed to %s',
51             defined($arg) ? qq["$arg"] : 'undef',
52             $target,
53             );
54             }
55              
56 4 100       10 return if !$do_it;
57              
58 3         16 my $sub = $class->can($name);
59 3   66 4   24 $sub ||= subname $name => sub{ $class->fetch(@_) };
  4     4   5473  
60              
61             {
62 2     2   856 no strict 'refs';
  2         4  
  2         63  
  3         5  
63 2     2   10 no warnings 'redefine';
  2         4  
  2         554  
64 3         4 *{"$target\::$name"} = $sub
  3         12  
65             }
66              
67 3         7 return;
68             }
69              
70              
71             =head1 CLASS ATTRIBUTES
72              
73             =head2 depot
74              
75             The L singleton object. Will return C if
76             L has not yet been called.
77              
78             =cut
79              
80             sub depot {
81 10     10 1 16 my ($class) = @_;
82 10         33 return $DEPOTS{ $class };
83             }
84              
85             =head1 CLASS METHODS
86              
87             =head2 init_depot
88              
89             __PACKAGE__->init_depot( $depot );
90              
91             Takes an L object and saves it for later retrieval by
92             L.
93              
94             =cut
95              
96             sub init_depot {
97 3     3 1 1513 my $class = shift;
98              
99             croak "init_depot() has already been called on $class"
100 3 50       11 if $DEPOTS{ $class };
101              
102 3 0 33     24 if (@_==1 and blessed($_[0]) and $_[0]->isa('Object::Depot')) {
      33        
103 0         0 $DEPOTS{ $class } = shift;
104 0         0 return;
105             }
106              
107 3         33 $DEPOTS{ $class } = Object::Depot->new( @_ );
108              
109 3         476 return;
110             }
111              
112             =head1 PROXIED METHODS
113              
114             These class methods proxy to the L object.
115              
116             =over
117              
118             =item L
119              
120             =item L
121              
122             =item L
123              
124             =item L
125              
126             =item L
127              
128             =item L
129              
130             =item L
131              
132             =item L
133              
134             =item L
135              
136             =item L
137              
138             =item L
139              
140             =item L
141              
142             =item L
143              
144             =back
145              
146             =cut
147              
148             foreach my $method (qw(
149             fetch
150             store
151             remove
152             create
153             arguments
154             declared_keys
155             inject
156             inject_with_guard
157             clear_injection
158             injection
159             has_injection
160             add_key
161             alias_key
162             )) {
163             my $sub = subname( $method => sub{
164 4     4 1 9 my $class = shift;
        4 1    
        4 1    
        4 1    
        4 1    
        4 1    
        4 1    
        4 1    
        4 1    
        4 1    
        4 1    
        4 1    
        4 1    
165 4         9 local $Carp::CarpInternal{ (__PACKAGE__) } = 1;
166 4         17 return $class->depot->$method( @_ );
167             });
168              
169 2     2   12 { no strict 'refs'; *{__PACKAGE__ . "::$method"} = $sub }
  2         4  
  2         129  
170             }
171              
172             1;
173             __END__