|
412
|
1 package IMPL::Config::Hierarchy;
|
|
|
2 use strict;
|
|
|
3
|
|
|
4 use IMPL::Exception();
|
|
|
5 use IMPL::lang qw(:base);
|
|
|
6 use IMPL::clone;
|
|
|
7 use IMPL::declare {
|
|
|
8 base => {
|
|
|
9 'IMPL::Object' => undef
|
|
|
10 },
|
|
415
|
11 props => [
|
|
412
|
12 roles => '*rw',
|
|
|
13 _cache => '*rw'
|
|
415
|
14 ]
|
|
412
|
15 };
|
|
|
16
|
|
|
17 sub CTOR {
|
|
|
18 my ( $this, $roles ) = @_;
|
|
|
19
|
|
|
20 if ( is( $roles, SELF ) ) {
|
|
|
21 $this->roles( clone( $roles->roles ) );
|
|
|
22 }
|
|
|
23 elsif ( ishash($roles) ) {
|
|
415
|
24 $this->roles({});
|
|
|
25 while(my ($n, $p) = each %$roles) {
|
|
|
26 $this->AddRole($n,$p);
|
|
|
27 }
|
|
412
|
28 }
|
|
|
29 elsif ( isarray($roles) ) {
|
|
415
|
30 $this->roles( { map { $_, undef } @$roles } );
|
|
412
|
31 }
|
|
|
32 else {
|
|
|
33 $this->roles( {} );
|
|
|
34 }
|
|
|
35 }
|
|
|
36
|
|
|
37 sub AddRole {
|
|
|
38 my ( $this, $role, $parent ) = @_;
|
|
|
39
|
|
|
40 $parent = isarray($parent) ? $parent : [$parent]
|
|
|
41 if $parent;
|
|
|
42
|
|
|
43 die IMPL::InvalidArgumentException->new('role') unless $role;
|
|
|
44
|
|
|
45 $this->roles->{$role} = $parent;
|
|
|
46 }
|
|
|
47
|
|
|
48 sub GetLinearRoleHash {
|
|
|
49 my ( $this, $role ) = @_;
|
|
|
50
|
|
|
51 return [] unless $role;
|
|
|
52
|
|
|
53 my $cache = $this->{$_cache}{$role};
|
|
|
54
|
|
|
55 unless ($cache) {
|
|
414
|
56 $cache = { $role, 1 };
|
|
412
|
57
|
|
415
|
58 my @roles = ([$role, 1]);
|
|
413
|
59
|
|
412
|
60 while (my $r = shift @roles ) {
|
|
413
|
61 my ($name, $level) = @$r;
|
|
|
62
|
|
|
63 $cache->{$name} = $level;
|
|
|
64 if(my $parents = $this->{$roles}{$name}) {
|
|
|
65 foreach my $p (@$parents) {
|
|
415
|
66 next if $cache->{$p};
|
|
|
67 push @roles, [$p, $cache->{$p} = $level + 1];
|
|
413
|
68 }
|
|
412
|
69 }
|
|
|
70 }
|
|
|
71 $this->{$_cache}{$role} = $cache;
|
|
|
72 }
|
|
|
73
|
|
|
74 return $cache;
|
|
|
75 }
|
|
|
76
|
|
|
77 1;
|
