kivitendo/SL/Menu.pm @ 1b9d825f
| b251cc22 | Sven Schöling | package SL::Menu;
|
||
| d319704a | Moritz Bunkus | |||
| a7393349 | Sven Schöling | use strict;
|
||
| 8c7e4493 | Moritz Bunkus | use SL::Auth;
|
||
| b251cc22 | Sven Schöling | use File::Spec;
|
||
use SL::MoreCommon qw(uri_encode);
|
||||
| 65b2387a | Moritz Bunkus | use SL::YAML;
|
||
| fb974d9c | Sven Schöling | |||
| af0085b8 | Sven Schöling | our %menu_cache;
|
||
| d319704a | Moritz Bunkus | sub new {
|
||
| b251cc22 | Sven Schöling | my ($package, $domain) = @_;
|
||
| d319704a | Moritz Bunkus | |||
| af0085b8 | Sven Schöling | if (!$menu_cache{$domain}) {
|
||
my $path = File::Spec->catdir('menus', $domain);
|
||||
| db53dc8a | Moritz Bunkus | |||
| af0085b8 | Sven Schöling | opendir my $dir, $path or die "can't open $path: $!";
|
||
| b8db269c | Sven Schöling | my @files = sort grep -f "$path/$_", grep /\.yaml$/, readdir $dir;
|
||
| af0085b8 | Sven Schöling | close $dir;
|
||
| d319704a | Moritz Bunkus | |||
| af0085b8 | Sven Schöling | my $nodes = [];
|
||
my $nodes_by_id = {};
|
||||
for my $file (@files) {
|
||||
my $data;
|
||||
| b6865605 | Sven Schöling | eval {
|
||
| 65b2387a | Moritz Bunkus | $data = SL::YAML::LoadFile(File::Spec->catfile($path, $file));
|
||
| b6865605 | Sven Schöling | 1;
|
||
} or do {
|
||||
die "Error while parsing $file: $@";
|
||||
};
|
||||
# check if this file is internally consistent.
|
||||
die 'not an array ref' unless $data && 'ARRAY' eq ref $data; # TODO get better diag to user
|
||||
# in particular duplicate ids tend to come up as a user error when editing the menu files
|
||||
| 6f4fcf7b | Martin Helmling | #my %uniq_ids;
|
||
#$uniq_ids{$_->{id}}++ && die "Error in $file: duplicate id $_->{id}" for @$data;
|
||||
| b6865605 | Sven Schöling | |||
| af0085b8 | Sven Schöling | _merge($nodes, $nodes_by_id, $data);
|
||
| fb974d9c | Sven Schöling | }
|
||
| 63a8dae2 | Moritz Bunkus | |||
| 8c7e4493 | Moritz Bunkus | |||
| af0085b8 | Sven Schöling | my $self = bless {
|
||
nodes => $nodes,
|
||||
by_id => $nodes_by_id,
|
||||
}, $package;
|
||||
$self->build_tree;
|
||||
| b251cc22 | Sven Schöling | |||
| af0085b8 | Sven Schöling | $menu_cache{$domain} = $self;
|
||
} else {
|
||||
$menu_cache{$domain}->clear_access;
|
||||
}
|
||||
$menu_cache{$domain}->set_access;
|
||||
| d319704a | Moritz Bunkus | |||
| af0085b8 | Sven Schöling | return $menu_cache{$domain};
|
||
| d319704a | Moritz Bunkus | }
|
||
| b251cc22 | Sven Schöling | sub _merge {
|
||
my ($nodes, $by_id, $data) = @_;
|
||||
| 32fa785e | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | for my $node (@$data) {
|
||
my $id = $node->{id};
|
||||
| 32fa785e | Moritz Bunkus | |||
| c3459448 | Sven Schöling | die "menu: node with name '$node->{name}' does not have an id" if !$id;
|
||
| b251cc22 | Sven Schöling | my $merge_to = $by_id->{$id};
|
||
| 32fa785e | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | if (!$merge_to) {
|
||
push @$nodes, $node;
|
||||
$by_id->{$id} = $node;
|
||||
next;
|
||||
}
|
||||
| 32fa785e | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | # TODO make this a real recursive merge
|
||
# TODO add support for arrays
|
||||
# merge keys except params
|
||||
for my $key (keys %$node) {
|
||||
if (ref $node->{$key}) {
|
||||
if ('HASH' eq ref $node->{$key}) {
|
||||
$merge_to->{$key} = {} if !exists $merge_to->{$key} || 'HASH' ne ref $merge_to->{$key};
|
||||
for (keys %{ $node->{params} }) {
|
||||
$merge_to->{$key}{$_} = $node->{params}{$_};
|
||||
}
|
||||
} else {
|
||||
die "unsupported structure @{[ ref $node->{$key} ]}";
|
||||
}
|
||||
} else {
|
||||
$merge_to->{$key} = $node->{$key};
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
| 32fa785e | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | sub build_tree {
|
||
my ($self) = @_;
|
||||
# first, some sanity check. are all parents valid ids or empty?
|
||||
for my $node ($self->nodes) {
|
||||
next if !exists $node->{parent} || !$node->{parent} || $self->{by_id}->{$node->{id}};
|
||||
| bf7f935d | Sven Schöling | die "menu: node $node->{id} has non-existent parent $node->{parent}";
|
||
| 32fa785e | Moritz Bunkus | }
|
||
| b251cc22 | Sven Schöling | my %by_parent;
|
||
# order them by parent
|
||||
for my $node ($self->nodes) {
|
||||
| 8f3e8a02 | Moritz Bunkus | push @{ $by_parent{ $node->{parent} // '' } //= [] }, $node;
|
||
| b251cc22 | Sven Schöling | }
|
||
| 32fa785e | Moritz Bunkus | |||
| 37df271b | Sven Schöling | # autovivify order in by_parent, so that numerical sorting for entries without order
|
||
# preserves their order and position with respect to entries with order.
|
||||
for (values %by_parent) {
|
||||
my $last_order = 0;
|
||||
for my $node (@$_) {
|
||||
if (defined $node->{order} && $node->{order} * 1) {
|
||||
$last_order = $node->{order};
|
||||
} else {
|
||||
$node->{order} = ++$last_order;
|
||||
}
|
||||
}
|
||||
}
|
||||
| b251cc22 | Sven Schöling | my $tree = { };
|
||
$self->{by_id}{''} = $tree;
|
||||
| d319704a | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | for (keys %by_parent) {
|
||
my $parent = $self->{by_id}{$_};
|
||||
$parent->{children} = [ sort { $a->{order} <=> $b->{order} } @{ $by_parent{$_} } ];
|
||||
}
|
||||
_set_level_rec($tree->{children}, 0);
|
||||
$self->{tree} = $tree->{children};
|
||||
}
|
||||
sub _set_level_rec {
|
||||
my ($ary_ref, $level) = @_;
|
||||
| d319704a | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | for (@$ary_ref) {
|
||
$_->{level} = $level;
|
||||
_set_level_rec($_->{children}, $level + 1) if $_->{children};
|
||||
| d319704a | Moritz Bunkus | }
|
||
| b251cc22 | Sven Schöling | }
|
||
| d319704a | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | sub nodes {
|
||
@{ $_[0]{nodes} }
|
||||
}
|
||||
sub tree_walk {
|
||||
my ($self, $all) = @_;
|
||||
| d319704a | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | _tree_walk_rec($self->{tree}, $all);
|
||
| ff7976ff | Moritz Bunkus | }
|
||
| b251cc22 | Sven Schöling | sub _tree_walk_rec {
|
||
my ($ary_ref, $all) = @_;
|
||||
map { $_->{children} ? ($_, _tree_walk_rec($_->{children}, $all)) : ($_) } grep { $all || $_->{visible} } @$ary_ref;
|
||||
}
|
||||
| 8c7e4493 | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | sub parse_access_string {
|
||
my ($self, $node) = @_;
|
||||
| c621a918 | Sven Schöling | |||
| 8c7e4493 | Moritz Bunkus | my @stack;
|
||
my $cur_ary = [];
|
||||
push @stack, $cur_ary;
|
||||
| b251cc22 | Sven Schöling | my $access = $node->{access};
|
||
| 471d166b | Bernd Bleßmann | while ($access =~ m/^([a-z_\/]+|\!|\||\&|\(|\)|\s+)/) {
|
||
| 8c7e4493 | Moritz Bunkus | my $token = $1;
|
||
substr($access, 0, length($1)) = "";
|
||||
next if ($token =~ /\s/);
|
||||
if ($token eq "(") {
|
||||
my $new_cur_ary = [];
|
||||
push @stack, $new_cur_ary;
|
||||
push @{$cur_ary}, $new_cur_ary;
|
||||
$cur_ary = $new_cur_ary;
|
||||
} elsif ($token eq ")") {
|
||||
pop @stack;
|
||||
if (!@stack) {
|
||||
| 92770ef6 | Sven Schöling | die "Error while parsing menu entry $node->{id}: missing '('";
|
||
| 8c7e4493 | Moritz Bunkus | }
|
||
$cur_ary = $stack[-1];
|
||||
| 471d166b | Bernd Bleßmann | } elsif (($token eq "|") || ($token eq "&") || ($token eq "!")) {
|
||
| 8c7e4493 | Moritz Bunkus | push @{$cur_ary}, $token;
|
||
} else {
|
||||
| b251cc22 | Sven Schöling | if ($token =~ m{^ client / (.*) }x) {
|
||
push @{$cur_ary}, $self->parse_instance_conf_string($1);
|
||||
} else {
|
||||
push @{$cur_ary}, $::auth->check_right($::myconfig{login}, $token, 1);
|
||||
}
|
||||
| 8c7e4493 | Moritz Bunkus | }
|
||
}
|
||||
if ($access) {
|
||||
| 92770ef6 | Sven Schöling | die "Error while parsing menu entry $node->{id}: unrecognized token at the start of '$access'\n";
|
||
| 8c7e4493 | Moritz Bunkus | }
|
||
if (1 < scalar @stack) {
|
||||
| 92770ef6 | Sven Schöling | die "Error while parsing menu entry $node->{id}: Missing ')'\n";
|
||
| 8c7e4493 | Moritz Bunkus | }
|
||
return SL::Auth::evaluate_rights_ary($stack[0]);
|
||||
}
|
||||
| b251cc22 | Sven Schöling | sub href_for_node {
|
||
my ($self, $node) = @_;
|
||||
| 8c7e4493 | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | return undef if !$node->{href} && !$node->{module} && !$node->{params};
|
||
| 8c7e4493 | Moritz Bunkus | |||
| 02497699 | Sven Schöling | return $node->{href_for_node} ||= do {
|
||
my $href = $node->{href} || $node->{module} || 'controller.pl';
|
||||
my @tokens;
|
||||
| 8c7e4493 | Moritz Bunkus | |||
| 02497699 | Sven Schöling | while (my ($key, $value) = each %{ $node->{params} }) {
|
||
push @tokens, uri_encode($key, 1) . "=" . uri_encode($value, 1);
|
||||
}
|
||||
| 8c7e4493 | Moritz Bunkus | |||
| 02497699 | Sven Schöling | join '?', $href, grep $_, join '&', @tokens;
|
||
}
|
||||
| b251cc22 | Sven Schöling | }
|
||
| 8c7e4493 | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | sub name_for_node {
|
||
$::locale->text($_[1]{name})
|
||||
}
|
||||
| 8c7e4493 | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | sub parse_instance_conf_string {
|
||
my ($self, $setting) = @_;
|
||||
return $::instance_conf->data->{$setting};
|
||||
| 8c7e4493 | Moritz Bunkus | }
|
||
| af0085b8 | Sven Schöling | sub clear_access {
|
||
my ($self) = @_;
|
||||
for my $node ($self->tree_walk("all")) {
|
||||
delete $node->{visible};
|
||||
delete $node->{visible_children};
|
||||
}
|
||||
}
|
||||
| b251cc22 | Sven Schöling | sub set_access {
|
||
my ($self) = @_;
|
||||
# 1. evaluate access for all
|
||||
# 2. if a menu has no visible children, its not visible either
|
||||
for my $node (reverse $self->tree_walk("all")) {
|
||||
$node->{visible} = $node->{access} ? $self->parse_access_string($node)
|
||||
: !$node->{children} ? 1
|
||||
: $node->{visible_children} ? 1
|
||||
: 0;
|
||||
if ($node->{visible} && $node->{parent}) {
|
||||
$self->{by_id}{ $node->{parent} }{visible_children} = 1;
|
||||
}
|
||||
| 8c7e4493 | Moritz Bunkus | }
|
||
}
|
||||
| d319704a | Moritz Bunkus | 1;
|