Zeiterfassung: Bericht: Einige Sortierungen repariert

[mfinanz.git] / SL / Menu.pm

diff --git a/SL/Menu.pm b/SL/Menu.pm
index d72bb36192956bec1a85bdc85210a639f5eba24c..0c6df2247a976d6efb2939b9fd710bfa7d26e61e 100644 (file)
--- a/SL/Menu.pm
+++ b/SL/Menu.pm
@@ -3,46 +3,69 @@ package SL::Menu;
 use strict;
 
 use SL::Auth;
 use strict;
 
 use SL::Auth;

-use YAML::XS ();

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

+use SL::YAML;
+
+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 = YAML::XS::LoadFile(File::Spec->catfile($path, $file));
-    _merge($nodes, $nodes_by_id, $data);
-  }
+    my $nodes = [];
+    my $nodes_by_id = {};
+    for my $file (@files) {
+      my $data;
+      eval {
+        $data = SL::YAML::LoadFile(File::Spec->catfile($path, $file));
+        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
+      #my %uniq_ids;
+      #$uniq_ids{$_->{id}}++ && die "Error in $file: duplicate id $_->{id}" for @$data;
+
+      _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->set_access;
+    $self->build_tree;

 
 

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

 }
 
 sub _merge {
   my ($nodes, $by_id, $data) = @_;
 
 }
 
 sub _merge {
   my ($nodes, $by_id, $data) = @_;
 

-  die 'not an array ref' unless $data && 'ARRAY' eq ref $data; # TODO check this sooner, to get better diag to user
-

   for my $node (@$data) {
     my $id = $node->{id};
 
   for my $node (@$data) {
     my $id = $node->{id};
 

+    die "menu: node with name '$node->{name}' does not have an id" if !$id;
+

     my $merge_to = $by_id->{$id};
 
     if (!$merge_to) {
     my $merge_to = $by_id->{$id};
 
     if (!$merge_to) {


@@ -78,13 +101,26 @@ 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;
   # order them by parent
   for my $node ($self->nodes) {
   }
 
   my %by_parent;
   # order them by parent
   for my $node ($self->nodes) {

-    push @{ $by_parent{ $node->{parent} } //= [] }, $node;
+    push @{ $by_parent{ $node->{parent} // '' } //= [] }, $node;
+  }
+
+  # 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;
+      }
+    }

   }
 
   my $tree = { };
   }
 
   my $tree = { };


@@ -135,7 +171,7 @@ sub parse_access_string {
 
   my $access = $node->{access};
 
 
   my $access = $node->{access};
 

-  while ($access =~ m/^([a-z_\/]+|\||\&|\(|\)|\s+)/) {
+  while ($access =~ m/^([a-z_\/]+|\!|\||\&|\(|\)|\s+)/) {

     my $token = $1;
     substr($access, 0, length($1)) = "";
 
     my $token = $1;
     substr($access, 0, length($1)) = "";
 


@@ -154,7 +190,7 @@ sub parse_access_string {
       }
       $cur_ary = $stack[-1];
 
       }
       $cur_ary = $stack[-1];
 

-    } elsif (($token eq "|") || ($token eq "&")) {
+    } elsif (($token eq "|") || ($token eq "&") || ($token eq "!")) {

       push @{$cur_ary}, $token;
 
     } else {
       push @{$cur_ary}, $token;
 
     } else {


@@ -182,14 +218,16 @@ sub href_for_node {
 
   return undef if !$node->{href} && !$node->{module} && !$node->{params};
 
 
   return undef if !$node->{href} && !$node->{module} && !$node->{params};
 

-  my $href = $node->{href} || $node->{module} || 'controller.pl';
-  my @tokens;
+  return $node->{href_for_node} ||= do {
+    my $href = $node->{href} || $node->{module} || 'controller.pl';
+    my @tokens;

 
 

-  while (my ($key, $value) = each %{ $node->{params} }) {
-    push @tokens, uri_encode($key, 1) . "=" . uri_encode($value, 1);
-  }
+    while (my ($key, $value) = each %{ $node->{params} }) {
+      push @tokens, uri_encode($key, 1) . "=" . uri_encode($value, 1);
+    }

 
 

-  return join '?', $href, grep $_, join '&', @tokens;
+    join '?', $href, grep $_, join '&', @tokens;
+  }

 }
 
 sub name_for_node {
 }
 
 sub name_for_node {


@@ -201,6 +239,14 @@ sub parse_instance_conf_string {
   return $::instance_conf->data->{$setting};
 }
 
   return $::instance_conf->data->{$setting};
 }
 

+sub clear_access {
+  my ($self) = @_;
+  for my $node ($self->tree_walk("all")) {
+    delete $node->{visible};
+    delete $node->{visible_children};
+  }
+}
+

 sub set_access {
   my ($self) = @_;
   # 1. evaluate access for all
 sub set_access {
   my ($self) = @_;
   # 1. evaluate access for all


@@ -218,4 +264,3 @@ sub set_access {
 }
 
 1;
 }
 
 1;

-