File Coverage

blib/lib/Articulate/Syntax.pm
Criterion Covered Total %
statement 104 120 86.6
branch 30 36 83.3
condition 23 26 88.4
subroutine 25 28 89.2
pod 10 10 100.0
total 192 220 87.2


line stmt bran cond sub pod time code
1             package Articulate::Syntax;
2 10     10   20060 use strict;
  10         13  
  10         290  
3 10     10   32 use warnings;
  10         13  
  10         210  
4              
5 10     10   36 use Scalar::Util qw(blessed);
  10         11  
  10         2122  
6 10     10   4998 use Module::Load ();
  10         9289  
  10         189  
7              
8 10     10   4954 use Exporter::Declare;
  10         196741  
  10         42  
9             default_exports qw(
10             instantiate instantiate_array instantiate_selection instantiate_array_selection
11             response articulate_request
12             credentials permission
13             loc locspec
14             dpath_get dpath_set
15             hash_merge
16             throw_error
17             select_from
18             is_single_key_hash
19             );
20              
21 10     10   16287 use Articulate::Error;
  10         28  
  10         69  
22 10     10   10311 use Data::DPath qw(dpath dpathr);
  10         1111371  
  10         73  
23 10     10   8559 use Hash::Merge ();
  10         21170  
  10         250  
24              
25 10     10   66 use Articulate::Error;
  10         13  
  10         89  
26 10     10   7655 use Articulate::Credentials;
  10         31  
  10         45  
27 10     10   7009 use Articulate::File;
  10         112  
  10         277  
28 10     10   2546 use Articulate::Item;
  10         29  
  10         288  
29 10     10   3673 use Articulate::Location;
  10         22  
  10         40  
30 10     10   6733 use Articulate::LocationSpecification;
  10         30  
  10         35  
31 10     10   6692 use Articulate::Permission;
  10         27  
  10         39  
32 10     10   6901 use Articulate::Request;
  10         39  
  10         43  
33 10     10   4773 use Articulate::Response;
  10         23  
  10         114  
34              
35             # sub throw_error { Articulate::Error::throw_error(@_) };
36             # sub loc { Articulate::Location::loc(@_) };
37              
38             =head3 instantiate_array
39              
40             C accepts an arrayref of values which represent objects. For each value, if it is not an object, it will attempt to instantiate one using C.
41              
42             If you pass C a value which is not an arrayref, it will assume you meant to give it an arrayref with a single item; or, if you pass it C, it will return an empty arrayref.
43              
44             The purpose of this function is to enable the following:
45              
46             package Articulate::SomeDelegatingComponent;
47             use Moo;
48             has delegates_to =>
49             is => 'rw',
50             default => sub { [] },
51             coerce => sub{ instantiate_array(@_) };
52              
53             Which means given config like the following:
54              
55             Articulate::SomeDelegatingComponent:
56             delegates_to:
57             - My::Validation::For::Articles
58             - class: My::Validation::For::Images
59             args:
60             - max_width: 1024
61             max_height: 768
62             - class: My::Validation::For::Documents
63             constructor: preset
64             args: pdf
65              
66             You can be guaranteed that looping through C<< @{ $self->delegates_to } >> will always produce objects.
67              
68             =head3 instantiate
69              
70             Attempts to create an object from the hashref or class name provided.
71              
72             If the value is a string, it will treat as a class name, and perform C<< $class->new >>, or, if the method exists, C<< $class->instance >> will be preferred (for instance, as provided by C).
73              
74             If the value is a hashref, it will look at the values for the keys C, C, and C. It will then attempt to perform C<< $class->$constructor(@$args) >>, unless the constructor is absent (in which case C or C will be supplied), or if C is not an arrayref, in which case it will be passed to the constructor as a single argument (or the empty list will be passed if C is undefined).
75              
76             If the value is an object, the object will simply be returned.
77              
78             =cut
79              
80             sub instantiate {
81 350     350 1 6523 my $original = shift;
82 350 100       1092 if ( blessed $original ) {
    100          
    50          
83 210         550 return $original;
84             }
85             elsif ( !ref $original ) {
86 86         305 Module::Load::load($original);
87 86 100       3424 if ( $original->can('instance') ) {
88 1         4 return $original->instance();
89             }
90             else {
91 85         461 return $original->new();
92             }
93             }
94             elsif ( ref $original eq ref {} ) {
95 54         85 my $class = $original->{class};
96 54         73 my $args = $original->{args};
97 54 100 100     506 if ( 1 == keys %$original and join( '', keys %$original ) !~ /^[a-z_]/ )
98             { # single key that looks like a class
99 41         96 $class = join '', keys %$original;
100 41         95 $args = $original->{$class};
101             }
102 54 50       153 throw_error Internal => 'Instantiation failed: expecting key class, got '
103             . ( join ', ', keys %$original )
104             unless defined $class;
105 54         167 Module::Load::load($class);
106 54 100 66     4052 my $constructor = $original->{constructor}
107             // ( $class->can('instance') ? 'instance' : 'new' );
108 54 100       245 my @args = (
    100          
109             ( defined $args )
110             ? ( ref $args eq ref [] )
111             ? @$args
112             : $args
113             : ()
114             );
115 54         242 return $class->$constructor(@args);
116             }
117             }
118              
119             sub instantiate_array {
120 73     73 1 3576 my $arrayref = shift;
121 73 50       226 return [] unless defined $arrayref;
122              
123             # delegates_to => "Class::Name" should be interpreted as delegates_to => ["Class::Name"]
124 73 100 100     367 $arrayref = [$arrayref] unless ref $arrayref and ref $arrayref eq ref [];
125 73         337 return [ map { instantiate $_ } @$arrayref ];
  106         4250  
126             }
127              
128             =head3 from_meta
129              
130             sub email_address { from_meta (shift, 'schema/user/email_address'); }
131              
132             This method uses Data::DPath to retrieve a field from the metadata structure.
133              
134             =cut
135              
136             sub from_meta {
137 0     0 1 0 my $structure = shift;
138 0         0 my $item = shift;
139 0         0 my @results = dpath( $item->meta )->match($structure);
140 0         0 return shift @results;
141             }
142              
143             =head3 dpath_get
144              
145             my $value = dpath_get($structure, '/path/in/structure');
146              
147             =cut
148              
149             sub dpath_get {
150 23     23 1 1856 my $structure = shift;
151 23         26 my $path = shift;
152 23         245 my @results = dpath($path)->match($structure);
153 23         5502 return shift @results;
154             }
155              
156             =head3 dpath_set
157              
158             dpath_set($structure, '/path/in/structure', $value);
159              
160             =cut
161              
162             sub dpath_set {
163 1     1 1 2 my $structure = shift;
164 1         1 my $path = shift;
165 1         4 my $value = shift;
166 1         5 my @results = dpathr($path)->match($structure);
167 1         232 map { $$_ = $value } @results;
  2         4  
168 1 50       6 return $value if @results;
169             }
170              
171             =head3 instantiate_selection
172              
173             # in config:
174              
175             rules:
176             default:
177             alias: main_schema
178             main_schema:
179             dsn: 'csv:main.csv'
180             utf8: 1
181              
182             has schemata =>
183             is => 'rw',
184             default => sub { {} },
185             coerce => sub { instantiate_selection @_ };
186              
187             Expects a hash. If any of the values are single-key hashes with the key 'alias' then the alias is resolved. Otherwise the value is instantiated.
188              
189             If a value other than a hash is given, returns a hash with the key 'default' and the original value instantiated.
190              
191             =cut
192              
193             sub instantiate_selection {
194 6     6 1 2549 my $orig = shift;
195 6         26 _instantiate_selection( $orig, \&instantiate );
196             }
197              
198             =head3 instantiate_array_selection
199              
200             rules:
201             default:
202             alias: two_rules
203             two_rules:
204             - Some::Rule
205             - Some::Other::Rule
206              
207             has rules =>
208             is => 'rw',
209             default => sub { {} },
210             coerce => sub { instantiate_array_selection @_ };
211              
212             Expects a hash. If any of the values are single-key hashes with the key 'alias' then the alias is resolved. Otherwise the value is instantiated as an array (see C).
213              
214             If a value other than a hash is given, returns a hash with the key 'default' and the original value instantiated as an array.
215              
216             =cut
217              
218             sub instantiate_array_selection {
219 2     2 1 2976 my $orig = shift;
220 2         6 _instantiate_selection( $orig, \&instantiate_array );
221             }
222              
223             sub _instantiate_selection {
224 8     8   101 my $orig = shift;
225 8         12 my $instantiate = shift;
226 8 100       33 if ( ref $orig eq ref {} ) {
227 6         18 for my $i ( 1 .. 5 ) {
228 30         261 foreach my $this ( keys %$orig ) {
229 250         16661 my $got = $orig->{$this};
230 250 100       338 if ( is_single_key_hash( $got, 'alias' ) ) {
231 10 100       27 $orig->{$this} = $orig->{ $got->{alias} } if $i > 1;
232             }
233             else {
234 240         296 $orig->{$this} = $instantiate->($got);
235             }
236             }
237             }
238 6         107 return $orig;
239             }
240             else {
241 2         4 return { default => $instantiate->($orig) };
242             }
243             }
244              
245             =head3 select_from
246              
247             # given this config:
248              
249             schemata:
250             default:
251             "[Complicated] configuration: can_be->[string, hash, whatever]"
252             schema_generic:
253             alias: default
254              
255             # if your class has
256             sub schema { select_from schemata => @_ }
257              
258             # then you can do
259             $self->schema;
260             $self->schema('default'); # same thing
261             $self->schema('schema_generic'); # same thing, because of alias
262             $self->schemata->{default}; # This is what they all do in practice
263              
264             Implements a user-friendly selection mechanism like the one implemented by C.
265              
266             =cut
267              
268             sub select_from {
269 0     0 1 0 my ( $attribute, $self, $which ) = @_;
270 0   0     0 $which //= 'default';
271 0         0 my $this = $which;
272 0         0 my $selectables = $self->$attribute;
273 0         0 for ( 1 .. 5 ) { # if more than this then you probably have recusion
274 0         0 my $got = $selectables->{$this};
275 0 0       0 if ( is_single_key_hash( $got, 'alias' ) ) {
276 0         0 $this = $got->{alias};
277 0         0 next;
278             }
279 0         0 return $got;
280             }
281             }
282              
283             =head3 is_single_key_hash
284              
285             is_single_key_hash ( { foo => 123 } ); # returns 1
286             is_single_key_hash ( { foo => 123 }, 'foo' ); # returns 1
287             is_single_key_hash ( { foo => 123 }, 'bar' ); # returns 0
288              
289             Returns 1 if the first argument is a hashref with exactly one key. If a second argument is provided, then the key, if it exists, must be equal to that argument, or the return value will be 0.
290              
291             =cut
292              
293             sub is_single_key_hash {
294 257     257 1 1617 my $got = shift;
295 257         226 my $key = shift;
296 257 100 100     1662 return 1
      100        
      100        
297             if (defined $key
298             and ref $got eq ref {}
299             and 1 == scalar keys %$got
300             and $key eq [ keys %$got ]->[0] );
301 246 100 100     532 return 1
      100        
302             if ( !defined $key and ref $got eq ref {} and 1 == scalar keys %$got );
303 245         469 return 0;
304             }
305              
306             =head3 hash_merge
307              
308             my $merged = hash_merge ($parent, $child)
309              
310             Returns a new hashref whose values represent a union of the parent's and the child's. The child's values overwrite the parent, in case of conflict. The merge is deep (i.e. it handles nested hashes), using L with right precedence.
311              
312             =cut
313              
314             my $hash_merger = Hash::Merge->new('RIGHT_PRECEDENT');
315              
316             sub hash_merge { # very naive, will change to something like Hash::Merge
317 0     0 1   my ( $parent, $child ) = @_;
318 0           return $hash_merger->merge( $parent, $child ); # todo: more
319             }
320              
321             1;