SL/Menu.pm

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