File Coverage

blib/lib/Net/LDAP/Message.pm
Criterion Covered Total %
statement 34 122 27.8
branch 5 58 8.6
condition 3 14 21.4
subroutine 12 36 33.3
pod 13 23 56.5
total 67 253 26.4


line stmt bran cond sub pod time code
1             # Copyright (c) 1997-2004 Graham Barr . All rights reserved.
2             # This program is free software; you can redistribute it and/or
3             # modify it under the same terms as Perl itself.
4              
5             package Net::LDAP::Message;
6              
7 21     21   10462 use Net::LDAP::Constant qw(LDAP_SUCCESS LDAP_COMPARE_TRUE LDAP_COMPARE_FALSE);
  21         72  
  21         3321  
8 21     21   10513 use Net::LDAP::ASN qw(LDAPRequest);
  21         98  
  21         258  
9 21     21   306 use strict;
  21         57  
  21         35996  
10              
11             our $VERSION = '1.12';
12              
13             my $MsgID = 0;
14              
15             # We do this here so when we add threading we can lock it
16             sub NewMesgID {
17 2 50   2 0 7 $MsgID = 1 if ++$MsgID > 65535;
18 2         31 $MsgID;
19             }
20              
21             sub new {
22 2     2 0 4 my $self = shift;
23 2   33     11 my $type = ref($self) || $self;
24 2         8 my $parent = shift->inner;
25 2         4 my $arg = shift;
26              
27             $self = bless {
28             parent => $parent,
29             mesgid => NewMesgID(),
30             callback => $arg->{callback} || undef,
31             raw => $arg->{raw} || undef,
32 2   50     5 }, $type;
      50        
33              
34 2         9 $self;
35             }
36              
37             sub code {
38 1     1 1 10 my $self = shift;
39              
40 1 50       5 $self->sync unless exists $self->{resultCode};
41              
42             exists $self->{resultCode}
43             ? $self->{resultCode}
44             : undef
45 1 50       6 }
46              
47             sub done {
48 2     2 1 3 my $self = shift;
49              
50 2         7 exists $self->{resultCode};
51             }
52              
53             sub dn {
54 0     0 1 0 my $self = shift;
55              
56 0 0       0 $self->sync unless exists $self->{resultCode};
57              
58             exists $self->{matchedDN}
59             ? $self->{matchedDN}
60             : undef
61 0 0       0 }
62              
63             sub referrals {
64 0     0 1 0 my $self = shift;
65              
66 0 0       0 $self->sync unless exists $self->{resultCode};
67              
68             exists $self->{referral}
69 0 0       0 ? @{$self->{referral}}
  0         0  
70             : ();
71             }
72              
73             sub server_error {
74 0     0 1 0 my $self = shift;
75              
76 0 0       0 $self->sync unless exists $self->{resultCode};
77              
78             exists $self->{errorMessage}
79             ? $self->{errorMessage}
80             : undef
81 0 0       0 }
82              
83             sub error {
84 0     0 1 0 my $self = shift;
85 0         0 my $return;
86              
87 0 0       0 unless ($return = $self->server_error) {
88             require Net::LDAP::Util and
89 0 0       0 $return = Net::LDAP::Util::ldap_error_desc( $self->code );
90             }
91              
92 0         0 $return;
93             }
94              
95             sub set_error {
96 2     2 0 4 my $self = shift;
97 2         8 ($self->{resultCode}, $self->{errorMessage}) = ($_[0]+0, "$_[1]");
98             $self->{callback}->($self)
99 2 50       6 if (defined $self->{callback});
100 2         5 $self;
101             }
102              
103             sub error_name {
104 0     0 1 0 require Net::LDAP::Util;
105 0         0 Net::LDAP::Util::ldap_error_name(shift->code);
106             }
107              
108             sub error_text {
109 0     0 1 0 require Net::LDAP::Util;
110 0         0 Net::LDAP::Util::ldap_error_text(shift->code);
111             }
112              
113             sub error_desc {
114 0     0 1 0 require Net::LDAP::Util;
115 0         0 Net::LDAP::Util::ldap_error_desc(shift->code);
116             }
117              
118             sub sync {
119 0     0 1 0 my $self = shift;
120 0         0 my $ldap = $self->{parent};
121 0         0 my $err;
122              
123 0         0 until(exists $self->{resultCode}) {
124 0 0       0 $err = $ldap->sync($self->mesg_id) or next;
125             $self->set_error($err, 'Protocol Error')
126 0 0       0 unless exists $self->{resultCode};
127 0         0 return $err;
128             }
129              
130 0         0 LDAP_SUCCESS;
131             }
132              
133              
134             sub decode { # $self, $pdu, $control
135 0     0 0 0 my $self = shift;
136 0         0 my $result = shift;
137 0         0 my $data = (values %{$result->{protocolOp}})[0];
  0         0  
138              
139 0         0 @{$self}{keys %$data} = values %$data;
  0         0  
140              
141 0         0 @{$self}{qw(controls ctrl_hash)} = ($result->{controls}, undef);
  0         0  
142              
143             # free up memory as we have a result so we will not need to re-send it
144 0         0 delete $self->{pdu};
145              
146 0 0       0 if ($data = delete $result->{protocolOp}{intermediateResponse}) {
147              
148 0         0 my $intermediate = Net::LDAP::Intermediate->from_asn($data);
149              
150 0 0       0 if (defined $self->{callback}) {
151 0         0 $self->{callback}->($self, $intermediate);
152             } else {
153 0   0     0 push(@{$self->{intermediate} ||= []}, $intermediate);
  0         0  
154             }
155              
156 0         0 return $self;
157             } else {
158             # tell our LDAP client to forget us as this message has now completed
159             # all communications with the server
160 0         0 $self->parent->_forgetmesg($self);
161             }
162              
163             $self->{callback}->($self)
164 0 0       0 if (defined $self->{callback});
165              
166 0         0 $self;
167             }
168              
169              
170             sub abandon {
171 0     0 0 0 my $self = shift;
172              
173 0 0       0 return if exists $self->{resultCode}; # already complete
174              
175 0         0 my $ldap = $self->{parent};
176              
177 0         0 $ldap->abandon($self->{mesgid});
178             }
179              
180             sub saslref {
181 0     0 0 0 my $self = shift;
182              
183 0 0       0 $self->sync unless exists $self->{resultCode};
184              
185             exists $self->{sasl}
186             ? $self->{sasl}
187             : undef
188 0 0       0 }
189              
190              
191             sub encode {
192 2     2 0 4 my $self = shift;
193              
194             $self->{pdu} = $LDAPRequest->encode(@_, messageID => $self->{mesgid})
195 2 50       13 or return;
196 2         678 1;
197             }
198              
199             sub control {
200 0     0 1 0 my $self = shift;
201              
202 0 0       0 if ($self->{controls}) {
203 0         0 require Net::LDAP::Control;
204 0         0 my $hash = $self->{ctrl_hash} = {};
205 0         0 foreach my $asn (@{delete $self->{controls}}) {
  0         0  
206 0         0 my $ctrl = Net::LDAP::Control->from_asn($asn);
207             $ctrl->{raw} = $self->{parent}->{raw}
208 0 0       0 if ($self->{parent});
209 0   0     0 push @{$hash->{$ctrl->type} ||= []}, $ctrl;
  0         0  
210             }
211             }
212              
213             my $ctrl_hash = $self->{ctrl_hash}
214 0 0       0 or return;
215              
216 0 0       0 my @oid = @_ ? @_ : keys %$ctrl_hash;
217 0 0       0 my @control = map {@$_} grep $_, @{$ctrl_hash}{@oid}
  0         0  
  0         0  
218             or return;
219              
220             # return a list, so in a scalar context we do not just get array length
221 0         0 return @control[0 .. $#control];
222             }
223              
224 2     2 0 8 sub pdu { shift->{pdu} }
225 0     0 0 0 sub callback { shift->{callback} }
226 0     0 0 0 sub parent { shift->{parent}->outer }
227 2     2 1 6 sub mesg_id { shift->{mesgid} }
228 0     0 1   sub is_error { shift->code }
229              
230             ##
231             ##
232             ##
233              
234              
235             @Net::LDAP::Add::ISA = qw(Net::LDAP::Message);
236             @Net::LDAP::Delete::ISA = qw(Net::LDAP::Message);
237             @Net::LDAP::Modify::ISA = qw(Net::LDAP::Message);
238             @Net::LDAP::ModDN::ISA = qw(Net::LDAP::Message);
239             @Net::LDAP::Compare::ISA = qw(Net::LDAP::Message);
240             @Net::LDAP::Unbind::ISA = qw(Net::LDAP::Message::Dummy);
241             @Net::LDAP::Abandon::ISA = qw(Net::LDAP::Message::Dummy);
242              
243             sub Net::LDAP::Compare::is_error {
244 0     0     my $mesg = shift;
245 0           my $code = $mesg->code;
246 0 0         $code != LDAP_COMPARE_FALSE and $code != LDAP_COMPARE_TRUE
247             }
248              
249             {
250             package Net::LDAP::Message::Dummy;
251             our @ISA = qw(Net::LDAP::Message);
252 21     21   230 use Net::LDAP::Constant qw(LDAP_SUCCESS);
  21         275  
  21         5988  
253              
254             sub new {
255 0     0     my $self = shift;
256 0   0       my $type = ref($self) || $self;
257              
258 0           $self = bless {
259             mesgid => Net::LDAP::Message::NewMesgID(),
260             }, $type;
261              
262 0           $self;
263             }
264              
265 0     0     sub sync { shift }
266 0     0     sub decode { shift }
267 0     0     sub abandon { shift }
268 0 0   0     sub code { shift->{resultCode} || LDAP_SUCCESS }
269 0 0   0     sub error { shift->{errorMessage} || '' }
270 0     0     sub dn { '' }
271 0     0     sub done { 1 }
272             }
273              
274             1;