[27174] | 1 | # Copyright (c) 1998 Graham Barr <[email protected]>. 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.12";
|
---|
| 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 | # Lowercase 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;
|
---|