SL/Menu.pm

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