git.sur5r.net Git - openldap/blob - servers/slapd/back-perl/SampleLDAP.pm

   1 # This is a sample Perl module for the OpenLDAP server slapd.
   2 # $OpenLDAP$
   3 ## This work is part of OpenLDAP Software <http://www.openldap.org/>.
   4 ##
   5 ## Copyright 1998-2014 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 # This demo module keeps an in-memory hash {"DN" => "LDIF entry", ...}
  27 # built in sub add{} & co.  The data is lost when slapd shuts down.
  28
  29 package SampleLDAP;
  30 use strict;
  31 use warnings;
  32 use POSIX;
  33
  34 $SampleLDAP::VERSION = '1.01';
  35
  36 sub new {
  37     my $class = shift;
  38
  39     my $this = {};
  40     bless $this, $class;
  41     print {*STDERR} "Here in new\n";
  42     print {*STDERR} 'Posix Var ' . BUFSIZ . ' and ' . FILENAME_MAX . "\n";
  43     return $this;
  44 }
  45
  46 sub init {
  47     return 0;
  48 }
  49
  50 sub search {
  51     my $this = shift;
  52     my ( $base, $scope, $deref, $sizeLim, $timeLim, $filterStr, $attrOnly,
  53         @attrs )
  54       = @_;
  55     print {*STDERR} "====$filterStr====\n";
  56     $filterStr =~ s/\(|\)//gm;
  57     $filterStr =~ s/=/: /m;
  58
  59     my @match_dn = ();
  60     for my $dn ( keys %{$this} ) {
  61         if ( $this->{$dn} =~ /$filterStr/imx ) {
  62             push @match_dn, $dn;
  63             last if ( scalar @match_dn == $sizeLim );
  64
  65         }
  66     }
  67
  68     my @match_entries = ();
  69
  70     for my $dn (@match_dn) {
  71         push @match_entries, $this->{$dn};
  72     }
  73
  74     return ( 0, @match_entries );
  75
  76 }
  77
  78 sub compare {
  79     my $this = shift;
  80     my ( $dn, $avaStr ) = @_;
  81     my $rc = 5;    # LDAP_COMPARE_FALSE
  82
  83     $avaStr =~ s/=/: /m;
  84
  85     if ( $this->{$dn} =~ /$avaStr/im ) {
  86         $rc = 6;    # LDAP_COMPARE_TRUE
  87     }
  88
  89     return $rc;
  90 }
  91
  92 sub modify {
  93     my $this = shift;
  94
  95     my ( $dn, @list ) = @_;
  96
  97     while ( @list > 0 ) {
  98         my $action = shift @list;
  99         my $key    = shift @list;
 100         my $value  = shift @list;
 101
 102         if ( $action eq 'ADD' ) {
 103             $this->{$dn} .= "$key: $value\n";
 104
 105         }
 106         elsif ( $action eq 'DELETE' ) {
 107             $this->{$dn} =~ s/^$key:\s*$value\n//im;
 108
 109         }
 110         elsif ( $action eq 'REPLACE' ) {
 111             $this->{$dn} =~ s/$key: .*$/$key: $value/im;
 112         }
 113     }
 114
 115     return 0;
 116 }
 117
 118 sub add {
 119     my $this = shift;
 120
 121     my ($entryStr) = @_;
 122
 123     my ($dn) = ( $entryStr =~ /dn:\s(.*)$/m );
 124
 125     #
 126     # This needs to be here until a normalized dn is
 127     # passed to this routine.
 128     #
 129     $dn = uc $dn;
 130     $dn =~ s/\s*//gm;
 131
 132     $this->{$dn} = $entryStr;
 133
 134     return 0;
 135 }
 136
 137 sub modrdn {
 138     my $this = shift;
 139
 140     my ( $dn, $newdn, $delFlag ) = @_;
 141
 142     $this->{$newdn} = $this->{$dn};
 143
 144     if ($delFlag) {
 145         delete $this->{$dn};
 146     }
 147     return 0;
 148
 149 }
 150
 151 sub delete {
 152     my $this = shift;
 153
 154     my ($dn) = @_;
 155
 156     print {*STDERR} "XXXXXX $dn XXXXXXX\n";
 157     delete $this->{$dn};
 158     return 0;
 159 }
 160
 161 sub config {
 162     my $this = shift;
 163
 164     my (@args) = @_;
 165     local $, = ' - ';
 166     print {*STDERR} @args;
 167     print {*STDERR} "\n";
 168     return 0;
 169 }
 170
 171 1;