File Coverage

blib/lib/Articulate/Navigation.pm
Criterion Covered Total %
statement 37 40 92.5
branch 3 6 50.0
condition 1 3 33.3
subroutine 8 8 100.0
pod 3 3 100.0
total 52 60 86.6


line stmt bran cond sub pod time code
1             package Articulate::Navigation;
2 6     6   4578 use strict;
  6         10  
  6         200  
3 6     6   23 use warnings;
  6         13  
  6         124  
4              
5 6     6   22 use Moo;
  6         14  
  6         33  
6             with 'Articulate::Role::Component';
7              
8 6     6   1447 use Articulate::Location;
  6         11  
  6         47  
9 6     6   1835 use Articulate::LocationSpecification;
  6         13  
  6         33  
10              
11             =head1 NAME
12              
13             Articulate::Navigation - determine valid locations
14              
15             =head1 SYNOPSIS
16              
17             components:
18             navigation:
19             Articulate::Navigation:
20             locations:
21             - zone/*
22             - zone/*/article/*
23             - user/*
24             - []
25              
26             Provides validation for locations.
27              
28             =head1 ATTRIBUTE
29              
30             =head3 locations
31              
32             Any location specifications configured in the locations attribute are
33             valid locations for deposition and retrieval of items from storage.
34              
35             =cut
36              
37             has locations => (
38             is => 'rw', # rwp?
39             default => sub { [] },
40             coerce => sub {
41             my $orig = shift;
42             my $new = [];
43             foreach my $l ( @{$orig} ) {
44             push @$new, new_location_specification $l;
45             }
46             return $new;
47             },
48             );
49              
50             # A new_location_specification is like a location except it can contain "*": "/zone/*/article/"
51              
52             =head1 METHODS
53              
54             =cut
55              
56             =head3 valid_location
57              
58             do_something if $self->valid_location('zone/public')
59             do_something if $self->valid_location($location_object)
60              
61             Returns the location if valid (matches one of the locspecs in
62             C), undef otherwise.
63              
64             =cut
65              
66             sub valid_location {
67 81     81 1 4361 my $self = shift;
68 81         211 my $location = new_location shift;
69 81         1099 foreach my $defined_location ( @{ $self->locations } ) {
  81         1617  
70 149 100       1865 if ( $defined_location->matches($location) ) {
71 80         260 return $location;
72             }
73             }
74 1         9 return undef;
75             }
76              
77             =head3 define_locspec
78              
79             $self->define_locspec('zone/*')
80             $self->define_locspec($location_specification)
81              
82             Adds a new_location_specification to C, unless it is already
83             there
84              
85             =cut
86              
87             sub define_locspec {
88 1     1 1 1257 my $self = shift;
89 1         6 my $location = new_location_specification shift;
90 1         25 foreach my $defined_location ( @{ $self->locations } ) {
  1         19  
91 0 0       0 if ( ( $location eq $defined_location ) ) {
92 0         0 return undef;
93             }
94             }
95 1         6 push @{ $self->locations }, $location;
  1         15  
96             }
97              
98             =head3 undefine_locspec
99              
100             $self->undefine_locspec('zone/*')
101             $self->undefine_locspec($location_specification)
102              
103             Removes a new_location_specification from C.
104              
105             =cut
106              
107             sub undefine_locspec {
108 1     1 1 1 my $self = shift;
109 1         5 my $location = new_location_specification shift;
110 1         20 my ( $removed, $kept ) = ( [], [] );
111 1         1 foreach my $defined_location ( @{ $self->locations } ) {
  1         18  
112 1 50 33     8 if ( ( "$location" eq "$defined_location" )
113             or $defined_location->matches_descendant_of($location) )
114             {
115 1         4 push @$removed, $location;
116             }
117             else {
118 0         0 push @$kept, $location;
119             }
120             }
121 1         17 $self->locations($kept);
122 1         15 return $removed;
123             }
124              
125             =head1 SEE ALSO
126              
127             =over
128              
129             =item * L
130              
131             =item * L
132              
133             =back
134              
135             =cut
136              
137             1;