[ Index ] |
PHP Cross Reference of Unnamed Project |
[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;
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |