Net-ManageSieve-0.13/0000755000175600001460000000000012642447442016006 5ustar skaise2asystemd-journalNet-ManageSieve-0.13/t/0000755000175600001460000000000012642447432016250 5ustar skaise2asystemd-journalNet-ManageSieve-0.13/t/Net-ManageSieve.t0000644000175600001460000000707111070663131021340 0ustar skaise2asystemd-journaluse strict; use warnings FATAL => 'all'; use constant dataf => 'managesieve-test-account'; use Carp; use Test::More; plan tests => 18; use_ok('Net::ManageSieve'); unless(-r dataf) { SKIP: { skip "Install host data file " . dataf . " as described in README", 17; } exit 0; } my %cfg = ( ); if(open(LOGINDATA, '<', dataf)) { while() { chomp; next if /^\s*#/s; # comment next unless s/^\s*(\S+)\s*=\s*//; my $opt = $1; s/\s+$//; if(/^"/s && /"$/s) { # unquote $_ = substr($_, 1, length($_) - 2); } if($opt =~ /^(?:host|port|debug|timeout)$/) { $opt = ucfirst(lc($opt)); } /^(.*)$/s; # untaint $cfg{$opt} = $1; } close LOGINDATA; } croak "Define a host in file " . dataf . " to get host and login data from" unless $cfg{Host}; my $srv = Net::ManageSieve->new(%cfg); ok($srv, "connect to server " . $cfg{Host} . ":" . $cfg{Port}); croak "Need a server connection" unless $srv; my $cap = $srv->capabilities; unless(scalar keys %$cap) { fail("No capabilities returned from server"); } else { my $err = ""; $err .= ", SIEVE" unless $cap->{sieve}; $err .= ", IMPLEMENTATION" unless $cap->{implementation}; if($err) { fail("Missing required capabilities: " . substr($err, 2)); } else { pass("Required capabilities found"); } } SKIP: { skip "TLS already handled by new()", 2 if $srv->encrypted(); skip "TLS disabled in config file", 2 if $cfg{tls} && $cfg{tls} =~ /^(?:disabled?|skip)$/i; skip "No STARTTLS available from server", 2 unless $cap->{starttls}; ok($srv->starttls(), "Test STARTTLS"); ok($srv->get_cipher(), "Test get_cipher"); } SKIP: { skip "No user specified in file " . dataf, 1 unless $cfg{user} ||= $cfg{username}; ok($srv->auth($cfg{user}, $cfg{password}), "TEST Authentificate"); } ok($srv->havespace("TESTSCRIPT", 1), "TEST HaveSpace"); my $scripts = $srv->listscripts(); ok($scripts, "TEST ListScripts"); my $testScriptName = 'tstScript'; if($scripts) { my $i = 0; ++$i while grep { $_ eq $testScriptName . $i } @$scripts; $testScriptName .= $i; } my $testScript = "# Net::ManageSieve TEST SCRIPT\n"; ok($srv->putscript($testScriptName, $testScript), "TEST PutScript"); my $script = $srv->getscript($testScriptName); if($script) { is($script, $testScript, "TEST (re)GetScript"); } else { fail("(re)GetScript"); } my $s; if($s = $srv->listscripts()) { if(grep { $testScriptName eq $_ } @$s) { pass("Script uploaded onto server"); } else { fail("Scrip NOT on server"); $s = undef; } } else { fail("Could not list scripts to verify it is there"); } SKIP: { skip "Skip SetActive as test script is not on server", 4 unless $s; ok($srv->setactive($testScriptName), "TEST SetActive"); if($s = $srv->listscripts()) { my $actScript = pop(@$s); is($actScript, $testScriptName, "Is active script the test script"); } else { fail("Could not list scripts to verify SetActive"); } # Deactive any script ok($srv->setactive(""), "TEST UnActive any script"); if($s = $srv->listscripts()) { my $actScript = pop(@$s); is($actScript, '', "Is active script empty"); } else { fail("Could not list scripts to verify UnSetActive"); } # Reset to old state if($scripts) { my $oldScript = pop(@$scripts); $srv->setactive($oldScript) if $oldScript; } } ok($srv->deletescript($testScriptName), "TEST DeleteScript"); # Invalid Name if(my $o = $srv->putscript($testScriptName."\n", $testScript)) { # Er, shouldn't fail("Uploading script with invalid name not blocked"); $srv->deletescript($testScriptName."\n"); } else { pass("Uploading script with invalid name block succeeded"); } ok($srv->logout(), "TEST Logout"); Net-ManageSieve-0.13/t/pod-coverage.t0000644000175600001460000000045711070663131021004 0ustar skaise2asystemd-journaluse Test::More; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; all_pod_coverage_ok({ trustme => [ qr/^(?:authentificate|bye|dbgPrint|deep_copy|login|ok|quit)$/ ] } , "non-documented functions in Net::ManageSieve package"); Net-ManageSieve-0.13/t/pod.t0000644000175600001460000000020111070663131017176 0ustar skaise2asystemd-journaluse Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Net-ManageSieve-0.13/managesieve-test-account.sample0000644000175600001460000000031011070663130024062 0ustar skaise2asystemd-journalhost = localhost port = 2000 #user = name #password = pwd # next setting allows explicit STARTTLS test #tls = require | yes/auto | no # use next setting to skip TLS test at all #tls = skip #debug = 1 Net-ManageSieve-0.13/Makefile.PL0000644000175600001460000000204011070663130017740 0ustar skaise2asystemd-journaluse 5.000; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( NAME => 'Net::ManageSieve', VERSION_FROM => 'lib/Net/ManageSieve.pm', # finds $VERSION PREREQ_PM => { Socket => 1.3, Carp => 0, # minimal version? IO::Socket => 0, # minimal version? Encode => 0, # minimal version? }, # e.g., Module::Name => 1.1 ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT_FROM => 'lib/Net/ManageSieve.pm', # retrieve abstract from module AUTHOR => 'Steffen Kaiser ') : ()), LIBS => [''], # e.g., '-lm' DEFINE => '', # e.g., '-DHAVE_SOMETHING' INC => '-I.', # e.g., '-I. -I/usr/include/other' SIGN => 1, LICENSE => 'perl', # Un-comment this if you add C files to link with later: # OBJECT => '$(O_FILES)', # link all the C files too ); Net-ManageSieve-0.13/lib/0000755000175600001460000000000012642447432016553 5ustar skaise2asystemd-journalNet-ManageSieve-0.13/lib/Net/0000755000175600001460000000000012642447432017301 5ustar skaise2asystemd-journalNet-ManageSieve-0.13/lib/Net/ManageSieve.pm0000644000175600001460000006773512642447306022045 0ustar skaise2asystemd-journalpackage Net::ManageSieve; =head1 NAME Net::ManageSieve - ManageSieve Protocol Client =head1 SYNOPSIS use Net::ManageSieve; # Constructors $sieve = Net::ManageSieve->new('localhost'); $sieve = Net::ManageSieve->new('localhost', Timeout => 60); =head1 DESCRIPTION This module implements a client interface to the ManageSieve protocol (L). This documentation assumes that you are familiar with the concepts of the protocol. A new Net::ManageSieve object must be created with the I method. Once this has been done, all ManageSieve commands are accessed through this object. I: ManageSieve allows one to manipulate scripts on a host running a ManageSieve service, this module does not perform, validate or something like that Sieve scipts themselves. This module works in taint mode. =head1 EXAMPLES This example prints the capabilities of the server known as mailhost: #!/usr/local/bin/perl -w use Net::ManageSieve; $sieve = Net::ManageSieve->new('mailhost'); print "$k=$v\n" while ($k, $v) = each %{ $sieve->capabilities }; $sieve->logout; This example lists all storred scripts on the server and requires TLS: #!/usr/local/bin/perl -w use Net::ManageSieve; my $sieve = Net::ManageSieve->new('mailhost', tls => 'require') or die "$@\n"; print "Cipher: ", $sieve->get_cipher(), "\n"; $sieve->login('user', 'password') or die "Login: ".$sieve->error()."\n"; my $scripts = $sieve->listscripts or die "List: ".$sieve->error()."\n"; my $activeScript = pop(@$scripts); print "$_\n" for sort @$scripts; print $activeScript ? 'active script: ' . $activeScript : 'no script active' , "\n"; $sieve->logout; =head1 ERROR HANDLING By default all functions return C on failure and set an error description into C<$@>, which can be retrieved with the method C as well. The constructor accepts the setting C, which alters this behaviour by changing the step to assign C<$@>: If its value is: =over 4 =item C the program carps the error description. If C is enabled, too, the description is printed twice. =item C the program croaks. =item is a CODE ref this subroutine is called with the arguments: &code_ref ( $object, $error_message ) The return value controls, whether or not the error message will be assigned to C<$@>. Private functions may just signal that an error occurred, but keep C<$@> unchanged. In this case C<$@> remains unchanged, if code_ref returns true. I: Even if the code ref returns false, C<$@> might bi clobberred by called modules. This is especially true in the C constructor. =item otherwise the default behaviour is retained by setting C<$@>. =back =cut require 5.001; use strict; use vars qw($VERSION @ISA); use Socket 1.3; use Carp; use IO::Socket; use Encode; $VERSION = "0.13"; @ISA = qw(); =head1 CONSTRUCTOR =over 4 =item new ( [ HOST ] [, OPTIONS ] ) This is the constructor for a new Net::ManageSieve object. C is the name of the remote host to which an ManageSieve connection is required. C is optional. If C is not given then it may instead be passed as the C option described below. If neither is given then C will be used. C are passed in a hash like fashion, using key and value pairs. Possible options are: B - ManageSieve host to connect to. It may be a single scalar, as defined for the C option in L, or a reference to an array with hosts to try in turn. The L method will return the value which was used to connect to the host. B and B - These parameters are passed directly to IO::Socket to allow binding the socket to a local port. B - Maximum time, in seconds, to wait for a response from the ManageSieve server (default: 120) B - Select a port on the remote host to connect to (default is 2000) B or B - enable debugging if true (default OFF) I: All of the above options are passed through to L. B - issue STARTTLS right after connect. If B is a HASH ref, the mode is in member C, otherwise C itself is the mode and an empty SSL option HASH is passed to L. The C may be one of C to fail, if TLS negotiation fails, or C, C or C, if TLS is to attempt, but a failure is ignored. (Aliases: B, B) B - Changes the error handling of all functions that would otherwise return undef and set C<$@>. See section ERROR HANDLING (Aliases: B) Example: $sieve = Net::ManageSieve->new('mailhost', Timeout => 30, ); use the first host one can connect to successfully C on port C<2000>, the default port, then C on port C<2008>. $sieve = Net::ManageSieve->new(Host => [ 'mailhost', 'localhost:2008' ], Timeout => 30, tls => { mode => require, SSL_ca_path => '/usr/ssl/cert', } ); =back =cut sub _decodeCap ($$) { my $self = shift; my $cap = shift; if(ref($cap) eq 'ARRAY') { $self->{capabilities} = { }; while(my $c = shift(@$cap)) { next if ref($c); $c = lc($c); # capability-name my @v; while(my $v = shift(@$cap)) { # quaff even multiple tokens last if ref($v);#CRLF # standard allows one push(@v, $v); # optional value } # lasr CRLF had been quaffed by ok() already $self->{capabilities}->{$c} = scalar(@v)? join(',', @v) : '0 but true'; } } return $self; } sub new { my $self = shift; my $type = ref($self) || $self; $self = bless {}, $type; my ($host,%arg); if(@_ % 2) { $host = shift ; %arg = @_; } else { %arg = @_; $host = delete $arg{Host}; } $host ||= 'localhost'; $arg{Proto} ||= 'tcp'; $arg{Port} ||= 'managesieve(2000)'; $arg{PeerPort} = $arg{Port}; $arg{Timeout} = 120 unless defined $arg{Timeout}; $self->{timeout} = $arg{Timeout}; $self->{_last_response} = 'OK no response, yet'; $self->{_last_error} = ''; $self->{_last_command} = ''; $self->{_debug} = 1 if $arg{Debug} || $arg{debug}; $self->{_on_fail} = delete $arg{on_fail} || delete $arg{On_fail}; $self->{_tls} = delete $arg{tls} || delete $arg{Tls} || delete $arg{TLS}; foreach my $h (@{ref($host) ? $host : [ $host ]}) { $arg{PeerAddr} = $h; if($self->{fh} = IO::Socket::INET->new(%arg)) { $self->{host} = $h; last; } } unless(defined $self->{host}) { my $err = $@; $err = 'failed to connect to host(s): '.$! unless defined $err; $self->_set_error($err); return undef; } $self->{fh}->autoflush(1); # Read the capabilities my $cap = $self->_response(); return undef unless $self->ok($cap); $self->_decodeCap($cap); if(my $mode = $self->{_tls}) { my $tls; if(ref($mode) eq 'HASH') { $tls = $mode; $mode = delete $tls->{mode} || 'auto'; } else { $tls = { }; # no arguments } if($mode && $mode =~ /\A(?:require|auto|yes|on|y)\Z/) { my $rc = $self->starttls(%$tls); if(!$rc && $mode eq 'require') { my $err = $@; $err = 'unknown error' unless defined $err; $self->_set_error('failed to enable TLS: '.$err); return undef; } } } return $self; } =head1 METHODS Unless otherwise stated all methods return either a I or I value, with I meaning that the operation was a success. When a method states that it returns a value, failure will be returned as I or an empty list. The error is specified in C<$@> and can be returned with the L method. Please see section ERROR HANDLING for an alternative error handling scheme. =over 4 =item close () Closes the connection to the server. Any already cached data is kept active, though, there should be no pending data, if an user calls this function. =cut sub close { my $self = shift; return undef unless $self->{fh}; my $rc = $self->{fh}->close(); delete $self->{fh}; return $rc; # we keep locally cached data intentionally } =item starttls ( %SSL_opts ) Initiates a TLS session, may be used only before any authentication. The C is a HASH containing any options you can pass to L<< IO::Socket::SSL->new() >>. No one is passed by default. In order to detect in the later run, if the connection is encrypted, use the C function. Return: $self or C on failure - the socket is still functioning, but is not encrypted. =cut sub starttls { my $self = shift; unless(scalar(@_) % 2 == 0) { $@ = 'The argument list must be a HASH'; return undef; } my %opts = @_; return undef unless $self->ok($self->_command("STARTTLS")); # Initiate TLS unless(defined &IO::Socket::SSL::new) { eval { require IO::Socket::SSL }; if($@) { $self->_set_error('cannot find module IO::Socket::SSL', 'skipAd'); return undef; } } IO::Socket::SSL->start_SSL($self->{fh} , %opts); # In-place upgrade of socket return undef unless ref($self->{fh}) eq 'IO::Socket::SSL'; # success, state now is the same as right after connect my $cap = $self->_response(); return undef unless $self->ok($cap); $self->_decodeCap($cap); return $self; } =item encrypted () Returns C, if the connection is not encrypted, otherwise C. =cut sub encrypted { my $fh = $_[0]->{fh}; return $fh && ref($fh) && $fh->isa('IO::Socket::SSL'); } =item get_cipher (), dump_peer_certificate (), peer_certificate ($field) Returns C, if the connection is not encrypted, otherwise the functions directly calls the equally named function of L. =cut sub _encrypted { my $fh = $_[0]->{fh}; unless($fh) { $_[0]->_set_error('no connection opened'); return undef; } unless(encrypted($_[0])) { $_[0]->_set_error('connection not encrypted'); return undef; } return $fh; } sub get_cipher { return undef unless &_encrypted; return $_[0]->{fh}->get_cipher(); } sub dump_peer_certificate { return undef unless &_encrypted; return $_[0]->{fh}->dump_peer_certificate(); } sub peer_certificate { return undef unless &_encrypted; shift; return $_[0]->{fh}->peer_certificate(@_); } =item auth (USER [, PASSWORD [, AUTHNAME ] ]) Authentificates as C. If the module L is available, this module is tried first. In this case, the C parameter may be a C object, that is not furtherly modified. If C is no C object, C is passed as C, C as C and C as C to C<< Authen::SASL->new() >>. If C is undefined, C is passed as C. This way you can authentificate against Cyrus: C. If L is I available or the initialization of it fails, this function attempts to authentificate via the C method. Aliases: C, C. =cut sub _encode_base64 { my $self = shift; unless(defined &MIME::Base64::encode_base64) { # Automatically load it eval { require MIME::Base64; }; if($@) { $self->_set_error('failed to load MIME::Base64: ' . $@); return undef; } } my $r = &MIME::Base64::encode_base64; $r and $r =~ s/[\s\r\n]+$//s; return $r; } sub auth { my ($self, $username, $password, $authname) = @_; if(my $mech = $self->{capabilities}{sasl}) { # If the server does not announce SASL, we try PLAIN anyway my $doSASL = 1; unless(defined &Authen::SASL::new) { # Automatically load it eval { require Authen::SASL; }; if($@) { $self->_set_error("failed to load Authen::SASL: $@\nFallback to PLAIN\n"); $doSASL = undef; } } if($doSASL) { my $sasl; if(ref($username) && UNIVERSAL::isa($username, 'Authen::SASL')) { $sasl = $username; # $sasl->mechanism($mech); } else { unless(length $username) { $self->_set_error("need username or Authen::SASL object"); return undef; } unless(defined $authname) { $authname = $username; } # for unknown reason to pass in a space # separated string leads to the problem # that $client->mechnism returns the same # string, but ought to return the _used_ # mechnism only therefore, we use the # first one of the list # 2008-04-25 ska $mech =~ s/\s.*//; # $mech = "LOGIN"; $sasl = Authen::SASL->new(mechanism=> "".$mech, # without "". the behaviour is funny callback => { user => $username, pass => $password, password => $password, # needed it to work properly authname => $authname, } ); } # draft-martin-managesieve-08: service := 'sieve' my $client = $sasl->client_new('sieve', $self->{host}, 0); # I did understood the documentation that way that # 'undef' means error, this is wrong. client_start() returns # undef for no initial client response. my $msg = $client->client_start; if($client->mechanism) { if($msg) { return undef unless defined($msg = $self->_encode_base64($msg,'')); $msg = ' "' . $msg . '"'; } else { $msg = ''; # Empty initial request # Force to load MIME::Encode return undef unless defined $self->_encode_base64('z'); } # Initial response $self->_send_command( 'Authenticate "'. $client->mechanism . '"' . $msg) or return undef; while($msg = $self->_token()) { if(ref($msg)) { # end of command received OK|NO next if $msg->[0] eq "\n"; #CRLF is a token $msg = $self->ok([ $msg ]); last; } # MIME::Base64 is definitely loaded here $self->_write( '"' . $self->_encode_base64( $client->client_step( MIME::Base64::decode_base64($msg) ), '' ) . "\"\r\n" ); } return $msg if $msg; $self->_set_error('SASL authentification failed'); return undef; } $self->_set_error("start of SASL failed"); # Circumvent SASL problems by falling back to plain PLAIN } } my $r = $self->_encode_base64( join("\0", ($username, $username, $password)) , ''); return undef unless defined $r; return $self->ok($self->_command('Authenticate "PLAIN" "'.$r.'"')); } sub login { goto &auth; } sub authentificate { goto &auth; } =item logout () Sends the C command to the server and closes the connection to the server. Aliases: C, C. =cut sub logout { my ($self) = @_; return 1 unless $self->{fh}; my $rc = $self->_command("LOGOUT"); $self->close(); return $self->ok($rc, 'bye'); } sub quit { goto &logout; } sub bye { goto &logout; } =item host () Returns the remote host of the connection. =cut sub host { my ($self) = @_; return $self->{host}; } =item capabilities ([reget]) Returns the capabilities as HASH ref, e.g.: { 'starttls' => 1, 'sasl' => 'PLAIN LOGIN', 'implementation' => 'dovecot', 'sieve' => 'fileinto reject envelope vacation imapflags notify subaddress relational comparator-i;ascii-numeric regex' }; If the argument C is specified and is boolean C, the capabilities are reaquired from the server using the I command. Note: The initial capabilities may be different from the set acquired later. =cut sub capabilities { my ($self, $reget) = @_; if($reget) { my $cap = $self->_command("CAPABILITY") or return undef; return undef unless $self->ok($cap); $self->_decodeCap($cap); } return $self->{capabilities}; } =item havespace (NAME, SIZE) Return whether or not a script with the specified size (and name) might fit into the space of the user on the server. Due to various reasons, the result of this function is not very reliable, because in the meantime lots of changes may take place on the server. =cut sub havespace { my ($self, $name, $size) = @_; unless($size =~ /\A\d+\Z/) { $self->_set_error("size is not numeric: $size"); return undef; } return undef unless $name = $self->_chkName($name); return $self->ok($self->_command("HAVESPACE $name $size")); } =item putscript (NAME, SCRIPT) Stores the C