File Coverage

blib/lib/Net/ManageSieve.pm
Criterion Covered Total %
statement 18 460 3.9
branch 0 272 0.0
condition 0 89 0.0
subroutine 6 48 12.5
pod 20 27 74.0
total 44 896 4.9


line stmt bran cond sub pod time code
1             package Net::ManageSieve;
2              
3             =head1 NAME
4              
5             Net::ManageSieve - ManageSieve Protocol Client
6              
7             =head1 SYNOPSIS
8              
9             use Net::ManageSieve;
10              
11             # Constructors
12             $sieve = Net::ManageSieve->new('localhost');
13             $sieve = Net::ManageSieve->new('localhost', Timeout => 60);
14              
15             =head1 DESCRIPTION
16              
17             This module implements a client interface to the ManageSieve protocol
18             (L). This
19             documentation assumes that you are familiar with the concepts of the
20             protocol.
21              
22             A new Net::ManageSieve object must be created with the I method. Once
23             this has been done, all ManageSieve commands are accessed through
24             this object.
25              
26             I: ManageSieve allows to manipulate scripts on a host running a
27             ManageSieve service, this module does not perform, validate or something
28             like that Sieve scipts themselves.
29              
30             This module works in taint mode.
31              
32             =head1 EXAMPLES
33              
34             This example prints the capabilities of the server known as mailhost:
35              
36             #!/usr/local/bin/perl -w
37              
38             use Net::ManageSieve;
39              
40             $sieve = Net::ManageSieve->new('mailhost');
41             print "$k=$v\n" while ($k, $v) = each %{ $sieve->capabilities };
42             $sieve->logout;
43              
44             This example lists all storred scripts on the server and requires TLS:
45              
46             #!/usr/local/bin/perl -w
47              
48             use Net::ManageSieve;
49              
50             my $sieve = Net::ManageSieve->new('mailhost', tls => 'require')
51             or die "$@\n";
52             print "Cipher: ", $sieve->get_cipher(), "\n";
53             $sieve->login('user', 'password')
54             or die "Login: ".$sieve->error()."\n";
55             my $scripts = $sieve->listscripts
56             or die "List: ".$sieve->error()."\n";
57             my $activeScript = pop(@$scripts);
58             print "$_\n" for sort @$scripts;
59             print $activeScript
60             ? 'active script: ' . $activeScript
61             : 'no script active'
62             , "\n";
63             $sieve->logout;
64              
65             =head1 ERROR HANDLING
66              
67             By default all functions return C on failure and set an
68             error description into C<$@>, which can be retrieved with the
69             method C as well.
70              
71             The constructor accepts the setting C, which alters this
72             behaviour by changing the step to assign C<$@>:
73             If its value is:
74              
75             =over 4
76              
77             =item C
78              
79             the program carps the error description.
80              
81             If C is enabled, too, the description is printed twice.
82              
83             =item C
84              
85             the program croaks.
86              
87             =item is a CODE ref
88              
89             this subroutine is called with the arguments:
90              
91             &code_ref ( $object, $error_message )
92              
93             The return value controls, whether or not the error message will be
94             assigned to C<$@>. Private functions may just signal that an error
95             occured, but keep C<$@> unchanged. In this case C<$@> remains unchanged,
96             if code_ref returns true.
97              
98             I: Even if the code ref returns false, C<$@> might bi clobberred
99             by called modules. This is especially true in the C constructor.
100              
101             =item otherwise
102              
103             the default behaviour is retained by setting C<$@>.
104              
105             =back
106              
107             =cut
108              
109             require 5.001;
110              
111 1     1   1045 use strict;
  1         1  
  1         40  
112 1     1   4 use vars qw($VERSION @ISA);
  1         2  
  1         81  
113 1     1   849 use Socket 1.3;
  1         4268  
  1         622  
114 1     1   6 use Carp;
  1         1  
  1         44  
115 1     1   816 use IO::Socket;
  1         17282  
  1         4  
116 1     1   1863 use Encode;
  1         9736  
  1         5096  
117              
118             $VERSION = "0.12";
119              
120             @ISA = qw();
121              
122             =head1 CONSTRUCTOR
123              
124             =over 4
125              
126             =item new ( [ HOST ] [, OPTIONS ] )
127              
128             This is the constructor for a new Net::ManageSieve object. C is the
129             name of the remote host to which an ManageSieve connection is required.
130              
131             C is optional. If C is not given then it may instead be
132             passed as the C option described below. If neither is given then
133             C will be used.
134              
135             C are passed in a hash like fashion, using key and value pairs.
136             Possible options are:
137              
138             B - ManageSieve host to connect to. It may be a single scalar,
139             as defined for the C option in L, or a
140             reference to an array with hosts to try in turn. The L method
141             will return the value which was used to connect to the host.
142              
143             B and B - These parameters are passed directly
144             to IO::Socket to allow binding the socket to a local port.
145              
146             B - Maximum time, in seconds, to wait for a response from the
147             ManageSieve server (default: 120)
148              
149             B - Select a port on the remote host to connect to (default is 2000)
150              
151             B or B - enable debugging if true (default OFF)
152              
153             I: All of the above options are passed through to L.
154              
155             B - issue STARTTLS right after connect. If B is a HASH ref,
156             the mode is in member C, otherwise C itself is the mode and
157             an empty SSL option HASH is passed to L. The C may be
158             one of C to fail, if TLS negotiation fails, or C,
159             C or C, if TLS is to attempt, but a failure is ignored.
160             (Aliases: B, B)
161              
162             B - Changes the error handling of all functions that would
163             otherwise return undef and set C<$@>. See section ERROR HANDLING
164             (Aliases: B)
165              
166             Example:
167              
168             $sieve = Net::ManageSieve->new('mailhost',
169             Timeout => 30,
170             );
171              
172             use the first host one can connect to successfully C on port
173             C<2000>, the default port, then C on port C<2008>.
174              
175             $sieve = Net::ManageSieve->new(Host => [ 'mailhost', 'localhost:2008' ],
176             Timeout => 30,
177             tls => {
178             mode => require,
179             SSL_ca_path => '/usr/ssl/cert',
180             }
181             );
182              
183             =back
184              
185             =cut
186              
187             sub _decodeCap ($$) {
188 0     0     my $self = shift;
189 0           my $cap = shift;
190              
191 0 0         if(ref($cap) eq 'ARRAY') {
192 0           $self->{capabilities} = { };
193 0           while(my $c = shift(@$cap)) {
194 0 0         next if ref($c);
195 0           $c = lc($c); # capability-name
196 0           my @v;
197 0           while(my $v = shift(@$cap)) { # quaff even multiple tokens
198 0 0         last if ref($v);#CRLF # standard allows one
199 0           push(@v, $v); # optional value
200             } # lasr CRLF had been quaffed by ok() already
201 0 0         $self->{capabilities}->{$c}
202             = scalar(@v)? join(',', @v)
203             : '0 but true';
204             }
205             }
206              
207 0           return $self;
208             }
209              
210             sub new {
211 0     0 1   my $self = shift;
212 0   0       my $type = ref($self) || $self;
213 0           $self = bless {}, $type;
214              
215 0           my ($host,%arg);
216 0 0         if(@_ % 2) {
217 0           $host = shift ;
218 0           %arg = @_;
219             } else {
220 0           %arg = @_;
221 0           $host = delete $arg{Host};
222             }
223 0   0       $host ||= 'localhost';
224 0   0       $arg{Proto} ||= 'tcp';
225 0   0       $arg{Port} ||= 'managesieve(2000)';
226 0           $arg{PeerPort} = $arg{Port};
227 0 0         $arg{Timeout} = 120 unless defined $arg{Timeout};
228 0           $self->{timeout} = $arg{Timeout};
229 0           $self->{_last_response} = 'OK no response, yet';
230 0           $self->{_last_error} = '';
231 0           $self->{_last_command} = '';
232 0 0 0       $self->{_debug} = 1 if $arg{Debug} || $arg{debug};
233 0   0       $self->{_on_fail} = delete $arg{on_fail} || delete $arg{On_fail};
234 0   0       $self->{_tls} = delete $arg{tls} || delete $arg{Tls} || delete $arg{TLS};
235              
236 0 0         foreach my $h (@{ref($host) ? $host : [ $host ]}) {
  0            
237 0           $arg{PeerAddr} = $h;
238 0 0         if($self->{fh} = IO::Socket::INET->new(%arg)) {
239 0           $self->{host} = $h;
240 0           last;
241             }
242             }
243              
244 0 0         unless(defined $self->{host}) {
245 0           my $err = $@;
246 0 0         $err = 'failed to connect to host(s): '.$! unless defined $err;
247 0           $self->_set_error($err);
248 0           return undef;
249             }
250              
251 0           $self->{fh}->autoflush(1);
252              
253             # Read the capabilities
254 0           my $cap = $self->_response();
255 0 0         return undef unless $self->ok($cap);
256 0           $self->_decodeCap($cap);
257              
258 0 0         if(my $mode = $self->{_tls}) {
259 0           my $tls;
260 0 0         if(ref($mode) eq 'HASH') {
261 0           $tls = $mode;
262 0   0       $mode = delete $tls->{mode} || 'auto';
263             } else {
264 0           $tls = { }; # no arguments
265             }
266              
267 0 0 0       if($mode && $mode =~ /\A(?:require|auto|yes|on|y)\Z/) {
268 0           my $rc = $self->starttls(%$tls);
269 0 0 0       if(!$rc && $mode eq 'require') {
270 0           my $err = $@;
271 0 0         $err = 'unknown error' unless defined $err;
272 0           $self->_set_error('failed to enable TLS: '.$err);
273 0           return undef;
274             }
275             }
276             }
277              
278 0           return $self;
279             }
280              
281             =head1 METHODS
282              
283             Unless otherwise stated all methods return either a I or I
284             value, with I meaning that the operation was a success. When
285             a method states that it returns a value, failure will be returned as
286             I or an empty list. The error is specified in C<$@> and can be
287             returned with the L method. Please see section ERROR HANDLING
288             for an alternative error handling scheme.
289              
290             =over 4
291              
292             =item close ()
293              
294             Closes the connection to the server. Any already cached data is kept
295             active, though, there should be no pending data, if an user calls this
296             function.
297              
298             =cut
299              
300             sub close {
301 0     0 1   my $self = shift;
302 0 0         return undef unless $self->{fh};
303 0           my $rc = $self->{fh}->close();
304 0           delete $self->{fh};
305 0           return $rc; # we keep locally cached data intentionally
306             }
307              
308             =item starttls ( %SSL_opts )
309              
310             Initiates a TLS session, may be used only before any
311             authentication.
312              
313             The C is a HASH containing any options you can
314             pass to L<< IO::Socket::SSL->new() >>. No one is passed by default.
315              
316             In order to detect in the later run, if the connection is encrypted,
317             use the C function.
318              
319             Return: $self or C on failure - the socket is still
320             functioning, but is not encrypted.
321              
322             =cut
323              
324             sub starttls {
325 0     0 1   my $self = shift;
326 0 0         unless(scalar(@_) % 2 == 0) {
327 0           $@ = 'The argument list must be a HASH';
328 0           return undef;
329             }
330 0           my %opts = @_;
331              
332 0 0         return undef unless $self->ok($self->_command("STARTTLS"));
333              
334             # Initiate TLS
335 0 0         unless(defined &IO::Socket::SSL::new) {
336 0           eval { require IO::Socket::SSL };
  0            
337 0 0         if($@) {
338 0           $self->_set_error('cannot find module IO::Socket::SSL', 'skipAd');
339 0           return undef;
340             }
341             }
342              
343 0           IO::Socket::SSL->start_SSL($self->{fh} , %opts);
344             # In-place upgrade of socket
345 0 0         return undef unless ref($self->{fh}) eq 'IO::Socket::SSL';
346              
347             # success, state now is the same as right after connect
348 0           my $cap = $self->_response();
349 0 0         return undef unless $self->ok($cap);
350 0           $self->_decodeCap($cap);
351              
352 0           return $self;
353             }
354              
355             =item encrypted ()
356              
357             Returns C, if the connection is not encrypted, otherwise
358             C.
359              
360             =cut
361              
362             sub encrypted {
363 0     0 1   my $fh = $_[0]->{fh};
364 0   0       return $fh && ref($fh) && $fh->isa('IO::Socket::SSL');
365             }
366              
367              
368             =item get_cipher (), dump_peer_certificate (), peer_certificate ($field)
369              
370             Returns C, if the connection is not encrypted, otherwise
371             the functions directly calls the equally named function
372             of L.
373              
374             =cut
375              
376             sub _encrypted {
377 0     0     my $fh = $_[0]->{fh};
378 0 0         unless($fh) {
379 0           $_[0]->_set_error('no connection opened');
380 0           return undef;
381             }
382 0 0         unless(encrypted($_[0])) {
383 0           $_[0]->_set_error('connection not encrypted');
384 0           return undef;
385             }
386 0           return $fh;
387             }
388              
389             sub get_cipher {
390 0 0   0 1   return undef unless &_encrypted;
391 0           return $_[0]->{fh}->get_cipher();
392             }
393             sub dump_peer_certificate {
394 0 0   0 1   return undef unless &_encrypted;
395 0           return $_[0]->{fh}->dump_peer_certificate();
396             }
397             sub peer_certificate {
398 0 0   0 1   return undef unless &_encrypted;
399 0           shift;
400 0           return $_[0]->{fh}->peer_certificate(@_);
401             }
402              
403             =item auth (USER [, PASSWORD [, AUTHNAME ] ])
404              
405             Authentificates as C.
406              
407             If the module L is available, this module is tried first. In
408             this case, the C parameter may be a C object, that
409             is not furtherly modified. If C is no C object,
410             C is passed as C, C as C and C
411             as C to C<< Authen::SASL->new() >>. If C is
412             undefined, C is passed as C. This way you can
413             authentificate against Cyrus: C.
414              
415             If L is I available or the initialization of it fails,
416             this function attempts to authentificate via the C method.
417              
418             Aliases: C, C.
419              
420             =cut
421              
422             sub _encode_base64 {
423 0     0     my $self = shift;
424              
425 0 0         unless(defined &MIME::Base64::encode_base64) { # Automatically load it
426 0           eval { require MIME::Base64; };
  0            
427 0 0         if($@) {
428 0           $self->_set_error('failed to load MIME::Base64: ' . $@);
429 0           return undef;
430             }
431             }
432              
433 0           my $r = &MIME::Base64::encode_base64;
434 0 0         $r and $r =~ s/[\s\r\n]+$//s;
435 0           return $r;
436             }
437             sub auth {
438 0     0 1   my ($self, $username, $password, $authname) = @_;
439            
440 0 0         if(my $mech = $self->{capabilities}{sasl}) {
441             # If the server does not announce SASL, we try PLAIN anyway
442 0           my $doSASL = 1;
443 0 0         unless(defined &Authen::SASL::new) { # Automatically load it
444 0           eval { require Authen::SASL; };
  0            
445 0 0         if($@) {
446 0           $self->_set_error("failed to load Authen::SASL: $@\nFallback to PLAIN\n");
447 0           $doSASL = undef;
448             }
449             }
450 0 0         if($doSASL) {
451 0           my $sasl;
452 0 0 0       if(ref($username) && UNIVERSAL::isa($username, 'Authen::SASL')) {
453 0           $sasl = $username;
454             # $sasl->mechanism($mech);
455             } else {
456 0 0         unless(length $username) {
457 0           $self->_set_error("need username or Authen::SASL object");
458 0           return undef;
459             }
460 0 0         unless(defined $authname) {
461 0           $authname = $username;
462             }
463             # for unknown reason to pass in a space
464             # separated string leads to the problem
465             # that $client->mechnism returns the same
466             # string, but ought to return the _used_
467             # mechnism only therefore, we use the
468             # first one of the list
469             # 2008-04-25 ska
470 0           $mech =~ s/\s.*//;
471             # $mech = "LOGIN";
472 0           $sasl = Authen::SASL->new(mechanism=> "".$mech, # without "". the behaviour is funny
473             callback => { user => $username,
474             pass => $password,
475             password => $password, # needed it to work properly
476             authname => $authname,
477             }
478             );
479             }
480              
481             # draft-martin-managesieve-08: service := 'sieve'
482 0           my $client = $sasl->client_new('sieve', $self->{host}, 0);
483             # I did understood the documentation that way that
484             # 'undef' means error, this is wrong. client_start() returns
485             # undef for no initial client response.
486 0           my $msg = $client->client_start;
487 0 0         if($client->mechanism) {
488 0 0         if($msg) {
489             return undef
490 0 0         unless defined($msg = $self->_encode_base64($msg,''));
491 0           $msg = ' "' . $msg . '"';
492             } else {
493 0           $msg = ''; # Empty initial request
494             # Force to load MIME::Encode
495 0 0         return undef unless defined $self->_encode_base64('z');
496             }
497             # Initial response
498 0 0         $self->_send_command(
499             'Authenticate "'. $client->mechanism . '"' . $msg)
500             or return undef;
501 0           while($msg = $self->_token()) {
502 0 0         if(ref($msg)) { # end of command received OK|NO
503 0 0         next if $msg->[0] eq "\n"; #CRLF is a token
504 0           $msg = $self->ok([ $msg ]);
505 0           last;
506             }
507             # MIME::Base64 is definitely loaded here
508             $self->_write(
509 0           '"' . $self->_encode_base64(
510             $client->client_step(
511             MIME::Base64::decode_base64($msg)
512             ), ''
513             ) . "\"\r\n"
514             );
515             }
516              
517 0 0         return $msg if $msg;
518 0           $self->_set_error('SASL authentification failed');
519 0           return undef;
520             }
521 0           $self->_set_error("start of SASL failed");
522             # Circumvent SASL problems by falling back to plain PLAIN
523             }
524             }
525              
526 0           my $r = $self->_encode_base64(
527             join("\0", ($username, $username, $password))
528             , '');
529 0 0         return undef unless defined $r;
530 0           return $self->ok($self->_command('Authenticate "PLAIN" "'.$r.'"'));
531             }
532 0     0 0   sub login { goto &auth; }
533 0     0 0   sub authentificate { goto &auth; }
534              
535             =item logout ()
536              
537             Sends the C command to the server and closes the
538             connection to the server.
539              
540             Aliases: C, C.
541              
542             =cut
543              
544             sub logout {
545 0     0 1   my ($self) = @_;
546              
547 0 0         return 1 unless $self->{fh};
548 0           my $rc = $self->_command("LOGOUT");
549 0           $self->close();
550 0           return $self->ok($rc, 'bye');
551             }
552 0     0 0   sub quit { goto &logout; }
553 0     0 0   sub bye { goto &logout; }
554              
555             =item host ()
556              
557             Returns the remote host of the connection.
558              
559             =cut
560              
561             sub host {
562 0     0 1   my ($self) = @_;
563              
564 0           return $self->{host};
565             }
566              
567             =item capabilities ([reget])
568              
569             Returns the capabilities as HASH ref, e.g.:
570              
571             {
572             'starttls' => 1,
573             'sasl' => 'PLAIN LOGIN',
574             'implementation' => 'dovecot',
575             'sieve' => 'fileinto reject envelope vacation imapflags notify subaddress relational comparator-i;ascii-numeric regex'
576             };
577              
578             If the argument C is specified and is boolean C,
579             the capabilities are reaquired from the server using
580             the I command.
581             Note: The initial capabilities may be different from the set
582             acquired later.
583              
584             =cut
585              
586             sub capabilities {
587 0     0 1   my ($self, $reget) = @_;
588              
589 0 0         if($reget) {
590 0 0         my $cap = $self->_command("CAPABILITY") or return undef;
591 0 0         return undef unless $self->ok($cap);
592 0           $self->_decodeCap($cap);
593             }
594 0           return $self->{capabilities};
595             }
596              
597             =item havespace (NAME, SIZE)
598              
599             Return whether or not a script with the specified size (and name)
600             might fit into the space of the user on the server.
601              
602             Due to various reasons, the result of this function is not very
603             reliable, because in the meantime lots of changes may take place
604             on the server.
605              
606             =cut
607              
608             sub havespace {
609 0     0 1   my ($self, $name, $size) = @_;
610              
611 0 0         unless($size =~ /\A\d+\Z/) {
612 0           $self->_set_error("size is not numeric: $size");
613 0           return undef;
614             }
615 0 0         return undef unless $name = $self->_chkName($name);
616 0           return $self->ok($self->_command("HAVESPACE $name $size"));
617             }
618              
619             =item putscript (NAME, SCRIPT)
620              
621             Stores the C