package Net::LDAP::Schema;
use strict;
use vars qw($VERSION);
$VERSION = "0.9905";
sub new {
my $self = shift;
my $type = ref($self) || $self;
my $schema = bless {}, $type;
@_ ? $schema->parse(@_) : $schema;
}
sub _error {
my $self = shift;
$self->{error} = shift;
return;
}
sub parse {
my $schema = shift;
my $arg = shift;
unless (defined($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;
}
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;
}
sub merge {
my $self = shift;
my $new = shift;
}
sub all_attributes { values %{shift->{at}} }
sub all_objectclasses { values %{shift->{oc}} }
sub all_syntaxes { values %{shift->{syn}} }
sub all_matchingrules { values %{shift->{mr}} }
sub all_matchingruleuses { values %{shift->{mru}} }
sub all_ditstructurerules { values %{shift->{dts}} }
sub all_ditcontentrules { values %{shift->{dtc}} }
sub all_nameforms { values %{shift->{nfm}} }
sub superclass {
my $self = shift;
my $oc = shift;
my $elem = $self->objectclass( $oc )
or return scalar _error($self, "Not an objectClass");
return @{$elem->{sup} || []};
}
sub must { _must_or_may(@_,'must') }
sub may { _must_or_may(@_,'may') }
sub _must_or_may {
my $self = shift;
my $must_or_may = pop;
my @oc = @_ or return;
if ( ref($oc[0]) && UNIVERSAL::isa( $oc[0], "Net::LDAP::Entry" ) ) {
my $entry = $oc[0];
@oc = $entry->get_value( "objectclass" )
or return;
}
my %res;
my %done;
while (@oc) {
my $oc = shift @oc;
$done{lc $oc}++ and next;
my $elem = $self->objectclass( $oc ) or next;
if (my $res = $elem->{$must_or_may}) {
@res{ @$res } = (); }
my $sup = $elem->{sup} or next;
push @oc, @$sup;
}
my %unique = map { ($_,$_) } $self->attribute(keys %res);
values %unique;
}
sub _get {
my $self = shift;
my $type = pop(@_);
my $hash = $self->{$type};
my $oid = $self->{oid};
my @elem = grep $_, map {
my $elem = $hash->{lc $_};
($elem or ($elem = $oid->{$_} and $elem->{type} eq $type))
? $elem
: undef;
} @_;
wantarray ? @elem : $elem[0];
}
sub attribute { _get(@_,'at') }
sub objectclass { _get(@_,'oc') }
sub syntax { _get(@_,'syn') }
sub matchingrule { _get(@_,'mr') }
sub matchingruleuse { _get(@_,'mru') }
sub ditstructurerule { _get(@_,'dts') }
sub ditcontentrule { _get(@_,'dtc') }
sub nameform { _get(@_,'nfm') }
my %flags = map { ($_,1) } qw(
single-value
obsolete
collective
no-user-modification
abstract
structural
auxiliary
);
my %xat_flags = map { ($_,1) } qw(indexed system-only);
my %listops = map { ($_,1) } qw(must may sup);
my %type2attr = qw(
at attributetypes
xat extendedAttributeInfo
oc objectclasses
syn ldapsyntaxes
mr matchingrules
mru matchingruleuse
dts ditstructurerules
dtc ditcontentrules
nfm nameforms
);
sub _parse_schema {
my $schema = shift;
my $entry = shift;
return undef unless defined($entry);
keys %type2attr; while(my($type,$attr) = each %type2attr) {
my $vals = $entry->get_value($attr, asref => 1);
my %names;
$schema->{$type} = \%names;
next unless $vals;
foreach my $val (@$vals) {
next if $val eq '';
my %schema_entry = ( type => $type, aliases => [] );
my @tokens;
pos($val) = 0;
push @tokens, $+
while $val =~ /\G\s*(?:
([()])
|
([^"'\s()]+)
|
"([^"]*)"
|
'((?:[^']+|'[^\s)])*)'
)\s*/xcg;
die "Cannot parse [$val] [",substr($val,pos($val)),"]" unless @tokens and pos($val) == length($val);
shift @tokens if $tokens[0] eq '(';
pop @tokens if $tokens[-1] eq ')';
my $oid = $schema_entry{oid} = shift @tokens;
my $flags = ($type eq 'xat') ? \%xat_flags : \%flags;
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 '$';
die "Cannot parse [$val] {$tag}" unless @tokens;
}
}
$schema_entry{$tag} = [ $schema_entry{$tag} ]
if exists $listops{$tag} and !ref $schema_entry{$tag};
}
else {
die "Cannot parse [$val] {$tag}";
}
}
$schema_entry{max_length} = $1
if exists $schema_entry{syntax} and $schema_entry{syntax} =~ s/{(\d+)}//;
$schema_entry{name} = $schema_entry{oid}
unless exists $schema_entry{name};
if (ref $schema_entry{name}) {
my $aliases;
$schema_entry{name} = shift @{$aliases = $schema_entry{name}};
$schema_entry{aliases} = $aliases if @$aliases;
}
$schema->{oid}->{$oid} = \%schema_entry unless $type eq 'xat';
foreach my $name ( @{$schema_entry{aliases}}, $schema_entry{name} ) {
my $lc_name = lc $name;
$names{lc $name} = \%schema_entry;
}
}
}
if (my $xat = $schema->{xat}) {
foreach my $xat_ref (values %$xat) {
my $oid = $schema->{oid}{$xat_ref->{oid}} ||= {};
while (my($k,$v) = each %$xat_ref) {
$oid->{"x-$k"} = $v unless $k =~ /^(oid|type|name|aliases)$/;
}
}
}
$schema->{entry} = $entry;
return $schema;
}
sub attribute_syntax {
my $self = shift;
my $attr = shift;
my $syntax;
while ($attr) {
my $elem = $self->attribute( $attr ) or return undef;
$syntax = $elem->{syntax} and return $self->syntax($syntax);
$attr = ${$elem->{sup} || []}[0];
}
return undef;
}
sub error {
$_[0]->{error};
}
sub entry {
$_[0]->{entry};
}
sub matchingrule_for_attribute {
my $self = shift;
my $attr = shift;
my $matchtype = shift;
my $attrtype = $self->attribute( $attr );
if (exists $attrtype->{$matchtype}) {
return $attrtype->{$matchtype};
} elsif (exists $attrtype->{'sup'}) {
return $self->matchingrule_for_attribute(
$attrtype->{'sup'}[0],
$matchtype);
}
return undef;
}
1;