File Coverage

blib/lib/MVC/Neaf/Util/Container.pm
Criterion Covered Total %
statement 88 88 100.0
branch 28 32 87.5
condition 22 28 78.5
subroutine 12 12 100.0
pod 7 7 100.0
total 157 167 94.0


line stmt bran cond sub pod time code
1             package MVC::Neaf::Util::Container;
2              
3 82     82   68008 use strict;
  82         188  
  82         2462  
4 82     82   438 use warnings;
  82         173  
  82         3611  
5             our $VERSION = '0.2901';
6              
7             =head1 NAME
8              
9             MVC::Neaf::Util::Container - path & method based container for Not Even A Framework
10              
11             =head1 DESCRIPTION
12              
13             This is utility class.
14             Nothing to see here unless one intends to work on L itself.
15              
16             This class can hold multiple entities addressed by paths and methods
17             and extract them in the needed order.
18              
19             =head1 SYNOPSIS
20              
21             my $c = MVC::Neaf::Util::Container->new;
22              
23             $c->store( "foo", path => '/foo', method => 'GET' );
24             $c->store( "bar", path => '/foo/bar', exclude => '/foo/bar/baz' );
25              
26             $c->fetch( path => "/foo", method => 'GET' ); # foo
27             $c->fetch( path => "/foo/bar", method => 'GET' ); # foo bar
28             $c->fetch( path => "/foo/bar", method => 'POST' );
29             # qw(bar) - 'foo' limited to GET only
30             $c->fetch( path => "/foo/bar/baz", method => 'GET' );
31             # qw(foo) - 'bar' excluded
32              
33             =cut
34              
35 82     82   505 use Carp;
  82         183  
  82         4747  
36              
37 82     82   981 use parent qw(MVC::Neaf::Util::Base);
  82         490  
  82         513  
38 82     82   6915 use MVC::Neaf::Util qw( maybe_list canonize_path path_prefixes supported_methods check_path );
  82         234  
  82         92204  
39             our @CARP_NOT = qw(MVC::Neaf::Route);
40              
41             =head1 ATTRIBUTES
42              
43             =head2 exclusive
44              
45             Only store one item per (path,method) pair, and fail loudly in case of conflicts.
46              
47             =head1 METHODS
48              
49             =head2 store
50              
51             store( $data, %spec )
52              
53             Store $data in container. Spec may include:
54              
55             =over
56              
57             =item path - single path or list of paths, '/' assumed if none.
58              
59             =item method - name of method or array of methods.
60             By default, all methods supported by Neaf.
61              
62             =item exclude - single path or list of paths. None by default.
63              
64             =item prepend - if true, prepend to the list instead of appending.
65              
66             =item tentative (exclusive container only) - if true, don't override existing
67             declarations, and don't complain when overridden.
68              
69             =item override (exclusive container only) - if true, override
70             any preexisting content.
71              
72             =back
73              
74             =cut
75              
76             sub store {
77 165     165 1 548 my ($self, $data, %opt) = @_;
78              
79             $self->my_croak( "'tentative' and 'override' are useless for non-exclusive container" )
80 165 50 33     1400 if !$self->{exclusive} and ( $opt{tentative} or $opt{override} );
      66        
81              
82             $self->my_croak( "'tentative' and 'override' are mutually exclusive" )
83 165 50 66     565 if $opt{tentative} and $opt{override};
84              
85 165         432 $opt{data} = $data;
86              
87 165         879 my @methods = map { uc $_ } maybe_list( $opt{method}, supported_methods() );
  967         2137  
88              
89 165         1632 my @todo = check_path map { canonize_path( $_ ) } maybe_list( $opt{path}, '' );
  169         711  
90 165 100       717 if ($opt{exclude}) {
91 3         11 my $rex = join '|', map { quotemeta(canonize_path($_)) }
92 3         20 check_path maybe_list( $opt{exclude} );
93 3         82 $opt{exclude} = qr(^(?:$rex)(?:[/?]|$));
94 3         19 @todo = grep { $_ !~ $opt{exclude} } @todo
  3         17  
95             };
96              
97 165 100       583 if ($self->{exclusive}) {
98 19         118 my @list = $self->store_check_conflict( %opt, method => \@methods, path => \@todo );
99 19 100       78 $self->my_croak( "Conflicting path spec: ".join ", ", @list )
100             if @list;
101             };
102              
103 164         437 foreach my $method ( @methods ) {
104 965         1617 foreach my $path ( @todo ) {
105 979   100     7834 my $array = $self->{data}{$method}{$path} ||= [];
106 979 100       4954 if ( $self->{exclusive} ) {
    100          
107             @$array = (\%opt)
108 113 100 100     352 unless $array->[0] and $opt{tentative} and !$array->[0]{tentative};
      66        
109             } elsif ( $opt{prepend} ) {
110 12         25 unshift @$array, \%opt;
111             } else {
112 854         2170 push @$array, \%opt;
113             };
114             };
115             };
116              
117 164         618 $self;
118             };
119              
120             =head2 store_check_conflict
121              
122             store_check_conflict( path => ..., method => ... )
123              
124             Check that no previous declarations conflict with the new one.
125              
126             This is only if exclusive was specified.
127              
128             =cut
129              
130             sub store_check_conflict {
131 19     19 1 96 my ($self, %opt) = @_;
132              
133             $self->my_croak( "useless call for non-exclusive container" )
134 19 50       111 unless $self->{exclusive};
135              
136 19 100 100     118 if (!$opt{tentative} and !$opt{override}) {
137             # Check for conflicts before changing anything
138 12         23 my %conflict;
139 12         27 foreach my $method ( @{ $opt{method} } ) {
  12         37  
140 64         82 foreach my $path ( @{ $opt{path} } ) {
  64         107  
141 68         125 my $existing = $self->{data}{$method}{$path};
142 68 100 66     168 next unless $existing && $existing->[0];
143 7 100       18 next if $existing->[0]->{tentative};
144 1         3 push @{ $conflict{$path} }, $method;
  1         3  
145             };
146             };
147              
148             my @list =
149 12         45 map { $_."[".(join ",", sort @{ $conflict{$_} })."]" }
  1         2  
  1         5  
150             sort keys %conflict;
151 12         43 return @list;
152             };
153              
154 7         23 return ();
155             };
156              
157             =head2 list_methods
158              
159             Returns methods currently in the storage.
160              
161             =cut
162              
163             sub list_methods {
164 3     3 1 8 my $self = shift;
165              
166 3         15 return keys %{ $self->{data} };
  3         29  
167             };
168              
169             =head2 list_paths
170              
171             Returns paths for given method, or all if no method given.
172              
173             =cut
174              
175             sub list_paths {
176 2     2 1 6 my ($self, @methods) = @_;
177              
178 2 100       14 @methods = $self->list_methods
179             unless @methods;
180              
181 2         4 my %uniq;
182 2         6 foreach my $method (@methods) {
183 8         9 $uniq{$_}++ for keys %{ $self->{data}{$method} };
  8         43  
184             };
185 2         22 return keys %uniq;
186             };
187              
188             =head2 fetch
189              
190             fetch( %spec )
191              
192             Return all matching previously stored objects,
193             from shorter to longer paths, in order of addition.
194              
195             Spec may include:
196              
197             =over
198              
199             =item path - a single path to match against
200              
201             =item method - method to match against
202              
203             =back
204              
205             =cut
206              
207             sub fetch {
208 292     292 1 1764 my $self = shift;
209 292         790 return map { $_->{data} } $self->fetch_raw(@_);
  339         1311  
210             };
211              
212             =head2 fetch_last
213              
214             Same as fetch(), but only return the last (last added & longest path) element.
215              
216             =cut
217              
218             sub fetch_last {
219 10     10 1 92 my $self = shift;
220 10         34 my ($bucket) = reverse $self->fetch_raw(@_);
221 10         49 return $bucket->{data};
222             };
223              
224             =head2 fetch_raw
225              
226             Same as fetch(), but return additional info instead of just stored item:
227              
228             {
229             data => $your_item_here,
230             path => $all_the_paths,
231             method => $list_of_methods,
232             ...
233             }
234              
235             =cut
236              
237             sub fetch_raw {
238 302     302 1 1039 my ($self, %opt) = @_;
239              
240 302         717 my @missing = grep { !defined $opt{$_} } qw(path method);
  604         1677  
241 302 50       871 croak __PACKAGE__."->fetch: required fields missing: @missing"
242             if @missing;
243              
244 302         906 my $path = canonize_path( $opt{path} );
245              
246 302         527 my @ret;
247 302         975 my $tree = $self->{data}{ $opt{method} };
248              
249 302   100     1242 foreach my $prefix ( path_prefixes( $opt{path} || '' ) ) {
250 560         1015 my $list = $tree->{$prefix};
251 560 100       1272 next unless $list;
252 320         728 foreach my $node( @$list ) {
253 353 100 100     1043 next if $node->{exclude} and $opt{path} =~ $node->{exclude};
254 348         789 push @ret, $node;
255             };
256             };
257              
258 302         1022 return @ret;
259             };
260              
261             =head1 LICENSE AND COPYRIGHT
262              
263             This module is part of L suite.
264              
265             Copyright 2016-2023 Konstantin S. Uvarin C.
266              
267             This program is free software; you can redistribute it and/or modify it
268             under the terms of either: the GNU General Public License as published
269             by the Free Software Foundation; or the Artistic License.
270              
271             See L for more information.
272              
273             =cut
274              
275             1;