CVS: ispman/lib/Net/LDAP ASN.pm,1.3,1.4 Bind.pm,1.3,1.4 Constant.pm,1.3,1.4 Control.pm,1.3,1.4 DSML.pm,1.3,1.4 Entry.pm,1.3,1.4 Filter.pm,1.3,1.4 LDIF.pm,1.3,1.4 Message.pm,1.3,1.4 Schema.pm,1.3,1.4 Search.pm,1.3,1.4 Util.pm,1.3,1.4 RootDSE.pm,1.1,NONE
Joerg Delker <[email protected]>
| Newsgroups | gmane.comp.isp.ispman.cvs |
|---|---|
| Message-ID | <[email protected]> |
Update of /cvsroot/ispman/ispman/lib/Net/LDAP
In directory sc8-pr-cvs1:/tmp/cvs-serv23200/lib/Net/LDAP
Modified Files:
ASN.pm Bind.pm Constant.pm Control.pm DSML.pm Entry.pm
Filter.pm LDIF.pm Message.pm Schema.pm Search.pm Util.pm
Removed Files:
RootDSE.pm
Log Message:
rollback of HEAD to REL_1_0 versions
former HEAD development will continue in "experimental-branch" and merged back here
(more info on ispman-developer maillist and upcoming README.cvs in HEAD)
Index: ASN.pm
===================================================================
RCS file: /cvsroot/ispman/ispman/lib/Net/LDAP/ASN.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -r1.3 -r1.4
*** ASN.pm 29 Jul 2003 12:47:06 -0000 1.3
--- ASN.pm 4 Jan 2004 18:56:15 -0000 1.4
***************
*** 3,8 ****
package Net::LDAP::ASN;
- $VERSION = "0.02";
-
use Convert::ASN1;
--- 3,6 ----
***************
*** 315,320 ****
sortControlMissing (60),
indexRangeError (61),
! other (80) }
! contextID OCTET STRING OPTIONAL }
--- 313,317 ----
sortControlMissing (60),
indexRangeError (61),
! other (80) } }
Index: Bind.pm
===================================================================
RCS file: /cvsroot/ispman/ispman/lib/Net/LDAP/Bind.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -r1.3 -r1.4
*** Bind.pm 29 Jul 2003 12:47:06 -0000 1.3
--- Bind.pm 4 Jan 2004 18:56:15 -0000 1.4
***************
*** 6,10 ****
use strict;
! use Net::LDAP qw(LDAP_SASL_BIND_IN_PROGRESS LDAP_DECODING_ERROR LDAP_SUCCESS);
use Net::LDAP::Message;
use vars qw(@ISA);
--- 6,10 ----
use strict;
! use Net::LDAP qw(LDAP_SASL_BIND_IN_PROGRESS LDAP_DECODING_ERROR);
use Net::LDAP::Message;
use vars qw(@ISA);
***************
*** 24,33 ****
and return;
- my $sasl = $self->{sasl};
- my $ldap = $self->parent;
-
- $ldap->{net_ldap_socket} = $sasl->securesocket($ldap->{net_ldap_socket})
- if $sasl and $bind->{resultCode} == LDAP_SUCCESS;
-
return $self->SUPER::decode($result)
unless $bind->{resultCode} == LDAP_SASL_BIND_IN_PROGRESS;
--- 24,27 ----
***************
*** 35,46 ****
# tell our LDAP client to forget us as this message has now completed
# all communications with the server
! $ldap->_forgetmesg($self);
$self->{mesgid} = Net::LDAP::Message->NewMesgID(); # Get a new message ID
! my $resp = $sasl->client_step($bind->{serverSaslCreds});
!
! $self->set_error(LDAP_DECODING_ERROR,"LDAP decode error"), return
! unless defined $resp;
$self->encode(
--- 29,39 ----
# tell our LDAP client to forget us as this message has now completed
# all communications with the server
! $self->parent->_forgetmesg($self);
$self->{mesgid} = Net::LDAP::Message->NewMesgID(); # Get a new message ID
! my $sasl = $self->{sasl};
! my $ldap = $self->parent;
! my $resp = $sasl->challenge($bind->{serverSaslCreds});
$self->encode(
***************
*** 50,54 ****
authentication => {
sasl => {
! mechanism => $sasl->mechanism,
credentials => $resp
}
--- 43,47 ----
authentication => {
sasl => {
! mechanism => $sasl->name,
credentials => $resp
}
Index: Constant.pm
===================================================================
RCS file: /cvsroot/ispman/ispman/lib/Net/LDAP/Constant.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -r1.3 -r1.4
*** Constant.pm 29 Jul 2003 12:47:06 -0000 1.3
--- Constant.pm 4 Jan 2004 18:56:15 -0000 1.4
***************
*** 1,3 ****
! # Copyright (c) 1998-2003 Graham Barr <[email protected]>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
--- 1,3 ----
! # Copyright (c) 1998-2000 Graham Barr <[email protected]>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
***************
*** 5,507 ****
package Net::LDAP::Constant;
! $VERSION = "0.02";
! use Carp;
!
! my %const;
!
! sub import {
! shift;
! my $callpkg = caller(0);
! _find(@_);
! my $oops;
! my $all = grep /:all/, @_;
! foreach my $sym ($all ? keys %const : @_) {
! if (my $sub = $const{$sym}) {
! *{$callpkg . "::$sym"} = $sub;
! }
! else {
! ++$oops;
! carp(qq["$sym" is not exported by the Net::LDAP::Constant module]);
! }
! }
! croak("Can't continue after import errors") if $oops;
! }
!
! sub _find {
! if (my @need = grep { ! $const{$_} } @_) {
! my %need; @need{@need} = ();
! my $all = exists $need{':all'};
! seek(DATA,0,0);
! local $/=''; # paragraph mode
! local $_;
! while(<DATA>) {
! next unless /^=item\s+(LDAP_\S+)\s+\((.*)\)/ and ($all or exists $need{$1});
! my ($name, $value) = ($1,$2);
! delete $need{$name};
! $const{$name} = sub () { $value };
! last unless keys %need;
! }
! }
! @const{@_};
! }
!
! sub AUTOLOAD {
! (my $name = $AUTOLOAD) =~ s/^.*:://;
! my $sub = _find($name) or croak("Undefined subroutine &$AUTOLOAD");
! my $val = &$sub; # Avoid prototype error caused by *$AUTOLOAD = $sub
! *$AUTOLOAD = sub { $val };
! goto &$AUTOLOAD;
! }
!
! # These subs are really in Net::LDAP::Util, but need to access <DATA>
! # so its easier for them to be here.
!
! my @err2name;
!
! sub Net::LDAP::Util::ldap_error_name {
! my $code = 0 + (ref($_[0]) ? $_[0]->code : $_[0]);
!
! unless (@err2name) {
! seek(DATA,0,0);
! local $/=''; # paragraph mode
! local $_;
! my $n = -1;
! while(<DATA>) {
! last if /^=head2/ and ++$n;
! next if $n;
! $err2name[$2] = $1 if /^=item\s+(LDAP_\S+)\s+\((\d+)\)/;
! }
! }
! $err2name[$code] || sprintf("LDAP error code %d(0x%02X)",$code,$code);
! }
!
!
! sub Net::LDAP::Util::ldap_error_text {
! my $code = 0 + (ref($_[0]) ? $_[0]->code : $_[0]);
! my $text;
!
! seek(DATA,0,0);
! local $/=''; # paragraph mode
! local $_;
! my $n = -1;
! while(<DATA>) {
! last if /^=head2/ and ++$n;
! next if $n;
! if (/^=item\s+(LDAP_\S+)\s+\((\d+)\)/) {
! last if defined $text;
! $text = '' if $2 == $code;
! }
! elsif (defined $text) {
! $text .= $_;
! }
! }
!
! if (defined $text) {
! # Do some cleanup. Really should use a proper pod parser here.
!
! $text =~ s/^=item\s+\*\s+/ * /msg;
! $text =~ s/^=(over\s*\d*|back)//msg;
! $text =~ s/ +\n//g;
! $text =~ s/\n\n+/\n\n/g;
! $text =~ s/\n+\Z/\n/ if defined $text;
! }
!
! return $text;
! }
1;
-
- __DATA__
-
- =head1 NAME
-
- Net::LDAP::Constant - Constants for use with Net::LDAP
-
- =head1 SYNOPSIS
-
- use Net::LDAP qw(LDAP_SUCCESS LDAP_PROTOCOL_ERROR);
-
- =head1 DESCRIPTION
-
- B<Net::LDAP::Constant> exports constant subroutines for the following LDAP
- error codes.
-
- =head2 Protocol Constants
-
- =over 4
-
- =item LDAP_SUCCESS (0)
-
- Operation completed without error
-
- =item LDAP_OPERATIONS_ERROR (1)
-
- Server encountered an internal error
-
- =item LDAP_PROTOCOL_ERROR (2)
-
- Unrecognized version number or incorrect PDU structure
-
- =item LDAP_TIMELIMIT_EXCEEDED (3)
-
- The time limit on a search operation has been exceeded
-
- =item LDAP_SIZELIMIT_EXCEEDED (4)
-
- The maximum number of search results to return has been exceeded.
-
- =item LDAP_COMPARE_FALSE (5)
-
- This code is returned when a compare request completes and the attribute value
- given is not in the entry specified
-
- =item LDAP_COMPARE_TRUE (6)
-
- This code is returned when a compare request completes and the attribute value
- given is in the entry specified
-
- =item LDAP_AUTH_METHOD_NOT_SUPPORTED (7)
-
- Unrecognized SASL mechanism name
-
- =item LDAP_STRONG_AUTH_NOT_SUPPORTED (7)
-
- Unrecognized SASL mechanism name
-
- =item LDAP_STRONG_AUTH_REQUIRED (8)
-
- The server requires authentication be performed with a SASL mechanism
-
- =item LDAP_PARTIAL_RESULTS (9)
-
- Returned to version 2 clients when a referral is returned. The response
- will contain a list of URL's for other servers.
-
- =item LDAP_REFERRAL (10)
-
- The server is referring the client to another server. The response will
- contain a list of URL's
-
- =item LDAP_ADMIN_LIMIT_EXCEEDED (11)
-
- The server has exceed the maximum number of entries to search while gathering
- a list of search result candidates
-
- =item LDAP_UNAVAILABLE_CRITICAL_EXT (12)
-
- A control or matching rule specified in the request is not supported by
- the server
-
- =item LDAP_CONFIDENTIALITY_REQUIRED (13)
-
- This result code is returned when confidentiality is required to perform
- a given operation
-
- =item LDAP_SASL_BIND_IN_PROGRESS (14)
-
- The server requires the client to send a new bind request, with the same SASL
- mechanism, to continue the authentication process
-
- =item LDAP_NO_SUCH_ATTRIBUTE (16)
-
- The request referenced an attribute that does not exist
-
- =item LDAP_UNDEFINED_TYPE (17)
-
- The request contains an undefined attribute type
-
- =item LDAP_INAPPROPRIATE_MATCHING (18)
-
- An extensible matching rule in the given filter does not apply to the specified
- attribute
-
- =item LDAP_CONSTRAINT_VIOLATION (19)
-
- The request contains a value which does not meet with certain constraints.
- This result can be returned as a consequence of
-
- =over 4
-
- =item *
-
- The request was to add or modify a user password, and the password fails to
- meet the criteria the server is configured to check. This could be that the
- password is too short, or a recognizable word (e.g. it matches one of the
- attributes in the users entry) or it matches a previous password used by
- the same user.
-
- =item *
-
- The request is a bind request to a user account that has been locked
-
- =back
-
- =item LDAP_TYPE_OR_VALUE_EXISTS (20)
-
- The request attempted to add an attribute type or value that already exists
-
- =item LDAP_INVALID_SYNTAX (21)
-
- Some part of the request contained an invalid syntax. It could be a search
- with an invalid filter or a request to modify the schema and the given
- schema has a bad syntax.
-
- =item LDAP_NO_SUCH_OBJECT (32)
-
- The server cannot find an object specified in the request
-
- =item LDAP_ALIAS_PROBLEM (33)
-
- Server encountered a problem while attempting to dereference an alias
-
- =item LDAP_INVALID_DN_SYNTAX (34)
-
- The request contained an invalid DN
-
- =item LDAP_IS_LEAF (35)
-
- The specified entry is a leaf entry
-
- =item LDAP_ALIAS_DEREF_PROBLEM (36)
-
- Server encountered a problem while attempting to dereference an alias
-
- =item LDAP_INAPPROPRIATE_AUTH (48)
-
- The server requires the client which had attempted to bind anonymously or
- without supplying credentials to provide some form of credentials
-
- =item LDAP_INVALID_CREDENTIALS (49)
-
- The wrong password was supplied or the SASL credentials could not be processed
-
- =item LDAP_INSUFFICIENT_ACCESS (50)
-
- The client does not have sufficient access to perform the requested
- operation
-
- =item LDAP_BUSY (51)
-
- The server is too busy to perform requested operation
-
- =item LDAP_UNAVAILABLE (52)
-
- The server in unavailable to perform the request, or the server is
- shutting down
-
- =item LDAP_UNWILLING_TO_PERFORM (53)
-
- The server is unwilling to perform the requested operation
-
- =item LDAP_LOOP_DETECT (54)
-
- The server was unable to perform the request due to an internal loop detected
-
- =item LDAP_SORT_CONTROL_MISSING (60)
-
- The search contained a "virtual list view" control, but not a server-side
- sorting control, which is required when a "virtual list view" is given.
-
- =item LDAP_INDEX_RANGE_ERROR (61)
-
- The search contained a control for a "virtual list view" and the results
- exceeded the range specified by the requested offsets.
-
- =item LDAP_NAMING_VIOLATION (64)
-
- The request violates the structure of the DIT
-
- =item LDAP_OBJECT_CLASS_VIOLATION (65)
-
- The request specifies a change to an existing entry or the addition of a new
- entry that does not comply with the servers schema
-
- =item LDAP_NOT_ALLOWED_ON_NONLEAF (66)
-
- The requested operation is not allowed on an entry that has child entries
-
- =item LDAP_NOT_ALLOWED_ON_RDN (67)
-
- The requested operation ill affect the RDN of the entry
-
- =item LDAP_ALREADY_EXISTS (68)
-
- The client attempted to add an entry that already exists. This can occur as
- a result of
-
- =over 4
-
- =item *
-
- An add request was submitted with a DN that already exists
-
- =item *
-
- A modify DN requested was submitted, where the requested new DN already exists
-
- =item *
-
- The request is adding an attribute to the schema and an attribute with the
- given OID or name already exists
-
- =back
-
- =item LDAP_NO_OBJECT_CLASS_MODS (69)
-
- Request attempt to modify the object class of an entry that should not be
- modified
-
- =item LDAP_RESULTS_TOO_LARGE (70)
-
- The results of the request are to large
-
- =item LDAP_AFFECTS_MULTIPLE_DSAS (71)
-
- The requested operation needs to be performed on multiple servers where
- the requested operation is not permitted
-
- =item LDAP_OTHER (80)
-
- An unknown error has occurred
-
- =item LDAP_SERVER_DOWN (81)
-
- C<Net::LDAP> cannot establish a connection or the connection has been lost
-
- =item LDAP_LOCAL_ERROR (82)
-
- An error occurred in C<Net::LDAP>
-
- =item LDAP_ENCODING_ERROR (83)
-
- C<Net::LDAP> encountered an error while encoding the request packet that would
- have been sent to the server
-
- =item LDAP_DECODING_ERROR (84)
-
- C<Net::LDAP> encountered an error while decoding a response packet from
- the server.
-
- =item LDAP_TIMEOUT (85)
-
- C<Net::LDAP> timeout while waiting for a response from the server
-
- =item LDAP_AUTH_UNKNOWN (86)
-
- The method of authentication requested in a bind request is unknown to
- the server
-
- =item LDAP_FILTER_ERROR (87)
-
- An error occurred while encoding the given search filter.
-
- =item LDAP_USER_CANCELED (88)
-
- The user canceled the operation
-
- =item LDAP_PARAM_ERROR (89)
-
- An invalid parameter was specified
-
- =item LDAP_NO_MEMORY (90)
-
- Out of memory error
-
- =item LDAP_CONNECT_ERROR (91)
-
- A connection to the server could not be established
-
- =item LDAP_NOT_SUPPORTED (92)
-
- An attempt has been made to use a feature not supported by Net::LDAP
-
- =item LDAP_CONTROL_NOT_FOUND (93)
-
- The controls required to perform the requested operation were not
- found.
-
- =item LDAP_NO_RESULTS_RETURNED (94)
-
- No results were returned from the server.
-
- =item LDAP_MORE_RESULTS_TO_RETURN (95)
-
- There are more results in the chain of results.
-
- =item LDAP_CLIENT_LOOP (96)
-
- A loop has been detected. For example when following referals.
-
- =item LDAP_REFERRAL_LIMIT_EXCEEDED (97)
-
- The referral hop limit has been exceeded.
-
- =back
-
- =head2 Control OIDs
-
- =item LDAP_CONTROL_SORTREQUEST (1.2.840.113556.1.4.473)
-
- =item LDAP_CONTROL_SORTRESULT (1.2.840.113556.1.4.474)
-
- =item LDAP_CONTROL_VLVREQUEST (2.16.840.1.113730.3.4.9)
-
- =item LDAP_CONTROL_VLVRESPONSE (2.16.840.1.113730.3.4.10)
-
- =item LDAP_CONTROL_PROXYAUTHENTICATION (2.16.840.1.113730.3.4.12)
-
- =item LDAP_CONTROL_PAGED (1.2.840.113556.1.4.319)
-
- =item LDAP_CONTROL_TREE_DELETE (1.2.840.113556.1.4.805)
-
- =item LDAP_CONTROL_MATCHEDVALS (1.2.826.0.1.3344810.2.2)
-
- =item LDAP_CONTROL_MANAGEDSAIT (2.16.840.1.113730.3.4.2)
-
- =item LDAP_CONTROL_PERSISTENTSEARCH (2.16.840.1.113730.3.4.3)
-
- =item LDAP_CONTROL_ENTRYCHANGE (2.16.840.1.113730.3.4.7)
-
- =item LDAP_CONTROL_PWEXPIRED (2.16.840.1.113730.3.4.4)
-
- =item LDAP_CONTROL_PWEXPIRING (2.16.840.1.113730.3.4.5)
-
- =item LDAP_CONTROL_REFERRALS (1.2.840.113556.1.4.616)
-
- =head2 Extension OIDs
-
- B<Net::LDAP::Constant> exports constant subroutines for the following LDAP
- extension OIDs.
-
- =over 4
-
- =item LDAP_EXTENSION_START_TLS (1.3.6.1.4.1.1466.20037)
-
- Indicates if the server supports the Start TLS extension (RFC-2830)
-
- =back
-
- =head1 SEE ALSO
-
- L<Net::LDAP>,
- L<Net::LDAP::Message>
-
- =head1 AUTHOR
-
- Graham Barr E<lt>gbarr-e+AXbWqSrlAb/[email protected]<gt>
-
- Please report any bugs, or post any suggestions, to the perl-ldap mailing list
- E<lt>[email protected]<gt>
-
- =head1 COPYRIGHT
-
- Copyright (c) 1998-2003 Graham Barr. All rights reserved. This program is
- free software; you can redistribute it and/or modify it under the same
- terms as Perl itself.
-
- =for html <hr>
-
- I<$Id$>
-
- =cut
--- 5,108 ----
package Net::LDAP::Constant;
! use Exporter ();
! @ISA = qw(Exporter);
! @EXPORT_OK = ( grep /^LDAP_/, keys %{'Net::LDAP::Constant::'} );
! %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
!
! ##
! ## The constants
! ##
!
! sub LDAP_SUCCESS () { 0x00 }
! sub LDAP_OPERATIONS_ERROR () { 0x01 }
! sub LDAP_PROTOCOL_ERROR () { 0x02 }
! sub LDAP_TIMELIMIT_EXCEEDED () { 0x03 }
! sub LDAP_SIZELIMIT_EXCEEDED () { 0x04 }
! sub LDAP_COMPARE_FALSE () { 0x05 }
! sub LDAP_COMPARE_TRUE () { 0x06 }
! sub LDAP_STRONG_AUTH_NOT_SUPPORTED () { 0x07 }
! sub LDAP_AUTH_METHOD_NOT_SUPPORTED () { 0x07 }
! sub LDAP_STRONG_AUTH_REQUIRED () { 0x08 }
! sub LDAP_PARTIAL_RESULTS () { 0x09 }
! sub LDAP_REFERRAL () { 0x0a } # V3
! sub LDAP_ADMIN_LIMIT_EXCEEDED () { 0x0b } # V3
! sub LDAP_UNAVAILABLE_CRITICAL_EXT () { 0x0c } # V3
! sub LDAP_CONFIDENTIALITY_REQUIRED () { 0x0d } # V3
! sub LDAP_SASL_BIND_IN_PROGRESS () { 0x0e } # V3
!
! sub LDAP_NO_SUCH_ATTRIBUTE () { 0x10 }
! sub LDAP_UNDEFINED_TYPE () { 0x11 }
! sub LDAP_INAPPROPRIATE_MATCHING () { 0x12 }
! sub LDAP_CONSTRAINT_VIOLATION () { 0x13 }
! sub LDAP_TYPE_OR_VALUE_EXISTS () { 0x14 }
! sub LDAP_INVALID_SYNTAX () { 0x15 }
!
! sub LDAP_NO_SUCH_OBJECT () { 0x20 }
! sub LDAP_ALIAS_PROBLEM () { 0x21 }
! sub LDAP_INVALID_DN_SYNTAX () { 0x22 }
! sub LDAP_IS_LEAF () { 0x23 }
! sub LDAP_ALIAS_DEREF_PROBLEM () { 0x24 }
!
! sub LDAP_INAPPROPRIATE_AUTH () { 0x30 }
! sub LDAP_INVALID_CREDENTIALS () { 0x31 }
! sub LDAP_INSUFFICIENT_ACCESS () { 0x32 }
! sub LDAP_BUSY () { 0x33 }
! sub LDAP_UNAVAILABLE () { 0x34 }
! sub LDAP_UNWILLING_TO_PERFORM () { 0x35 }
! sub LDAP_LOOP_DETECT () { 0x36 }
!
! sub LDAP_SORT_CONTROL_MISSING () { 0x3C }
! sub LDAP_INDEX_RANGE_ERROR () { 0x3D }
!
! sub LDAP_NAMING_VIOLATION () { 0x40 }
! sub LDAP_OBJECT_CLASS_VIOLATION () { 0x41 }
! sub LDAP_NOT_ALLOWED_ON_NONLEAF () { 0x42 }
! sub LDAP_NOT_ALLOWED_ON_RDN () { 0x43 }
! sub LDAP_ALREADY_EXISTS () { 0x44 }
! sub LDAP_NO_OBJECT_CLASS_MODS () { 0x45 }
! sub LDAP_RESULTS_TOO_LARGE () { 0x46 }
! sub LDAP_AFFECTS_MULTIPLE_DSAS () { 0x47 } # V3
!
! sub LDAP_OTHER () { 0x50 }
! sub LDAP_SERVER_DOWN () { 0x51 }
! sub LDAP_LOCAL_ERROR () { 0x52 }
! sub LDAP_ENCODING_ERROR () { 0x53 }
! sub LDAP_DECODING_ERROR () { 0x54 }
! sub LDAP_TIMEOUT () { 0x55 }
! sub LDAP_AUTH_UNKNOWN () { 0x56 }
! sub LDAP_FILTER_ERROR () { 0x57 }
! sub LDAP_USER_CANCELED () { 0x58 }
! sub LDAP_PARAM_ERROR () { 0x59 }
! sub LDAP_NO_MEMORY () { 0x5a }
! sub LDAP_CONNECT_ERROR () { 0x5b }
! sub LDAP_NOT_SUPPORTED () { 0x5c } # V3
! sub LDAP_CONTROL_NOT_FOUND () { 0x5d } # V3
! sub LDAP_NO_RESULTS_RETURNED () { 0x5e } # V3
! sub LDAP_MORE_RESULTS_TO_RETURN () { 0x5f } # V3
! sub LDAP_CLIENT_LOOP () { 0x60 } # V3
! sub LDAP_REFERRAL_LIMIT_EXCEEDED () { 0x61 } # V3
!
! # LDAP Controls
!
! sub LDAP_CONTROL_SORTREQUEST () { "1.2.840.113556.1.4.473" }
! sub LDAP_CONTROL_SORTRESULT () { "1.2.840.113556.1.4.474" }
!
! sub LDAP_CONTROL_VLVREQUEST () { "2.16.840.1.113730.3.4.9" }
! sub LDAP_CONTROL_VLVRESPONSE () { "2.16.840.1.113730.3.4.10" }
! sub LDAP_CONTROL_PROXYAUTHENTICATION () { "2.16.840.1.113730.3.4.12" }
!
! sub LDAP_CONTROL_PAGED () { "1.2.840.113556.1.4.319" }
!
! sub LDAP_CONTROL_MATCHEDVALS () { "1.2.826.0.1.3344810.2.2" }
!
! sub LDAP_CONTROL_MANAGEDSAIT () { "2.16.840.1.113730.3.4.2" }
! sub LDAP_CONTROL_PERSISTENTSEARCH () { "2.16.840.1.113730.3.4.3" }
! sub LDAP_CONTROL_ENTRYCHANGE () { "2.16.840.1.113730.3.4.7" }
! # Password information sent back to client
! sub LDAP_CONTROL_PWEXPIRED () { "2.16.840.1.113730.3.4.4" }
! sub LDAP_CONTROL_PWEXPIRING () { "2.16.840.1.113730.3.4.5" }
! # Client controls we know about
! sub LDAP_CONTROL_REFERRALS () { "1.2.840.113556.1.4.616" }
1;
Index: Control.pm
===================================================================
RCS file: /cvsroot/ispman/ispman/lib/Net/LDAP/Control.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -r1.3 -r1.4
*** Control.pm 29 Jul 2003 12:47:06 -0000 1.3
--- Control.pm 4 Jan 2004 18:56:15 -0000 1.4
***************
*** 6,21 ****
package Net::LDAP::Control;
use vars qw($VERSION);
use strict;
- use Net::LDAP::Constant qw(
- LDAP_CONTROL_SORTREQUEST
- LDAP_CONTROL_SORTRESULT
- LDAP_CONTROL_VLVREQUEST
- LDAP_CONTROL_VLVRESPONSE
- LDAP_CONTROL_PAGED
- LDAP_CONTROL_PROXYAUTHENTICATION
- );
-
$VERSION = "0.04";
--- 6,13 ----
package Net::LDAP::Control;
+ use Net::LDAP::Constant qw(/^LDAP_CONTROL/);
use vars qw($VERSION);
use strict;
$VERSION = "0.04";
***************
*** 26,30 ****
'Net::LDAP::Control::VLV' => LDAP_CONTROL_VLVREQUEST,
! 'Net::LDAP::Control::VLVResponse' => LDAP_CONTROL_VLVRESPONSE,
'Net::LDAP::Control::Paged' => LDAP_CONTROL_PAGED,
--- 18,22 ----
'Net::LDAP::Control::VLV' => LDAP_CONTROL_VLVREQUEST,
! 'Net::LDAP::Control::VLVResponse' => LDAP_CONTROL_VLVRESPONSE,
'Net::LDAP::Control::Paged' => LDAP_CONTROL_PAGED,
***************
*** 93,97 ****
delete $asn->{error};
!
bless($asn, $class)->init;
}
--- 85,89 ----
delete $asn->{error};
!
bless($asn, $class)->init;
}
***************
*** 281,288 ****
=head1 AUTHOR
! Graham Barr E<lt>gbarr-e+AXbWqSrlAb/[email protected]<gt>
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
! E<lt>[email protected]<gt>
=head1 COPYRIGHT
--- 273,280 ----
=head1 AUTHOR
! Graham Barr <[email protected]>
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
! <[email protected]>
=head1 COPYRIGHT
Index: DSML.pm
===================================================================
RCS file: /cvsroot/ispman/ispman/lib/Net/LDAP/DSML.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -r1.3 -r1.4
*** DSML.pm 29 Jul 2003 12:47:06 -0000 1.3
--- DSML.pm 4 Jan 2004 18:56:15 -0000 1.4
***************
*** 1,688 ****
package Net::LDAP::DSML;
! #
! # $Id$
#
use strict;
- use vars qw(@ISA $VERSION);
- use Carp;
- use XML::SAX::Base;
[...1175 lines suppressed...]
! Copyright (c) 2002 Graham Barr. All rights reserved. This program is
free software; you can redistribute it and/or modify it under the same
terms as Perl itself.
--- 321,336 ----
callback routine.
=head1 AUTHOR
! Mark Wilcox mark-DQ8DaQOu1HtWk0Htik3J/[email protected]
=head1 SEE ALSO
L<Net::LDAP>,
! L<XML::Parser>
=head1 COPYRIGHT
! Copyright (c) 2000 Graham Barr and Mark Wilcox. All rights reserved. This program is
free software; you can redistribute it and/or modify it under the same
terms as Perl itself.
Index: Entry.pm
===================================================================
RCS file: /cvsroot/ispman/ispman/lib/Net/LDAP/Entry.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -r1.3 -r1.4
*** Entry.pm 29 Jul 2003 12:47:06 -0000 1.3
--- Entry.pm 4 Jan 2004 18:56:15 -0000 1.4
***************
*** 10,14 ****
use vars qw($VERSION);
! $VERSION = "0.20";
sub new {
--- 10,14 ----
use vars qw($VERSION);
! $VERSION = "0.15";
sub new {
***************
*** 21,47 ****
}
- sub clone {
- my $self = shift;
- my $clone = $self->new();
-
- $clone->dn($self->dn());
- foreach ($self->attributes()) {
- $clone->add($_ => [$self->get_value($_)]);
- }
-
- $clone->{changetype} = $self->{changetype};
- my @changes = @{$self->{changes}};
- while (my($action, $cmd) = splice(@changes,0,2)) {
- my @new_cmd;
- my @cmd = @$cmd;
- while (my($type, $val) = splice(@cmd,0,2)) {
- push @new_cmd, $type, [ @$val ];
- }
- push @{$clone->{changes}}, $action, \@new_cmd;
- }
-
- $clone;
- }
-
# Build attrs cache, created when needed
--- 21,24 ----
***************
*** 102,106 ****
if ($opt{alloptions}) {
my %ret = map {
! $_->{type} =~ /^\Q$type\E((?:;.*)?)$/i ? (lc($1), $_->{vals}) : ()
} @{$self->{asn}{attributes}};
return %ret ? \%ret : undef;
--- 79,83 ----
if ($opt{alloptions}) {
my %ret = map {
! $_->{type} =~ /^\Q$type\E(.*)/ ? (lc($1), $_->{vals}) : ()
} @{$self->{asn}{attributes}};
return %ret ? \%ret : undef;
***************
*** 266,270 ****
my $asn = $self->{asn};
print "-" x 72,"\n";
! print "dn:",$asn->{objectName},"\n\n" if $asn->{objectName};
my($attr,$val);
--- 243,247 ----
my $asn = $self->{asn};
print "-" x 72,"\n";
! print "dn:",$asn->{objectName},"\n\n";
my($attr,$val);
***************
*** 311,316 ****
sub changes {
! my $ref = shift->{'changes'};
! $ref ? @$ref : ();
}
--- 288,292 ----
sub changes {
! @{shift->{'changes'}}
}
Index: Filter.pm
===================================================================
RCS file: /cvsroot/ispman/ispman/lib/Net/LDAP/Filter.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -r1.3 -r1.4
*** Filter.pm 29 Jul 2003 12:47:06 -0000 1.3
--- Filter.pm 4 Jan 2004 18:56:15 -0000 1.4
***************
*** 8,12 ****
use vars qw($VERSION);
! $VERSION = "0.14";
# filter = "(" filtercomp ")"
--- 8,12 ----
use vars qw($VERSION);
! $VERSION = "0.12";
# filter = "(" filtercomp ")"
***************
*** 89,93 ****
}
! sub _escape { (my $t = $_[0]) =~ s/([\\\(\)\*\0-\37])/sprintf("\\%02x",ord($1))/sge; $t }
sub _encode {
--- 89,95 ----
}
! my %ch = split(/\s+/, '( \\( ) \\) \\ \\\\ * \\*');
!
! sub _escape { (my $t = $_[0]) =~ s/([\\\(\)\*\0-\37])/$ch{$1}||sprintf("\\%02x",ord($1))/sge; $t }
sub _encode {
***************
*** 108,114 ****
extensibleMatch => {
matchingRule => $rule,
! type => length($type) ? $type : undef,
matchValue => _unescape($val),
! dnAttributes => $dn ? 1 : undef
}
});
--- 110,116 ----
extensibleMatch => {
matchingRule => $rule,
! type => $type,
matchValue => _unescape($val),
! dnAttributes => $dn ? 1 : 0
}
});
***************
*** 123,129 ****
my $type = 'initial';
! while ($val =~ s/^((\\.|[^\\*]+)*)\*//) {
push(@$n, { $type, _unescape("$1") }) # $1 is readonly, copy it
! if length($1) or $type eq 'any';
$type = 'any';
--- 125,131 ----
my $type = 'initial';
! while ($val =~ s/^((\\.|[^\\*]+)*)\*+//) {
push(@$n, { $type, _unescape("$1") }) # $1 is readonly, copy it
! if length $1;
$type = 'any';
***************
*** 258,263 ****
};
/^extensibleMatch/ and do {
! my $str = "(";
! $str .= $_[1]->{type} if defined $_[1]->{type};
$str .= ":dn" if $_[1]->{dnAttributes};
$str .= ":$_[1]->{matchingRule}" if defined $_[1]->{matchingRule};
--- 260,264 ----
};
/^extensibleMatch/ and do {
! my $str = "($_[1]->{type}";
$str .= ":dn" if $_[1]->{dnAttributes};
$str .= ":$_[1]->{matchingRule}" if defined $_[1]->{matchingRule};
Index: LDIF.pm
===================================================================
RCS file: /cvsroot/ispman/ispman/lib/Net/LDAP/LDIF.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -r1.3 -r1.4
*** LDIF.pm 29 Jul 2003 12:47:06 -0000 1.3
--- LDIF.pm 4 Jan 2004 18:56:15 -0000 1.4
***************
*** 10,14 ****
use vars qw($VERSION);
! $VERSION = "0.13";
my %mode = qw(w > r < a >>);
--- 10,14 ----
use vars qw($VERSION);
! $VERSION = "0.09";
my %mode = qw(w > r < a >>);
***************
*** 37,43 ****
require Symbol;
$fh = Symbol::gensym();
! my $open = $file =~ /^\| | \|$/x
! ? $file
! : (($mode{$mode} || "<") . $file);
open($fh,$open) or return;
$opened_fh = 1;
--- 37,41 ----
require Symbol;
$fh = Symbol::gensym();
! my $open = ($mode{$mode} || "<") . $file;
open($fh,$open) or return;
$opened_fh = 1;
***************
*** 63,67 ****
opened_fh => $opened_fh,
eof => 0,
- write_count => ($mode eq 'a' and tell($fh) > 0) ? 1 : 0,
};
--- 61,64 ----
***************
*** 83,99 ****
return;
}
- $ln =~ s/\n //sg;
$ln =~ s/^#.*\n//mg;
chomp($ln);
$self->{_current_lines} = $ln;
chomp(@ldif = split(/^/, $ln));
! do {
! $ln = scalar <$fh> || '';
! $self->eof(1) unless $ln;
! $ln =~ s/\n //sg;
! $ln =~ s/^#.*\n//mg;
! chomp($ln);
! $self->{_next_lines} = $ln;
! } until ($self->{_next_lines} || $self->eof());
}
--- 80,90 ----
return;
}
$ln =~ s/^#.*\n//mg;
+ $ln =~ s/\n //sg;
chomp($ln);
$self->{_current_lines} = $ln;
chomp(@ldif = split(/^/, $ln));
! $self->{_next_lines} = scalar <$fh> || '';
! $self->eof(1) unless $self->{_next_lines};
}
***************
*** 115,125 ****
shift @ldif if @ldif && $ldif[0] !~ /\D/;
- if (@ldif and $ldif[0] =~ /^version:\s+(\d+)/) {
- $self->{version} = $1;
- shift @ldif;
- return $self->_read_entry
- unless @ldif;
- }
-
if (@ldif <= 1) {
$self->_error("LDIF entry is not valid", @ldif);
--- 106,109 ----
***************
*** 373,382 ****
next if $type eq 'modify' and !@changes;
! if ($self->{write_count}++) {
! print "\n";
! }
! else {
! print "version: $self->{version}\n" if defined $self->{version};
! }
_write_dn($entry->dn,$self->{'encode'},$wrap);
--- 357,361 ----
next if $type eq 'modify' and !@changes;
! print "\n" if tell($self->{'fh'});
_write_dn($entry->dn,$self->{'encode'},$wrap);
***************
*** 416,427 ****
else {
! if ($self->{write_count}++) {
! print "\n";
! }
! else {
! print "version: $self->{version}\n" if defined $self->{version};
! }
! _write_dn($entry->dn,$self->{'encode'},$wrap);
! _write_attrs($entry,$wrap,$lower);
}
}
--- 395,401 ----
else {
! print "\n" if tell($self->{'fh'});
! _write_dn($entry->dn,$self->{'encode'},$wrap);
! _write_attrs($entry,$wrap,$lower);
}
}
***************
*** 520,528 ****
my $self = shift;
$self->{_current_lines};
- }
-
- sub version {
- my $self = shift;
- $self->{version};
}
--- 494,497 ----
Index: Message.pm
===================================================================
RCS file: /cvsroot/ispman/ispman/lib/Net/LDAP/Message.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -r1.3 -r1.4
*** Message.pm 29 Jul 2003 12:47:06 -0000 1.3
--- Message.pm 4 Jan 2004 18:56:15 -0000 1.4
***************
*** 11,15 ****
use vars qw($VERSION);
! $VERSION = "1.07";
my $MsgID = 0;
--- 11,15 ----
use vars qw($VERSION);
! $VERSION = "1.05";
my $MsgID = 0;
***************
*** 24,28 ****
my $self = shift;
my $type = ref($self) || $self;
! my $parent = shift->inner;
my $arg = shift;
--- 24,28 ----
my $self = shift;
my $type = ref($self) || $self;
! my $parent = shift;
my $arg = shift;
***************
*** 84,95 ****
sub error {
my $self = shift;
! my $return;
!
! unless ($return = $self->server_error) {
! require Net::LDAP::Util and
! $return = Net::LDAP::Util::ldap_error_desc( $self->code );
! }
!
! $return;
}
--- 84,90 ----
sub error {
my $self = shift;
! $self->server_error
! or require Net::LDAP::Util
! and Net::LDAP::Util::ldap_error_desc( $self->code );
}
***************
*** 97,117 ****
my $self = shift;
($self->{resultCode},$self->{errorMessage}) = ($_[0]+0, "$_[1]");
- $self->{callback}->($self)
- if (defined $self->{callback});
$self;
}
- sub error_name {
- Net::LDAP::Util::ldap_error_name(shift->code);
- }
-
- sub error_text {
- Net::LDAP::Util::ldap_error_text(shift->code);
- }
-
- sub error_desc {
- Net::LDAP::Util::ldap_error_desc(shift->code);
- }
-
sub sync {
my $self = shift;
--- 92,98 ----
***************
*** 207,211 ****
sub pdu { shift->{pdu} }
sub callback { shift->{callback} }
! sub parent { shift->{parent}->outer }
sub mesg_id { shift->{mesgid} }
sub is_error { shift->code }
--- 188,192 ----
sub pdu { shift->{pdu} }
sub callback { shift->{callback} }
! sub parent { shift->{parent} }
sub mesg_id { shift->{mesgid} }
sub is_error { shift->code }
Index: Schema.pm
===================================================================
RCS file: /cvsroot/ispman/ispman/lib/Net/LDAP/Schema.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -r1.3 -r1.4
*** Schema.pm 29 Jul 2003 12:47:06 -0000 1.3
--- Schema.pm 4 Jan 2004 18:56:15 -0000 1.4
***************
*** 1,3 ****
! # Copyright (c) 1998-2002 Graham Barr <[email protected]>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
--- 1,3 ----
! # Copyright (c) 1998-2000 Graham Barr <[email protected]>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
***************
*** 8,15 ****
use vars qw($VERSION);
! $VERSION = "0.9901";
#
! # Get schema from the server (or read from LDIF) and parse it into
# data structure
#
--- 8,15 ----
use vars qw($VERSION);
! $VERSION = "0.10";
#
! # Get schema from the server (or read from LDIF) and parse it into
# data structure
#
***************
*** 38,42 ****
return undef;
}
!
%$schema = ();
--- 38,42 ----
return undef;
}
!
%$schema = ();
***************
*** 49,58 ****
unless ($entry = $arg->entry) {
$schema->{error} = 'Bad Argument';
! return $schema;
}
}
else {
$schema->{error} = 'Bad Argument';
! return $schema;
}
}
--- 49,58 ----
unless ($entry = $arg->entry) {
$schema->{error} = 'Bad Argument';
! return undef;
}
}
else {
$schema->{error} = 'Bad Argument';
! return undef;
}
}
***************
*** 63,74 ****
unless( $entry ) {
$schema->{error} = "Cannot parse LDIF from file [$arg]";
! return $schema;
}
}
else {
$schema->{error} = "Can't load schema from [$arg]: $!";
! return $schema;
}
!
eval {
local $SIG{__DIE__} = sub {};
--- 63,74 ----
unless( $entry ) {
$schema->{error} = "Cannot parse LDIF from file [$arg]";
! return undef;
}
}
else {
$schema->{error} = "Can't load schema from [$arg]: $!";
! return undef;
}
!
eval {
local $SIG{__DIE__} = sub {};
***************
*** 78,82 ****
if ($@) {
$schema->{error} = $@;
! return $schema;
}
--- 78,82 ----
if ($@) {
$schema->{error} = $@;
! return undef;
}
***************
*** 110,148 ****
}
! sub all_attributes { values %{shift->{at}} }
! sub all_objectclasses { values %{shift->{oc}} }
! sub all_syntaxes { values %{shift->{syn}} }
! sub all_matchingrules { values %{shift->{mr}} }
! sub all_matchingruleuses { values %{shift->{mru}} }
! sub all_ditstructurerules { values %{shift->{dts}} }
! sub all_ditcontentrules { values %{shift->{dtc}} }
! sub all_nameforms { values %{shift->{nfm}} }
! sub superclass {
my $self = shift;
! my $oc = shift;
! my $elem = $self->objectclass( $oc )
! or return scalar _error($self, "Not an objectClass");
! return @{$elem->{sup} || []};
}
! sub must { _must_or_may(@_,'must') }
! sub may { _must_or_may(@_,'may') }
#
! # Return must or may attributes for this OC.
#
sub _must_or_may {
my $self = shift;
! my $must_or_may = pop;
my @oc = @_ or return;
!
#
# If called with an entry, get the OC names and continue
#
! if ( UNIVERSAL::isa( $oc[0], "Net::LDAP::Entry" ) ) {
my $entry = $oc[0];
@oc = $entry->get_value( "objectclass" )
--- 110,225 ----
}
+ #
+ # The names of all the attributes.
+ # Or all atts in (one or more) objectclass(es).
+ #
+ sub attributes {
+ my $self = shift;
+ my @oc = @_;
+ my %res;
+
+ if( @oc ) {
+ @res{ $self->must( @oc ) } = ();
+ @res{ $self->may( @oc ) } = ();
+ }
+ else {
+ @res{ @{ $self->{at} } } = () if $self->{at};
+ }
+
+ return wantarray ? (keys %res) : [keys %res];
+ }
! # The names of all the object classes
! sub objectclasses {
! my $self = shift;
! my $res = $self->{oc};
! return wantarray ? @$res : $res;
! }
!
! # Return all syntaxes
!
! sub syntaxes {
! my $self = shift;
! my $res = $self->{syn};
! return wantarray ? @$res : $res;
! }
!
!
! # The names of all the matchingrules
!
! sub matchingrules {
! my $self = shift;
! my $res = $self->{mr};
! return wantarray ? @$res : $res;
! }
!
! # The names of all the matchingruleuse
!
! sub matchingruleuse {
! my $self = shift;
! my $res = $self->{mru};
! return wantarray ? @$res : $res;
! }
!
! # The names of all the ditstructurerules
!
! sub ditstructurerules {
my $self = shift;
! my $res = $self->{dts};
! return wantarray ? @$res : $res;
! }
!
! # The names of all the ditcontentrules
!
! sub ditcontentrules {
! my $self = shift;
! my $res = $self->{dtc};
! return wantarray ? @$res : $res;
! }
!
! # The names of all the nameforms
!
! sub nameforms {
! my $self = shift;
! my $res = $self->{nfm};
! return wantarray ? @$res : $res;
! }
!
! sub superclass {
! my $self = shift;
! my $oc = shift;
!
! my $oid = $self->is_objectclass( $oc );
! return scalar _error($self, "Not an objectClass") unless $oid;
! my $res = $self->{oid}->{$oid}->{sup};
! return scalar _error($self, "No superclass") unless $res;
! return wantarray ? @$res : $res;
! }
! sub must {
! my $self = shift;
! $self->_must_or_may( "must", @_ );
}
! sub may {
! my $self = shift;
! $self->_must_or_may( "may", @_ );
! }
#
! # Return must or may attributes for this OC. [As array or array ref]
! # return empty array/undef on error
#
sub _must_or_may {
my $self = shift;
! my $must_or_may = shift;
my @oc = @_ or return;
!
#
# If called with an entry, get the OC names and continue
#
! if( UNIVERSAL::isa( $oc[0], "Net::LDAP::Entry" ) ) {
my $entry = $oc[0];
@oc = $entry->get_value( "objectclass" )
***************
*** 150,201 ****
}
! my %res;
! my %done;
! while (@oc) {
! my $oc = shift @oc;
! $done{lc $oc}++ and next;
! my $elem = $self->objectclass( $oc ) or next;
! my $res = $elem->{$must_or_may} or next;
! @res{ @$res } = (); # Add in, getting uniqueness
! my $sup = $elem->{sup} or next;
! push @oc, @$sup;
}
! my %unique = map { ($_,$_) } $self->attribute(keys %res);
! values %unique;
}
#
! # Given name or oid, return element or undef if not of appropriate type
#
! sub _get {
my $self = shift;
! my $type = pop(@_);
! my $hash = $self->{$type};
! my $oid = $self->{oid};
! my @elem = grep $_, map {
! my $elem = $hash->{lc $_};
! ($elem or ($elem = $oid->{$_} and $elem->{type} eq $type))
! ? $elem
! : undef;
! } @_;
! wantarray ? @elem : $elem[0];
}
! sub attribute { _get(@_,'at') }
! sub objectclass { _get(@_,'oc') }
! sub syntax { _get(@_,'syn') }
! sub matchingrule { _get(@_,'mr') }
! sub matchingruleuse { _get(@_,'mru') }
! sub ditstructurerule { _get(@_,'dts') }
! sub ditcontentrule { _get(@_,'dtc') }
! sub nameform { _get(@_,'nfm') }
--- 227,377 ----
}
! my %res; # Use hash to get uniqueness
!
! foreach my $oc ( @oc ) {
! my $oid = $self->is_objectclass( $oc );
! if( $oid ) {
! my $res = $self->{oid}->{$oid}->{$must_or_may} or next;
! @res{ @$res } = (); # Add in, getting uniqueness
! }
! }
!
! return wantarray ? (keys %res) : [ keys %res ];
! }
!
! #
! # Return the value of an item, e.g. 'desc'. If item is array ref and we
! # are called from array context, return an array, else scalar
! #
! sub item {
! my $self = shift;
! my $arg = shift;
! my $item_name = shift; # May be undef. If so all are returned
! my @oid = $self->name2oid( $arg );
! return _error($self, @oid ? "Non-unique name" : "Unknown name")
! unless @oid == 1;
! my $item_ref = $self->{oid}->{$oid[0]} or return _error($self, "Unknown OID");
!
! my $value = $item_ref->{$item_name} or return _error($self, "No such property");
! delete $self->{error};
!
! if( ref $value eq "ARRAY" && wantarray ) {
! return @$value;
! }
! else {
! return $value;
}
+ }
+
+ #
+ # Return a list of items for a particular name or oid
+ #
+ # BUG:Dumps internal representation rather than real info. E.g. shows
+ # the alias/name distinction we create and the 'type' field.
+ #
+ sub items {
+ my $self = shift;
+ my $arg = shift;
+
+ my @oid = $self->name2oid( $arg );
+ return _error($self, @oid ? "Non-unique name" : "Unknown name")
+ unless @oid == 1;
+
+ my $item_ref = $self->{oid}->{$oid[0]} or return _error($self, "Unknown OID");
+ delete $self->{error};
+
+ return wantarray ? (keys %$item_ref) : [keys %$item_ref];
+ }
+
+ #
+ # Given a name, alias or oid, return oid or undef. Undef if not known.
+ #
+ sub name2oid {
+ my $self = shift;
+ my $name = lc shift;
+ return _error($self, "Bad name") unless defined($name) && length($name);
+ return $name if exists $self->{oid}->{$name}; # Already an oid
+ my $oid = $self->{name}->{$name} || $self->{aliases}->{$name}
+ or return _error($self, "Unknown name");
+ return (wantarray && ref $oid) ? @$oid : $oid;
+ }
! #
! # Given an an OID (not a name) return the canonical name. Undef if not
! # an OID
! #
! sub oid2name {
! my $self = shift;
! my $oid = shift;
! return _error($self, "Bad OID") unless $oid;
! return _error($self, "Unknown OID") unless $self->{oid}->{$oid};
! delete $self->{error};
! return $self->{oid}->{$oid}->{name};
}
#
! # Given name or oid, return oid or undef if not of appropriate type
#
+ sub is_attribute {
+ my $self = shift;
+ return $self->_is_type( "at", @_ );
+ }
+
+ sub is_objectclass {
+ my $self = shift;
+ return $self->_is_type( "oc", @_ );
+ }
! sub is_syntax {
my $self = shift;
! return $self->_is_type( "syn", @_ );
! }
!
! sub is_matchingrule {
! my $self = shift;
! return $self->_is_type( "mr", @_ );
! }
! sub is_matchingruleuse {
! my $self = shift;
! return $self->_is_type( "mru", @_ );
! }
!
! sub is_ditstructurerule {
! my $self = shift;
! return $self->_is_type( "dts", @_ );
! }
! sub is_ditcontentrule {
! my $self = shift;
! return $self->_is_type( "dtc", @_ );
! }
! sub is_nameform {
! my $self = shift;
! return $self->_is_type( "nfm", @_ );
}
! # --------------------------------------------------
! # Internal functions
! # --------------------------------------------------
!
! #
! # Given a type and a name_or_oid, return true (the oid) if the name_or_oid
! # is of the appropriate type. Else return undef.
! #
! sub _is_type {
! my ($self, $type, $name) = @_;
!
! foreach my $oid ($self->name2oid( $name )) {
! my $hash = $self->{oid}->{$oid} or next;
! return $oid if $hash->{type} eq $type;
! }
!
! undef;
! }
***************
*** 223,237 ****
#
# These next items are optimisations, to avoid always searching the OID
! # lists. Could be removed in theory. Each is a hash ref mapping
! # lowercase names to the hash stored in the oid struucture
#
! # ->{at}
! # ->{oc}
! # ->{syn}
! # ->{mr}
! # ->{mru}
! # ->{dts}
! # ->{dtc}
! # ->{nfm}
#
--- 399,418 ----
#
# These next items are optimisations, to avoid always searching the OID
! # lists. Could be removed in theory.
! #
! # ->{at} = [ list of canonical names of attributes ]
! # ->{oc} = [ list of can. names of objectclasses ]
! # ->{syn} = [ list of can. names of syntaxes (we make names from descripts) ]
! # ->{mr} = [ list of can. names of matchingrules ]
! # ->{mru} = [ list of can. names of matchingruleuse ]
! # ->{dts} = [ list of can. names of ditstructurerules ]
! # ->{dtc} = [ list of can. names of ditcontentrules ]
! # ->{nfm} = [ list of can. names of nameForms ]
! #
! # This is used to optimise name => oid lookups (to avoid searching).
! # This could be removed or made into a cache to reduce memory usage.
! # The names include any aliases.
#
! # ->{name}->{ $lower_case_name } = $oid
#
***************
*** 258,271 ****
# Map schema attribute names to internal names
#
! my %type2attr = qw(
! at attributetypes
! oc objectclasses
! syn ldapsyntaxes
! mr matchingrules
! mru matchingruleuse
! dts ditstructurerules
! dtc ditcontentrules
! nfm nameforms
! );
#
--- 439,451 ----
# Map schema attribute names to internal names
#
! my %type2attr = ( at => "attributetypes",
! oc => "objectclasses",
! syn => "ldapsyntaxes",
! mr => "matchingrules",
! mru => "matchingruleuse",
! dts => "ditstructurerules",
! dtc => "ditcontentrules",
! nfm => "nameforms",
! );
#
***************
*** 276,280 ****
my $schema = shift;
my $entry = shift;
!
return undef unless defined($entry);
--- 456,460 ----
my $schema = shift;
my $entry = shift;
!
return undef unless defined($entry);
***************
*** 283,288 ****
my $vals = $entry->get_value($attr, asref => 1);
! my %names;
! $schema->{$type} = \%names; # Save reference to hash of names => element
next unless $vals; # Just leave empty ref if nothing
--- 463,468 ----
my $vals = $entry->get_value($attr, asref => 1);
! my @names;
! $schema->{$type} = \@names; # Save reference to list of names
next unless $vals; # Just leave empty ref if nothing
***************
*** 313,319 ****
"([^"]*)"
|
! '((?:[^']+|'[^\s)])*)'
)\s*/xcg;
! die "Cannot parse [$val] [",substr($val,pos($val)),"]" unless @tokens and pos($val) == length($val);
# remove () from start/end
--- 493,499 ----
"([^"]*)"
|
! '([^']*)'
)\s*/xcg;
! die "Cannot parse [$val] ",substr($val,pos($val)) unless @tokens and pos($val) == length($val);
# remove () from start/end
***************
*** 340,344 ****
# Drop of end of list ?
! die "Cannot parse [$val] {$tag}" unless @tokens;
}
}
--- 520,524 ----
# Drop of end of list ?
! die "Cannot parse [$val]" unless @tokens;
}
}
***************
*** 349,353 ****
}
else {
! die "Cannot parse [$val] {$tag}";
}
}
--- 529,533 ----
}
else {
! die "Cannot parse [$val]";
}
}
***************
*** 356,388 ****
# Extract the maximum length of a syntax
#
! $schema_entry{max_length} = $1
! if exists $schema_entry{syntax} and $schema_entry{syntax} =~ s/{(\d+)}//;
#
# Force a name if we don't have one
#
! $schema_entry{name} = $schema_entry{oid}
! unless exists $schema_entry{name};
#
# If we have multiple names, make the name be the first and demote the rest to aliases
#
! if (ref $schema_entry{name}) {
! my $aliases;
! $schema_entry{name} = shift @{$aliases = $schema_entry{name}};
! $schema_entry{aliases} = $aliases if @$aliases;
! }
#
! # Store the elements by OID
! #
! $schema->{oid}->{$oid} = \%schema_entry;
!
#
! # We also index elements by name within each type
#
! foreach my $name ( @{$schema_entry{aliases}}, $schema_entry{name} ) {
! my $lc_name = lc $name;
! $names{lc $name} = \%schema_entry;
}
}
--- 536,581 ----
# Extract the maximum length of a syntax
#
! if ( exists $schema_entry{syntax}) {
! $schema_entry{syntax} =~ s/{(\d+)}//
! and $schema_entry{max_length} = $1;
! }
#
# Force a name if we don't have one
#
! if (!exists $schema_entry{name}) {
! if (exists $schema_entry{desc}) {
! ($schema_entry{name} = $schema_entry{desc}) =~ s/\s+//g
! }
! else {
! $schema_entry{name} = "$type:$schema_entry{oid}"
! }
! }
#
# If we have multiple names, make the name be the first and demote the rest to aliases
#
! $schema_entry{name} = shift @{$schema_entry{aliases} = $schema_entry{name}}
! if ref $schema_entry{name};
#
! # In the schema we store:
#
! # 1 - The schema entry referenced by OID
! # 2 - a list of canonical names of each type
! # 3 - a (lower-cased) canonical name -> OID map
! # 4 - a (lower-cased) alias -> OID map
#
! $schema->{oid}->{$oid} = \%schema_entry;
! my $uc_name = uc $schema_entry{name};
! push @names, $uc_name;
! foreach my $name ( @{$schema_entry{aliases}}, $uc_name ) {
! if (exists $schema->{name}{lc $name}) {
! $schema->{name}{lc $name} = [ $schema->{name}{lc $name} ] unless ref $schema->{name}{lc $name};
! push @{$schema->{name}{lc $name}}, $oid;
! }
! else {
! $schema->{name}{lc $name} = $oid;
! }
}
}
***************
*** 399,418 ****
# Get the syntax of an attribute
#
! sub attribute_syntax {
my $self = shift;
my $attr = shift;
- my $syntax;
! while ($attr) {
! my $elem = $self->attribute( $attr ) or return undef;
! $syntax = $elem->{syntax} and return $self->syntax($syntax);
!
! $attr = ${$elem->{sup} || []}[0];
}
! return undef
}
sub error {
--- 592,620 ----
# Get the syntax of an attribute
#
! sub syntax {
my $self = shift;
my $attr = shift;
! my $oid = $self->is_attribute( $attr ) or return undef;
! my $syntax = $self->{oid}->{$oid}->{syntax};
! unless( $syntax ) {
! my @sup = @{$self->{oid}->{$oid}->{sup}};
! $syntax = $self->syntax( $sup[0] );
}
! return $syntax;
}
+ #
+ # Given an OID or name (or alias), return the canonical name
+ #
+ sub name {
+ my $self = shift;
+ my $arg = shift;
+ my @oid = $self->name2oid( $arg );
+ return undef unless @oid == 1;
+ return $self->oid2name( $oid[0] );
+ }
sub error {
Index: Search.pm
===================================================================
RCS file: /cvsroot/ispman/ispman/lib/Net/LDAP/Search.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -r1.3 -r1.4
*** Search.pm 29 Jul 2003 12:47:06 -0000 1.3
--- Search.pm 4 Jan 2004 18:56:15 -0000 1.4
***************
*** 13,17 ****
@ISA = qw(Net::LDAP::Message);
! $VERSION = "0.09";
--- 13,17 ----
@ISA = qw(Net::LDAP::Message);
! $VERSION = "0.07";
***************
*** 132,138 ****
}
! $v ||= ($a->[1] ||= Net::LDAP::Util::canonical_dn( $a->[0]->dn, "reverse" => 1, separator => "\0"))
cmp
! ($b->[1] ||= Net::LDAP::Util::canonical_dn( $b->[0]->dn, "reverse" => 1, separator => "\0"));
}
map { [ $_ ] } @{$self->{entries}};
--- 132,138 ----
}
! $v ||= ($a->[1] ||= Net::LDAP::Util::canonical_dn( $a->[0]->dn, 1))
cmp
! ($b->[1] ||= Net::LDAP::Util::canonical_dn( $b->[0]->dn, 1));
}
map { [ $_ ] } @{$self->{entries}};
Index: Util.pm
===================================================================
RCS file: /cvsroot/ispman/ispman/lib/Net/LDAP/Util.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -r1.3 -r1.4
*** Util.pm 29 Jul 2003 12:47:06 -0000 1.3
--- Util.pm 4 Jan 2004 18:56:15 -0000 1.4
***************
*** 1,6 ****
! # Copyright (c) 1999-2002 Graham Barr <[email protected]> and
! # Norbert Klasen <norbert.klasen-c4/[email protected]> All Rights Reserved.
! # This program is free software; you can redistribute it and/or modify
! # it under the same terms as Perl itself.
package Net::LDAP::Util;
--- 1,5 ----
! # Copyright (c) 1999-2000 Graham Barr <[email protected]>. All rights reserved.
! # This program is free software; you can redistribute it and/or
! # modify it under the same terms as Perl itself.
package Net::LDAP::Util;
***************
*** 19,23 ****
$mesg = $ldap->search( .... );
! die "Error ",ldap_error_name($mesg) if $mesg->code;
=head1 DESCRIPTION
--- 18,22 ----
$mesg = $ldap->search( .... );
! die "Error ",ldap_error_name($mesg->code) if $mesg->code;
=head1 DESCRIPTION
***************
*** 34,38 ****
use vars qw($VERSION);
require Exporter;
- require Net::LDAP::Constant;
@ISA = qw(Exporter);
@EXPORT_OK = qw(
--- 33,36 ----
***************
*** 41,75 ****
ldap_error_desc
canonical_dn
- ldap_explode_dn
);
! $VERSION = "0.10";
! =item ldap_error_name ( ERR )
! Returns the name corresponding with ERR. ERR can either be an LDAP
! error number, or a C<Net::LDAP::Message> object containing an error
! code. If the error is not known the a string in the form C<"LDAP error
! code %d(0x%02X)"> is returned.
=cut
! # Defined in Constant.pm
! =item ldap_error_text ( ERR )
! Returns the text from the POD description for the given error. ERR can
! either be an LDAP error code, or a C<Net::LDAP::Message> object
! containing an LDAP error code. If the error code given is unknown then
! C<undef> is returned.
=cut
! # Defined in Constant.pm
! =item ldap_error_desc ( ERR )
! Returns a short text description of the error. ERR can either be an
! LDAP error code or a C<Net::LDAP::Message> object containing an LDAP
! error code.
=cut
--- 39,117 ----
ldap_error_desc
canonical_dn
);
! $VERSION = "0.06";
! =item ldap_error_name ( NUM )
! Returns the name corresponding with the error number passed in. If the
! error is not known the a string in the form C<"LDAP error code %d(0x%02X)">
! is returned.
=cut
! my @err2name;
! sub ldap_error_name {
! my $code = 0+ shift;
! require Net::LDAP::Constant;
!
! unless (@err2name) {
! local *FH;
!
! if (open(FH,$INC{'Net/LDAP/Constant.pm'})) {
! while(<FH>) {
! ($err2name[hex($2)] = $1) if /^sub\s+(LDAP_\S+)\s+\(\)\s+\{\s+0x([0-9a-fA-f]{2})\s+\}/;
! }
! close(FH);
! }
! }
! $err2name[$code] || sprintf("LDAP error code %d(0x%02X)",$code,$code);
! }
! =item ldap_error_text ( NUM )
!
! Returns the text from the POD description for the given error. If the
! error code given is unknown then C<undef> is returned.
=cut
! sub ldap_error_text {
! my $name = ldap_error_name(shift);
! my $text;
! if($name =~ /^LDAP_/) {
! my $pod = $INC{'Net/LDAP/Constant.pm'};
! substr($pod,-3) = ".pod";
! local *F;
! open(F,$pod) or return;
! local $/ = "";
! local $_;
! my $len = length($name);
! my $indent = 0;
! while(<F>) {
! if(substr($_,0,11) eq "=item LDAP_") {
! last if defined $text;
! $text = "" if /^=item $name\b/;
! }
! elsif(defined $text && /^=(\S+)/) {
! $indent = 1 if $1 eq "over";
! $indent = 0 if $1 eq "back";
! $text .= " * " if $1 eq "item";
! }
! elsif(defined $text) {
! if($indent) {
! s/\n(?=.)/\n /sog;
! }
! $text .= $_;
! }
! }
! close(F);
! $text =~ s/\n+\Z/\n/ if defined $text;
! }
! $text;
! }
! =item ldap_error_desc ( NUM )
! Returns a short text description of the error.
=cut
***************
*** 177,181 ****
sub ldap_error_desc {
! my $code = (ref($_[0]) ? $_[0]->code : $_[0]);
$err2desc[$code] || sprintf("LDAP error code %d(0x%02X)",$code,$code);
}
--- 219,223 ----
sub ldap_error_desc {
! my $code = shift;
$err2desc[$code] || sprintf("LDAP error code %d(0x%02X)",$code,$code);
}
***************
*** 183,196 ****
! =item canonical_dn ( DN [ , OPTIONS ] )
!
! Returns the given B<DN> in a canonical form. Returns undef if B<DN> is
! not a valid Distinguished Name. (Note: The empty string "" is a valid DN.)
! B<DN> can either be a string or reference to an array of hashes as returned by
! ldap_explode_dn, which is useful when constructing a DN.
! It performs the following operations on the given B<DN>:
=over 4
--- 225,238 ----
+ =item canonical_dn ( DN [, FOR_SORT ])
+ Returns the given DN in a canonical form. Returns undef if DN is
+ not a valid Distinguished Name
! If FOR_SORT is specified and is a I<true> value, the the DNs returned
! will have their RDN components in reverse order. This is primarily
! used for sorting.
! It performs the following operations on the given DN
=over 4
***************
*** 198,491 ****
=item *
! Removes the leading 'OID.' characters if the type is an OID instead
! of a name.
=item *
! Escapes all RFC 2253 special characters (",", "+", """, "\", "E<lt>",
! "E<gt>", ";", "#", "=", " "), slashes ("/"), and any other character
! where the ASCII code is E<lt> 32 as \hexpair.
=item *
! Converts all leading and trailing spaces in values to be \20.
=item *
! If an RDN contains multiple parts, the parts are re-ordered so that
! the attribute type names are in alphabetical order.
!
! =back
!
! B<OPTIONS> is a list of name/value pairs, valid options are:
!
! =over 4
!
! =item casefold
!
! Controls case folding of attribute type names. Attribute values are not
! affected by this option. The default is to uppercase. Valid values are:
!
! =over 4
!
! =item lower
!
! Lowercase attribute type names.
!
! =item upper
!
! Uppercase attribute type names. This is the default.
!
! =item none
!
! Do not change attribute type names.
!
! =back
!
! =item mbcescape
!
! If TRUE, characters that are encoded as a multi-octet UTF-8 sequence
! will be escaped as \(hexpair){2,*}.
!
! =item reverse
!
! If TRUE, the RDN sequence is reversed.
!
! =item separator
!
! Separator to use between RDNs. Defaults to comma (',').
!
! =back
!
! =cut
!
! sub canonical_dn($%) {
! my ($dn, %opt) = @_;
!
! return $dn unless defined $dn and $dn ne '';
!
! # create array of hash representation
! my $rdns = ref($dn) eq 'ARRAY'
! ? $dn
! : ldap_explode_dn( $dn )
! or return undef; #error condition
!
! # assign specified or default separator value
! my $separator = $opt{separator} || ',';
!
! # flatten all RDNs into strings
! my @flatrdns =
! map {
! my $rdn = $_;
! my @types = sort keys %$rdn;
! join('+',
! map {
! my $val = $rdn->{$_};
!
! if ( ref($val) ) {
! $val = '#' . unpack("H*", $$val);
! } else {
! #escape insecure characters and optionally MBCs
! if ( $opt{mbcescape} ) {
! $val =~ s/([\x00-\x1f\/\\",=+<>#;\x7f-\xff])/
! sprintf("\\%02x",ord($1))/xeg;
! } else {
! $val =~ s/([\x00-\x1f\/\\",=+<>#;])/
! sprintf("\\%02x",ord($1))/xeg;
! }
! #escape leading and trailing whitespace
! $val =~ s/(^\s+|\s+$)/
! "\\20" x length $1/xeg;
! }
!
! # case fold attribute type and create return value
! if ( !$opt{casefold} || $opt{casefold} eq 'upper' ) {
! (uc $_)."=$val";
! } elsif ( $opt{casefold} eq 'lower' ) {
! (lc $_)."=$val";
! } else {
! "$_=$val";
! }
! } @types);
! } @$rdns;
!
! # join RDNs into string, optionally reversing order
! $opt{reverse}
! ? join($separator, reverse @flatrdns)
! : join($separator, @flatrdns);
! }
!
!
! =item ldap_explode_dn ( DN [ , OPTIONS ] )
!
! Explodes the given B<DN> into an array of hashes and returns a reference to this
! array. Returns undef if B<DN> is not a valid Distinguished Name.
!
! A Distinguished Name is a sequence of Relative Distingushed Names (RDNs), which
! themselves are sets of Attributes. For each RDN a hash is constructed with the
! attribute type names as keys and the attribute values as corresponding values.
! These hashes are then strored in an array in the order in which they appear
! in the DN.
!
! For example, the DN 'OU=Sales+CN=J. Smith,DC=example,DC=net' is exploded to:
! [
! {
! 'OU' =E<gt> 'Sales',
! 'CN' =E<gt> 'J. Smith'
! },
! {
! 'DC' =E<gt> 'example'
! },
! {
! 'DC' =E<gt> 'net'
! }
! ]
!
! (RFC2253 string) DNs might also contain values, which are the bytes of the
! BER encoding of the X.500 AttributeValue rather than some LDAP string syntax.
! These values are hex-encoded and prefixed with a #. To distingush such BER
! values, ldap_explode_dn uses references to the actual values,
! e.g. '1.3.6.1.4.1.1466.0=#04024869,DC=example,DC=com' is exploded to:
! [
! {
! '1.3.6.1.4.1.1466.0' =E<gt> \"\004\002Hi"
! },
! {
! 'DC' =E<gt> 'example'
! },
! {
! 'DC' =E<gt> 'com'
! }
! ];
!
! It also performs the following operations on the given DN:
!
! =over 4
=item *
! Unescape "\" followed by ",", "+", """, "\", "E<lt>", "E<gt>", ";",
! "#", "=", " ", or a hexpair and and strings beginning with "#".
=item *
! Removes the leading OID. characters if the type is an OID instead
! of a name.
!
! =back
!
! B<OPTIONS> is a list of name/value pairs, valid options are:
!
! =over 4
!
! =item casefold
!
! Controls case folding of attribute types names. Attribute values are not
! affected by this option. The default is to uppercase. Valid values are:
!
! =over 4
!
! =item lower
!
! Lowercase attribute types names.
!
! =item upper
!
! Uppercase attribute type names. This is the default.
!
! =item none
!
! Do not change attribute type names.
!
! =item reverse
!
! If TRUE, the RDN sequence is reversed.
=back
! =back
=cut
- sub ldap_explode_dn($%) {
- my ($dn, %opt) = @_;
- return undef unless defined $dn;
- return [] if $dn eq '';
! my (@dn, %rdn);
while (
! $dn =~ /\G(?:
! \s*
! ([a-zA-Z][-a-zA-Z0-9]*|(?:[Oo][Ii][Dd]\.)?\d+(?:\.\d+)*)
! \s*
! =
! \s*
! (
! (?:[^\\",=+<>\#;]*[^\\",=+<>\#;\s]|\s*\\(?:[\\ ",=+<>#;]|[0-9a-fA-F]{2}))*
! |
! \#(?:[0-9a-fA-F]{2})+
! |
! "(?:[^\\"]+|\\(?:[\\",=+<>#;]|[0-9a-fA-F]{2}))*"
! )
! \s*
! (?:([;,+])\s*(?=\S)|$)
! )\s*/gcx)
{
my($type,$val,$sep) = ($1,$2,$3);
! $type =~ s/^oid\.(\d+(\.\d+)*)$/$1/i; #remove leading "oid."
!
! if ( !$opt{casefold} || $opt{casefold} eq 'upper' ) {
! $type = uc $type;
! } elsif ( $opt{casefold} eq 'lower' ) {
! $type = lc($type);
! }
! if ( $val =~ s/^#// ) {
! # decode hex-encoded BER value
! my $tmp = pack('H*', $val);
! $val = \$tmp;
! } else {
! # remove quotes
$val =~ s/^"(.*)"$/$1/;
! # unescape characters
! $val =~ s/\\([\\ ",=+<>#;]|[0-9a-fA-F]{2})
! /length($1)==1 ? $1 : chr(hex($1))
! /xeg;
}
! $rdn{$type} = $val;
unless (defined $sep and $sep eq '+') {
! if ( $opt{reverse} ) {
! unshift @dn, { %rdn };
! } else {
! push @dn, { %rdn };
! }
! %rdn = ();
}
}
! length($dn) == (pos($dn)||0)
! ? \@dn
! : undef;
}
-
=back
=head1 AUTHOR
! Graham Barr E<lt>gbarr-e+AXbWqSrlAb/[email protected]<gt>
=head1 COPYRIGHT
! Copyright (c) 1999-2002 Graham Barr. All rights reserved. This program is
free software; you can redistribute it and/or modify it under the same
terms as Perl itself.
-
- ldap_explode_dn and canonical_dn also
-
- (c) 2002 Norbert Klasen, norbert.klasen-c4/[email protected], All Rights Reserved.
=for html <hr>
--- 240,340 ----
=item *
! Lowercases values that are # followed by hex.
=item *
! Uppercases type names.
=item *
! Removes the leading OID. characters if the type is an OID instead
! of a name.
=item *
! Escapes all RFC 2253 special characters, and any other character
! where the ASCII code is <32 or >= 127, with a backslash and a two
! digit hex code.
=item *
! Converts all leading and trailing spaces in values to be \20.
=item *
! If an RDN contains multiple parts, the parts are re-ordered so that
! the attribute names are in alphabetical order.
=back
! B<Note> values that are hex encoded (ie start with a #) are not
! decoded. So C<SN=Barr> is not treated the same as C<SN=#42617272>
=cut
! sub canonical_dn {
! my ($dn, $rev) = @_;
!
! $dn = $dn->dn if ref($dn);
!
! my (@dn, @rdn);
while (
! $dn =~ /\G(?:
! \s*
! ([a-zA-Z][-a-zA-Z0-9]*|(?:[Oo][Ii][Dd]\.)?\d+(?:\.\d+)*)
! \s*
! =
! \s*
! (
! (?:[^\\",=+<>\#;]*[^\\",=+<>\#;\s]|\\(?:[\\ ",=+<>#;]|[0-9a-fA-F]{2}))*
! |
! \#(?:[0-9a-fA-F]{2})+
! |
! "(?:[^\\"]+|\\(?:[\\",=+<>#;]|[0-9a-fA-F]{2}))*"
! )
! \s*
! (?:([;,+])\s*(?=\S)|$)
! )\s*/gcx)
{
my($type,$val,$sep) = ($1,$2,$3);
! $type =~ s/^oid\.(\d+(\.\d+)*)$/$1/i;
! if ($val !~ /^#/) {
$val =~ s/^"(.*)"$/$1/;
! $val =~ s/\\([\\ ",=+<>#;]|[0-9a-fA-F]{2})
! /length($1)==1 ? $1 : chr(hex($1))
! /xeg;
! $val =~ s/([\\",=+<>#;])/\\$1/g;
! $val =~ s/([\x00-\x1f\x7f-\xff])/sprintf("\\%02x",ord($1))/eg;
!
! $val =~ s/(^\s+|\s+$)/"\\20" x length $1/ge;
}
! push @rdn, "\U$type\E=$val";
unless (defined $sep and $sep eq '+') {
! push @dn, join($rev ? "\001" : "+", sort @rdn);
! @rdn = ();
}
}
! (length($dn) != (pos($dn)||0))
! ? undef
! : join($rev ? "\000" : ",",$rev ? (reverse @dn) : @dn);
}
=back
=head1 AUTHOR
! Graham Barr <[email protected]>
=head1 COPYRIGHT
! Copyright (c) 1999-2000 Graham Barr. All rights reserved. This program is
free software; you can redistribute it and/or modify it under the same
terms as Perl itself.
=for html <hr>
--- RootDSE.pm DELETED ---
-------------------------------------------------------
This SF.net email is sponsored by: IBM Linux Tutorials.
Become an expert in LINUX or just sharpen your skills. Sign up for IBM's
Free Linux Tutorials. Learn everything from the bash shell to sys admin.
Click now! http://ads.osdn.com/?ad_id=1278&alloc_id=3371&op=click