File Coverage

blib/lib/Tree/Authz/Role.pm
Criterion Covered Total %
statement 21 58 36.2
branch 0 12 0.0
condition 0 12 0.0
subroutine 7 19 36.8
pod 8 8 100.0
total 36 109 33.0


line stmt bran cond sub pod time code
1             package Tree::Authz::Role;
2 1     1   4151 use strict;
  1         2  
  1         29  
3 1     1   5 use warnings;
  1         1  
  1         28  
4 1     1   5 use Carp;
  1         1  
  1         69  
5            
6 1     1   6 use overload '""' => 'name';
  1         1  
  1         5  
7            
8             # NOTE: if this class ever holds any more data than just its name, it
9             # should probably be a singleton
10            
11             =over
12            
13             =item new( $role, $authz_class )
14            
15             Represents a role.
16            
17             =cut
18            
19             # called by Tree::Authz::role
20             sub new {
21 0     0 1   my ($proto, $role, $authz_class) = @_;
22            
23 0           my $self = [ $role, $authz_class ];
24            
25 0   0       bless $self, ref( $proto ) || $proto;
26            
27             # $self->_init;
28            
29 0           return $self;
30             }
31            
32             =item name()
33            
34             Returns the name of this role.
35            
36             =item group_name()
37            
38             DEPRECATED.
39            
40             Use C instead.
41            
42             =cut
43            
44 0     0 1   sub name { $_[0]->[0] }
45            
46             =item authz
47            
48             Returns the L subclass used to instantiate this role.
49            
50             =cut
51            
52 0     0 1   sub authz { $_[0]->[1] }
53            
54             sub group_name {
55 0     0 1   carp "'group_name' is deprecated - use 'name' instead";
56 0           goto &name;
57             }
58            
59             =item list_roles
60            
61             Returns a list of roles inherited by this role, including this role.
62            
63             =cut
64            
65             sub list_roles {
66 0     0 1   my ($self) = @_;
67            
68 0           my @my_roles = grep { $self->can( $_ ) } $self->authz->list_roles;
  0            
69            
70 0 0         wantarray ? @my_roles : [ @my_roles ];
71             }
72            
73            
74             =item setup_permissions( $cando )
75            
76             Instance method.
77            
78             Adds methods to the class representing the role. I<$cando> is a single method
79             name, or arrayref of method names. No-op methods are added to the class
80             representing the group:
81            
82             my $spies = $authz->role( 'spies' );
83            
84             my $cando = [ qw( read_secret wear_disguise ) ];
85            
86             $spies->setup_permissions( $cando );
87            
88             if ( $spies->can( 'read_secret' ) ) {
89             warn 'Compromised!';
90             }
91            
92             warn 'Trust no-one' if $spies->can( 'wear_disguise' );
93            
94             =cut
95            
96             sub setup_permissions {
97 0     0 1   my ($self, $cando) = @_;
98            
99 0 0         croak( 'Nothing to permit' ) unless $cando;
100 0   0       my $class = ref( $self ) || croak( 'object method called on class name' );
101            
102 0           $class->_setup_perms( $cando );
103             }
104            
105             sub _setup_perms {
106 0     0     my ($class, $cando) = @_;
107            
108 0 0         my @permits = ref( $cando ) ? @$cando : ( $cando );
109            
110 1     1   394 no strict 'refs';
  1         2  
  1         217  
111 0           foreach my $permit ( @permits ) {
112 0     0     *{"${class}::$permit"} = sub {};
  0            
113             }
114             }
115            
116             =item setup_abilities( $name => $coderef, [ $name2 => $coderef2 ], ... )
117            
118             Instance method.
119            
120             Adds methods to the class representing the group. Keys give method names and
121             values are coderefs that will be installed as methods on the group class:
122            
123             my $spies = $authz->get_group( 'spies' );
124            
125             my %able = ( read_secret => sub {
126             my ($self, $file) = @_;
127             open( SECRET, $file );
128             local $/;
129             ;
130             },
131            
132             find_moles => sub { ... },
133            
134             );
135            
136             $spies->setup_abilities( %able );
137            
138             if ( $spies->can( 'read_secret' ) ) {
139             print $spies->read_secret( '/path/to/secret/file' );
140             }
141            
142             # or
143            
144             if ( my $read = $spies->can( 'read_secret' ) ) {
145             print $spies->$read( '/path/to/secret/file' );
146             }
147            
148             # with an unknown $group
149             my $get_secret = $group->can( 'read_secret' ) || # spy
150             $group->can( 'steal_document' ) || # mole
151             $group->can( 'create_secret' ) || # spymaster
152             $group->can( 'do_illicit_thing' ) || # politician
153             sub {}; # boring life
154            
155             my $secret = $group->$get_secret;
156            
157             =cut
158            
159             sub setup_abilities {
160 0     0 1   my ($self, %code) = @_;
161            
162 0 0         croak( 'Nothing to set up' ) unless %code;
163            
164 0   0       my $class = ref( $self ) || croak( 'object method called on class name' );
165            
166 0           $class->_setup_abil( %code );
167             }
168            
169             sub _setup_abil {
170 0     0     my ($class, %code) = @_;
171            
172 1     1   6 no strict 'refs';
  1         1  
  1         195  
173 0           foreach my $method ( keys %code ) {
174 0           *{"${class}::$method"} = $code{ $method };
  0            
175             }
176             }
177            
178             =item setup_plugins( $plugins )
179            
180             Instance method.
181            
182             Instead of adding a set of coderefs to a group's class, this method adds
183             a class to the C<@ISA> array of the group's class.
184            
185             package My::Spies;
186            
187             sub wear_disguise {}
188            
189             sub read_secret {
190             my ($self, $file) = @_;
191             open( SECRET, $file );
192             local $/;
193             ;
194             }
195            
196             package main;
197            
198             my $spies = $authz->get_group( 'spies' );
199            
200             $spies->setup_plugins( 'My::Spies' );
201            
202             if ( $spies->can( 'read_secret' ) ) {
203             warn 'Compromised!';
204             print $spies->read_secret( '/path/to/secret/file' );
205             }
206            
207             warn 'Trust no-one' if $spies->can( 'wear_disguise' );
208            
209             =back
210            
211             =cut
212            
213            
214             sub setup_plugins {
215 0     0 1   my ($self, $plugins) = @_;
216            
217 0 0         croak( 'Nothing to plug in' ) unless $plugins;
218            
219 0   0       my $class = ref( $self ) || croak( 'object method called on class name' );
220            
221 0           $class->_setup_plugins( $plugins );
222             }
223            
224             sub _setup_plugins {
225 0     0     my ($class, $plugins) = @_;
226            
227 0 0         my @plugins = ref( $plugins ) ? @$plugins : ( $plugins );
228            
229 1     1   7 no strict 'refs';
  1         1  
  1         82  
230            
231 0           push( @{"${class}::ISA"}, $_ ) for @plugins;
  0            
232             }
233            
234             1;
235