html menĂ¼ rewrite v1
[kivitendo-erp.git] / 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;
36
37 use SL::Auth;
38 use SL::Inifile;
39
40 use strict;
41
42 sub new {
43   $main::lxdebug->enter_sub();
44
45   my ($type, $menufile) = @_;
46
47   my $self    = {};
48   my $inifile = Inifile->new($menufile);
49
50   map { $self->{$_} = $inifile->{$_} } keys %{ $inifile };
51
52   bless $self, $type;
53
54   $self->set_access();
55
56   $main::lxdebug->leave_sub();
57
58   return $self;
59 }
60
61 sub menuitem {
62   $main::lxdebug->enter_sub();
63
64   my ($self, $myconfig, $form, $item) = @_;
65
66   my $module = $self->{$item}{module} || $form->{script};
67   my $action = $self->{$item}{action} || "section_menu";
68   my $target = $self->{$item}{target} || "";
69   my $level  = $form->escape($item);
70   my $target_token = ($target) ? "target='$target'" : '';
71
72   my $href = ($self->{$item}{href})
73            ? $form->escape($self->{$item}{href})
74            : "$module?action=$action";
75
76 #  my @vars = ($self->{$item}{href})
77 #           ? qw(module        target href)
78 #           : qw(module action target href);
79 #
80   # add other params
81   foreach my $key (keys %{ $self->{$item} }) {
82     next if $key =~ /target|module|action/;
83     $href .= "&" . $form->escape($key, 1) . "=";
84     my ($value, $conf) = split(/=/, $self->{$item}{$key}, 2);
85     $value = $myconfig->{$value} . "/$conf" if ($conf);
86     $href .= $form->escape($value, 1);
87   }
88
89   my $str = "<a href='$href' $target_token>";
90
91   $main::lxdebug->leave_sub();
92
93   return $str;
94 }
95
96 sub menuitem_js {
97   my ($self, $myconfig, $form, $item) = @_;
98
99   my $module = $form->{script};
100   my $action = "section_menu";
101
102   #if ($self->{$item}{module}) {
103   $module = $self->{$item}{module};
104
105   #}
106   if ($self->{$item}{action}) {
107     $action = $self->{$item}{action};
108   }
109
110   my $level = $form->escape($item);
111   my $str   = qq|$module?action=$action&level=$level|;
112   my @vars  = qw(module action target href);
113
114   if ($self->{$item}{href}) {
115     $str  = qq|$self->{$item}{href}|;
116     @vars = qw(module target href);
117   }
118
119   map { delete $self->{$item}{$_} } @vars;
120
121   # add other params
122   foreach my $key (keys %{ $self->{$item} }) {
123     $str .= "&" . $form->escape($key, 1) . "=";
124     my ($value, $conf) = split(/=/, $self->{$item}{$key}, 2);
125     $value = $myconfig->{$value} . "/$conf" if ($conf);
126     $str .= $form->escape($value, 1);
127   }
128
129   $str .= " ";
130
131 }
132
133 sub menuitem_new {
134   $main::lxdebug->enter_sub();
135
136   my ($self, $name, $item) = @_;
137
138   my $form        =  $main::form;
139   my $myconfig    = \%main::myconfig;
140
141   my $module      = $self->{$name}->{module} || $form->{script};
142   my $action      = $self->{$name}->{action};
143
144   $item->{target} = $self->{$name}->{target} || "main_window";
145   $item->{href}   = $self->{$name}->{href}   || "${module}?action=" . $form->escape($action);
146
147   my @vars = qw(module target href);
148   push @vars, 'action' unless ($self->{$name}->{href});
149
150   map { delete $self->{$name}{$_} } @vars;
151
152   # add other params
153   foreach my $key (keys %{ $self->{$name} }) {
154     my ($value, $conf)  = split(m/=/, $self->{$name}->{$key}, 2);
155     $value              = $myconfig->{$value} . "/$conf" if ($conf);
156     $item->{href}      .= "&" . $form->escape($key) . "=" . $form->escape($value);
157   }
158
159   $main::lxdebug->leave_sub();
160 }
161
162 sub menuitem_v3 {
163   $main::lxdebug->enter_sub();
164
165   my ($self, $myconfig, $form, $item, $other) = @_;
166
167   my $module = $form->{script};
168   my $action = "section_menu";
169   my $target = "";
170
171   if ($self->{$item}{module}) {
172     $module = $self->{$item}{module};
173   }
174   if ($self->{$item}{action}) {
175     $action = $self->{$item}{action};
176   }
177   if ($self->{$item}{target}) {
178     $target = $self->{$item}{target};
179   }
180
181   my $level = $form->escape($item);
182
183   my $str = qq|<a href="$module?action=| . $form->escape($action) . qq|&level=| . $form->escape($level);
184
185   my @vars = qw(module action target href);
186
187   if ($self->{$item}{href}) {
188     $str  = qq|<a href=$self->{$item}{href}|;
189     @vars = qw(module target href);
190   }
191
192   map { delete $self->{$item}{$_} } @vars;
193
194   # add other params
195   foreach my $key (keys %{ $self->{$item} }) {
196     $str .= "&" . $form->escape($key, 1) . "=";
197     my ($value, $conf) = split(/=/, $self->{$item}{$key}, 2);
198     $value = $myconfig->{$value} . "/$conf" if ($conf);
199     $str .= $form->escape($value, 1);
200   }
201
202   $str .= '"';
203
204   if ($target) {
205     $str .= qq| target="| . $form->quote($target) . qq|"|;
206   }
207
208   if ($other) {
209     foreach my $key (keys(%{$other})) {
210       $str .= qq| ${key}="| . $form->quote($other->{$key}) . qq|"|;
211     }
212   }
213
214   $str .= ">";
215
216   $main::lxdebug->leave_sub();
217
218   return $str;
219 }
220
221 sub menuitem_XML {
222   $main::lxdebug->enter_sub();
223
224   my ($self, $myconfig, $form, $item, $other) = @_;
225
226   my $module = $form->{script};
227   my $action = "section_menu";
228   my $target = "";
229
230   if ($self->{$item}{module}) {
231     $module = $self->{$item}{module};
232   }
233   if ($self->{$item}{action}) {
234     $action = $self->{$item}{action};
235   }
236   if ($self->{$item}{target}) {
237     $target = $self->{$item}{target};
238   }
239
240   my $level = $form->escape($item);
241
242   my $str = qq| link="$module?action=| . $form->escape($action) .
243     qq|&amp;level=| . $form->escape($level);
244
245   my @vars = qw(module action target href);
246
247   if ($self->{$item}{href}) {
248     $str  = qq| link=$self->{$item}{href}|;
249     @vars = qw(module target href);
250   }
251
252   map { delete $self->{$item}{$_} } @vars;
253
254   # add other params
255   foreach my $key (keys %{ $self->{$item} }) {
256     $str .= "&amp;" . $form->escape($key, 1) . "=";
257     my ($value, $conf) = split(/=/, $self->{$item}{$key}, 2);
258     $value = $myconfig->{$value} . "/$conf" if ($conf);
259     $str .= $form->escape($value, 1);
260   }
261
262   $str .= '"';
263
264
265
266   if ($other) {
267     foreach my $key (keys(%{$other})) {
268       $str .= qq| ${key}="| . $form->quote($other->{$key}) . qq|"|;
269     }
270   }
271
272
273   $main::lxdebug->leave_sub();
274
275   return $str;
276 }
277
278 sub access_control {
279   $main::lxdebug->enter_sub(2);
280
281   my ($self, $myconfig, $menulevel) = @_;
282
283   my @menu = ();
284
285   if ($menulevel eq "") {
286     @menu = grep { !/--/ } @{ $self->{ORDER} };
287   } else {
288     @menu = grep { /^${menulevel}--/ } @{ $self->{ORDER} };
289   }
290
291   $main::lxdebug->leave_sub(2);
292
293   return @menu;
294 }
295
296 sub parse_access_string {
297   my $self   = shift;
298   my $key    = shift;
299   my $access = shift;
300
301   my $form        =  $main::form;
302   my $auth        =  $main::auth;
303   my $myconfig    = \%main::myconfig;
304
305   my @stack;
306   my $cur_ary = [];
307
308   push @stack, $cur_ary;
309
310   while ($access =~ m/^([a-z_]+|\||\&|\(|\)|\s+)/) {
311     my $token = $1;
312     substr($access, 0, length($1)) = "";
313
314     next if ($token =~ /\s/);
315
316     if ($token eq "(") {
317       my $new_cur_ary = [];
318       push @stack, $new_cur_ary;
319       push @{$cur_ary}, $new_cur_ary;
320       $cur_ary = $new_cur_ary;
321
322     } elsif ($token eq ")") {
323       pop @stack;
324       if (!@stack) {
325         $form->error("Error in menu.ini for entry ${key}: missing '('");
326       }
327       $cur_ary = $stack[-1];
328
329     } elsif (($token eq "|") || ($token eq "&")) {
330       push @{$cur_ary}, $token;
331
332     } else {
333       push @{$cur_ary}, $auth->check_right($form->{login}, $token, 1);
334     }
335   }
336
337   if ($access) {
338     $form->error("Error in menu.ini for entry ${key}: unrecognized token at the start of '$access'\n");
339   }
340
341   if (1 < scalar @stack) {
342     $main::form->error("Error in menu.ini for entry ${key}: Missing ')'\n");
343   }
344
345   return SL::Auth::evaluate_rights_ary($stack[0]);
346 }
347
348 sub set_access {
349   my $self = shift;
350
351   my $key;
352
353   foreach $key (@{ $self->{ORDER} }) {
354     my $entry = $self->{$key};
355
356     $entry->{GRANTED}              = $entry->{ACCESS} ? $self->parse_access_string($key, $entry->{ACCESS}) : 1;
357     $entry->{IS_MENU}              = $entry->{submenu} || ($key !~ m/--/);
358     $entry->{NUM_VISIBLE_CHILDREN} = 0;
359
360     if ($key =~ m/--/) {
361       my $parent = $key;
362       substr($parent, rindex($parent, '--')) = '';
363       $entry->{GRANTED} &&= $self->{$parent}->{GRANTED};
364     }
365
366     $entry->{VISIBLE} = $entry->{GRANTED};
367   }
368
369   foreach $key (reverse @{ $self->{ORDER} }) {
370     my $entry = $self->{$key};
371
372     if ($entry->{IS_MENU}) {
373       $entry->{VISIBLE} &&= $entry->{NUM_VISIBLE_CHILDREN} > 0;
374     }
375
376     next if (($key !~ m/--/) || !$entry->{VISIBLE});
377
378     my $parent = $key;
379     substr($parent, rindex($parent, '--')) = '';
380     $self->{$parent}->{NUM_VISIBLE_CHILDREN}++;
381   }
382
383 #   $self->dump_visible();
384
385   $self->{ORDER} = [ grep { $self->{$_}->{VISIBLE} } @{ $self->{ORDER} } ];
386
387   { no strict 'refs';
388   # ToDO: fix this. nuke and pave algorithm without type checking screams for problems.
389   map { delete @{$self->{$_}}{qw(GRANTED IS_MENU NUM_VISIBLE_CHILDREN VISIBLE ACCESS)} if ($_ ne 'ORDER') } keys %{ $self };
390   }
391 }
392
393 sub dump_visible {
394   my $self = shift;
395   foreach my $key (@{ $self->{ORDER} }) {
396     my $entry = $self->{$key};
397     $main::lxdebug->message(0, "$entry->{GRANTED} $entry->{VISIBLE} $entry->{NUM_VISIBLE_CHILDREN} $key");
398   }
399 }
400
401 1;
402