kivitendo/SL/Menu.pm @ cd306e61
| 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 YAML::XS ();
|
||
use File::Spec;
|
||||
use SL::MoreCommon qw(uri_encode);
|
||||
| c621a918 | Sven Schöling | |||
| d319704a | Moritz Bunkus | sub new {
|
||
| b251cc22 | Sven Schöling | my ($package, $domain) = @_;
|
||
| d319704a | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | my $path = File::Spec->catdir('menus', $domain);
|
||
| db53dc8a | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | opendir my $dir, $path or die "can't open $path: $!";
|
||
my @files = sort grep -f "$path/$_", readdir $dir;
|
||||
close $dir;
|
||||
| d319704a | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | my $nodes = [];
|
||
my $nodes_by_id = {};
|
||||
for my $file (@files) {
|
||||
my $data = YAML::XS::LoadFile(File::Spec->catfile($path, $file));
|
||||
_merge($nodes, $nodes_by_id, $data);
|
||||
| 63a8dae2 | Moritz Bunkus | }
|
||
| 8c7e4493 | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | my $self = bless {
|
||
nodes => $nodes,
|
||||
by_id => $nodes_by_id,
|
||||
}, $package;
|
||||
$self->build_tree;
|
||||
$self->set_access;
|
||||
| d319704a | Moritz Bunkus | |||
| 075f1eab | Sven Schöling | return $self;
|
||
| d319704a | Moritz Bunkus | }
|
||
| b251cc22 | Sven Schöling | sub _merge {
|
||
my ($nodes, $by_id, $data) = @_;
|
||||
| 32fa785e | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | die 'not an array ref' unless $data && 'ARRAY' eq ref $data; # TODO check this sooner, to get better diag to user
|
||
| 32fa785e | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | for my $node (@$data) {
|
||
my $id = $node->{id};
|
||||
| 32fa785e | Moritz Bunkus | |||
| 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}};
|
||||
die "menu: node $node->{id} has non-existant parent $node->{parent}";
|
||||
| 32fa785e | Moritz Bunkus | }
|
||
| b251cc22 | Sven Schöling | my %by_parent;
|
||
# order them by parent
|
||||
for my $node ($self->nodes) {
|
||||
push @{ $by_parent{ $node->{parent} } //= [] }, $node;
|
||||
}
|
||||
| 32fa785e | Moritz Bunkus | |||
| 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};
|
||
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) {
|
||||
| b251cc22 | Sven Schöling | die "Error in menu.ini for entry $node->{id}: missing '('";
|
||
| 8c7e4493 | Moritz Bunkus | }
|
||
$cur_ary = $stack[-1];
|
||||
} elsif (($token eq "|") || ($token eq "&")) {
|
||||
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) {
|
||||
| b251cc22 | Sven Schöling | die "Error in menu.ini for entry $node->{id}: unrecognized token at the start of '$access'\n";
|
||
| 8c7e4493 | Moritz Bunkus | }
|
||
if (1 < scalar @stack) {
|
||||
| b251cc22 | Sven Schöling | die "Error in menu.ini for 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 | |||
| b251cc22 | Sven Schöling | my $href = $node->{href} || $node->{module} || 'controller.pl';
|
||
my @tokens;
|
||||
| 8c7e4493 | Moritz Bunkus | |||
| b251cc22 | Sven Schöling | while (my ($key, $value) = each %{ $node->{params} }) {
|
||
push @tokens, uri_encode($key, 1) . "=" . uri_encode($value, 1);
|
||||
| 8c7e4493 | Moritz Bunkus | }
|
||
| b251cc22 | Sven Schöling | return join '?', $href, grep $_, join '&', @tokens;
|
||
}
|
||||
| 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 | }
|
||
| 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;
|