Revision b251cc22
Von Sven Schöling vor mehr als 9 Jahren hinzugefügt
| SL/Menu.pm | ||
|---|---|---|
| 1 |
#===================================================================== |
|
| 2 |
# LX-Office ERP |
|
| 3 |
# Copyright (C) 2004 |
|
| 4 |
# Based on SQL-Ledger Version 2.1.9 |
|
| 5 |
# Web http://www.lx-office.org |
|
| 6 |
# |
|
| 7 |
#===================================================================== |
|
| 8 |
# SQL-Ledger Accounting |
|
| 9 |
# Copyright (C) 2001 |
|
| 10 |
# |
|
| 11 |
# Author: Dieter Simader |
|
| 12 |
# Email: dsimader@sql-ledger.org |
|
| 13 |
# Web: http://www.sql-ledger.org |
|
| 14 |
# |
|
| 15 |
# Contributors: |
|
| 16 |
# |
|
| 17 |
# This program is free software; you can redistribute it and/or modify |
|
| 18 |
# it under the terms of the GNU General Public License as published by |
|
| 19 |
# the Free Software Foundation; either version 2 of the License, or |
|
| 20 |
# (at your option) any later version. |
|
| 21 |
# |
|
| 22 |
# This program is distributed in the hope that it will be useful, |
|
| 23 |
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
| 24 |
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
| 25 |
# GNU General Public License for more details. |
|
| 26 |
# You should have received a copy of the GNU General Public License |
|
| 27 |
# along with this program; if not, write to the Free Software |
|
| 28 |
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. |
|
| 29 |
#===================================================================== |
|
| 30 |
# |
|
| 31 |
# routines for menu items |
|
| 32 |
# |
|
| 33 |
#===================================================================== |
|
| 34 |
|
|
| 35 |
package Menu; |
|
| 1 |
package SL::Menu; |
|
| 36 | 2 |
|
| 37 | 3 |
use strict; |
| 38 | 4 |
|
| 39 | 5 |
use SL::Auth; |
| 40 |
use SL::Inifile; |
|
| 41 |
|
|
| 42 |
our @ISA = qw(Inifile); |
|
| 43 |
|
|
| 6 |
use YAML::XS (); |
|
| 7 |
use File::Spec; |
|
| 8 |
use SL::MoreCommon qw(uri_encode); |
|
| 44 | 9 |
|
| 45 | 10 |
sub new {
|
| 46 |
$main::lxdebug->enter_sub();
|
|
| 11 |
my ($package, $domain) = @_;
|
|
| 47 | 12 |
|
| 48 |
my ($package, @menufiles) = @_;
|
|
| 13 |
my $path = File::Spec->catdir('menus', $domain);
|
|
| 49 | 14 |
|
| 50 |
my $self = $package->SUPER::new($menufiles[0]); |
|
| 15 |
opendir my $dir, $path or die "can't open $path: $!"; |
|
| 16 |
my @files = sort grep -f "$path/$_", readdir $dir; |
|
| 17 |
close $dir; |
|
| 51 | 18 |
|
| 52 |
for (@menufiles[1..$#menufiles]) {
|
|
| 53 |
my $inifile = Inifile->new($_); |
|
| 54 |
push @{ $self->{ORDER} }, @{ delete $inifile->{ORDER} };
|
|
| 55 |
$self->{$_} = $inifile->{$_} for keys %$inifile;
|
|
| 19 |
my $nodes = []; |
|
| 20 |
my $nodes_by_id = {};
|
|
| 21 |
for my $file (@files) {
|
|
| 22 |
my $data = YAML::XS::LoadFile(File::Spec->catfile($path, $file)); |
|
| 23 |
_merge($nodes, $nodes_by_id, $data); |
|
| 56 | 24 |
} |
| 57 | 25 |
|
| 58 |
$self->set_access; |
|
| 59 | 26 |
|
| 60 |
$main::lxdebug->leave_sub(); |
|
| 27 |
my $self = bless {
|
|
| 28 |
nodes => $nodes, |
|
| 29 |
by_id => $nodes_by_id, |
|
| 30 |
}, $package; |
|
| 31 |
|
|
| 32 |
$self->build_tree; |
|
| 33 |
$self->set_access; |
|
| 61 | 34 |
|
| 62 | 35 |
return $self; |
| 63 | 36 |
} |
| 64 | 37 |
|
| 65 |
sub menuitem_new {
|
|
| 66 |
$main::lxdebug->enter_sub(LXDebug::DEBUG2());
|
|
| 38 |
sub _merge {
|
|
| 39 |
my ($nodes, $by_id, $data) = @_;
|
|
| 67 | 40 |
|
| 68 |
my ($self, $name, $item) = @_;
|
|
| 41 |
die 'not an array ref' unless $data && 'ARRAY' eq ref $data; # TODO check this sooner, to get better diag to user
|
|
| 69 | 42 |
|
| 70 |
my $module = $self->{$name}->{module} || $::form->{script};
|
|
| 71 |
my $action = $self->{$name}->{action};
|
|
| 43 |
for my $node (@$data) {
|
|
| 44 |
my $id = $node->{id};
|
|
| 72 | 45 |
|
| 73 |
$item->{target} = $self->{$name}->{target} || "main_window";
|
|
| 74 |
$item->{href} = $self->{$name}->{href} || "${module}?action=" . $::form->escape($action);
|
|
| 46 |
my $merge_to = $by_id->{$id};
|
|
| 75 | 47 |
|
| 76 |
my @vars = qw(module target href); |
|
| 77 |
push @vars, 'action' unless ($self->{$name}->{href});
|
|
| 48 |
if (!$merge_to) {
|
|
| 49 |
push @$nodes, $node; |
|
| 50 |
$by_id->{$id} = $node;
|
|
| 51 |
next; |
|
| 52 |
} |
|
| 78 | 53 |
|
| 79 |
map { delete $self->{$name}{$_} } @vars;
|
|
| 54 |
# TODO make this a real recursive merge |
|
| 55 |
# TODO add support for arrays |
|
| 56 |
|
|
| 57 |
# merge keys except params |
|
| 58 |
for my $key (keys %$node) {
|
|
| 59 |
if (ref $node->{$key}) {
|
|
| 60 |
if ('HASH' eq ref $node->{$key}) {
|
|
| 61 |
$merge_to->{$key} = {} if !exists $merge_to->{$key} || 'HASH' ne ref $merge_to->{$key};
|
|
| 62 |
for (keys %{ $node->{params} }) {
|
|
| 63 |
$merge_to->{$key}{$_} = $node->{params}{$_};
|
|
| 64 |
} |
|
| 65 |
} else {
|
|
| 66 |
die "unsupported structure @{[ ref $node->{$key} ]}";
|
|
| 67 |
} |
|
| 68 |
} else {
|
|
| 69 |
$merge_to->{$key} = $node->{$key};
|
|
| 70 |
} |
|
| 71 |
} |
|
| 72 |
} |
|
| 73 |
} |
|
| 80 | 74 |
|
| 81 |
# add other params |
|
| 82 |
foreach my $key (keys %{ $self->{$name} }) {
|
|
| 83 |
my ($value, $conf) = split(m/=/, $self->{$name}->{$key}, 2);
|
|
| 84 |
$value = $::myconfig->{$value} . "/$conf" if ($conf);
|
|
| 85 |
$item->{href} .= "&" . $::form->escape($key) . "=" . $::form->escape($value);
|
|
| 75 |
sub build_tree {
|
|
| 76 |
my ($self) = @_; |
|
| 77 |
|
|
| 78 |
# first, some sanity check. are all parents valid ids or empty? |
|
| 79 |
for my $node ($self->nodes) {
|
|
| 80 |
next if !exists $node->{parent} || !$node->{parent} || $self->{by_id}->{$node->{id}};
|
|
| 81 |
die "menu: node $node->{id} has non-existant parent $node->{parent}";
|
|
| 86 | 82 |
} |
| 87 | 83 |
|
| 88 |
$main::lxdebug->leave_sub(LXDebug::DEBUG2()); |
|
| 89 |
} |
|
| 84 |
my %by_parent; |
|
| 85 |
# order them by parent |
|
| 86 |
for my $node ($self->nodes) {
|
|
| 87 |
push @{ $by_parent{ $node->{parent} } //= [] }, $node;
|
|
| 88 |
} |
|
| 90 | 89 |
|
| 91 |
sub access_control {
|
|
| 92 |
$main::lxdebug->enter_sub(2);
|
|
| 90 |
my $tree = { };
|
|
| 91 |
$self->{by_id}{''} = $tree;
|
|
| 93 | 92 |
|
| 94 |
my ($self, $myconfig, $menulevel) = @_; |
|
| 95 | 93 |
|
| 96 |
my @menu = (); |
|
| 94 |
for (keys %by_parent) {
|
|
| 95 |
my $parent = $self->{by_id}{$_};
|
|
| 96 |
$parent->{children} = [ sort { $a->{order} <=> $b->{order} } @{ $by_parent{$_} } ];
|
|
| 97 |
} |
|
| 98 |
|
|
| 99 |
_set_level_rec($tree->{children}, 0);
|
|
| 100 |
|
|
| 101 |
$self->{tree} = $tree->{children};
|
|
| 102 |
} |
|
| 103 |
|
|
| 104 |
sub _set_level_rec {
|
|
| 105 |
my ($ary_ref, $level) = @_; |
|
| 97 | 106 |
|
| 98 |
if (!$menulevel) {
|
|
| 99 |
@menu = grep { !/--/ } @{ $self->{ORDER} };
|
|
| 100 |
} else {
|
|
| 101 |
@menu = grep { /^${menulevel}--/ } @{ $self->{ORDER} };
|
|
| 107 |
for (@$ary_ref) {
|
|
| 108 |
$_->{level} = $level;
|
|
| 109 |
_set_level_rec($_->{children}, $level + 1) if $_->{children};
|
|
| 102 | 110 |
} |
| 111 |
} |
|
| 103 | 112 |
|
| 104 |
$main::lxdebug->leave_sub(2); |
|
| 113 |
sub nodes {
|
|
| 114 |
@{ $_[0]{nodes} }
|
|
| 115 |
} |
|
| 116 |
|
|
| 117 |
sub tree_walk {
|
|
| 118 |
my ($self, $all) = @_; |
|
| 105 | 119 |
|
| 106 |
return @menu;
|
|
| 120 |
_tree_walk_rec($self->{tree}, $all);
|
|
| 107 | 121 |
} |
| 108 | 122 |
|
| 109 |
sub parse_access_string {
|
|
| 110 |
my $self = shift;
|
|
| 111 |
my $key = shift;
|
|
| 112 |
my $access = shift;
|
|
| 123 |
sub _tree_walk_rec {
|
|
| 124 |
my ($ary_ref, $all) = @_;
|
|
| 125 |
map { $_->{children} ? ($_, _tree_walk_rec($_->{children}, $all)) : ($_) } grep { $all || $_->{visible} } @$ary_ref;
|
|
| 126 |
}
|
|
| 113 | 127 |
|
| 114 |
my $form = $main::form; |
|
| 115 |
my $auth = $main::auth; |
|
| 116 |
my $myconfig = \%main::myconfig; |
|
| 128 |
sub parse_access_string {
|
|
| 129 |
my ($self, $node) = @_; |
|
| 117 | 130 |
|
| 118 | 131 |
my @stack; |
| 119 | 132 |
my $cur_ary = []; |
| 120 | 133 |
|
| 121 | 134 |
push @stack, $cur_ary; |
| 122 | 135 |
|
| 123 |
while ($access =~ m/^([a-z_]+|\||\&|\(|\)|\s+)/) {
|
|
| 136 |
my $access = $node->{access};
|
|
| 137 |
|
|
| 138 |
while ($access =~ m/^([a-z_\/]+|\||\&|\(|\)|\s+)/) {
|
|
| 124 | 139 |
my $token = $1; |
| 125 | 140 |
substr($access, 0, length($1)) = ""; |
| 126 | 141 |
|
| ... | ... | |
| 135 | 150 |
} elsif ($token eq ")") {
|
| 136 | 151 |
pop @stack; |
| 137 | 152 |
if (!@stack) {
|
| 138 |
$form->error("Error in menu.ini for entry ${key}: missing '('");
|
|
| 153 |
die "Error in menu.ini for entry $node->{id}: missing '('";
|
|
| 139 | 154 |
} |
| 140 | 155 |
$cur_ary = $stack[-1]; |
| 141 | 156 |
|
| ... | ... | |
| 143 | 158 |
push @{$cur_ary}, $token;
|
| 144 | 159 |
|
| 145 | 160 |
} else {
|
| 146 |
push @{$cur_ary}, $auth->check_right($::myconfig{login}, $token, 1);
|
|
| 161 |
if ($token =~ m{^ client / (.*) }x) {
|
|
| 162 |
push @{$cur_ary}, $self->parse_instance_conf_string($1);
|
|
| 163 |
} else {
|
|
| 164 |
push @{$cur_ary}, $::auth->check_right($::myconfig{login}, $token, 1);
|
|
| 165 |
} |
|
| 147 | 166 |
} |
| 148 | 167 |
} |
| 149 | 168 |
|
| 150 | 169 |
if ($access) {
|
| 151 |
$form->error("Error in menu.ini for entry ${key}: unrecognized token at the start of '$access'\n");
|
|
| 170 |
die "Error in menu.ini for entry $node->{id}: unrecognized token at the start of '$access'\n";
|
|
| 152 | 171 |
} |
| 153 | 172 |
|
| 154 | 173 |
if (1 < scalar @stack) {
|
| 155 |
$main::form->error("Error in menu.ini for entry ${key}: Missing ')'\n");
|
|
| 174 |
die "Error in menu.ini for entry $node->{id}: Missing ')'\n";
|
|
| 156 | 175 |
} |
| 157 | 176 |
|
| 158 | 177 |
return SL::Auth::evaluate_rights_ary($stack[0]); |
| 159 | 178 |
} |
| 160 | 179 |
|
| 161 |
sub parse_instance_conf_string {
|
|
| 162 |
my ($self, $setting) = @_; |
|
| 163 |
return $::instance_conf->data->{$setting};
|
|
| 164 |
} |
|
| 165 |
|
|
| 166 |
sub set_access {
|
|
| 167 |
my $self = shift; |
|
| 168 |
|
|
| 169 |
my $key; |
|
| 170 |
|
|
| 171 |
foreach $key (@{ $self->{ORDER} }) {
|
|
| 172 |
my $entry = $self->{$key};
|
|
| 173 |
|
|
| 174 |
$entry->{GRANTED} = $entry->{ACCESS} ? $self->parse_access_string($key, $entry->{ACCESS}) : 1;
|
|
| 175 |
$entry->{GRANTED} &&= $self->parse_instance_conf_string($entry->{INSTANCE_CONF}) if $entry->{INSTANCE_CONF};
|
|
| 176 |
$entry->{IS_MENU} = $entry->{submenu} || ($key !~ m/--/);
|
|
| 177 |
$entry->{NUM_VISIBLE_CHILDREN} = 0;
|
|
| 178 |
|
|
| 179 |
if ($key =~ m/--/) {
|
|
| 180 |
my $parent = $key; |
|
| 181 |
substr($parent, rindex($parent, '--')) = ''; |
|
| 182 |
$entry->{GRANTED} &&= $self->{$parent}->{GRANTED};
|
|
| 183 |
} |
|
| 184 |
|
|
| 185 |
$entry->{VISIBLE} = $entry->{GRANTED};
|
|
| 186 |
} |
|
| 187 |
|
|
| 188 |
foreach $key (reverse @{ $self->{ORDER} }) {
|
|
| 189 |
my $entry = $self->{$key};
|
|
| 180 |
sub href_for_node {
|
|
| 181 |
my ($self, $node) = @_; |
|
| 190 | 182 |
|
| 191 |
if ($entry->{IS_MENU}) {
|
|
| 192 |
$entry->{VISIBLE} &&= $entry->{NUM_VISIBLE_CHILDREN} > 0;
|
|
| 193 |
} |
|
| 183 |
return undef if !$node->{href} && !$node->{module} && !$node->{params};
|
|
| 194 | 184 |
|
| 195 |
next if (($key !~ m/--/) || !$entry->{VISIBLE});
|
|
| 185 |
my $href = $node->{href} || $node->{module} || 'controller.pl';
|
|
| 186 |
my @tokens; |
|
| 196 | 187 |
|
| 197 |
my $parent = $key; |
|
| 198 |
substr($parent, rindex($parent, '--')) = ''; |
|
| 199 |
$self->{$parent}->{NUM_VISIBLE_CHILDREN}++;
|
|
| 188 |
while (my ($key, $value) = each %{ $node->{params} }) {
|
|
| 189 |
push @tokens, uri_encode($key, 1) . "=" . uri_encode($value, 1); |
|
| 200 | 190 |
} |
| 201 | 191 |
|
| 202 |
# $self->dump_visible(); |
|
| 192 |
return join '?', $href, grep $_, join '&', @tokens; |
|
| 193 |
} |
|
| 203 | 194 |
|
| 204 |
$self->{ORDER} = [ grep { $self->{$_}->{VISIBLE} } @{ $self->{ORDER} } ];
|
|
| 195 |
sub name_for_node {
|
|
| 196 |
$::locale->text($_[1]{name})
|
|
| 197 |
} |
|
| 205 | 198 |
|
| 206 |
{ no strict 'refs';
|
|
| 207 |
# ToDO: fix this. nuke and pave algorithm without type checking screams for problems. |
|
| 208 |
map { delete @{$self->{$_}}{qw(GRANTED IS_MENU NUM_VISIBLE_CHILDREN VISIBLE ACCESS)} if ($_ ne 'ORDER') } keys %{ $self };
|
|
| 209 |
} |
|
| 199 |
sub parse_instance_conf_string {
|
|
| 200 |
my ($self, $setting) = @_; |
|
| 201 |
return $::instance_conf->data->{$setting};
|
|
| 210 | 202 |
} |
| 211 | 203 |
|
| 212 |
sub dump_visible {
|
|
| 213 |
my $self = shift; |
|
| 214 |
foreach my $key (@{ $self->{ORDER} }) {
|
|
| 215 |
my $entry = $self->{$key};
|
|
| 216 |
$main::lxdebug->message(0, "$entry->{GRANTED} $entry->{VISIBLE} $entry->{NUM_VISIBLE_CHILDREN} $key");
|
|
| 204 |
sub set_access {
|
|
| 205 |
my ($self) = @_; |
|
| 206 |
# 1. evaluate access for all |
|
| 207 |
# 2. if a menu has no visible children, its not visible either |
|
| 208 |
|
|
| 209 |
for my $node (reverse $self->tree_walk("all")) {
|
|
| 210 |
$node->{visible} = $node->{access} ? $self->parse_access_string($node)
|
|
| 211 |
: !$node->{children} ? 1
|
|
| 212 |
: $node->{visible_children} ? 1
|
|
| 213 |
: 0; |
|
| 214 |
if ($node->{visible} && $node->{parent}) {
|
|
| 215 |
$self->{by_id}{ $node->{parent} }{visible_children} = 1;
|
|
| 216 |
} |
|
| 217 | 217 |
} |
| 218 | 218 |
} |
| 219 | 219 |
|
Auch abrufbar als: Unified diff
Menüstruktur auf YAML geändert