oqapi/webgui
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Added Net::LDAP to the distribution for easier installs.

Browse source
This commit is contained in:
JT Smith 2002-11-25 07:43:41 +00:00
parent f51b335d74
commit 223c014813
47 changed files with 15060 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

4
docs/credits.txt
View file

@ -49,6 +49,8 @@ Perl.................................Larry Wall / O'Reilly
Rich Edit............................interactivetools.com
Convert::ASN1........................Graham Barr
Data::Config.........................Sébastien Aperghis-Tramoni
HTML::CalendarMonthSimple............Gregor Mosheh
@ -57,6 +59,8 @@ HTML::TagFilter......................William Ross
HTML::Template.......................Sam Tregar
Net::LDAP............................Graham Barr
Tie::CPHash..........................Christopher J. Madsen
Tie::IxHash..........................Gurusamy Sarathy

2
docs/install.txt
View file

@ -18,10 +18,8 @@ QnD INSTALL INSTRUCTIONS:
DBI
DBD::mysql
Digest::MD5
Net::LDAP
Date::Calc
Image::Magick
HTML::Parser
3. Install Apache (with or without mod_perl) and set up your config.

47
lib/Bundle/Net/LDAP.pm Normal file
View file

@ -0,0 +1,47 @@
package Bundle::Net::LDAP;
$VERSION = '0.02';
1;
__END__
=head1 NAME
Bundle::Net::LDAP - A bundle for Net::LDAP
=head1 SYNOPSIS
C<perl -MCPAN -e 'install Bundle::Net::LDAP'>
=head1 CONTENTS
Convert::ASN1
Digest::MD5
URI
URI::ldap
IO::Socket::SSL
XML::Parser
Net::LDAP
=head1 DESCRIPTION
This bundle all modules that Net::LDAP depends on.
=head1 AUTHOR
Graham Barr
=for html <hr>
I<$Id$>
=cut

372
lib/Convert/ASN1.pm Normal file
View file

@ -0,0 +1,372 @@
# Copyright (c) 2000-2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Convert::ASN1;
# $Id$
use 5.004;
use strict;
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS @opParts @opName $AUTOLOAD);
use Exporter;
BEGIN {
@ISA = qw(Exporter);
$VERSION = '0.15';
%EXPORT_TAGS = (
io => [qw(asn_recv asn_send asn_read asn_write asn_get asn_ready)],
debug => [qw(asn_dump asn_hexdump)],
const => [qw(ASN_BOOLEAN ASN_INTEGER ASN_BIT_STR ASN_OCTET_STR
ASN_NULL ASN_OBJECT_ID ASN_REAL ASN_ENUMERATED
ASN_SEQUENCE ASN_SET ASN_PRINT_STR ASN_IA5_STR
ASN_UTC_TIME ASN_GENERAL_TIME ASN_RELATIVE_OID
ASN_UNIVERSAL ASN_APPLICATION ASN_CONTEXT ASN_PRIVATE
ASN_PRIMITIVE ASN_CONSTRUCTOR ASN_LONG_LEN ASN_EXTENSION_ID ASN_BIT)],
tag => [qw(asn_tag asn_decode_tag2 asn_decode_tag asn_encode_tag asn_decode_length asn_encode_length)]
);
@EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
$EXPORT_TAGS{all} = \@EXPORT_OK;
@opParts = qw(
cTAG cTYPE cVAR cLOOP cOPT cCHILD
);
@opName = qw(
opUNKNOWN opBOOLEAN opINTEGER opBITSTR opSTRING opNULL opOBJID opREAL
opSEQUENCE opSET opUTIME opGTIME opUTF8 opANY opCHOICE opROID
);
foreach my $l (\@opParts, \@opName) {
my $i = 0;
foreach my $name (@$l) {
my $j = $i++;
no strict 'refs';
*{__PACKAGE__ . '::' . $name} = sub () { $j }
}
}
}
sub _internal_syms {
my $pkg = caller;
no strict 'refs';
for my $sub (@opParts,@opName,'dump_op') {
*{$pkg . '::' . $sub} = \&{__PACKAGE__ . '::' . $sub};
}
}
sub ASN_BOOLEAN () { 0x01 }
sub ASN_INTEGER () { 0x02 }
sub ASN_BIT_STR () { 0x03 }
sub ASN_OCTET_STR () { 0x04 }
sub ASN_NULL () { 0x05 }
sub ASN_OBJECT_ID () { 0x06 }
sub ASN_REAL () { 0x09 }
sub ASN_ENUMERATED () { 0x0A }
sub ASN_RELATIVE_OID () { 0x0D }
sub ASN_SEQUENCE () { 0x10 }
sub ASN_SET () { 0x11 }
sub ASN_PRINT_STR () { 0x13 }
sub ASN_IA5_STR () { 0x16 }
sub ASN_UTC_TIME () { 0x17 }
sub ASN_GENERAL_TIME () { 0x18 }
sub ASN_UNIVERSAL () { 0x00 }
sub ASN_APPLICATION () { 0x40 }
sub ASN_CONTEXT () { 0x80 }
sub ASN_PRIVATE () { 0xC0 }
sub ASN_PRIMITIVE () { 0x00 }
sub ASN_CONSTRUCTOR () { 0x20 }
sub ASN_LONG_LEN () { 0x80 }
sub ASN_EXTENSION_ID () { 0x1F }
sub ASN_BIT () { 0x80 }
sub new {
my $pkg = shift;
my $self = bless {}, $pkg;
$self->configure(@_);
$self;
}
sub configure {
my $self = shift;
my %opt = @_;
for my $type (qw(encode decode)) {
if (exists $opt{$type}) {
while(my($what,$value) = each %{$opt{$type}}) {
$self->{options}{"${type}_${what}"} = $value;
}
}
}
}
sub find {
my $self = shift;
my $what = shift;
return unless exists $self->{tree}{$what};
my %new = %$self;
$new{script} = $new{tree}->{$what};
bless \%new, ref($self);
}
sub prepare {
my $self = shift;
my $asn = shift;
$self = $self->new unless ref($self);
my $tree = Convert::ASN1::parser::parse($asn);
unless ($tree) {
$self->{error} = $@;
return;
}
$self->{tree} = _pack_struct($tree);
$self->{script} = (values %$tree)[0];
$self;
}
# In XS the will convert the tree between perl and C structs
sub _pack_struct { $_[0] }
sub _unpack_struct { $_[0] }
##
## Encoding
##
sub encode {
my $self = shift;
my $stash = @_ == 1 ? shift : { @_ };
my $buf = '';
local $SIG{__DIE__};
eval { _encode($self->{options}, $self->{script}, $stash, [], $buf) }
or do { $self->{error} = $@; undef }
}
# Encode tag value for encoding.
# We assume that the tag has been correclty generated with asn_tag()
sub asn_encode_tag {
$_[0] >> 8
? $_[0] & 0x8000
? $_[0] & 0x800000
? pack("V",$_[0])
: substr(pack("V",$_[0]),0,3)
: pack("v", $_[0])
: chr($_[0]);
}
# Encode a length. If < 0x80 then encode as a byte. Otherwise encode
# 0x80 | num_bytes followed by the bytes for the number. top end
# bytes of all zeros are not encoded
sub asn_encode_length {
if($_[0] >> 7) {
my $lenlen = &num_length;
return pack("Ca*", $lenlen | 0x80, substr(pack("N",$_[0]), -$lenlen));
}
return pack("C", $_[0]);
}
##
## Decoding
##
sub decode {
my $self = shift;
my $stash = {};
local $SIG{__DIE__};
eval { _decode($self->{options}, $self->{script}, $stash, 0, length $_[0], undef, [], $_[0]); $stash }
or do {
$self->{'error'} = $@;
undef;
};
}
sub asn_decode_length {
return unless length $_[0];
my $len = ord substr($_[0],0,1);
if($len & 0x80) {
$len &= 0x7f or return (1,-1);
return if $len >= length $_[0];
return (1+$len, unpack("N", "\0" x (4 - $len) . substr($_[0],1,$len)));
}
return (1, $len);
}
sub asn_decode_tag {
return unless length $_[0];
my $tag = ord $_[0];
my $n = 1;
if(($tag & 0x1f) == 0x1f) {
my $b;
do {
return if $n >= length $_[0];
$b = ord substr($_[0],$n,1);
$tag |= $b << (8 * $n++);
} while($b & 0x80);
}
($n, $tag);
}
sub asn_decode_tag2 {
return unless length $_[0];
my $tag = ord $_[0];
my $num = $tag & 0x1f;
my $len = 1;
if($num == 0x1f) {
$num = 0;
my $b;
do {
return if $len >= length $_[0];
$b = ord substr($_[0],$len++,1);
$num = ($num << 7) + ($b & 0x7f);
} while($b & 0x80);
}
($len, $tag, $num);
}
##
## Utilities
##
# How many bytes are needed to encode a number
sub num_length {
$_[0] >> 8
? $_[0] >> 16
? $_[0] >> 24
? 4
: 3
: 2
: 1
}
# Convert from a bigint to an octet string
sub i2osp {
my($num, $biclass) = @_;
eval "use $biclass";
$num = $biclass->new($num);
my $neg = $num < 0
and $num = abs($num+1);
my $base = $biclass->new(256);
my $result = '';
while($num != 0) {
my $r = $num % $base;
$num = ($num-$r) / $base;
$result .= chr($r);
}
$result ^= chr(255) x length($result) if $neg;
return scalar reverse $result;
}
# Convert from an octet string to a bigint
sub os2ip {
my($os, $biclass) = @_;
eval "require $biclass";
my $base = $biclass->new(256);
my $result = $biclass->new(0);
my $neg = ord($os) >= 0x80
and $os ^= chr(255) x length($os);
for (unpack("C*",$os)) {
$result = ($result * $base) + $_;
}
return $neg ? ($result + 1) * -1 : $result;
}
# Given a class and a tag, calculate an integer which when encoded
# will become the tag. This means that the class bits are always
# in the bottom byte, so are the tag bits if tag < 30. Otherwise
# the tag is in the upper 3 bytes. The upper bytes are encoded
# with bit8 representing that there is another byte. This
# means the max tag we can do is 0x1fffff
sub asn_tag {
my($class,$value) = @_;
die sprintf "Bad tag class 0x%x",$class
if $class & ~0xe0;
unless ($value & ~0x1f or $value == 0x1f) {
return (($class & 0xe0) | $value);
}
die sprintf "Tag value 0x%08x too big\n",$value
if $value & 0xffe00000;
$class = ($class | 0x1f) & 0xff;
my @t = ($value & 0x7f);
unshift @t, (0x80 | ($value & 0x7f)) while $value >>= 7;
unpack("V",pack("C4",$class,@t,0,0));
}
BEGIN {
# When we have XS &_encode will be defined by the XS code
# so will all the subs in these required packages
unless (defined &_encode) {
require Convert::ASN1::_decode;
require Convert::ASN1::_encode;
require Convert::ASN1::IO;
}
require Convert::ASN1::parser;
}
sub AUTOLOAD {
require Convert::ASN1::Debug if $AUTOLOAD =~ /dump/;
goto &{$AUTOLOAD} if defined &{$AUTOLOAD};
require Carp;
my $pkg = ref($_[0]) || ($_[0] =~ /^[\w\d]+(?:::[\w\d]+)*$/)[0];
if ($pkg and UNIVERSAL::isa($pkg, __PACKAGE__)) { # guess it was a method call
$AUTOLOAD =~ s/.*:://;
Carp::croak(sprintf q{Can't locate object method "%s" via package "%s"},$AUTOLOAD,$pkg);
}
else {
Carp::croak(sprintf q{Undefined subroutine &%s called}, $AUTOLOAD);
}
}
sub DESTROY {}
sub error { $_[0]->{error} }
1;

443
lib/Convert/ASN1.pod Normal file
View file

@ -0,0 +1,443 @@
=head1 NAME
Convert::ASN1 - ASN.1 Encode/Decode library
=head1 SYNOPSYS
use Convert::ASN1;
$asn = Convert::ASN1->new;
$asn->prepare(q<
[APPLICATION 7] SEQUENCE {
int INTEGER,
str OCTET STRING
}
>);
$pdu = $asn->encode( int => 7, str => "string");
$out = $asn->decode($pdu);
print $out->{int}," ",$out->{str},"\n";
use Convert::ASN1 qw(:io);
$peer = asn_recv($sock,$buffer,0);
$nbytes = asn_read($fh, $buffer);
$nbytes = asn_send($sock, $buffer, $peer);
$nbytes = asn_send($sock, $buffer);
$nbytes = asn_write($fh, $buffer);
$buffer = asn_get($fh);
$yes = asn_ready($fh)
=head1 DESCRIPTION
Convert::ASN1 encodes and decodes ASN.1 data structures using BER/DER
rules.
=head1 METHODS
=head2 new
Contructor, creates a new object.
=head2 error
Returns the last error.
=head2 configure ( OPTIONS )
Configure options to control how Convert::ASN1 will perform various tasks.
Options are passed as name-value pairs.
=over 4
=item encode
Reference to a hash which contains various encode options.
=item decode
Reference to a hash which contains various decode options.
=item encoding
One of 'ber', 'der', 'per'. I<Currently not used>
=back
Encode options
=over 4
=item real
Which encoding to use for real's. One of 'binary', 'nr1', 'nr2', 'nr3'
=item time
This controls how UTCTime and GeneralizedTime elements are encoded. The default
is C<withzone>.
=over 4
=item utctime
The value passed will be encoded without a zone, ie a UTC value.
=item withzone
The value will be encoded with a zone. By default it will be encoded
using the local time offset. The offset may be set using the C<timezone>
configure option.
=item raw
The value passed should already be in the correct format and will be copied
into the PDU as-is.
=back
=item timezone
By default UTCTime and GeneralizedTime will be encoded using the local
time offset from UTC. This will over-ride that. It is an offset from UTC
in seconds. This option can be overriden by passing a reference to a
list of two values as the time value. The list should contain the time
value and the offset from UTC in seconds.
=item bigint
If during encoding an value greater than 32 bits is discovered and
is not already a big integer object, then the value will first be
converted into a big integer object. This option controls the big
integer class into which the objects will be blessed. The default
is to use Math::BigInt
=back
Decode options
=over 4
=item time
This controls how a UTCTime or a GeneralizedTime element will be decoded. The default
is C<utctime>.
=over 4
=item utctime
The value returned will be a time value as returned by the C<time> function.
=item withzone
The value returned will be a reference to an array of two values. The first is the
same as with C<utctime>, the second is the timezone offset, in seconds, that was
used in the encoding.
=item raw
The value returned will be the raw encoding as extracted from the PDU.
=back
=item bigint
If during decoding any big integers are discovered (integers greater
than 32 bits), they will be decoded into big integer objects. This option
controls the big integer class into which the objects will be blessed.
The default is to use Math::BigInt.
=back
=head2 prepare ( ASN )
Compile the given ASN.1 descripton. The syntax used is very close to ASN.1, but has
a few differnces. If the ASN decribes only one macro then encode/decode can be
called on this object. If ASN describes more than one ASN.1 macro then C<find>
must be called.
=head2 find ( MACRO )
Find a macro froma prepared ASN.1 description. Returns an object which can
be used for encode/decode.
=head2 encode ( VARIABLES )
Encode a PDU. Top-level variable are passed as name-value pairs, or as a reference
to a hash containing them. Returns the encoded PDU, or undef on error.
=head2 decode ( PDU )
Decode the PDU, returns a reference to a hash containg the values for the PDU. Returns
undef if there was an error.
=head1 EXPORTS
As well as providing an object interface for encoding/decoding PDUs Convert::ASN1
also provides the follow functions.
=head2 IO Functions
=over 4
=item asn_recv SOCK, BUFFER, FLAGS
Will read a single element from the socket SOCK into BUFFER. FLAGS may
be MSG_PEEK as exported by C<Socket>. Returns the address of the sender,
or undef if there was an error. Some systems do not support the return
of the peer address when the socket is a connected socket, in these
cases the empty string will be returned. This is the same behaviour
as the C<recv> function in perl itself.
It is reccomended that if the socket is of type SOCK_DGRAM then C<recv>
be called directly instead of calling C<asn_recv>.
=item asn_read FH, BUFFER, OFFSET
=item asn_read FH, BUFFER
Will read a single element from the filehandle FH into BUFFER. Returns the
number of bytes read if a complete element was read, -1 if an incomplete
element was read or undef if there was an error. If OFFSET is specified
then it is assumed that BUFFER already contains an incomplete element
and new data will be appended starting at OFFSET.
If FH is a socket the asn_recv is used to read the element, so the same
restiction applies if FH is a socket of type SOCK_DGRAM.
=item asn_send SOCK, BUFFER, FLAGS, TO
=item asn_send SOCK, BUFFER, FLAGS
Identical to calling C<send>, see L<perlfunc>
=item asn_write FH, BUFFER
Identical to calling C<syswrite> with 2 arguments, see L<perlfunc>
=item asn_get FH
C<asn_get> provides buffered IO. Because it needs a buffer FH must be a GLOB
or a reference to a GLOB. C<asn_get> will use two entries in the hash element
of the GLOB to use as it's buffer
asn_buffer - input buffer
asn_need - number of bytes needed for the next element, if known
Returns an element or undef if there was an error.
=item asn_ready FH
C<asn_ready> works with C<asn_get>. It will return true if C<asn_get> has already
read enough data into the buffer to return a complete element.
=back
=head2 Encode/Decode Functions
=over 4
=item asn_tag
=item asn_decode_tag
=item asn_encode_tag
=item asn_decode_length
=item asn_encode_length
=back
=head2 Constants
=over 4
=item ASN_BIT_STR
=item ASN_BOOLEAN
=item ASN_ENUMERATED
=item ASN_GENERAL_TIME
=item ASN_IA5_STR
=item ASN_INTEGER
=item ASN_NULL
=item ASN_OBJECT_ID
=item ASN_OCTET_STR
=item ASN_PRINT_STR
=item ASN_REAL
=item ASN_SEQUENCE
=item ASN_SET
=item ASN_UTC_TIME
=item ASN_APPLICATION
=item ASN_CONTEXT
=item ASN_PRIVATE
=item ASN_UNIVERSAL
=item ASN_PRIMITIVE
=item ASN_CONSTRUCTOR
=item ASN_LONG_LEN
=item ASN_EXTENSION_ID
=item ASN_BIT
=back
=head2 Debug Functions
=over 4
=item asn_dump
=item asn_hexdump
=back
=head1 EXPORT TAGS
=over 4
=item :all
All exported functions
=item :const
ASN_BOOLEAN, ASN_INTEGER, ASN_BIT_STR, ASN_OCTET_STR,
ASN_NULL, ASN_OBJECT_ID, ASN_REAL, ASN_ENUMERATED,
ASN_SEQUENCE, ASN_SET, ASN_PRINT_STR, ASN_IA5_STR,
ASN_UTC_TIME, ASN_GENERAL_TIME,
ASN_UNIVERSAL, ASN_APPLICATION, ASN_CONTEXT, ASN_PRIVATE,
ASN_PRIMITIVE, ASN_CONSTRUCTOR, ASN_LONG_LEN, ASN_EXTENSION_ID, ASN_BIT
=item :debug
asn_dump, asn_dumphex
=item :io
asn_recv, asn_send, asn_read, asn_write, asn_get, asn_ready
=item :tag
asn_tag, asn_decode_tag, asn_encode_tag, asn_decode_length, asn_encode_length
=back
=head1 MAPPING ASN.1 TO PERL
Every element in the ASN.1 definition has a name, in perl a hash is used
with these names as an index and the element value as the hash value.
# ASN.1
int INTEGER,
str OCTET STRING
# Perl
{ int => 5, str => "text" }
In the case of a SEQUENCE, SET or CHOICE then the value in the namespace will
be a hash reference which will be the namespce for the elements with
that element.
# ASN.1
int INTEGER,
seq SEQUENCE {
str OCTET STRING,
bool BOOLEAN
}
# Perl
{ int => 5, seq => { str => "text", bool => 1}}
If the element is a SEQUENCE OF, or SET OF, then the value in the namespace
will be an array reference. The elements in the array will be of
the type expected by the type following the OF. For example
with "SEQUENCE OF STRING" the array would contain strings. With
"SEQUENCE OF SEQUENCE { ... }" the array will contain hash references
which will be used as namespaces
# ASN.1
int INTEGER,
str SEQUENCE OF OCTET STRING
# Perl
{ int => 5, str => [ "text1", "text2"]}
# ASN.1
int INTEGER,
str SEQUENCE OF SEQUENCE {
type OCTET STRING,
value INTEGER
}
# Perl
{ int => 5, str => [
{ type => "abc", value => 4 },
{ type => "def", value => -1 },
]}
=head2 Exceptions
There are some exceptions where Convert::ASN1 does not require an element to be named.
These are SEQUENCE {...}, SET {...} and CHOICE. In each case if the element is not
given a name then the elements inside the {...} will share the same namespace as
the elements outside of the {...}.
=head1 TODO
=over 4
=item *
Indefinite length encoding
=item *
XS implementation.
=item *
More documentation.
=item *
More tests.
=back
=head1 AUTHOR
Graham Barr <gbarr@pobox.xom>
=head1 COPYRIGHT
Copyright (c) 2000-2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut

228
lib/Convert/ASN1/Debug.pm Normal file
View file

@ -0,0 +1,228 @@
# Copyright (c) 2000-2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Convert::ASN1;
# $Id$
##
## just for debug :-)
##
sub _hexdump {
my($fmt,$pos) = @_[1,2]; # Don't copy buffer
$pos ||= 0;
my $offset = 0;
my $cnt = 1 << 4;
my $len = length($_[0]);
my $linefmt = ("%02X " x $cnt) . "%s\n";
print "\n";
while ($offset < $len) {
my $data = substr($_[0],$offset,$cnt);
my @y = unpack("C*",$data);
printf $fmt,$pos if $fmt;
# On the last time through replace '%02X ' with '__ ' for the
# missing values
substr($linefmt, 5*@y,5*($cnt-@y)) = "__ " x ($cnt - @y)
if @y != $cnt;
# Change non-printable chars to '.'
$data =~ s/[\x00-\x1f\x7f-\xff]/./sg;
printf $linefmt, @y,$data;
$offset += $cnt;
$pos += $cnt;
}
}
my %type = (
split(/[\t\n]\s*/,
q(10 SEQUENCE
01 BOOLEAN
0A ENUM
0D RELATIVE-OID
11 SET
02 INTEGER
03 BIT STRING
C0 [PRIVATE %d]
04 STRING
40 [APPLICATION %d]
05 NULL
06 OBJECT ID
80 [CONTEXT %d]
)
)
);
BEGIN { undef &asn_dump }
sub asn_dump {
my $fh = @_>1 ? shift : \*STDERR;
my $ofh = select($fh);
my $pos = 0;
my $indent = "";
my @seqend = ();
my $length = length($_[0]);
my $fmt = $length > 0xffff ? "%08X" : "%04X";
while(1) {
while (@seqend && $pos >= $seqend[0]) {
$indent = substr($indent,2);
warn "Bad sequence length " unless $pos == shift @seqend;
printf "$fmt : %s}\n",$pos,$indent;
}
last unless $pos < $length;
my $start = $pos;
my($tb,$tag,$tnum) = asn_decode_tag2(substr($_[0],$pos,10));
$pos += $tb;
my($lb,$len) = asn_decode_length(substr($_[0],$pos,10));
$pos += $lb;
if($tag == 0 && $len == 0) {
$seqend[0] = $pos;
redo;
}
printf $fmt. " %4d: %s",$start,$len,$indent;
my $label = $type{sprintf("%02X",$tag & ~0x20)}
|| $type{sprintf("%02X",$tag & 0xC0)}
|| "[UNIVERSAL %d]";
printf $label, $tnum;
if ($tag & ASN_CONSTRUCTOR) {
print " {\n";
if($len < 0) {
unshift(@seqend, length $_[0]);
}
else {
unshift(@seqend, $pos + $len);
}
$indent .= " ";
next;
}
my $tmp;
for ($label) { # switch
/^(INTEGER|ENUM)/ && do {
Convert::ASN1::_dec_integer({},[],{},$tmp,$_[0],$pos,$len);
printf " = %d\n",$tmp;
last;
};
/^BOOLEAN/ && do {
Convert::ASN1::_dec_boolean({},[],{},$tmp,$_[0],$pos,$len);
printf " = %s\n",$tmp ? 'TRUE' : 'FALSE';
last;
};
/^(?:(OBJECT ID)|(RELATIVE-OID))/ && do {
my @op; $op[opTYPE] = $1 ? opOBJID : opROID;
Convert::ASN1::_dec_object_id({},\@op,{},$tmp,$_[0],$pos,$len);
printf " = %s\n",$tmp;
last;
};
/^NULL/ && do {
print "\n";
last;
};
/^STRING/ && do {
Convert::ASN1::_dec_string({},[],{},$tmp,$_[0],$pos,$len);
if ($tmp =~ /[\x00-\x1f\x7f-\xff]/s) {
_hexdump($tmp,$fmt . " : ".$indent, $pos);
}
else {
printf " = '%s'\n",$tmp;
}
last;
};
# /^BIT STRING/ && do {
# Convert::BER::BIT_STRING->unpack($ber,\$tmp);
# print " = ",$tmp,"\n";
# last;
# };
# default -- dump hex data
_hexdump(substr($_[0],$pos,$len),$fmt . " : ".$indent, $pos);
}
$pos += $len;
}
select($ofh);
}
BEGIN { undef &asn_hexdump }
sub asn_hexdump {
my $fh = @_>1 ? shift : \*STDERR;
my $ofh = select($fh);
_hexdump($_[0]);
print "\n";
select($ofh);
}
BEGIN { undef &dump }
sub dump {
my $self = shift;
for (@{$self->{script}}) {
dump_op($_,"",{},1);
}
}
BEGIN { undef &dump_all }
sub dump_all {
my $self = shift;
while(my($k,$v) = each %{$self->{tree}}) {
print STDERR "$k:\n";
for (@$v) {
dump_op($_,"",{},1);
}
}
}
BEGIN { undef &dump_op }
sub dump_op {
my($op,$indent,$done,$line) = @_;
$indent ||= "";
printf STDERR "%3d: ",$line;
if ($done->{$op}) {
print STDERR " $indent=",$done->{$op},"\n";
return ++$line;
}
$done->{$op} = $line++;
print STDERR $indent,"[ '",unpack("H*",$op->[cTAG]),"', ";
print STDERR $op->[cTYPE] =~ /\D/ ? $op->[cTYPE] : $opName[$op->[cTYPE]];
print STDERR ", ",defined($op->[cVAR]) ? $op->[cVAR] : "_";
print STDERR ", ",defined($op->[cLOOP]) ? $op->[cLOOP] : "_";
print STDERR ", ",defined($op->[cOPT]) ? $op->[cOPT] : "_";
print STDERR "]";
if ($op->[cCHILD]) {
print STDERR " ",scalar @{$op->[cCHILD]},"\n";
for (@{$op->[cCHILD]}) {
$line = dump_op($_,$indent . " ",$done,$line);
}
}
else {
print STDERR "\n";
}
print STDERR "\n" unless length $indent;
$line;
}
1;

261
lib/Convert/ASN1/IO.pm Normal file
View file

@ -0,0 +1,261 @@
# Copyright (c) 2000-2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Convert::ASN1;
# $Id$
use strict;
use Socket;
BEGIN {
local $SIG{__DIE__};
eval { require bytes } and 'bytes'->import
}
sub asn_recv { # $socket, $buffer, $flags
my $peer;
my $buf;
my $n = 128;
my $pos = 0;
my $depth = 0;
my $len = 0;
my($tmp,$tb,$lb);
MORE:
for(
$peer = recv($_[0],$buf,$n,MSG_PEEK);
defined $peer;
$peer = recv($_[0],$buf,$n<<=1,MSG_PEEK)
) {
if ($depth) { # Are we searching of "\0\0"
unless (2+$pos <= length $buf) {
next MORE if $n == length $buf;
last MORE;
}
if(substr($buf,$pos,2) eq "\0\0") {
unless (--$depth) {
$len = $pos + 2;
last MORE;
}
}
}
# If we can decode a tag and length we can detemine the length
($tb,$tmp) = asn_decode_tag(substr($buf,$pos));
unless ($tb || $pos+$tb < length $buf) {
next MORE if $n == length $buf;
last MORE;
}
if (ord(substr($buf,$pos+$tb,1)) == 0x80) {
# indefinite length, grrr!
$depth++;
$pos += $tb + 1;
redo MORE;
}
($lb,$len) = asn_decode_length(substr($buf,$pos+$tb));
if ($lb) {
if ($depth) {
$pos += $tb + $lb + $len;
redo MORE;
}
else {
$len += $tb + $lb + $pos;
last MORE;
}
}
}
if (defined $peer) {
if ($len > length $buf) {
# Check we can read the whole element
goto error
unless defined($peer = recv($_[0],$buf,$len,MSG_PEEK));
if ($len > length $buf) {
# Cannot get whole element
$_[1]='';
return $peer;
}
}
elsif ($len == 0) {
$_[1] = '';
return $peer;
}
if ($_[2] & MSG_PEEK) {
$_[1] = substr($buf,0,$len);
}
elsif (!defined($peer = recv($_[0],$_[1],$len,0))) {
goto error;
}
return $peer;
}
error:
$_[1] = undef;
}
sub asn_read { # $fh, $buffer, $offset
# We need to read one packet, and exactly only one packet.
# So we have to read the first few bytes one at a time, until
# we have enough to decode a tag and a length. We then know
# how many more bytes to read
my $pos = 0;
my $need = 0;
if ($_[2]) {
if ($_[2] > length $_[1]) {
require Carp;
Carp::carp("Offset beyond end of buffer");
return;
}
substr($_[1],$_[2]) = '';
}
else {
$_[1] = '';
}
my $depth = 0;
my $ch;
my $n;
while(($n = $need - length $_[1]) > 0) {
sysread($_[0],$_[1],$n,length $_[1]) or
goto READ_ERR;
}
while(1) {
$need = $pos + 2;
my $tch = ord(substr($_[1],$pos++,1));
# Tag may be multi-byte
if(($tch & 0x1f) == 0x1f) {
my $ch;
do {
$need++;
while(($n = $need - length $_[1]) > 0) {
sysread($_[0],$_[1],$n,length $_[1]) or
goto READ_ERR;
}
$ch = ord(substr($_[1],$pos++,1));
} while($ch & 0x80);
}
$need = $pos + 1;
while(($n = $need - length $_[1]) > 0) {
sysread($_[0],$_[1],$n,length $_[1]) or
goto READ_ERR;
}
my $len = ord(substr($_[1],$pos++,1));
if($len & 0x80) {
unless ($len &= 0x7f) {
$depth++;
next;
}
$need = $pos + $len;
while(($n = $need - length $_[1]) > 0) {
sysread($_[0],$_[1],$n,length $_[1]) or
goto READ_ERR;
}
$pos += $len + unpack("N", "\0" x (4 - $len) . substr($_[1],$pos,$len));
}
elsif (!$len && !$tch) {
die "Bad ASN PDU" unless $depth;
unless (--$depth) {
last;
}
}
else {
$pos += $len;
}
$need = $pos + 2*$depth;
while(($n = $need - length $_[1]) > 0) {
sysread($_[0],$_[1],$n,length $_[1]) or
goto READ_ERR;
}
last unless $depth;
}
return length $_[1];
READ_ERR:
$@ = "I/O Error $! " . CORE::unpack("H*",$_[1]);
return undef;
}
sub asn_send { # $sock, $buffer, $flags, $to
@_ == 4
? send($_[0],$_[1],$_[2],$_[3])
: send($_[0],$_[1],$_[2]);
}
sub asn_write { # $sock, $buffer
syswrite($_[0],$_[1], length $_[1]);
}
sub asn_get { # $fh
my $fh = ref($_[0]) ? $_[0] : \($_[0]);
my $href = \%{*$fh};
$href->{'asn_buffer'} = '' unless exists $href->{'asn_buffer'};
my $need = delete $href->{'asn_need'} || 0;
while(1) {
next if $need;
my($tb,$tag) = asn_decode_tag($href->{'asn_buffer'}) or next;
my($lb,$len) = asn_decode_length(substr($href->{'asn_buffer'},$tb,8)) or next;
$need = $tb + $lb + $len;
}
continue {
if ($need && $need <= length $href->{'asn_buffer'}) {
my $ret = substr($href->{'asn_buffer'},0,$need);
substr($href->{'asn_buffer'},0,$need) = '';
return $ret;
}
my $get = $need > 1024 ? $need : 1024;
sysread($_[0], $href->{'asn_buffer'}, $get, length $href->{'asn_buffer'})
or return undef;
}
}
sub asn_ready { # $fh
my $fh = ref($_[0]) ? $_[0] : \($_[0]);
my $href = \%{*$fh};
return 0 unless exists $href->{'asn_buffer'};
return $href->{'asn_need'} <= length $href->{'asn_buffer'}
if exists $href->{'asn_need'};
my($tb,$tag) = asn_decode_tag($href->{'asn_buffer'}) or return 0;
my($lb,$len) = asn_decode_length(substr($href->{'asn_buffer'},$tb,8)) or return 0;
$href->{'asn_need'} = $tb + $lb + $len;
$href->{'asn_need'} <= length $href->{'asn_buffer'};
}
1;

613
lib/Convert/ASN1/_decode.pm Normal file
View file

@ -0,0 +1,613 @@
# Copyright (c) 2000-2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Convert::ASN1;
# $Id$
BEGIN {
local $SIG{__DIE__};
eval { require bytes } and 'bytes'->import
}
# These are the subs that do the decode, they are called with
# 0 1 2 3 4
# $optn, $op, $stash, $var, $buf
# The order must be the same as the op definitions above
my @decode = (
sub { die "internal error\n" },
\&_dec_boolean,
\&_dec_integer,
\&_dec_bitstring,
\&_dec_string,
\&_dec_null,
\&_dec_object_id,
\&_dec_real,
\&_dec_sequence,
\&_dec_set,
\&_dec_time,
\&_dec_time,
\&_dec_utf8,
undef, # ANY
undef, # CHOICE
\&_dec_object_id,
);
my @ctr;
@ctr[opBITSTR, opSTRING, opUTF8] = (\&_ctr_bitstring,\&_ctr_string,\&_ctr_string);
sub _decode {
my ($optn, $ops, $stash, $pos, $end, $seqof, $larr) = @_;
my $idx = 0;
# we try not to copy the input buffer at any time
foreach my $buf ($_[-1]) {
OP:
foreach my $op (@{$ops}) {
my $var = $op->[cVAR];
if (length $op->[cTAG]) {
TAGLOOP: {
my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
or do {
next OP if $pos==$end and ($seqof || defined $op->[cOPT]);
die "decode error";
};
if ($tag eq $op->[cTAG]) {
&{$decode[$op->[cTYPE]]}(
$optn,
$op,
$stash,
# We send 1 if there is not var as if there is the decode
# should be getting undef. So if it does not get undef
# it knows it has no variable
($seqof ? $seqof->[$idx++] : defined($var) ? $stash->{$var} : 1),
$buf,$npos,$len, $indef ? $larr : []
);
$pos = $npos+$len+$indef;
redo TAGLOOP if $seqof && $pos < $end;
next OP;
}
if ($tag eq ($op->[cTAG] | chr(ASN_CONSTRUCTOR))
and my $ctr = $ctr[$op->[cTYPE]])
{
_decode(
$optn,
[$op],
undef,
$npos,
$npos+$len,
(\my @ctrlist),
$indef ? $larr : [],
$buf,
);
($seqof ? $seqof->[$idx++] : defined($var) ? $stash->{$var} : undef)
= &{$ctr}(@ctrlist);
$pos = $npos+$len+$indef;
redo TAGLOOP if $seqof && $pos < $end;
next OP;
}
if ($seqof || defined $op->[cOPT]) {
unshift @$larr, $len if $indef;
next OP;
}
die "decode error " . unpack("H*",$tag) ."<=>" . unpack("H*",$op->[cTAG]);
}
}
else { # opTag length is zero, so it must be an ANY or CHOICE
if ($op->[cTYPE] == opANY) {
ANYLOOP: {
my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
or do {
next OP if $pos==$end and ($seqof || defined $op->[cOPT]);
die "decode error";
};
$len += $npos-$pos;
($seqof ? $seqof->[$idx++] : $stash->{$var})
= substr($buf,$pos,$len);
$pos += $len + $indef;
redo ANYLOOP if $seqof && $pos < $end;
}
}
else {
CHOICELOOP: {
my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
or do {
next OP if $pos==$end and ($seqof || defined $op->[cOPT]);
die "decode error";
};
foreach my $cop (@{$op->[cCHILD]}) {
if ($tag eq $cop->[cTAG]) {
my $nstash = $seqof
? ($seqof->[$idx++]={})
: defined($var)
? ($stash->{$var}={}) : $stash;
&{$decode[$cop->[cTYPE]]}(
$optn,
$cop,
$nstash,
$nstash->{$cop->[cVAR]},
$buf,$npos,$len,$indef ? $larr : []
);
$pos = $npos+$len+$indef;
redo CHOICELOOP if $seqof && $pos < $end;
next OP;
}
if ($tag eq ($cop->[cTAG] | chr(ASN_CONSTRUCTOR))
and my $ctr = $ctr[$cop->[cTYPE]])
{
my $nstash = $seqof
? ($seqof->[$idx++]={})
: defined($var)
? ($stash->{$var}={}) : $stash;
_decode(
$optn,
[$cop],
undef,
$npos,
$npos+$len,
(\my @ctrlist),
$indef ? $larr : [],
$buf,
);
$nstash->{$cop->[cVAR]} = &{$ctr}(@ctrlist);
$pos = $npos+$len+$indef;
redo CHOICELOOP if $seqof && $pos < $end;
next OP;
}
}
}
die "decode error" unless $op->[cOPT];
}
}
}
}
die "decode error $pos $end" unless $pos == $end;
}
sub _dec_boolean {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $pos, $len
$_[3] = ord(substr($_[4],$_[5],1)) ? 1 : 0;
1;
}
sub _dec_integer {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $pos, $len
my $buf = substr($_[4],$_[5],$_[6]);
my $tmp = ord($buf) & 0x80 ? chr(255) : chr(0);
if ($_[6] > 4) {
$_[3] = os2ip($tmp x (4-$_[6]) . $buf, $_[0]->{decode_bigint} || 'Math::BigInt');
} else {
# N unpacks an unsigned value
$_[3] = unpack("l",pack("l",unpack("N", $tmp x (4-$_[6]) . $buf)));
}
1;
}
sub _dec_bitstring {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $pos, $len
$_[3] = [ substr($_[4],$_[5]+1,$_[6]-1), ($_[6]-1)*8-ord(substr($_[4],$_[5],1)) ];
1;
}
sub _dec_string {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $pos, $len
$_[3] = substr($_[4],$_[5],$_[6]);
1;
}
sub _dec_null {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $pos, $len
$_[3] = 1;
1;
}
sub _dec_object_id {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $pos, $len
my @data = unpack("w*",substr($_[4],$_[5],$_[6]));
splice(@data,0,1,int($data[0]/40),$data[0] % 40)
if $_[1]->[cTYPE] == opOBJID and $data[0];
$_[3] = join(".", @data);
1;
}
my @_dec_real_base = (2,8,16);
sub _dec_real {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $pos, $len
$_[3] = 0.0, return unless $_[6];
my $first = ord(substr($_[4],$_[5],1));
if ($first & 0x80) {
# A real number
require POSIX;
my $exp;
my $expLen = $first & 0x3;
my $estart = $_[5]+1;
if($expLen == 3) {
$estart++;
$expLen = ord(substr($_[4],$_[5]+1,1));
}
else {
$expLen++;
}
_dec_integer(undef, undef, undef, $exp, $_[4],$estart,$expLen);
my $mant = 0.0;
for (reverse unpack("C*",substr($_[4],$estart+$expLen,$_[6]-1-$expLen))) {
$exp +=8, $mant = (($mant+$_) / 256) ;
}
$mant *= 1 << (($first >> 2) & 0x3);
$mant = - $mant if $first & 0x40;
$_[3] = $mant * POSIX::pow($_dec_real_base[($first >> 4) & 0x3], $exp);
return;
}
elsif($first & 0x40) {
$_[3] = POSIX::HUGE_VAL(),return if $first == 0x40;
$_[3] = - POSIX::HUGE_VAL(),return if $first == 0x41;
}
elsif(substr($_[4],$_[5],$_[6]) =~ /^.([-+]?)0*(\d+(?:\.\d+(?:[Ee][-+]?\d+)?)?)$/s) {
$_[3] = eval "$1$2";
return;
}
die "REAL decode error\n";
}
sub _dec_sequence {
# 0 1 2 3 4 5 6 7
# $optn, $op, $stash, $var, $buf, $pos, $len, $larr
if (defined( my $ch = $_[1]->[cCHILD])) {
_decode(
$_[0], #optn
$ch, #ops
(defined($_[3]) || $_[1]->[cLOOP]) ? $_[2] : ($_[3]= {}), #stash
$_[5], #pos
$_[5]+$_[6], #end
$_[1]->[cLOOP] && ($_[3]=[]), #loop
$_[7],
$_[4], #buf
);
}
else {
$_[3] = substr($_[4],$_[5],$_[6]);
}
1;
}
sub _dec_set {
# 0 1 2 3 4 5 6 7
# $optn, $op, $stash, $var, $buf, $pos, $len, $larr
# decode SET OF the same as SEQUENCE OF
my $ch = $_[1]->[cCHILD];
goto &_dec_sequence if $_[1]->[cLOOP] or !defined($ch);
my ($optn, $pos, $larr) = @_[0,5,7];
my $stash = defined($_[3]) ? $_[2] : ($_[3]={});
my $end = $pos + $_[6];
my @done;
while ($pos < $end) {
my($tag,$len,$npos,$indef) = _decode_tl($_[4],$pos,$end,$larr)
or die "decode error";
my ($idx, $any, $done) = (-1);
SET_OP:
foreach my $op (@$ch) {
$idx++;
if (length($op->[cTAG])) {
if ($tag eq $op->[cTAG]) {
my $var = $op->[cVAR];
&{$decode[$op->[cTYPE]]}(
$optn,
$op,
$stash,
# We send 1 if there is not var as if there is the decode
# should be getting undef. So if it does not get undef
# it knows it has no variable
(defined($var) ? $stash->{$var} : 1),
$_[4],$npos,$len,$indef ? $larr : []
);
$done = $idx;
last SET_OP;
}
if ($tag eq ($op->[cTAG] | chr(ASN_CONSTRUCTOR))
and my $ctr = $ctr[$op->[cTYPE]])
{
_decode(
$optn,
[$op],
undef,
$npos,
$npos+$len,
(\my @ctrlist),
$indef ? $larr : [],
$_[4],
);
$stash->{$op->[cVAR]} = &{$ctr}(@ctrlist)
if defined $op->[cVAR];
$done = $idx;
last SET_OP;
}
next SET_OP;
}
elsif ($op->[cTYPE] == opANY) {
$any = $idx;
}
elsif ($op->[cTYPE] == opCHOICE) {
foreach my $cop (@{$op->[cCHILD]}) {
if ($tag eq $cop->[cTAG]) {
my $nstash = defined($var) ? ($stash->{$var}={}) : $stash;
&{$decode[$cop->[cTYPE]]}(
$optn,
$cop,
$nstash,
$nstash->{$cop->[cVAR]},
$_[4],$npos,$len,$indef ? $larr : []
);
$done = $idx;
last SET_OP;
}
if ($tag eq ($cop->[cTAG] | chr(ASN_CONSTRUCTOR))
and my $ctr = $ctr[$cop->[cTYPE]])
{
my $nstash = defined($var) ? ($stash->{$var}={}) : $stash;
_decode(
$optn,
[$cop],
undef,
$npos,
$npos+$len,
(\my @ctrlist),
$indef ? $larr : [],
$_[4],
);
$nstash->{$cop->[cVAR]} = &{$ctr}(@ctrlist);
$done = $idx;
last SET_OP;
}
}
}
else {
die "internal error";
}
}
if (!defined($done) and defined($any)) {
my $var = $ch->[$any][cVAR];
$stash->{$var} = substr($_[4],$pos,$len+$npos-$pos) if defined $var;
$done = $any;
}
die "decode error" if !defined($done) or $done[$done]++;
$pos = $npos + $len + $indef;
}
die "decode error" unless $end == $pos;
foreach my $idx (0..$#{$ch}) {
die "decode error" unless $done[$idx] or $ch->[$idx][cOPT];
}
1;
}
my %_dec_time_opt = ( unixtime => 0, withzone => 1, raw => 2);
sub _dec_time {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $pos, $len
my $mode = $_dec_time_opt{$_[0]->{'decode_time'} || ''} || 0;
if ($mode == 2) {
$_[3] = substr($_[4],$_[5],$_[6]);
return;
}
my @bits = (substr($_[4],$_[5],$_[6])
=~ /^((?:\d\d)?\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)((?:\.\d{1,3})?)(([-+])(\d\d)(\d\d)|Z)/)
or die "bad time format";
if ($bits[0] < 100) {
$bits[0] += 100 if $bits[0] < 50;
}
else {
$bits[0] -= 1900;
}
$bits[1] -= 1;
require Time::Local;
my $time = Time::Local::timegm(@bits[5,4,3,2,1,0]);
$time += $bits[6] if length $bits[6];
my $offset = 0;
if ($bits[7] ne 'Z') {
$offset = $bits[9] * 3600 + $bits[10] * 60;
$offset = -$offset if $bits[8] eq '-';
$time -= $offset;
}
$_[3] = $mode ? [$time,$offset] : $time;
}
sub _dec_utf8 {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $pos, $len
BEGIN {
local $SIG{__DIE__};
eval { require bytes } and 'bytes'->unimport;
eval { require utf8 } and 'utf8'->import;
}
$_[3] = (substr($_[4],$_[5],$_[6]) =~ /(.*)/s)[0];
1;
}
sub _decode_tl {
my($pos,$end,$larr) = @_[1,2,3];
my $indef = 0;
my $tag = substr($_[0], $pos++, 1);
if((ord($tag) & 0x1f) == 0x1f) {
my $b;
my $n=1;
do {
$tag .= substr($_[0],$pos++,1);
$b = ord substr($tag,-1);
} while($b & 0x80);
}
return if $pos >= $end;
my $len = ord substr($_[0],$pos++,1);
if($len & 0x80) {
$len &= 0x7f;
if ($len) {
return if $pos+$len > $end ;
($len,$pos) = (unpack("N", "\0" x (4 - $len) . substr($_[0],$pos,$len)), $pos+$len);
}
else {
unless (@$larr) {
_scan_indef($_[0],$pos,$end,$larr) or return;
}
$indef = 2;
$len = shift @$larr;
}
}
return if $pos+$len+$indef > $end;
# return the tag, the length of the data, the position of the data
# and the number of extra bytes for indefinate encoding
($tag, $len, $pos, $indef);
}
sub _scan_indef {
my($pos,$end,$larr) = @_[1,2,3];
@$larr = ();
my @depth = ( $pos );
while(@depth) {
return if $pos+2 > $end;
if (substr($_[0],$pos,2) eq "\0\0") {
my $end = $pos;
my $start = shift @depth;
unshift @$larr, $end-$start;
$pos += 2;
next;
}
my $tag = substr($_[0], $pos++, 1);
if((ord($tag) & 0x1f) == 0x1f) {
my $b;
my $n=1;
do {
$tag .= substr($_[0],$pos++,1);
$b = ord substr($tag,-1);
} while($b & 0x80);
}
return if $pos >= $end;
my $len = ord substr($_[0],$pos++,1);
if($len & 0x80) {
if ($len &= 0x7f) {
return if $pos+$len > $end ;
$pos += $len + unpack("N", "\0" x (4 - $len) . substr($_[0],$pos,$len));
}
else {
unshift @depth, $pos;
}
}
else {
$pos += $len;
}
}
1;
}
sub _ctr_string { join '', @_ }
sub _ctr_bitstring {
[ join('', map { $_->[0] } @_), $_[-1]->[1] ]
}
1;

364
lib/Convert/ASN1/_encode.pm Normal file
View file

@ -0,0 +1,364 @@
# Copyright (c) 2000-2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Convert::ASN1;
# $Id$
BEGIN {
local $SIG{__DIE__};
eval { require bytes } and 'bytes'->import
}
# These are the subs which do the encoding, they are called with
# 0 1 2 3 4 5
# $opt, $op, $stash, $var, $buf, $loop
# The order in the array must match the op definitions above
my @encode = (
sub { die "internal error\n" },
\&_enc_boolean,
\&_enc_integer,
\&_enc_bitstring,
\&_enc_string,
\&_enc_null,
\&_enc_object_id,
\&_enc_real,
\&_enc_sequence,
\&_enc_sequence, # SET is the same encoding as sequence
\&_enc_time,
\&_enc_time,
\&_enc_utf8,
\&_enc_any,
\&_enc_choice,
\&_enc_object_id,
);
sub _encode {
my ($optn, $ops, $stash, $path) = @_;
my $var;
foreach my $op (@{$ops}) {
if (defined(my $opt = $op->[cOPT])) {
next unless defined $stash->{$opt};
}
if (defined($var = $op->[cVAR])) {
push @$path, $var;
require Carp, Carp::croak(join(".", @$path)," is undefined") unless defined $stash->{$var};
}
$_[4] .= $op->[cTAG];
&{$encode[$op->[cTYPE]]}(
$optn,
$op,
$stash,
defined($var) ? $stash->{$var} : undef,
$_[4],
$op->[cLOOP],
$path,
);
pop @$path if defined $var;
}
$_[4];
}
sub _enc_boolean {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $loop, $path
$_[4] .= pack("CC",1, $_[3] ? 0xff : 0);
}
sub _enc_integer {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $loop, $path
if (abs($_[3]) >= 2**31) {
my $os = i2osp($_[3], ref($_[3]) || $_[0]->{encode_bigint} || 'Math::BigInt');
my $len = length $os;
my $msb = (vec($os, 0, 8) & 0x80) ? 0 : 255;
$len++, $os = chr($msb) . $os if $msb xor $_[3] > 0;
$_[4] .= asn_encode_length($len);
$_[4] .= $os;
}
else {
my $val = int($_[3]);
my $neg = ($val < 0);
my $len = num_length($neg ? ~$val : $val);
my $msb = $val & (0x80 << (($len - 1) * 8));
$len++ if $neg ? !$msb : $msb;
$_[4] .= asn_encode_length($len);
$_[4] .= substr(pack("N",$val), -$len);
}
}
sub _enc_bitstring {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $loop, $path
if (ref($_[3])) {
my $less = (8 - ($_[3]->[1] & 7)) & 7;
my $len = ($_[3]->[1] + 7)/8;
$_[4] .= asn_encode_length(1+$len);
$_[4] .= chr($less);
$_[4] .= substr($_[3]->[0], 0, $len);
if ($less && $len) {
substr($_[4],-1) &= chr(0xff << $less);
}
}
else {
$_[4] .= asn_encode_length(1+length $_[3]);
$_[4] .= chr(0);
$_[4] .= $_[3];
}
}
sub _enc_string {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $loop, $path
$_[4] .= asn_encode_length(length $_[3]);
$_[4] .= $_[3];
}
sub _enc_null {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $loop, $path
$_[4] .= chr(0);
}
sub _enc_object_id {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $loop, $path
my @data = ($_[3] =~ /(\d+)/g);
if ($_[1]->[cTYPE] == opOBJID) {
if(@data < 2) {
@data = (0);
}
else {
my $first = $data[1] + ($data[0] * 40);
splice(@data,0,2,$first);
}
}
my $l = length $_[4];
$_[4] .= pack("cw*", 0, @data);
substr($_[4],$l,1) = asn_encode_length(length($_[4]) - $l - 1);
}
sub _enc_real {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $loop, $path
# Zero
unless ($_[3]) {
$_[4] .= chr(0);
return;
}
require POSIX;
# +oo (well we use HUGE_VAL as Infinity is not avaliable to perl)
if ($_[3] >= POSIX::HUGE_VAL()) {
$_[4] .= pack("C*",0x01,0x40);
return;
}
# -oo (well we use HUGE_VAL as Infinity is not avaliable to perl)
if ($_[3] <= - POSIX::HUGE_VAL()) {
$_[4] .= pack("C*",0x01,0x41);
return;
}
if (exists $_[0]->{'encode_real'} && $_[0]->{'encode_real'} ne 'binary') {
my $tmp = sprintf("%g",$_[3]);
$_[4] .= asn_encode_length(1+length $tmp);
$_[4] .= chr(1); # NR1?
$_[4] .= $tmp;
return;
}
# We have a real number.
my $first = 0x80;
my($mantissa, $exponent) = POSIX::frexp($_[3]);
if ($mantissa < 0.0) {
$mantissa = -$mantissa;
$first |= 0x40;
}
my($eMant,$eExp);
while($mantissa > 0.0) {
($mantissa, my $int) = POSIX::modf($mantissa * (1<<8));
$eMant .= chr($int);
}
$exponent -= 8 * length $eMant;
_enc_integer(undef, undef, undef, $exponent, $eExp);
# $eExp will br prefixed by a length byte
if (5 > length $eExp) {
$eExp =~ s/\A.//s;
$first |= length($eExp)-1;
}
else {
$first |= 0x3;
}
$_[4] .= asn_encode_length(1 + length($eMant) + length($eExp));
$_[4] .= chr($first);
$_[4] .= $eExp;
$_[4] .= $eMant;
}
sub _enc_sequence {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $loop, $path
if (my $ops = $_[1]->[cCHILD]) {
my $l = length $_[4];
$_[4] .= "\0\0"; # guess
if (defined $_[5]) {
my $op = $ops->[0]; # there should only be one
my $enc = $encode[$op->[cTYPE]];
my $tag = $op->[cTAG];
my $loop = $op->[cLOOP];
push @{$_[6]}, -1;
foreach my $var (@{$_[3]}) {
$_[6]->[-1]++;
$_[4] .= $tag;
&{$enc}(
$_[0], # $optn
$op, # $op
$_[2], # $stash
$var, # $var
$_[4], # $buf
$loop, # $loop
$_[6], # $path
);
}
pop @{$_[6]};
}
else {
_encode($_[0],$_[1]->[cCHILD], defined($_[3]) ? $_[3] : $_[2], $_[6], $_[4]);
}
substr($_[4],$l,2) = asn_encode_length(length($_[4]) - $l - 2);
}
else {
$_[4] .= asn_encode_length(length $_[3]);
$_[4] .= $_[3];
}
}
my %_enc_time_opt = ( utctime => 1, withzone => 0, raw => 2);
sub _enc_time {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $loop, $path
my $mode = $_enc_time_opt{$_[0]->{'encode_time'} || ''} || 0;
if ($mode == 2) {
$_[4] .= asn_encode_length(length $_[3]);
$_[4] .= $_[3];
return;
}
my @time;
my $offset;
my $isgen = $_[1]->[cTYPE] == opGTIME;
if (ref($_[3])) {
$offset = int($_[3]->[1] / 60);
$time = $_[3]->[0] + $_[3]->[1];
}
elsif ($mode == 0) {
if (exists $_[0]->{'encode_timezone'}) {
$offset = int($_[0]->{'encode_timezone'} / 60);
$time = $_[3] + $_[0]->{'encode_timezone'};
}
else {
@time = localtime($_[3]);
my @g = gmtime($_[3]);
$offset = ($time[1] - $g[1]) + ($time[2] - $g[2]) * 60;
$time = $_[3] + $offset*60;
}
}
else {
$time = $_[3];
}
@time = gmtime($time);
$time[4] += 1;
$time[5] = $isgen ? ($time[5] + 1900) : ($time[5] % 100);
my $tmp = sprintf("%02d"x6, @time[5,4,3,2,1,0]);
if ($isgen) {
my $sp = sprintf("%.03f",$time);
$tmp .= substr($sp,-4) unless $sp =~ /\.000$/;
}
$tmp .= $offset ? sprintf("%+03d%02d",$offset / 60, abs($offset % 60)) : 'Z';
$_[4] .= asn_encode_length(length $tmp);
$_[4] .= $tmp;
}
sub _enc_utf8 {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $loop, $path
$_[4] .= asn_encode_length(length $_[3]);
$_[4] .= $_[3];
}
sub _enc_any {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $loop, $path
$_[4] .= $_[3];
}
sub _enc_choice {
# 0 1 2 3 4 5 6
# $optn, $op, $stash, $var, $buf, $loop, $path
my $stash = defined($_[3]) ? $_[3] : $_[2];
for my $op (@{$_[1]->[cCHILD]}) {
my $var = $op->[cVAR];
if (exists $stash->{$var}) {
push @{$_[6]}, $var;
_encode($_[0],[$op], $stash, $_[6], $_[4]);
pop @{$_[6]};
return;
}
}
require Carp;
Carp::croak("No value found for CHOICE " . join(".", @{$_[6]}));
}
1;

910
lib/Convert/ASN1/parser.pm Normal file
View file

@ -0,0 +1,910 @@
# 1 "y.tab.pl"
#$yysccsid = "@(#)yaccpar 1.8 (Berkeley) 01/20/91 (Perl 2.0 12/31/92)";
# 20 "parser.y"
;# Copyright (c) 2000-2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
;# This program is free software; you can redistribute it and/or
;# modify it under the same terms as Perl itself.
package Convert::ASN1::parser;
;# $Id$
use strict;
use Convert::ASN1 qw(:all);
use vars qw(
$asn $yychar $yyerrflag $yynerrs $yyn @yyss
$yyssp $yystate @yyvs $yyvsp $yylval $yys $yym $yyval
);
BEGIN { Convert::ASN1->_internal_syms }
my $yydebug=0;
my %yystate;
my %base_type = (
BOOLEAN => [ asn_encode_tag(ASN_BOOLEAN), opBOOLEAN ],
INTEGER => [ asn_encode_tag(ASN_INTEGER), opINTEGER ],
BIT_STRING => [ asn_encode_tag(ASN_BIT_STR), opBITSTR ],
OCTET_STRING => [ asn_encode_tag(ASN_OCTET_STR), opSTRING ],
STRING => [ asn_encode_tag(ASN_OCTET_STR), opSTRING ],
NULL => [ asn_encode_tag(ASN_NULL), opNULL ],
OBJECT_IDENTIFIER => [ asn_encode_tag(ASN_OBJECT_ID), opOBJID ],
REAL => [ asn_encode_tag(ASN_REAL), opREAL ],
ENUMERATED => [ asn_encode_tag(ASN_ENUMERATED), opINTEGER ],
ENUM => [ asn_encode_tag(ASN_ENUMERATED), opINTEGER ],
'RELATIVE-OID' => [ asn_encode_tag(ASN_RELATIVE_OID), opROID ],
SEQUENCE => [ asn_encode_tag(ASN_SEQUENCE | ASN_CONSTRUCTOR), opSEQUENCE ],
SET => [ asn_encode_tag(ASN_SET | ASN_CONSTRUCTOR), opSET ],
ObjectDescriptor => [ asn_encode_tag(ASN_UNIVERSAL | 7), opSTRING ],
UTF8String => [ asn_encode_tag(ASN_UNIVERSAL | 12), opUTF8 ],
NumericString => [ asn_encode_tag(ASN_UNIVERSAL | 18), opSTRING ],
PrintableString => [ asn_encode_tag(ASN_UNIVERSAL | 19), opSTRING ],
TeletexString => [ asn_encode_tag(ASN_UNIVERSAL | 20), opSTRING ],
T61String => [ asn_encode_tag(ASN_UNIVERSAL | 20), opSTRING ],
VideotexString => [ asn_encode_tag(ASN_UNIVERSAL | 21), opSTRING ],
IA5String => [ asn_encode_tag(ASN_UNIVERSAL | 22), opSTRING ],
UTCTime => [ asn_encode_tag(ASN_UNIVERSAL | 23), opUTIME ],
GeneralizedTime => [ asn_encode_tag(ASN_UNIVERSAL | 24), opGTIME ],
GraphicString => [ asn_encode_tag(ASN_UNIVERSAL | 25), opSTRING ],
VisibleString => [ asn_encode_tag(ASN_UNIVERSAL | 26), opSTRING ],
ISO646String => [ asn_encode_tag(ASN_UNIVERSAL | 26), opSTRING ],
GeneralString => [ asn_encode_tag(ASN_UNIVERSAL | 27), opSTRING ],
CharacterString => [ asn_encode_tag(ASN_UNIVERSAL | 28), opSTRING ],
UniversalString => [ asn_encode_tag(ASN_UNIVERSAL | 28), opSTRING ],
BMPString => [ asn_encode_tag(ASN_UNIVERSAL | 30), opSTRING ],
CHOICE => [ '', opCHOICE ],
ANY => [ '', opANY ],
);
;# Given an OP, wrap it in a SEQUENCE
sub explicit {
my $op = shift;
my @seq = @$op;
@seq[cTYPE,cCHILD,cVAR,cLOOP] = ('SEQUENCE',[$op],undef,undef);
@{$op}[cTAG,cOPT] = ();
\@seq;
}
# 74 "y.tab.pl"
sub constWORD () { 1 }
sub constCLASS () { 2 }
sub constSEQUENCE () { 3 }
sub constSET () { 4 }
sub constCHOICE () { 5 }
sub constOF () { 6 }
sub constIMPLICIT () { 7 }
sub constEXPLICIT () { 8 }
sub constOPTIONAL () { 9 }
sub constLBRACE () { 10 }
sub constRBRACE () { 11 }
sub constCOMMA () { 12 }
sub constANY () { 13 }
sub constASSIGN () { 14 }
sub constNUMBER () { 15 }
sub constENUM () { 16 }
sub constCOMPONENTS () { 17 }
sub constPOSTRBRACE () { 18 }
sub constYYERRCODE () { 256 }
my @yylhs = ( -1,
0, 0, 2, 2, 3, 3, 6, 6, 6, 6,
8, 13, 13, 12, 14, 14, 14, 9, 9, 9,
10, 17, 17, 17, 17, 17, 11, 15, 15, 18,
18, 18, 19, 1, 1, 20, 20, 20, 22, 22,
22, 22, 21, 21, 21, 23, 23, 4, 4, 5,
5, 5, 16, 16, 24, 7, 7,
);
my @yylen = ( 2,
1, 1, 3, 4, 4, 1, 1, 1, 1, 1,
3, 1, 1, 5, 1, 1, 1, 4, 4, 4,
4, 1, 1, 1, 1, 1, 1, 1, 2, 1,
3, 3, 4, 1, 2, 1, 3, 3, 2, 1,
1, 1, 4, 1, 3, 0, 1, 0, 1, 0,
1, 1, 1, 3, 2, 0, 1,
);
my @yydefred = ( 0,
0, 49, 0, 0, 1, 0, 0, 44, 0, 36,
0, 0, 0, 0, 52, 51, 0, 0, 0, 3,
0, 6, 0, 11, 0, 0, 0, 0, 45, 0,
37, 38, 0, 22, 0, 0, 25, 0, 42, 40,
0, 41, 0, 27, 43, 4, 0, 0, 0, 0,
7, 8, 9, 10, 0, 47, 39, 0, 0, 0,
0, 0, 0, 30, 57, 5, 0, 0, 53, 0,
18, 19, 0, 20, 0, 0, 55, 21, 0, 0,
0, 32, 31, 54, 0, 0, 17, 15, 16, 14,
33,
);
my @yydgoto = ( 4,
5, 6, 20, 7, 17, 50, 66, 8, 51, 52,
53, 54, 43, 90, 62, 68, 44, 63, 64, 9,
10, 45, 57, 69,
);
my @yysindex = ( 53,
5, 0, -1, 0, 0, 12, 96, 0, 30, 0,
7, 96, 14, 4, 0, 0, 41, 70, 70, 0,
96, 0, 92, 0, 7, 17, 20, 43, 0, 33,
0, 0, 92, 0, 17, 20, 0, 82, 0, 0,
64, 0, 93, 0, 0, 0, 70, 70, 75, 91,
0, 0, 0, 0, 110, 0, 0, 33, 106, 117,
33, 131, 62, 0, 0, 0, 128, 95, 0, 96,
0, 0, 96, 0, 75, 75, 0, 0, 110, 97,
92, 0, 0, 0, 17, 20, 0, 0, 0, 0,
0,
);
my @yyrindex = ( 127,
78, 0, 0, 0, 0, 133, 85, 0, 21, 0,
78, 111, 0, 0, 0, 0, 0, 127, 118, 0,
111, 0, 0, 0, 78, 0, 0, 0, 0, 78,
0, 0, 0, 0, 11, 25, 0, 38, 0, 0,
57, 0, 0, 0, 0, 0, 127, 127, 0, 119,
0, 0, 0, 0, 0, 0, 0, 78, 0, 0,
78, 0, 134, 0, 0, 0, 0, 0, 0, 111,
0, 0, 111, 0, 0, 135, 0, 0, 0, 0,
0, 0, 0, 0, 40, 66, 0, 0, 0, 0,
0,
);
my @yygindex = ( 0,
89, 0, 123, 3, -11, 68, 0, -9, -17, -20,
-15, 121, 0, 0, 0, 0, 0, 0, 63, 0,
122, 0, 0, 71,
);
sub constYYTABLESIZE () { 150 }
my @yytable = ( 29,
23, 22, 40, 12, 13, 39, 2, 41, 2, 33,
23, 23, 14, 21, 24, 22, 12, 25, 11, 23,
34, 23, 23, 3, 24, 24, 47, 21, 23, 48,
13, 34, 12, 24, 2, 24, 24, 26, 26, 23,
23, 18, 24, 26, 27, 28, 26, 19, 26, 26,
23, 23, 49, 1, 2, 26, 46, 23, 80, 88,
70, 81, 87, 73, 89, 24, 24, 46, 46, 3,
30, 2, 56, 75, 46, 61, 24, 24, 48, 76,
48, 48, 48, 24, 48, 48, 3, 50, 50, 50,
48, 55, 34, 48, 35, 36, 28, 34, 58, 85,
86, 28, 15, 16, 37, 78, 79, 38, 65, 37,
67, 50, 38, 50, 50, 50, 71, 35, 56, 56,
48, 48, 48, 50, 48, 48, 50, 72, 35, 48,
48, 48, 2, 48, 48, 59, 60, 82, 83, 31,
32, 74, 77, 42, 28, 29, 0, 46, 91, 84,
);
my @yycheck = ( 17,
12, 11, 23, 1, 6, 23, 2, 23, 2, 21,
0, 1, 1, 11, 1, 25, 6, 14, 14, 9,
0, 11, 12, 17, 0, 1, 10, 25, 18, 10,
6, 11, 30, 9, 2, 11, 12, 0, 1, 0,
1, 12, 18, 3, 4, 5, 9, 18, 11, 12,
11, 12, 10, 1, 2, 18, 0, 18, 70, 80,
58, 73, 80, 61, 80, 0, 1, 11, 12, 17,
1, 2, 9, 12, 18, 1, 11, 12, 1, 18,
3, 4, 5, 18, 7, 8, 17, 3, 4, 5,
13, 10, 1, 16, 3, 4, 5, 1, 6, 3,
4, 5, 7, 8, 13, 11, 12, 16, 18, 13,
1, 1, 16, 3, 4, 5, 11, 0, 0, 1,
3, 4, 5, 13, 7, 8, 16, 11, 11, 3,
4, 5, 0, 7, 8, 47, 48, 75, 76, 18,
19, 11, 15, 23, 11, 11, -1, 25, 81, 79,
);
sub constYYFINAL () { 4 }
sub constYYMAXTOKEN () { 18 }
# 262 "y.tab.pl"
sub yyclearin { $yychar = -1; }
sub yyerrok { $yyerrflag = 0; }
sub YYERROR { ++$yynerrs; &yy_err_recover; }
sub yy_err_recover
{
if ($yyerrflag < 3)
{
$yyerrflag = 3;
while (1)
{
if (($yyn = $yysindex[$yyss[$yyssp]]) &&
($yyn += constYYERRCODE()) >= 0 &&
$yycheck[$yyn] == constYYERRCODE())
{
$yyss[++$yyssp] = $yystate = $yytable[$yyn];
$yyvs[++$yyvsp] = $yylval;
next yyloop;
}
else
{
return(1) if $yyssp <= 0;
--$yyssp;
--$yyvsp;
}
}
}
else
{
return (1) if $yychar == 0;
# 313 "y.tab.pl"
$yychar = -1;
next yyloop;
}
0;
} # yy_err_recover
sub yyparse
{
if ($yys = $ENV{'YYDEBUG'})
{
$yydebug = int($1) if $yys =~ /^(\d)/;
}
$yynerrs = 0;
$yyerrflag = 0;
$yychar = (-1);
$yyssp = 0;
$yyvsp = 0;
$yyss[$yyssp] = $yystate = 0;
yyloop: while(1)
{
yyreduce: {
last yyreduce if ($yyn = $yydefred[$yystate]);
if ($yychar < 0)
{
if (($yychar = &yylex) < 0) { $yychar = 0; }
# 352 "y.tab.pl"
}
if (($yyn = $yysindex[$yystate]) && ($yyn += $yychar) >= 0 &&
$yycheck[$yyn] == $yychar)
{
$yyss[++$yyssp] = $yystate = $yytable[$yyn];
$yyvs[++$yyvsp] = $yylval;
$yychar = (-1);
--$yyerrflag if $yyerrflag > 0;
next yyloop;
}
if (($yyn = $yyrindex[$yystate]) && ($yyn += $yychar) >= 0 &&
$yycheck[$yyn] == $yychar)
{
$yyn = $yytable[$yyn];
last yyreduce;
}
if (! $yyerrflag) {
&yyerror('syntax error');
++$yynerrs;
}
return undef if &yy_err_recover;
} # yyreduce
$yym = $yylen[$yyn];
$yyval = $yyvs[$yyvsp+1-$yym];
switch:
{
my $label = "State$yyn";
goto $label if exists $yystate{$label};
last switch;
State1: {
# 94 "parser.y"
{ $yyval = { '' => $yyvs[$yyvsp-0] };
last switch;
} }
State3: {
# 99 "parser.y"
{
$yyval = { $yyvs[$yyvsp-2], [$yyvs[$yyvsp-0]] };
last switch;
} }
State4: {
# 103 "parser.y"
{
$yyval=$yyvs[$yyvsp-3];
$yyval->{$yyvs[$yyvsp-2]} = [$yyvs[$yyvsp-0]];
last switch;
} }
State5: {
# 110 "parser.y"
{
$yyvs[$yyvsp-1]->[cTAG] = $yyvs[$yyvsp-3];
$yyval = $yyvs[$yyvsp-2] ? explicit($yyvs[$yyvsp-1]) : $yyvs[$yyvsp-1];
last switch;
} }
State11: {
# 124 "parser.y"
{
@{$yyval = []}[cTYPE,cCHILD] = ('COMPONENTS', $yyvs[$yyvsp-0]);
last switch;
} }
State14: {
# 134 "parser.y"
{
$yyvs[$yyvsp-0]->[cTAG] = $yyvs[$yyvsp-2];
@{$yyval = []}[cTYPE,cCHILD,cLOOP] = ($yyvs[$yyvsp-4], [$yyvs[$yyvsp-0]], 1);
$yyval = explicit($yyval) if $yyvs[$yyvsp-1];
last switch;
} }
State18: {
# 147 "parser.y"
{
@{$yyval = []}[cTYPE,cCHILD] = ('SEQUENCE', $yyvs[$yyvsp-1]);
last switch;
} }
State19: {
# 151 "parser.y"
{
@{$yyval = []}[cTYPE,cCHILD] = ('SET', $yyvs[$yyvsp-1]);
last switch;
} }
State20: {
# 155 "parser.y"
{
@{$yyval = []}[cTYPE,cCHILD] = ('CHOICE', $yyvs[$yyvsp-1]);
last switch;
} }
State21: {
# 161 "parser.y"
{
@{$yyval = []}[cTYPE] = ('ENUM');
last switch;
} }
State27: {
# 174 "parser.y"
{
@{$yyval = []}[cTYPE] = ($yyvs[$yyvsp-0]);
last switch;
} }
State28: {
# 179 "parser.y"
{ $yyval = $yyvs[$yyvsp-0];
last switch;
} }
State29: {
# 180 "parser.y"
{ $yyval = $yyvs[$yyvsp-1];
last switch;
} }
State30: {
# 184 "parser.y"
{
$yyval = [ $yyvs[$yyvsp-0] ];
last switch;
} }
State31: {
# 188 "parser.y"
{
push @{$yyval=$yyvs[$yyvsp-2]}, $yyvs[$yyvsp-0];
last switch;
} }
State32: {
# 192 "parser.y"
{
push @{$yyval=$yyvs[$yyvsp-2]}, $yyvs[$yyvsp-0];
last switch;
} }
State33: {
# 198 "parser.y"
{
@{$yyval=$yyvs[$yyvsp-0]}[cVAR,cTAG] = ($yyvs[$yyvsp-3],$yyvs[$yyvsp-2]);
$yyval = explicit($yyval) if $yyvs[$yyvsp-1];
last switch;
} }
State34: {
# 205 "parser.y"
{ $yyval = $yyvs[$yyvsp-0];
last switch;
} }
State35: {
# 206 "parser.y"
{ $yyval = $yyvs[$yyvsp-1];
last switch;
} }
State36: {
# 210 "parser.y"
{
$yyval = [ $yyvs[$yyvsp-0] ];
last switch;
} }
State37: {
# 214 "parser.y"
{
push @{$yyval=$yyvs[$yyvsp-2]}, $yyvs[$yyvsp-0];
last switch;
} }
State38: {
# 218 "parser.y"
{
push @{$yyval=$yyvs[$yyvsp-2]}, $yyvs[$yyvsp-0];
last switch;
} }
State39: {
# 224 "parser.y"
{
@{$yyval=$yyvs[$yyvsp-1]}[cOPT] = ($yyvs[$yyvsp-0]);
last switch;
} }
State43: {
# 233 "parser.y"
{
@{$yyval=$yyvs[$yyvsp-0]}[cVAR,cTAG] = ($yyvs[$yyvsp-3],$yyvs[$yyvsp-2]);
$yyval->[cOPT] = $yyvs[$yyvsp-3] if $yyval->[cOPT];
$yyval = explicit($yyval) if $yyvs[$yyvsp-1];
last switch;
} }
State45: {
# 240 "parser.y"
{
@{$yyval=$yyvs[$yyvsp-0]}[cTAG] = ($yyvs[$yyvsp-2]);
$yyval = explicit($yyval) if $yyvs[$yyvsp-1];
last switch;
} }
State46: {
# 246 "parser.y"
{ $yyval = undef;
last switch;
} }
State47: {
# 247 "parser.y"
{ $yyval = 1;
last switch;
} }
State48: {
# 251 "parser.y"
{ $yyval = undef;
last switch;
} }
State50: {
# 255 "parser.y"
{ $yyval = undef;
last switch;
} }
State51: {
# 256 "parser.y"
{ $yyval = 1;
last switch;
} }
State52: {
# 257 "parser.y"
{ $yyval = 0;
last switch;
} }
State53: {
# 260 "parser.y"
{
last switch;
} }
State54: {
# 261 "parser.y"
{
last switch;
} }
State55: {
# 264 "parser.y"
{
last switch;
} }
State56: {
# 267 "parser.y"
{
last switch;
} }
State57: {
# 268 "parser.y"
{
last switch;
} }
# 615 "y.tab.pl"
} # switch
$yyssp -= $yym;
$yystate = $yyss[$yyssp];
$yyvsp -= $yym;
$yym = $yylhs[$yyn];
if ($yystate == 0 && $yym == 0)
{
$yystate = constYYFINAL();
$yyss[++$yyssp] = constYYFINAL();
$yyvs[++$yyvsp] = $yyval;
if ($yychar < 0)
{
if (($yychar = &yylex) < 0) { $yychar = 0; }
# 641 "y.tab.pl"
}
return $yyvs[$yyvsp] if $yychar == 0;
next yyloop;
}
if (($yyn = $yygindex[$yym]) && ($yyn += $yystate) >= 0 &&
$yyn <= $#yycheck && $yycheck[$yyn] == $yystate)
{
$yystate = $yytable[$yyn];
} else {
$yystate = $yydgoto[$yym];
}
$yyss[++$yyssp] = $yystate;
$yyvs[++$yyvsp] = $yyval;
} # yyloop
} # yyparse
# 272 "parser.y"
my %reserved = (
'OPTIONAL' => constOPTIONAL(),
'CHOICE' => constCHOICE(),
'OF' => constOF(),
'IMPLICIT' => constIMPLICIT(),
'EXPLICIT' => constEXPLICIT(),
'SEQUENCE' => constSEQUENCE(),
'SET' => constSET(),
'ANY' => constANY(),
'ENUM' => constENUM(),
'ENUMERATED' => constENUM(),
'COMPONENTS' => constCOMPONENTS(),
'{' => constLBRACE(),
'}' => constRBRACE(),
',' => constCOMMA(),
'::=' => constASSIGN(),
);
my $reserved = join("|", reverse sort grep { /\w/ } keys %reserved);
my %tag_class = (
APPLICATION => ASN_APPLICATION,
UNIVERSAL => ASN_UNIVERSAL,
PRIVATE => ASN_PRIVATE,
CONTEXT => ASN_CONTEXT,
'' => ASN_CONTEXT # if not specified, its CONTEXT
);
;##
;## This is NOT thread safe !!!!!!
;##
my $pos;
my $last_pos;
my @stacked;
sub parse {
local(*asn) = \($_[0]);
($pos,$last_pos,@stacked) = ();
eval {
local $SIG{__DIE__};
compile(verify(yyparse()));
}
}
sub compile_one {
my $tree = shift;
my $ops = shift;
my $name = shift;
foreach my $op (@$ops) {
next unless ref($op) eq 'ARRAY';
bless $op;
my $type = $op->[cTYPE];
if (exists $base_type{$type}) {
$op->[cTYPE] = $base_type{$type}->[1];
$op->[cTAG] = defined($op->[cTAG]) ? asn_encode_tag($op->[cTAG]): $base_type{$type}->[0];
}
else {
die "Unknown type '$type'\n" unless exists $tree->{$type};
my $ref = compile_one(
$tree,
$tree->{$type},
defined($op->[cVAR]) ? $name . "." . $op->[cVAR] : $name
);
if (defined($op->[cTAG]) && $ref->[0][cTYPE] == opCHOICE) {
@{$op}[cTYPE,cCHILD] = (opSEQUENCE,$ref);
}
else {
@{$op}[cTYPE,cCHILD,cLOOP] = @{$ref->[0]}[cTYPE,cCHILD,cLOOP];
}
$op->[cTAG] = defined($op->[cTAG]) ? asn_encode_tag($op->[cTAG]): $ref->[0][cTAG];
}
$op->[cTAG] |= chr(ASN_CONSTRUCTOR)
if length $op->[cTAG] && ($op->[cTYPE] == opSET || $op->[cTYPE] == opSEQUENCE);
if ($op->[cCHILD]) {
;# If we have children we are one of
;# opSET opSEQUENCE opCHOICE
compile_one($tree, $op->[cCHILD], defined($op->[cVAR]) ? $name . "." . $op->[cVAR] : $name);
;# If a CHOICE is given a tag, then it must be EXPLICIT
$op = explicit($op) if $op->[cTYPE] == opCHOICE && defined($op->[cTAG]) && length($op->[cTAG]);
if ( @{$op->[cCHILD]} > 1) {
;#if ($op->[cTYPE] != opSEQUENCE) {
;# Here we need to flatten CHOICEs and check that SET and CHOICE
;# do not contain duplicate tags
;#}
}
else {
;# A SET of one element can be treated the same as a SEQUENCE
$op->[cTYPE] = opSEQUENCE if $op->[cTYPE] == opSET;
}
}
}
$ops;
}
sub compile {
my $tree = shift;
;# The tree should be valid enough to be able to
;# - resolve references
;# - encode tags
;# - verify CHOICEs do not contain duplicate tags
;# once references have been resolved, and also due to
;# flattening of COMPONENTS, it is possible for an op
;# to appear in multiple places. So once an op is
;# compiled we bless it. This ensure we dont try to
;# compile it again.
while(my($k,$v) = each %$tree) {
compile_one($tree,$v,$k);
}
$tree;
}
sub verify {
my $tree = shift or return;
my $err = "";
;# Well it parsed correctly, now we
;# - check references exist
;# - flatten COMPONENTS OF (checking for loops)
;# - check for duplicate var names
while(my($name,$ops) = each %$tree) {
my $stash = {};
my @scope = ();
my $path = "";
my $idx = 0;
while($ops) {
if ($idx < @$ops) {
my $op = $ops->[$idx++];
my $var;
if (defined ($var = $op->[cVAR])) {
$err .= "$name: $path.$var used multiple times\n"
if $stash->{$var}++;
}
if (defined $op->[cCHILD]) {
if (ref $op->[cCHILD]) {
push @scope, [$stash, $path, $ops, $idx];
if (defined $var) {
$stash = {};
$path .= "." . $var;
}
$idx = 0;
$ops = $op->[cCHILD];
}
elsif ($op->[cTYPE] eq 'COMPONENTS') {
splice(@$ops,--$idx,1,expand_ops($tree, $op->[cCHILD]));
}
else {
die "Internal error\n";
}
}
}
else {
my $s = pop @scope
or last;
($stash,$path,$ops,$idx) = @$s;
}
}
}
die $err if length $err;
$tree;
}
sub expand_ops {
my $tree = shift;
my $want = shift;
my $seen = shift || { };
die "COMPONENTS OF loop $want\n" if $seen->{$want}++;
die "Undefined macro $want\n" unless exists $tree->{$want};
my $ops = $tree->{$want};
die "Bad macro for COMPUNENTS OF '$want'\n"
unless @$ops == 1
&& ($ops->[0][cTYPE] eq 'SEQUENCE' || $ops->[0][cTYPE] eq 'SET')
&& ref $ops->[0][cCHILD];
$ops = $ops->[0][cCHILD];
for(my $idx = 0 ; $idx < @$ops ; ) {
my $op = $ops->[$idx++];
if ($op->[cTYPE] eq 'COMPONENTS') {
splice(@$ops,--$idx,1,expand_ops($tree, $op->[cCHILD], $seen));
}
}
@$ops;
}
sub _yylex {
my $ret = &_yylex;
warn $ret;
$ret;
}
sub yylex {
return shift @stacked if @stacked;
while ($asn =~ /\G(?:
(\s+|--[^\n]*)
|
([,{}]|::=)
|
($reserved)\b
|
(
(?:OCTET|BIT)\s+STRING
|
OBJECT\s+IDENTIFIER
|
RELATIVE-OID
)\b
|
(\w+)
|
\[\s*
(
(?:(?:APPLICATION|PRIVATE|UNIVERSAL|CONTEXT)\s+)?
\d+
)
\s*\]
|
\((\d+)\)
)/sxgo
) {
($last_pos,$pos) = ($pos,pos($asn));
next if defined $1; # comment or whitespace
if (defined $2 or defined $3) {
#A comma is not required after a '}' so to aid the
#parser we insert a fake token after any '}'
push @stacked, constPOSTRBRACE() if defined $2 and $+ eq '}';
return $reserved{$yylval = $+};
}
if (defined $4) {
($yylval = $+) =~ s/\s+/_/g;
return constWORD();
}
if (defined $5) {
$yylval = $+;
return constWORD();
}
if (defined $6) {
my($class,$num) = ($+ =~ /^([A-Z]*)\s*(\d+)$/);
$yylval = asn_tag($tag_class{$class}, $num);
return constCLASS();
}
if (defined $7) {
$yylval = $+;
return constNUMBER();
}
die "Internal error\n";
}
die "Parse error before ",substr($asn,$pos,40),"\n"
unless $pos == length($asn);
0
}
sub yyerror {
die @_," ",substr($asn,$last_pos,40),"\n";
}
1;
# 947 "y.tab.pl"
%yystate = ('State20','','State21','','State43','','State27','','State28',
'','State45','','State29','','State46','','State47','','State48','',
'State1','','State3','','State4','','State5','','State11','','State14','',
'State30','','State31','','State32','','State33','','State18','','State34',
'','State50','','State19','','State35','','State51','','State36','',
'State52','','State37','','State53','','State38','','State54','','State39',
'','State55','','State56','','State57','');
1;

143
lib/LWP/Protocol/ldap.pm Normal file
View file

@ -0,0 +1,143 @@
# Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package LWP::Protocol::ldap;
use Carp ();
use HTTP::Status ();
use HTTP::Negotiate ();
use HTTP::Response ();
use LWP::MediaTypes ();
require LWP::Protocol;
@ISA = qw(LWP::Protocol);
use strict;
eval {
require Net::LDAP;
};
my $init_failed = $@ ? $@ : undef;
sub request {
my($self, $request, $proxy, $arg, $size, $timeout) = @_;
$size = 4096 unless $size;
LWP::Debug::trace('()');
# check proxy
if (defined $proxy)
{
return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
'You can not proxy through the ldap';
}
my $url = $request->url;
if ($url->scheme ne 'ldap') {
my $scheme = $url->scheme;
return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
"LWP::Protocol::ldap::request called for '$scheme'";
}
# check method
my $method = $request->method;
unless ($method eq 'GET') {
return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
'Library does not allow method ' .
"$method for 'ldap:' URLs";
}
if ($init_failed) {
return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
$init_failed;
}
my $host = $url->host;
my $port = $url->port;
my $user = $url->user;
my $password = $url->password;
# Create an initial response object
my $response = new HTTP::Response &HTTP::Status::RC_OK, "Document follows";
$response->request($request);
my $ldap = new Net::LDAP($host, port => $port);
my $mesg = $ldap->bind;
if ($mesg->code) {
my $res = new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
"LDAP return code " . $ldap->code;
$res->content_type("text/plain");
$res->content($ldap->error);
return $res;
}
my $dn = $url->dn;
my @attrs = $url->attributes;
my $scope = $url->scope || "base";
my $filter = $url->filter;
my @opts = (scope => $scope);
push @opts, "base" => $dn if $dn;
push @opts, "filter" => $filter if $filter;
push @opts, "attrs" => \@attrs if @attrs;
$mesg = $ldap->search(@opts);
if ($mesg->code) {
my $res = new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
"LDAP return code " . $ldap->code;
$res->content_type("text/plain");
$res->content($ldap->error);
return $res;
}
else {
my $content = "<HEAD><TITLE>Directory Search Results</TITLE></HEAD>\n<BODY>";
my $entry;
my $index;
for($index = 0 ; $entry = $mesg->entry($index) ; $index++ ) {
my $attr;
$content .= $index ? "<TR><TH COLSPAN=2><hr>&nbsp</TR>\n"
: "<TABLE>";
$content .= "<TR><TH COLSPAN=2>" . $entry->dn . "</TH></TR>\n";
foreach $attr ($entry->attributes) {
my $vals = $entry->get_value($attr, asref => 1);
my $val;
$content .= "<TR><TD align=right valign=top";
$content .= " ROWSPAN=" . scalar(@$vals)
if (@$vals > 1);
$content .= ">" . $attr . "&nbsp</TD>\n";
my $j = 0;
foreach $val (@$vals) {
$val = qq!<a href="$val">$val</a>! if $val =~ /^https?:/;
$val = qq!<a href="mailto:$val">$val</a>! if $val =~ /^[-\w]+\@[-.\w]+$/;
$content .= "<TR>" if $j++;
$content .= "<TD>" . $val . "</TD></TR>\n";
}
}
}
$content .= "</TABLE>" if $index;
$content .= "<hr>";
$content .= $index ? sprintf("%s Match%s found",$index, $index>1 ? "es" : "")
: "<B>No Matches found</B>";
$content .= "</BODY>\n";
$response->header('Content-Type' => 'text/html');
$response->header('Content-Length', length($content));
$response = $self->collect_once($arg, $response, $content)
if ($method ne 'HEAD');
}
$ldap->unbind;
$response;
}

822
lib/Net/LDAP.pm Normal file
View file

@ -0,0 +1,822 @@
# Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. 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;
use strict;
use IO::Socket;
use IO::Select;
use vars qw($VERSION $LDAP_VERSION @ISA);
use Convert::ASN1 qw(asn_read);
use Net::LDAP::Message;
use Net::LDAP::ASN qw(LDAPResponse);
use Net::LDAP::Constant qw(LDAP_SUCCESS
LDAP_OPERATIONS_ERROR
LDAP_DECODING_ERROR
LDAP_PROTOCOL_ERROR
LDAP_ENCODING_ERROR
LDAP_FILTER_ERROR
LDAP_LOCAL_ERROR
LDAP_PARAM_ERROR
LDAP_INAPPROPRIATE_AUTH
);
$VERSION = 0.25;
@ISA = qw(Net::LDAP::Extra);
$LDAP_VERSION = 2; # default LDAP protocol version
# Net::LDAP::Extra will only exist is someone use's the module. But we need
# to ensure the package stash exists or perl will complain that we inherit
# from a non-existant package. I could just use the module, but I did not
# want to.
$Net::LDAP::Extra::create = $Net::LDAP::Extra::create = 0;
sub import {
shift;
unshift @_, 'Net::LDAP::Constant';
require Net::LDAP::Constant;
goto &{Net::LDAP::Constant->can('import')};
}
sub _options {
my %ret = @_;
my $once = 0;
for my $v (grep { /^-/ } keys %ret) {
require Carp;
$once++ or Carp::carp("deprecated use of leading - for options");
$ret{substr($v,1)} = $ret{$v};
}
$ret{control} = [ map { (ref($_) =~ /[^A-Z]/) ? $_->to_asn : $_ }
ref($ret{control}) eq 'ARRAY'
? @{$ret{control}}
: $ret{control}
]
if exists $ret{control};
\%ret;
}
sub _dn_options {
unshift @_, 'dn' if @_ & 1;
&_options;
}
sub _err_msg {
my $mesg = shift;
my $errstr = $mesg->dn || '';
$errstr .= ": " if $errstr;
$errstr . $mesg->error;
}
my %onerror = (
'die' => sub {
require Carp;
Carp::croak(_err_msg(@_))
},
'warn' => sub { require Carp; Carp::carp(_err_msg(@_)); $_[0] },
'undef' => sub { require Carp; Carp::carp(_err_msg(@_)) if $^W; undef },
);
sub _error {
my ($ldap, $mesg) = splice(@_,0,2);
$mesg->set_error(@_);
$ldap->{net_ldap_onerror} && !$ldap->{net_ldap_async}
? scalar &{$ldap->{net_ldap_onerror}}($mesg)
: $mesg;
}
sub new {
my $self = shift;
my $type = ref($self) || $self;
my $host = shift if @_ % 2;
my $arg = &_options;
my $obj = bless {}, $type;
$obj->_connect($host, $arg) or return;
$obj->{net_ldap_host} = $host;
$obj->{net_ldap_resp} = {};
$obj->{net_ldap_version} = $arg->{version} || $LDAP_VERSION;
$obj->{net_ldap_async} = $arg->{async} ? 1 : 0;
if (defined(my $onerr = $arg->{onerror})) {
$onerr = $onerror{$onerr} if exists $onerror{$onerr};
$obj->{net_ldap_onerror} = $onerr;
}
$obj->debug($arg->{debug} || 0 );
$obj;
}
sub _connect {
my ($ldap, $host, $arg) = @_;
$ldap->{net_ldap_socket} = IO::Socket::INET->new(
PeerAddr => $host,
PeerPort => $arg->{port} || '389',
Proto => 'tcp',
Timeout => defined $arg->{timeout}
? $arg->{timeout}
: 120
);
}
sub message {
my $ldap = shift;
shift->new($ldap, @_);
}
sub async {
my $ldap = shift;
@_
? ($ldap->{'net_ldap_async'},$ldap->{'net_ldap_async'} = shift)[0]
: $ldap->{'net_ldap_async'};
}
sub debug {
my $ldap = shift;
require Convert::ASN1::Debug if $_[0];
@_
? ($ldap->{net_ldap_debug},$ldap->{net_ldap_debug} = shift)[0]
: $ldap->{net_ldap_debug};
}
sub socket {
$_[0]->{net_ldap_socket};
}
sub unbind {
my $ldap = shift;
my $arg = &_options;
my $mesg = $ldap->message('Net::LDAP::Unbind' => $arg);
my $control = $arg->{control}
and $ldap->{net_ldap_version} < 3
and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
$mesg->encode(
unbindRequest => 1,
controls => $control,
) or return _error($ldap, $mesg,LDAP_ENCODING_ERROR,"$@");
$ldap->_sendmesg($mesg);
}
sub ldapbind {
require Carp;
Carp::carp("->ldapbind deprecated, use ->bind") if $^W;
goto &bind;
}
my %ptype = qw(
password simple
krb41password krbv41
krb42password krbv42
kerberos41 krbv41
kerberos42 krbv42
sasl sasl
noauth anon
anonymous anon
);
sub bind {
my $ldap = shift;
my $arg = &_dn_options;
require Net::LDAP::Bind;
my $mesg = $ldap->message('Net::LDAP::Bind' => $arg);
$ldap->version(delete $arg->{version})
if exists $arg->{version};
my $dn = delete $arg->{dn} || '';
my $control = delete $arg->{control}
and $ldap->{net_ldap_version} < 3
and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
my %stash = (
name => ref($dn) ? $dn->dn : $dn,
version => $ldap->version,
);
my($auth_type,$passwd) = scalar(keys %$arg) ? () : (simple => '');
keys %ptype; # Reset iterator
while(my($param,$type) = each %ptype) {
if (exists $arg->{$param}) {
($auth_type,$passwd) = $type eq 'anon' ? (simple => '') : ($type,$arg->{$param});
return _error($ldap, $mesg, LDAP_INAPPROPRIATE_AUTH, "No password, did you mean noauth or anonymous ?")
if $type eq 'simple' and $passwd eq '';
last;
}
}
return _error($ldap, $mesg, LDAP_INAPPROPRIATE_AUTH, "No AUTH supplied")
unless $auth_type;
if ($auth_type eq 'sasl') {
return _error($ldap, $mesg, LDAP_PARAM_ERROR, "SASL requires LDAPv3")
if $ldap->{net_ldap_version} < 3;
my $sasl = $passwd;
# Tell the SASL object our user identifier
$sasl->user("dn: $dn") unless $sasl->user;
$passwd = {
mechanism => $sasl->name,
credentials => $sasl->initial
};
# Save data, we will need it later
$mesg->_sasl_info($stash{name},$control,$sasl);
}
$stash{authentication} = { $auth_type => $passwd };
$mesg->encode(
bindRequest => \%stash,
controls => $control
) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
$ldap->_sendmesg($mesg);
}
my %scope = qw(base 0 one 1 single 1 sub 2 subtree 2);
my %deref = qw(never 0 search 1 find 2 always 3);
sub search {
my $ldap = shift;
my $arg = &_options;
require Net::LDAP::Search;
my $mesg = $ldap->message('Net::LDAP::Search' => $arg);
my $control = $arg->{control}
and $ldap->{net_ldap_version} < 3
and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
my $base = $arg->{base} || '';
my $filter;
unless (ref ($filter = $arg->{filter})) {
require Net::LDAP::Filter;
my $f = Net::LDAP::Filter->new;
$f->parse($filter)
or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"Bad filter");
$filter = $f;
}
my %stash = (
baseObject => ref($base) ? $base->dn : $base,
scope => 2,
derefAliases => 2,
sizeLimit => $arg->{sizelimit} || 0,
timeLimit => $arg->{timelimit} || 0,
typesOnly => $arg->{typesonly} || $arg->{attrsonly} || 0,
filter => $filter,
attributes => $arg->{attrs} || []
);
if (exists $arg->{scope}) {
my $sc = lc $arg->{scope};
$stash{scope} = 0 + (exists $scope{$sc} ? $scope{$sc} : $sc);
}
if (exists $arg->{deref}) {
my $dr = lc $arg->{deref};
$stash{derefAliases} = 0 + (exists $deref{$dr} ? $deref{$dr} : $dr);
}
$mesg->encode(
searchRequest => \%stash,
controls => $control
) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
$ldap->_sendmesg($mesg);
}
sub add {
my $ldap = shift;
my $arg = &_dn_options;
my $mesg = $ldap->message('Net::LDAP::Add' => $arg);
my $control = $arg->{control}
and $ldap->{net_ldap_version} < 3
and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
my $entry = $arg->{dn}
or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"No DN specified");
unless (ref $entry) {
require Net::LDAP::Entry;
$entry = Net::LDAP::Entry->new;
$entry->dn($arg->{dn});
$entry->add(@{$arg->{attrs} || $arg->{attr} || []});
}
$mesg->encode(
addRequest => $entry->asn,
controls => $control
) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
$ldap->_sendmesg($mesg);
}
my %opcode = ( 'add' => 0, 'delete' => 1, 'replace' => 2);
sub modify {
my $ldap = shift;
my $arg = &_dn_options;
my $mesg = $ldap->message('Net::LDAP::Modify' => $arg);
my $control = $arg->{control}
and $ldap->{net_ldap_version} < 3
and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
my $dn = $arg->{dn}
or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"No DN specified");
my @ops;
my $opcode;
my $op;
if (exists $arg->{changes}) {
my $chg;
my $opcode;
my $j = 0;
while($j < @{$arg->{changes}}) {
return _error($ldap, $mesg, LDAP_PARAM_ERROR,"Bad change type '" . $arg->{changes}[--$j] . "'")
unless defined($opcode = $opcode{$arg->{changes}[$j++]});
$chg = $arg->{changes}[$j++];
if (ref($chg)) {
my $i = 0;
while ($i < @$chg) {
push @ops, {
operation => $opcode,
modification => {
type => $chg->[$i],
vals => ref($chg->[$i+1]) ? $chg->[$i+1] : [$chg->[$i+1]]
}
};
$i += 2;
}
}
}
}
else {
foreach $op (qw(add delete replace)) {
next unless exists $arg->{$op};
my $opt = $arg->{$op};
my $opcode = $opcode{$op};
my($k,$v);
if (ref($opt) eq 'HASH') {
while (($k,$v) = each %$opt) {
push @ops, {
operation => $opcode,
modification => {
type => $k,
vals => ref($v) ? $v : [$v]
}
};
}
}
elsif (ref($opt) eq 'ARRAY') {
$k = 0;
while ($k < @{$opt}) {
my $attr = ${$opt}[$k++];
my $val = $opcode == 1 ? [] : ${$opt}[$k++];
push @ops, {
operation => $opcode,
modification => {
type => $attr,
vals => $val
}
};
}
}
else {
push @ops, {
operation => $opcode,
modification => {
type => $opt,
vals => []
}
};
}
}
}
$mesg->encode(
modifyRequest => {
object => ref($dn) ? $dn->dn : $dn,
modification => \@ops
},
controls => $control
)
or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
$ldap->_sendmesg($mesg);
}
sub delete {
my $ldap = shift;
my $arg = &_dn_options;
my $mesg = $ldap->message('Net::LDAP::Delete' => $arg);
my $control = $arg->{control}
and $ldap->{net_ldap_version} < 3
and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
my $dn = $arg->{dn}
or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"No DN specified");
$mesg->encode(
delRequest => ref($dn) ? $dn->dn : $dn,
controls => $control
) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
$ldap->_sendmesg($mesg);
}
sub moddn {
my $ldap = shift;
my $arg = &_dn_options;
my $del = $arg->{deleteoldrdn} || $arg->{'delete'} || 0;
my $newsup = $arg->{newsuperior};
my $mesg = $ldap->message('Net::LDAP::ModDN' => $arg);
my $control = $arg->{control}
and $ldap->{net_ldap_version} < 3
and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
my $dn = $arg->{dn}
or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"No DN specified");
my $new = $arg->{newrdn} || $arg->{'new'}
or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"No NewRDN specified");
$mesg->encode(
modDNRequest => {
entry => ref($dn) ? $dn->dn : $dn,
newrdn => ref($new) ? $new->dn : $new,
deleteoldrdn => $del,
newSuperior => ref($newsup) ? $newsup->dn : $newsup,
},
controls => $control
) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
$ldap->_sendmesg($mesg);
}
# now maps to the V3/X.500(93) modifydn map
sub modrdn { goto &moddn }
sub compare {
my $ldap = shift;
my $arg = &_dn_options;
my $mesg = $ldap->message('Net::LDAP::Compare' => $arg);
my $control = $arg->{control}
and $ldap->{net_ldap_version} < 3
and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
my $dn = $arg->{dn}
or return _error($ldap, $mesg, LDAP_PARAM_ERROR,"No DN specified");
my $attr = exists $arg->{attr}
? $arg->{attr}
: exists $arg->{attrs} #compat
? $arg->{attrs}[0]
: "";
my $value = exists $arg->{value}
? $arg->{value}
: exists $arg->{attrs} #compat
? $arg->{attrs}[1]
: "";
$mesg->encode(
compareRequest => {
entry => ref($dn) ? $dn->dn : $dn,
ava => {
attributeDesc => $attr,
assertionValue => $value
}
},
controls => $control
) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
$ldap->_sendmesg($mesg);
}
sub abandon {
my $ldap = shift;
unshift @_,'id' if @_ & 1;
my $arg = &_options;
my $id = $arg->{id};
my $mesg = $ldap->message('Net::LDAP::Abandon' => $arg);
my $control = $arg->{control}
and $ldap->{net_ldap_version} < 3
and return _error($ldap, $mesg, LDAP_PARAM_ERROR, "Controls require LDAPv3");
$mesg->encode(
abandonRequest => ref($id) ? $id->mesg_id : $id,
controls => $control
) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
$ldap->_sendmesg($mesg);
}
sub extension {
my $ldap = shift;
my $arg = &_options;
require Net::LDAP::Extension;
my $mesg = $ldap->message('Net::LDAP::Extension' => $arg);
return _error($ldap, $mesg, LDAP_LOCAL_ERROR, "ExtendedRequest requires LDAPv3")
if $ldap->{net_ldap_version} < 3;
$mesg->encode(
extendedRequest => {
requestName => $arg->{name},
requestValue => $arg->{value}
},
controls => $arg->{control}
) or return _error($ldap, $mesg, LDAP_ENCODING_ERROR,"$@");
$ldap->_sendmesg($mesg);
}
sub sync {
my $ldap = shift;
my $mid = shift;
my $table = $ldap->{net_ldap_mesg};
my $err = LDAP_SUCCESS;
$mid = $mid->mesg_id if ref($mid);
while (defined($mid) ? exists $table->{$mid} : %$table) {
last if $err = $ldap->_recvresp($mid);
}
$err;
}
sub _sendmesg {
my $ldap = shift;
my $mesg = shift;
my $debug;
if ($debug = $ldap->debug) {
require Convert::ASN1::Debug;
print STDERR "$ldap sending:\n";
Convert::ASN1::asn_hexdump(*STDERR, $mesg->pdu)
if $debug & 1;
Convert::ASN1::asn_dump(*STDERR, $mesg->pdu)
if $debug & 4;
}
syswrite($ldap->socket, $mesg->pdu, length($mesg->pdu))
or return _error($ldap, $mesg, LDAP_LOCAL_ERROR,"$!");
# for CLDAP, here we need to recode when we were sent
# so that we can perform timeouts and resends
my $mid = $mesg->mesg_id;
my $sync = not $ldap->async;
unless ($mesg->done) { # may not have a responce
$ldap->{net_ldap_mesg}->{$mid} = $mesg;
if ($sync) {
my $err = $ldap->sync($mid);
return _error($ldap, $mesg, $err,$@) if $err;
}
}
$sync && $ldap->{net_ldap_onerror} && $mesg->is_error
? scalar &{$ldap->{net_ldap_onerror}}($mesg)
: $mesg;
}
sub _recvresp {
my $ldap = shift;
my $what = shift;
my $sock = $ldap->socket;
my $sel = IO::Select->new($sock);
my $ready;
for( $ready = 1 ; $ready ; $ready = $sel->can_read(0)) {
my $pdu;
asn_read($sock, $pdu)
or return LDAP_OPERATIONS_ERROR;
my $debug;
if ($debug = $ldap->debug) {
require Convert::ASN1::Debug;
print STDERR "$ldap received:\n";
Convert::ASN1::asn_hexdump(\*STDERR,$pdu)
if $debug & 2;
Convert::ASN1::asn_dump(\*STDERR,$pdu)
if $debug & 8;
}
my $result = $LDAPResponse->decode($pdu)
or return LDAP_DECODING_ERROR;
my $mid = $result->{messageID};
my $mesg = $ldap->{net_ldap_mesg}->{$mid} or
do {
print STDERR "Unexpected PDU, ignored\n" if $debug & 10;
next;
};
$mesg->decode($result) or
return $mesg->code;
last if defined $what && $what == $mid;
}
# FIXME: in CLDAP here we need to check if any message has timed out
# and if so do we resend it or what
return LDAP_SUCCESS;
}
sub _forgetmesg {
my $ldap = shift;
my $mesg = shift;
my $mid = $mesg->mesg_id;
delete $ldap->{net_ldap_mesg}->{$mid};
}
#Mark Wilcox 3-20-2000
#now accepts named parameters
#dn => "dn of subschema entry"
#
#
# Clif Harden 2-4-2001.
# corrected filter for subschema search.
# added attributes to retrieve on subschema search.
# added attributes to retrieve on rootDSE search.
# changed several double qoute character to single quote
# character, just to be consistent throughout the schema
# and root_dse functions.
#
sub schema {
require Net::LDAP::Schema;
my $self = shift;
my %arg = @_;
my $base;
my $mesg;
if (exists $arg{'dn'}) {
$base = $arg{'dn'};
}
else {
my $root = $self->root_dse( attrs => ['subschemaSubentry'] )
or return undef;
$base = $root->get_value('subschemaSubentry') || 'cn=schema';
}
$mesg = $self->search(
base => $base,
scope => 'base',
filter => '(objectClass=subschema)',
attrs => [qw(
objectClasses
attributeTypes
matchingRules
matchingRuleUse
dITStructureRules
dITContentRules
nameForms
ldapSyntaxes
)],
);
$mesg->code
? undef
: Net::LDAP::Schema->new($mesg->entry);
}
sub root_dse {
my $ldap = shift;
my %arg = @_;
my $attrs = $arg{attrs} || [qw(
subschemaSubentry
namingContexts
altServer
supportedExtension
supportedControl
supportedSASLMechanisms
supportedLDAPVersion
)];
my $mesg = $ldap->search(
base => '',
scope => 'base',
filter => '(objectClass=*)',
attrs => $attrs,
);
$mesg->entry;
}
sub start_tls {
my $ldap = shift;
my $arg = &_options;
my $sock = $ldap->socket;
require Net::LDAP::Extension;
my $mesg = $ldap->message('Net::LDAP::Extension' => $arg);
return _error($ldap, $mesg, LDAP_OPERATIONS_ERROR, "TLS already started")
if $sock->isa('IO::Socket::SSL');
return _error($ldap, $mesg, LDAP_PARAM_ERROR, "StartTLS requires LDAPv3")
if $ldap->version < 3;
$mesg->encode(
extendedReq => {
requestName => "1.3.6.1.4.1.1466.20037",
}
);
$ldap->_sendmesg($mesg);
$mesg->sync();
return $mesg
if $mesg->code;
require Net::LDAPS;
$arg->{sslversion} = 'tlsv1' unless defined $arg->{sslversion};
IO::Socket::SSL::context_init( { Net::LDAPS::SSL_context_init_args($arg) } );
(IO::Socket::SSL::socketToSSL($sock) and tie *{$sock}, 'IO::Socket::SSL', $sock)
? $mesg
: _error($ldap, $mesg, LDAP_OPERATIONS_ERROR, $@);
}
sub cipher {
my $ldap = shift;
$ldap->socket->isa('IO::Socket::SSL')
? $ldap->socket->get_cipher
: undef;
}
sub certificate {
my $ldap = shift;
$ldap->socket->isa('IO::Socket::SSL')
? $ldap->socket->get_peer_certificate
: undef;
}
# what version are we talking?
sub version {
my $ldap = shift;
@_
? ($ldap->{net_ldap_version},$ldap->{net_ldap_version} = shift)[0]
: $ldap->{net_ldap_version};
}
1;

875
lib/Net/LDAP.pod Normal file
View file

@ -0,0 +1,875 @@
=head1 NAME
Net::LDAP - Lightweight Directory Access Protocol
=head1 SYNOPSIS
use Net::LDAP;
$ldap = Net::LDAP->new('ldap.bigfoot.com') or die "$@";
$ldap->bind ; # an anonymous bind
$mesg = $ldap->search ( # perform a search
base => "c=US",
filter => "(&(sn=Barr) (o=Texas Instruments))"
);
$mesg->code && die $mesg->error;
foreach $entry ($mesg->all_entries) { $entry->dump; }
$ldap->unbind; # take down session
$ldap = Net::LDAP->new('ldap.umich.edu');
# bind to a directory with dn and password
$ldap->bind ( 'cn=root, o=University of Michigan, c=us',
password => 'secret'
);
$result = $ldap->add ( 'cn = Barbara Jensen, o=University of Michigan, c=us',
attr => [ 'cn' => ['Barbara Jensen', 'Barbs Jensen'],
'sn => 'Jensen',
'mail' => 'b.jensen@umich.edu',
'objectclass' => ['top', 'person',
'organizationalPerson',
'inetOrgPerson' ],
]
);
$result->code && warn "failed to add entry: ", $result->error ;
=head1 DESCRIPTION
B<Net::LDAP> is a collection of modules that implements a LDAP services API
for Perl programs. The module may be used to search directories or
perform maintenance functions such as add, deleting or modify entries in
an LDAP directory.
This document assumes that the reader has some knowledge of the LDAP
protocol.
=head1 CONSTRUCTOR
=over 4
=item new ( HOST [, OPTIONS ] )
Creates a new B<Net::LDAP> object and opens a connection to the named host.
OPTIONS is a list of key-value pairs, valid options are :-
=over 4
=item port
Port to connect to on the remote server.
=item timeout
Timeout passed to L<IO::Socket> when connecting the remote server.
(Default: 120)
=item debug
If passed a non-zero value then debug data will be sent to C<STDERR>. The
bits of this value are :-
1 Show outgoing packets (using asn_hexdump).
2 Show incoming packets (using asn_hexdump).
4 Show outgoing packets (using asn_dump).
8 Show incoming packets (using asn_dump).
=item async
Perform all operations asynchronously if passed a I<true> value.
=item onerror
If set then Net::LDAP will check all responses for errors on all methods
if the object is in synchronous mode. If an error is detected then the
specified action will be taken. Valid values and their actions are.
=over 4
=item die
Net::LDAP will croak with an appropriate message.
=item warn
Net::LDAP will warn with an appropriate message.
=item undef
Net::LDAP will warn with an appropriate message if C<-w> is in effect.
The method that was called will return C<undef>
=item CODEREF
The given coderef will be called in a scalar context with a single argument, the result
message. The value returned will be the return value for the method
that was called.
=back
=item version
Set the protocol version being used (default is LDAPv2). This is
useful if you want to avoid sending a bind operation and therefore
have to use LDAPv3.
=back
Example
$ldap = Net::LDAP->new('remote.host', async => 1);
=back
=head1 METHODS
Each of the following methods take as arguments some number of fixed
parameters followed by options, these options are passed in a named
fashion, for example
$mesg = $ldap->bind( "me", password => "mypasswd");
The return value from these methods is an object derived from the
L<Net::LDAP::Message> class. The methods of this class allow
you to examine the status of request.
=over 4
=item abandon ( ID [, OPTIONS ] )
Request server to abandon a request. The id to abandon may be passed as the
first parameter or as part of the options list. The B<ID> may be a number
or a object which is a sub-class of L<Net::LDAP::Message>, returned from
a previous method call.
=over 4
=item id
This option is here for B<compatibility only>, and may be removed in future.
Previous releases did not take the B<ID> argument which replaces this option.
=item control
See L</CONTROLS> below
=item callback
See L</CALLBACKS> below
=back
B<Example>
$mesg = $ldap->search( @search_args );
$ldap->abandon( $mesg ); # This could be written as $mesg->abandon
=item add ( DN [, OPTIONS ] )
Add an entry to the directory. The B<DN> argument can be either a
L<Net::LDAP::Entry> object or a string.
=over 4
=item dn
This option is here for B<compatibility only>, and may be removed in future.
Previous releases did not take the B<DN> argument which replaces this option.
=item attrs
This argument is a reference to a list of attribute-value pairs. Attributes
with multiple values can be added as either multiple entries or the value
could be a reference to a list of values.
This argument is not used if B<DN> is a L<Net::LDAP::Entry> object.
=item control
See L</CONTROLS> below
=item callback
See L</CALLBACKS> below
=back
B<Example>
# $entry is an object of class Net::LDAP::Entry
$mesg = $ldap->add( $entry );
$mesg = $ldap->add( $DN,
attrs => [
name => 'Graham Barr',
attr => 'value1',
attr => 'value2',
multi => [qw(value1 value2)]
]
);
=item bind ( [ DN [, OPTIONS ]] )
Bind to the server. B<DN> is the DN to bind as. An anonymous bind may be done
by calling bind without any arguments.
=over 4
=item dn
This option is here for B<compatibility only>, and may be removed in future.
Previous releases did not take the B<DN> argument which replaces this option.
=item control
See L</CONTROLS> below
=item callback
See L</CALLBACKS> below
=back
Only one of the following should be given, if none are given then B<noauth>
is assumed.
=over 4
=item noauth
=item anonymous
Bind without any password, the value passed with this option is ignored. This
is the default if no arguments are given.
=item password
Bind with the given password.
=item kerberos41
Bind using Kerberos V4.1 B<I<not supported>>.
=item kerberos42
Bind using Kerberos V4.2 B<I<not supported>>.
=item sasl
Bind using a SASL mechanism. The argument given should be a sub-class
of L<Authen::SASL>.
=back
B<Example>
$ldap->bind; # Anonymous bind
$ldap->bind( $DN, password => $password);
# $sasl is an object of class Authen::SASL
$ldap->bind( $DN, sasl => $sasl, version => 3);
=item compare ( DN, OPTIONS )
Perform a comparison on the server. B<DN> is the DN which the comparison is
to be performed. B<DN> May be a string or a L<Net::LDAP::Entry>
object.
=over 4
=item dn
This option is here for B<compatibility only>, and may be removed in future.
Previous releases did not take the B<DN> argument which replaces this option.
=item attr
The name of the attribute to compare.
=item value
The value to compare with.
=item control
See L</CONTROLS> below.
=item callback
See L</CALLBACKS> below.
=back
B<Example>
$ldap->compare( $DN,
attr => 'cn',
value => 'Graham Barr'
);
=item delete ( DN [, OPTIONS ] )
Delete B<DN> from the server. B<DN> May be a string or a L<Net::LDAP::Entry>
object.
=over 4
=item dn
This option is here for B<compatibility only>, and may be removed in future.
Previous releases did not take the B<DN> argument which replaces this option.
=item control
See L</CONTROLS> below.
=item callback
See L</CALLBACKS> below.
=back
B<Example>
$ldap->delete( $dn );
=item moddn ( DN, OPTIONS )
Modify the DN for B<DN> on the server. B<DN> May be a string or a
L<Net::LDAP::Entry> object.
=over 4
=item dn
This option is here for B<compatibility only>, and may be removed in future.
Previous releases did not take the B<DN> argument which replaces this option.
=item newrdn
This value should be a new RDN to assign to B<DN>.
=item deleteoldrdn
This value should be I<true> if the existing RDN is to be deleted.
=item newsuperior
If given this value should be the DN of the new superior for B<DN>.
=item control
See L</CONTROLS> below.
=item callback
See L</CALLBACKS> below.
=back
B<Example>
$ldap->moddn( $dn, newrdn => 'cn=Graham Barr');
=item modify ( DN, OPTIONS )
Modify the contents of B<DN> on the server. B<DN> May be a string or a
L<Net::LDAP::Entry> object.
=over 4
=item dn
This option is here for B<compatibility only>, and may be removed in future.
Previous releases did not take the B<DN> argument which replaces this option.
=item add
The B<add> option should be a reference to a HASH. The values of the
HASH are the attributes to add, and the values may be a string or a reference
to a list of values.
=item delete
A reference to an ARRAY of attributes to delete or a reference to a
HASH (as in B<add>) if only specific values should be deleted. If the
value for any attribute in the HASH is a reference to an empty ARRAY
the all instances of the attribute will be deleted.
=item replace
The <replace> option takes a argument in the same form as B<add>, but will
cause any existing attributes with the same name to be replaced. If the
value for any attribute in the HASH is a reference to an empty ARRAY
the all instances of the attribute will be deleted.
=item changes
This is an alternative to B<add>, B<delete> and B<replace> where the
whole operation can be given in a single argument. The argument should
be a reference to an ARRAY.
Values in the ARRAY are used in pairs, the first is the operation
B<add>, B<delete> or B<replace> and the second is a reference to an
ARRAY of attribute values.
The attribute value list is also used in pairs. The first value in each
pair is the attribute name and the second is a reference to a list of values.
Use this form if you want to control the order in which the operations will
be performed.
=item control
See L</CONTROLS> below.
=item callback
See L</CALLBACKS> below.
=back
B<Example>
$ldap->modify( $dn, add => { sn => 'Barr' } );
$ldap->modify( $dn, delete => [qw(faxNumber)]);
$ldap->modify( $dn, delete => { 'telephoneNumber' => '911' });
$ldap->modify( $dn, replace => { 'email' => 'gbarr@pobox.com' });
$ldap->modify( $dn,
changes => [
add => [ sn => 'Barr' ], # Add sn=Barr
delete => [ faxNumber => []], # Delete all fax numbers
delete => [ telephoneNumber => ['911']], # delete phone number 911
replace => [ email => 'gbarr@pobox.com'] # change email address
]
);
=item root_dse ( OPTIONS )
The root_dse method retrieves information from the server's
rootDSE entry.
=over 4
=item attrs
A reference to a list of attributes to be returned.
If not specified, then the following attributes will be requested
subschemaSubentry
namingContexts
altServer
supportedExtension
supportedControl
supportedSASLMechanisms
supportedLDAPVersion
=back
The result is an object of class L<Net::LDAP::Search>.
B<Example>
my $root = $ldap->root_dse();
# get naming Context
$root->get_value('namingContext', asref => 1);
# get supported LDAP versions
$root->get_value('supportedLDAPVersion', asref => 1);
=item schema ( OPTIONS )
Request that a schema search be performed. This can be used to read
schema information.
The result is an object of class L<Net::LDAP::Schema>.
Read this documentation for further information about methods that
can be preformed with this object.
=over 4
=item dn
If a DN is supplied, it will become the base object entry from
which the search for schema information will be conducted. If
no DN is supplied the base object entry will be determined from
the rootDSE entry.
B<Example>
my $schema = $ldap->schema();
# get objectClasses
@ocs = $schema->objectclasses();
# Get the attributes
@atts = $schema->attributes();
=item search ( OPTIONS )
Request that a search be performed. This can be used to read attributes
from a single entry, from entries immediately below a particular entry,
or a whole subtree of entries.
The result is an object of class L<Net::LDAP::Search>.
=over 4
=item base
The DN that is the base object entry relative to which the search is
to be performed.
=item scope
By default the search is performed on the whole tree below
the specified base object. This may be chaned by specifying a C<scope>
parameter with one of the following values.
=over 4
=item base
Search only the base object.
=item one
Search the entries immediately below the base object.
=item sub
Search the whole tree below the base object. This is the default.
=back
=item deref
By default aliases are
dereferenced to locate the base object for the search, but not when
searching subordinates of the base object. This may be changed by
specifying a C<deref> parameter with one of the following values.
=over 4
=item never
Do not dereference aliases in searching
or in locating the base object of the search.
=item search
Dereference aliases in subordinates of the base object in searching,
but not in locating the base object of the search.
=item find
Dereference aliases in locating the base object of the search, but not
when searching subordinates of the base object. This is the default.
=item always
Dereference aliases both in searching and in locating the base object
of the search.
=back
=item sizelimit
A sizelimit that restricts the maximum number of entries to be returned
as a result of the search. A value of 0, and the default, means that
no restriction is requested. Servers may enforce a maximum number of
entries to return.
=item timelimit
A timelimit that restricts the maximum time (in seconds) allowed for
a search. A value of 0, and the default, means that no timelimit will
be requested.
=item typesonly
An indicator as to whether search results should contain both attribute
types and values, or just attribute types. Setting this parameter to
a I<true> value causes only attribute types (no values) to be returned.
Setting this field to a I<false> causes both attribute types and values
to be returned. The default is to return both attribute types and values.
=item filter
A filter that defines the conditions an entry in the directory must meet
in order for it to be returned by the search. This may be a string or a
L<Net::LDAP::Filter> object. See L<Net::LDAP::Filter> for a defintion of
the filter format.
=item attrs
A reference to a list of attributes to be returned for each entry that
matches the search filter.
If not specified, then the server will return the attributes that are
specified as accessible by default given your bind credentials.
Certain additional attributes such as "createtimestamp" and other
operational attributes may also be available for the asking:
$ldap->search( ... , attrs => ['createtimestamp'] , ... );
To retreive the default attributes and additional ones, use '*'.
$ldap->search( ... , attrs => ['*', 'createtimestamp'] , ... );
=item control
See L</CONTROLS> below.
=item callback
See L</CALLBACKS> below.
=back
B<Example>
$mesg = $ldap->search(
base => $base_dn,
scope => 'sub',
filter => '(|(objectclass=rfc822mailgroup)(sn=jones))'
);
Net::LDAP::LDIF->new(\*STDOUT,"w")->write($mesg->entries);
=item unbind
The unbind method does not take any parameters and will unbind you
from the server. While some servers may allow you to re-bind or perform
other operations after unbinding, the only portable operation is closing
the connection. In the case that you wish to switch to another set of
credentials while continuing to use the same connection, re-binding with
another DN and password, without unbind-ing, will generally work.
B<Example>
$ldap->unbind;
=back
The following methods are for convenience.
=over 4
=item async
Returns I<true> if the LDAP operations are being performed asynchronously.
=item debug ( [ VALUE ] )
If B<VALUE> is given the debug bit-value will be set to B<VALUE> and the
previous value will be returned. If not given the bit-value will remain
unchanged and will be returned.
=item sync ( [ MESG ] )
Calling this method will synchronize the client with the server. It will
not return until all requests have been completed, or id B<MESG> is given
it will return when B<MESG> has been completed.
Returns an error code defined in L<Net::LDAP::Constant>.
=item start_tls ( [ OPTIONS ] )
Calling this method will convert the connection to using Transport
Layer Security (TLS), which potentially provides an encrypted
connection. This is I<only> possible if the connection is using
LDAPv3. OPTIONS is a number of key-value pairs which describe how to
configure the security of the connection:
=over 4
=item verify
How to verify the server's certificate, either 'none' (the server may
provide a certificate but it will not be checked - this may mean you
are be connected to the wrong server), 'optional' (verify if the
server offers a certificate), or 'require' (the server must provide a
certificate, and it must be valid.) If you set verify to optional or
require, you must also set either cafile or capath. The most secure
option is 'require'.
=item sslversion
This defines the version of the SSL/TLS protocol to use. Defaults to
'tlsv1', other possible values are 'sslv2', 'sslv3', and 'sslv2/3'.
=item ciphers
Specify which subset of cipher suites are permissible for this
connection, using the standard OpenSSL string format. The default
value for ciphers is 'ALL', which permits all ciphers, even those that
don't encrypt!
=item clientcert
=item clientkey
If you want to use the client to offer a certificate to the server for
SSL authentication (which is not the same as for the LDAP Bind
operation) then set clientcert to the user's certificate file, and
clientkey to the user's private key file. These files must be in PEM
format.
=item capath
=item cafile
When verifying the server's certificate, either set capath to the
pathname of the directory containing CA certificates, or set cafile to
the filename containing the certificate of the CA who signed the
server's certificate. These certificates must all be in PEM format.
The directory in 'capath' must contain certificates named using the
hash value of themselves. To generate these names, use OpenSSL like
this in Unix:
ln -s cacert.pem `openssl x509 -hash -noout < cacert.pem`.0
(assuming that the certificate of the CA is in cacert.pem.)
=back
=back
=over 4
=item cipher
Returns the cipher mode being used by the connection, in the string
format used by OpenSSL.
=item certificate
Returns an X509_Certificate object containing the server's
certificate. See the IO::Socket::SSL documentation for information
about this class.
For example, to get the subject name (in a peculiar OpenSSL-specific
format, different from RFC 1779 and RFC 2253) from the server's
certificate, do this:
print "Subject DN: " . $ldaps->certificate->subject_name . "\n";
=back
=item version
Returns the version of the LDAP protocol that is being used.
=back
=head1 CONTROLS
Many of the methods described above accept a control option.
This allows the user to pass controls to the server as described
in LDAPv3. The value to the control argument may be either a
single control or a reference to an array of controls.
A control is a reference to a HASH and should contain the three
elements below. If any of the controls are blessed then the
method C<to_asn> will be called which should return a reference
to a HASH containing the three elements described below.
=over 4
=item type
This element must be present and is the name of the type of control
being requested.
=item critical
critical is optional and should be a boolean value, if it is not specified
then it is assumed to be I<false>.
=item value
If the control being requested requires a value then this element should
hold the value for the server.
=back
=head1 CALLBACKS
Most of the above commands accept a callback option. This option
should be a reference to a subroutine. This subroutine will be called
for each packet received from the server as a response to the request
sent.
When the subroutine is called the first argument will be the
L<Net::LDAP::Message> object which was returned from the method.
If the request is a search then multiple packets can be received from
the server. Each entry is received as a separate packet. For each of these
the subroutine will be called with a L<Net::LDAP::Entry> object as the second
argument.
During a search the server may also send a list of references. When such
a list is received then the subroutine will be called with a
L<Net::LDAP::Reference> object as the second argument.
=head1 LDAP ERROR CODES
B<Net::LDAP> also exports constants for the error codes that can be received
from the server, see L<Net::LDAP::Constant>.
=head1 SEE ALSO
L<Net::LDAP::Constant>,
L<Net::LDAP::Control>,
L<Net::LDAP::Entry>,
L<Net::LDAP::Filter>,
L<Net::LDAP::Message>,
L<Net::LDAP::Reference>,
L<Net::LDAP::Search>,
L<Net::LDAP::RFC>
The homepage for the perl-ldap modules can be found at
http://www.pobox.com/~gbarr/perl-ldap/.
=head1 ACKNOWLEDGEMENTS
This document is based on a document originally written by Russell Fulton
<r.fulton@auckland.ac.nz>.
Chris Ridd @isode.com for the many hours spent testing and contribution
of the ldap* command line utilities.
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap-dev@lists.sourceforge.net>
=head1 COPYRIGHT
Copyright (c) 1997-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>
I<$Id$>
=cut

366
lib/Net/LDAP/ASN.pm Normal file
View file

@ -0,0 +1,366 @@
# $Id$
package Net::LDAP::ASN;
use Convert::ASN1;
my $asn = Convert::ASN1->new;
sub import {
my $pkg = shift;
my $caller = caller;
foreach my $macro (@_) {
my $obj = $asn->find($macro)
or require Carp and Carp::croak("Unknown macro '$macro'");
*{"$caller\::$macro"} = \$obj;
}
}
$asn->prepare(<<LDAP_ASN) or die $asn->error;
-- We have split LDAPMessage into LDAPResponse and LDAPRequest
-- The purpose of this is two fold
-- 1) for encode we don't want the protocolOp
-- in the hierarchy as it is not really neede
-- 2) For decode we do want it, this allows Net::LDAP::Message::decode
-- to be much simpler. Decode will also be faster due to
-- less elements in the CHOICE
LDAPRequest ::= SEQUENCE {
messageID MessageID,
--protocolOp
CHOICE {
bindRequest BindRequest,
unbindRequest UnbindRequest,
searchRequest SearchRequest,
modifyRequest ModifyRequest,
addRequest AddRequest,
delRequest DelRequest,
modDNRequest ModifyDNRequest,
compareRequest CompareRequest,
abandonRequest AbandonRequest,
extendedReq ExtendedRequest}
controls [0] Controls OPTIONAL }
LDAPResponse ::= SEQUENCE {
messageID MessageID,
protocolOp CHOICE {
bindResponse BindResponse,
searchResEntry SearchResultEntry,
searchResDone SearchResultDone,
searchResRef SearchResultReference,
modifyResponse ModifyResponse,
addResponse AddResponse,
delResponse DelResponse,
modDNResponse ModifyDNResponse,
compareResponse CompareResponse,
extendedResp ExtendedResponse }
controls [0] Controls OPTIONAL }
MessageID ::= INTEGER -- (0 .. maxInt)
-- maxInt INTEGER ::= 2147483647 -- (2^^31 - 1) --
LDAPString ::= OCTET STRING -- UTF8String ??
LDAPOID ::= OCTET STRING
LDAPDN ::= LDAPString
RelativeLDAPDN ::= LDAPString
AttributeType ::= LDAPString
AttributeDescription ::= LDAPString
AttributeDescriptionList ::= SEQUENCE OF
AttributeDescription
AttributeValue ::= OCTET STRING
AttributeValueAssertion ::= SEQUENCE {
attributeDesc AttributeDescription,
assertionValue AssertionValue }
AssertionValue ::= OCTET STRING
Attribute ::= SEQUENCE {
type AttributeDescription,
vals SET OF AttributeValue }
MatchingRuleId ::= LDAPString
LDAPResult ::= SEQUENCE {
resultCode ENUMERATED {
success (0),
operationsError (1),
protocolError (2),
timeLimitExceeded (3),
sizeLimitExceeded (4),
compareFalse (5),
compareTrue (6),
authMethodNotSupported (7),
strongAuthRequired (8),
-- 9 reserved --
referral (10), -- new
adminLimitExceeded (11), -- new
unavailableCriticalExtension (12), -- new
confidentialityRequired (13), -- new
saslBindInProgress (14), -- new
noSuchAttribute (16),
undefinedAttributeType (17),
inappropriateMatching (18),
constraintViolation (19),
attributeOrValueExists (20),
invalidAttributeSyntax (21),
-- 22-31 unused --
noSuchObject (32),
aliasProblem (33),
invalidDNSyntax (34),
-- 35 reserved for undefined isLeaf --
aliasDereferencingProblem (36),
-- 37-47 unused --
inappropriateAuthentication (48),
invalidCredentials (49),
insufficientAccessRights (50),
busy (51),
unavailable (52),
unwillingToPerform (53),
loopDetect (54),
-- 55-63 unused --
namingViolation (64),
objectClassViolation (65),
notAllowedOnNonLeaf (66),
notAllowedOnRDN (67),
entryAlreadyExists (68),
objectClassModsProhibited (69),
-- 70 reserved for CLDAP --
affectsMultipleDSAs (71), -- new
-- 72-79 unused --
other (80)}
-- 81-90 reserved for APIs --
matchedDN LDAPDN,
errorMessage LDAPString,
referral [3] Referral OPTIONAL }
Referral ::= SEQUENCE OF LDAPURL
LDAPURL ::= LDAPString -- limited to characters permitted in URLs
Controls ::= SEQUENCE OF Control
-- Names changed here for backwards compat with previous
-- Net::LDAP --GMB
Control ::= SEQUENCE {
type LDAPOID, -- controlType
critical BOOLEAN OPTIONAL, -- DEFAULT FALSE, -- criticality
value OCTET STRING OPTIONAL } -- controlValue
BindRequest ::= [APPLICATION 0] SEQUENCE {
version INTEGER, -- (1 .. 127),
name LDAPDN,
authentication AuthenticationChoice }
AuthenticationChoice ::= CHOICE {
simple [0] OCTET STRING,
-- 1 and 2 reserved
sasl [3] SaslCredentials }
SaslCredentials ::= SEQUENCE {
mechanism LDAPString,
credentials OCTET STRING OPTIONAL }
BindResponse ::= [APPLICATION 1] SEQUENCE {
COMPONENTS OF LDAPResult,
serverSaslCreds [7] OCTET STRING OPTIONAL }
UnbindRequest ::= [APPLICATION 2] NULL
SearchRequest ::= [APPLICATION 3] SEQUENCE {
baseObject LDAPDN,
scope ENUMERATED {
baseObject (0),
singleLevel (1),
wholeSubtree (2) }
derefAliases ENUMERATED {
neverDerefAliases (0),
derefInSearching (1),
derefFindingBaseObj (2),
derefAlways (3) }
sizeLimit INTEGER , -- (0 .. maxInt),
timeLimit INTEGER , -- (0 .. maxInt),
typesOnly BOOLEAN,
filter Filter,
attributes AttributeDescriptionList }
Filter ::= CHOICE {
and [0] SET OF Filter,
or [1] SET OF Filter,
not [2] Filter,
equalityMatch [3] AttributeValueAssertion,
substrings [4] SubstringFilter,
greaterOrEqual [5] AttributeValueAssertion,
lessOrEqual [6] AttributeValueAssertion,
present [7] AttributeDescription,
approxMatch [8] AttributeValueAssertion,
extensibleMatch [9] MatchingRuleAssertion }
SubstringFilter ::= SEQUENCE {
type AttributeDescription,
-- at least one must be present
substrings SEQUENCE OF CHOICE {
initial [0] LDAPString,
any [1] LDAPString,
final [2] LDAPString } }
MatchingRuleAssertion ::= SEQUENCE {
matchingRule [1] MatchingRuleId OPTIONAL,
type [2] AttributeDescription OPTIONAL,
matchValue [3] AssertionValue,
dnAttributes [4] BOOLEAN OPTIONAL } -- DEFAULT FALSE }
SearchResultEntry ::= [APPLICATION 4] SEQUENCE {
objectName LDAPDN,
attributes PartialAttributeList }
PartialAttributeList ::= SEQUENCE OF SEQUENCE {
type AttributeDescription,
vals SET OF AttributeValue }
SearchResultReference ::= [APPLICATION 19] SEQUENCE OF LDAPURL
SearchResultDone ::= [APPLICATION 5] LDAPResult
ModifyRequest ::= [APPLICATION 6] SEQUENCE {
object LDAPDN,
modification SEQUENCE OF SEQUENCE {
operation ENUMERATED {
add (0),
delete (1),
replace (2) }
modification AttributeTypeAndValues } }
AttributeTypeAndValues ::= SEQUENCE {
type AttributeDescription,
vals SET OF AttributeValue }
ModifyResponse ::= [APPLICATION 7] LDAPResult
AddRequest ::= [APPLICATION 8] SEQUENCE {
objectName LDAPDN,
attributes AttributeList }
AttributeList ::= SEQUENCE OF SEQUENCE {
type AttributeDescription,
vals SET OF AttributeValue }
AddResponse ::= [APPLICATION 9] LDAPResult
DelRequest ::= [APPLICATION 10] LDAPDN
DelResponse ::= [APPLICATION 11] LDAPResult
ModifyDNRequest ::= [APPLICATION 12] SEQUENCE {
entry LDAPDN,
newrdn RelativeLDAPDN,
deleteoldrdn BOOLEAN,
newSuperior [0] LDAPDN OPTIONAL }
ModifyDNResponse ::= [APPLICATION 13] LDAPResult
CompareRequest ::= [APPLICATION 14] SEQUENCE {
entry LDAPDN,
ava AttributeValueAssertion }
CompareResponse ::= [APPLICATION 15] LDAPResult
AbandonRequest ::= [APPLICATION 16] MessageID
ExtendedRequest ::= [APPLICATION 23] SEQUENCE {
requestName [0] LDAPOID,
requestValue [1] OCTET STRING OPTIONAL }
ExtendedResponse ::= [APPLICATION 24] SEQUENCE {
COMPONENTS OF LDAPResult,
responseName [10] LDAPOID OPTIONAL,
response [11] OCTET STRING OPTIONAL }
VirtualListViewRequest ::= SEQUENCE {
beforeCount INTEGER , --(0 .. maxInt),
afterCount INTEGER , --(0 .. maxInt),
CHOICE {
byoffset [0] SEQUENCE {
offset INTEGER , --(0 .. maxInt),
contentCount INTEGER } --(0 .. maxInt) }
byValue [1] AssertionValue }
-- byValue [1] greaterThanOrEqual assertionValue }
contextID OCTET STRING OPTIONAL }
VirtualListViewResponse ::= SEQUENCE {
targetPosition INTEGER , --(0 .. maxInt),
contentCount INTEGER , --(0 .. maxInt),
virtualListViewResult ENUMERATED {
success (0),
operatonsError (1),
unwillingToPerform (53),
insufficientAccessRights (50),
busy (51),
timeLimitExceeded (3),
adminLimitExceeded (11),
sortControlMissing (60),
indexRangeError (61),
other (80) } }
LDAPEntry ::= COMPONENTS OF AddRequest
-- Current parser does not allow a named entity following the ::=
-- so we use a COMPONENTS OF hack
SortRequestDummy ::= SEQUENCE {
order SEQUENCE OF SEQUENCE {
type OCTET STRING,
orderingRule [0] OCTET STRING OPTIONAL,
reverseOrder [1] BOOLEAN OPTIONAL } }
SortRequest ::= COMPONENTS OF SortRequestDummy
SortResult ::= SEQUENCE {
sortResult ENUMERATED {
success (0), -- results are sorted
operationsError (1), -- server internal failure
timeLimitExceeded (3), -- timelimit reached before
-- sorting was completed
strongAuthRequired (8), -- refused to return sorted
-- results via insecure
-- protocol
adminLimitExceeded (11), -- too many matching entries
-- for the server to sort
noSuchAttribute (16), -- unrecognized attribute
-- type in sort key
inappropriateMatching (18), -- unrecognized or inappro-
-- priate matching rule in
-- sort key
insufficientAccessRights (50), -- refused to return sorted
-- results to this client
busy (51), -- too busy to process
unwillingToPerform (53), -- unable to sort
other (80) }
attributeType [0] AttributeDescription OPTIONAL }
realSearchControlValue ::= SEQUENCE {
size INTEGER, -- (0..maxInt),
-- requested page size from client
-- result set size estimate from server
cookie OCTET STRING }
proxyAuthValue ::= SEQUENCE {
proxyDN LDAPDN
}
LDAP_ASN
1;

55
lib/Net/LDAP/Bind.pm Normal file
View file

@ -0,0 +1,55 @@
# Copyright (c) 1998-2000 Graham Barr <gbarr@pobox.com>. 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::Bind;
use strict;
use Net::LDAP qw(LDAP_SASL_BIND_IN_PROGRESS LDAP_DECODING_ERROR);
use Net::LDAP::Message;
use vars qw(@ISA);
@ISA = qw(Net::LDAP::Message);
sub _sasl_info {
my $self = shift;
@{$self}{qw(dn saslctrl sasl)} = @_;
}
sub decode {
my $self = shift;
my $result = shift;
my $bind = $result->{protocolOp}{bindResponse}
or $self->set_error(LDAP_DECODING_ERROR,"LDAP decode error")
and return;
return $self->SUPER::decode($result)
unless $bind->{resultCode} == LDAP_SASL_BIND_IN_PROGRESS;
# 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(
bindRequest => {
version => $ldap->version,
name => $self->{dn},
authentication => {
sasl => {
mechanism => $sasl->name,
credentials => $resp
}
},
control => $self->{saslcontrol}
});
$ldap->_sendmesg($self);
}
1;

108
lib/Net/LDAP/Constant.pm Normal file
View file

@ -0,0 +1,108 @@
# Copyright (c) 1998-2000 Graham Barr <gbarr@pobox.com>. 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::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;

347
lib/Net/LDAP/Constant.pod Normal file
View file

@ -0,0 +1,347 @@
=head1 NAME
Net::LDAP::Constant - Constants for use with Net::LDAP
=head1 SYNOPSIS
use Net::LDAP qw(LDAP_SUCCESS LDAP_PROTOCOL_ERROR);
# import all constants
use Net::LDAP qw(:all);
=head1 DESCRIPTION
B<Net::LDAP::Constant> exports constant subroutines for the following LDAP
error codes.
=over 4
=item LDAP_SUCCESS
Operation completed without error
=item LDAP_OPERATIONS_ERROR
Server encountered an internal error
=item LDAP_PROTOCOL_ERROR
Unrecognized version number or incorrect PDU structure
=item LDAP_TIMELIMIT_EXCEEDED
The time limit on a search operation has been exceeded
=item LDAP_SIZELIMIT_EXCEEDED
The maximum number of search results to return has been exceeded.
=item LDAP_COMPARE_FALSE
This code is returned when a compare request completes and the attribute value
given is not in the entry specified
=item LDAP_COMPARE_TRUE
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
Unrecognized SASL mechanism name
=item LDAP_STRONG_AUTH_REQUIRED
The server requires authentication be performed with a SASL mechanism
=item LDAP_PARTIAL_RESULTS
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
The server is referring the client to another server. The response will
contain a list of URL's
=item LDAP_ADMIN_LIMIT_EXCEEDED
The server has exceed the maximum number of entries to search while gathering
a list of search result candidates
=item LDAP_UNAVAILABLE_CRITICAL_EXT
A control or matching rule specified in the request is not supported by
the server
=item LDAP_CONFIDENTIALITY_REQUIRED
This result code is returned when confidentiality is required to perform
a given operation
=item LDAP_SASL_BIND_IN_PROGRESS
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
The request referenced an attribute that does not exist
=item LDAP_UNDEFINED_TYPE
The request contains an undefined attribute type
=item LDAP_INAPPROPRIATE_MATCHING
An extensible matching rule in the given filter does not apply to the specified
attribute
=item LDAP_CONSTRAINT_VIOLATION
The request contains a value which does not meet with certain constraints.
This result can be returned as a consequence of
=over 8
=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
The request attempted to add an attribute type or value that already exists
=item LDAP_INVALID_SYNTAX
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
The server cannot find an object specified in the request
=item LDAP_ALIAS_PROBLEM
Server encountered a problem while attempting to dereference an alias
=item LDAP_INVALID_DN_SYNTAX
The request contained an invalid DN
=item LDAP_IS_LEAF
The specified entry is a leaf entry
=item LDAP_ALIAS_DEREF_PROBLEM
Server encountered a problem while attempting to dereference an alias
=item LDAP_INAPPROPRIATE_AUTH
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
The wrong password was supplied or the SASL credentials could not be processed
=item LDAP_INSUFFICIENT_ACCESS
The client does not have sufficient access to perform the requested
operation
=item LDAP_BUSY
The server is too busy to perform requested operation
=item LDAP_UNAVAILABLE
The server in unavailable to perform the request, or the server is
shutting down
=item LDAP_UNWILLING_TO_PERFORM
The server is unwilling to perform the requested operation
=item LDAP_LOOP_DETECT
The server was unable to perform the request due to an internal loop detected
=item LDAP_SORT_CONTROL_MISSING
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
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
The request violates the structure of the DIT
=item LDAP_OBJECT_CLASS_VIOLATION
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
The requested operation is not allowed on an entry that has child entries
=item LDAP_NOT_ALLOWED_ON_RDN
The requested operation ill affect the RDN of the entry
=item LDAP_ALREADY_EXISTS
The client attempted to add an entry that already exists. This can occur as
a result of
=over 8
=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
Request attempt to modify the object class of an entry that should not be
modified
=item LDAP_RESULTS_TOO_LARGE
The results of the request are to large
=item LDAP_AFFECTS_MULTIPLE_DSAS
The requested operation needs to be performed on multiple servers where
the requested operation is not permitted
=item LDAP_OTHER
An unknown error has occurred
=item LDAP_SERVER_DOWN
C<Net::LDAP> cannot establish a connection or the connection has been lost
=item LDAP_LOCAL_ERROR
An error occurred in C<Net::LDAP>
=item LDAP_ENCODING_ERROR
C<Net::LDAP> encountered an error while encoding the request packet that would
have been sent to the server
=item LDAP_DECODING_ERROR
C<Net::LDAP> encountered an error while decoding a response packet from
the server.
=item LDAP_TIMEOUT
C<Net::LDAP> timeout while waiting for a response from the server
=item LDAP_AUTH_UNKNOWN
The method of authentication requested in a bind request is unknown to
the server
=item LDAP_FILTER_ERROR
An error occurred while encoding the given search filter.
=item LDAP_USER_CANCELED
The user canceled the operation
=item LDAP_PARAM_ERROR
An invalid parameter was specified
=item LDAP_NO_MEMORY
Out of memory error
=item LDAP_CONNECT_ERROR
A connection to the server could not be established
=item LDAP_NOT_SUPPORTED
An attempt has been made to use a feature not supported by Net::LDAP
=item LDAP_CONTROL_NOT_FOUND
The controls required to perform the requested operation were not
found.
=item LDAP_NO_RESULTS_RETURNED
No results were returned from the server.
=item LDAP_MORE_RESULTS_TO_RETURN
There are more results in the chain of results.
=item LDAP_CLIENT_LOOP
A loop has been detected. For example when following referals.
=item LDAP_REFERRAL_LIMIT_EXCEEDED
The referral hop limit has been exceeded.
=back
=head1 SEE ALSO
L<Net::LDAP>,
L<Net::LDAP::Message>
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap-dev@lists.sourceforge.net>
=head1 COPYRIGHT
Copyright (c) 1998-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>
I<$Id$>
=cut

290
lib/Net/LDAP/Control.pm Normal file
View file

@ -0,0 +1,290 @@
# $Id$
# Copyright (c) 1999-2000 Graham Barr <gbarr@pobox.com>. 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::Control;
use Net::LDAP::Constant qw(/^LDAP_CONTROL/);
use vars qw($VERSION);
use strict;
$VERSION = "0.04";
my %Pkg2Type = (
'Net::LDAP::Control::Sort' => LDAP_CONTROL_SORTREQUEST,
'Net::LDAP::Control::SortResult' => LDAP_CONTROL_SORTRESULT,
'Net::LDAP::Control::VLV' => LDAP_CONTROL_VLVREQUEST,
'Net::LDAP::Control::VLVResponse' => LDAP_CONTROL_VLVRESPONSE,
'Net::LDAP::Control::Paged' => LDAP_CONTROL_PAGED,
'Net::LDAP::Control::ProxyAuth' => LDAP_CONTROL_PROXYAUTHENTICATION,
#LDAP_CONTROL_MANAGEDSAIT
#LDAP_CONTROL_PERSISTENTSEARCH
#LDAP_CONTROL_ENTRYCHANGE
#
#LDAP_CONTROL_PWEXPIRED
#LDAP_CONTROL_PWEXPIRING
#
#LDAP_CONTROL_REFERRALS
);
my %Type2Pkg = reverse %Pkg2Type;
sub register {
my($class,$oid) = @_;
require Carp and Carp::croak("$oid is already registered to $Type2Pkg{$oid}")
if exists $Type2Pkg{$oid} and $Type2Pkg{$oid} ne $class;
require Carp and Carp::croak("$class is already registered to $Pkg2Type{$class}")
if exists $Pkg2Type{$class} and $Pkg2Type{$class} ne $oid;
$Type2Pkg{$oid} = $class;
$Pkg2Type{$class} = $oid;
}
sub new {
my $self = shift;
my $pkg = ref($self) || $self;
my $oid = (@_ & 1) ? shift : undef;
my %args = @_;
$args{'type'} ||= $oid || $Pkg2Type{$pkg} || '';
unless ($args{type} =~ /^\d+(?:\.\d+)+$/) {
$args{error} = 'Invalid OID';
return bless \%args;
}
if ($pkg eq __PACKAGE__ and exists $Type2Pkg{$args{type}}) {
$pkg = $Type2Pkg{$args{type}};
eval "require $pkg" or die $@;
}
delete $args{error};
bless(\%args, $pkg)->init;
}
sub from_asn {
my $self = shift;
my $asn = shift;
my $class = ref($self) || $self;
if ($class eq __PACKAGE__ and exists $Type2Pkg{$asn->{type}}) {
$class = $Type2Pkg{$asn->{type}};
eval "require $class" or die $@;
}
delete $asn->{error};
bless($asn, $class)->init;
}
sub to_asn {
my $self = shift;
$self->value; # Ensure value is there
delete $self->{critical} unless $self->{critical};
$self;
}
sub critical {
my $self = shift;
$self->{critical} = shift if @_;
$self->{critical} || 0;
}
sub value {
my $self = shift;
$self->{value} = shift if @_;
$self->{value} || undef
}
sub type { shift->{type} }
sub valid { ! exists shift->{error} }
sub error { shift->{error} }
sub init { shift }
1;
__END__
=head1 NAME
Net::LDAP::Control - LDAPv3 control object base class
=head1 SYNOPSIS
use Net::LDAP::Control;
use Net::LDAP::Constant qw( LDAP_CONTROL_MATCHEDVALS );
$ctrl = Net::LDAP::Control->new(
type => "1.2.3.4",
value => "help",
critical => 0
);
$mesg = $ldap->search( @args, control => [ $ctrl ]);
$ctrl = Net::LDAP::Control->new( type => LDAP_CONTROL_MATCHEDVALS );
=head1 DESCRIPTION
C<Net::LDAP::Control> is a base-class for LDAPv3 control objects.
=cut
##
## Need more blurb in here about controls
##
=head1 CONSTRUCTORS
=over 4
=item new ARGS
ARGS is a list of name/value pairs, valid arguments are.
=over 4
=item critical
A booloean value, if TRUE and the control is unrecognized by the server or
is inappropriate for the requested operation then the server will return
an error and the operation will not be performed.
If FALSE and the control is unrecognized by the server or
is inappropriate for the requested operation then the server will ignore
the control and perform the requested operation as if the control was
not given.
If absent, FALSE is assume.
=item type
A dotted-decimal representation of an OBJECT IDENTIFIER which
uniquely identifies the control. This prevents conflicts between
control names.
This may be ommitted if the contructor is being called on a sub-class of
Net::LDAP::Control which has registered to be associated with an OID.
If the contructor is being called on the Net::LDAP::Control
package, then this argument must be given. If the given OID has been
registered by a package, then the returned object will be of the type
registered to handle that OID.
=item value
Optional information associated with the control. It's format is specific
to the particular control.
=back
=item from_asn ASN
ASN is a HASH reference, normally extracted from a PDU. It will contain
a C<type> element and optionally C<critical> and C<value> elements. On
return ASN will be blessed into a package. If C<type> is a registered
OID, then ASN will be blessed into the registered package, if not then ASN
will be blessed into Net::LDAP::Control.
This constructor is used internally by Net::LDAP and assumes that HASH
passed contains a valid control. It should be used with B<caution>.
=back
=head1 METHODS
In addition to the methods listed below, each of the named parameters
to C<new> is also avaliable as a method. C<type> will return the OID of
the control object. C<value> and C<critical> are set/get methods and will
return the current value for each attribute if called without arguments,
but may also be called with arguments to set new values.
=over 4
=item error
If there has been an error returns a description of the error, otherwise it will
return C<undef>
=item init
C<init> will be called as the last step in both contructors. What it does will depend
on the sub-class. It must always return the object.
=item register OID
C<register> is provided for sub-class implementors. It should be called as a class method
on a sub-class of Net::LDAP::Control with the OID that the class will handle. Net::LDAP::Control
will remember this class and OID pair and use it in the following
situations.
=over 4
=item *
C<new> is called as a class method on the Net::LDAP::Control package and OID is passed
as the type. The returned object will be blessed into the package that registered
the OID.
=item *
C<new> is called as a class method on a registered package and the C<type> is not
specified. The C<type> will be set to the OID registered by that package.
=item *
C<from_asn> is called to construct an object from ASN. The returned object will be
blessed into the package which was registered to handle the OID in the ASN.
=back
=item to_asn
Returns a structure suitable for passing to Convert::ASN1 for
encoding. This method will be called by L<Net::LDAP> when the
control is used.
The base class implementation of this method will call the C<value> method
without arguments to allow a sub-class to encode it's value. Sub-classes
should not need to override this method.
=item valid
Returns true if the object is valid and can be encoded. The default implementation
for this method is to return TRUE if there is no error, but sub-classes may override that.
=back
=head1 SEE ALSO
L<Net::LDAP>
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap-dev@lists.sourceforge.net>
=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>
I<$Id$>
=cut

165
lib/Net/LDAP/Control/Paged.pm Normal file
View file

@ -0,0 +1,165 @@
# $Id$
# Copyright (c) 2000 Graham Barr <gbarr@pobox.com>. 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::Control::Paged;
use vars qw(@ISA $VERSION);
use Net::LDAP::Control;
@ISA = qw(Net::LDAP::Control);
$VERSION = "0.01";
use Net::LDAP::ASN qw(realSearchControlValue);
use strict;
sub init {
my($self) = @_;
delete $self->{asn};
unless (exists $self->{value}) {
$self->{asn} = {
size => $self->{size} || 0,
cookie => defined($self->{cookie}) ? $self->{cookie} : ''
};
}
$self;
}
sub cookie {
my $self = shift;
$self->{asn} ||= $realSearchControlValue->decode($self->{value});
if (@_) {
delete $self->{value};
return $self->{asn}{cookie} = defined($_[0]) ? $_[0] : '';
}
$self->{asn}{cookie};
}
sub size {
my $self = shift;
$self->{asn} ||= $realSearchControlValue->decode($self->{value});
if (@_) {
delete $self->{value};
return $self->{asn}{size} = shift || 0;
}
$self->{asn}{size};
}
sub value {
my $self = shift;
exists $self->{value}
? $self->{value}
: $self->{value} = $realSearchControlValue->encode($self->{asn});
}
1;
__END__
=head1 NAME
Net::LDAP::Control::Paged - LDAPv3 Paged results control object
=head1 SYNOPSIS
use Net::LDAP;
use Net::LDAP::Control::Paged;
use Net::LDAP::Constant qw( LDAP_CONTROL_PAGED );
$ldap = Net::LDAP->new( "ldap.mydomain.eg" );
$page = Net::LDAP::Control::Paged->new( size => 100 );
@args = ( base => "cn=subnets,cn=sites,cn=configuration,$BASE_DN",
scope => "subtree",
filter => "(objectClass=subnet)",
callback => \&process_entry, # Call this sub for each entry
control => [ $page ],
);
my $cookie;
while(1) {
# Perform search
my $mesg = $ldap->search( @args );
# Only continue on LDAP_SUCCESS
$mesg->code and last;
# Get cookie from paged control
my($resp) = $mesg->control( LDAP_CONTROL_PAGED ) or last;
$cookie = $resp->cookie or last;
# Set cookie in paged control
$page->cookie($cookie);
}
if ($cookie) {
# We had an abnormal exit, so let the server know we do not want any more
$page->cookie($cookie);
$page->size(0);
$ldap->search( @args );
}
=head1 DESCRIPTION
C<Net::LDAP::Control::Paged> provides an interface for the creation and manipulatrion
of objects that represent the C<pagedResultsControl> as described by RFC-2696.
=head1 CONSTRUCTOR ARGUMENTS
In addition to the constructor arguments described in
L<Net::LDAP::Control> the following are provided.
=over 4
=item cookie
The value to use as the cookie. This is not normally set when an object is
created, but is set from the cookie value returned bu the server. This associates
a search with a previous search, so the server knows to return the page
of entries following the entries it returned the previous time.
=item size
The page size that is required. This is the maximum number of entries that the
server will return to the search request.
=back
=head1 METHODS
As with L<Net::LDAP::Control> each constructor argument
described above is also avaliable as a method on the object which will
return the current value for the attribute if called without an argument,
and set a new value for the attribute if called with an argument.
=head1 SEE ALSO
L<Net::LDAP>,
L<Net::LDAP::Control>,
http://info.internet.isi.edu/in-notes/rfc/files/rfc2696.txt
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap-dev@lists.sourceforge.net>
=head1 COPYRIGHT
Copyright (c) 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>
I<$Id$>
=cut

134
lib/Net/LDAP/Control/ProxyAuth.pm Normal file
View file

@ -0,0 +1,134 @@
# $Id$
# Copyright (c) 2001 Graham Barr <gbarr@pobox.com>. 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::Control::ProxyAuth;
use vars qw(@ISA $VERSION);
use Net::LDAP::Control;
@ISA = qw(Net::LDAP::Control);
$VERSION = do { my @r=(q$Revision$=~/\d+/g); sprintf "%d."."%02d"x$#r,@r};
use Net::LDAP::ASN qw(proxyAuthValue);
use strict;
sub init {
my($self) = @_;
delete $self->{asn};
unless (exists $self->{value}) {
$self->{asn} = {
proxyDN => $self->{proxyDN} || '',
};
}
$self->{critical}=1;
$self;
}
sub proxyDN {
my $self = shift;
$self->{asn} ||= $proxyAuthValue->decode($self->{value});
if (@_) {
delete $self->{value};
return $self->{asn}{proxyDN} = shift || 0;
}
$self->{asn}{proxyDN};
}
sub value {
my $self = shift;
exists $self->{value}
? $self->{value}
: $self->{value} = $proxyAuthValue->encode($self->{asn});
}
1;
__END__
=head1 NAME
Net::LDAP::Control::ProxyAuth - LDAPv3 Proxy Authentication control object
=head1 SYNOPSIS
use Net::LDAP;
use Net::LDAP::Control::ProxyAuth;
$ldap = Net::LDAP->new( "ldap.mydomain.eg" );
$auth = Net::LDAP::Control::ProxyAuth->new( proxyDN => 'cn=me,ou=people,o=myorg.com' );
@args = ( base => "cn=subnets,cn=sites,cn=configuration,$BASE_DN",
scope => "subtree",
filter => "(objectClass=subnet)",
callback => \&process_entry, # Call this sub for each entry
control => [ $auth ],
);
while(1) {
# Perform search
my $mesg = $ldap->search( @args );
# Only continue on LDAP_SUCCESS
$mesg->code and last;
}
=head1 DESCRIPTION
C<Net::LDAP::Control::ProxyAuth> provides an interface for the creation and manipulation
of objects that represent the C<proxyauthorisationControl> as described by draft-weltman-ldapv3-proxy-05.txt.
=head1 CONSTRUCTOR ARGUMENTS
In addition to the constructor arguments described in
L<Net::LDAP::Control> the following are provided.
=over 4
=item proxyDN
The proxyDN that is required. This is the identity we are requesting operations to use
=back
=head1 METHODS
As with L<Net::LDAP::Control> each constructor argument
described above is also available as a method on the object which will
return the current value for the attribute if called without an argument,
and set a new value for the attribute if called with an argument.
=head1 SEE ALSO
L<Net::LDAP>,
L<Net::LDAP::Control>,
http://info.internet.isi.edu/in-notes/rfc/files/rfc2696.txt
=head1 AUTHOR
Olivier Dubois, Swift sa/nv based on Net::LDAP::Control::Page from Graham Barr <gbarr@pobox.com>
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap-dev@lists.sourceforge.net>
=head1 COPYRIGHT
Copyright (c) 2001 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

205
lib/Net/LDAP/Control/Sort.pm Normal file
View file

@ -0,0 +1,205 @@
# $Id$
# Copyright (c) 1999-2000 Graham Barr <gbarr@pobox.com>. 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::Control::Sort;
use vars qw(@ISA $VERSION);
use Net::LDAP::Control;
@ISA = qw(Net::LDAP::Control);
$VERSION = "0.01";
use Net::LDAP::ASN qw(SortRequest);
use strict;
sub init {
my($self) = @_;
if (exists $self->{value}) {
$self->value($self->{value});
}
elsif (exists $self->{order}) {
$self->order(ref($self->{order}) ? @{$self->{order}} : $self->{order});
}
$self;
}
sub value {
my $self = shift;
if (@_) {
my $value = shift;
delete $self->{value};
delete $self->{order};
delete $self->{error};
my $asn = $SortRequest->decode($value);
unless ($asn) {
$self->{error} = $@;
return undef;
}
$self->{order} = [ map {
($_->{reverseOrder} ? "-" : "")
. $_->{type}
. (defined($_->{orderingRule}) ? ":$_->{orderingRule}" : "")
} @{$asn->{order}}];
return $self->{value} = $value;
}
unless (defined $self->{value}) {
$self->{value} = $SortRequest->encode(
order => [
map {
/^(-)?([^:]+)(?::(.+))?/;
{
type => $2,
(defined $1 ? (reverseOrder => 1) : ()),
(defined $3 ? (orderingRule => $3) : ())
}
} @{$self->{order} || []}
]
) or $self->{error} = $@;
}
$self->{value};
}
sub valid { exists shift->{order} }
sub order {
my $self = shift;
if (@_) {
# @_ can either be a list, or a single item.
# if a single item it can be a string, which needs
# to be split on spaces, or a reference to a list
#
# Each element has three parts
# leading - (optional)
# an attribute name
# :match-rule (optional)
my @order = (@_ == 1) ? split(/\s+/, $_[0]) : @_;
delete $self->{'value'};
delete $self->{order};
delete $self->{error};
foreach (@order) {
next if /^-?[^:]+(?::.+)?$/;
$self->{error} = "Bad order argument '$_'";
return;
}
$self->{order} = \@order;
}
return @{$self->{order}};
}
1;
__END__
=head1 NAME
Net::LDAP::Control::Sort - Server Side Sort (SSS) control object
=head1 SYNOPSIS
use Net::LDAP::Control::Sort;
use Net::LDAP::Constant qw(LDAP_CONTROL_SORTRESULT);
$sort = Net::LDAP::Control::Sort->new(
order => "cn -phone"
);
$mesg = $ldap->search( @args, control => [ $sort ]);
($resp) = $mesg->control( LDAP_CONTROL_SORTRESULT );
print "Results are sorted\n" if $resp and !$resp->result;
=head1 DESCRIPTION
C<Net::LDAP::Control::Sort> is a sub-class of
L<Net::LDAP::Control>. It provides a class
for manipulating the LDAP Server Side Sort (SSS) request control
C<1.2.840.113556.1.4.473> as defined in RFC-2891
If the server supports sorting, then the response from a search
operation will include a sort result control. This control is handled
by L<Net::LDAP::Control::SortResult>.
=head1 CONSTRUCTOR ARGUMENTS
=over 4
=item order
A string which defines how entries may be sorted. It consists of
multiple directives, spearated by whitespace. Each directive describes how
to sort entries using a single attribute. If two entries have identical
attributes, then the next directive in the list is used.
Each directive specifies a sorting order as follows
-attributeType:orderingRule
The leading C<-> is optional, and if present indicates that the sorting order should
be reversed. C<attributeType> is the attribute name to sort by. C<orderingRule> is optional and
indicates the rule to use for the sort and should be valid for the given C<attributeType>.
Any one attributeType should only appear once in the sorting list.
B<Examples>
"cn" sort by cn using the default ordering rule for the cn attribute
"-cn" sort by cn using the reverse of the default ordering rule
"age cn" sort by age first, then by cn using the default ordering rules
"cn:1.2.3.4" sort by cn using the ordering rule defined as 1.2.3.4
=back
=head1 METHODS
As with L<Net::LDAP::Control> each constructor argument
described above is also avaliable as a method on the object which will
return the current value for the attribute if called without an argument,
and set a new value for the attribute if called with an argument.
=head1 SEE ALSO
L<Net::LDAP>,
L<Net::LDAP::Control::SortResult>,
L<Net::LDAP::Control>,
http://info.internet.isi.edu/in-notes/rfc/files/rfc2891.txt
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap-dev@lists.sourceforge.net>
=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>
I<$Id$>
=cut

178
lib/Net/LDAP/Control/SortResult.pm Normal file
View file

@ -0,0 +1,178 @@
# $Id$
# Copyright (c) 1999-2000 Graham Barr <gbarr@pobox.com>. 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::Control::SortResult;
use Net::LDAP::ASN qw(SortResult);
use Net::LDAP::Control;
@ISA = qw(Net::LDAP::Control);
sub init {
my($self) = @_;
if (exists $self->{value}) {
$self->{asn} = $SortResult->decode(delete $self->{value});
}
else {
$self->{asn} = { sortResult => delete $self->{result} };
$self->{asn}{attributeType} = delete $self->{attr} if exists $self->{attr};
}
$self;
}
sub value {
my $self = shift;
$self->{value} = $SortResult->encode($self->{asn});
}
sub result {
my $self = shift;
@_ ? ($self->{asn}{sortResult}=shift)
: $self->{asn}{sortResult};
}
sub attr {
my $self = shift;
@_ ? ($self->{asn}{attributeType}=shift)
: $self->{asn}{attributeType};
}
1;
__END__
=head1 NAME
Net::LDAP::Control::SortResult - Server Side Sort (SSS) result control object
=head1 SYNOPSIS
use Net::LDAP::Control::Sort;
use Net::LDAP::Constant qw(LDAP_CONTROL_SORTRESULT);
use Net::LDAP::Util qw(ldap_error_name);
$sort = Net::LDAP::Control::Sort->new(
order => "cn -age"
);
$mesg = $ldap->search( @args, control => [ $sort ]);
($resp) = $mesg->control( LDAP_CONTROL_SORTRESULT );
if ($resp) {
if ($resp->result) {
my $attr = $resp->attr;
print "Problem sorting, ",ldap_error_name($resp->result);
print " ($attr)" if $attr;
print "\n";
}
else {
print "Results are sorted\n";
}
}
else {
print "Server does not support sorting\n";
}
=head1 DESCRIPTION
C<Net::LDAP::Control::SortResult> is a sub-class of
L<Net::LDAP::Control>. It provides a class for
manipulating the LDAP sort request control C<1.2.840.113556.1.4.474>
as defined in RFC-2891
A sort result control will be returned by the server in response to
a search with a Server Side Sort control. If a sort result control is
not returned then the user may assume that the server does not support
sorting and the results are not sorted.
=head1 CONSTRUCTOR ARGUMENTS
=over 4
=item attr
If C<result> indicates that there was a problem with sorting and that problem was
due to one of the attributes specified in the sort control. C<attr> is set to
the name of the attribute causing the problem.
=item result
This is the result code that describes if the sort operation was sucessful. If will
be one of the result codes describes below.
=back
=head1 METHODS
As with L<Net::LDAP::Control> each constructor argument
described above is also avaliable as a method on the object which will
return the current value for the attribute if called without an argument,
and set a new value for the attribute if called with an argument.
=head1 RESULT CODES
Possible results from a sort request are listed below. See L<Net::LDAP::Constant> for
a definition of each.
=over 4
=item LDAP_SUCCESS
=item LDAP_OPERATIONS_ERROR
=item LDAP_TIMELIMIT_EXCEEDED
=item LDAP_STRONG_AUTH_REQUIRED
=item LDAP_ADMIN_LIMIT_EXCEEDED
=item LDAP_NO_SUCH_ATTRIBUTE
=item LDAP_INAPPROPRIATE_MATCHING
=item LDAP_INSUFFICIENT_ACCESS
=item LDAP_BUSY
=item LDAP_UNWILLING_TO_PERFORM
=item LDAP_OTHER
=back
=head1 SEE ALSO
L<Net::LDAP>,
L<Net::LDAP::Control::Sort>,
L<Net::LDAP::Control>,
http://info.internet.isi.edu/in-notes/rfc/files/rfc2891.txt
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap-dev@lists.sourceforge.net>
=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>
I<$Id$>
=cut

403
lib/Net/LDAP/Control/VLV.pm Normal file
View file

@ -0,0 +1,403 @@
# $Id$
# Copyright (c) 2000 Graham Barr <gbarr@pobox.com>. 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::Control::VLV;
use vars qw(@ISA $VERSION);
use Net::LDAP::Control;
@ISA = qw(Net::LDAP::Control);
$VERSION = "0.02";
use Net::LDAP::ASN qw(VirtualListViewRequest);
use strict;
sub init {
my($self) = @_;
# VLVREQUEST should always have a critical of true
$self->{'critical'} = 1 unless exists $self->{'critical'};
if (exists $self->{value}) {
$self->value($self->{value});
}
else {
my $asn = $self->{asn} = {};
$asn->{beforeCount} = $self->{before} || 0;
$asn->{afterCount} = $self->{after} || 0;
if (exists $self->{assert}) {
$asn->{byValue} = $self->{assert};
}
else {
$asn->{byoffset} = {
offset => $self->{offset} || 0,
contentCount => $self->{content} || 0
};
}
}
$self;
}
sub before {
my $self = shift;
if (@_) {
delete $self->{value};
return $self->{asn}{beforeCount} = shift;
}
$self->{asn}{beforeCount};
}
sub after {
my $self = shift;
if (@_) {
delete $self->{value};
return $self->{asn}{afterCount} = shift;
}
$self->{asn}{afterCount};
}
sub content {
my $self = shift;
if (@_) {
delete $self->{value};
if (exists $self->{asn}{byValue}) {
delete $self->{asn}{byValue};
$self->{asn}{byoffset} = { offset => 0 };
}
return $self->{asn}{byoffset}{contentCount} = shift;
}
exists $self->{asn}{byoffset}
? $self->{asn}{byoffset}{contentCount}
: undef;
}
sub assert {
my $self = shift;
if (@_) {
delete $self->{value};
delete $self->{asn}{byoffset};
return $self->{asn}{byValue} = shift;
}
exists $self->{asn}{byValue}
? $self->{asn}{byValue}
: undef;
}
sub context {
my $self = shift;
if (@_) {
delete $self->{value};
return $self->{asn}{contextID} = shift;
}
$self->{asn}{contextID};
}
# Update self with values from a response
sub response {
my $self = shift;
my $resp = shift;
my $asn = $self->{asn};
$asn->{contextID} = $resp->context;
$asn->{byoffset} = {
offset => $resp->target,
contentCount => $resp->content
};
delete $asn->{byValue};
1;
}
sub offset {
my $self = shift;
if (@_) {
delete $self->{value};
if (exists $self->{asn}{byValue}) {
delete $self->{asn}{byValue};
$self->{asn}{byoffset} = { contentCount => 0 };
}
return $self->{asn}{byoffset}{offset} = shift;
}
exists $self->{asn}{byoffset}
? $self->{asn}{byoffset}{offset}
: undef;
}
sub value {
my $self = shift;
if (@_) {
unless ($self->{asn} = $VirtualListViewRequest->decode($_[0])) {
delete $self->{value};
return undef;
}
$self->{value} = shift;
}
exists $self->{value}
? $self->{value}
: $self->{value} = $VirtualListViewRequest->encode($self->{asn});
}
sub scroll {
my $self = shift;
my $n = shift;
my $asn = $self->{asn};
my $byoffset = $asn->{byoffset}
or return undef;
my $offset = $byoffset->{offset} + $n;
my $content;
if ($offset < 1) {
$asn->{afterCount} += $asn->{beforeCount};
$asn->{beforeCount} = 0;
$offset = $byoffset->{offset} = 1;
}
elsif ($byoffset->{contentCount} and $asn->{afterCount}+$offset >$byoffset->{contentCount}) {
if ($offset > $byoffset->{contentCount}) {
$offset = $byoffset->{offset} = $byoffset->{contentCount};
$asn->{beforeCount} += $asn->{afterCount};
$asn->{afterCount} = 0;
}
else {
my $tmp = $byoffset->{contentCount} - $offset;
$asn->{beforeCount} += $tmp;
$asn->{afterCount} -= $tmp;
$byoffset->{offset} = $offset;
}
}
else {
$byoffset->{offset} = $offset;
}
$offset;
}
sub scroll_page {
my $self = shift;
my $n = shift;
my $asn = $self->{asn};
my $page_size = $asn->{beforeCount} + $asn->{afterCount} + 1;
$self->scroll( $page_size * $n);
}
sub start {
my $self = shift;
my $asn = $self->{asn};
$asn->{afterCount} += $asn->{beforeCount};
$asn->{beforeCount} = 0;
$self->offset(1);
}
sub end {
my $self = shift;
my $asn = $self->{asn};
my $content = $self->content || 0;
$asn->{beforeCount} += $asn->{afterCount};
$asn->{afterCount} = 0;
$self->offset($content);
}
1;
__END__
=head1 NAME
Net::LDAP::Control::VLV - LDAPv3 Virtual List View control object
=head1 SYNOPSIS
use Net::LDAP;
use Net::LDAP::Control::VLV;
use Net::LDAP::Constant qw( LDAP_CONTROL_VLVRESPONSE );
$ldap = Net::LDAP->new( "ldap.mydomain.eg" );
# Get the first 20 entries
$vlv = Net::LDAP::Control::VLV->new(
before => 0, # No entries from before target entry
after => 19, # 19 entries after target entry
content => 0, # List size unknown
offset => 1, # Target entry is the first
);
$sort = Net::LDAP::Control::Sort->new( sort => 'cn' );
@args = ( base => "o=Ace Industry, c=us",
scope => "subtree",
filter => "(objectClass=inetOrgPerson)",
callback => \&process_entry, # Call this sub for each entry
control => [ $vlv, $sort ],
);
$mesg = $ldap->search( @args );
# Get VLV response control
($resp) = $mesg->control( LDAP_CONTROL_VLVRESPONSE ) or die;
$vlv->response( $resp );
# Set the control to get the last 20 entries
$vlv->end;
$mesg = $ldap->search( @args );
# Get VLV response control
($resp) = $mesg->control( LDAP_CONTROL_VLVRESPONSE ) or die;
$vlv->response( $resp );
# Now get the previous page
$vlv->scroll_page( -1 );
$mesg = $ldap->search( @args );
# Get VLV response control
($resp) = $mesg->control( LDAP_CONTROL_VLVRESPONSE ) or die;
$vlv->response( $resp );
# Now page with first entry starting with "B" in the middle
$vlv->before(9); # Change page to show 9 before
$vlv->after(10); # Change page to show 10 after
$vlv->assert("B"); # assert "B"
$mesg = $ldap->search( @args );
=head1 DESCRIPTION
C<Net::LDAP::Control::VLV> provides an interface for the creation and
manipulation of objects that represent the Virtual List View as described
by draft-ietf-ldapext-ldapv3-vlv-03.txt.
When using a Virtual List View control in a search, it must be accompanied by a sort
control. See L<Net::LDAP::Control::Sort>
=cut
##
## Need some blurb here to describe the VLV control. Maybe extract some simple
## describtion from the draft RFC
##
=head1 CONSTRUCTOR ARGUMENTS
In addition to the constructor arguments described in
L<Net::LDAP::Control> the following are provided.
=over 4
=item after
Set the number of entries the server should return from the list after
the target entry.
=item assert
Set the assertion value user to locate the target entry. This value should
be a legal value to compare with the first attribute in the sort control
that is passed with the VLV control. The target entry is the first entry
in the list which is greater than or equal the assert value.
=item before
Set the number of entries the server should return from the list before
the target entry.
=item content
Set the number of entries in the list. On the first search this value
should be set to zero. On subsequent searches it should be set to the
length of the list, as returned by the server in the VLVResponse control.
=item context
Set the context identifier. On the first search this value should be
set to zero. On subsequent searches it should be set to the context
value returned by the server in the VLVResponse control.
=item offset
Set the offset of the target entry.
=back
=head2 METHODS
As with L<Net::LDAP::Control> each constructor argument
described above is also avaliable as a method on the object which will
return the current value for the attribute if called without an argument,
and set a new value for the attribute if called with an argument.
The C<offset> and C<assert> attributes are mutually exclusive. Setting
one or the other will cause previous values set by the other to
be forgotten. The C<content> attribute is also associated with the
C<offset> attribute, so setting C<assert> will cause any C<content>
value to be forgotten.
=over 4
=item end
Set the target entry to the end of the list. This method will change the C<before>
and C<after> attributes so that the target entry is the last in the page.
=item response VLV_RESPONSE
Set the attributes in the control as per VLV_RESPONSE. VLV_RESPONSE should be a control
of type L<Net::LDAP::Control::VLVResponse> returned
from the server. C<response> will populate the C<context>, C<offset> and C<content>
attibutes of the control with the values from VLV_RESPONSE. Because this sets the
C<offset> attribute, any previous setting of the C<assert> attribute will be forgotten.
=item scroll NUM
Move the target entry by NUM entries. A positive NUM will move the target entry towards
the end of the list and a negative NUM will move the target entry towards the
start of the list. Returns the index of the new target entry, or C<undef> if the current target
is identified by an assertion.
C<scroll> may change the C<before> and C<after> attributes if the scroll value would
cause the page to go off either end of the list. But the page size will be maintained.
=item scroll_page NUM
Scroll by NUM pages. This method simple calculates the current page size and calls
C<scroll> with C<NUM * $page_size>
=item start
Set the target entry to the start of the list. This method will change the C<before> and C<after>
attributes to the the target entry is the first entry in the page.
=back
=head1 SEE ALSO
L<Net::LDAP>,
L<Net::LDAP::Control>,
L<Net::LDAP::Control::Sort>,
L<Net::LDAP::Control::VLVResponse>
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap-dev@lists.sourceforge.net>
=head1 COPYRIGHT
Copyright (c) 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>
I<$Id$>

198
lib/Net/LDAP/Control/VLVResponse.pm Normal file
View file

@ -0,0 +1,198 @@
# Copyright (c) 2000 Graham Barr <gbarr@pobox.com>. 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::Control::VLVResponse;
use vars qw(@ISA $VERSION);
use Net::LDAP::Control;
@ISA = qw(Net::LDAP::Control);
$VERSION = "0.01";
use Net::LDAP::ASN qw(VirtualListViewResponse);
use strict;
sub init {
my($self) = @_;
if (exists $self->{value}) {
$self->value($self->{value});
}
else {
my $asn = $self->{asn} = {};
$asn->{targetPosition} = $self->{target} || 0;
$asn->{contentCount} = $self->{content} || 0;
$asn->{virtualListViewResult} = $self->{result} || 0;
$asn->{context} = $self->{context} || undef;
}
$self;
}
sub target {
my $self = shift;
if (@_) {
delete $self->{value};
return $self->{asn}{targetPosition} = shift;
}
$self->{asn}{targetPosition};
}
sub content {
my $self = shift;
if (@_) {
delete $self->{value};
return $self->{asn}{contentCount} = shift;
}
$self->{asn}{contentCount};
}
sub result {
my $self = shift;
if (@_) {
delete $self->{value};
return $self->{asn}{virtualListViewResult} = shift;
}
$self->{asn}{virtualListViewResult};
}
sub context {
my $self = shift;
if (@_) {
delete $self->{value};
return $self->{asn}{context} = shift;
}
$self->{asn}{context};
}
sub value {
my $self = shift;
if (@_) {
unless ($self->{asn} = $VirtualListViewResponse->decode($_[0])) {
delete $self->{value};
return undef;
}
$self->{value} = shift;
}
exists $self->{value}
? $self->{value}
: $self->{value} = $VirtualListViewResponse->encode($self->{asn});
}
1;
__END__
=head1 NAME
Net::LDAP::Control::VLVResponse -- LDAPv3 Virtual List View server response
=head1 SYNOPSIS
See L<Net::LDAP::Control::VLV>
=head1 DESCRIPTION
C<Net::LDAP::Control::VLVResponse> is a sub-class of L<Net::LDAP::Control>.
It provides a class for manipulating the LDAP Virtual List View Response control
C<>
If the server supports Virtual List Views, then the response from a search operation will
include a VLVResponse control.
=head1 CONSTRUCTOR ARGUMENTS
In addition to the constructor arguments described in
L<Net::LDAP::Control> the following are provided.
=over 4
=item content
An estimate of the number of entries in the complete list. This value should
be used in any subsequent Virtual List View control using the same list.
=item context
An arbitary value which is used to associate subsequent requests with the
request which this control is a response for. This value should be copied
by the client into the Virtual List View control for any subsequent
search that uses the same list.
=item result
A result code indicating the result of the Virtual List View request. This
may be any of the codes listed below.
=item target
The list offset of the target entry.
=back
=head1 METHODS
As with L<Net::LDAP::Control> each constructor argument
described above is also avaliable as a method on the object which will
return the current value for the attribute if called without an argument,
and set a new value for the attribute if called with an argument.
=head1 RESULT CODES
Possible results from a sort request are listed below. See L<Net::LDAP::Constant> for
a definition of each.
=over 4
=item LDAP_SUCCESS
=item LDAP_OPERATIONS_ERROR
=item LDAP_TIMELIMIT_EXCEEDED
=item LDAP_ADMIN_LIMIT_EXCEEDED
=item LDAP_INSUFFICIENT_ACCESS
=item LDAP_BUSY
=item LDAP_UNWILLING_TO_PERFORM
=item LDAP_OTHER
=item LDAP_SORT_CONTROL_MISSING
=item LDAP_INDEX_RANGE_ERROR
=back
=head1 SEE ALSO
L<Net::LDAP>,
L<Net::LDAP::Control>,
http://info.internet.isi.edu/in-notes/rfc/files/rfc2696.txt
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap-dev@lists.sourceforge.net>
=head1 COPYRIGHT
Copyright (c) 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>
I<$Id$>
=cut

340
lib/Net/LDAP/DSML.pm Executable file
View file

@ -0,0 +1,340 @@
package Net::LDAP::DSML;
# For schema parsing, add ability to Net::LDAP::Schema to accecpt a Net::LDAP::Entry object. First
# we'll convert XML into Net::LDAP::Entry with schema attributes and then pass to schema object constructor
#
# move XML::DSML to Net::LDAP::DSML::Parser
# change parser so that it uses callbacks
use strict;
use Net::LDAP::Entry;
use vars qw($VERSION);
$VERSION = "0.06";
sub new {
my $pkg = shift;
my $self = {};
bless $self, $pkg;
}
sub open {
my $self = shift;
my $file = shift ;
my $fh = $file;
my $close = 0;
$self->finish
if $self->{net_ldap_fh};
if (ref($file) or ref(\$file) eq "GLOB") {
$close = 0;
$fh = $file;
}
else {
local *FH;
unless (open(FH,$file)) {
$self->{error} = "Cannot open file '$file'";
return 0;
}
$close = 1;
$fh = \*FH;
}
$self->{net_ldap_fh} = $fh;
$self->{net_ldap_close} = $close;
print $fh $self->start_dsml;
1;
}
sub finish {
my $self = shift;
my $fh = $self->{net_ldap_fh};
if ($fh) {
print $fh $self->end_dsml;
close($fh) if $self->{net_ldap_close};
}
}
sub start_dsml {
qq!<?xml version="1.0" encoding="utf-8"?>\n<dsml:dsml xmlns:dsml="http://www.dsml.org/DSML">\n!;
}
sub end_dsml {
qq!</dsml:dsml>\n!;
}
sub DESTROY { shift->close }
#transform any entity chararcters
#must handle ourselves because I don't know of an XML module that does this
sub _normalize {
my $normal = shift;
$normal =~ s/&/&amp;/g;
$normal =~ s/</&lt;/g;
$normal =~ s/>/&gt;/g;
$normal =~ s/\"/&quot;/g;
$normal =~ s/\'/&apos;/g;
return $normal;
}
sub write {
my $self = shift;
my $entry = shift;
#my @unknown = _print_schema(_print_entries(@_));
if (ref $entry eq 'Net::LDAP::Entry') {
$self->_print_entry($entry)
}
elsif (ref $entry eq 'Net::LDAP::Schem') {
_print_schema($entry);
}
else {
return undef;
}
1;
}
#coming soon! ;)
sub _print_schema {
my $self = shift;
@_;
}
sub _print_entry {
my ($self,$entry) = @_;
my @unknown;
my $count;
my $fh = $self->{'net_ldap_fh'} or return;
return undef unless ($entry->isa('Net::LDAP::Entry'));
print $fh "<dsml:directory-entries>\n";
print $fh "<dsml:entry dn=\"",_normalize($entry->dn),"\">\n";
my @attributes = $entry->attributes();
#at some point integrate with Net::LDAP::Schema to determine if binary or not
#now look for ;binary tag
for my $attr (@attributes) {
my $isOC = 0;
if (lc($attr) eq 'objectclass') {
$isOC = 1;
}
if ($isOC) {
print $fh "<dsml:objectclass>\n";
}
else {
print $fh "<dsml:attr name=\"",_normalize($attr),"\">\n";
}
my @values = $entry->get_value($attr);
for my $value (@values) {
if ($isOC) {
print $fh "<dsml:oc-value>",_normalize($value),"</dsml:oc-value>\n";
}
else {
#at some point we'll use schema object to determine
#this but until then we'll borrow this from Net::LDAP::LDIF
if ($value=~ /(^[ :]|[\x00-\x1f\x7f-\xff])/) {
require MIME::Base64;
print $fh qq!<dsml:value encoding="base64">!,
MIME::Base64::encode($value),
"</dsml:value>\n";
}
else {
print $fh "<dsml:value>",_normalize($value),"</dsml:value>\n";
}
}
}
if ($isOC) {
print $fh "</dsml:objectclass>\n";
}
else {
print $fh "</dsml:attr>\n";
}
}
print $fh "</dsml:entry>\n";
print $fh "</dsml:directory-entries>\n";
1;
}
# only parse DSML entry elements, no schema here
sub read_entries {
my ($self, $file) = @_;
my @entries;
$self->process($file, entry => sub { push @entries, @_ });
@entries;
}
sub read_schema {
my ($self, $file) = @_;
my $schema;
$self->process($file, schema => sub { $schema = shift } );
$schema;
}
sub process {
my $self = shift;
my $file = shift;
my %arg = @_;
require XML::Parser;
require Net::LDAP::DSML::Parser;
my $xml = XML::Parser->new(
Style => 'Subs',
Pkg => 'Net::LDAP::DSML::Parser',
Handlers => {
ExternEnt => sub { "" },
Char => \&_Char
}
);
$xml->{net_ldap_entry_handler} = $arg{entry} if exists $arg{entry};
$xml->{net_ldap_schema_handler} = $arg{schema} if exists $arg{schema};
delete $self->{error};
my $ok = eval { local $SIG{__DIE__}; $xml->parsefile($file); 1 };
$self->{error} = $@ unless $ok;
$ok;
}
sub error { shift->{error} }
sub _Char {
my $self = shift;
my $tag = $self->current_element;
if ($tag =~ /^dsml:(oc-)?value$/) {
$self->{net_ldap_entry}->add(
($1 ? 'objectclass' : $self->{net_ldap_attr}),
$self->{net_ldap_base64}
? MIME::Base64::decode(shift)
: shift
);
}
elsif ($_[0] =~ /\S/) {
die "Unexpected text '$_[0]', while parsing $tag";
}
}
1;
__END__
=head1 NAME
Net::LDAP::DSML -- A DSML Writer and Reader for Net::LDAP
=head1 SYNOPSIS
use Net::LDAP;
use Net::LDAP::DSML;
use IO::File;
my $server = "localhost";
my $file = "testdsml.xml";
my $ldap = Net::LDAP->new($server);
$ldap->bind();
my $dsml = Net::LDAP::DSML->new();
my $file = "testdsml.xml";
my $io = IO::File->new($file,"w") or die ("failed to open $file as filehandle.$!\n");
$dsml->open($io) or die ("DSML problems opening $file.$!\n"); ;
#or
open (IO,">$file") or die("failed to open $file.$!");
$dsml->open(*IO) or die ("DSML problems opening $file.$!\n");
my $mesg = $ldap->search(
base => 'o=airius.com',
scope => 'sub',
filter => 'ou=accounting',
callback => sub {
my ($mesg,$entry) =@_;
$dsml->write($entry) if (ref $entry eq 'Net::LDAP::Entry');
}
);
die ("search failed with ",$mesg->code(),"\n") if $mesg->code();
$dsml->write($schema);
$dsml->finish();
print "Finished printing DSML\n";
print "Starting to process DSML\n";
$dsml = new Net::LDAP::DSML();
$dsml->process($file, entry => \&processEntry);
#future when schema support is available will be
#$dsml->process($file, entry => \&processEntry, schema => \&processSchema);
sub processEntry {
my $entry = shift;
$entry->dump();
}
=head1 DESCRIPTION
Directory Service Markup Language (DSML) is the XML standard for
representing directory service information in XML.
At the moment this module only reads and writes DSML entry entities. It
cannot process any schema entities because schema entities are processed
differently than elements.
Eventually this module will be a full level 2 consumer and producer
enabling you to give you full DSML conformance.
The module uses callbacks to improve performance (at least the appearance
of improving performance ;) and to reduce the amount of memory required to
parse large DSML files. Every time a single entry or schema is processed
we pass the Net::LDAP object (either an Entry or Schema object) to the
callback routine.
=head1 AUTHOR
Mark Wilcox mark@mwjilcox.com
=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.
=cut

72
lib/Net/LDAP/DSML/Parser.pm Normal file
View file

@ -0,0 +1,72 @@
package Net::LDAP::DSML::Parser;
use Net::LDAP::Entry;
#use Net::LDAP::Schema;
use vars qw($VERSION);
$VERSION = "0.06";
# dsml:entry
*{'dsml:entry'} = sub {
my ($self,$tag, %attr) = @_;
my $entry = $self->{net_ldap_entry} = Net::LDAP::Entry->new;
$entry->dn( $attr{dn} );
};
*{'dsml:entry_'} = sub {
my $self = shift;
if ($self->{net_ldap_entry_handler}) {
&{$self->{net_ldap_entry_handler}}(delete $self->{net_ldap_entry});
}
};
# dsml:attr
*{'dsml:attr'} = sub {
my ($self,$tag, %attr) = @_;
$self->{net_ldap_attr} = $attr{name};
};
*{'dsml:attr_'} = sub {
my $self = shift;
delete $self->{net_ldap_attr};
};
# dsml:value
*{'dsml:value'} = sub {
my ($self,$tag, %attr) = @_;
$self->{net_ldap_base64} =
(exists $attr{encoding} && lc($attr{encoding}) eq 'base64')
and require MIME::Base64;
};
*{'dsml:value_'} = sub {
my $self = shift;
delete $self->{net_ldap_base64};
};
*{'dsml:oc-value'} = \&{'dsml:value'};
*{'dsml:oc-value_'} = \&{'dsml:value_'};
*{'dsml:objectclass'} = sub {};
*{'dsml:objectclass_'} = sub {};
*{'dsml:dsml'} = sub {};
*{'dsml:dsml_'} = sub {};
*{'dsml:directory-entries'} = sub {};
*{'dsml:directory-entries_'} = sub {};
sub AUTOLOAD {
my $tag = substr($AUTOLOAD,25);
die "Unknown tag '$tag'";
}
1;

293
lib/Net/LDAP/Entry.pm Normal file
View file

@ -0,0 +1,293 @@
# Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. 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::Entry;
use strict;
use Net::LDAP::ASN qw(LDAPEntry);
use Net::LDAP::Constant qw(LDAP_LOCAL_ERROR);
use vars qw($VERSION);
$VERSION = "0.15";
sub new {
my $self = shift;
my $type = ref($self) || $self;
my $entry = bless { 'changetype' => 'add', changes => [] }, $type;
$entry;
}
# Build attrs cache, created when needed
sub _build_attrs {
+{ map { (lc($_->{type}),$_->{vals}) } @{$_[0]->{asn}{attributes}} };
}
# If we are passed an ASN structure we really do nothing
sub decode {
my $self = shift;
my $result = ref($_[0]) ? shift : $LDAPEntry->decode(shift)
or return;
%{$self} = ( asn => $result, changetype => 'modify', changes => []);
$self;
}
sub encode {
$LDAPEntry->encode( shift->{asn} );
}
sub dn {
my $self = shift;
@_ ? ($self->{asn}{objectName} = shift) : $self->{asn}{objectName};
}
sub get_attribute {
require Carp;
Carp::carp("->get_attribute deprecated, use ->get_value") if $^W;
shift->get_value(@_, asref => !wantarray);
}
sub get {
require Carp;
Carp::carp("->get deprecated, use ->get_value") if $^W;
shift->get_value(@_, asref => !wantarray);
}
sub exists {
my $self = shift;
my $type = lc(shift);
my $attrs = $self->{attrs} ||= _build_attrs($self);
exists $attrs->{$type};
}
sub get_value {
my $self = shift;
my $type = lc(shift);
my %opt = @_;
if ($opt{alloptions}) {
my %ret = map {
$_->{type} =~ /^\Q$type\E(.*)/ ? (lc($1), $_->{vals}) : ()
} @{$self->{asn}{attributes}};
return %ret ? \%ret : undef;
}
my $attrs = $self->{attrs} ||= _build_attrs($self);
my $attr = $attrs->{$type} or return;
return $opt{asref}
? $attr
: wantarray
? @{$attr}
: $attr->[0];
}
sub changetype {
my $self = shift;
return $self->{'changetype'} unless @_;
$self->{'changes'} = [];
$self->{'changetype'} = shift;
}
sub add {
my $self = shift;
my $cmd = $self->{'changetype'} eq 'modify' ? [] : undef;
my $attrs = $self->{attrs} ||= _build_attrs($self);
while (my($type,$val) = splice(@_,0,2)) {
$type = lc $type;
push @{$self->{asn}{attributes}}, { type => $type, vals => ($attrs->{$type}=[])}
unless exists $attrs->{$type};
push @{$attrs->{$type}}, ref($val) ? @$val : $val;
push @$cmd, $type, [ ref($val) ? @$val : $val ]
if $cmd;
}
push(@{$self->{'changes'}}, 'add', $cmd) if $cmd;
}
sub replace {
my $self = shift;
my $cmd = $self->{'changetype'} eq 'modify' ? [] : undef;
my $attrs = $self->{attrs} ||= _build_attrs($self);
while(my($type, $val) = splice(@_,0,2)) {
$type = lc $type;
if (defined($val) and (!ref($val) or @$val)) {
push @{$self->{asn}{attributes}}, { type => $type, vals => ($attrs->{$type}=[])}
unless exists $attrs->{$type};
@{$attrs->{$type}} = ref($val) ? @$val : ($val);
push @$cmd, $type, [ ref($val) ? @$val : $val ]
if $cmd;
}
else {
delete $attrs->{$type};
@{$self->{asn}{attributes}}
= grep { $type ne lc($_->{type}) } @{$self->{asn}{attributes}};
push @$cmd, $type, []
if $cmd;
}
}
push(@{$self->{'changes'}}, 'replace', $cmd) if $cmd;
}
sub delete {
my $self = shift;
unless (@_) {
$self->changetype('delete');
return;
}
my $cmd = $self->{'changetype'} eq 'modify' ? [] : undef;
my $attrs = $self->{attrs} ||= _build_attrs($self);
while(my($type,$val) = splice(@_,0,2)) {
$type = lc $type;
if (defined($val) and (!ref($val) or @$val)) {
my %values;
@values{@$val} = ();
unless( @{$attrs->{$type}}
= grep { !exists $values{$_} } @{$attrs->{$type}})
{
delete $attrs->{$type};
@{$self->{asn}{attributes}}
= grep { $type ne lc($_->{type}) } @{$self->{asn}{attributes}};
}
push @$cmd, $type, [ ref($val) ? @$val : $val ]
if $cmd;
}
else {
delete $attrs->{$type};
@{$self->{asn}{attributes}}
= grep { $type ne lc($_->{type}) } @{$self->{asn}{attributes}};
push @$cmd, $type, [] if $cmd;
}
}
push(@{$self->{'changes'}}, 'delete', $cmd) if $cmd;
}
sub update {
my $self = shift;
my $ldap = shift;
my $mesg;
my $cb = sub { $self->changetype('modify') unless $_[0]->code };
if ($self->{'changetype'} eq 'add') {
$mesg = $ldap->add($self, 'callback' => $cb);
}
elsif ($self->{'changetype'} eq 'delete') {
$mesg = $ldap->delete($self, 'callback' => $cb);
}
elsif ($self->{'changetype'} =~ /modr?dn/) {
my @args = (newrdn => $self->get_value('newrdn'),
deleteoldrdn => $self->get_value('deleteoldrdn'));
my $newsuperior = $self->get_value('newsuperior');
push(@args, newsuperior => $newsuperior) if $newsuperior;
$mesg = $ldap->moddn($self, @args, 'callback' => $cb);
}
elsif (@{$self->{'changes'}}) {
$mesg = $ldap->modify($self, 'changes' => $self->{'changes'}, 'callback' => $cb);
}
else {
require Net::LDAP::Message;
$mesg = Net::LDAP::Message->new( {} );
$mesg->set_error(LDAP_LOCAL_ERROR,"No attributes to update");
}
return $mesg;
}
# Just for debugging
sub dump {
my $self = shift;
my $asn = $self->{asn};
print "-" x 72,"\n";
print "dn:",$asn->{objectName},"\n\n";
my($attr,$val);
my $l = 0;
for (keys %{ $self->{attrs} ||= _build_attrs($self) }) {
$l = length if length > $l;
}
my $spc = "\n " . " " x $l;
foreach $attr (@{$asn->{attributes}}) {
$val = $attr->{vals};
printf "%${l}s: ", $attr->{type};
my($i,$v);
$i = 0;
foreach $v (@$val) {
print $spc if $i++;
print $v;
}
print "\n";
}
}
sub attributes {
my $self = shift;
my %opt = @_;
if ($opt{nooptions}) {
my %done;
return map {
$_->{type} =~ /^([^;]+)/;
$done{lc $1}++ ? () : ($1);
} @{$self->{asn}{attributes}};
}
else {
return map { $_->{type} } @{$self->{asn}{attributes}};
}
}
sub asn {
shift->{asn}
}
sub changes {
@{shift->{'changes'}}
}
1;

295
lib/Net/LDAP/Entry.pod Normal file
View file

@ -0,0 +1,295 @@
=head1 NAME
Net::LDAP::Entry - An LDAP entry object
=head1 SYNOPSIS
use Net::LDAP;
$ldap = Net::LDAP->new($host);
$mesg = $ldap->search(@search_args);
my $max = $mesg->count;
for($i = 0 ; $i < $max ; $i++) {
my $entry = $mesg->entry($i);
foreach my $attr ($entry->attributes) {
print join("\n ",$attr, $entry->get_value($attr)),"\n";
}
}
# or
use Net::LDAP::Entry;
$entry = Net::LDAP::Entry->new;
$entry->add(
attr1 => 'value1',
attr2 => [qw(value1 value2)]
);
$entry->delete( 'unwanted' );
$entry->replace(
attr1 => 'newvalue'
attr2 => [qw(new values)]
);
$entry->update( $ldap ); # update directory server
=head1 DESCRIPTION
The B<Net::LDAP::Entry> object represents a single entry in the directory.
It is a container for attribute-value pairs.
A B<Net::LDAP::Entry> object can be used in two situations. The first and
probably most common use is in the result of a search to the directory
server.
The other is where a new object is created locally and then a single
command is sent to the directory server to add, modify or replace an
entry. Entries for this purpose can also be created by reading an
LDIF file with the L<Net::LDAP::LDIF> module.
=head1 CONSTRUCTOR
=over 4
=item new
Create a new entry object with the changetype set to C<'add'>
=back
=head1 METHODS
=over 4
=item add ( ATTR => VALUE [, ATTR2 => VALUE2 ... ] )
Add one or more new attributes to the entry. Each value
must be a scalar variable or a reference to an array. The
values given will be added to the values which already exist
for the given attributes.
$entry->add( 'sn' => 'Barr');
$entry->add( 'street' => [ '1 some road','nowhere']);
B<NOTE>: these changes are local to the client and will not
appear on the directory server until the C<update> method
is called.
=item attributes ( [ OPTIONS ] )
Return a list of attributes that this entry has.
OPTIONS is a list of name/value pairs, valid options are :-
=over 4
=item nooptions
If TRUE, return a list of the attribute names excluding any options. For example for the entry
name: Graham Barr
name;en-us: Bob
jpeg;binary: **binary data**
then
@values = $entry->attributes()
print "default: @values\n";
@values = $entry->attributes( nooptions => 1);
print "nooptions: @values\n";
will output
default: name name;en-us jpeg;binary
nooptions: name jpeg
=back
=item changetype ( [ TYPE ] )
If called without arguments it returns the type of operation that would
be performed when the update method is called. If called with an argument
it will set the changetype to TYPE.
Possible values for TYPE are
=over 4
=item add
The update method will call the add method on the client object, which
will result in the entry being added to the directory server.
=item delete
The update method will call the delete method on the client object, which
will result in the entry being removed from the directory server.
=item modify
The update method will call the modify method on the client object, which
will result in any changes that have been made locally being made to the
entry on the directory server.
=item moddn/modrdn
The update method will call the moddn method on the client object, which
will result in any DN changes that have been made locally being made
to the entry on the directory server. These DN changes are specified by
setting the entry attributes newrdn, deleteoldrdn, and (optionally) newsuperior.
=back
=item delete ( [ ATTR [, ATTR2 ... ]] )
Delete the given attributes from the entry. If no attributes
are passed then the next call to update will cause the entry
to be deleted from the server.
B<NOTE>: these changes are local to the client and will not
appear on the directory server until the C<update> method
is called.
=item dn ( [ DN ] )
Set or get the DN for the entry. With no arguments C<dn> will return
the current DN. If an argument is given then it will change the DN
for the entry and return the previous value.
B<NOTE>: these changes are local to the client and will not
appear on the directory server until the C<update> method
is called.
=item exists ( ATTR )
Returns TRUE if the entry has an attribute called ATTR.
=item get_value ( ATTR [, OPTIONS ] )
Get the values for the attribute ATTR. In a list context returns all
values for the given attribute, or the empty list if the attribute does
not exist. In a scalar context returns the first value for the attribute
or undef if the attribute does not exist.
The return value may be changed by OPTIONS, which is a list of name => value
pairs, valid options are :-
=over 4
=item alloptions
If TRUE then the result will be a hash reference. The keys of the hash
will be the options and the hash value will be the values for those attributes.
For example if an entry had
name: Graham Barr
name;en-us: Bob
Then a get for attribute "name" with alloptions set to a true value
$ref = $entry->get_value( 'name', alloptions => 1);
will return a hash reference that would be like
{
'' => [ 'Graham Barr' ],
';en-us' => [ 'Bob' ]
}
=item asref
If TRUE then the result will be a reference to an array containing all the
values for the attribute, or undef if the attribute does not exist.
$scalar = $entry->get_value('name');
$scalar will be the first value for the C<name> attribute, or C<undef> if the
entry does not contain a C<name> attribute.
$ref = $entry->get_value('name', asref => 1);
$ref will be a reference to an array, which will have all the values for
the C<name> attribute. If the entry does not have an attribute called C<name>
then $ref will be C<undef>
=back
B<NOTE>: In the interest of performance the array references returned by C<get_value>
are references to structures held inside the entry object. These values and
thier contents should B<NOT> be modified directly.
=item replace ( ATTR => VALUE [, ATTR2 => VALUE2 ... ] )
Similar to add, except that the values given will replace
any values that already exist for the given attributes.
B<NOTE>: these changes are local to the client and will not
appear on the directory server until the C<update> method
is called.
=item update ( CLIENT )
Update the directory server with any changes that have been made locally
to the attributes of this entry. This means any calls that have been
made to add, replace or delete since the last call to changetype or
update was made.
This method can also be used to modify the DN of the entry on the server,
by specifying moddn or modrdn as the changetype, and setting the entry
attributes newrdn, deleteoldrdn, and (optionally) newsuperior.
CLIENT is a C<Net::LDAP> object where the update will be sent to.
The result will be an object of type
L<Net::LDAP::Message> as returned by the add, modify
or delete method called on CLIENT.
=back
=head1 SEE ALSO
L<Net::LDAP>,
L<Net::LDAP::LDIF>
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>.
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap-dev@lists.sourceforge.net>.
=head1 COPYRIGHT
Copyright (c) 1997-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>
I<$Id$>
=cut

556
lib/Net/LDAP/Examples.pod Normal file
View file

@ -0,0 +1,556 @@
=head1 NAME
Net::LDAP::Examples - PERL LDAP by Example
=head1 DESCRIPTION
The following examples are of course PERL code, found to work
with the Net::LDAP modules.
The intent of this document is to give the reader a I<cut and paste>
jump start to getting an LDAP application working.
Below you will find snippets of code that should work as-is with only
a small amount of work to correct any variable assignments and LDAP
specifics, e.g. Distinguished Name Syntax, related to the user's
own implementation.
The I<S>tandard I<O>perating I<P>roceedure that is followed here is:
=over 8
=item 1 Package - use Net::LDAP
=item 2 Initialization - new
=item 3 Binding - bind
=item 4 Operation - add modify moddn search
=item 4.1 Processing - displaying data from a search
=item 5 Error - displaying error information
=item 6 Unbinding - unbind
=back
Look to each of these for a snippet of code to meet your needs.
B<What is not covered in these examples at this time:>
=over 4
=item I<abandon> and I<compare> methods
=item I<callback> subroutines
=back
=head1 CODE
=head2 PACKAGE - Definitions
use Net::LDAP qw(:all); # use for all code
use Net::LDAP::Util qw(ldap_error_name
ldap_error_text) ; # use for Error handling
=head2 INITIALIZING
$ldap = Net::LDAP->new("yourLDAPhost.yourCompany.com") or die "$@";
=head2 BINDING
$mesg = $ldap->bind( version => 3 ); # use for searches
$mesg = $ldap->bind("$userToAuthenticate",
password => "$passwd",
version => 3 ); # use for changes/edits
# see your LDAP administrator for information concerning the
# user authentication setup at your site.
=head2 OPERATION - Generating a SEARCH
sub LDAPsearch
{
my ($ldap,$searchString,$attrs,$base) = @_ ;
# if they don't pass a base... set it for them
if (!$base ) { $base = "o=mycompany, c=mycountry"; }
# if they don't pass an array of attributes...
# set up something for them
if (!$attrs ) { $attrs = ['cn','mail' ]; }
my $result = $ldap->search (
base => "$base",
scope => "sub",
filter => "$searchString",
attrs => $attrs
);
}
my @Attrs = (); # request all available attributes
# to be returned.
my $result = LDAPsearch($ldap,"sn=*",\@Attrs);
=head2 PROCESSING - Displaying SEARCH Results
#------------
#
# Accessing the data as if in a structure
# i.e. Using the "as_struct" method
#
my $href = $result->as_struct;
# get an array of the DN names
my @arrayOfDNs = keys %$href ; # use DN hashes
# process each DN using it as a key
foreach (@arrayOfDNs) {
print $_,"\n";
my $valref = $$href{$_};
# get an array of the attribute names
# passed for this one DN.
my @arrayOfAttrs = sort keys %$valref; #use Attr hashes
my $attrName;
foreach $attrName (@arrayOfAttrs) {
# skip any binary data: yuck!
next if ( $attrName =~ /;binary$/ );
# get the attribute value (pointer) using the
# attribute name as the hash
my $attrVal = @$valref{$attrName} ;
print "\t $attrName: @$attrVal \n";
}
print "#-------------------------------\n";
# End of that DN
}
#
# end of as_struct method
#
#--------
#------------
#
# handle each of the results independently
# ... i.e. using the walk through method
#
my @entries = $result->entries;
my $entr ;
foreach $entr ( @entries )
{
print "DN: ",$entr->dn,"\n";
#my @attrs = sort $entr->attributes;
my $attr;
foreach $attr ( sort $entr->attributes ){
#skip binary we can't handle
next if ( $attr =~ /;binary$/ );
print " $attr : ",$entr->get_value($attr),"\n";
}
#print "@attrs\n";
print "#-------------------------------\n";
}
#
# end of walk through method
#------------
=head2 OPERATION - Modifying entries
#
# Modify
#
# for each of the modifies below you'll need to supply
# a full DN (Distinguished Name) for the $dn variable.
# example:
# cn=Jo User,ou=person,o=mycompany,c=mycountry
#
# I would recommend doing a search (listed above)
# then use the dn returned to populate the $dn variable.
#
# Do we only have one result returned from the search?
if ( $result->count != 1 ) { exit ; } # Nope.. exit
my $dn = $entries[0]->dn; # yes.. get the DN
#######################################
#
# MODIFY using a HASH
#
my %ReplaceHash = ( keyword => "x", proxy => "x" );
my $result = LDAPmodifyUsingHash($ldap,$dn, \%ReplaceHash );
sub LDAPmodifyUsingHash
{
my ($ldap,$dn,$whatToChange ) = @_ ;
my $result = $ldap->modify($dn,
replace => { %$whatToChange }
);
return ($result );
}
#######################################
#
# MODIFY using a ARRAY List
#
my @ReplaceArrayList = [ 'keyword', "xxxxxxxxxx" ,
'proxy' , "yyyyyyyyyy" ];
my $result = LDAPmodifyUsingArrayList($ldap,$dn, \@ReplaceArrayList );
sub LDAPmodifyUsingArrayList
{
my ($ldap,$dn,$whatToChange ) = @_ ;
my $result = $ldap->modify($dn,
changes => [
replace => @$whatToChange
]
);
return ($result );
}
#######################################
#
# MODIFY using a ARRAY
#
my @ReplaceArray = ( 'keyword', "xxxxxxxxxx" ,
'proxy' , "yyyyyyyyyy" );
my $result = LDAPmodifyUsingArray($ldap,$dn, \@ReplaceArray );
sub LDAPmodifyUsingArray
{
my ($ldap,$dn,$whatToChange ) = @_ ;
my $result = $ldap->modify($dn,
changes => [
replace => [ @$whatToChange ]
]
);
return ($result );
}
#######################################
#
# MODIFY an existing record using 'Changes'
# (or combination of add/delete/replace)
#
my @whatToChange ;
my @ReplaceArray ;
my @DeleteArray ;
my @AddArray ;
push @AddArray, 'cn',"me myself";
push @ReplaceArray, 'sn','!@#$%^&*()__+Hello THere';
push @ReplaceArray, 'cn',"me myself I";
push @DeleteArray, 'cn',"me myself";
if ( $#ReplaceArray > 0 ) {
push @whatToChange, 'replace' ;
push @whatToChange, \@ReplaceArray ;
}
if ( $#DeleteArray > 0 ) {
push @whatToChange, 'delete' ;
push @whatToChange, \@DeleteArray ;
}
if ( $#AddArray > 0 ) {
push @whatToChange, 'add' ;
push @whatToChange, \@AddArray ;
}
$result = LDAPmodify($ldap,$dn, \@whatToChange );
sub LDAPmodify
{
my ($ldap,$dn,$whatToChange) = @_ ;
my $result = $ldap->modify($dn,
changes => [
@$whatToChange
]
);
return ($result );
}
=head2 OPERATION - Changing the RDN
my $newRDN = "cn=Joseph User";
my $result = LDAPrdnChange($ldap,$dn,$newRDN,"archive");
sub LDAPrdnChange
{
my ($ldap,$dn,$whatToChange,$action) = @_ ;
my $branch ;
#
# if the archive action is selected, move this
# entry to another place in the directory.
#
if ( $action =~ /archive/i ) {
$branch = "ou=newbranch,o=mycompany,c=mycountry";
}
#
# use the 'deleteoldrdn' to keep from getting
# multivalues in the NAMING attribute.
# in most cases that would be the 'CN' attribute
#
my $result = $ldap->moddn($dn,
newrdn => $whatToChange,
deleteoldrdn => '1',
newsuperior => $branch
);
return ($result );
}
=head2 OPERATION - Adding a new Record
my $DNbranch = "ou=bailiwick, o=mycompany, c=mycountry";
#
# check with your Directory Schema or Administrator
# for the correct objectClass... I'm sure it'll be different
#
my $CreateArray = [
objectClass => ["top","person","organizationalPerson"],
cn => "Jane User",
uid => "0000001",
sn => "User",
mail => "JaneUser@mycompany.com"
];
#
# create the new DN to look like this
# " cn=Jo User + uid=0000001 , ou=bailiwick, o=mycompany, c=mycountry "
#
# NOTE: this DN MUST be changed to meet your implementation
#
my $NewDN = "@$CreateArray[2]=".
"@$CreateArray[3]+".
"@$CreateArray[4]=".
"@$CreateArray[5],".
$DNbranch;
LDAPentryCreate($ldap,$NewDN,$CreateArray);
#
# CreateArray is a reference to an anonymous array
# you have to dereference it in the subroutine it's
# passed to.
#
sub LDAPentryCreate
{
my ($ldap,$dn,$whatToCreate) = @_ ;
my $result = $ldap->add( $dn, attrs => [ @$whatToCreate ] );
return ($result );
}
=head2 ERROR - Retrieving and Displaying ERROR information
use Net::LDAP::Util qw( ldap_error_name
ldap_error_text) ;
if ( $result->code ) {
#
# if we've got an error... record it
#
LDAPerror("Searching",$result);
}
sub LDAPerror
{
my ($from,$mesg) = @_;
print "Return code: ",$mesg->code ;
print "\tMessage: ", ldap_error_name($mesg->code);
print " :", ldap_error_text($mesg->code);
print "MessageID: ",$mesg->mesg_id;
print "\tDN: ",$mesg->dn;
#---
# Programmer note:
#
# "$mesg->error" DOESN'T work!!!
#
#print "\tMessage: ", $mesg->error;
#-----
}
=head2 UNBIND
$ldap->unbind;
=head1 LDAP SCHEMA RETRIEVAL
The following code snippet shows how to retrieve schema information.
The first procedure is to initialize a new LDAP object using the
same procedures as listed at the beginning of this document.
The second procedure is to bind to your directory server. Some
servers may require authentication to retrieve the schema from the
directory server. This procedure is listed at the beginning of
this document too.
After a successful bind you are ready to retrieve the schema
information. You do this by initializing a schema object.
$schema = $ldap->schema();
In this case Net::LDAP will attempt to determine the dn under which
the schema can be found. First it will look for the attribute
C<subschemasubentry> in the root DSE. If that cannot be found then
it will default to the assumption of C<cn=schema>
Alternatively you can specify the dn where the schema is to be found
with
$schema = $ldap->schema(dn => $dn);
Once we have a dn to search for, Net::LDAP will fetch the schema entry with
$mesg = $self->search(
base => $dn,
scope => 'base',
filter => '(objectClass=*)',
);
Once the schema object has been initialized, schema methods
are used to retrieve the data. There are a number of ways this
can be done. Information on the schema methods can be found
in the Net::LDAP::Schema pod documentation.
The following is a code snippet showing how to get and display
information about returned attributes.
#
# Get the attributes
#
@attributes = $schema->attributes();
#
# Display the attributes
#
foreach ( @attributes)
{
print "attributeType\n";
#
# Get and display the oid number of the objectclass.
#
$oid = $schema->name2oid( "$_" );
#
# Get the various items associated with
# this attribute.
#
@attribute_items = $schema->items( "$oid" );
#
# Read returned item names and display their associated data.
#
foreach $value ( @attribute_items )
{
# We know we are dealing with an attribute, ignore type.
next if ( $value eq 'type'); # Type holds oc or at
#
# Read the data for this item of this oid.
#
@item = $schema->item( $oid, $value );
#
# Some item names have no data, the name itself is data.
# This type of item has 1 as data.
#
if ( defined(@item) && $item[0] == 1 )
{
print "\t$value\n";
next;
}
if ( defined(@item) && $#item >= 0 )
{
print "\t$value: @item\n";
}
}
}
The process is the basically the same for getting objectClass
information. Where schema->attributes() is used, substitute
schema->objectclasses(). From that point on the process is
the same for both objectClasses and attributes.
=head1 BUGS
None known, but there may be some
=head1 AUTHOR (of this document)
Russell Biggs <rgb@ticnet.com>
=head1 COPYRIGHT
All rights to this document are hereby relinquished to Graham Barr.
=for html <hr>
I<$Id$>
=cut

34
lib/Net/LDAP/Extension.pm Normal file
View file

@ -0,0 +1,34 @@
# Copyright (c) 1998-2000 Graham Barr <gbarr@pobox.com>. 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::Extension;
use vars qw(@ISA $VERSION);
@ISA = qw(Net::LDAP::Message);
$VERSION = "1.01";
#fetch the response name
sub response_name {
my $self = shift;
$self->sync unless exists $self->{Code};
exists $self->{responseName}
? $self->{responseName}
: undef;
}
# fetch the response.
sub response {
my $self = shift;
$self->sync unless exists $self->{Code};
exists $self->{response}
? $self->{response}
: undef;
}
1;

62
lib/Net/LDAP/Extra.pm Normal file
View file

@ -0,0 +1,62 @@
# Copyright (c) 2000 Graham Barr <gbarr@pobox.com>. 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::Extra;
use strict;
use vars qw($VERSION);
require Net::LDAP;
require Carp;
$VERSION = "0.01";
sub import {
shift;
local $SIG{__DIE__} = \&Carp::croak;
foreach (@_) {
my $file = "Net/LDAP/Extra/$_.pm";
next if exists $INC{$file};
require $file;
"Net::LDAP::Extra::$_"->import;
}
}
1;
__END__
=head1 NAME
Net::LDAP::Extra -- Load extra Net::LDAP methods
=head1 SYNOPSIS
use Net::LDAP::Extra qw(my_extn);
$ldap = Net::LDAP->new( ... );
$ldap->my_extn( ... );
=head1 DESCRIPTION
C<Net::LDAP::Extra> allows extra methods to be added to Net::LDAP.
Normally such methods would be added by sub-classing Net::LDAP, but this
proves to get messy as different people write different additions and
others want to use multiple of these sub-classes. Users end up having
to create sub-classes of their own which inherit from all the extension
sub-classes just so they can get all the features.
C<Net::LDAP::Extra> allows methods to be added directly to
all Net::LDAP objects. This can be done by creating a class
C<Net::LDAP::Extra::name> which exports functions. A
C<use Net::LDAP::Extra qw(name)> will then make these functions avaliable
as a methods on all C<Net::LDAP> objects.
Care should be taken when choosing names for the functions to export
to ensure that they do not clash with others.
=cut

1198
lib/Net/LDAP/FAQ.pod Normal file
View file

File diff suppressed because it is too large Load diff

273
lib/Net/LDAP/Filter.pm Normal file
View file

@ -0,0 +1,273 @@
# Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. 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::Filter;
use strict;
use vars qw($VERSION);
$VERSION = "0.12";
# filter = "(" filtercomp ")"
# filtercomp = and / or / not / item
# and = "&" filterlist
# or = "|" filterlist
# not = "!" filter
# filterlist = 1*filter
# item = simple / present / substring / extensible
# simple = attr filtertype value
# filtertype = equal / approx / greater / less
# equal = "="
# approx = "~="
# greater = ">="
# less = "<="
# extensible = attr [":dn"] [":" matchingrule] ":=" value
# / [":dn"] ":" matchingrule ":=" value
# present = attr "=*"
# substring = attr "=" [initial] any [final]
# initial = value
# any = "*" *(value "*")
# final = value
# attr = AttributeDescription from Section 4.1.5 of [1]
# matchingrule = MatchingRuleId from Section 4.1.9 of [1]
# value = AttributeValue from Section 4.1.6 of [1]
#
# Special Character encodings
# ---------------------------
# * \2a, \*
# ( \28, \(
# ) \29, \)
# \ \5c, \\
# NUL \00
my $ErrStr;
sub new {
my $self = shift;
my $class = ref($self) || $self;
my $me = bless {}, $class;
if (@_) {
$me->parse(shift) or
return undef;
}
$me;
}
my $Attr = '[-;.:\d\w]*[-;\d\w]';
my %Op = qw(
& and
| or
! not
= equalityMatch
~= approxMatch
>= greaterOrEqual
<= lessOrEqual
:= extensibleMatch
);
my %Rop = reverse %Op;
# Unescape
# \xx where xx is a 2-digit hex number
# \y where y is one of ( ) \ *
sub errstr { $ErrStr }
sub _unescape {
$_[0] =~ s/
\\([\da-fA-F]{2}|.)
/
length($1) == 1
? $1
: chr(hex($1))
/soxeg;
$_[0];
}
my %ch = split(/\s+/, '( \\( ) \\) \\ \\\\ * \\*');
sub _escape { (my $t = $_[0]) =~ s/([\\\(\)\*\0-\37])/$ch{$1}||sprintf("\\%02x",ord($1))/sge; $t }
sub _encode {
my($attr,$op,$val) = @_;
# An extensible match
if ($op eq ':=') {
# attr must be in the form type:dn:1.2.3.4
unless ($attr =~ /^([-;\d\w]*)(:dn)?(:(\w+|[.\d]+))?$/) {
$ErrStr = "Bad attribute $attr";
return undef;
}
my($type,$dn,$rule) = ($1,$2,$4);
return ( {
extensibleMatch => {
matchingRule => $rule,
type => $type,
matchValue => _unescape($val),
dnAttributes => $dn ? 1 : 0
}
});
}
# If the op is = and contains one or more * not
# preceeded by \ then do partial matches
if ($op eq '=' && $val =~ /^(\\.|[^\\*]+)*\*/o ) {
my $n = [];
my $type = 'initial';
while ($val =~ s/^((\\.|[^\\*]+)*)\*+//) {
push(@$n, { $type, _unescape("$1") }) # $1 is readonly, copy it
if length $1;
$type = 'any';
}
push(@$n, { 'final', _unescape($val) })
if length $val;
return ({
substrings => {
type => $attr,
substrings => $n
}
});
}
# Well we must have an operator and no un-escaped *'s on the RHS
return {
$Op{$op} => {
attributeDesc => $attr, assertionValue => _unescape($val)
}
};
}
sub parse {
my $self = shift;
my $filter = shift;
my @stack = (); # stack
my $cur = [];
my $op;
undef $ErrStr;
# Algorithm depends on /^\(/;
$filter =~ s/^\s*//;
$filter = "(" . $filter . ")"
unless $filter =~ /^\(/;
while (length($filter)) {
# Process the start of (& (...)(...))
if ($filter =~ s/^\(\s*([&!|])\s*//) {
push @stack, [$op,$cur];
$op = $1;
$cur = [];
next;
}
# Process the end of (& (...)(...))
elsif ($filter =~ s/^\)\s*//o) {
unless (@stack) {
$ErrStr = "Bad filter, unmatched )";
return undef;
}
my($myop,$mydata) = ($op,$cur);
($op,$cur) = @{ pop @stack };
# Need to do more checking here
push @$cur, { $Op{$myop} => $myop eq '!' ? $mydata->[0] : $mydata };
next if @stack;
}
# present is a special case (attr=*)
elsif ($filter =~ s/^\(\s*($Attr)=\*\)\s*//o) {
push(@$cur, { present => $1 } );
next if @stack;
}
# process (attr op string)
elsif ($filter =~ s/^\(\s*
($Attr)\s*
([:~<>]?=)
((?:\\.|[^\\()]+)*)
\)\s*
//xo) {
push(@$cur, _encode($1,$2,$3));
next if @stack;
}
# If we get here then there is an error in the filter string
# so exit loop with data in $filter
last;
}
if (length $filter) {
# If we have anything left in the filter, then there is a problem
$ErrStr = "Bad filter, error before " . substr($filter,0,20);
return undef;
}
if (@stack) {
$ErrStr = "Bad filter, unmatched (";
return undef;
}
%$self = %{$cur->[0]};
$self;
}
sub print {
my $self = shift;
no strict 'refs'; # select may return a GLOB name
my $fh = @_ ? shift : select;
print $fh $self->as_string,"\n";
}
sub as_string { _string(%{$_[0]}) }
sub _string { # prints things of the form (<op> (<list>) ... )
my $i;
my $str = "";
for ($_[0]) {
/^and/ and return "(&" . join("", map { _string(%$_) } @{$_[1]}) . ")";
/^or/ and return "(|" . join("", map { _string(%$_) } @{$_[1]}) . ")";
/^not/ and return "(!" . _string(%{$_[1]}) . ")";
/^present/ and return "($_[1]=*)";
/^(equalityMatch|greaterOrEqual|lessOrEqual|approxMatch)/
and return "(" . $_[1]->{attributeDesc} . $Rop{$1} . _escape($_[1]->{assertionValue}) .")";
/^substrings/ and do {
my $str = join("*", "",map { _escape($_) } map { values %$_ } @{$_[1]->{substrings}});
$str =~ s/^.// if exists $_[1]->{substrings}[0]{initial};
$str .= '*' unless exists $_[1]->{substrings}[-1]{final};
return "($_[1]->{type}=$str)";
};
/^extensibleMatch/ and do {
my $str = "($_[1]->{type}";
$str .= ":dn" if $_[1]->{dnAttributes};
$str .= ":$_[1]->{matchingRule}" if defined $_[1]->{matchingRule};
$str .= ":=" . _escape($_[1]->{matchValue}) . ")";
return $str;
};
}
die "Internal error $_[0]";
}
1;

112
lib/Net/LDAP/Filter.pod Normal file
View file

@ -0,0 +1,112 @@
=head1 NAME
Net::LDAP::Filter - representation of LDAP filters
=head1 SYNOPSIS
use Net::LDAP::Filter;
$filter = Net::LDAP::Filter->new( $filter_str );
=head1 DESCRIPTION
=head1 CONSTRUCTOR
=over 4
=item new ( FILTER )
Create a new object and parse FILTER.
=back
=head1 METHODS
=over 4
=item parse ( FILTER )
Parse FILTER. The next call to ber will return this filter encoded.
=item asn
Return the data structure suitable for passing directly to L<Convert::ASN1>
to encode a filter object.
=item as_string
Return the filter in text form.
=item print ( [ FH ] )
Print the text representation of the filter to FH, or the currently
selected output handle if FH is not given.
=back
=head1 FILTER SYNTAX
Below is the syntax for a filter given in
RFC-2254 http://info.internet.isi.edu/in-notes/rfc/files/rfc2254.txt
filter = "(" filtercomp ")"
filtercomp = and / or / not / item
and = "&" filterlist
or = "|" filterlist
not = "!" filter
filterlist = 1*filter
item = simple / present / substring / extensible
simple = attr filtertype value
filtertype = equal / approx / greater / less
equal = "="
approx = "~="
greater = ">="
less = "<="
extensible = attr [":dn"] [":" matchingrule] ":=" value
/ [":dn"] ":" matchingrule ":=" value
present = attr "=*"
substring = attr "=" [initial] any [final]
initial = value
any = "*" *(value "*")
final = value
attr = AttributeDescription from Section 4.1.5 of RFC-2251
matchingrule = MatchingRuleId from Section 4.1.9 of RFC-2251
value = AttributeValue from Section 4.1.6 of RFC-2251
Special Character encodings
---------------------------
* \2a, \*
( \28, \(
) \29, \)
\ \5c, \\
NUL \00
=head1 SEE ALSO
L<Net::LDAP>,
L<Other online documentation|Net::LDAP::RFC>
=head1 ACKNOWLEDGEMENTS
This document is based on a document originally written by Russell Fulton
<r.fulton@auckland.ac.nz>.
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap-dev@lists.sourceforge.net>.
=head1 COPYRIGHT
Copyright (c) 1997-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>
I<$Id$>
=cut

508
lib/Net/LDAP/LDIF.pm Normal file
View file

@ -0,0 +1,508 @@
# Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. 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::LDIF;
use strict;
use SelectSaver;
require Net::LDAP::Entry;
use vars qw($VERSION);
$VERSION = "0.09";
my %mode = qw(w > r < a >>);
sub new {
my $pkg = shift;
my $file = shift || "-";
my $mode = shift || "r";
my %opt = @_;
my $fh;
my $opened_fh = 0;
if (ref($file)) {
$fh = $file;
}
else {
if ($file eq "-") {
if ($mode eq "w") {
($file,$fh) = ("STDOUT",\*STDOUT);
}
else {
($file,$fh) = ("STDIN",\*STDIN);
}
}
else {
require Symbol;
$fh = Symbol::gensym();
my $open = ($mode{$mode} || "<") . $file;
open($fh,$open) or return;
$opened_fh = 1;
}
}
# Default the encoding of DNs to 'none' unless the user specifies
$opt{'encode'} = 'none' unless exists $opt{'encode'};
# Default the error handling to die
$opt{'onerror'} = 'die' unless exists $opt{'onerror'};
$opt{'lowercase'} ||= 0;
my $self = {
change => 0,
changetype => "modify",
modify => 'add',
wrap => 78,
%opt,
fh => $fh,
file => "$file",
opened_fh => $opened_fh,
eof => 0,
};
bless $self, $pkg;
}
sub _read_lines {
my $self = shift;
my @ldif;
{
local $/ = "";
my $fh = $self->{'fh'};
my $ln = $self->{_next_lines} || scalar <$fh>;
unless ($ln) {
$self->{_next_lines} = '';
$self->{_current_lines} = '';
$self->eof(1);
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};
}
@ldif;
}
# _read_one() is deprecated and will be removed
# in a future version
*_read_one = \&_read_entry;
sub _read_entry {
my $self = shift;
my @ldif;
$self->_clear_error();
@ldif = $self->_read_lines;
return unless @ldif;
shift @ldif if @ldif && $ldif[0] !~ /\D/;
if (@ldif <= 1) {
$self->_error("LDIF entry is not valid", @ldif);
return;
}
elsif (not ( $ldif[0] =~ s/^dn:(:?) *//) ) {
$self->_error("First line of LDIF entry does not begin with 'dn:'", @ldif);
return;
}
my $dn = shift @ldif;
if (length($1)) {
eval { require MIME::Base64 };
if ($@) {
$self->_error($@, @ldif);
return;
}
$dn = MIME::Base64::decode($dn);
}
my $entry = Net::LDAP::Entry->new;
$entry->dn($dn);
if ($ldif[0] =~ /^changetype:\s*/) {
my $changetype = $ldif[0] =~ s/^changetype:\s*//
? shift(@ldif) : $self->{'changetype'};
$entry->changetype($changetype);
return $entry if ($changetype eq "delete");
unless (@ldif) {
$self->_error("LDAP entry is not valid",@ldif);
return;
}
while(@ldif) {
my $modify = $self->{'modify'};
my $modattr;
my $lastattr;
if($changetype eq "modify") {
unless ( (my $tmp = shift @ldif) =~ s/^(add|delete|replace):\s*([-;\w]+)// ) {
$self->_error("LDAP entry is not valid",@ldif);
return;
}
$lastattr = $modattr = $2;
$modify = $1;
}
my @values;
while(@ldif) {
my $line = shift @ldif;
my $attr;
if ($line eq "-") {
$entry->$modify($lastattr, \@values)
if defined $lastattr;
undef $lastattr;
@values = ();
last;
}
$line =~ s/^([-;\w]+):\s*// and $attr = $1;
if ($line =~ s/^:\s*//) {
eval { require MIME::Base64 };
if ($@) {
$self->_error($@, @ldif);
return;
}
$line = MIME::Base64::decode($line);
}
if( defined($modattr) && $attr ne $modattr ) {
$self->_error("LDAP entry is not valid", @ldif);
return;
}
if(!defined($lastattr) || $lastattr ne $attr) {
$entry->$modify($lastattr, \@values)
if defined $lastattr;
$lastattr = $attr;
@values = ($line);
next;
}
push @values, $line;
}
$entry->$modify($lastattr, \@values)
if defined $lastattr;
}
}
else {
my @attr;
my $last = "";
my $vals = [];
my $line;
my $attr;
foreach $line (@ldif) {
$line =~ s/^([-;\w]+):\s*// && ($attr = $1) or next;
if ($line =~ s/^:\s*//) {
eval { require MIME::Base64 };
if ($@) {
$self->_error($@, @ldif);
return;
}
$line = MIME::Base64::decode($line);
}
if ($attr eq $last) {
push @$vals, $line;
next;
}
else {
$vals = [$line];
push(@attr,$last=$attr,$vals);
}
}
$entry->add(@attr);
}
$self->{_current_entry} = $entry;
$entry;
}
sub read_entry {
my $self = shift;
unless ($self->{'fh'}) {
$self->_error("LDIF file handle not valid");
return;
}
$self->_read_entry();
}
# read() is deprecated and will be removed
# in a future version
sub read {
my $self = shift;
return $self->read_entry() unless wantarray;
my($entry, @entries);
push(@entries,$entry) while $entry = $self->read_entry;
@entries;
}
sub eof {
my $self = shift;
my $eof = shift;
if ($eof) {
$self->{_eof} = $eof;
}
$self->{_eof};
}
sub _wrap {
if($_[1] > 40) {
my $pos = $_[1];
while($pos < length($_[0])) {
substr($_[0],$pos,0) = "\n ";
$pos += $_[1]+1;
}
}
$_[0];
}
sub _write_attr {
my($attr,$val,$wrap,$lower) = @_;
my $v;
foreach $v (@$val) {
my $ln = $lower ? lc $attr : $attr;
if ($v =~ /(^[ :]|[\x00-\x1f\x7f-\xff])/) {
require MIME::Base64;
$ln .= ":: " . MIME::Base64::encode($v,"");
}
else {
$ln .= ": " . $v;
}
print _wrap($ln,$wrap),"\n";
}
}
sub _write_attrs {
my($entry,$wrap,$lower) = @_;
my $attr;
foreach $attr ($entry->attributes) {
my $val = $entry->get_value($attr, asref => 1);
_write_attr($attr,$val,$wrap,$lower);
}
}
sub _write_dn {
my($dn,$encode,$wrap) = @_;
if ($dn =~ /^[ :<]|[\x00-\x1f\x7f-\xff]/) {
if ($encode =~ /canonical/i) {
require Net::LDAP::Util;
$dn = Net::LDAP::Util::canonical_dn($dn);
# Canonicalizer won't fix leading spaces, colons or less-thans, which
# are special in LDIF, so we fix those up here.
$dn =~ s/^([ :<])/\\$1/;
} elsif ($encode =~ /base64/i) {
require MIME::Base64;
$dn = "dn:: " . MIME::Base64::encode($dn,"");
} else {
$dn = "dn: $dn";
}
} else {
$dn = "dn: $dn";
}
print _wrap($dn,$wrap), "\n";
}
# write() is deprecated and will be removed
# in a future version
sub write {
my $self = shift;
$self->{change} = 0;
$self->write_entry(@_);
}
sub write_entry {
my $self = shift;
my $entry;
my $change = $self->{change};
my $wrap = int($self->{'wrap'});
my $lower = $self->{'lowercase'};
local($\,$,); # output field and record separators
unless ($self->{'fh'}) {
$self->_error("LDIF file handle not valid");
return;
}
my $saver = SelectSaver->new($self->{'fh'});
my $fh = $self->{'fh'};
foreach $entry (@_) {
unless (ref $entry) {
$self->_error("Entry '$entry' is not a valid Net::LDAP::Entry object.");
next;
}
if ($change) {
my @changes = $entry->changes;
my $type = $entry->changetype;
# Skip entry if there is nothing to write
next if $type eq 'modify' and !@changes;
print "\n" if tell($self->{'fh'});
_write_dn($entry->dn,$self->{'encode'},$wrap);
print "changetype: $type\n";
if ($type eq 'delete') {
next;
}
elsif ($type eq 'add') {
_write_attrs($entry,$wrap,$lower);
next;
}
elsif ($type eq 'modrdn') {
print _write_attr('newrdn',$entry->get_value('newrdn', asref => 1),$wrap,$lower);
print 'deleteoldrdn: ', scalar $entry->get_value('deleteoldrdn'),"\n";
my $ns = $entry->get_value('newsuperior', asref => 1);
print _write_attr('newsuperior',$ns,$wrap,$lower) if defined $ns;
next;
}
my $dash=0;
foreach my $chg (@changes) {
unless (ref($chg)) {
$type = $chg;
next;
}
my $i = 0;
while ($i < @$chg) {
print "-\n" if $dash++;
my $attr = $chg->[$i++];
my $val = $chg->[$i++];
print $type,": ",$attr,"\n";
_write_attr($attr,$val,$wrap,$lower);
}
}
}
else {
print "\n" if tell($self->{'fh'});
_write_dn($entry->dn,$self->{'encode'},$wrap);
_write_attrs($entry,$wrap,$lower);
}
}
1;
}
# read_cmd() is deprecated in favor of read_entry()
# and will be removed in a future version
sub read_cmd {
my $self = shift;
return $self->read_entry() unless wantarray;
my($entry, @entries);
push(@entries,$entry) while $entry = $self->read_entry;
@entries;
}
# _read_one_cmd() is deprecated in favor of _read_one()
# and will be removed in a future version
*_read_one_cmd = \&_read_entry;
# write_cmd() is deprecated in favor of write_entry()
# and will be removed in a future version
sub write_cmd {
my $self = shift;
$self->{change} = 1;
$self->write_entry(@_);
}
sub done {
my $self = shift;
if ($self->{fh}) {
if ($self->{opened_fh}) {
close $self->{fh};
undef $self->{opened_fh};
}
delete $self->{fh};
}
1;
}
my %onerror = (
'die' => sub {
my $self = shift;
require Carp;
$self->done;
Carp::croak($self->error(@_));
},
'warn' => sub {
my $self = shift;
require Carp;
Carp::carp($self->error(@_));
},
'undef' => sub {
my $self = shift;
require Carp;
Carp::carp($self->error(@_)) if $^W;
},
);
sub _error {
my ($self,$errmsg,@errlines) = @_;
$self->{_err_msg} = $errmsg;
$self->{_err_lines} = join "\n",@errlines;
scalar &{ $onerror{ $self->{onerror} } }($self,$self->{_err_msg}) if $self->{onerror};
}
sub _clear_error {
my $self = shift;
undef $self->{_err_msg};
undef $self->{_err_lines};
}
sub error {
my $self = shift;
$self->{_err_msg};
}
sub error_lines {
my $self = shift;
$self->{_err_lines};
}
sub current_entry {
my $self = shift;
$self->{_current_entry};
}
sub current_lines {
my $self = shift;
$self->{_current_lines};
}
sub next_lines {
my $self = shift;
$self->{_next_lines};
}
sub DESTROY {
my $self = shift;
$self->done();
}
1;

141
lib/Net/LDAP/LDIF.pod Normal file
View file

@ -0,0 +1,141 @@
=head1 NAME
Net::LDAP::LDIF - LDIF reading and writing
=head1 SYNOPSIS
use Net::LDAP::LDIF;
$ldif = Net::LDAP::LDIF->new( "file.ldif", "r", onerror => 'undef' );
while( not $ldif->eof() ) {
$entry = $ldif->read_entry();
if ( $ldif->error() ) {
print "Error msg: ",$ldif->error(),"\n";
print "Error lines:\n",$ldif->error_lines(),"\n";
}
else {
# do stuff
}
}
$ldif->done();
=head1 DESCRIPTION
B<Net::LDAP::LDIF> provides a means to convert between
L<Net::LDAP::Entry> objects and LDAP entries represented
in LDIF format files. Reading and writing are supported and may manipulate
single entries or lists of entries.
As when reading an entire file into memory with perl normally, take into
account the possibility of memory use when loading an LDIF file in one go.
=head1 CONSTRUCTOR
=over 4
=item new ( [ FILE [, MODE [,OPTIONS ]]] )
FILE may be the name of a file or an already open filehandle. If a filename
is passed in then it will be opened with the mode specified.
MODE defaults to "r" for read. You may specify "w" to for write+truncate or
"a" for write+append.
OPTIONS is a list of key-value pairs. Valid options are:
=over 4
=item encode
Some values in LDIF cannot be written verbatim and have to be encoded
in some way. This option lets you specify how. Valid encoding options
are 'none' (the default), 'canonical' (see
L<Net::LDAP::Util/canonical_dn>), or 'base64'.
=back
=item onerror
If set then Net::LDAP::LDIF will check all responses for errors on all methods.
If an error is detected then the specified action will be taken. Valid values
and their actions are.
=over 4
=item die
Net::LDAP::LDIF will croak with an appropriate message.
=item warn
Net::LDAP::LDIF will warn with an appropriate message.
=item undef
Net::LDAP::LDIF will warn with an appropriate message if C<-w> is in effect.
The method that was called will return C<undef>
=back
=back
=head1 METHODS
=over 4
=item read_entry
Read one entry from the file and return it as a Net::LDAP::Entry object.
=item eof
Returns true when the end of the file is reached.
=item write_entry ( ENTRIES )
=item done
This method signals that the LDIF object is no longer needed. If a file was
opened automatically when the object was created it will be closed. This
method is called automatically via DESTROY when the object goes out of scope.
=item error
Returns error message if error was found.
=item error_lines
Returns lines that resulted in error.
=item current_entry
Returns the current Net::LDAP::Entry object.
=item current_lines
Returns the lines that generated the current Net::LDAP::Entry object.
=item next_lines
Returns the lines that will generate the next Net::LDAP::Entry object.
=back
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>.
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap-dev@lists.sourceforge.net>.
=head1 COPYRIGHT
Copyright (c) 1997-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>
=cut

227
lib/Net/LDAP/Message.pm Normal file
View file

@ -0,0 +1,227 @@
# $Id$
# Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. 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::Message;
use Net::LDAP::Constant qw(LDAP_SUCCESS LDAP_COMPARE_TRUE LDAP_COMPARE_FALSE);
use Net::LDAP::ASN qw(LDAPRequest);
use strict;
use vars qw($VERSION);
$VERSION = "1.05";
my $MsgID = 0;
# We do this here so when we add threading we can lock it
sub NewMesgID {
$MsgID = 1 if ++$MsgID > 65535;
$MsgID;
}
sub new {
my $self = shift;
my $type = ref($self) || $self;
my $parent = shift;
my $arg = shift;
$self = bless {
parent => $parent,
mesgid => NewMesgID(),
callback => $arg->{callback} || undef,
}, $type;
$self;
}
sub code {
my $self = shift;
$self->sync unless exists $self->{resultCode};
exists $self->{resultCode}
? $self->{resultCode}
: undef
}
sub done {
my $self = shift;
exists $self->{resultCode};
}
sub dn {
my $self = shift;
$self->sync unless exists $self->{resultCode};
exists $self->{matchedDN}
? $self->{matchedDN}
: undef
}
sub referrals {
my $self = shift;
$self->sync unless exists $self->{resultCode};
exists $self->{referral}
? @{$self->{referral}}
: ();
}
sub server_error {
my $self = shift;
$self->sync unless exists $self->{resultCode};
exists $self->{errorMessage}
? $self->{errorMessage}
: undef
}
sub error {
my $self = shift;
$self->server_error
or require Net::LDAP::Util
and Net::LDAP::Util::ldap_error_desc( $self->code );
}
sub set_error {
my $self = shift;
($self->{resultCode},$self->{errorMessage}) = ($_[0]+0, "$_[1]");
$self;
}
sub sync {
my $self = shift;
my $ldap = $self->{parent};
my $err;
until(exists $self->{resultCode}) {
$err = $ldap->sync($self->mesg_id) or next;
$self->set_error($err,"Protocol Error")
unless exists $self->{resultCode};
return $err;
}
LDAP_SUCCESS;
}
sub decode { # $self, $pdu, $control
my $self = shift;
my $result = shift;
my $data = (values %{$result->{protocolOp}})[0];
@{$self}{keys %$data} = values %$data;
# Should the controls be associated with the whole request, or in
# the case of a search the entry in this packet ? -- GMB
$self->{controls} = $result->{controls}
if exists $result->{controls};
# free up memory as we have a result so we will not need to re-send it
delete $self->{pdu};
# tell our LDAP client to forget us as this message has now completed
# all communications with the server
$self->parent->_forgetmesg($self);
$self->{callback}->($self)
if (defined $self->{callback});
$self;
}
sub abandon {
my $self = shift;
return if exists $self->{resultCode}; # already complete
my $ldap = $self->{parent};
$ldap->abandon($self->{mesgid});
}
sub saslref {
my $self = shift;
$self->sync unless exists $self->{resultCode};
exists $self->{sasl}
? $self->{sasl}
: undef
}
sub encode {
my $self = shift;
$self->{pdu} = $LDAPRequest->encode(@_, messageID => $self->{mesgid})
or return;
1;
}
sub control {
my $self = shift;
if (exists $self->{controls}) {
require Net::LDAP::Control;
my $hash = $self->{ctrl_hash} = {};
foreach my $asn (@{delete $self->{controls}}) {
my $ctrl = Net::LDAP::Control->from_asn($asn);
push @{$hash->{$ctrl->type} ||= []}, $ctrl;
}
}
return unless exists $self->{ctrl_hash};
@_ ? exists $self->{ctrl_hash}{$_[0]}
? @{$self->{ctrl_hash}{$_[0]}}
: ()
: map { @$_ } values %{$self->{ctrl_hash}};
}
sub pdu { shift->{pdu} }
sub callback { shift->{callback} }
sub parent { shift->{parent} }
sub mesg_id { shift->{mesgid} }
sub is_error { shift->code }
##
##
##
@Net::LDAP::Add::ISA = qw(Net::LDAP::Message);
@Net::LDAP::Delete::ISA = qw(Net::LDAP::Message);
@Net::LDAP::Modify::ISA = qw(Net::LDAP::Message);
@Net::LDAP::ModDN::ISA = qw(Net::LDAP::Message);
@Net::LDAP::Compare::ISA = qw(Net::LDAP::Message);
@Net::LDAP::Unbind::ISA = qw(Net::LDAP::Message::Dummy);
@Net::LDAP::Abandon::ISA = qw(Net::LDAP::Message::Dummy);
sub Net::LDAP::Compare::is_error {
my $mesg = shift;
my $code = $mesg->code;
$code != LDAP_COMPARE_FALSE and $code != LDAP_COMPARE_TRUE
}
{
package Net::LDAP::Message::Dummy;
use vars qw(@ISA);
@ISA = qw(Net::LDAP::Message);
sub sync { shift }
sub decode { shift }
sub abandon { shift }
sub code { 0 }
sub error { "" }
sub dn { "" }
sub done { 1 }
}
1;

111
lib/Net/LDAP/Message.pod Normal file
View file

@ -0,0 +1,111 @@
=head1 NAME
Net::LDAP::Message - Message response from LDAP server
=head1 SYNOPSIS
use Net::LDAP;
=head1 DESCRIPTION
B<Net::LDAP::Message> is a base class for the objects returned by the
L<Net::LDAP> methods
L<abandon|Net::LDAP/item_abandon>,
L<add|Net::LDAP/item_add>,
L<bind|Net::LDAP/item_bind>,
L<compare|Net::LDAP/item_compare>,
L<delete|Net::LDAP/item_delete>,
L<modify|Net::LDAP/item_modify>,
L<moddn|Net::LDAP/item_moddn>,
L<search|Net::LDAP/item_search> and
L<unbind|Net::LDAP/item_unbind>.
The sub-class L<Net::LDAP::Search> returned by L<search|Net::LDAP/item_search> also
defines many methods.
If the L<Net::LDAP> object is in async mode then all these methods, except
C<done>, will cause a wait until the request is completed.
=head1 METHODS
=over 4
=item code
The code value in the result message from the server. Normally for
a success zero will be returned. Constants for the result codes
can be imported from the L<Net::LDAP> or L<Net::LDAP::Constant> module.
=item control [ OID ]
Return a list of controls returned from the server. If OID is given
then only controls with type equal to OID will be returned.
=item dn
The DN in the result message from the server.
=item done
Returns I<true> if the request has been completed.
=item error
The error message in the result message from the server. If the server did
not include an error message, then the result of
L<ldap_error_desc|Net::LDAP::Util/ldap_error_desc> with the
error code from the result message.
=item is_error
Returns I<true> if the result code is considered to be an error for the operation.
=item mesg_id
The message id of the request message sent to the server.
=item referrals
Returns a list of referrals from the result message.
=item server_error
The error message returned by the server, or undef if the server did not provide
a message.
=item sync
Wait for the server to complete the request.
=back
=head1 SEE ALSO
L<Net::LDAP>,
L<Net::LDAP::Search>,
L<Net::LDAP::Constant>,
L<Net::LDAP::Util>
=head1 ACKNOWLEDGEMENTS
This document is based on a document originally written by Russell Fulton
<r.fulton@auckland.ac.nz>.
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap-dev@lists.sourceforge.net>.
=head1 COPYRIGHT
Copyright (c) 1997-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>
I<$Id$>
=cut

1295
lib/Net/LDAP/RFC.pod Normal file
View file

File diff suppressed because it is too large Load diff

63
lib/Net/LDAP/Reference.pod Normal file
View file

@ -0,0 +1,63 @@
=head1 NAME
Net::LDAP::Reference - search reference
=head1 SYNOPSIS
use Net::LDAP;
$ldap->search( @search_args, callback => \&process);
sub process {
my $mesg = shift;
my $obj = shift;
if (!$obj) {
# Search complete
}
elsif ($obj->isa('Net::LDAP::Reference')) {
my $ref;
foreach $ref ($obj->references) {
# process ref
}
}
else {
# Process Net::LDAP::Entry
}
}
=head1 DESCRIPTION
=head1 METHODS
=over 4
=item references
Returns a list of references from the server.
=back
=head1 SEE ALSO
L<Net::LDAP>,
L<Net::LDAP::Search>
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>.
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap-dev@lists.sourceforge.net>.
=head1 COPYRIGHT
Copyright (c) 1997-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>
I<$Id$>
=cut

631
lib/Net/LDAP/Schema.pm Normal file
View file

@ -0,0 +1,631 @@
# Copyright (c) 1998-2000 Graham Barr <gbarr@pobox.com>. 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::Schema;
use strict;
use vars qw($VERSION);
$VERSION = "0.10";
#
# Get schema from the server (or read from LDIF) and parse it into
# data structure
#
sub new {
my $self = shift;
my $type = ref($self) || $self;
my $schema = bless {}, $type;
return $schema unless @_;
return $schema->parse( shift ) ? $schema : undef;
}
sub _error {
my $self = shift;
$self->{error} = shift;
return;
}
sub parse {
my $schema = shift;
my $arg = shift;
unless ($arg) {
$schema->{error} = "Bad argument";
return undef;
}
%$schema = ();
my $entry;
if( ref $arg ) {
if (UNIVERSAL::isa($arg, 'Net::LDAP::Entry')) {
$entry = $arg;
}
elsif (UNIVERSAL::isa($arg, 'Net::LDAP::Search')) {
unless ($entry = $arg->entry) {
$schema->{error} = 'Bad Argument';
return undef;
}
}
else {
$schema->{error} = 'Bad Argument';
return undef;
}
}
elsif( -f $arg ) {
require Net::LDAP::LDIF;
my $ldif = Net::LDAP::LDIF->new( $arg, "r" );
$entry = $ldif->read();
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 {};
_parse_schema( $schema, $entry );
};
if ($@) {
$schema->{error} = $@;
return undef;
}
return $schema;
}
#
# Dump as LDIF
#
# XXX - We should really dump from the internal structure. That way we can
# have methods to modify the schema and write a new one -- GMB
sub dump {
my $self = shift;
my $fh = @_ ? shift : \*STDOUT;
my $entry = $self->{'entry'} or return;
require Net::LDAP::LDIF;
Net::LDAP::LDIF->new($fh,"w", wrap => 0)->write($entry);
1;
}
#
# Given another Net::LDAP::Schema, merge the contents together.
# XXX - todo
#
sub merge {
my $self = shift;
my $new = shift;
# Go through structure of 'new', copying code to $self. Take some
# parameters describing what to do in the event of a clash.
}
#
# 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" )
or return;
}
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;
}
#
# XXX - TODO - move long comments to POD and write up interface
#
# Data structure is:
#
# $schema (hash ref)
#
# The {oid} piece here is a little redundant since we control the other
# top-level members. We promote the first listed name to be 'canonical' and
# also make up a name for syntaxes (from the description). Thus we always
# have a unique name. This avoids a lot of checking in the access routines.
#
# ->{oid}->{$oid}->{
# name => $canonical_name, (created for syn)
# aliases => list of non. canon names
# type => at/oc/syn
# desc => description
# must => list of can. names of mand. atts [if OC]
# may => list of can. names of opt. atts [if OC]
# syntax => can. name of syntax [if AT]
# ... etc per oid details
#
# 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
#
#
# These items have no following arguments
#
my %flags = map { ($_,1) } qw(
single-value
obsolete
collective
no-user-modification
abstract
structural
auxiliary
);
#
# These items can have lists arguments
# (name can too, but we treat it special)
#
my %listops = map { ($_,1) } qw(must may sup);
#
# 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",
);
#
# Return ref to hash containing schema data - undef on failure
#
sub _parse_schema {
my $schema = shift;
my $entry = shift;
return undef unless defined($entry);
keys %type2attr; # reset iterator
while(my($type,$attr) = each %type2attr) {
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
foreach my $val (@$vals) {
#
# The following statement takes care of defined attributes
# that have no data associated with them.
#
next if $val eq '';
#
# We assume that each value can be turned into an OID, a canonical
# name and a 'schema_entry' which is a hash ref containing the items
# present in the value.
#
my %schema_entry = ( type => $type, aliases => [] );
my @tokens;
pos($val) = 0;
push @tokens, $+
while $val =~ /\G\s*(?:
([()])
|
([^"'\s()]+)
|
"([^"]*)"
|
'([^']*)'
)\s*/xcg;
die "Cannot parse [$val] ",substr($val,pos($val)) unless @tokens and pos($val) == length($val);
# remove () from start/end
shift @tokens if $tokens[0] eq '(';
pop @tokens if $tokens[-1] eq ')';
# The first token is the OID
my $oid = $schema_entry{oid} = shift @tokens;
while(@tokens) {
my $tag = lc shift @tokens;
if (exists $flags{$tag}) {
$schema_entry{$tag} = 1;
}
elsif (@tokens) {
if (($schema_entry{$tag} = shift @tokens) eq '(') {
my @arr;
$schema_entry{$tag} = \@arr;
while(1) {
my $tmp = shift @tokens;
last if $tmp eq ')';
push @arr,$tmp unless $tmp eq '$';
# Drop of end of list ?
die "Cannot parse [$val]" unless @tokens;
}
}
# Ensure items that can be lists are stored as array refs
$schema_entry{$tag} = [ $schema_entry{$tag} ]
if exists $listops{$tag} and !ref $schema_entry{$tag};
}
else {
die "Cannot parse [$val]";
}
}
#
# 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;
}
}
}
}
$schema->{entry} = $entry;
return $schema;
}
#
# 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 {
$_[0]->{error};
}
#
# Return base entry
#
sub entry {
$_[0]->{entry};
}
1;

265
lib/Net/LDAP/Schema.pod Normal file
View file

@ -0,0 +1,265 @@
=head1 NAME
Net::LDAP::Schema - Load and manipulate an LDAP v3 Schema
=head1 SYNOPSIS
use Net::LDAP;
use Net::LDAP::Schema;
#
# Read schema from server
#
$ldap = Net::LDAP->new( $server );
$ldap->bind();
$schema = $ldap->schema();
#
# Load from LDIF
#
$schema = Net::LDAP::Schema->new;
$schema->parse( "schema.ldif" ) or die $schema->error;
=head1 DESCRIPTION
B<Net::LDAP::Schema> provides a means to load an LDAP schema and query it
for information regarding supported objectclasses, attributes and syntaxes.
=head1 METHODS
Where a method is stated as taking the 'name or oid' of a schema item (which
may be an object class, attribute or syntax) then a case-insensitive name
or raw oid (object identifier, in dotted numeric string form, e.g. 2.5.4.0)
may be supplied.
=over 4
=item attributes
With no arguments, returns a list of the names all attributes in the schema.
@atts = $schema->attributes();
If called with an argument which is the name or oid of a known object class,
returns a list of the attributes which may (or must) be present in the OC.
@person_atts = $schema->attributes( "person" );
Return value is an array or array reference depending on calling context, or
empty list on error.
=item ditstructurerules
Returns a list of the names of all ditstructurerules in the schema.
@dts = $schema->ditstructurerules();
Return value is an array or array reference depending on calling context.
=item ditcontentrules
Returns a list of the names of all ditcontentrules in the schema.
@dtc = $schema->ditcontentrules();
Return value is an array or array reference depending on calling context.
=item dump
Given an argument which is the name of a file, and the file or
directory has write permission, will dump the raw schema
information to a file. If no argument is given the raw schema
information is dumped to standard out.
$result = $schema->dump( "./schema.dump" );
or
$result = $schema->dump();
If no schema data is returned from directory server, the method
will return undefined. Otherwise a value of 1 is always returned.
=item error
Returns the last error encountered.
=item is_objectclass, is_attribute, is_syntax, is_matchingrule
Given the name or oid of a schema item (object class, attribute,
syntax or matchingrule respectively) returns the assoicated OID
or undef if the name or oid is not of the appropriate type.
# Is foo a known OC?
$oid = $schema->is_objectclass( "foo" );
# No? Bale out.
die( "Not an objectclass" ) unless $oid;
# Yes...so we can do this
@must = $schema->must( $oid );
=item is_matchingruleuse, is_ditstructurerule, is_ditcontentrule, is_nameform
Given the name or oid of a schema item (matchingruleuse, ditstructurerule,
ditcontentrule or nameform respectively) returns the assoicated OID
or undef if the name or oid is not of the appropriate type.
# Is foo a known OC?
$oid = $schema->is_nameform( "foo" );
# No? Bale out.
die( "Not a nameform" ) unless $oid;
=item item
Given two arguments, first of which is the name or oid of a known
object class or attribute and second of which is the name of the
item, returns the item's data value. The item's value may be
undefined.
@item = $schema->item( $oid, "desc" );
Return value is an array or a value depending on calling context.
If the first argument is a name and there is more than one item in the
schema with that name then undef, or the empty list, will be returned.
=item items
Given an argument which is the name or oid of a known object class or
attribute, returns the items available for this attribute or object class.
The returned item name may have an undefined value.
@items = $schema->items( $oid );
Return value is a list or array reference depending on calling context.
If the argument given is a name and there is more than one item in the
schema with that name then undef, or the empty list, will be returned.
=item matchingrules
Returns a list of the names of all matchingrules in the schema.
@mrs = $schema->matchingrules();
Return value is an array or array reference depending on calling context.
=item matchingruleuse
Returns a list of the names of all matchingruleuse in the schema.
@mru = $schema->matchingruleuse();
Return value is an array or array reference depending on calling context.
=item may
Given an argument which is the name or oid of a known object class, returns
the name of the attributes which are optional in the class.
@may = $schema->may( $oc );
Return value is an array or array reference depending on calling context.
=item must
Given an argument which is the name or oid of a known object class, returns
the name of the attributes which are mandatory in the class
@must = $schema->must( $oc );
Return value is an array or array reference depending on calling context.
=item name
Given an argument which is the name or oid of an item,
returns the items canonical name or undef if the name or oid is not known.
If the argument given is a name and there is more than one item in the
schema with that name then undef will be returned.
=item name2oid
Given the name of a schema item (object class, attribute or syntax) returns
the assoicated OID or undef if it is not recognised.
It is possible that two objects, of different types, have the same name.
In this case C<name2oid> will return a list of OIDs in an array context.
In a scalar context it will return undef if there is more than one object
with the given name.
=item nameforms
Returns a list of the names of all nameforms in the schema.
@nfm = $schema->nameforms();
Return value is an array or array reference depending on calling context.
=item objectclasses
Returns a list of the names of all objectclasses in the schema.
@ocs = $schema->objectclasses();
Return value is an array or array reference depending on calling context.
=item parse
Takes a single argument which can be any of, A message objected returned from
an LDAP search, a Net::LDAP::Entry object or the name of a file containing
an LDIF form of the schema.
If the argument is a message result from a search, Net::LDAP::Schema will parse
the schema from the first entry returned.
Returns true on success and C<undef> on error.
=item superclass
Given an argument which is the name or oid of a known objectclass, returns
the list of names of the immediate superclasses.
=item syntax
Given an argument which is the name or oid of a known attribute, returns the
name of the attribute's syntax (or the syntax of the attributes superior
if the syntax is inherited).
$name_syntax = $schema->syntax( "commonName" );
=item syntaxes
Returns a list of the names of all ldapSyntaxes in the schema. (The name of
a syntax is not well defined. It may be an OID or abbreviated description).
@syns = $schema->syntaxes();
Return value is an array or array reference depending on calling context.
=back
=head1 SEE ALSO
L<Net::LDAP>,
L<Net::LDAP::RFC>
=head1 AUTHORS
Graham Barr <gbarr@pobox.com>
John Berthels <jjb@nexor.co.uk>
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap-dev@lists.sourceforge.net>.
=head1 COPYRIGHT
Copyright (c) 1998-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>
I<$Id$>
=cut

174
lib/Net/LDAP/Search.pm Normal file
View file

@ -0,0 +1,174 @@
# Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. 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::Search;
use strict;
use vars qw(@ISA $VERSION);
use Net::LDAP::Message;
use Net::LDAP::Entry;
use Net::LDAP::Filter;
use Net::LDAP::Constant qw(LDAP_SUCCESS LDAP_DECODING_ERROR);
@ISA = qw(Net::LDAP::Message);
$VERSION = "0.07";
sub first_entry { # compat
my $self = shift;
$self->entry(0);
}
sub next_entry { # compat
my $self = shift;
$self->entry( defined $self->{'CurrentEntry'}
? $self->{'CurrentEntry'} + 1
: 0);
}
sub decode {
my $self = shift;
my $result = shift;
return $self->SUPER::decode($result)
if exists $result->{protocolOp}{searchResDone};
my $data;
if ($data = delete $result->{protocolOp}{searchResEntry}) {
my $entry = Net::LDAP::Entry->new;
$entry->decode($data)
or $self->set_error(LDAP_DECODING_ERROR,"LDAP decode error")
and return;
push(@{$self->{entries} ||= []}, $entry);
$self->{callback}->($self,$entry)
if (defined $self->{callback});
return $self;
}
elsif ($data = delete $result->{protocolOp}{searchResRef}) {
push(@{$self->{'reference'} ||= []}, @$data);
$self->{callback}->($self, bless $data, 'Net::LDAP::Reference')
if (defined $self->{callback});
return $self;
}
$self->set_error(LDAP_DECODING_ERROR, "LDAP decode error");
return;
}
sub entry {
my $self = shift;
my $index = shift || 0; # avoid undef warning and default to first entry
my $entries = $self->{entries} ||= [];
my $ldap = $self->parent;
# There could be multiple response to a search request
# but only the last will set {resultCode}
until (exists $self->{resultCode} || (@{$entries} > $index)) {
return
unless $ldap->_recvresp($self->mesg_id) == LDAP_SUCCESS;
}
return
unless (@{$entries} > $index);
$self->{current_entry} = $index; # compat
return $entries->[$index];
}
sub all_entries { goto &entries } # compat
sub count {
my $self = shift;
scalar entries($self);
}
sub shift_entry {
my $self = shift;
entry($self, 0) ? shift @{$self->{entries}} : undef;
}
sub pop_entry {
my $self = shift;
entry($self, 0) ? pop @{$self->{entries}} : undef;
}
sub sorted {
my $self = shift;
$self->sync unless exists $self->{resultCode};
return unless exists $self->{entries} && ref($self->{entries});
return @{$self->{entries}} unless @{$self->{entries}} > 1;
require Net::LDAP::Util;
map { $_->[0] }
sort {
my $v;
my $i = 2;
foreach my $attr (@_) {
$v = ($a->[$i] ||= join("\000", @{$a->[0]->get_value($attr, asref => 1) || []}))
cmp
($b->[$i] ||= join("\000", @{$b->[0]->get_value($attr, asref => 1) || []}))
and last;
$i++;
}
$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}};
}
sub references {
my $self = shift;
$self->sync unless exists $self->{resultCode};
return unless exists $self->{'reference'} && ref($self->{'reference'});
@{$self->{'reference'} || []}
}
sub as_struct {
my $self = shift;
my %result = map { ( $_->dn, ($_->{'attrs'} || $_->_build_attrs) ) } entries($self);
return \%result;
}
sub entries {
my $self = shift;
$self->sync unless exists $self->{resultCode};
@{$self->{entries} || []}
}
package Net::LDAP::Reference;
sub references {
my $self = shift;
@{$self}
}
1;

117
lib/Net/LDAP/Search.pod Normal file
View file

@ -0,0 +1,117 @@
=head1 NAME
Net::LDAP::Search - Object returned by Net::LDAP search method
=head1 SYNOPSIS
use Net::LDAP;
$mesg = $ldap->search( @search_args );
@entries = $mesg->entries;
=head1 DESCRIPTION
A B<Net::LDAP::Search> object is returned from the
L<search|Net::LDAP/item_search> method of a L<Net::LDAP>
object. It is a container object which holds the results of the search.
=head1 METHODS
B<Net::LDAP::Search> inherits from L<Net::LDAP::Message>, and so supports
all methods defined in L<Net::LDAP::Message>.
=over 4
=item as_struct
Returns a reference to a HASH, where the keys are the DN's of the results
and the values are HASH references. These second level HASH's hold the
attributes such that the keys are the attribute names, in lowercase, and
the values are references to and ARRAY holding the values.
This method will block until the whole search request has finished.
=item count
Returns the number of entries returned by the server.
This method will block until the whole search request has finished.
=item entry ( INDEX )
Return the N'th entry, which will be a L<Net::LDAP::Entry> object. If
INDEX is greater than the total number of entries returned then
undef will be returned.
This method will block until the search request has returned enough
entries.
=item entries
Return an array of L<Net::LDAP::Entry> objects hat were returned from the
server.
This method will block until the whole search request has finished.
=item pop_entry
Pop an entry from the internal list of L<Net::LDAP::Entry> objects for this
search. If there are not more entries then undef is returned.
This call will block, if the list is empty, until the server returns
another entry.
=item references
Return a list of references that the server returned. This will be a list
of L<Net::LDAP::Reference> objects.
=item sorted ( [ ATTR_LIST ] )
Return a list of L<Net::LDAP::Entry> objects,
sorted by the attributes given in ATTR_LIST. The attributes are
compared in the order specified, each only being compared if all
the prior attributes compare equal. If all the specified attributes
compare equal then the DN is used to determine order.
=item shift_entry
Shift an entry from the internal list of L<Net::LDAP::Entry> objects for this
search. If there are not more entries then undef is returned.
This call will block, if the list is empty, until the server returns
another entry.
=back
=head1 SEE ALSO
L<Net::LDAP>,
L<Net::LDAP::Message>,
L<Net::LDAP::Entry>,
L<Net::LDAP::Reference>
=head1 ACKNOWLEDGEMENTS
This document is based on a document originally written by Russell Fulton
<r.fulton@auckland.ac.nz>.
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap-dev@lists.sourceforge.net>.
=head1 COPYRIGHT
Copyright (c) 1997-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>
I<$Id$>
=cut

197
lib/Net/LDAP/Security.pod Normal file
View file

@ -0,0 +1,197 @@
=head1 NAME
Net::LDAP::Security - Security issues with LDAP connections
=head1 SYNOPSIS
none
=head1 DESCRIPTION
This document discusses various security issues relating to using LDAP
and connecting to LDAP servers, notably how to manage these potential
vulnerabilities:
=over 4
=item *
do you know that you are connected to the right server
=item *
can someone sniff your passwords/userids from the directory connection
=item *
can someone sniff other confidential information from the directory
connection
=back
B<Net::LDAP> provides ways to address these vulnerabilities: through the
use of LDAPS, or LDAPv3 and TLS, and/or the use of SASL. Each of these
will be explained below.
=head2 How does an LDAP connection work
A normal LDAPv2 or LDAPv3 connection works by the client connecting
directly to port 389 (by default), and then issuing various LDAP
requests like search, add, etc.
There is no way to guarantee that an LDAP client is connected to the
right LDAP server. Hackers could have poisoned your DNS, so
'ldap.example.com' could be made to point to 'ldap.hacker.com'. Or
they could have installed their own server on the correct machine.
It is in the nature of the LDAP protocol that all information goes
between the client and the server in 'plain text'. This is a term used
by cryptographers to describe unencrypted and recoverable data, so
even though LDAP can transfer binary values like JPEG photographs,
audio clips and X.509 certificates, everything is still considered
'plain text'.
If these vulnerabilities are an issue to, then you should consider the
other possibilities described below, namely LDAPS, LDAPv3 and TLS, and
SASL.
=head2 How does an LDAPS connection work
LDAPS is an unofficial protocol. It is to LDAP what HTTPS is to HTTP,
namely the exact same protocol (but in this case LDAPv2 or LDAPv3)
running over a I<secured> SSL ("Secure Socket Layer") connection to
port 636 (by default).
Not all servers will be configured to listen for LDAPS connections,
but if they do, it will commonly be on a different port from the normal
plain text LDAP port.
Using LDAPS can I<potentially> solve the vulnerabilities described
above, but you should be aware that simply "using" SSL is not a magic
bullet that automatically makes your system "secure".
First of all, LDAPS can solve the problem of verifying that you are
connected to the correct server. When the client and server connect,
they perform a special SSL 'handshake', part of which involves the
server and client exchanging cryptographic keys, which are described
using X.509 certificates. If the client wishes to confirm that it is
connected to the correct server, all it needs to do is verify the
server's certificate which is sent in the handshake. This is done in
two ways:
=over 4
=item 1
check that the certificate is signed (trusted) by someone that you
trust, and that the certificate hasn't been revoked. For instance, the
server's certificate may have been signed by Verisign
(www.verisign.com), and you decide that you want to trust Verisign to
sign legitimate certificates.
=item 2
check that the least-significant cn RDN in the server's
certificate's DN is the fully-qualified hostname of the hostname that
you connected to when creating the LDAPS object. For example if the
server is <cn=ldap.example.com,ou=My department,o=My company>, then
the RDN to check is cn=ldap.example.com.
=back
You can do this by using the cafile and capath options when creating a
B<Net::LDAPS> object, I<and> by setting the verify option to 'require'.
To prevent hackers 'sniffing' passwords and other information on your
connection, you also have to make sure the encryption algorithm used
by the SSL connection is good enough. This is also something that gets
decided by the SSL handshake - if the client and server cannot agree
on an acceptable algorithm the connection is not made.
B<Net::LDAPS> will by default use all the algorithms built into your copy
of OpenSSL, except for ones considered to use "low" strength
encryption, and those using export strength encryption. You can
override this when you create the B<Net::LDAPS> object using the
'ciphers' option.
Once you've made the secure connection, you should also check that the
encryption algorithm that is actually being used is one that you find
acceptable. Broken servers have been observed in the field which 'fail
over' and give you an unencrypted connection, so you ought to check
for that.
=head2 How does LDAP and TLS work
SSL is a good solution to many network security problems, but it is
not a standard. The IETF corrected some defects in the SSL mechanism
and published a standard called RFC 2246 which describes TLS
("Transport Layer Security"), which is simply a cleaned up and
standardized version of SSL.
You can only use TLS with an LDAPv3 server. That is because the
standard (RFC 2830) for LDAP and TLS requires that the I<normal> LDAP
connection (ie., on port 389) can be switched on demand from plain text
into a TLS connection. The switching mechanism uses a special extended
LDAP operation, and since these are not legal in LDAPv2, you can only
switch to TLS on an LDAPv3 connection.
So the way you use TLS with LDAPv3 is that you create your normal
LDAPv3 connection using C<Net::LDAP::new()>, and then you perform the
switch using C<Net::LDAP::start_tls()>. The C<start_tls()> method takes
pretty much the same arguments as C<Net::LDAPS::new()>, so check above for
details.
=head2 How does SASL work
SASL is an authentication framework that can be used by a number of
different Internet services, including LDAPv3. Because it is only a
framework, it doesn't provide any way to authenticate by itself; to
actually authenticate to a service you need to use a specific SASL
I<mechanism>. A number of mechanisms are defined, such as CRAM-MD5.
The use of a mechanism like CRAM-MD5 provides a solution to the
password sniffing vulnerability, because these mechanisms typically do
not require the user to send across a secret (eg., a password) in the
clear across the network. Instead, authentication is carried out in a
clever way which avoids this, and so prevents passwords from being
sniffed.
B<Net::LDAP> supports SASL using the B<Authen::SASL> class. Currently the
only B<Authen::SASL> subclasses (ie., SASL mechanism) available are
CRAM-MD5 and EXTERNAL.
Some SASL mechanisms provide a general solution to the sniffing of all
data on the network vulnerability, as they can negotiate confidential
(ie., encrypted) network connections. Note that this is over and above
any SSL or TLS encryption! Unfortunately, perl's B<Authen::SASL> code
cannot negotiate this.
=head1 SEE ALSO
L<Net::LDAP>,
L<Net::LDAPS>,
L<Authen::SASL>
=head1 ACKNOWLEDGEMENTS
Jim Dutton <jimd@dutton3.it.siu.edu> provided lots of useful feedback
on the early drafts.
=head1 AUTHOR
Chris Ridd <chris.ridd@messagingdirect.com>
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap-dev@lists.sourceforge.net>
=head1 COPYRIGHT
Copyright (c) 2001 Chris Ridd. 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

346
lib/Net/LDAP/Util.pm Normal file
View file

@ -0,0 +1,346 @@
# Copyright (c) 1999-2000 Graham Barr <gbarr@pobox.com>. 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;
=head1 NAME
Net::LDAP::Util - Utility functions
=head1 SYNOPSIS
use Net::LDAP::Util qw(ldap_error_text
ldap_error_name
ldap_error_desc
);
$mesg = $ldap->search( .... );
die "Error ",ldap_error_name($mesg->code) if $mesg->code;
=head1 DESCRIPTION
B<Net::LDAP::Util> is a collection of utility functions for use with
the L<Net::LDAP> modules.
=head1 FUNCTIONS
=over 4
=cut
use vars qw($VERSION);
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(
ldap_error_name
ldap_error_text
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
my @err2desc = (
"Success", # 0x00 LDAP_SUCCESS
"Operations error", # 0x01 LDAP_OPERATIONS_ERROR
"Protocol error", # 0x02 LDAP_PROTOCOL_ERROR
"Timelimit exceeded", # 0x03 LDAP_TIMELIMIT_EXCEEDED
"Sizelimit exceeded", # 0x04 LDAP_SIZELIMIT_EXCEEDED
"Compare false", # 0x05 LDAP_COMPARE_FALSE
"Compare true", # 0x06 LDAP_COMPARE_TRUE
"Strong authentication not supported", # 0x07 LDAP_STRONG_AUTH_NOT_SUPPORTED
"Strong authentication required", # 0x08 LDAP_STRONG_AUTH_REQUIRED
"Partial results and referral received", # 0x09 LDAP_PARTIAL_RESULTS
"Referral received", # 0x0a LDAP_REFERRAL
"Admin limit exceeded", # 0x0b LDAP_ADMIN_LIMIT_EXCEEDED
"Critical extension not available", # 0x0c LDAP_UNAVAILABLE_CRITICAL_EXT
"Confidentiality required", # 0x0d LDAP_CONFIDENTIALITY_REQUIRED
"SASL bind in progress", # 0x0e LDAP_SASL_BIND_IN_PROGRESS
undef,
"No such attribute", # 0x10 LDAP_NO_SUCH_ATTRIBUTE
"Undefined attribute type", # 0x11 LDAP_UNDEFINED_TYPE
"Inappropriate matching", # 0x12 LDAP_INAPPROPRIATE_MATCHING
"Constraint violation", # 0x13 LDAP_CONSTRAINT_VIOLATION
"Type or value exists", # 0x14 LDAP_TYPE_OR_VALUE_EXISTS
"Invalid syntax", # 0x15 LDAP_INVALID_SYNTAX
undef,
undef,
undef,
undef,
undef,
undef,
undef,
undef,
undef,
undef,
"No such object", # 0x20 LDAP_NO_SUCH_OBJECT
"Alias problem", # 0x21 LDAP_ALIAS_PROBLEM
"Invalid DN syntax", # 0x22 LDAP_INVALID_DN_SYNTAX
"Object is a leaf", # 0x23 LDAP_IS_LEAF
"Alias dereferencing problem", # 0x24 LDAP_ALIAS_DEREF_PROBLEM
undef,
undef,
undef,
undef,
undef,
undef,
undef,
undef,
undef,
undef,
undef,
"Inappropriate authentication", # 0x30 LDAP_INAPPROPRIATE_AUTH
"Invalid credentials", # 0x31 LDAP_INVALID_CREDENTIALS
"Insufficient access", # 0x32 LDAP_INSUFFICIENT_ACCESS
"DSA is busy", # 0x33 LDAP_BUSY
"DSA is unavailable", # 0x34 LDAP_UNAVAILABLE
"DSA is unwilling to perform", # 0x35 LDAP_UNWILLING_TO_PERFORM
"Loop detected", # 0x36 LDAP_LOOP_DETECT
undef,
undef,
undef,
undef,
undef,
"Sort control missing", # 0x3C LDAP_SORT_CONTROL_MISSING
"Index range error", # 0x3D LDAP_INDEX_RANGE_ERROR
undef,
undef,
"Naming violation", # 0x40 LDAP_NAMING_VIOLATION
"Object class violation", # 0x41 LDAP_OBJECT_CLASS_VIOLATION
"Operation not allowed on nonleaf", # 0x42 LDAP_NOT_ALLOWED_ON_NONLEAF
"Operation not allowed on RDN", # 0x43 LDAP_NOT_ALLOWED_ON_RDN
"Already exists", # 0x44 LDAP_ALREADY_EXISTS
"Cannot modify object class", # 0x45 LDAP_NO_OBJECT_CLASS_MODS
"Results too large", # 0x46 LDAP_RESULTS_TOO_LARGE
"Affects multiple servers", # 0x47 LDAP_AFFECTS_MULTIPLE_DSAS
undef,
undef,
undef,
undef,
undef,
undef,
undef,
undef,
"Unknown error", # 0x50 LDAP_OTHER
"Can't contact LDAP server", # 0x51 LDAP_SERVER_DOWN
"Local error", # 0x52 LDAP_LOCAL_ERROR
"Encoding error", # 0x53 LDAP_ENCODING_ERROR
"Decoding error", # 0x54 LDAP_DECODING_ERROR
"Timed out", # 0x55 LDAP_TIMEOUT
"Unknown authentication method", # 0x56 LDAP_AUTH_UNKNOWN
"Bad search filter", # 0x57 LDAP_FILTER_ERROR
"Canceled", # 0x58 LDAP_USER_CANCELED
"Bad parameter to an ldap routine", # 0x59 LDAP_PARAM_ERROR
"Out of memory", # 0x5a LDAP_NO_MEMORY
"Can't connect to the LDAP server", # 0x5b LDAP_CONNECT_ERROR
"Not supported by this version of the LDAP protocol", # 0x5c LDAP_NOT_SUPPORTED
"Requested LDAP control not found", # 0x5d LDAP_CONTROL_NOT_FOUND
"No results returned", # 0x5e LDAP_NO_RESULTS_RETURNED
"More results to return", # 0x5f LDAP_MORE_RESULTS_TO_RETURN
"Client detected loop", # 0x60 LDAP_CLIENT_LOOP
"Referral hop limit exceeded", # 0x61 LDAP_REFERRAL_LIMIT_EXCEEDED
);
sub ldap_error_desc {
my $code = shift;
$err2desc[$code] || sprintf("LDAP error code %d(0x%02X)",$code,$code);
}
=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
=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 <gbarr@pobox.com>
=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>
I<$Id$>
=cut
1;

219
lib/Net/LDAPS.pm Normal file
View file

@ -0,0 +1,219 @@
# Copyright (c) 2000-2001 Chris Ridd <chris.ridd@messagingdirect.com> and
# Graham Barr <gbarr@pobox.com>. 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::LDAPS;
@Net::LDAPS::ISA = ( 'Net::LDAP' );
$Net::LDAPS::VERSION = "0.03";
use strict;
use Net::LDAP;
use IO::Socket::SSL;
# Different OpenSSL verify modes.
my %verify = qw(none 0 optional 1 require 3);
sub _connect {
my ($ldap, $host, $arg) = @_;
$ldap->{'net_ldap_socket'} = IO::Socket::SSL->new(
PeerAddr => $host,
PeerPort => $arg->{'port'} || '636',
Proto => 'tcp',
Timeout => defined $arg->{'timeout'} ? $arg->{'timeout'} : 120,
SSL_context_init_args($arg)
);
}
sub SSL_context_init_args {
my $arg = shift;
my $verify = 0;
my ($clientcert,$clientkey);
if (exists $arg->{'verify'}) {
my $v = lc $arg->{'verify'};
$verify = 0 + (exists $verify{$v} ? $verify{$v} : $verify);
}
if (exists $arg->{'clientcert'}) {
$clientcert = $arg->{'clientcert'};
if (exists $arg->{'clientkey'}) {
$clientkey = $arg->{'clientkey'};
} else {
require Carp;
Carp::croak("Setting client public key but not client private key");
}
}
(
SSL_cipher_list => defined $arg->{'ciphers'} ? $arg->{'ciphers'} : 'ALL',
SSL_ca_file => exists $arg->{'cafile'} ? $arg->{'cafile'} : '',
SSL_ca_path => exists $arg->{'capath'} ? $arg->{'capath'} : '',
SSL_key_file => $clientcert ? $clientkey : undef,
SSL_use_cert => $clientcert ? 1 : 0,
SSL_cert_file => $clientcert,
SSL_verify_mode => $verify,
SSL_version => defined $arg->{'sslversion'} ? $arg->{'sslversion'} :
'sslv2/3',
);
}
1;
__END__
=head1 NAME
Net::LDAPS - use LDAP over an SSL connection
=head1 SYNOPSIS
use Net::LDAPS;
$ldaps = new Net::LDAPS('myhost.example.com',
port => '10000',
verify => 'require',
capath => '/usr/local/cacerts/');
=head1 DESCRIPTION
Communicate using the LDAP protocol to a directory server using a
potentially encrypted (SSL) network connection.
This class is a subclass of Net::LDAP so all the normal Net::LDAP
methods can be used with a Net::LDAPS object; see the documentation
for Net::LDAP to find out how to query a directory server using the
LDAP protocol.
Note that the use of LDAPS is not recommended, because it is not
described by any IETF documents. Instead, you should consider using
LDAPv3 with the TLS extension defined in RFC 2830. This will give you
the same functionality as LDAPS, but using recognized standards. See
L<Net::LDAP/start_tls>.
=head1 CONSTRUCTOR
=over 4
=item new ( HOST [, OPTIONS ] )
Create a new connection. HOST is the hostname to contact. OPTIONS is a
number of key/value pairs - additional keys to those understood by
Net::LDAP::new are:
=over 4
=item verify
How to verify the server's certificate, either 'none' (the server may
provide a certificate but it will not be checked - this may mean you
are be connected to the wrong server), 'optional' (verify if the
server offers a certificate), or 'require' (the server must provide a
certificate, and it must be valid.) If you set verify to optional or
require, you must also set either cafile or capath. The most secure
option is 'require'.
=item sslversion
This defines the version of the SSL/TLS protocol to use. Defaults to
'sslv2/3', other possible values are 'sslv2', 'sslv3', and 'tlsv1'.
=item ciphers
Specify which subset of cipher suites are permissible for this
connection, using the standard OpenSSL string format. The default
value for ciphers is 'ALL', which permits all ciphers, even those that
don't encrypt!
=item clientcert
=item clientkey
If you want to use the client to offer a certificate to the server for
SSL authentication (which is not the same as for the LDAP Bind
operation) then set clientcert to the user's certificate file, and
clientkey to the user's private key file. These files must be in PEM
format.
=item capath
=item cafile
When verifying the server's certificate, either set capath to the
pathname of the directory containing CA certificates, or set cafile to
the filename containing the certificate of the CA who signed the
server's certificate. These certificates must all be in PEM format.
The directory in 'capath' must contain certificates named using the
hash value of themselves. To generate these names, use OpenSSL like
this in Unix:
ln -s cacert.pem `openssl x509 -hash -noout < cacert.pem`.0
(assuming that the certificate of the CA is in cacert.pem.)
=back
=back
=head1 ADDITIONAL METHODS
=over 4
=item cipher
Returns the cipher mode being used by the connection, in the string
format used by OpenSSL.
=item certificate
Returns an X509_Certificate object containing the server's
certificate. See the IO::Socket::SSL documentation for information
about this class.
For example, to get the subject name (in a peculiar OpenSSL-specific
format, different from RFC 1779 and RFC 2253) from the server's
certificate, do this:
print "Subject DN: " . $ldaps->certificate->subject_name . "\n";
=back
=head1 SEE ALSO
L<Net::LDAP>,
L<IO::Socket::SSL>
=head1 BUGS
Several apparently bogus warnings are emitted when initializing the
two underlying modules used by Net::LDAPS, namely IO::Socket::SSL and
Net::SSLeay. To avoid these, don't initialize via 'use Net::LDAPS' and
instead try initializing Net::LDAPS like this:
BEGIN {
# Turn off all warnings etc whilst initializing
# IO::Socket::SSL and Net::SSLeay.
local $^W = 0;
no strict;
require Net::SSLeay;
# The /dev/urandom is a device on Linux that returns
# random data.
Net::SSLeay::randomize('/dev/urandom');
require Net::LDAPS;
}
=head1 AUTHOR
Chris Ridd <chris.ridd@messagingdirect.com>
=head1 COPYRIGHT
Copyright (c) 2000-2001, Chris Ridd and Graham Barr. All rights reserved. This
library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut