external/bsd/openldap/dist/servers/slapd/back-perl/SampleLDAP.pm

   1 # This is a sample Perl module for the OpenLDAP server slapd.
   2 # $OpenLDAP: pkg/ldap/servers/slapd/back-perl/SampleLDAP.pm,v 1.10.2.3 2008/02/11 23:26:47 kurt Exp $
   3 ## This work is part of OpenLDAP Software <http://www.openldap.org/>.
   4 ##
   5 ## Copyright 1998-2008 The OpenLDAP Foundation.
   6 ## Portions Copyright 1999 John C. Quillan.
   7 ## All rights reserved.
   8 ##
   9 ## Redistribution and use in source and binary forms, with or without
  10 ## modification, are permitted only as authorized by the OpenLDAP
  11 ## Public License.
  12 ##
  13 ## A copy of this license is available in the file LICENSE in the
  14 ## top-level directory of the distribution or, alternatively, at
  15 ## <http://www.OpenLDAP.org/license.html>.
  16 #
  17 # Usage: Add something like this to slapd.conf:
  18 #
  19 #       database        perl
  20 #       suffix          "o=AnyOrg,c=US"
  21 #       perlModulePath  /directory/containing/this/module
  22 #       perlModule      SampleLDAP
  23 #
  24 # See the slapd-perl(5) manual page for details.
  25
  26 package SampleLDAP;
  27 use strict;
  28 use warnings;
  29 use POSIX;
  30
  31 $SampleLDAP::VERSION = '1.01';
  32
  33 sub new {
  34     my $class = shift;
  35
  36     my $this = {};
  37     bless $this, $class;
  38     print {*STDERR} "Here in new\n";
  39     print {*STDERR} 'Posix Var ' . BUFSIZ . ' and ' . FILENAME_MAX . "\n";
  40     return $this;
  41 }
  42
  43 sub init {
  44     return 0;
  45 }
  46
  47 sub search {
  48     my $this = shift;
  49     my ( $base, $scope, $deref, $sizeLim, $timeLim, $filterStr, $attrOnly,
  50         @attrs )
  51       = @_;
  52     print {*STDERR}, "====$filterStr====\n";
  53     $filterStr =~ s/\(|\)//gm;
  54     $filterStr =~ s/=/: /m;
  55
  56     my @match_dn = ();
  57     for my $dn ( keys %{$this} ) {
  58         if ( $this->{$dn} =~ /$filterStr/imx ) {
  59             push @match_dn, $dn;
  60             last if ( scalar @match_dn == $sizeLim );
  61
  62         }
  63     }
  64
  65     my @match_entries = ();
  66
  67     for my $dn (@match_dn) {
  68         push @match_entries, $this->{$dn};
  69     }
  70
  71     return ( 0, @match_entries );
  72
  73 }
  74
  75 sub compare {
  76     my $this = shift;
  77     my ( $dn, $avaStr ) = @_;
  78     my $rc = 5;    # LDAP_COMPARE_FALSE
  79
  80     $avaStr =~ s/=/: /m;
  81
  82     if ( $this->{$dn} =~ /$avaStr/im ) {
  83         $rc = 6;    # LDAP_COMPARE_TRUE
  84     }
  85
  86     return $rc;
  87 }
  88
  89 sub modify {
  90     my $this = shift;
  91
  92     my ( $dn, @list ) = @_;
  93
  94     while ( @list > 0 ) {
  95         my $action = shift @list;
  96         my $key    = shift @list;
  97         my $value  = shift @list;
  98
  99         if ( $action eq 'ADD' ) {
 100             $this->{$dn} .= "$key: $value\n";
 101
 102         }
 103         elsif ( $action eq 'DELETE' ) {
 104             $this->{$dn} =~ s/^$key:\s*$value\n//im;
 105
 106         }
 107         elsif ( $action eq 'REPLACE' ) {
 108             $this->{$dn} =~ s/$key: .*$/$key: $value/im;
 109         }
 110     }
 111
 112     return 0;
 113 }
 114
 115 sub add {
 116     my $this = shift;
 117
 118     my ($entryStr) = @_;
 119
 120     my ($dn) = ( $entryStr =~ /dn:\s(.*)$/m );
 121
 122     #
 123     # This needs to be here until a normalized dn is
 124     # passed to this routine.
 125     #
 126     $dn = uc $dn;
 127     $dn =~ s/\s*//gm;
 128
 129     $this->{$dn} = $entryStr;
 130
 131     return 0;
 132 }
 133
 134 sub modrdn {
 135     my $this = shift;
 136
 137     my ( $dn, $newdn, $delFlag ) = @_;
 138
 139     $this->{$newdn} = $this->{$dn};
 140
 141     if ($delFlag) {
 142         delete $this->{$dn};
 143     }
 144     return 0;
 145
 146 }
 147
 148 sub delete {
 149     my $this = shift;
 150
 151     my ($dn) = @_;
 152
 153     print {*STDERR} "XXXXXX $dn XXXXXXX\n";
 154     delete $this->{$dn};
 155     return 0;
 156 }
 157
 158 sub config {
 159     my $this = shift;
 160
 161     my (@args) = @_;
 162     local $, = ' - ';
 163     print {*STDERR} @args;
 164     print {*STDERR} "\n";
 165     return 0;
 166 }
 167
 168 1;