This file is indexed.

/usr/share/perl5/Net/LDAP/Schema.pm is in libnet-ldap-perl 1:0.5800-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
# Copyright (c) 1998-2004 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;

our $VERSION = '0.9908';

#
# 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;

  @_ ? $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 (eval { $arg->isa('Net::LDAP::Entry') }) {
      $entry = $arg;
    }
    elsif (eval { $arg->isa('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.
}


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')  }

#
# Return must or may attributes for this OC.
#
sub _must_or_may {
  my $self = shift;
  my $must_or_may = pop;
  my @oc = @_ or return;

  #
  # If called with an entry, get the OC names and continue
  #
  if (eval { $oc[0]->isa('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 } = (); 	# Add in, getting uniqueness
    }
    my $sup = $elem->{sup} or next;
    push @oc, @$sup;
  }

  my %unique = map { ($_, $_) } $self->attribute(keys %res);
  values %unique;
}

#
# Given name or oid, return element or undef if not of appropriate type
#

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') }


#
# 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. Each is a hash ref mapping
# lowercase names to the hash stored in the oid structure
#
# ->{at}
# ->{oc}
# ->{syn}
# ->{mr}
# ->{mru}
# ->{dts}
# ->{dtc}
# ->{nfm}
#

#
# These items have no following arguments
#
my %flags = map { ($_, 1) } qw(
			      single-value
			      obsolete
			      collective
			      no-user-modification
			      abstract
			      structural
			      auxiliary
			     );

my %xat_flags = map { ($_, 1) } qw(indexed system-only);

#
# 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 = qw(
	at	attributetypes
        xat     extendedAttributeInfo
	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 hash of names => element

    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)])*)'
                      )\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;

      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 '$';

              # Drop of end of list ?
	      die "Cannot parse [$val] {$tag}"  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] {$tag}";
        }
      }

      #
      # Extract the maximum length of a syntax
      #
      $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
      #
      $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
      #
      if (ref $schema_entry{name}) {
	my $aliases;
	$schema_entry{name} = shift @{$aliases = $schema_entry{name}};
	$schema_entry{aliases} = $aliases  if @$aliases;
      }

      #
      # Store the elements by OID
      #
      $schema->{oid}->{$oid} = \%schema_entry  unless $type eq 'xat';

      #
      # 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;
      }
    }
  }

  # place extendedAttributeInfo into attribute types
  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;
}




#
# Get the syntax of an attribute
#
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};
}

#
# Return base entry
#
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}) {
	# the assumption is that all superiors result in the same ruleset
	return $self->matchingrule_for_attribute(
				 	 $attrtype->{sup}[0],
					 $matchtype);
    }
    return undef;
}

1;