1 # $Id: Sieve.pm,v 0.4.9b 2001/06/15 19:25:00 alain Exp $
3 package IMAP::Sieve;
5 use strict;
6 use Carp;
7 use IO::Select;
8 use IO::Socket;
9 use IO::Socket::INET;
10 #use Text::ParseWords qw(parse_line);
11 use Cwd;
13 use vars qw($VERSION);
15 $VERSION = '0.4.9b';
17 sub new {
18 my $class = shift;
19 my $self = {};
20 bless $self, $class;
21 if ((scalar(@_) % 2) != 0) {
22 croak "$class called with incorrect number of arguments";
23 }
24 while (@_) {
25 my $key = shift(@_);
26 my $value = shift(@_);
27 $self->{$key} = $value;
28 }
29 $self->{'CLASS'} = $class;
30 $self->_initialize;
31 return $self;
32 }
34 sub _initialize {
35 my $self = shift;
36 my ($len,$userpass,$encode);
37 if (!defined($self->{'Server'})) {
38 croak "$self->{'CLASS'} not initialized properly : Server parameter missing";
39 }
40 if (!defined($self->{'Port'})) {
41 $self->{'Port'} = 2000; # default sieve port;
42 }
43 if (!defined($self->{'Login'})) {
44 croak "$self->{'CLASS'} not initialized properly : Login parameter missing";
45 }
46 if (!defined($self->{'Password'})) {
47 croak "$self->{'CLASS'} not initialized properly : Password parameter missing";
48 }
49 if (!defined($self->{'Proxy'})) {
50 $self->{'Proxy'} = ''; # Proxy;
51 }
52 if (defined($self->{'SSL'})) {
53 my $cwd= cwd;
54 my %ssl_defaults = (
55 'SSL_use_cert' => 0,
56 'SSL_verify_mode' => 0x00,
57 'SSL_key_file' => $cwd."/certs/client-key.pem",
58 'SSL_cert_file' => $cwd."/certs/client-cert.pem",
59 'SSL_ca_path' => $cwd."/certs",
60 'SSL_ca_file' => $cwd."/certs/ca-cert.pem",
61 );
62 my @ssl_options;
63 my $ssl_key;
64 my $key;
65 foreach $ssl_key (keys(%ssl_defaults)) {
66 if (!defined($self->{$ssl_key})) {
67 $self->{$ssl_key} = $ssl_defaults{$ssl_key};
68 }
69 }
70 foreach $ssl_key (keys(%{$self})) {
71 if ($ssl_key =~ /^SSL_/) {
72 push @ssl_options, $ssl_key,$self->{$ssl_key};
73 }
74 }
75 my $SSL_try="use IO::Socket::SSL";
76 eval $SSL_try;
77 if (!eval {$self->{'Socket'} =
78 IO::Socket::SSL->new(PeerAddr => $self->{'Server'},
79 PeerPort => $self->{'Port'},
80 Proto => 'tcp',
81 Reuse => 1,
82 Timeout => 5,
83 @ssl_options);}) {
84 $self->_error("initialize", "couldn't establish a sieve SSL connection to",$self->{'Server'}, "[$!]","path=$cwd");
85 delete $self->{'Socket'};
86 return;
87 }
88 }
89 else {
91 if (!eval {$self->{'Socket'} = IO::Socket::INET->new(PeerAddr => $self->{'Server'},
92 PeerPort => $self->{'Port'},
93 Proto => 'tcp',
94 Reuse => 1); })
95 {
96 $self->_error("initialize", "could'nt establish a Sieve connection to",$self->{'Server'});
97 return;
98 }
99 } # if SSL
101 my $fh = $self->{'Socket'};
102 $_ = $self->_read; #get banner
103 my $try=$_;
104 if (!/timsieved/i) {
105 $self->close;
106 $self->_error("initialize","bad response from",$self->{'Server'},$try);
107 return;
108 }
109 chomp;
110 if (/\r$/) {
111 chop;
112 }
113 if (/IMPLEMENTATION/) {
114 $self->{'Implementation'}=$1 if /^"IMPLEMENTATION" +"(.*)"/;
115 #version 2 of cyrus imap/timsieved
116 # get capability
117 # get OK as well
118 $_=$self->_read;
119 while (!/^OK/) {
120 $self->{'Capability'}=$1 if /^"SASL" +"(.*)"/;
121 $self->{'Sieve'}=$1 if /^"SIEVE" +"(.*)"/;
122 $_ = $self->_read;
123 ## $_=$self->_read;
124 }
125 }
126 else {
127 $self->{'Capability'}=$_;
128 }
129 $userpass = "$self->{'Proxy'}\x00".$self->{'Login'}."\x00".$self->{'Password'};
130 $encode=encode_base64($userpass);
131 $len=length($encode);
132 print $fh "AUTHENTICATE \"PLAIN\" {$len+}\r\n";
134 print $fh "$encode\r\n";
136 $_ = $self->_read;
137 $try=$_;
138 if ($try=~/NO/) {
139 $self->close;
140 $self->_error("Login incorrect while connecting to $self->{'Server'}", $try);
141 return;
142 } elsif (/OK/) {
143 $self->{'Error'}= "No Errors";
144 return;
145 } else {
146 #croak "$self->{'CLASS'}: Unknown error -- $_";
147 $self->_error("Unknown error",$try);
148 return;
149 }
150 $self->{'Error'}="No Errors";
151 return;
152 }
153 sub encode_base64 ($;$)
154 {
155 my $res = "";
156 my $eol = $_[1];
157 $eol = "\n" unless defined $eol;
158 pos($_[0]) = 0; # ensure start at the beginning
159 while ($_[0] =~ /(.{1,45})/gs) {
160 $res .= substr(pack('u', $1), 1);
161 chop($res);
162 }
163 $res =~ tr|` -_|AA-Za-z0-9+/|; # `# help emacs
164 # fix padding at the end
165 my $padding = (3 - length($_[0]) % 3) % 3;
166 $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
167 # break encoded string into lines of no more than 76 characters each
168 if (length $eol) {
169 $res =~ s/(.{1,76})/$1$eol/g;
170 }
171 $res;
172 }
175 sub _error {
176 my $self = shift;
177 my $func = shift;
178 my @error = @_;
180 $self->{'Error'} = join(" ",$self->{'CLASS'}, "[", $func, "]:", @error);
181 }
183 sub _read {
184 my $self = shift;
185 my $buffer ="";
186 my $char = "";
187 my $bytes= 1;
188 while ($bytes == 1) {
189 $bytes = sysread $self->{'Socket'},$char,1;
190 if ($bytes == 0) {
191 if (length ($buffer) != 0) {
192 return $buffer;
193 }
194 else {
195 return;
196 }
197 }
198 else {
199 if (($char eq "\n") or ($char eq "\r")) {
200 if (length($buffer) ==0) {
201 # remove any cr or nl leftover
202 }
203 else {
204 return $buffer;
205 }
206 }
207 else {
208 $buffer.=$char;
209 }
210 }
211 }
212 }
215 sub close {
216 my $self = shift;
217 if (!defined($self->{'Socket'})) {
218 return 0;
219 }
220 my $fh =$self->{'Socket'};
221 print $fh "LOGOUT\r\n";
222 close($self->{'Socket'});
223 delete $self->{'Socket'};
224 }
226 sub putscript {
227 my $self = shift;
228 my $len;
230 if (scalar(@_) != 2) {
231 $self->_error("putscript", "incorrect number of arguments");
232 return 1;
233 }
235 my $scriptname = shift;
236 my $script = shift;
238 if (!defined($self->{'Socket'})) {
239 $self->_error("putscript", "no connection open to", $self->{'Server'});
240 return 1;
241 }
242 $len=length($script);
243 my $fh = $self->{'Socket'};
244 print $fh "PUTSCRIPT \"$scriptname\" {$len+}\r\n";
245 print $fh "$script\r\n";
246 $_ = $self->_read;
247 if (/^OK/) {
248 $self->{'Error'} = 'No Errors';
249 return 0;
250 } else {
251 $self->_error("putscript", "couldn't save script", $scriptname, ":", $_);
252 return 1;
253 }
254 }
256 sub deletescript {
257 my $self = shift;
259 if (scalar(@_) != 1) {
260 $self->_error("deletescript", "incorrect number of arguments");
261 return 1;
262 }
263 my $script = shift;
264 if (!defined($self->{'Socket'})) {
265 $self->_error("deletescript", "no connection open to", $self->{'Server'});
266 return 1;
267 }
268 my $fh = $self->{'Socket'};
269 print $fh "DELETESCRIPT \"$script\"\r\n";
270 $_ = $self->_read;
271 if (/^OK/) {
272 $self->{'Error'} = 'No Errors';
273 return 0;
274 } else {
275 $self->_error("deletescript", "couldn't delete", $script, ":", $_);
276 return 1;
277 }
278 }
279 sub getscript { # returns a string
280 my $self = shift;
281 my $allscript;
283 if (scalar(@_) != 1) {
284 $self->_error("getscript", "incorrect number of arguments");
285 return 1;
286 }
287 my $script = shift;
288 if (!defined($self->{'Socket'})) {
289 $self->_error("getscript", "no connection open to", $self->{'Server'});
290 return 1;
291 }
292 my $fh = $self->{'Socket'};
293 print $fh "GETSCRIPT \"$script\"\r\n";
294 $_ = $self->_read;
295 if (/^{.*}/) { $_ = $self->_read; } # remove file size line
297 # should probably use the file size to calculate how much to read in
298 while ((!/^OK/) && (!/^NO/)) {
299 $_.="\n" if $_ !~/\n.*$/; # replace newline that _read removes
300 $allscript.=$_;
301 $_ = $self->_read;
302 }
303 if (/^OK/) {
304 return $allscript;
305 } else {
306 $self->_error("getscript", "couldn't get script", $script, ":", $_);
307 return;
308 }
309 }
311 sub setactive {
312 my $self = shift;
314 if (scalar(@_) != 1) {
315 $self->_error("setactive", "incorrect number of arguments");
316 return 1;
317 }
318 my $script = shift;
319 if (!defined($self->{'Socket'})) {
320 $self->_error("setactive", "no connection open to", $self->{'Server'});
321 return 1;
322 }
323 my $fh = $self->{'Socket'};
324 print $fh "SETACTIVE \"$script\"\r\n";
325 $_ = $self->_read;
326 if (/^OK/) {
327 $self->{'Error'} = "No Errors";
328 return 0;
329 } else {
330 $self->_error("setactive", "couldn't set as active", $script, ":", $_);
331 return 1;
332 }
333 }
336 sub noop {
337 my $self = shift;
338 my ($id, $acl);
340 if (!defined($self->{'Socket'})) {
341 $self->_error("noop", "no connection open to", $self->{'Server'});
342 return 1;
343 }
344 my $fh = $self->{'Socket'};
345 print $fh "NOOP\r\n";
346 $_ = $self->_read;
347 if (!/^OK/) {
348 $self->_error("noop", "couldn't do noop"
349 );
350 return 1;
351 }
352 $self->{'Error'} = 'No Errors';
353 return 0;
354 }
357 sub listscripts {
358 my $self = shift;
359 my (@scripts);
361 if (!defined($self->{'Socket'})) {
362 $self->_error("listscripts", "no connection open to", $self->{'Server'});
363 return;
364 }
366 #send the command
367 $self->{'Socket'}->print ("LISTSCRIPTS\r\n");
369 # While we have more to read
370 while (defined ($_ = $self->_read)) {
372 # Exit the loop if we're at the end of the text
373 last if (m/^OK.*/);
375 # Select the stuff between the quotes (without the asterisk)
376 # m/^"([^"]+?)\*?"\r?$/;
377 # Select including the asterisk (to determine the default script)
378 # m/^"([^"]+?\*?)"\r?$/;
379 $_=~s/"//g;
380 # Get the name of the script
381 push @scripts, $_;
382 }
384 if (/^OK/) {
385 return @scripts;
386 } else {
390 }
391 if (/^OK/) {
392 return @scripts;
393 } else {
394 $self->_error("list", "couldn't get list for", ":", $_);
395 return;
396 }
397 }
399 1;
400 __END__