File Coverage

blib/lib/Object/Depot/Role.pm
Criterion Covered Total %
statement 60 63 95.2
branch 5 12 41.6
condition 5 12 41.6
subroutine 29 29 100.0
pod 15 15 100.0
total 114 131 87.0


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