8 use SL::MoreCommon qw(uri_encode);
12 $yaml_xs = eval { require YAML::XS };
18 my ($package, $domain) = @_;
20 if (!$menu_cache{$domain}) {
21 my $path = File::Spec->catdir('menus', $domain);
23 opendir my $dir, $path or die "can't open $path: $!";
24 my @files = sort grep -f "$path/$_", grep /\.yaml$/, readdir $dir;
29 for my $file (@files) {
33 $data = YAML::XS::LoadFile(File::Spec->catfile($path, $file));
35 $data = YAML::LoadFile(File::Spec->catfile($path, $file));
39 die "Error while parsing $file: $@";
42 # check if this file is internally consistent.
43 die 'not an array ref' unless $data && 'ARRAY' eq ref $data; # TODO get better diag to user
45 # in particular duplicate ids tend to come up as a user error when editing the menu files
47 #$uniq_ids{$_->{id}}++ && die "Error in $file: duplicate id $_->{id}" for @$data;
49 _merge($nodes, $nodes_by_id, $data);
55 by_id => $nodes_by_id,
60 $menu_cache{$domain} = $self;
62 $menu_cache{$domain}->clear_access;
65 $menu_cache{$domain}->set_access;
67 return $menu_cache{$domain};
71 my ($nodes, $by_id, $data) = @_;
73 for my $node (@$data) {
76 my $merge_to = $by_id->{$id};
80 $by_id->{$id} = $node;
84 # TODO make this a real recursive merge
85 # TODO add support for arrays
87 # merge keys except params
88 for my $key (keys %$node) {
89 if (ref $node->{$key}) {
90 if ('HASH' eq ref $node->{$key}) {
91 $merge_to->{$key} = {} if !exists $merge_to->{$key} || 'HASH' ne ref $merge_to->{$key};
92 for (keys %{ $node->{params} }) {
93 $merge_to->{$key}{$_} = $node->{params}{$_};
96 die "unsupported structure @{[ ref $node->{$key} ]}";
99 $merge_to->{$key} = $node->{$key};
108 # first, some sanity check. are all parents valid ids or empty?
109 for my $node ($self->nodes) {
110 next if !exists $node->{parent} || !$node->{parent} || $self->{by_id}->{$node->{id}};
111 die "menu: node $node->{id} has non-existent parent $node->{parent}";
115 # order them by parent
116 for my $node ($self->nodes) {
117 push @{ $by_parent{ $node->{parent} // '' } //= [] }, $node;
121 $self->{by_id}{''} = $tree;
124 for (keys %by_parent) {
125 my $parent = $self->{by_id}{$_};
126 $parent->{children} = [ sort { $a->{order} <=> $b->{order} } @{ $by_parent{$_} } ];
129 _set_level_rec($tree->{children}, 0);
131 $self->{tree} = $tree->{children};
135 my ($ary_ref, $level) = @_;
138 $_->{level} = $level;
139 _set_level_rec($_->{children}, $level + 1) if $_->{children};
148 my ($self, $all) = @_;
150 _tree_walk_rec($self->{tree}, $all);
154 my ($ary_ref, $all) = @_;
155 map { $_->{children} ? ($_, _tree_walk_rec($_->{children}, $all)) : ($_) } grep { $all || $_->{visible} } @$ary_ref;
158 sub parse_access_string {
159 my ($self, $node) = @_;
164 push @stack, $cur_ary;
166 my $access = $node->{access};
168 while ($access =~ m/^([a-z_\/]+|\||\&|\(|\)|\s+)/) {
170 substr($access, 0, length($1)) = "";
172 next if ($token =~ /\s/);
175 my $new_cur_ary = [];
176 push @stack, $new_cur_ary;
177 push @{$cur_ary}, $new_cur_ary;
178 $cur_ary = $new_cur_ary;
180 } elsif ($token eq ")") {
183 die "Error while parsing menu entry $node->{id}: missing '('";
185 $cur_ary = $stack[-1];
187 } elsif (($token eq "|") || ($token eq "&")) {
188 push @{$cur_ary}, $token;
191 if ($token =~ m{^ client / (.*) }x) {
192 push @{$cur_ary}, $self->parse_instance_conf_string($1);
194 push @{$cur_ary}, $::auth->check_right($::myconfig{login}, $token, 1);
200 die "Error while parsing menu entry $node->{id}: unrecognized token at the start of '$access'\n";
203 if (1 < scalar @stack) {
204 die "Error while parsing menu entry $node->{id}: Missing ')'\n";
207 return SL::Auth::evaluate_rights_ary($stack[0]);
211 my ($self, $node) = @_;
213 return undef if !$node->{href} && !$node->{module} && !$node->{params};
215 my $href = $node->{href} || $node->{module} || 'controller.pl';
218 while (my ($key, $value) = each %{ $node->{params} }) {
219 push @tokens, uri_encode($key, 1) . "=" . uri_encode($value, 1);
222 return join '?', $href, grep $_, join '&', @tokens;
226 $::locale->text($_[1]{name})
229 sub parse_instance_conf_string {
230 my ($self, $setting) = @_;
231 return $::instance_conf->data->{$setting};
236 for my $node ($self->tree_walk("all")) {
237 delete $node->{visible};
238 delete $node->{visible_children};
244 # 1. evaluate access for all
245 # 2. if a menu has no visible children, its not visible either
247 for my $node (reverse $self->tree_walk("all")) {
248 $node->{visible} = $node->{access} ? $self->parse_access_string($node)
249 : !$node->{children} ? 1
250 : $node->{visible_children} ? 1
252 if ($node->{visible} && $node->{parent}) {
253 $self->{by_id}{ $node->{parent} }{visible_children} = 1;