PageRenderTime 26ms CodeModel.GetById 7ms app.highlight 16ms RepoModel.GetById 1ms app.codeStats 0ms

/IronPython_Main/Runtime/Tests/LinqDlrTests/testenv/perl/site/lib/URI/ldap.pm

#
Perl | 245 lines | 169 code | 66 blank | 10 comment | 16 complexity | a1dd105c3e56d710b669c8062cca619a MD5 | raw file
  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(@ISA $VERSION);
 10$VERSION = "1.10";
 11
 12require URI::_server;
 13@ISA=qw(URI::_server);
 14
 15use URI::Escape qw(uri_unescape);
 16
 17
 18sub default_port { 389 }
 19
 20sub _ldap_elem {
 21  my $self  = shift;
 22  my $elem  = shift;
 23  my $query = $self->query;
 24  my @bits  = (split(/\?/,defined($query) ? $query : ""),("")x4);
 25  my $old   = $bits[$elem];
 26
 27  if (@_) {
 28    my $new = shift;
 29    $new =~ s/\?/%3F/g;
 30    $bits[$elem] = $new;
 31    $query = join("?",@bits);
 32    $query =~ s/\?+$//;
 33    $query = undef unless length($query);
 34    $self->query($query);
 35  }
 36
 37  $old;
 38}
 39
 40sub dn {
 41  my $old = shift->path(@_);
 42  $old =~ s:^/::;
 43  uri_unescape($old);
 44}
 45
 46sub attributes {
 47  my $self = shift;
 48  my $old = _ldap_elem($self,0, @_ ? join(",", map { my $tmp = $_; $tmp =~ s/,/%2C/g; $tmp } @_) : ());
 49  return $old unless wantarray;
 50  map { uri_unescape($_) } split(/,/,$old);
 51}
 52
 53sub _scope {
 54  my $self = shift;
 55  my $old = _ldap_elem($self,1, @_);
 56  return unless defined wantarray && defined $old;
 57  uri_unescape($old);
 58}
 59
 60sub scope {
 61  my $old = &_scope;
 62  $old = "base" unless length $old;
 63  $old;
 64}
 65
 66sub _filter {
 67  my $self = shift;
 68  my $old = _ldap_elem($self,2, @_);
 69  return unless defined wantarray && defined $old;
 70  uri_unescape($old); # || "(objectClass=*)";
 71}
 72
 73sub filter {
 74  my $old = &_filter;
 75  $old = "(objectClass=*)" unless length $old;
 76  $old;
 77}
 78
 79sub extensions {
 80  my $self = shift;
 81  my @ext;
 82  while (@_) {
 83    my $key = shift;
 84    my $value = shift;
 85    push(@ext, join("=", map { $_="" unless defined; s/,/%2C/g; $_ } $key, $value));
 86  }
 87  @ext = join(",", @ext) if @ext;
 88  my $old = _ldap_elem($self,3, @ext);
 89  return $old unless wantarray;
 90  map { uri_unescape($_) } map { /^([^=]+)=(.*)$/ } split(/,/,$old);
 91}
 92
 93sub canonical
 94{
 95    my $self = shift;
 96    my $other = $self->SUPER::canonical;
 97
 98    # The stuff below is not as efficient as one might hope...
 99
100    $other = $other->clone if $other == $self;
101
102    $other->dn(_normalize_dn($other->dn));
103
104    # Should really know about mixed case "postalAddress", etc...
105    $other->attributes(map lc, $other->attributes);
106
107    # Lowecase scope, remove default
108    my $old_scope = $other->scope;
109    my $new_scope = lc($old_scope);
110    $new_scope = "" if $new_scope eq "base";
111    $other->scope($new_scope) if $new_scope ne $old_scope;
112
113    # Remove filter if default
114    my $old_filter = $other->filter;
115    $other->filter("") if lc($old_filter) eq "(objectclass=*)" ||
116	                  lc($old_filter) eq "objectclass=*";
117
118    # Lowercase extensions types and deal with known extension values
119    my @ext = $other->extensions;
120    for (my $i = 0; $i < @ext; $i += 2) {
121	my $etype = $ext[$i] = lc($ext[$i]);
122	if ($etype =~ /^!?bindname$/) {
123	    $ext[$i+1] = _normalize_dn($ext[$i+1]);
124	}
125    }
126    $other->extensions(@ext) if @ext;
127    
128    $other;
129}
130
131sub _normalize_dn  # RFC 2253
132{
133    my $dn = shift;
134
135    return $dn;
136    # The code below will fail if the "+" or "," is embedding in a quoted
137    # string or simply escaped...
138
139    my @dn = split(/([+,])/, $dn);
140    for (@dn) {
141	s/^([a-zA-Z]+=)/lc($1)/e;
142    }
143    join("", @dn);
144}
145
1461;
147
148__END__
149
150=head1 NAME
151
152URI::ldap - LDAP Uniform Resource Locators
153
154=head1 SYNOPSIS
155
156  use URI;
157
158  $uri = URI->new("ldap:$uri_string");
159  $dn     = $uri->dn;
160  $filter = $uri->filter;
161  @attr   = $uri->attributes;
162  $scope  = $uri->scope;
163  %extn   = $uri->extensions;
164  
165  $uri = URI->new("ldap:");  # start empty
166  $uri->host("ldap.itd.umich.edu");
167  $uri->dn("o=University of Michigan,c=US");
168  $uri->attributes(qw(postalAddress));
169  $uri->scope('sub');
170  $uri->filter('(cn=Babs Jensen)');
171  print $uri->as_string,"\n";
172
173=head1 DESCRIPTION
174
175C<URI::ldap> provides an interface to parse an LDAP URI in its
176constituent parts and also build a URI as described in
177RFC 2255.
178
179=head1 METHODS
180
181C<URI::ldap> support all the generic and server methods defined by
182L<URI>, plus the following.
183
184Each of the following methods can be used to set or get the value in
185the URI. The values are passed in unescaped form.  None of these will
186return undefined values, but elements without a default can be empty.
187If arguments are given then a new value will be set for the given part
188of the URI.
189
190=over 4
191
192=item $uri->dn( [$new_dn] )
193
194Set or get the I<Distinguised Name> part of the URI.  The DN
195identifies the base object of the LDAP search.
196
197=item $uri->attributes( [@new_attrs] )
198
199Set or get the list of attribute names which will be
200returned by the search.
201
202=item $uri->scope( [$new_scope] )
203
204Set or get the scope that the search will use. The value can be one of
205C<"base">, C<"one"> or C<"sub">. If none is given in the URI then the
206return value will default to C<"base">.
207
208=item $uri->_scope( [$new_scope] )
209
210Same as scope(), but does not default to anything.
211
212=item $uri->filter( [$new_filter] )
213
214Set or get the filter that the search will use. If none is given in
215the URI then the return value will default to C<"(objectClass=*)">.
216
217=item $uri->_filter( [$new_filter] )
218
219Same as filter(), but does not default to anything.
220
221=item $uri->extensions( [$etype => $evalue,...] )
222
223Set or get the extensions used for the search. The list passed should
224be in the form etype1 => evalue1, etype2 => evalue2,... This is also
225the form of list that will be returned.
226
227=back
228
229=head1 SEE ALSO
230
231L<RFC-2255|http://www.cis.ohio-state.edu/htbin/rfc/rfc2255.html>
232
233=head1 AUTHOR
234
235Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
236
237Slightly modified by Gisle Aas to fit into the URI distribution.
238
239=head1 COPYRIGHT
240
241Copyright (c) 1998 Graham Barr. All rights reserved. This program is
242free software; you can redistribute it and/or modify it under the same
243terms as Perl itself.
244
245=cut