]> git.sur5r.net Git - openldap/blob - servers/slapd/back-perl/SampleLDAP.pm
Added bdb_attribute and bdb_group ACL support routines
[openldap] / servers / slapd / back-perl / SampleLDAP.pm
1
2 =head1 Introduction
3
4 This is a sample Perl module for the OpenLDAP server slapd.
5 It also contains the documentation that you will need to
6 get up and going.
7
8 WARNING: the interfaces of this backen to the perl module
9 MAY change.  Any suggestions would greatly be appreciated.
10
11
12 =head1 Overview
13
14 The Perl back end works by embedding a Perl interpreter into
15 the slapd backend. Then when the configuration file indicates
16 that we are going to be using a Perl backend it will get an
17 option that tells it what module to use.  It then creates a 
18 new Perl object that handles all the request for that particular
19 instance of the back end.
20
21
22 =head1 Interface
23
24 You will need to create a method for each one of the
25 following actions that you wish to handle.
26
27    * new        # Creates a new object.
28    * search     # Performs the ldap search
29    * compare    # does a compare
30    * modify     # modify's and entry
31    * add        # adds an entry to back end
32    * modrdn     # modifies a an entries rdn
33    * delete     # deletes an ldap entry
34    * config     # process unknow config file lines
35
36 =head2 new
37
38 This method is called when the config file encounters a 
39 B<perlmod> line. The module in that line is then effectively
40 used into the perl interpreter, then the new method is called
41 to create a new object.  Note that multiple instances of that
42 object may be instantiated, as with any perl object.
43
44 The new method doesn't receive any arguments other than the
45 class name.
46
47 RETURN: 
48
49 =head2 search
50
51 This method is called when a search request comes from a client.
52 It arguments are as follow.
53
54   * obj reference
55   * filter string
56   * size limit
57   * time limit
58   * attributes only flag ( 1 for yes )
59   * list of attributes that are to be returned. (could be empty)
60
61 RETURN:
62
63 =head2 compare
64
65 This method is called when a compare request comes from a client.
66 Its arguments are as follows.
67
68   * obj reference
69   * dn
70
71 RETURN:
72
73 =head2 modify
74
75 This method is called when a modify request comes from a client.
76 Its arguments are as follows.
77
78   * obj reference
79   * dn
80   * lists formatted as follows
81    { ADD | DELETE | REPLACE }, key, value
82
83 RETURN:
84
85 =head2 add
86
87 This method is called when a add request comes from a client.
88 Its arguments are as follows.
89
90   * obj reference
91   * entry in string format.
92
93 RETURN:
94
95 =head2 modrdn
96
97 This method is called when a modrdn request comes from a client.
98 Its arguments are as follows.
99
100   * obj reference
101   * dn
102   * new rdn
103   * delete old dn flage ( 1 means yes )
104
105 RETURN:
106
107 =head2 delete
108
109 This method is called when a delete request comes from a client.
110 Its arguments are as follows.
111
112   * obj reference
113   * dn
114
115 RETURN:
116
117 =head2 config
118
119   * obj reference
120   * arrray of arguments on line
121
122 RETURN: non zero value if this is not a valid option.
123
124 =head1 Configuration
125
126 The perl section of the config file recognizes the following 
127 options.  It should also be noted that any option not recoginized
128 will be sent to the B<config> method of the perl module as noted
129 above.
130
131   database perl         # startn section for the perl database
132
133   suffix          "o=AnyOrg, c=US"
134
135   perlModulePath /path/to/libs  # addes the path to @INC variable same
136                              # as "use lib '/path/to/libs'"
137
138   perlModule ModName       # use the module name ModName from ModName.pm
139
140
141
142 =cut
143
144 package SampleLDAP;
145
146 use POSIX;
147
148 sub new
149 {
150         my $class = shift;
151
152         my $this = {};
153         bless $this, $class;
154         print STDERR "Here in new\n";
155         print STDERR "Posix Var " . BUFSIZ . " and " . FILENAME_MAX . "\n";
156         return $this;
157 }
158
159 sub search
160 {
161         my $this = shift;
162         my( $filterStr, $sizeLim, $timeLim, $attrOnly, @attrs ) = @_;
163         print STDERR "====$filterStr====\n";
164         $filterStr =~ s/\(|\)//g;
165         $filterStr =~ s/=/: /;
166
167         my @match_dn = ();
168         foreach my $dn ( keys %$this ) {
169                 if ( $this->{ $dn } =~ /$filterStr/im ) {
170                         push @match_dn, $dn;
171                         last if ( scalar @match_dn == $sizeLim );
172
173                 }
174         }
175
176         my @match_entries = ();
177         
178         foreach my $dn ( @match_dn )  {
179                 push @match_entries, $this->{ $dn };
180         }
181
182         return ( 0 , @match_entries );
183
184 }
185
186 sub compare
187 {
188         my $this = shift;
189         my ( $dn ) = @_;
190
191         return 1;
192 }
193
194 sub modify
195 {
196         my $this = shift;
197
198         my ( $dn, @list ) = @_;
199
200         while ( @list > 0 ) {
201                 my $action = shift @list;
202                 my $key    = shift @list;
203                 my $value  = shift @list;
204
205                 if( $action eq "ADD" ) {
206                         $this->{ $dn } .= "$key: $value\n";
207
208                 }
209                 elsif( $action eq "DELETE" ) {
210                         $this->{ $dn } =~ s/^$key:\s*$value\n//mi ;
211
212                 }
213                 elsif( $action eq "REPLACE" ) {
214                         $this->{ $dn } =~ s/$key: .*$/$key: $value/im ;
215                 }
216         }
217
218         return 0;
219 }
220
221 sub add
222 {
223         my $this = shift;
224
225         my ( $entryStr ) = @_;
226
227         my ( $dn ) = ( $entryStr =~ /dn:\s(.*)$/m );
228
229         #
230         # This needs to be here untill a normalize dn is
231         # passed to this routine.
232         #
233         $dn = uc( $dn );
234         $dn =~ s/\s*//g;
235
236
237         $this->{$dn} = $entryStr;
238
239         return 0;
240 }
241
242 sub modrdn
243 {
244         my $this = shift;
245
246         my ( $dn, $newdn, $delFlag ) = @_;
247
248         $this->{ $newdn } = $this->{ $dn };
249
250         if( $delFlag ) {
251                 delete $this->{ $dn };
252         }
253         return 0;
254
255 }
256
257 sub delete
258 {
259         my $this = shift;
260
261         my ( $dn ) = @_;
262         
263         print STDERR "XXXXXX $dn XXXXXXX\n";
264         delete $this->{$dn};
265 }
266
267 sub config
268 {
269         my $this = shift;
270
271         my ( @args ) = @_;
272         local $, = " - ";
273         print STDERR @args;
274         print STDERR "\n";
275         return 0;
276 }
277
278 1;
279
280