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