libnet-ldap-perl 1:0.6500+dfsg-1 / usr / share / perl5 / Net / LDAP / Filter.pm

# Copyright (c) 1997-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Net::LDAP::Filter;

use strict;

our $VERSION = '0.20';

# filter       = "(" filtercomp ")"
# filtercomp   = and / or / not / item
# and          = "&" filterlist
# or           = "|" filterlist
# not          = "!" filter
# filterlist   = 1*filter
# item         = simple / present / substring / extensible
# simple       = attr filtertype value
# filtertype   = equal / approx / greater / less
# equal        = "="
# approx       = "~="
# greater      = ">="
# less         = "<="
# extensible   = attr [":dn"] [":" matchingrule] ":=" value
#                / [":dn"] ":" matchingrule ":=" value
# present      = attr "=*"
# substring    = attr "=" [initial] any [final]
# initial      = value
# any          = "*" *(value "*")
# final        = value
# attr         = AttributeDescription from Section 2.5 of RFC 4512
# matchingrule = MatchingRuleId from Section 4.1.8 of RFC 4511
# value        = AttributeValue from Section 4.1.6 of RFC 4511
#                with some characters encoded, see below.
#
# Special Character encodings
# ---------------------------
#    *               \2a, \*
#    (               \28, \(
#    )               \29, \)
#    \               \5c, \\
#    NUL             \00

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 }

# Unescape
#   \xx where xx is a 2-digit hex number
#   \y  where y is one of ( ) \ *
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 }

# encode a triplet ($attr,$op,$val) representing a single filter item
sub _encode {
  my($attr, $op, $val) = @_;

  # extensible match
  if ($op eq ':=') {

    # attr must be in the form type:dn:1.2.3.4
    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
      }
    });
  }

  # special cases: present / substring match
  if ($op eq '=') {

    # present match
    if ($val eq '*') {
      return ({ present => $attr });
    }

    # if val contains unescaped *, then we have substring match
    elsif ( $val =~ /^(\\.|[^\\*]+)*\*/o ) {

      my $n = [];
      my $type = 'initial';

      while ($val =~ s/^((\\.|[^\\*]+)*)\*//) {
	push(@$n, { $type, _unescape("$1") })         # $1 is readonly, copy it
	  if length($1) or $type eq 'any';

	$type = 'any';
      }

      push(@$n, { 'final', _unescape($val) })
	if length $val;

      return ({
	substrings => {
	  type       => $attr,
	  substrings => $n
	}
      });
    }
  }

  # in all other cases we must have an operator and no un-escaped *'s on the RHS
  return {
    $Op{$op} => {
      attributeDesc => $attr, assertionValue =>  _unescape($val)
    }
  };
}

# parse & encode a filter string
sub parse {
  my $self   = shift;
  my $filter = shift;

  my @stack = ();   # stack
  my $cur   = [];
  my $op;

  undef $ErrStr;

  # a filter is required
  if (!defined $filter) {
    $ErrStr = 'Undefined filter';
    return undef;
  }

  # Algorithm depends on /^\(/;
  $filter =~ s/^\s*//;

  $filter = '(' . $filter . ')'
    unless $filter =~ /^\(/;

  while (length($filter)) {

    # Process the start of  (<op> (...)(...)), with <op> = [&!|]

    if ($filter =~ s/^\(\s*([&!|])\s*//) {
      push @stack, [$op, $cur];
      $op = $1;
      $cur = [];
      next;
    }

    # Process the end of  (<op> (...)(...)), with <op> = [&!|]

    elsif ($filter =~ s/^\)\s*//o) {
      unless (@stack) {
	$ErrStr = 'Bad filter, unmatched )';
	return undef;
      }
      my($myop, $mydata) = ($op, $cur);
      ($op, $cur) = @{ pop @stack };
	# Need to do more checking here
      push @$cur, { $Op{$myop} => $myop eq '!' ? $mydata->[0] : $mydata };
      next  if @stack;
    }

    # process (attr op string)

    elsif ($filter =~ s/^\(\s*
                        ($Attr)\s*
                        ([:~<>]?=)
                        ((?:\\.|[^\\()]+)*)
                        \)\s*
                       //xo) {
      push(@$cur, _encode($1, $2, $3));
      next  if @stack;
    }

    # If we get here then there is an error in the filter string
    # so exit loop with data in $filter
    last;
  }

  if (length $filter) {
    # If we have anything left in the filter, then there is a problem
    $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'; # select may return a GLOB name
  my $fh = @_ ? shift : select;

  print $fh $self->as_string, "\n";
}

sub as_string { _string(%{$_[0]}) }

sub _string {    # prints things of the form (<op> (<list>) ... )
  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]";
}

sub negate {
  my $self = shift;

  %{$self} = _negate(%{$self});

  $self;
}

sub _negate {    # negate a filter tree
  for ($_[0]) {
    /^and/  and return ( 'or' => [ map { { _negate(%$_) }; } @{$_[1]} ] );
    /^or/   and return ( 'and' => [ map { { _negate(%$_) }; } @{$_[1]} ] );
    /^not/  and return %{$_[1]};
    /^(present|equalityMatch|greaterOrEqual|lessOrEqual|approxMatch|substrings|extensibleMatch)/
      and  do return ( 'not' => { $_[0 ], $_[1] } );
  }

  die "Internal error $_[0]";
}

1;