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