81 lines
2.3 KiB
Perl
81 lines
2.3 KiB
Perl
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};
|
|
}
|