X-Git-Url: https://git.sur5r.net/?a=blobdiff_plain;f=servers%2Fslapd%2Fback-perl%2FSampleLDAP.pm;h=f1ca8775974ff6cbd79575d00ad89040eb270c47;hb=e0952945d0b6da70703a711c91306be07d31ea1a;hp=4f78bfb8a391d7f342c09b6e6f6cdce1a7a92191;hpb=3f1fd3bceebb47aaee74966ca208a14605cc5121;p=openldap diff --git a/servers/slapd/back-perl/SampleLDAP.pm b/servers/slapd/back-perl/SampleLDAP.pm index 4f78bfb8a3..f1ca877597 100644 --- a/servers/slapd/back-perl/SampleLDAP.pm +++ b/servers/slapd/back-perl/SampleLDAP.pm @@ -1,273 +1,168 @@ -=head1 Introduction +# This is a sample Perl module for the OpenLDAP server slapd. +# $OpenLDAP$ +## This work is part of OpenLDAP Software . +## +## Copyright 1998-2008 The OpenLDAP Foundation. +## Portions Copyright 1999 John C. Quillan. +## All rights reserved. +## +## Redistribution and use in source and binary forms, with or without +## modification, are permitted only as authorized by the OpenLDAP +## Public License. +## +## A copy of this license is available in the file LICENSE in the +## top-level directory of the distribution or, alternatively, at +## . +# +# Usage: Add something like this to slapd.conf: +# +# database perl +# suffix "o=AnyOrg,c=US" +# perlModulePath /directory/containing/this/module +# perlModule SampleLDAP +# +# See the slapd-perl(5) manual page for details. -This is a sample Perl module for the OpenLDAP server slapd. -It also contains the documentation that you will need to -get up and going. - -WARNING: the interfaces of this backen to the perl module -MAY change. Any suggestions would greatly be appreciated. - - -=head1 Overview - -The Perl back end works by embedding a Perl interpreter into -the slapd backend. Then when the configuration file indicates -that we are going to be using a Perl backend it will get an -option that tells it what module to use. It then creates a -new Perl object that handles all the request for that particular -instance of the back end. - - -=head1 Interface - -You will need to create a method for each one of the -following actions that you wish to handle. - - * new # Creates a new object. - * search # Performs the ldap search - * compare # does a compare - * modify # modify's and entry - * add # adds an entry to back end - * modrdn # modifies a an entries rdn - * delete # deletes an ldap entry - * config # process unknow config file lines - -=head2 new - -This method is called when the config file encounters a -B line. The module in that line is then effectively -used into the perl interpreter, then the new method is called -to create a new object. Note that multiple instances of that -object may be instantiated, as with any perl object. - -The new method doesn't receive any arguments other than the -class name. - -RETURN: - -=head2 search - -This method is called when a search request comes from a client. -It arguments are as follow. - - * obj reference - * filter string - * size limit - * time limit - * attributes only flag ( 1 for yes ) - * list of attributes that are to be returned. (could be empty) - -RETURN: - -=head2 compare - -This method is called when a compare request comes from a client. -Its arguments are as follows. - - * obj reference - * dn - -RETURN: - -=head2 modify - -This method is called when a modify request comes from a client. -Its arguments are as follows. - - * obj reference - * dn - * lists formatted as follows - { ADD | DELETE | REPLACE }, key, value - -RETURN: - -=head2 add - -This method is called when a add request comes from a client. -Its arguments are as follows. - - * obj reference - * entry in string format. - -RETURN: - -=head2 modrdn - -This method is called when a modrdn request comes from a client. -Its arguments are as follows. - - * obj reference - * dn - * new rdn - * delete old dn flage ( 1 means yes ) - -RETURN: - -=head2 delete - -This method is called when a delete request comes from a client. -Its arguments are as follows. - - * obj reference - * dn - -RETURN: - -=head2 config - - * obj reference - * arrray of arguments on line - -RETURN: non zero value if this is not a valid option. - -=head1 Configuration - -The perl section of the config file recognizes the following -options. It should also be noted that any option not recoginized -will be sent to the B method of the perl module as noted -above. +package SampleLDAP; +use strict; +use warnings; +use POSIX; - database perl # startn section for the perl database +$SampleLDAP::VERSION = '1.01'; - suffix "o=AnyOrg, c=US" +sub new { + my $class = shift; - perlModulePath /path/to/libs # addes the path to @INC variable same - # as "use lib '/path/to/libs'" + my $this = {}; + bless $this, $class; + print {*STDERR} "Here in new\n"; + print {*STDERR} 'Posix Var ' . BUFSIZ . ' and ' . FILENAME_MAX . "\n"; + return $this; +} - perlModule ModName # use the module name ModName from ModName.pm +sub init { + return 0; +} +sub search { + my $this = shift; + my ( $base, $scope, $deref, $sizeLim, $timeLim, $filterStr, $attrOnly, + @attrs ) + = @_; + print {*STDERR}, "====$filterStr====\n"; + $filterStr =~ s/\(|\)//gm; + $filterStr =~ s/=/: /m; + my @match_dn = (); + for my $dn ( keys %{$this} ) { + if ( $this->{$dn} =~ /$filterStr/imx ) { + push @match_dn, $dn; + last if ( scalar @match_dn == $sizeLim ); -=cut + } + } -package SampleLDAP; + my @match_entries = (); -sub new -{ - my $class = shift; + for my $dn (@match_dn) { + push @match_entries, $this->{$dn}; + } - my $this = {}; - bless $this, $class; + return ( 0, @match_entries ); - return $this; } -sub search -{ - my $this = shift; - my( $filterStr, $sizeLim, $timeLim, $attrOnly, @attrs ) = @_; - - $filterStr =~ s/\(|\)//g; - $filterStr =~ s/=/: /; +sub compare { + my $this = shift; + my ( $dn, $avaStr ) = @_; + my $rc = 5; # LDAP_COMPARE_FALSE - my @match_dn = (); - foreach my $dn ( keys %$this ) { - if ( $this->{ $dn } =~ /$filterStr/im ) { - push @match_dn, $dn; - last if ( scalar @match_dn == $sizeLim ); + $avaStr =~ s/=/: /m; - } - } - - my @match_entries = (); - - foreach my $dn ( @match_dn ) { - push @match_entries, $this->{ $dn }; - } - - return ( 0 , @match_entries ); + if ( $this->{$dn} =~ /$avaStr/im ) { + $rc = 6; # LDAP_COMPARE_TRUE + } + return $rc; } -sub compare -{ - my $this = shift; - my ( $dn ) = @_; +sub modify { + my $this = shift; - return 1; -} + my ( $dn, @list ) = @_; -sub modify -{ - my $this = shift; + while ( @list > 0 ) { + my $action = shift @list; + my $key = shift @list; + my $value = shift @list; - my ( $dn, @list ) = @_; + if ( $action eq 'ADD' ) { + $this->{$dn} .= "$key: $value\n"; - while ( @list > 0 ) { - my $action = shift @list; - my $key = shift @list; - my $value = shift @list; + } + elsif ( $action eq 'DELETE' ) { + $this->{$dn} =~ s/^$key:\s*$value\n//im; - if( $action eq "ADD" ) { - $this->{ $dn } .= "$key: $value\n"; + } + elsif ( $action eq 'REPLACE' ) { + $this->{$dn} =~ s/$key: .*$/$key: $value/im; + } + } - } - elsif( $action eq "DELETE" ) { - $this->{ $dn } =~ s/^$key:\s*$value\n//mi ; - - } - elsif( $action eq "REPLACE" ) { - $this->{ $dn } =~ s/$key: .*$/$key: $value/im ; - } - } - - return 0; + return 0; } -sub add -{ - my $this = shift; - - my ( $entryStr ) = @_; +sub add { + my $this = shift; - my ( $dn ) = ( $entryStr =~ /dn:\s(.*)$/m ); + my ($entryStr) = @_; - # - # This needs to be here untill a normalize dn is - # passed to this routine. - # - $dn = uc( $dn ); - $dn =~ s/\s*//g; + my ($dn) = ( $entryStr =~ /dn:\s(.*)$/m ); + # + # This needs to be here until a normalized dn is + # passed to this routine. + # + $dn = uc $dn; + $dn =~ s/\s*//gm; - $this->{$dn} = $entryStr; + $this->{$dn} = $entryStr; - return 0; + return 0; } -sub modrdn -{ - my $this = shift; +sub modrdn { + my $this = shift; - my ( $dn, $newdn, $delFlag ) = @_; + my ( $dn, $newdn, $delFlag ) = @_; - $this->{ $newdn } = $this->{ $dn }; + $this->{$newdn} = $this->{$dn}; - if( $delFlag ) { - delete $this->{ $dn }; - } - return 0; + if ($delFlag) { + delete $this->{$dn}; + } + return 0; } -sub delete -{ - my $this = shift; +sub delete { + my $this = shift; - my ( $dn ) = @_; - - delete $this->{$dn}; + my ($dn) = @_; + + print {*STDERR} "XXXXXX $dn XXXXXXX\n"; + delete $this->{$dn}; + return 0; } -sub config -{ - my $this = shift; +sub config { + my $this = shift; - my ( @args ) = @_; - - return 1; + my (@args) = @_; + local $, = ' - '; + print {*STDERR} @args; + print {*STDERR} "\n"; + return 0; } 1; - -