DBConnect Caching: rollback nur bei Handles ohne AutoCommit
[kivitendo-erp.git] / SL / Menu.pm
1 package SL::Menu;
2
3 use strict;
4
5 use SL::Auth;
6 use YAML ();
7 use File::Spec;
8 use SL::MoreCommon qw(uri_encode);
9
10 our $yaml_xs;
11 BEGIN {
12    $yaml_xs =  eval { require YAML::XS };
13 }
14
15 our %menu_cache;
16
17 sub new {
18   my ($package, $domain) = @_;
19
20   if (!$menu_cache{$domain}) {
21     my $path = File::Spec->catdir('menus', $domain);
22
23     opendir my $dir, $path or die "can't open $path: $!";
24     my @files = sort grep -f "$path/$_", grep /\.yaml$/, readdir $dir;
25     close $dir;
26
27     my $nodes = [];
28     my $nodes_by_id = {};
29     for my $file (@files) {
30       my $data;
31       if ($yaml_xs) {
32         $data = YAML::XS::LoadFile(File::Spec->catfile($path, $file));
33       } else {
34         $data = YAML::LoadFile(File::Spec->catfile($path, $file));
35       }
36       _merge($nodes, $nodes_by_id, $data);
37     }
38
39
40     my $self = bless {
41       nodes => $nodes,
42       by_id => $nodes_by_id,
43     }, $package;
44
45     $self->build_tree;
46
47     $menu_cache{$domain} = $self;
48   } else {
49     $menu_cache{$domain}->clear_access;
50   }
51
52   $menu_cache{$domain}->set_access;
53
54   return $menu_cache{$domain};
55 }
56
57 sub _merge {
58   my ($nodes, $by_id, $data) = @_;
59
60   die 'not an array ref' unless $data && 'ARRAY' eq ref $data; # TODO check this sooner, to get better diag to user
61
62   for my $node (@$data) {
63     my $id = $node->{id};
64
65     my $merge_to = $by_id->{$id};
66
67     if (!$merge_to) {
68       push @$nodes, $node;
69       $by_id->{$id} = $node;
70       next;
71     }
72
73     # TODO make this a real recursive merge
74     # TODO add support for arrays
75
76     # merge keys except params
77     for my $key (keys %$node) {
78       if (ref $node->{$key}) {
79         if ('HASH' eq ref $node->{$key}) {
80           $merge_to->{$key} = {} if !exists $merge_to->{$key} || 'HASH' ne ref $merge_to->{$key};
81           for (keys %{ $node->{params} }) {
82             $merge_to->{$key}{$_} = $node->{params}{$_};
83           }
84         } else {
85           die "unsupported structure @{[ ref $node->{$key} ]}";
86         }
87       } else {
88         $merge_to->{$key} = $node->{$key};
89       }
90     }
91   }
92 }
93
94 sub build_tree {
95   my ($self) = @_;
96
97   # first, some sanity check. are all parents valid ids or empty?
98   for my $node ($self->nodes) {
99     next if !exists $node->{parent} || !$node->{parent} || $self->{by_id}->{$node->{id}};
100     die "menu: node $node->{id} has non-existent parent $node->{parent}";
101   }
102
103   my %by_parent;
104   # order them by parent
105   for my $node ($self->nodes) {
106     push @{ $by_parent{ $node->{parent} } //= [] }, $node;
107   }
108
109   my $tree = { };
110   $self->{by_id}{''} = $tree;
111
112
113   for (keys %by_parent) {
114     my $parent = $self->{by_id}{$_};
115     $parent->{children} =  [ sort { $a->{order} <=> $b->{order} } @{ $by_parent{$_} } ];
116   }
117
118   _set_level_rec($tree->{children}, 0);
119
120   $self->{tree} = $tree->{children};
121 }
122
123 sub _set_level_rec {
124   my ($ary_ref, $level) = @_;
125
126   for (@$ary_ref) {
127     $_->{level} = $level;
128     _set_level_rec($_->{children}, $level + 1) if $_->{children};
129   }
130 }
131
132 sub nodes {
133   @{ $_[0]{nodes} }
134 }
135
136 sub tree_walk {
137   my ($self, $all) = @_;
138
139   _tree_walk_rec($self->{tree}, $all);
140 }
141
142 sub _tree_walk_rec {
143   my ($ary_ref, $all) = @_;
144   map { $_->{children} ? ($_, _tree_walk_rec($_->{children}, $all)) : ($_) } grep { $all || $_->{visible} } @$ary_ref;
145 }
146
147 sub parse_access_string {
148   my ($self, $node) = @_;
149
150   my @stack;
151   my $cur_ary = [];
152
153   push @stack, $cur_ary;
154
155   my $access = $node->{access};
156
157   while ($access =~ m/^([a-z_\/]+|\||\&|\(|\)|\s+)/) {
158     my $token = $1;
159     substr($access, 0, length($1)) = "";
160
161     next if ($token =~ /\s/);
162
163     if ($token eq "(") {
164       my $new_cur_ary = [];
165       push @stack, $new_cur_ary;
166       push @{$cur_ary}, $new_cur_ary;
167       $cur_ary = $new_cur_ary;
168
169     } elsif ($token eq ")") {
170       pop @stack;
171       if (!@stack) {
172         die "Error while parsing menu entry $node->{id}: missing '('";
173       }
174       $cur_ary = $stack[-1];
175
176     } elsif (($token eq "|") || ($token eq "&")) {
177       push @{$cur_ary}, $token;
178
179     } else {
180       if ($token =~ m{^ client / (.*) }x) {
181         push @{$cur_ary}, $self->parse_instance_conf_string($1);
182       } else {
183         push @{$cur_ary}, $::auth->check_right($::myconfig{login}, $token, 1);
184       }
185     }
186   }
187
188   if ($access) {
189     die "Error while parsing menu entry $node->{id}: unrecognized token at the start of '$access'\n";
190   }
191
192   if (1 < scalar @stack) {
193     die "Error while parsing menu entry $node->{id}: Missing ')'\n";
194   }
195
196   return SL::Auth::evaluate_rights_ary($stack[0]);
197 }
198
199 sub href_for_node {
200   my ($self, $node) = @_;
201
202   return undef if !$node->{href} && !$node->{module} && !$node->{params};
203
204   my $href = $node->{href} || $node->{module} || 'controller.pl';
205   my @tokens;
206
207   while (my ($key, $value) = each %{ $node->{params} }) {
208     push @tokens, uri_encode($key, 1) . "=" . uri_encode($value, 1);
209   }
210
211   return join '?', $href, grep $_, join '&', @tokens;
212 }
213
214 sub name_for_node {
215   $::locale->text($_[1]{name})
216 }
217
218 sub parse_instance_conf_string {
219   my ($self, $setting) = @_;
220   return $::instance_conf->data->{$setting};
221 }
222
223 sub clear_access {
224   my ($self) = @_;
225   for my $node ($self->tree_walk("all")) {
226     delete $node->{visible};
227     delete $node->{visible_children};
228   }
229 }
230
231 sub set_access {
232   my ($self) = @_;
233   # 1. evaluate access for all
234   # 2. if a menu has no visible children, its not visible either
235
236   for my $node (reverse $self->tree_walk("all")) {
237     $node->{visible} = $node->{access}           ? $self->parse_access_string($node)
238                      : !$node->{children}        ? 1
239                      : $node->{visible_children} ? 1
240                      :                             0;
241     if ($node->{visible} && $node->{parent}) {
242       $self->{by_id}{ $node->{parent} }{visible_children} = 1;
243     }
244   }
245 }
246
247 1;
248