use strict;
use SL::Auth;
-use YAML ();
use File::Spec;
use SL::MoreCommon qw(uri_encode);
-
-our $yaml_xs;
-BEGIN {
- $yaml_xs = eval { require YAML::XS };
-}
+use SL::YAML;
our %menu_cache;
my $path = File::Spec->catdir('menus', $domain);
opendir my $dir, $path or die "can't open $path: $!";
- my @files = sort grep -f "$path/$_", readdir $dir;
+ my @files = sort grep -f "$path/$_", grep /\.yaml$/, readdir $dir;
close $dir;
my $nodes = [];
my $nodes_by_id = {};
for my $file (@files) {
my $data;
- if ($yaml_xs) {
- $data = YAML::XS::LoadFile(File::Spec->catfile($path, $file));
- } else {
- $data = YAML::LoadFile(File::Spec->catfile($path, $file));
- }
+ eval {
+ $data = SL::YAML::LoadFile(File::Spec->catfile($path, $file));
+ 1;
+ } or do {
+ die "Error while parsing $file: $@";
+ };
+
+ # check if this file is internally consistent.
+ die 'not an array ref' unless $data && 'ARRAY' eq ref $data; # TODO get better diag to user
+
+ # in particular duplicate ids tend to come up as a user error when editing the menu files
+ #my %uniq_ids;
+ #$uniq_ids{$_->{id}}++ && die "Error in $file: duplicate id $_->{id}" for @$data;
+
_merge($nodes, $nodes_by_id, $data);
}
sub _merge {
my ($nodes, $by_id, $data) = @_;
- die 'not an array ref' unless $data && 'ARRAY' eq ref $data; # TODO check this sooner, to get better diag to user
-
for my $node (@$data) {
my $id = $node->{id};
+ die "menu: node with name '$node->{name}' does not have an id" if !$id;
+
my $merge_to = $by_id->{$id};
if (!$merge_to) {
# first, some sanity check. are all parents valid ids or empty?
for my $node ($self->nodes) {
next if !exists $node->{parent} || !$node->{parent} || $self->{by_id}->{$node->{id}};
- die "menu: node $node->{id} has non-existant parent $node->{parent}";
+ die "menu: node $node->{id} has non-existent parent $node->{parent}";
}
my %by_parent;
# order them by parent
for my $node ($self->nodes) {
- push @{ $by_parent{ $node->{parent} } //= [] }, $node;
+ push @{ $by_parent{ $node->{parent} // '' } //= [] }, $node;
+ }
+
+ # autovivify order in by_parent, so that numerical sorting for entries without order
+ # preserves their order and position with respect to entries with order.
+ for (values %by_parent) {
+ my $last_order = 0;
+ for my $node (@$_) {
+ if (defined $node->{order} && $node->{order} * 1) {
+ $last_order = $node->{order};
+ } else {
+ $node->{order} = ++$last_order;
+ }
+ }
}
my $tree = { };
my $access = $node->{access};
- while ($access =~ m/^([a-z_\/]+|\||\&|\(|\)|\s+)/) {
+ while ($access =~ m/^([a-z_\/]+|\!|\||\&|\(|\)|\s+)/) {
my $token = $1;
substr($access, 0, length($1)) = "";
}
$cur_ary = $stack[-1];
- } elsif (($token eq "|") || ($token eq "&")) {
+ } elsif (($token eq "|") || ($token eq "&") || ($token eq "!")) {
push @{$cur_ary}, $token;
} else {
return undef if !$node->{href} && !$node->{module} && !$node->{params};
- my $href = $node->{href} || $node->{module} || 'controller.pl';
- my @tokens;
+ return $node->{href_for_node} ||= do {
+ my $href = $node->{href} || $node->{module} || 'controller.pl';
+ my @tokens;
- while (my ($key, $value) = each %{ $node->{params} }) {
- push @tokens, uri_encode($key, 1) . "=" . uri_encode($value, 1);
- }
+ while (my ($key, $value) = each %{ $node->{params} }) {
+ push @tokens, uri_encode($key, 1) . "=" . uri_encode($value, 1);
+ }
- return join '?', $href, grep $_, join '&', @tokens;
+ join '?', $href, grep $_, join '&', @tokens;
+ }
}
sub name_for_node {
}
1;
-