Menu
▾
▴
[perl-ldap-checkins] CVS: ldap/lib/Net/LDAP Schema.pm,1.13,1.14 Schema.pod,1.10,1.11
|
From: Graham B. <gb...@us...> - 2002-04-23 10:57:33
|
Update of /cvsroot/perl-ldap/ldap/lib/Net/LDAP
In directory usw-pr-cvs1:/tmp/cvs-serv1015/lib/Net/LDAP
Modified Files:
Schema.pm Schema.pod
Log Message:
New Schema API
Index: Schema.pm
===================================================================
RCS file: /cvsroot/perl-ldap/ldap/lib/Net/LDAP/Schema.pm,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- Schema.pm 23 Jan 2002 13:25:30 -0000 1.13
+++ Schema.pm 23 Apr 2002 10:57:29 -0000 1.14
@@ -1,4 +1,4 @@
-# Copyright (c) 1998-2000 Graham Barr <gb...@po...>. All rights reserved.
+# Copyright (c) 1998-2002 Graham Barr <gb...@po...>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
@@ -7,10 +7,10 @@
use strict;
use vars qw($VERSION);
-$VERSION = "0.12";
+$VERSION = "0.99";
#
-# Get schema from the server (or read from LDIF) and parse it into
+# Get schema from the server (or read from LDIF) and parse it into
# data structure
#
sub new {
@@ -37,7 +37,7 @@
$schema->{error} = "Bad argument";
return undef;
}
-
+
%$schema = ();
my $entry;
@@ -69,7 +69,7 @@
$schema->{error} = "Can't load schema from [$arg]: $!";
return undef;
}
-
+
eval {
local $SIG{__DIE__} = sub {};
_parse_schema( $schema, $entry );
@@ -109,271 +109,93 @@
# 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 all_attributes { values %{shift->{at}} }
+sub all_objectclasses { values %{shift->{oc}} }
+sub all_syntaxes { values %{shift->{syn}} }
+sub all_matchingrules { values %{shift->{mr}} }
+sub all_matchingruleuses { values %{shift->{mru}} }
+sub all_ditstructurerules { values %{shift->{dts}} }
+sub all_ditcontentrules { values %{shift->{dtc}} }
+sub all_nameforms { values %{shift->{nfm}} }
sub superclass {
- my $self = shift;
- my $oc = shift;
-
- my $oid = $self->is_objectclass( $oc );
- return scalar _error($self, "Not an objectClass") unless $oid;
+ my $self = shift;
+ my $oc = shift;
- my $res = $self->{oid}->{$oid}->{sup};
- return scalar _error($self, "No superclass") unless $res;
- return wantarray ? @$res : $res;
-}
+ my $elem = $self->objectclass( $oc )
+ or return scalar _error($self, "Not an objectClass");
-sub must {
- my $self = shift;
- $self->_must_or_may( "must", @_ );
+ return @{$elem->{sup} || []};
}
-sub may {
- my $self = shift;
- $self->_must_or_may( "may", @_ );
-}
+sub must { _must_or_may(@_,'must') }
+sub may { _must_or_may(@_,'may') }
#
-# Return must or may attributes for this OC. [As array or array ref]
-# return empty array/undef on error
+# Return must or may attributes for this OC.
#
sub _must_or_may {
my $self = shift;
- my $must_or_may = shift;
+ my $must_or_may = pop;
my @oc = @_ or return;
-
+
#
# If called with an entry, get the OC names and continue
#
- if( UNIVERSAL::isa( $oc[0], "Net::LDAP::Entry" ) ) {
+ 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 %res;
+ my %done;
- my $item_ref = $self->{oid}->{$oid[0]} or return _error($self, "Unknown OID");
+ while (@oc) {
+ my $oc = shift @oc;
- my $value = defined($item_name) ? $item_ref->{lc $item_name} : $item_ref
- or return _error($self, "No such property");
- delete $self->{error};
+ $done{lc $oc}++ and next;
- if( ref $value eq "ARRAY" && wantarray ) {
- return @$value;
- }
- else {
- return $value;
+ my $elem = $self->objectclass( $oc ) or next;
+ my $res = $elem->{$must_or_may} or next;
+ @res{ @$res } = (); # Add in, getting uniqueness
+ my $sup = $elem->{sup} or next;
+ push @oc, @$sup;
}
-}
-
-#
-# 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};
+ my %unique = map { ($_,$_) } $self->attribute(keys %res);
+ values %unique;
}
#
-# Given name or oid, return oid or undef if not of appropriate type
+# Given name or oid, return element 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 {
+sub _get {
my $self = shift;
- return $self->_is_type( "mru", @_ );
-}
+ my $type = $self->{ pop(@_) };
+ my $oid = $self->{oid};
-sub is_ditstructurerule {
- my $self = shift;
- return $self->_is_type( "dts", @_ );
-}
+ my @elem = grep $_, map {
+ my $elem = $type->{lc $_};
-sub is_ditcontentrule {
- my $self = shift;
- return $self->_is_type( "dtc", @_ );
-}
+ ($elem or ($elem = $oid->{$_} and $elem->{type} eq $type))
+ ? $elem
+ : undef;
+ } @_;
-sub is_nameform {
- my $self = shift;
- return $self->_is_type( "nfm", @_ );
+ wantarray ? @elem : $elem[0];
}
-# --------------------------------------------------
-# 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;
-}
+sub attribute { _get(@_,'at') }
+sub objectclass { _get(@_,'oc') }
+sub syntax { _get(@_,'syn') }
+sub matchingrule { _get(@_,'mr') }
+sub matchingruleuse { _get(@_,'mru') }
+sub ditstructurerule { _get(@_,'dts') }
+sub ditcontentrule { _get(@_,'dtc') }
+sub nameform { _get(@_,'nfm') }
#
@@ -399,22 +221,17 @@
# ... 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.
+# lists. Could be removed in theory. Each is a hash ref mapping
+# lowercase names to the hash stored in the oid struucture
#
-# ->{name}->{ $lower_case_name } = $oid
+# ->{at}
+# ->{oc}
+# ->{syn}
+# ->{mr}
+# ->{mru}
+# ->{dts}
+# ->{dtc}
+# ->{nfm}
#
#
@@ -439,15 +256,16 @@
#
# 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",
- );
+my %type2attr = qw(
+ 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
@@ -456,15 +274,15 @@
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
+ my %names;
+ $schema->{$type} = \%names; # Save reference to hash of names => element
next unless $vals; # Just leave empty ref if nothing
@@ -495,7 +313,7 @@
|
'((?:[^']+|'[^\s)])*)'
)\s*/xcg;
- die "Cannot parse [$val] ",substr($val,pos($val)) unless @tokens and pos($val) == length($val);
+ 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 '(';
@@ -520,7 +338,7 @@
push @arr,$tmp unless $tmp eq '$';
# Drop of end of list ?
- die "Cannot parse [$val]" unless @tokens;
+ die "Cannot parse [$val] {$tag}" unless @tokens;
}
}
@@ -529,50 +347,42 @@
if exists $listops{$tag} and !ref $schema_entry{$tag};
}
else {
- die "Cannot parse [$val]";
+ die "Cannot parse [$val] {$tag}";
}
}
#
# Extract the maximum length of a syntax
#
- if ( exists $schema_entry{syntax}) {
- $schema_entry{syntax} =~ s/{(\d+)}//
- and $schema_entry{max_length} = $1;
- }
+ $schema_entry{max_length} = $1
+ if exists $schema_entry{syntax} and $schema_entry{syntax} =~ s/{(\d+)}//;
#
# Force a name if we don't have one
#
- if (!exists $schema_entry{name}) {
- $schema_entry{name} = $schema_entry{oid};
- }
+ $schema_entry{name} = $schema_entry{oid}
+ unless exists $schema_entry{name};
#
# If we have multiple names, make the name be the first and demote the rest to aliases
#
- $schema_entry{name} = shift @{$schema_entry{aliases} = $schema_entry{name}}
- if ref $schema_entry{name};
+ if (ref $schema_entry{name}) {
+ my $aliases;
+ $schema_entry{name} = shift @{$aliases = $schema_entry{name}};
+ $schema_entry{aliases} = $aliases if @$aliases;
+ }
#
- # 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
+ # Store the elements by OID
#
$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;
- }
+
+ #
+ # We also index elements by name within each type
+ #
+ foreach my $name ( @{$schema_entry{aliases}}, $schema_entry{name} ) {
+ my $lc_name = lc $name;
+ $names{lc $name} = \%schema_entry;
}
}
}
@@ -587,31 +397,22 @@
#
# Get the syntax of an attribute
#
-sub syntax {
+sub attribute_syntax {
my $self = shift;
my $attr = shift;
+ my $syntax;
- my $oid = $self->is_attribute( $attr ) or return undef;
+ while ($attr) {
+ my $elem = $self->attribute( $attr ) or return undef;
- my $syntax = $self->{oid}->{$oid}->{syntax};
- unless( $syntax ) {
- my @sup = @{$self->{oid}->{$oid}->{sup}};
- $syntax = $self->syntax( $sup[0] );
+ $syntax = $elem->{syntax} and return $self->syntax($syntax);
+
+ $attr = ${$elem->{sup} || []}[0];
}
- return $syntax;
+ return undef
}
-#
-# 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};
Index: Schema.pod
===================================================================
RCS file: /cvsroot/perl-ldap/ldap/lib/Net/LDAP/Schema.pod,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- Schema.pod 24 Aug 2001 19:31:14 -0000 1.10
+++ Schema.pod 23 Apr 2002 10:57:29 -0000 1.11
@@ -34,38 +34,50 @@
=over 4
-=item attributes
+=item all_attributes
-With no arguments, returns a list of the names all attributes in the schema.
+=item all_ditcontentrules
- @atts = $schema->attributes();
+=item all_ditstructurerules
-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.
+=item all_matchingrules
- @person_atts = $schema->attributes( "person" );
+=item all_matchingruleuses
-Return value is an array or array reference depending on calling context, or
-empty list on error.
+=item all_nameforms
-=item ditstructurerules
+=item all_objectclasses
-Returns a list of the names of all ditstructurerules in the schema.
+=item all_syntaxes
- @dts = $schema->ditstructurerules();
+Returns a list of the names all the requested type in the schema
-Return value is an array or array reference depending on calling context.
+ @attrs = $schema->all_attributes();
-=item ditcontentrules
+=item attribute NAME_OR_OID
-Returns a list of the names of all ditcontentrules in the schema.
+=item ditcontentrule NAME_OR_OID
- @dtc = $schema->ditcontentrules();
+=item ditstructurerule NAME_OR_OID
-Return value is an array or array reference depending on calling context.
+=item matchingrule NAME_OR_OID
+
+=item matchingruleuse NAME_OR_OID
+
+=item nameform NAME_OR_OID
+
+=item objectclass NAME_OR_OID
+
+=item syntax NAME_OR_OID
+
+Returns a reference to a hash, or undef if the attribute does not exist.
+
+ $attr_href = $schema->attribute( "attrname" );
=item dump
+=item dump FILENAME
+
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
@@ -84,127 +96,29 @@
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.
+the names 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
+the names 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();
+=item parse MESG
-Return value is an array or array reference depending on calling context.
+=item parse ENTRY
-=item parse
+=item parse FILENAME
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
@@ -219,23 +133,6 @@
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
|
