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