← Back to branch summary

~ubuntu-branches/debian/squeeze/sympa/squeeze

« back to all changes in this revision

Viewing changes to src/mail.pm

  • Committer: Bazaar Package Importer
  • Author(s): Christian Perrier
  • Date: 2007-01-20 18:09:28 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20070120180928-0e42mbwg87mlo44y
Tags: 5.2.3-1.2
* Non-maintainer upload to re-fix l10n issues
* As debconf-updatepo was not run in previous versions, the French
  translation was outdated. Hence fix it.
* Remove several duplicate spaces in the debconf templates

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/mail.pm
1
 
# mail.pm - This module includes mail sending functions
2
 
# RCS Identication ; $Revision: 1.18 $ ; $Date: 2002/09/17 09:04:46 $ 
 
1
# mail.pm - This module includes mail sending functions and does the smtp job.
 
2
# RCS Identication ; $Revision: 1.35 $ ; $Date: 2006/03/08 15:17:23 $ 
3
3
#
4
4
# Sympa - SYsteme de Multi-Postage Automatique
5
5
# Copyright (c) 1997, 1998, 1999, 2000, 2001 Comite Reseau des Universites
24
24
require Exporter;
25
25
use Carp;
26
26
@ISA = qw(Exporter);
27
 
@EXPORT = qw(mailback mailarc mailfile set_send_spool);
 
27
@EXPORT = qw(mail_file mail_message mail_forward set_send_spool);
28
28
 
29
29
#use strict;
30
 
 
 
30
use POSIX;
 
31
use Mail::Internet;
31
32
use Conf;
32
33
use Log;
33
34
use Language;
34
35
use List;
 
36
use strict;
 
37
require 'tools.pl';
 
38
 
 
39
#use strict;
35
40
 
36
41
## RCS identification.
37
 
#my $id = '@(#)$Id: mail.pm,v 1.18 2002/09/17 09:04:46 salaun Exp $';
38
 
 
39
 
my $send_spool;
40
 
 
 
42
#my $id = '@(#)$Id: mail.pm,v 1.35 2006/03/08 15:17:23 sympa-authors Exp $';
 
43
 
 
44
my $opensmtp = 0;
 
45
my $fh = 'fh0000000000';        ## File handle for the stream.
 
46
 
 
47
my $max_arg = eval { &POSIX::_SC_ARG_MAX; };
 
48
if ($@) {
 
49
    $max_arg = 4096;
 
50
    printf STDERR gettext("Your system does not conform to the POSIX P1003.1 standard, or\nyour Perl system does not define the _SC_ARG_MAX constant in its POSIX\nlibrary. You must modify the smtp.pm module in order to set a value\nfor variable $max_arg.\n");
 
51
} else {
 
52
    $max_arg = POSIX::sysconf($max_arg);
 
53
}
 
54
 
 
55
my %pid = ();
 
56
 
 
57
my $send_spool; ## for calling context
 
58
 
 
59
 
 
60
 
 
61
#################################### PUBLIC FUNCTIONS ##############################################
 
62
 
 
63
 
 
64
####################################################
 
65
# public set_send_spool      
 
66
####################################################
 
67
# set in global $send_spool, the concerned spool for
 
68
# sending message when it is not done by smtpto
 
69
#    
 
70
# IN : $spool (+): spool concerned by sending
 
71
# OUT :
 
72
#      
 
73
####################################################
41
74
sub set_send_spool {
42
75
    my $spool = pop;
43
76
 
44
77
    $send_spool = $spool;
45
78
}
46
79
 
47
 
## Mail back a response to the given address.
48
 
## Data is a reference to an array or a scalar.
49
 
sub mailback {
50
 
   my($data, $headers, $from, $to, $robot, @rcpt) = @_;
51
 
   do_log('debug2', 'mail::mailback(%s, %s)', $from, join(',', @rcpt));
52
 
 
53
 
   my ($fh, $sympa_file);
 
80
####################################################
 
81
# public mail_file                          
 
82
####################################################
 
83
# send a tt2 file 
 
84
# 
 
85
#  
 
86
# IN : -$filename(+) : tt2 filename (with .tt2) | ''
 
87
#      -$rcpt(+) : SCALAR |ref(ARRAY) : SMTP "RCPT To:" field
 
88
#      -$data(+) : used to parse tt2 file, ref(HASH) with keys :
 
89
#        -return_path(+) : SMTP "MAIL From:" field if send by smtp, 
 
90
#                          "X-Sympa-From:" field if send by spool
 
91
#        -to : "To:" header field
 
92
#        -lang : tt2 language if $filename
 
93
#        -list :  ref(HASH) if $sign_mode = 'smime', keys are :
 
94
#          -name
 
95
#          -dir
 
96
#        -from : "From:" field if not a full msg
 
97
#        -subject : "Subject:" field if not a full msg
 
98
#        -replyto : "Reply-to:" field if not a full msg
 
99
#        -body  : body message if not $filename
 
100
#        -headers : ref(HASH) with keys are headers mail
 
101
#      -$robot(+)
 
102
#      -$sign_mode :'smime' | '' | undef
 
103
#         
 
104
# OUT : 1 | undef
 
105
####################################################
 
106
sub mail_file {
 
107
    my ($filename, $rcpt, $data,$robot,$sign_mode) = @_;
 
108
    &do_log('debug2', 'mail::mail_file(%s, %s, %s)', $filename, $rcpt, $sign_mode);
 
109
 
 
110
    my ($to,$message);
 
111
 
 
112
    ## boolean
 
113
    my $header_possible = 0; # =1 : it is possible there are some headers
 
114
    my %header_ok;           # hash containing no missing headers
 
115
    my $existing_headers = 0;# the message already contains headers
54
116
   
55
 
   my $sympa_email =  &Conf::get_robot_conf($robot, 'sympa');
56
 
 
57
 
   ## Don't fork if used by a CGI (FastCGI problem)
58
 
   if (defined $send_spool) {
59
 
       $sympa_file = "$send_spool/T.$sympa_email.".time.'.'.int(rand(10000));
60
 
       my $rcpt = join ',', @rcpt;
61
 
 
62
 
       unless (open TMP, ">$sympa_file") {
63
 
           &do_log('notice', 'Cannot create %s : %s', $sympa_file, $!);
64
 
           return undef;
 
117
    ## We may receive a list a recepients
 
118
    if (ref ($rcpt)) {
 
119
        unless (ref ($rcpt) eq 'ARRAY') {
 
120
            &do_log('notice', 'mail:mail_file : Wrong type of reference for rcpt');
 
121
            return undef;
 
122
        }
 
123
    }
 
124
 
 
125
    ## TT2 file parsing 
 
126
    if ($filename =~ /\.tt2$/) {
 
127
        my $output;
 
128
        my @path = split /\//, $filename;          
 
129
        &Language::PushLang($data->{'lang'}) if (defined $data->{'lang'});
 
130
        &tt2::parse_tt2($data, $path[$#path], \$output);
 
131
        &Language::PopLang() if (defined $data->{'lang'});
 
132
        $message .= join('',$output);
 
133
        $header_possible = 1;
 
134
 
 
135
    }else { # or not
 
136
        $message .= $data->{'body'};
65
137
       }
66
138
       
67
 
       printf TMP "X-Sympa-To: %s\n", $rcpt;
68
 
       printf TMP "X-Sympa-From: %s\n", $sympa_email;
69
 
       printf TMP "X-Sympa-Checksum: %s\n", &tools::sympa_checksum($rcpt);
 
139
    ## ## Does the message include headers ?
 
140
    if ($header_possible) {
 
141
        foreach my $line (split(/\n/,$message)) {
 
142
            last if ($line=~/^\s*$/);
70
143
       
71
 
       $fh = \*TMP;
72
 
   }else {
73
 
       $fh = smtp::smtpto($sympa_email, \@rcpt);
 
144
            if ($line=~/^[\w-]+:\s+\S/) {
 
145
                $existing_headers=1;
 
146
            }else{
 
147
                last;
 
148
            }
 
149
                
 
150
            foreach my $header ('to','from','subject','reply-to','mime-version', 'content-type','content-transfer-encoding') {
 
151
                if ($line=~/^$header:/i) {
 
152
                    $header_ok{$header} = 1;
 
153
                    last;
 
154
                }
 
155
            }
 
156
        }
74
157
   }
75
158
   
76
159
   ## Charset for encoding
77
 
   my $charset = sprintf (Msg(12, 2, 'us-ascii'));
78
 
 
79
 
   printf $fh "To:  %s\n", MIME::Words::encode_mimewords($to, 'Q', $charset);
80
 
   if ($from eq 'sympa') {
81
 
       printf $fh "From: %s\n", MIME::Words::encode_mimewords((sprintf (Msg(12, 4, 'SYMPA <%s>'), $sympa_email)), 'Q', $charset);
 
160
   my $charset = sprintf (gettext("_charset_"));
 
161
 
 
162
    ## ADD MISSING HEADERS
 
163
    my $headers="";
 
164
 
 
165
    unless ($header_ok{'to'}) {
 
166
 
 
167
        if (ref ($rcpt)) {
 
168
            if ($data->{'to'}) {
 
169
                $to = $data->{'to'};
82
170
   }else {
83
 
       printf $fh "From: %s\n", $from;
84
 
   }
85
 
   foreach my $field (keys %{$headers}) {
86
 
       printf $fh "%s: %s\n", $field, MIME::Words::encode_mimewords($headers->{$field}, 'Q', $charset);
87
 
   }
88
 
   printf $fh "MIME-Version: %s\n", Msg(12, 1, '1.0');
89
 
   printf $fh "Content-Type: text/plain; charset=%s\n", Msg(12, 2, 'us-ascii');
90
 
   printf $fh "Content-Transfer-Encoding: %s\n", Msg(12, 3, '7bit');
91
 
   print $fh "\n";
 
171
                $to = join(",\n   ", @{$rcpt});
 
172
            }
 
173
        }else{
 
174
            $to = $rcpt;
 
175
        }   
 
176
        $headers .= "To: ".MIME::Words::encode_mimewords($to, ('Encode' => 'Q', 'Charset' => $charset))."\n"; 
 
177
    }     
 
178
    unless ($header_ok{'from'}) {
 
179
        if ($data->{'from'} eq 'sympa') {
 
180
            $headers .= "From: ".MIME::Words::encode_mimewords((sprintf ("SYMPA <%s>",&Conf::get_robot_conf($robot, 'sympa'))), ('Encode' => 'Q', 'Charset' => $charset))."\n";
 
181
        } else {
 
182
            $headers .= "From: ".MIME::Words::encode_mimewords($data->{'from'},('Encode' => 'Q', 'Charset' => $charset))."\n"; 
 
183
        }
 
184
   }
 
185
    unless ($header_ok{'subject'}) {
 
186
        $headers .= "Subject: ".MIME::Words::encode_mimewords($data->{'subject'},('Encode' => 'Q', 'Charset' => $charset))."\n";
 
187
   }
 
188
    unless ($header_ok{'reply-to'}) { 
 
189
        $headers .= "Reply-to: ".MIME::Words::encode_mimewords($data->{'replyto'},('Encode' => 'Q', 'Charset' => $charset))."\n" if ($data->{'replyto'})
 
190
    }
 
191
    if ($data->{'headers'}) {
 
192
        foreach my $field (keys %{$data->{'headers'}}) {
 
193
            $headers .= $field.': '.MIME::Words::encode_mimewords($data->{'headers'}{$field},('Encode' => 'Q', 'Charset' => $charset))."\n";
 
194
        }
 
195
    }
 
196
    unless ($header_ok{'mime-version'}) {
 
197
        $headers .= "MIME-Version: 1.0\n";
 
198
    }
 
199
    unless ($header_ok{'content-type'}) {
 
200
        $headers .= "Content-Type: text/plain; charset=$charset\n";
 
201
    }
 
202
    unless ($header_ok{'content-transfer-encoding'}) {
 
203
        $headers .= "Content-Transfer-Encoding:"; 
 
204
        $headers .= gettext("_encoding_");
 
205
        $headers .= "\n";
 
206
    }
 
207
    unless ($existing_headers) {
 
208
        $headers .= "\n";
 
209
   }
 
210
   
 
211
    $message = "$headers"."$message";
92
212
 
93
 
   if (ref($data) eq 'SCALAR') {
94
 
      print $fh $$data;
95
 
   } elsif (ref($data) eq 'ARRAY') {
96
 
      print $fh @$data;
97
 
   }
98
 
   close($fh);
99
 
   
100
 
   if (defined $sympa_file) {
101
 
       my $new_file = $sympa_file;
102
 
       $new_file =~ s/T\.//g;
 
213
    my $listname = '';
 
214
    if (ref($data->{'list'}) eq "HASH") {
 
215
        $listname = $data->{'list'}{'name'};
 
216
    } elsif ($data->{'list'}) {
 
217
        $listname = $data->{'list'};
 
218
    }
103
219
       
104
 
       unless (rename $sympa_file, $new_file) {
105
 
           &do_log('notice', 'Cannot rename %s to %s : %s', $sympa_file, $new_file, $!);
106
 
           return undef;
107
 
       }
108
 
   }
109
 
 
 
220
    ## SENDING
 
221
    if (ref($rcpt)) {
 
222
        unless (defined &sending($message,$rcpt,$data->{'return_path'},$robot,$listname,$sign_mode)) {
 
223
            return undef;
 
224
        }
 
225
    } else {
 
226
        unless (defined &sending($message,\$rcpt,$data->{'return_path'},$robot,$listname,$sign_mode)) {
 
227
            return undef;
 
228
        }
 
229
    }
110
230
   return 1;
111
231
}
112
232
 
113
 
## send an archive file
114
 
sub mailarc {
115
 
   my($filename, $subject, @rcpt) = @_;
116
 
   do_log('debug2', 'mail::mailarc(%s, %s)', $subject, join(',', @rcpt));
117
 
 
118
 
   my($i);
119
 
 
120
 
   if (!open(IN, $filename)) {
121
 
      fatal_err("Can't send %s to %s: %m", $filename, join(',', @rcpt));
122
 
   }
123
 
   my($fh) = &smtp::smtpto($Conf{'robots'}{$robot}{'sympa'} || $Conf{'request'}, \@rcpt);
124
 
   printf $fh "To: %s\n", join(",\n   ", @rcpt);
125
 
   print $fh "Subject: $subject\n";
126
 
   printf $fh "MIME-Version: %s\n", Msg(12, 1, '1.0');
127
 
   printf $fh "Content-Type: text/plain; charset=%s\n", Msg(12, 2, 'us-ascii');
128
 
   printf $fh "Content-Transfer-Encoding: %s\n", Msg(12, 3, '7bit');
129
 
   print $fh "\n";
130
 
   print $fh $i while ($i = <IN>);
131
 
   close($fh);
 
233
 
 
234
####################################################
 
235
# public mail_message                              
 
236
####################################################
 
237
# distribute a message to a list, Crypting if needed
 
238
# 
 
239
# IN : -$message(+) : ref(Message)
 
240
#      -$from(+) : message from
 
241
#      -$robot(+) : robot
 
242
#      -{verp=>[on|off]} : a hash to introduce verp parameters, starting just on or off, later will probably introduce optionnal parameters 
 
243
#      -@rcpt(+) : recepients
 
244
# OUT : -$numsmtp : number of sendmail process | undef
 
245
#       
 
246
####################################################
 
247
sub mail_message {
 
248
    my($message, $list, $verp, @rcpt) = @_;
 
249
   
 
250
 
 
251
    my $host = $list->{'admin'}{'host'};
 
252
    my $robot = $list->{'domain'};
 
253
    my $name = $list->{'name'};
 
254
 
 
255
    # normal return_path (ie used if verp is not enabled)
 
256
    my $from = $list->{'name'}.&Conf::get_robot_conf($robot, 'return_path_suffix').'@'.$host;
 
257
 
 
258
    do_log('debug', 'mail::mail_message(from: %s, , file:%s, %s, verp->%s %d rcpt)', $from, $message->{'filename'}, $message->{'smime_crypted'}, $verp->{'enable'}, $#rcpt+1);
 
259
    
 
260
    
 
261
    my($i, $j, $nrcpt, $size, @sendto);
 
262
    my $numsmtp = 0;
 
263
    
 
264
    ## If message contain a footer or header added by Sympa  use the object message else
 
265
    ## Extract body from original file to preserve signature
 
266
    my ($msg_body, $msg_header);
 
267
    
 
268
    $msg_header = $message->{'msg'}->head;
 
269
    
 
270
    if ($message->{'altered'}) {
 
271
        $msg_body = $message->{'msg'}->body_as_string;
 
272
        
 
273
    }elsif ($message->{'smime_crypted'}) {
 
274
        $msg_body = ${$message->{'msg_as_string'}};
 
275
        
 
276
    }else {
 
277
        ## Get body from original file
 
278
        unless (open MSG, $message->{'filename'}) {
 
279
            do_log ('notice',"mail::mail_message : Unable to open %s:%s",$message->{'filename'},$!);
 
280
            return undef;
 
281
        }
 
282
        my $in_header = 1 ;
 
283
        while (<MSG>) {
 
284
            if ( !$in_header)  { 
 
285
                $msg_body .= $_;       
 
286
            }else {
 
287
                $in_header = 0 if (/^$/); 
 
288
            }
 
289
        }
 
290
        close (MSG);
 
291
    }
 
292
    
 
293
    ## if the message must be crypted,  we need to send it using one smtp session for each rcpt
 
294
    ## n.b. : sendto can send by setting in spool, however, $numsmtp is incremented (=> to change)
 
295
    # ignore verp if crypted. It should be better to do the reverse : allway use verp if crypted (sa 03/01/2006)
 
296
    
 
297
    if (($message->{'smime_crypted'})||($verp->{'enable'} eq 'on')){
 
298
        $numsmtp = 0;
 
299
        while (defined ($i = shift(@rcpt))) {
 
300
            my $return_path = $from;
 
301
            if ($verp->{'enable'} eq 'on') {
 
302
                $return_path = $i ;
 
303
                $return_path =~ s/\@/\=\=a\=\=/; 
 
304
                $return_path = "$Conf{'bounce_email_prefix'}+$return_path\=\=$name\@$robot";
 
305
            }
 
306
            $numsmtp++ if (&sendto($msg_header, $msg_body, $return_path, [$i], $robot, $message->{'smime_crypted'}));
 
307
        }
 
308
        
 
309
        return ($numsmtp);
 
310
    }
 
311
    
 
312
 
 
313
    my %rcpt_by_dom ;
 
314
 
 
315
 
 
316
    while (defined ($i = shift(@rcpt))) {
 
317
        my @k = reverse(split(/[\.@]/, $i));
 
318
        my @l = reverse(split(/[\.@]/, $j));
 
319
 
 
320
        my $dom;
 
321
        if ($i =~ /\@(.*)$/) {
 
322
            $dom = $1;
 
323
            chomp $dom;
 
324
        }
 
325
        $rcpt_by_dom{$dom} += 1 ;
 
326
        &do_log('debug2', "domain: $dom ; rcpt by dom: $rcpt_by_dom{$dom} ; limit for this domain: $Conf{'nrcpt_by_domain'}{$dom}");
 
327
 
 
328
        if (defined ($Conf{'nrcpt_by_domain'}{$dom}) && ( $rcpt_by_dom{$dom} >= $Conf{'nrcpt_by_domain'}{$dom} )){
 
329
            undef %rcpt_by_dom ;
 
330
            $numsmtp++ if (&sendto($msg_header, $msg_body, $from, \@sendto, $robot));
 
331
            $nrcpt = $size = 0;
 
332
            @sendto = ();  
 
333
        }
 
334
        
 
335
        if ($j && $#sendto >= &Conf::get_robot_conf($robot, 'avg') && lc("$k[0] $k[1]") ne lc("$l[0] $l[1]")) {
 
336
            undef %rcpt_by_dom ;
 
337
            $numsmtp++ if (&sendto($msg_header, $msg_body, $from, \@sendto, $robot));
 
338
            $nrcpt = $size = 0;
 
339
            @sendto = ();
 
340
        }
 
341
        if ($#sendto >= 0 && (($size + length($i)) > $max_arg || $nrcpt >= &Conf::get_robot_conf($robot, 'nrcpt'))) {
 
342
            undef %rcpt_by_dom ;
 
343
            $numsmtp++ if (&sendto($msg_header, $msg_body, $from, \@sendto, $robot));
 
344
            $nrcpt = $size = 0;
 
345
            @sendto = ();
 
346
        }
 
347
        $nrcpt++; $size += length($i) + 5;
 
348
        push(@sendto, $i);
 
349
        $j = $i;
 
350
    }
 
351
    if ($#sendto >= 0) {
 
352
        $numsmtp++ if (&sendto($msg_header, $msg_body, $from, \@sendto, $robot));
 
353
        
 
354
    }
 
355
    
 
356
    return $numsmtp;
132
357
}
133
358
 
134
 
## send welcome, bye, expire removed or reminder message to a user
135
 
sub mailfile {
136
 
   my ($filename, $rcpt, $data, $robot, $sign_mode) = @_;
137
 
   do_log('debug2', 'mail::mailfile(%s, %s, %s, %s)', $filename, $rcpt, $robot, $sign_mode);
138
 
 
139
 
   my ($full_msg, $return_path, $sendmail, $to, $sympa_file);
140
 
 
141
 
   ## We may receive a list a recepients
 
359
 
 
360
####################################################
 
361
# public mail_forward                              
 
362
####################################################
 
363
# forward a message.
 
364
# 
 
365
# IN : -$msg(+) : ref(Message)|ref(MIME::Entity)|string
 
366
#      -$from(+) : message from
 
367
#      -$rcpt(+) : ref(SCALAR) | ref(ARRAY)  - recepients
 
368
#      -$robot(+) : robot
 
369
# OUT : 1 | undef
 
370
#
 
371
####################################################
 
372
sub mail_forward {
 
373
    my($msg,$from,$rcpt,$robot)=@_;
 
374
    &do_log('debug3', "mail::mail_forward($from,$rcpt)");
 
375
 
 
376
    my $message;
 
377
    if (ref($msg) eq 'Message') {
 
378
        $message = $msg->{'msg'};
142
379
   
143
 
   if (ref ($rcpt)) {
144
 
       unless (ref ($rcpt) eq 'ARRAY') {
145
 
           &do_log('notice', 'Wrong type of reference for rcpt');
 
380
    } else {
 
381
        $message = $msg;
 
382
    }
 
383
        
 
384
    unless (defined &sending($message,$rcpt,$from,$robot,'','none')) {
 
385
        &do_log('err','mail::mail_forward from %s impossible to send',$from);
146
386
           return undef;
147
387
       }
148
388
 
149
 
#       if ($sign_mode eq 'smime') {
150
 
#          &do_log('notice', 'Cannot sign a message with multiple recepients');
151
 
#          return undef;
152
 
#       }
153
 
 
154
 
       if ($data->{'to'}) {
155
 
           $to = $data->{'to'};
 
389
    return 1;
 
390
}
 
391
 
 
392
#####################################################################
 
393
# public reaper                              
 
394
#####################################################################
 
395
# Non blocking function called by : mail::smtpto(), sympa::main_loop
 
396
#  task_manager::INFINITE_LOOP scanning the queue, 
 
397
#  bounced::infinite_loop scanning the queue, 
 
398
# just to clean the defuncts list by waiting to any processes and 
 
399
#  decrementing the counter. 
 
400
# 
 
401
# IN : $block
 
402
# OUT : $i 
 
403
#####################################################################
 
404
sub reaper {
 
405
   my $block = shift;
 
406
   my $i;
 
407
 
 
408
   $block = 1 unless (defined($block));
 
409
   while (($i = waitpid(-1, $block ? &POSIX::WNOHANG : 0)) > 0) {
 
410
      $block = 1;
 
411
      if (!defined($pid{$i})) {
 
412
         &do_log('debug2', "Reaper waited $i, unknown process to me");
 
413
         next;
 
414
      }
 
415
      $opensmtp--;
 
416
      delete($pid{$i});
 
417
   }
 
418
   &do_log('debug2', "Reaper unwaited pids : %s\nOpen = %s\n", join(' ', sort keys %pid), $opensmtp);
 
419
   return $i;
 
420
}
 
421
     
 
422
 
 
423
#################################### PRIVATE FUNCTIONS ##############################################
 
424
 
 
425
####################################################
 
426
# sendto                              
 
427
####################################################
 
428
# send messages, S/MIME encryption if needed, 
 
429
# grouped sending (or not if encryption)
 
430
#  
 
431
# IN: $msg_header (+): message header : MIME::Head object 
 
432
#     $msg_body (+): message body
 
433
#     $from (+): message from
 
434
#     $rcpt(+) : ref(SCALAR) | ref(ARRAY) - message recepients
 
435
#     $robot(+) : robot
 
436
#     $encrypt : 'smime_crypted' | undef  
 
437
# OUT : 1 - call to smtpto (sendmail) | 0 - push in spool | undef
 
438
#       
 
439
####################################################
 
440
sub sendto {
 
441
    my($msg_header, $msg_body, $from, $rcpt, $robot, $encrypt) = @_;
 
442
    do_log('debug2', 'mail::sendto(%s, %s, %s', $from, $rcpt, $encrypt);
 
443
 
 
444
    my $msg;
 
445
 
 
446
    ## Encode subject before sending
 
447
    $msg_header->replace('Subject', MIME::Words::encode_mimewords($msg_header->get('Subject')));
 
448
 
 
449
    if ($encrypt eq 'smime_crypted') {
 
450
        my $email ;
 
451
        if (ref($rcpt) eq 'SCALAR') {
 
452
            $email = lc ($$rcpt) ;
 
453
        }else{
 
454
            my @rcpts = @$rcpt;
 
455
            if ($#rcpts != 0) {
 
456
                do_log('err',"incorrect call for encrypt with $#rcpts recipient(s)"); 
 
457
                return undef;
 
458
            }
 
459
            $email = lc ($rcpt->[0]); 
 
460
        }
 
461
        $msg = &tools::smime_encrypt ($msg_header, $msg_body, $email);
156
462
       }else {
157
 
           $to = join(",\n   ", @{$rcpt});
 
463
        $msg = $msg_header->as_string . "\n" . $msg_body;
158
464
       }
 
465
    
 
466
    if ($msg) {
 
467
        my $result = &sending($msg,$rcpt,$from,$robot,'','none');
 
468
        return $result;
 
469
 
159
470
   }else{
160
 
       $to = $rcpt;
 
471
        return undef;
161
472
   }   
162
 
 
163
 
   ## Get a FD
164
 
#   unless ($sign_mode eq 'smime') {
165
 
 
166
 
       ## Don't fork if used by a CGI (FastCGI problem)
167
 
       if (defined $send_spool) {
168
 
           my $sympa_email = $data->{'conf'}{'sympa'} || &Conf::get_robot_conf($robot, 'sympa');
169
 
           $sympa_file = "$send_spool/T.$sympa_email.".time.'.'.int(rand(10000));
170
 
           
171
 
           unless (open TMPMSG, ">$sympa_file") {
172
 
               &do_log('notice', 'Cannot create %s : %s', $sympa_file, $!);
173
 
               return undef;
174
 
           }
175
 
 
176
 
           printf TMPMSG "X-Sympa-To: %s\n", $rcpt;
177
 
           printf TMPMSG "X-Sympa-From: %s\n", $data->{'return_path'};
178
 
           printf TMPMSG "X-Sympa-Checksum: %s\n", &tools::sympa_checksum($rcpt);
179
 
           
180
 
           $sendmail = \*TMPMSG;
181
 
       }else {
182
 
           
183
 
           if (ref ($rcpt)) {
184
 
               $sendmail = &smtp::smtpto($data->{'return_path'}, $rcpt);
185
 
           }else {
186
 
               $sendmail = &smtp::smtpto($data->{'return_path'}, \$rcpt);
187
 
           }
188
 
       }
189
 
#  }
190
 
 
191
 
   ## Does the file include headers ?
192
 
   if ($filename =~ /\.tpl$/) {
193
 
       open TPL, $filename;
194
 
       my $first_line = <TPL>;
195
 
       $full_msg = 1 if ($first_line =~ /^From:\s/);
196
 
       close TPL;
197
 
   }
198
 
 
199
 
   ## If message needs to be signed
200
 
   my ($fh, $tmp_file);
201
 
   if ($sign_mode eq 'smime') {
202
 
       $tmp_file = $Conf{'tmpdir'}.'/sympa_mailfile_'.time.'.'.$$;
203
 
 
204
 
       unless (open TMPSMIME, ">$tmp_file") {
205
 
           &do_log('notice', 'Cannot create %s : %s', $tmp_file, $!);
 
473
}
 
474
 
 
475
 
 
476
####################################################
 
477
# sending                              
 
478
####################################################
 
479
# send a message using smpto function or puting it
 
480
# in spool according to the context
 
481
# Signing if needed
 
482
# 
 
483
#  
 
484
# IN : -$msg(+) : ref(MIME::Entity) | string - message to send
 
485
#      -$rcpt(+) : ref(SCALAR) | ref(ARRAY) - recepients 
 
486
#       (for SMTP : "RCPT To:" field)
 
487
#      -$from(+) : for SMTP "MAIL From:" field , for 
 
488
#        spool sending : "X-Sympa-From" field
 
489
#      -$robot(+) : robot
 
490
#      -$listname : listname | ''
 
491
#      -$sign_mode(+) : 'smime' | 'none' for signing
 
492
#      -$sympa_email : for the file name for spool 
 
493
#        sending
 
494
# OUT : 1 - call to smtpto (sendmail) | 0 - push in spool
 
495
#           | undef
 
496
#  
 
497
####################################################
 
498
sub sending {
 
499
    my ($msg,$rcpt,$from,$robot,$listname,$sign_mode,$sympa_email) = @_;
 
500
    &do_log('debug3', 'mail::sending()');
 
501
    my $sympa_file;
 
502
    my $fh;
 
503
    my $signed_msg; # if signing
 
504
    
 
505
 
 
506
    ## FILE HANDLER
 
507
    ## Don't fork if used by a CGI (FastCGI problem)
 
508
    if (defined $send_spool) {
 
509
        unless ($sympa_email) {
 
510
            $sympa_email = &Conf::get_robot_conf($robot, 'sympa');
 
511
        }
 
512
        
 
513
        $sympa_file = "$send_spool/T.$sympa_email.".time.'.'.int(rand(10000));
 
514
        
 
515
        my $all_rcpt;
 
516
        if (ref($rcpt) eq "ARRAY") {
 
517
            $all_rcpt = join (',', @$rcpt);
 
518
        } else {
 
519
            $all_rcpt = $$rcpt;
 
520
        }
 
521
        
 
522
        unless (open TMP, ">$sympa_file") {
 
523
            &do_log('notice', 'mail::sending : Cannot create %s : %s', $sympa_file, $!);
 
524
            return undef;
 
525
        }
 
526
        
 
527
        printf TMP "X-Sympa-To: %s\n", $all_rcpt;
 
528
        printf TMP "X-Sympa-From: %s\n", $from;
 
529
        printf TMP "X-Sympa-Checksum: %s\n", &tools::sympa_checksum($all_rcpt);
 
530
        
 
531
        *SMTP = \*TMP;
 
532
 
 
533
        
 
534
    }else {
 
535
 
 
536
 
 
537
 
 
538
        ## SIGNING 
 
539
        if ($sign_mode eq 'smime') {
 
540
            my $parser = new MIME::Parser;
 
541
            $parser->output_to_core(1);
 
542
            my $in_msg;
 
543
 
 
544
            if (ref($msg) eq "MIME::Entity") {
 
545
                $in_msg = $msg;
 
546
 
 
547
            }else {
 
548
                
 
549
                unless ($in_msg = $parser->parse_data($msg)) { 
 
550
                    &do_log('notice', 'mail::sending : unable to parse message for signing', $listname);
 
551
                    return undef;
 
552
                }
 
553
            }
 
554
            
 
555
            unless ($signed_msg = &tools::smime_sign($in_msg,$listname, $robot)) {
 
556
                &do_log('notice', 'mail::sending : unable to sign message from %s', $listname);
 
557
                return undef;
 
558
            }
 
559
        }
 
560
        
 
561
        *SMTP = &smtpto($from, $rcpt, $robot);
 
562
    }
 
563
 
 
564
   
 
565
 
 
566
    ## WRITING MESSAGE
 
567
    if (ref($signed_msg)) {
 
568
        $signed_msg->print(\*SMTP);
 
569
 
 
570
    }elsif (ref($msg) eq "MIME::Entity") {
 
571
        $msg->print(\*SMTP);
 
572
    
 
573
    }else {
 
574
        print SMTP $msg;
 
575
    }
 
576
    close SMTP;
 
577
 
 
578
    ## If spool sending : renaming file 
 
579
    if (defined $sympa_file) {
 
580
        my $new_file = $sympa_file;
 
581
        $new_file =~ s/T\.//g;
 
582
 
 
583
        unless (rename $sympa_file, $new_file) {
 
584
            &do_log('notice', 'mail::sending : Cannot rename %s to %s : %s', $sympa_file, $new_file, $!);
206
585
           return undef;
207
586
       }
208
 
 
209
 
       $fh = \*TMPSMIME;
 
587
    }
 
588
 
 
589
 
 
590
    if (defined $send_spool) {
 
591
        return 0;
 
592
    } else {
 
593
        return 1;
 
594
   }
 
595
}
 
596
 
 
597
 
 
598
##################################################################################
 
599
# smtpto                               
 
600
##################################################################################
 
601
# Makes a sendmail ready for the recipients given as argument, uses a file 
 
602
# descriptor in the smtp table which can be imported by other parties. 
 
603
# Before, waits for number of children process < number allowed by sympa.conf
 
604
# 
 
605
# IN : $from :(+) for SMTP "MAIL From:" field
 
606
#      $rcpt :(+) ref(SCALAR)|ref(ARRAY)- for SMTP "RCPT To:" field
 
607
#      $robot :(+) robot
 
608
# OUT : mail::$fh - file handle on opened file for ouput, for SMTP "DATA" field
 
609
#       | undef
 
610
#
 
611
##################################################################################
 
612
sub smtpto {
 
613
   my($from, $rcpt, $robot, $sign_mode) = @_;
 
614
 
 
615
   unless ($from) {
 
616
       &do_log('err', 'Missing Return-Path in mail::smtpto()');
 
617
   }
 
618
   
 
619
   if (ref($rcpt) eq 'SCALAR') {
 
620
       &do_log('debug2', 'mail::smtpto(%s, %s, %s )', $from, $$rcpt,$sign_mode);
210
621
   }else {
211
 
       $fh = $sendmail;
212
 
   }
213
 
 
214
 
   printf $fh "To: %s\n", $to;
215
 
 
216
 
 
217
 
   ## Not a complete MIME message
218
 
   unless ( $full_msg or ($filename =~ /\.mime$/) ){
219
 
       print $fh "From: $data->{'from'}\n";
220
 
       print $fh "Subject: $data->{'subject'}\n";
221
 
       print $fh "Reply-to: $data->{'replyto'}\n" if ($data->{'replyto'}) ;
222
 
       printf $fh "MIME-Version: %s\n", Msg(12, 1, '1.0');
223
 
       printf $fh "Content-Type: text/plain; charset=%s\n", Msg(12, 2, 'us-ascii');
224
 
       printf $fh "Content-Transfer-Encoding: %s\n", Msg(12, 3, '7bit');
225
 
       print $fh "\n";
226
 
   }
227
 
 
228
 
   if ($filename) {
229
 
       if ($filename =~ /\.tpl$/) {
230
 
           &parser::parse_tpl($data, $filename, $fh);
231
 
 
 
622
       &do_log('debug2', 'mail::smtpto(%s, %s, %s)', $from, join(',', @{$rcpt}), $sign_mode);
 
623
   }
 
624
   
 
625
   my($pid, $str);
 
626
   
 
627
   ## Escape "-" at beginning of recepient addresses
 
628
   ## prevent sendmail from taking it as argument
 
629
   
 
630
   if (ref($rcpt) eq 'SCALAR') {
 
631
       $$rcpt =~ s/^-/\\-/;
232
632
       }else {
233
 
           ## Old style
234
 
           open IN, $filename;
235
 
           while (<IN>) {
236
 
               s/\[listname\]/$data->{'list'}{'name'}/g;
237
 
               s/\[subscriber_email\]/$data->{'user'}{'email'}/g;
238
 
               s/\[email_subscriber\]/$data->{'user'}{'email'}/g;
239
 
               s/\[subscriber_gecos\]/$data->{'user'}{'gecos'}/g;
240
 
               s/\[sympa_email\]/$data->{'conf'}{'sympa'}/g;
241
 
               s/\[sympa_host\]/$data->{'conf'}{'host'}/g;
242
 
               print $fh $_ ;
 
633
       my @emails = @$rcpt;
 
634
       foreach my $i (0..$#emails) {
 
635
           $rcpt->[$i] =~ s/^-/\\-/;
243
636
           }
244
 
           close IN;
245
 
       }
246
 
   }else{
247
 
       print $fh $data->{'body'};
248
 
   }
249
 
   close ($fh);
250
 
   
251
 
   if ($sign_mode eq 'smime') {
252
 
       ## Open and parse the file   
253
 
       if (!open(MSG, $tmp_file)) {
254
 
           &do_log('info', 'Can\'t open %s: %m', $tmp_file);
255
 
           return undef;
256
 
       }
257
 
    
258
 
       my $parser = new MIME::Parser;
259
 
       $parser->output_to_core(1);
260
 
       my $in_msg;
261
 
       unless ($in_msg = $parser->read(\*MSG)) {
262
 
           do_log('notice', 'Unable to parse message %s', $file);
263
 
           return undef;
264
 
       }
265
 
       close MSG;
266
 
       
267
 
       
268
 
       ## Signing the message
269
 
       my $signed_msg ;
270
 
       unless ($signed_msg = &tools::smime_sign($in_msg,$data->{'list'}{'name'}, $data->{'list'}{'dir'})) {
271
 
           do_log('notice', 'Unable to sign message from %s', $data->{'list'}{'name'});
272
 
           return undef;
273
 
       }
274
 
       # dump signed message to sendmail
275
 
 
276
 
       $signed_msg->print($sendmail);
277
 
       close $sendmail;
278
 
 
279
 
   }
280
 
   
281
 
   if (defined $sympa_file) {
282
 
       my $new_file = $sympa_file;
283
 
       $new_file =~ s/T\.//g;
284
 
 
285
 
       unless (rename $sympa_file, $new_file) {
286
 
           &do_log('notice', 'Cannot rename %s to %s : %s', $sympa_file, $new_file, $!);
287
 
           return undef;
288
 
       }
289
 
   }
290
 
 
291
 
   return 1;
292
 
}
293
 
 
 
637
       }
 
638
   
 
639
   ## Check how many open smtp's we have, if too many wait for a few
 
640
   ## to terminate and then do our job.
 
641
 
 
642
   do_log('debug3',"Open = $opensmtp");
 
643
   while ($opensmtp > &Conf::get_robot_conf($robot, 'maxsmtp')) {
 
644
       do_log('debug3',"mail::smtpto: too many open SMTP ($opensmtp), calling reaper" );
 
645
       last if (&reaper(0) == -1); ## Blocking call to the reaper.
 
646
       }
 
647
    
 
648
   *IN = ++$fh; *OUT = ++$fh;
 
649
   
 
650
 
 
651
   if (!pipe(IN, OUT)) {
 
652
       fatal_err(sprintf gettext("Unable to create a channel in smtpto: %m"), $!); ## No return
 
653
       }
 
654
   $pid = &tools::safefork();
 
655
   $pid{$pid} = 0;
 
656
       
 
657
   my $sendmail = &Conf::get_robot_conf($robot, 'sendmail');
 
658
   my $sendmail_args = &Conf::get_robot_conf($robot, 'sendmail_args');
 
659
       
 
660
   if ($pid == 0) {
 
661
       close(OUT);
 
662
       open(STDIN, "<&IN");
 
663
 
 
664
       if (ref($rcpt) eq 'SCALAR') {
 
665
           exec $sendmail, split(/\s+/,$sendmail_args), '-f', $from, $$rcpt;
 
666
       }else{
 
667
           exec $sendmail, split(/\s+/,$sendmail_args), '-f', $from, @$rcpt;
 
668
       }
 
669
       exit 1; ## Should never get there.
 
670
       }
 
671
   if ($main::options{'mail'}) {
 
672
       $str = "safefork: $sendmail $sendmail_args -f $from ";
 
673
       if (ref($rcpt) eq 'SCALAR') {
 
674
           $str .= $$rcpt;
 
675
       } else {
 
676
           $str .= join(' ', @$rcpt);
 
677
       }
 
678
       do_log('notice', $str);
 
679
   }
 
680
   close(IN);
 
681
   $opensmtp++;
 
682
   select(undef, undef,undef, 0.3) if ($opensmtp < &Conf::get_robot_conf($robot, 'maxsmtp'));
 
683
   return("mail::$fh"); ## Symbol for the write descriptor.
 
684
}
 
685
 
 
686
 
 
687
 
 
688
 
 
689
 
 
690
####################################################
 
691
# send_in_spool      : not used but if needed ...
 
692
####################################################
 
693
# send a message by putting it in global $send_spool
 
694
#   
 
695
# IN : $rcpt (+): ref(SCALAR)|ref(ARRAY) - recepients
 
696
#      $robot(+) : robot
 
697
#      $sympa_email : for the file name
 
698
#      $XSympaFrom : for "X-Sympa-From" field
 
699
# OUT : $return->
 
700
#        -filename : name of temporary file 
 
701
#         needing to be renamed
 
702
#        -fh : file handle opened for writing
 
703
#         on 
 
704
####################################################
 
705
sub send_in_spool {
 
706
    my ($rcpt,$robot,$sympa_email,$XSympaFrom) = @_;
 
707
    &do_log('debug3', 'mail::send_in_spool(%s,%s, %s)',$XSympaFrom,$rcpt);
 
708
    
 
709
    unless ($sympa_email) {
 
710
        $sympa_email = &Conf::get_robot_conf($robot, 'sympa');
 
711
   }
 
712
   
 
713
    unless ($XSympaFrom) {
 
714
        $XSympaFrom = &Conf::get_robot_conf($robot, 'sympa'); 
 
715
    }
 
716
 
 
717
    my $sympa_file = "$send_spool/T.$sympa_email.".time.'.'.int(rand(10000));
 
718
    
 
719
    my $all_rcpt;
 
720
    if (ref($rcpt) eq "ARRAY") {
 
721
        $all_rcpt = join (',', @$rcpt);
 
722
    } else {
 
723
        $all_rcpt = $$rcpt;
 
724
       }
 
725
    
 
726
    unless (open TMP, ">$sympa_file") {
 
727
        &do_log('notice', 'Cannot create %s : %s', $sympa_file, $!);
 
728
        return undef;
 
729
   }
 
730
 
 
731
    printf TMP "X-Sympa-To: %s\n", $all_rcpt;
 
732
    printf TMP "X-Sympa-From: %s\n", $XSympaFrom;
 
733
    printf TMP "X-Sympa-Checksum: %s\n", &tools::sympa_checksum($all_rcpt);
 
734
    
 
735
    my $return;
 
736
    $return->{'filename'} = $sympa_file;     
 
737
    $return->{'fh'} = \*TMP;
 
738
 
 
739
    return $return;
 
740
}
 
741
 
 
742
#####################################################################
294
743
 
295
744
1;
296
745