File Coverage

blib/lib/Test/Net/LDAP/Mock.pm
Criterion Covered Total %
statement 111 140 79.2
branch 34 40 85.0
condition 6 10 60.0
subroutine 21 33 63.6
pod 17 17 100.0
total 189 240 78.7


line stmt bran cond sub pod time code
1 13     13   51199 use 5.006;
  13         32  
  13         407  
2 13     13   53 use strict;
  13         29  
  13         322  
3 13     13   50 use warnings;
  13         19  
  13         405  
4              
5             package Test::Net::LDAP::Mock;
6              
7 13     13   54 use base 'Test::Net::LDAP';
  13         16  
  13         4638  
8              
9 13     13   62 use IO::Socket;
  13         19  
  13         98  
10 13     13   7802 use Net::LDAP;
  13         22  
  13         91  
11 13     13   638 use Net::LDAP::Constant qw(LDAP_SUCCESS);
  13         68  
  13         2396  
12              
13             =head1 NAME
14              
15             Test::Net::LDAP::Mock - A mock LDAP client with simulated search in memory
16              
17             =cut
18              
19             =head1 SYNOPSIS
20              
21             All the LDAP operations are performed in memory, instead of connecting to the
22             real LDAP server.
23              
24             use Test::Net::LDAP::Mock;
25             my $ldap = Test::Net::LDAP::Mock->new();
26              
27             C is a subclass of L, which is
28             a subclass of L.
29              
30             In the actual test code, L should be used to mock
31             all the C instances in your application code.
32              
33             use Test::More tests => 1;
34             use Test::Net::LDAP::Util qw(ldap_mockify);
35            
36             ldap_mockify {
37             # Anywhere in this block, all the occurrences of Net::LDAP::new are
38             # replaced by Test::Net::LDAP::Mock::new
39             ok my_application_routine();
40             };
41              
42             Note: if no LDAP entries have been added to the in-memory directory, the
43             C method will silently succeed with no entries found.
44              
45             Below is an example to set up some fake data for particular test cases.
46              
47             use Test::More tests => 1;
48             use Test::Net::LDAP::Util qw(ldap_mockify);
49            
50             ldap_mockify {
51             my $ldap = Net::LDAP->new('ldap.example.com');
52            
53             $ldap->add('uid=user1, ou=users, dc=example, dc=com');
54             $ldap->add('uid=user2, ou=users, dc=example, dc=com');
55             $ldap->add('cn=group1, ou=groups, dc=example, dc=com', attrs => [
56             member => [
57             'uid=user1, ou=users, dc=example, dc=com',
58             'uid=user2, ou=users, dc=example, dc=com',
59             ]
60             ]);
61            
62             ok my_application_routine();
63             };
64              
65             C maintains a shared LDAP directory tree for the same
66             host/port, while it separates the directory trees for different
67             host/port combinations.
68             Thus, it is important to specify a correct server location consistently.
69              
70             =head1 DESCRIPTION
71              
72             =head2 Overview
73              
74             C provides all the operations of C, while
75             they are performed in memory with fake data that are set up just for testing.
76              
77             It is most useful for developers who write testing for an application that
78             uses LDAP search, while they do not have full control over the organizational
79             LDAP server.
80             In many cases, developers do not have write access to the LDAP data, and the
81             organizational information changes over time, which makes it difficult to write
82             stable test cases with LDAP.
83             C helps developers set up any fake LDAP directory tree
84             in memory, so that they can test sufficient varieties of senarios for the
85             application.
86              
87             Without this module, an alternative way to test an application using LDAP is to
88             run a real server locally during testing. (See how C is tested with
89             a local OpenLDAP server.)
90             However, it may not be always trivial to set up such a server with correct
91             configurations and schemas, where this module makes testing easier.
92              
93             =head2 LDAP Schema
94              
95             In the current version, the LDAP schema is ignored when entries are added or
96             modified, although a schema can optionally be specified only for the search
97             filter matching (based on L).
98              
99             An advantage is that it is much easier to set up fake data with any arbitrary
100             LDAP attributes than to care about all the restrictions with the schema.
101             A disadvantage is that it cannot test schema-sensitive cases.
102              
103             =head2 Controls
104              
105             LDAPv3 controls are not supported (yet).
106             The C parameter given as an argument of a method will be ignored.
107              
108             =head1 METHODS
109              
110             =head2 new
111              
112             Creates a new object. It does not connect to the real LDAP server.
113             Each object is associated with a shared LDAP data tree in memory, depending on
114             the target (host/port/path) and scheme (ldap/ldaps/ldapi).
115              
116             Test::Net::LDAP::Mock->new();
117             Test::Net::LDAP::Mock->new('ldap.example.com', port => 3389);
118              
119             =cut
120              
121             my $mock_map = {};
122             my $mock_target;
123              
124             my $mockified = 0;
125             my @mockified_subclasses;
126              
127             sub new {
128 33     33 1 771 my $class = shift;
129 33   33     133 $class = ref $class || $class;
130              
131 33 100       88 if ($mockified) {
132 11 100       31 if ($class eq 'Net::LDAP') {
    100          
133             # Net::LDAP
134 8         112 $class = __PACKAGE__;
135             } elsif (!$class->isa(__PACKAGE__)) {
136             # Subclass of Net::LDAP (but not yet of Test::Net::LDAP::Mock)
137 1         3 _mockify_subclass($class);
138             }
139             }
140              
141 33         53 my $target = &_mock_target;
142            
143 33         152 my $self = bless {
144             mock_data => undef,
145             net_ldap_socket => IO::Socket->new(),
146             }, $class;
147            
148 33   66     2215 $self->{mock_data} = ($mock_map->{$target} ||= do {
149 22         2057 require Test::Net::LDAP::Mock::Data;
150 22         130 Test::Net::LDAP::Mock::Data->new($self);
151             });
152            
153 33         78 return $self;
154             }
155              
156             sub _mockify_subclass {
157 1     1   1 my ($class) = @_;
158 13     13   56 no strict 'refs';
  13         16  
  13         527  
159             {
160 1         2 unshift @{$class.'::ISA'}, __PACKAGE__;
  1         1  
  1         24  
161             }
162 13     13   48 use strict 'refs';
  13         19  
  13         479  
163              
164 1         3 push @mockified_subclasses, $class;
165             }
166              
167             sub _unmockify_subclasses {
168 13     13   48 no strict 'refs';
  13         14  
  13         667  
169             {
170 4     4   4 for my $class (@mockified_subclasses) {
  4         7  
171 1         2 @{$class.'::ISA'} = grep {$_ ne __PACKAGE__} @{$class.'::ISA'};
  1         21  
  2         4  
  1         4  
172             }
173             }
174 13     13   48 use strict 'refs';
  13         17  
  13         9321  
175              
176 4         7 @mockified_subclasses = ();
177             }
178              
179             sub _mock_target {
180 33 100   33   95 my $host = shift if @_ % 2;
181 33         82 my $arg = &Net::LDAP::_options;
182              
183 33 100       346 if ($mock_target) {
184 12         9 my ($new_host, $new_arg);
185              
186 12 100       29 if (ref $mock_target eq 'CODE') {
    100          
    50          
187 4         8 ($new_host, $new_arg) = $mock_target->($host, $arg);
188             } elsif (ref $mock_target eq 'ARRAY') {
189 4         7 ($new_host, $new_arg) = @$mock_target;
190             } elsif (ref $mock_target eq 'HASH') {
191 0         0 $new_arg = $mock_target;
192             } else {
193 4         4 $new_host = $mock_target;
194             }
195              
196 12 50       44 $host = $new_host if defined $new_host;
197 12 100       30 $arg = {%$arg, %$new_arg} if defined $new_arg;
198             }
199              
200 33   100     122 my $scheme = $arg->{scheme} || 'ldap';
201              
202             # Net::LDAP->new() can take an array ref as hostnames, where
203             # the first host that we can connect to will be used.
204             # For the mock object, let's just pick the first one.
205 33 100       286 if (ref $host) {
206 1   50     3 $host = $host->[0] || '';
207             }
208            
209 33 100       68 if (length $host) {
210 23 100       34 if ($scheme ne 'ldapi') {
211 21 100       56 if ($arg->{port}) {
    50          
212 10         13 $host =~ s/:\d+$//;
213 10         16 $host .= ":$arg->{port}";
214             } elsif ($host !~ /:\d+$/) {
215 11         18 $host .= ":389";
216             }
217             }
218             } else {
219 10         13 $host = '';
220             }
221              
222 33         85 return "$scheme://$host";
223             }
224              
225             sub _mock_message {
226 173     173   170 my $self = shift;
227 173         486 my $mesg = $self->message(@_);
228 173         3549 $mesg->{resultCode} = LDAP_SUCCESS;
229 173         220 $mesg->{errorMessage} = '';
230 173         212 $mesg->{matchedDN} = '';
231 173         165 $mesg->{raw} = undef;
232 173         271 $mesg->{controls} = undef;
233 173         170 $mesg->{ctrl_hash} = undef;
234 173         336 return $mesg;
235             }
236              
237             #override
238             sub _send_mesg {
239 0     0   0 my $ldap = shift;
240 0         0 my $mesg = shift;
241 0         0 return $mesg;
242             }
243              
244             =head2 mockify
245              
246             Test::Net::LDAP::Mock->mockify(sub {
247             # CODE
248             });
249              
250             Inside the code block (recursively), all the occurrences of C
251             are replaced by C.
252              
253             Subclasses of C are also mockified. C is inserted
254             into C<@ISA> of each subclass, only within the context of C.
255              
256             See also: L.
257              
258             =cut
259              
260             sub mockify {
261 4     4 1 6 my ($class, $callback) = @_;
262              
263 4 50       7 if ($mockified) {
264 0         0 $callback->();
265             } else {
266 4         3 $mockified = 1;
267 4         18 local *Net::LDAP::new = *Test::Net::LDAP::Mock::new;
268 4         5 eval {$callback->()};
  4         8  
269 4         475 my $error = $@;
270 4         22 _unmockify_subclasses();
271 4         3 $mockified = 0;
272 4 50       29 die $error if $error;
273             }
274             }
275              
276             =head2 mock_data
277              
278             Retrieves the currently associated data tree (for the internal purpose only).
279              
280             =cut
281              
282             sub mock_data {
283 45     45 1 145 return shift->{mock_data};
284             }
285              
286             =head2 mock_schema
287              
288             Gets or sets the LDAP schema (L object) for the currently
289             associated data tree.
290              
291             In this version, the schema is used only for the search filter matching (based
292             on L internally).
293             It has no effect for any modification operations such as C, C, and
294             C.
295              
296             =cut
297              
298             sub mock_schema {
299 0     0 1 0 my $self = shift;
300 0         0 $self->mock_data->schema(@_);
301             }
302              
303             =head2 mock_root_dse
304              
305             Gets or sets the root DSE (L) for the currently associated
306             data tree.
307              
308             This should be set up as part of the test fixture before any successive call to
309             the C method, since L will cache the returned object.
310              
311             $ldap->mock_root_dse(
312             namingContexts => 'dc=example,dc=com'
313             );
314              
315             Note: the namingContexts value has no effect on the restriction with the
316             topmost DN. In other words, even if namingContexts is set to
317             'dc=example,dc=com', the C method still allows you to add an entry to
318             'dc=somewhere-else'.
319              
320             =cut
321              
322             sub mock_root_dse {
323 0     0 1 0 my $self = shift;
324 0         0 $self->mock_data->mock_root_dse(@_);
325             }
326              
327             =head2 mock_bind
328              
329             Gets or sets a LDAP result code (and optionally a message) that will be used as a message
330             returned by a later C call.
331              
332             use Net::LDAP::Constant qw(LDAP_INVALID_CREDENTIALS);
333             $ldap->mock_bind(LDAP_INVALID_CREDENTIALS);
334             $ldap->mock_bind(LDAP_INVALID_CREDENTIALS, 'Login failed');
335             # ...
336             my $mesg = $ldap->bind(...);
337             $mesg->code && die $mesg->error; #=> die('Login failed')
338              
339             In the list context, it returns an array of the code and message. In the scalar
340             context, it returns the code only.
341              
342             Alternatively, this method can take a callback subroutine:
343              
344             $ldap->mock_bind(sub {
345             my $arg = shift;
346             # Validate $arg->{dn} and $arg->{password}, etc.
347             if (...invalid credentials...) {
348             return LDAP_INVALID_CREDENTIALS;
349             }
350             });
351              
352             The callback can return a single value as the LDAP result code or an array in the form
353             C<($code, $message)>. If the callback returns nothing (or C), it is regarded as
354             C.
355              
356             =cut
357              
358             sub mock_bind {
359 0     0 1 0 my $self = shift;
360 0         0 $self->mock_data->mock_bind(@_);
361             }
362              
363             =head2 mock_password
364              
365             Gets or sets the password for the simple password authentication with C.
366              
367             $ldap->mock_password('uid=test, dc=example, dc=com' => 'test_password');
368             # Caution: Passwords should usually *not* be hard-coded like this. Consider to load
369             # passwords from a config file, etc.
370              
371             The passwords are stored with the entry node in the data tree.
372              
373             Once this method is used, the C call will check the credentials whenever the
374             C parameter is passed. Anonymous binding and all the other authentication
375             methods are not affected.
376              
377             =cut
378              
379             sub mock_password {
380 0     0 1 0 my $self = shift;
381 0         0 $self->mock_data->mock_password(@_);
382             }
383              
384             =head2 mock_target
385              
386             Gets or sets the target scheme://host:port to normalize the way for successive
387             C objects to resolve the associated data tree.
388              
389             It is useful when normalizing the target scheme://host:port for different
390             combinations. For example, if there are sub-domains (such as ldap1.example.com
391             and ldap2.example.com) that share the same data tree, the target host should be
392             normalized to be the single master server (such as ldap.example.com).
393              
394             Test::Net::LDAP::Mock->mock_target('ldap.example.com');
395             Test::Net::LDAP::Mock->mock_target('ldap.example.com', port => 3389);
396             Test::Net::LDAP::Mock->mock_target(['ldap.example.com', {port => 3389}]);
397             Test::Net::LDAP::Mock->mock_target({scheme => 'ldaps', port => 3389});
398              
399             Since this will affect all the successive calls to instantiate C,
400             it may not be ideal when your application uses connections to multiple LDAP
401             servers. In that case, you can specify a callback that will be invoked each
402             time a C object is instantiated.
403              
404             Test::Net::LDAP::Mock->mock_target(sub {
405             my ($host, $arg) = @_;
406             # Normalize $host, $arg->{port}, and $arg->{scheme}
407             $host = 'ldap.example1.com' if $host =~ /\.example1\.com$/;
408             $host = 'ldap.example2.com' if $host =~ /\.example2\.com$/;
409             return ($host, $arg);
410             });
411              
412             =cut
413              
414             sub mock_target {
415 6     6 1 788 my $class = shift;
416              
417 6 100       13 if (@_) {
418 3         6 my $old = $mock_target;
419 3         2 my $host = shift;
420              
421 3 100       11 if (@_ >= 2) {
    50          
422 1         3 $mock_target = [$host, {@_}];
423             } elsif (@_ == 1) {
424 0         0 my $arg = shift;
425 0         0 $mock_target = [$host, $arg];
426             } else {
427 2         3 $mock_target = $host;
428             }
429              
430 3         8 return $old;
431             } else {
432 3         18 return $mock_target;
433             }
434             }
435              
436             =head2 search
437              
438             Searches for entries in the currently associated data tree.
439              
440             $ldap->search(
441             base => 'dc=example, dc=com', scope => 'sub',
442             filter => '(cn=*)', attrs => ['uid', 'cn']
443             );
444              
445             See L for more parameter usage.
446              
447             =cut
448              
449             sub search {
450 12     12 1 33 my $ldap = shift;
451 12         24 return $ldap->mock_data->search(@_);
452             }
453              
454             =head2 compare
455              
456             Compares an attribute/value pair with an entry in the currently associated data
457             tree.
458              
459             $ldap->compare('uid=test, dc=example, dc=com',
460             attr => 'cn',
461             value => 'Test'
462             );
463              
464             See L for more parameter usage.
465              
466             =cut
467              
468             sub compare {
469 0     0 1 0 my $ldap = shift;
470 0         0 return $ldap->mock_data->compare(@_);
471             }
472              
473             =head2 add
474              
475             Adds an entry to the currently associated data tree.
476              
477             $ldap->add('uid=test, dc=example, dc=com', attrs => [
478             cn => 'Test'
479             ]);
480              
481             See L for more parameter usage.
482              
483             =cut
484              
485             sub add {
486 15     15 1 1769 my $ldap = shift;
487 15         31 return $ldap->mock_data->add(@_);
488             }
489              
490             =head2 modify
491              
492             Modifies an entry in the currently associated data tree.
493              
494             $ldap->modify('uid=test, dc=example, dc=com', add => [
495             cn => 'Test2'
496             ]);
497              
498             See L for more parameter usage.
499              
500             =cut
501              
502             sub modify {
503 0     0 1   my $ldap = shift;
504 0           return $ldap->mock_data->modify(@_);
505             }
506              
507             =head2 delete
508              
509             Deletes an entry from the currently associated data tree.
510              
511             $ldap->delete('uid=test, dc=example, dc=com');
512              
513             See L for more parameter usage.
514              
515             =cut
516              
517             sub delete {
518 0     0 1   my $ldap = shift;
519 0           return $ldap->mock_data->delete(@_);
520             }
521              
522             =head2 moddn
523              
524             Modifies DN of an entry in the currently associated data tree.
525              
526             $ldap->moddn('uid=test, dc=example, dc=com',
527             newrdn => 'uid=test2'
528             );
529              
530             See L for more parameter usage.
531              
532             =cut
533              
534             sub moddn {
535 0     0 1   my $ldap = shift;
536 0           return $ldap->mock_data->moddn(@_);
537             }
538              
539             =head2 bind
540              
541             Returns an expected result message if the bind result has previously been setup by the
542             C method. Otherwise, a success message is returned.
543              
544             =cut
545              
546             sub bind {
547 0     0 1   my $ldap = shift;
548 0           return $ldap->mock_data->bind(@_);
549             }
550              
551             =head2 unbind
552              
553             Returns a success message.
554              
555             =cut
556              
557             sub unbind {
558 0     0 1   my $ldap = shift;
559 0           return $ldap->mock_data->unbind(@_);
560             }
561              
562             =head2 abandon
563              
564             Returns a success message.
565              
566             =cut
567              
568             sub abandon {
569 0     0 1   my $ldap = shift;
570 0           return $ldap->mock_data->abandon(@_);
571             }
572              
573             1;