home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _7ce54977b13748d705bf6a90a8886738 < prev    next >
Encoding:
Text File  |  2004-06-01  |  3.3 KB  |  141 lines
  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;
  141.