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