local-lib5/lib/perl5/URI/_ldap.pm

   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;