Erfolgsrechnung 1st draft

[mfinanz.git] / SL / Menu.pm

diff --git a/SL/Menu.pm b/SL/Menu.pm
index 534a05e6ef7903b2f569a2b64c893bf756ca8afa..ac8f7280b4bf51e464c018c5223f9a8824c1cc3f 100644 (file)
--- a/SL/Menu.pm
+++ b/SL/Menu.pm
@@ -3,36 +3,55 @@ package SL::Menu;
 use strict;
 
 use SL::Auth;
 use strict;
 
 use SL::Auth;

-use YAML::XS ();
+use YAML ();

 use File::Spec;
 use SL::MoreCommon qw(uri_encode);
 
 use File::Spec;
 use SL::MoreCommon qw(uri_encode);
 

+our $yaml_xs;
+BEGIN {
+   $yaml_xs =  eval { require YAML::XS };
+}
+
+our %menu_cache;
+

 sub new {
   my ($package, $domain) = @_;
 
 sub new {
   my ($package, $domain) = @_;
 

-  my $path = File::Spec->catdir('menus', $domain);
+  if (!$menu_cache{$domain}) {
+    my $path = File::Spec->catdir('menus', $domain);

 
 

-  opendir my $dir, $path or die "can't open $path: $!";
-  my @files = sort grep -f "$path/$_", readdir $dir;
-  close $dir;
+    opendir my $dir, $path or die "can't open $path: $!";
+    my @files = sort grep -f "$path/$_", grep /\.yaml$/, readdir $dir;
+    close $dir;
+
+    my $nodes = [];
+    my $nodes_by_id = {};
+    for my $file (@files) {
+      my $data;
+      if ($yaml_xs) {
+        $data = YAML::XS::LoadFile(File::Spec->catfile($path, $file));
+      } else {
+        $data = YAML::LoadFile(File::Spec->catfile($path, $file));
+      }
+      _merge($nodes, $nodes_by_id, $data);
+    }

 
 

-  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);
-  }

 
 

+    my $self = bless {
+      nodes => $nodes,
+      by_id => $nodes_by_id,
+    }, $package;

 
 

-  my $self = bless {
-    nodes => $nodes,
-    by_id => $nodes_by_id,
-  }, $package;
+    $self->build_tree;

 
 

-  $self->build_tree;
-  $self->set_access;
+    $menu_cache{$domain} = $self;
+  } else {
+    $menu_cache{$domain}->clear_access;
+  }
+
+  $menu_cache{$domain}->set_access;

 
 

-  return $self;
+  return $menu_cache{$domain};

 }
 
 sub _merge {
 }
 
 sub _merge {


@@ -78,7 +97,7 @@ sub build_tree {
   # 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}};
   # 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}";
+    die "menu: node $node->{id} has non-existent parent $node->{parent}";

   }
 
   my %by_parent;
   }
 
   my %by_parent;


@@ -150,7 +169,7 @@ sub parse_access_string {
     } elsif ($token eq ")") {
       pop @stack;
       if (!@stack) {
     } elsif ($token eq ")") {
       pop @stack;
       if (!@stack) {

-        die "Error in menu.ini for entry $node->{id}: missing '('";
+        die "Error while parsing menu entry $node->{id}: missing '('";

       }
       $cur_ary = $stack[-1];
 
       }
       $cur_ary = $stack[-1];
 


@@ -167,11 +186,11 @@ sub parse_access_string {
   }
 
   if ($access) {
   }
 
   if ($access) {

-    die "Error in menu.ini for entry $node->{id}: unrecognized token at the start of '$access'\n";
+    die "Error while parsing menu entry $node->{id}: unrecognized token at the start of '$access'\n";

   }
 
   if (1 < scalar @stack) {
   }
 
   if (1 < scalar @stack) {

-    die "Error in menu.ini for entry $node->{id}: Missing ')'\n";
+    die "Error while parsing menu entry $node->{id}: Missing ')'\n";

   }
 
   return SL::Auth::evaluate_rights_ary($stack[0]);
   }
 
   return SL::Auth::evaluate_rights_ary($stack[0]);


@@ -201,13 +220,30 @@ sub parse_instance_conf_string {
   return $::instance_conf->data->{$setting};
 }
 
   return $::instance_conf->data->{$setting};
 }
 

+sub parse_compare_string {
+  my ($self, $switch) = @_;
+  my ($setting, $mode) = split m/=/, $switch, 2;
+  return $::instance_conf->data->{$setting} eq $mode;
+}
+
+sub clear_access {
+  my ($self) = @_;
+  for my $node ($self->tree_walk("all")) {
+    delete $node->{visible};
+    delete $node->{visible_children};
+  }
+}
+

 sub set_access {
   my ($self) = @_;
 sub set_access {
   my ($self) = @_;

-  # 1. evaluate access for all
-  # 2. if a menu has no visible children, its not visible either
+  # 1. evaluate appearence
+  # 2. evaluate access for all
+  # 3. if a menu has no visible children, its not visible either

 
   for my $node (reverse $self->tree_walk("all")) {
 
   for my $node (reverse $self->tree_walk("all")) {

-    $node->{visible} = $node->{access}           ? $self->parse_access_string($node)
+    $node->{visible} = $node->{inclusion}        ? $self->parse_compare_string($node->{inclusion})  : 1
+                   && $node->{exclusion}        ? !$self->parse_compare_string($node->{exclusion}) : 1
+                   && $node->{access}           ? $self->parse_access_string($node)

                      : !$node->{children}        ? 1
                      : $node->{visible_children} ? 1
                      :                             0;
                      : !$node->{children}        ? 1
                      : $node->{visible_children} ? 1
                      :                             0;