# 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;
use vars qw($VERSION);

$VERSION = "0.15";

# 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 4.1.5 of [1]
# matchingrule = MatchingRuleId from Section 4.1.9 of [1]
# value        = AttributeValue from Section 4.1.6 of [1]
# 
# 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;

# Unescape
#   \xx where xx is a 2-digit hex number
#   \y  where y is one of ( ) \ *

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) = @_;

  # An 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
      }
    });
  }

  # If the op is = and contains one or more * not
  # preceeded by \ then do partial matches

  if ($op eq '=' && $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
      }
    });
  }

  # Well we must have an operator and no un-escaped *'s on the RHS

  return {
    $Op{$op} => {
      attributeDesc => $attr, assertionValue =>  _unescape($val)
    }
  };
}

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  (& (...)(...))

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

    # Process the end of  (& (...)(...))

    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;
    }
    
    # present is a special case (attr=*)

    elsif ($filter =~ s/^\(\s*($Attr)=\*\)\s*//o) {
      push(@$cur, { present => $1 } );
      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 $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;