[Summary view] [Print] [Text view]

   1  # Copyright (c) 1998-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
   2  # This program is free software; you can redistribute it and/or
   3  # modify it under the same terms as Perl itself.
   4  
   5  package Net::LDAP::Schema;
   6  
   7  use strict;
   8  use vars qw($VERSION);
   9  
  10  $VERSION = "0.9905";
  11  
  12  #
  13  # Get schema from the server (or read from LDIF) and parse it into
  14  # data structure
  15  #
  16  sub new {
  17    my $self = shift;
  18    my $type = ref($self) || $self;
  19    my $schema = bless {}, $type;
  20  
  21    @_ ? $schema->parse(@_) : $schema;
  22  }
  23  
  24  sub _error {
  25    my $self = shift;
  26    $self->{error} = shift;
  27    return;
  28  }
  29  
  30  
  31  sub parse {
  32    my $schema = shift;
  33    my $arg = shift;
  34  
  35    unless (defined($arg)) {
  36      $schema->_error('Bad argument');
  37      return undef;
  38    }
  39  
  40    %$schema = ();
  41  
  42    my $entry;
  43    if( ref $arg ) {
  44      if (UNIVERSAL::isa($arg, 'Net::LDAP::Entry')) {
  45        $entry = $arg;
  46      }
  47      elsif (UNIVERSAL::isa($arg, 'Net::LDAP::Search')) {
  48        unless ($entry = $arg->entry) {
  49      $schema->_error('Bad Argument');
  50      return undef;
  51        }
  52      }
  53      else {
  54        $schema->_error('Bad Argument');
  55        return undef;
  56      }
  57    }
  58    elsif( -f $arg ) {
  59      require Net::LDAP::LDIF;
  60      my $ldif = Net::LDAP::LDIF->new( $arg, "r" );
  61      $entry = $ldif->read();
  62      unless( $entry ) {
  63        $schema->_error("Cannot parse LDIF from file [$arg]");
  64        return undef;
  65      }
  66    }
  67    else {
  68      $schema->_error("Can't load schema from [$arg]: $!");
  69      return undef;
  70    }
  71  
  72    eval {
  73      local $SIG{__DIE__} = sub {};
  74      _parse_schema( $schema, $entry );
  75    };
  76  
  77    if ($@) {
  78      $schema->_error($@);
  79      return undef;
  80    }
  81  
  82    return $schema;
  83  }
  84  
  85  #
  86  # Dump as LDIF
  87  #
  88  # XXX - We should really dump from the internal structure. That way we can
  89  #       have methods to modify the schema and write a new one -- GMB
  90  sub dump {
  91    my $self = shift;
  92    my $fh = @_ ? shift : \*STDOUT;
  93    my $entry = $self->{'entry'} or return;
  94    require Net::LDAP::LDIF;
  95    Net::LDAP::LDIF->new($fh,"w", wrap => 0)->write($entry);
  96    1;
  97  }
  98  
  99  #
 100  # Given another Net::LDAP::Schema, merge the contents together.
 101  # XXX - todo
 102  #
 103  sub merge {
 104    my $self = shift;
 105    my $new = shift;
 106  
 107    # Go through structure of 'new', copying code to $self. Take some
 108    # parameters describing what to do in the event of a clash.
 109  }
 110  
 111  
 112  sub all_attributes        { values %{shift->{at}}  }
 113  sub all_objectclasses        { values %{shift->{oc}}  }
 114  sub all_syntaxes        { values %{shift->{syn}} }
 115  sub all_matchingrules        { values %{shift->{mr}}  }
 116  sub all_matchingruleuses    { values %{shift->{mru}} }
 117  sub all_ditstructurerules    { values %{shift->{dts}} }
 118  sub all_ditcontentrules        { values %{shift->{dtc}} }
 119  sub all_nameforms        { values %{shift->{nfm}} }
 120  
 121  sub superclass {
 122    my $self = shift;
 123    my $oc = shift;
 124  
 125    my $elem = $self->objectclass( $oc )
 126      or return scalar _error($self, "Not an objectClass");
 127  
 128    return @{$elem->{sup} || []};
 129  }
 130  
 131  sub must { _must_or_may(@_,'must') }
 132  sub may  { _must_or_may(@_,'may')  }
 133  
 134  #
 135  # Return must or may attributes for this OC.
 136  #
 137  sub _must_or_may {
 138    my $self = shift;
 139    my $must_or_may = pop;
 140    my @oc = @_ or return;
 141  
 142    #
 143    # If called with an entry, get the OC names and continue
 144    #
 145    if ( ref($oc[0]) && UNIVERSAL::isa( $oc[0], "Net::LDAP::Entry" ) ) {
 146      my $entry = $oc[0];
 147      @oc = $entry->get_value( "objectclass" )
 148        or return;
 149    }
 150  
 151    my %res;
 152    my %done;
 153  
 154    while (@oc) {
 155      my $oc = shift @oc;
 156  
 157      $done{lc $oc}++ and next;
 158  
 159      my $elem = $self->objectclass( $oc ) or next;
 160      if (my $res  = $elem->{$must_or_may}) {
 161      @res{ @$res } = ();     # Add in, getting uniqueness
 162      }
 163      my $sup = $elem->{sup} or next;
 164      push @oc, @$sup;
 165    }
 166  
 167    my %unique = map { ($_,$_) } $self->attribute(keys %res);
 168    values %unique;
 169  }
 170  
 171  #
 172  # Given name or oid, return element or undef if not of appropriate type
 173  #
 174  
 175  sub _get {
 176    my $self = shift;
 177    my $type = pop(@_);
 178    my $hash = $self->{$type};
 179    my $oid  = $self->{oid};
 180  
 181    my @elem = grep $_, map {
 182      my $elem = $hash->{lc $_};
 183  
 184      ($elem or ($elem = $oid->{$_} and $elem->{type} eq $type))
 185        ? $elem
 186        : undef;
 187    } @_;
 188  
 189    wantarray ? @elem : $elem[0];
 190  }
 191  
 192  sub attribute        { _get(@_,'at')  }
 193  sub objectclass        { _get(@_,'oc')  }
 194  sub syntax        { _get(@_,'syn') }
 195  sub matchingrule    { _get(@_,'mr')  }
 196  sub matchingruleuse    { _get(@_,'mru') }
 197  sub ditstructurerule    { _get(@_,'dts') }
 198  sub ditcontentrule    { _get(@_,'dtc') }
 199  sub nameform        { _get(@_,'nfm') }
 200  
 201  
 202  #
 203  # XXX - TODO - move long comments to POD and write up interface
 204  #
 205  # Data structure is:
 206  #
 207  # $schema (hash ref)
 208  #
 209  # The {oid} piece here is a little redundant since we control the other
 210  # top-level members. We promote the first listed name to be 'canonical' and
 211  # also make up a name for syntaxes (from the description). Thus we always
 212  # have a unique name. This avoids a lot of checking in the access routines.
 213  #
 214  # ->{oid}->{$oid}->{
 215  #            name    => $canonical_name, (created for syn)
 216  #            aliases    => list of non. canon names
 217  #            type    => at/oc/syn
 218  #            desc    => description
 219  #            must    => list of can. names of mand. atts [if OC]
 220  #            may    => list of can. names of opt. atts [if OC]
 221  #            syntax    => can. name of syntax [if AT]
 222  #            ... etc per oid details
 223  #
 224  # These next items are optimisations, to avoid always searching the OID
 225  # lists. Could be removed in theory. Each is a hash ref mapping
 226  # lowercase names to the hash stored in the oid struucture
 227  #
 228  # ->{at}
 229  # ->{oc}
 230  # ->{syn}
 231  # ->{mr}
 232  # ->{mru}
 233  # ->{dts}
 234  # ->{dtc}
 235  # ->{nfm}
 236  #
 237  
 238  #
 239  # These items have no following arguments
 240  #
 241  my %flags = map { ($_,1) } qw(
 242                    single-value
 243                    obsolete
 244                    collective
 245                    no-user-modification
 246                    abstract
 247                    structural
 248                    auxiliary
 249                   );
 250  
 251  my %xat_flags = map { ($_,1) } qw(indexed system-only);
 252  
 253  #
 254  # These items can have lists arguments
 255  # (name can too, but we treat it special)
 256  #
 257  my %listops = map { ($_,1) } qw(must may sup);
 258  
 259  #
 260  # Map schema attribute names to internal names
 261  #
 262  my %type2attr = qw(
 263      at    attributetypes
 264          xat     extendedAttributeInfo
 265      oc    objectclasses
 266      syn    ldapsyntaxes
 267      mr    matchingrules
 268      mru    matchingruleuse
 269      dts    ditstructurerules
 270      dtc    ditcontentrules
 271      nfm    nameforms
 272  );
 273  
 274  #
 275  # Return ref to hash containing schema data - undef on failure
 276  #
 277  
 278  sub _parse_schema {
 279    my $schema = shift;
 280    my $entry = shift;
 281  
 282    return undef unless defined($entry);
 283  
 284    keys %type2attr; # reset iterator
 285    while(my($type,$attr) = each %type2attr) {
 286      my $vals = $entry->get_value($attr, asref => 1);
 287  
 288      my %names;
 289      $schema->{$type} = \%names;        # Save reference to hash of names => element
 290  
 291      next unless $vals;            # Just leave empty ref if nothing
 292  
 293      foreach my $val (@$vals) {
 294        #
 295        # The following statement takes care of defined attributes
 296        # that have no data associated with them.
 297        #
 298        next if $val eq '';
 299  
 300        #
 301        # We assume that each value can be turned into an OID, a canonical
 302        # name and a 'schema_entry' which is a hash ref containing the items
 303        # present in the value.
 304        #
 305        my %schema_entry = ( type => $type, aliases => [] );
 306  
 307        my @tokens;
 308        pos($val) = 0;
 309  
 310        push @tokens, $+
 311          while $val =~ /\G\s*(?:
 312                         ([()])
 313                        |
 314                         ([^"'\s()]+)
 315                        |
 316                         "([^"]*)"
 317                        |
 318                         '((?:[^']+|'[^\s)])*)'
 319                        )\s*/xcg;
 320        die "Cannot parse [$val] [",substr($val,pos($val)),"]" unless @tokens and pos($val) == length($val);
 321  
 322        # remove () from start/end
 323        shift @tokens if $tokens[0]  eq '(';
 324        pop   @tokens if $tokens[-1] eq ')';
 325  
 326        # The first token is the OID
 327        my $oid = $schema_entry{oid} = shift @tokens;
 328  
 329        my $flags = ($type eq 'xat') ? \%xat_flags : \%flags;
 330        while(@tokens) {
 331      my $tag = lc shift @tokens;
 332  
 333      if (exists $flags->{$tag}) {
 334        $schema_entry{$tag} = 1;
 335      }
 336      elsif (@tokens) {
 337        if (($schema_entry{$tag} = shift @tokens) eq '(') {
 338          my @arr;
 339          $schema_entry{$tag} = \@arr;
 340          while(1) {
 341            my $tmp = shift @tokens;
 342            last if $tmp eq ')';
 343            push @arr,$tmp unless $tmp eq '$';
 344  
 345                # Drop of end of list ?
 346            die "Cannot parse [$val] {$tag}" unless @tokens;
 347          }
 348        }
 349  
 350            # Ensure items that can be lists are stored as array refs
 351        $schema_entry{$tag} = [ $schema_entry{$tag} ]
 352          if exists $listops{$tag} and !ref $schema_entry{$tag};
 353      }
 354          else {
 355            die "Cannot parse [$val] {$tag}";
 356          }
 357        }
 358  
 359        #
 360        # Extract the maximum length of a syntax
 361        #
 362        $schema_entry{max_length} = $1
 363      if exists $schema_entry{syntax} and $schema_entry{syntax} =~ s/{(\d+)}//;
 364  
 365        #
 366        # Force a name if we don't have one
 367        #
 368        $schema_entry{name} = $schema_entry{oid}
 369      unless exists $schema_entry{name};
 370  
 371        #
 372        # If we have multiple names, make the name be the first and demote the rest to aliases
 373        #
 374        if (ref $schema_entry{name}) {
 375      my $aliases;
 376      $schema_entry{name} = shift @{$aliases = $schema_entry{name}};
 377      $schema_entry{aliases} = $aliases if @$aliases;
 378        }
 379  
 380        #
 381        # Store the elements by OID
 382        #
 383        $schema->{oid}->{$oid} = \%schema_entry unless $type eq 'xat';
 384  
 385        #
 386        # We also index elements by name within each type
 387        #
 388        foreach my $name ( @{$schema_entry{aliases}}, $schema_entry{name} ) {
 389      my $lc_name = lc $name;
 390      $names{lc $name} =  \%schema_entry;
 391        }
 392      }
 393    }
 394  
 395    # place extendedAttributeInfo into attribute types
 396    if (my $xat = $schema->{xat}) {
 397      foreach my $xat_ref (values %$xat) {
 398        my $oid = $schema->{oid}{$xat_ref->{oid}} ||= {};
 399        while (my($k,$v) = each %$xat_ref) {
 400          $oid->{"x-$k"} = $v unless $k =~ /^(oid|type|name|aliases)$/;
 401        }
 402      }
 403    }
 404  
 405    $schema->{entry} = $entry;
 406    return $schema;
 407  }
 408  
 409  
 410  
 411  
 412  #
 413  # Get the syntax of an attribute
 414  #
 415  sub attribute_syntax {
 416      my $self = shift;
 417      my $attr = shift;
 418      my $syntax;
 419  
 420      while ($attr) {
 421      my $elem = $self->attribute( $attr ) or return undef;
 422  
 423      $syntax = $elem->{syntax} and return $self->syntax($syntax);
 424  
 425      $attr = ${$elem->{sup} || []}[0];
 426      }
 427  
 428      return undef;
 429  }
 430  
 431  
 432  sub error {
 433      $_[0]->{error};
 434  }
 435  
 436  #
 437  # Return base entry
 438  #
 439  sub entry {
 440      $_[0]->{entry};
 441  }
 442  
 443  sub matchingrule_for_attribute {
 444      my $self = shift;
 445      my $attr = shift;
 446      my $matchtype = shift;
 447  
 448      my $attrtype = $self->attribute( $attr );
 449      if (exists $attrtype->{$matchtype}) {
 450      return $attrtype->{$matchtype};
 451      } elsif (exists $attrtype->{'sup'}) {
 452      # the assumption is that all superiors result in the same ruleset
 453      return $self->matchingrule_for_attribute(
 454                        $attrtype->{'sup'}[0],
 455                       $matchtype);
 456      }
 457      return undef;
 458  }
 459  
 460  1;