SL/Menu.pm

   1 package SL::Menu;
   2
   3 use strict;
   4
   5 use SL::Auth;
   6 use File::Spec;
   7 use SL::MoreCommon qw(uri_encode);
   8 use SL::YAML;
   9
  10 our %menu_cache;
  11
  12 sub new {
  13   my ($package, $domain) = @_;
  14
  15   if (!$menu_cache{$domain}) {
  16     my $path = File::Spec->catdir('menus', $domain);
  17
  18     opendir my $dir, $path or die "can't open $path: $!";
  19     my @files = sort grep -f "$path/$_", grep /\.yaml$/, readdir $dir;
  20     close $dir;
  21
  22     my $nodes = [];
  23     my $nodes_by_id = {};
  24     for my $file (@files) {
  25       my $data;
  26       eval {
  27         $data = SL::YAML::LoadFile(File::Spec->catfile($path, $file));
  28         1;
  29       } or do {
  30         die "Error while parsing $file: $@";
  31       };
  32
  33       # check if this file is internally consistent.
  34       die 'not an array ref' unless $data && 'ARRAY' eq ref $data; # TODO get better diag to user
  35
  36       # in particular duplicate ids tend to come up as a user error when editing the menu files
  37       #my %uniq_ids;
  38       #$uniq_ids{$_->{id}}++ && die "Error in $file: duplicate id $_->{id}" for @$data;
  39
  40       _merge($nodes, $nodes_by_id, $data);
  41     }
  42
  43
  44     my $self = bless {
  45       nodes => $nodes,
  46       by_id => $nodes_by_id,
  47     }, $package;
  48
  49     $self->build_tree;
  50
  51     $menu_cache{$domain} = $self;
  52   } else {
  53     $menu_cache{$domain}->clear_access;
  54   }
  55
  56   $menu_cache{$domain}->set_access;
  57
  58   return $menu_cache{$domain};
  59 }
  60
  61 sub _merge {
  62   my ($nodes, $by_id, $data) = @_;
  63
  64   for my $node (@$data) {
  65     my $id = $node->{id};
  66
  67     die "menu: node with name '$node->{name}' does not have an id" if !$id;
  68
  69     my $merge_to = $by_id->{$id};
  70
  71     if (!$merge_to) {
  72       push @$nodes, $node;
  73       $by_id->{$id} = $node;
  74       next;
  75     }
  76
  77     # TODO make this a real recursive merge
  78     # TODO add support for arrays
  79
  80     # merge keys except params
  81     for my $key (keys %$node) {
  82       if (ref $node->{$key}) {
  83         if ('HASH' eq ref $node->{$key}) {
  84           $merge_to->{$key} = {} if !exists $merge_to->{$key} || 'HASH' ne ref $merge_to->{$key};
  85           for (keys %{ $node->{params} }) {
  86             $merge_to->{$key}{$_} = $node->{params}{$_};
  87           }
  88         } else {
  89           die "unsupported structure @{[ ref $node->{$key} ]}";
  90         }
  91       } else {
  92         $merge_to->{$key} = $node->{$key};
  93       }
  94     }
  95   }
  96 }
  97
  98 sub build_tree {
  99   my ($self) = @_;
 100
 101   # first, some sanity check. are all parents valid ids or empty?
 102   for my $node ($self->nodes) {
 103     next if !exists $node->{parent} || !$node->{parent} || $self->{by_id}->{$node->{id}};
 104     die "menu: node $node->{id} has non-existent parent $node->{parent}";
 105   }
 106
 107   my %by_parent;
 108   # order them by parent
 109   for my $node ($self->nodes) {
 110     push @{ $by_parent{ $node->{parent} // '' } //= [] }, $node;
 111   }
 112
 113   # autovivify order in by_parent, so that numerical sorting for entries without order
 114   # preserves their order and position with respect to entries with order.
 115   for (values %by_parent) {
 116     my $last_order = 0;
 117     for my $node (@$_) {
 118       if (defined $node->{order} && $node->{order} * 1) {
 119         $last_order = $node->{order};
 120       } else {
 121         $node->{order} = ++$last_order;
 122       }
 123     }
 124   }
 125
 126   my $tree = { };
 127   $self->{by_id}{''} = $tree;
 128
 129
 130   for (keys %by_parent) {
 131     my $parent = $self->{by_id}{$_};
 132     $parent->{children} =  [ sort { $a->{order} <=> $b->{order} } @{ $by_parent{$_} } ];
 133   }
 134
 135   _set_level_rec($tree->{children}, 0);
 136
 137   $self->{tree} = $tree->{children};
 138 }
 139
 140 sub _set_level_rec {
 141   my ($ary_ref, $level) = @_;
 142
 143   for (@$ary_ref) {
 144     $_->{level} = $level;
 145     _set_level_rec($_->{children}, $level + 1) if $_->{children};
 146   }
 147 }
 148
 149 sub nodes {
 150   @{ $_[0]{nodes} }
 151 }
 152
 153 sub tree_walk {
 154   my ($self, $all) = @_;
 155
 156   _tree_walk_rec($self->{tree}, $all);
 157 }
 158
 159 sub _tree_walk_rec {
 160   my ($ary_ref, $all) = @_;
 161   map { $_->{children} ? ($_, _tree_walk_rec($_->{children}, $all)) : ($_) } grep { $all || $_->{visible} } @$ary_ref;
 162 }
 163
 164 sub parse_access_string {
 165   my ($self, $node) = @_;
 166
 167   my @stack;
 168   my $cur_ary = [];
 169
 170   push @stack, $cur_ary;
 171
 172   my $access = $node->{access};
 173
 174   while ($access =~ m/^([a-z_\/]+|\!|\||\&|\(|\)|\s+)/) {
 175     my $token = $1;
 176     substr($access, 0, length($1)) = "";
 177
 178     next if ($token =~ /\s/);
 179
 180     if ($token eq "(") {
 181       my $new_cur_ary = [];
 182       push @stack, $new_cur_ary;
 183       push @{$cur_ary}, $new_cur_ary;
 184       $cur_ary = $new_cur_ary;
 185
 186     } elsif ($token eq ")") {
 187       pop @stack;
 188       if (!@stack) {
 189         die "Error while parsing menu entry $node->{id}: missing '('";
 190       }
 191       $cur_ary = $stack[-1];
 192
 193     } elsif (($token eq "|") || ($token eq "&") || ($token eq "!")) {
 194       push @{$cur_ary}, $token;
 195
 196     } else {
 197       if ($token =~ m{^ client / (.*) }x) {
 198         push @{$cur_ary}, $self->parse_instance_conf_string($1);
 199       } else {
 200         push @{$cur_ary}, $::auth->check_right($::myconfig{login}, $token, 1);
 201       }
 202     }
 203   }
 204
 205   if ($access) {
 206     die "Error while parsing menu entry $node->{id}: unrecognized token at the start of '$access'\n";
 207   }
 208
 209   if (1 < scalar @stack) {
 210     die "Error while parsing menu entry $node->{id}: Missing ')'\n";
 211   }
 212
 213   return SL::Auth::evaluate_rights_ary($stack[0]);
 214 }
 215
 216 sub href_for_node {
 217   my ($self, $node) = @_;
 218
 219   return undef if !$node->{href} && !$node->{module} && !$node->{params};
 220
 221   return $node->{href_for_node} ||= do {
 222     my $href = $node->{href} || $node->{module} || 'controller.pl';
 223     my @tokens;
 224
 225     while (my ($key, $value) = each %{ $node->{params} }) {
 226       push @tokens, uri_encode($key, 1) . "=" . uri_encode($value, 1);
 227     }
 228
 229     join '?', $href, grep $_, join '&', @tokens;
 230   }
 231 }
 232
 233 sub name_for_node {
 234   $::locale->text($_[1]{name})
 235 }
 236
 237 sub parse_instance_conf_string {
 238   my ($self, $setting) = @_;
 239   return $::instance_conf->data->{$setting};
 240 }
 241
 242 sub clear_access {
 243   my ($self) = @_;
 244   for my $node ($self->tree_walk("all")) {
 245     delete $node->{visible};
 246     delete $node->{visible_children};
 247   }
 248 }
 249
 250 sub set_access {
 251   my ($self) = @_;
 252   # 1. evaluate access for all
 253   # 2. if a menu has no visible children, its not visible either
 254
 255   for my $node (reverse $self->tree_walk("all")) {
 256     $node->{visible} = $node->{access}           ? $self->parse_access_string($node)
 257                      : !$node->{children}        ? 1
 258                      : $node->{visible_children} ? 1
 259                      :                             0;
 260     if ($node->{visible} && $node->{parent}) {
 261       $self->{by_id}{ $node->{parent} }{visible_children} = 1;
 262     }
 263   }
 264 }
 265
 266 1;