1# Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
2# This program is free software; you can redistribute it and/or
3# modify it under the same terms as Perl itself.
4
5package URI::_ldap;
6
7use strict;
8
9use vars qw($VERSION);
10$VERSION = "1.10";
11
12use URI::Escape qw(uri_unescape);
13
14sub _ldap_elem {
15  my $self  = shift;
16  my $elem  = shift;
17  my $query = $self->query;
18  my @bits  = (split(/\?/,defined($query) ? $query : ""),("")x4);
19  my $old   = $bits[$elem];
20
21  if (@_) {
22    my $new = shift;
23    $new =~ s/\?/%3F/g;
24    $bits[$elem] = $new;
25    $query = join("?",@bits);
26    $query =~ s/\?+$//;
27    $query = undef unless length($query);
28    $self->query($query);
29  }
30
31  $old;
32}
33
34sub dn {
35  my $old = shift->path(@_);
36  $old =~ s:^/::;
37  uri_unescape($old);
38}
39
40sub attributes {
41  my $self = shift;
42  my $old = _ldap_elem($self,0, @_ ? join(",", map { my $tmp = $_; $tmp =~ s/,/%2C/g; $tmp } @_) : ());
43  return $old unless wantarray;
44  map { uri_unescape($_) } split(/,/,$old);
45}
46
47sub _scope {
48  my $self = shift;
49  my $old = _ldap_elem($self,1, @_);
50  return unless defined wantarray && defined $old;
51  uri_unescape($old);
52}
53
54sub scope {
55  my $old = &_scope;
56  $old = "base" unless length $old;
57  $old;
58}
59
60sub _filter {
61  my $self = shift;
62  my $old = _ldap_elem($self,2, @_);
63  return unless defined wantarray && defined $old;
64  uri_unescape($old); # || "(objectClass=*)";
65}
66
67sub filter {
68  my $old = &_filter;
69  $old = "(objectClass=*)" unless length $old;
70  $old;
71}
72
73sub extensions {
74  my $self = shift;
75  my @ext;
76  while (@_) {
77    my $key = shift;
78    my $value = shift;
79    push(@ext, join("=", map { $_="" unless defined; s/,/%2C/g; $_ } $key, $value));
80  }
81  @ext = join(",", @ext) if @ext;
82  my $old = _ldap_elem($self,3, @ext);
83  return $old unless wantarray;
84  map { uri_unescape($_) } map { /^([^=]+)=(.*)$/ } split(/,/,$old);
85}
86
87sub canonical
88{
89    my $self = shift;
90    my $other = $self->_nonldap_canonical;
91
92    # The stuff below is not as efficient as one might hope...
93
94    $other = $other->clone if $other == $self;
95
96    $other->dn(_normalize_dn($other->dn));
97
98    # Should really know about mixed case "postalAddress", etc...
99    $other->attributes(map lc, $other->attributes);
100
101    # Lowecase scope, remove default
102    my $old_scope = $other->scope;
103    my $new_scope = lc($old_scope);
104    $new_scope = "" if $new_scope eq "base";
105    $other->scope($new_scope) if $new_scope ne $old_scope;
106
107    # Remove filter if default
108    my $old_filter = $other->filter;
109    $other->filter("") if lc($old_filter) eq "(objectclass=*)" ||
110	                  lc($old_filter) eq "objectclass=*";
111
112    # Lowercase extensions types and deal with known extension values
113    my @ext = $other->extensions;
114    for (my $i = 0; $i < @ext; $i += 2) {
115	my $etype = $ext[$i] = lc($ext[$i]);
116	if ($etype =~ /^!?bindname$/) {
117	    $ext[$i+1] = _normalize_dn($ext[$i+1]);
118	}
119    }
120    $other->extensions(@ext) if @ext;
121
122    $other;
123}
124
125sub _normalize_dn  # RFC 2253
126{
127    my $dn = shift;
128
129    return $dn;
130    # The code below will fail if the "+" or "," is embedding in a quoted
131    # string or simply escaped...
132
133    my @dn = split(/([+,])/, $dn);
134    for (@dn) {
135	s/^([a-zA-Z]+=)/lc($1)/e;
136    }
137    join("", @dn);
138}
139
1401;
141