contrib/scripts/sieve_vacation/IMAP/Sieve.pm

   1 # $Id: Sieve.pm,v 0.4.9b 2001/06/15 19:25:00 alain Exp $
   2
   3 package IMAP::Sieve;
   4
   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;
  12
  13 use vars qw($VERSION);
  14
  15 $VERSION = '0.4.9b';
  16
  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 }
  33
  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 {
  90
  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
 100
 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";
 133
 134     print $fh "$encode\r\n";
 135
 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 }
 173
 174
 175 sub _error {
 176     my $self = shift;
 177     my $func = shift;
 178     my @error = @_;
 179
 180     $self->{'Error'} = join(" ",$self->{'CLASS'}, "[", $func, "]:", @error);
 181 }
 182
 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 }
 213
 214
 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 }
 225
 226 sub putscript {
 227     my $self = shift;
 228     my $len;
 229
 230     if (scalar(@_) != 2)  {
 231         $self->_error("putscript", "incorrect number of arguments");
 232         return 1;
 233     }
 234
 235     my $scriptname = shift;
 236     my $script = shift;
 237
 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 }
 255
 256 sub deletescript {
 257     my $self = shift;
 258
 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;
 282
 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
 296
 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 }
 310
 311 sub setactive {
 312     my $self = shift;
 313
 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 }
 334
 335
 336 sub noop {
 337     my $self = shift;
 338     my ($id, $acl);
 339
 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 }
 355
 356
 357 sub listscripts {
 358     my $self = shift;
 359     my (@scripts);
 360
 361     if (!defined($self->{'Socket'})) {
 362         $self->_error("listscripts", "no connection open to", $self->{'Server'});
 363         return;
 364     }
 365
 366     #send the command
 367     $self->{'Socket'}->print ("LISTSCRIPTS\r\n");
 368
 369     # While we have more to read
 370     while (defined ($_ = $self->_read)) {
 371
 372                 # Exit the loop if we're at the end of the text
 373                 last if (m/^OK.*/);
 374
 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      }
 383
 384      if (/^OK/) {
 385         return @scripts;
 386      } else {
 387
 388
 389
 390     }
 391     if (/^OK/) {
 392         return @scripts;
 393     } else {
 394         $self->_error("list", "couldn't get list for",  ":", $_);
 395         return;
 396     }
 397 }
 398
 399 1;
 400 __END__
 401