Commit 9c3bdd51 authored by Xavier Guimard's avatar Xavier Guimard

Combination parser works (#1151)

parent 00ee3605
......@@ -70,6 +70,7 @@ t/30-Common-Safelib.t
t/35-Common-Crypto.t
t/36-Common-Regexp.t
t/40-Common-Session.t
t/50-Combination-Parser.t
t/99-pod.t
tools/apache-session-mysql.sql
tools/lmConfig.CDBI.mysql
......
......@@ -22,39 +22,32 @@ sub parse {
if ( $rest =~ s/^\s*if\s*\(// ) {
my ( $cond, $then, $else );
( $cond, $rest ) = $self->findB( $rest, ')' );
unless ($cond) {
unless ( length $cond ) {
die('Bad combination: unmatched bracket');
}
unless ( $rest =~ s/\s*then\s*\{// ) {
unless ( $rest =~ s/^\s*\bthen\b\s*// ) {
die('Bad combination: missing "then"');
}
( $then, $rest ) = $self->findB( $rest, '}' );
unless( $rest =~ /(.*?)\s*\belse\b\s*(.*)$/ ) {
die('Bad combination: missing "else"');
}
($then,$else)=($1,$2);
unless ($then) {
die('Bad combination: missing "then" content');
}
unless ( $rest =~ s/\s*else\s*\{// ) {
die('Bad combination: missing "else"');
}
( $else, $rest ) = $self->findB( $rest, '}' );
unless ($else) {
die('Bad combination: missing "else" content');
}
if ( $rest !~ /^\s*$/ ) {
die('Bad combination: trailing characters after else{}');
}
$cond = buildSub($cond);
$then = $self->parse( $moduleList, $then );
$cond = $self->buildSub($cond);
$then = $self->parseOr( $moduleList, $then );
$else = $self->parse( $moduleList, $else );
unless ( $then and $else ) {
die('Bad combination: bad then or else');
}
return sub {
my ( $sub, $req ) = @_;
return [
( $cond->($req) ? $then->[0]->($@) : $else->[0]->($@) ),
( $cond->($req) ? $then->[1]->($@) : $else->[1]->($@) ),
];
my ( $req ) = @_;
return ( $cond->($req) ? $then : $else->($req) );
};
}
else {
......@@ -146,7 +139,8 @@ sub findB {
my ( $self, $expr, $char ) = @_;
my $res;
my @chars = split //, $expr;
while ( my $c = shift @chars ) {
while (@chars) {
my $c = shift @chars;
if ( $c eq "\\" ) {
$res .= $c . shift(@chars);
next;
......@@ -167,7 +161,7 @@ sub findB {
}->{$c};
my ( $m, $rest ) =
$self->findB( join( '', @chars ), $wanted );
unless ($m) {
unless ( length $m ) {
die("Bad combination: unmatched $c");
}
$res .= "$c$m$wanted";
......
use Test::More tests => 27;
use strict;
my $m = 'Lemonldap::NG::Common::Combination::Parser';
use_ok($m);
my $authMods = {};
foreach (qw(A B C)) {
$authMods->{$_} = LLNG::Auth->new($_);
}
# Verify structure
ok( ref( $m->parse( $authMods, '[A]' ) ) eq 'CODE', 'First level is a sub' );
ok( ref( $m->parse( $authMods, '[A]' )->() ) eq 'ARRAY',
'Second level is an array ("or" list)' );
ok( ref( $m->parse( $authMods, '[A]' )->()->[0] ) eq 'ARRAY',
'Third level is an array (auth,userDB)' );
ok( ref( $m->parse( $authMods, '[A]' )->()->[0]->[0] ) eq 'CODE',
'Fourth level is a sub' );
my @tests = (
'[A]' => 'A' => 'A',
'[A,B]' => 'A' => 'B',
'if(1) then [A,B] else [B,C]', 'A', 'B',
'if(0) then [A,B] else [B,C]', 'B', 'C',
'if(0) then [A,B] else if(1) then [B,C] else [B,A]', 'B', 'C',
'if(0) then [A,B] else if(0) then [B,C] else [B,A]', 'B', 'A',
'if($req->{test}) then [A,B] else [B,C]', 'A', 'B',
'if($req->{false}) then [A,B] else [B,C]', 'B', 'C',
'[A,B] or [B,C]', 'A', 'B',
'if(1) then [A,B] or [C,A] else [B,C]', 'A', 'B',
);
while ( my $expr = shift @tests ) {
my $auth = shift @tests;
my $udb = shift @tests;
ok( authName($expr) eq $auth, qq{"$expr" returns $auth as auth module} )
or print STDERR "Expect $auth, get " . authName($expr) . "\n";
ok( userDBName($expr) eq $udb, qq{"$expr" returns $udb as userDB module} )
or print STDERR "Expect $udb, get " . userDBName($expr) . "\n";
}
ok(
_call( '[A,B] or [B,C]', 'name', 0, 1 ) eq 'B',
'"[A,B] or [B,C]" returns 2 elements'
);
ok(
_call( 'if(1) then [A,B] or [C,A] else [B,C]', 'name', 0, 1 ) eq 'C',
'"if(1) then [A,B] or [C,A] else [B,C]" returns 2 elements'
);
sub authName {
my ( $expr, $ind ) = @_;
return _call( $expr, 'name', 0, 0 );
}
sub userDBName {
my ( $expr, $ind ) = @_;
return _call( $expr, 'name', 1, 0 );
}
sub _call {
my ( $expr, $name, $type, $ind ) = @_;
$ind //= 0;
return $m->parse( $authMods, $expr )->( { test => 1 } )->[$ind]->[$type]
->($name);
}
package LLNG::Auth;
sub new {
return bless { name => $_[1] }, $_[0];
}
sub name {
$_[0]->{name};
}
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment