Commit | Line | Data |
3fea05b9 |
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 | |
5 | package URI::_ldap; |
6 | |
7 | use strict; |
8 | |
9 | use vars qw($VERSION); |
10 | $VERSION = "1.10"; |
11 | |
12 | use URI::Escape qw(uri_unescape); |
13 | |
14 | sub _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 | |
34 | sub dn { |
35 | my $old = shift->path(@_); |
36 | $old =~ s:^/::; |
37 | uri_unescape($old); |
38 | } |
39 | |
40 | sub 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 | |
47 | sub _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 | |
54 | sub scope { |
55 | my $old = &_scope; |
56 | $old = "base" unless length $old; |
57 | $old; |
58 | } |
59 | |
60 | sub _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 | |
67 | sub filter { |
68 | my $old = &_filter; |
69 | $old = "(objectClass=*)" unless length $old; |
70 | $old; |
71 | } |
72 | |
73 | sub 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 | |
87 | sub 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 | |
125 | sub _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 | |
140 | 1; |