package Net::LDAP::Filter;
use strict;
use vars qw($VERSION);
$VERSION = "0.15";
my $ErrStr;
sub new {
my $self = shift;
my $class = ref($self) || $self;
my $me = bless {}, $class;
if (@_) {
$me->parse(shift) or
return undef;
}
$me;
}
my $Attr = '[-;.:\d\w]*[-;\d\w]';
my %Op = qw(
& and
| or
! not
= equalityMatch
~= approxMatch
>= greaterOrEqual
<= lessOrEqual
:= extensibleMatch
);
my %Rop = reverse %Op;
sub errstr { $ErrStr }
sub _unescape {
$_[0] =~ s/
\\([\da-fA-F]{2}|.)
/
length($1) == 1
? $1
: chr(hex($1))
/soxeg;
$_[0];
}
sub _escape { (my $t = $_[0]) =~ s/([\\\(\)\*\0-\37\177-\377])/sprintf("\\%02x",ord($1))/sge; $t }
sub _encode {
my($attr,$op,$val) = @_;
if ($op eq ':=') {
unless ($attr =~ /^([-;\d\w]*)(:dn)?(:(\w+|[.\d]+))?$/) {
$ErrStr = "Bad attribute $attr";
return undef;
}
my($type,$dn,$rule) = ($1,$2,$4);
return ( {
extensibleMatch => {
matchingRule => $rule,
type => length($type) ? $type : undef,
matchValue => _unescape($val),
dnAttributes => $dn ? 1 : undef
}
});
}
if ($op eq '=' && $val =~ /^(\\.|[^\\*]+)*\*/o ) {
my $n = [];
my $type = 'initial';
while ($val =~ s/^((\\.|[^\\*]+)*)\*//) {
push(@$n, { $type, _unescape("$1") }) if length($1) or $type eq 'any';
$type = 'any';
}
push(@$n, { 'final', _unescape($val) })
if length $val;
return ({
substrings => {
type => $attr,
substrings => $n
}
});
}
return {
$Op{$op} => {
attributeDesc => $attr, assertionValue => _unescape($val)
}
};
}
sub parse {
my $self = shift;
my $filter = shift;
my @stack = (); my $cur = [];
my $op;
undef $ErrStr;
if (!defined $filter) {
$ErrStr = "Undefined filter";
return undef;
}
$filter =~ s/^\s*//;
$filter = "(" . $filter . ")"
unless $filter =~ /^\(/;
while (length($filter)) {
if ($filter =~ s/^\(\s*([&!|])\s*//) {
push @stack, [$op,$cur];
$op = $1;
$cur = [];
next;
}
elsif ($filter =~ s/^\)\s*//o) {
unless (@stack) {
$ErrStr = "Bad filter, unmatched )";
return undef;
}
my($myop,$mydata) = ($op,$cur);
($op,$cur) = @{ pop @stack };
push @$cur, { $Op{$myop} => $myop eq '!' ? $mydata->[0] : $mydata };
next if @stack;
}
elsif ($filter =~ s/^\(\s*($Attr)=\*\)\s*//o) {
push(@$cur, { present => $1 } );
next if @stack;
}
elsif ($filter =~ s/^\(\s*
($Attr)\s*
([:~<>]?=)
((?:\\.|[^\\()]+)*)
\)\s*
//xo) {
push(@$cur, _encode($1,$2,$3));
next if @stack;
}
last;
}
if (length $filter) {
$ErrStr = "Bad filter, error before " . substr($filter,0,20);
return undef;
}
if (@stack) {
$ErrStr = "Bad filter, unmatched (";
return undef;
}
%$self = %{$cur->[0]};
$self;
}
sub print {
my $self = shift;
no strict 'refs'; my $fh = @_ ? shift : select;
print $fh $self->as_string,"\n";
}
sub as_string { _string(%{$_[0]}) }
sub _string { my $i;
my $str = "";
for ($_[0]) {
/^and/ and return "(&" . join("", map { _string(%$_) } @{$_[1]}) . ")";
/^or/ and return "(|" . join("", map { _string(%$_) } @{$_[1]}) . ")";
/^not/ and return "(!" . _string(%{$_[1]}) . ")";
/^present/ and return "($_[1]=*)";
/^(equalityMatch|greaterOrEqual|lessOrEqual|approxMatch)/
and return "(" . $_[1]->{attributeDesc} . $Rop{$1} . _escape($_[1]->{assertionValue}) .")";
/^substrings/ and do {
my $str = join("*", "",map { _escape($_) } map { values %$_ } @{$_[1]->{substrings}});
$str =~ s/^.// if exists $_[1]->{substrings}[0]{initial};
$str .= '*' unless exists $_[1]->{substrings}[-1]{final};
return "($_[1]->{type}=$str)";
};
/^extensibleMatch/ and do {
my $str = "(";
$str .= $_[1]->{type} if defined $_[1]->{type};
$str .= ":dn" if $_[1]->{dnAttributes};
$str .= ":$_[1]->{matchingRule}" if defined $_[1]->{matchingRule};
$str .= ":=" . _escape($_[1]->{matchValue}) . ")";
return $str;
};
}
die "Internal error $_[0]";
}
1;