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