Filename | /usr/local/libexec/sympa/Sympa/Mailer.pm |
Statements | Executed 2 statements in 13µs |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 13µs | 13µs | _new_instance | Sympa::Mailer::
0 | 0 | 0 | 0s | 0s | BEGIN@27 | Sympa::Mailer::
0 | 0 | 0 | 0s | 0s | BEGIN@28 | Sympa::Mailer::
0 | 0 | 0 | 0s | 0s | BEGIN@29 | Sympa::Mailer::
0 | 0 | 0 | 0s | 0s | BEGIN@31 | Sympa::Mailer::
0 | 0 | 0 | 0s | 0s | BEGIN@32 | Sympa::Mailer::
0 | 0 | 0 | 0s | 0s | BEGIN@34 | Sympa::Mailer::
0 | 0 | 0 | 0s | 0s | BEGIN@35 | Sympa::Mailer::
0 | 0 | 0 | 0s | 0s | BEGIN@36 | Sympa::Mailer::
0 | 0 | 0 | 0s | 0s | __ANON__ (xsub) | Sympa::Mailer::
0 | 0 | 0 | 0s | 0s | _safefork | Sympa::Mailer::
0 | 0 | 0 | 0s | 0s | store | Sympa::Mailer::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | # -*- indent-tabs-mode: nil; -*- | ||||
2 | # vim:ft=perl:et:sw=4 | ||||
3 | # $Id$ | ||||
4 | |||||
5 | # Sympa - SYsteme de Multi-Postage Automatique | ||||
6 | # | ||||
7 | # Copyright (c) 1997, 1998, 1999 Institut Pasteur & Christophe Wolfhugel | ||||
8 | # Copyright (c) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, | ||||
9 | # 2006, 2007, 2008, 2009, 2010, 2011 Comite Reseau des Universites | ||||
10 | # Copyright (c) 2011, 2012, 2013, 2014, 2015, 2016, 2017 GIP RENATER | ||||
11 | # | ||||
12 | # This program is free software; you can redistribute it and/or modify | ||||
13 | # it under the terms of the GNU General Public License as published by | ||||
14 | # the Free Software Foundation; either version 2 of the License, or | ||||
15 | # (at your option) any later version. | ||||
16 | # | ||||
17 | # This program is distributed in the hope that it will be useful, | ||||
18 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | ||||
19 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||||
20 | # GNU General Public License for more details. | ||||
21 | # | ||||
22 | # You should have received a copy of the GNU General Public License | ||||
23 | # along with this program. If not, see <http://www.gnu.org/licenses/>. | ||||
24 | |||||
25 | package Sympa::Mailer; | ||||
26 | |||||
27 | use strict; | ||||
28 | use warnings; | ||||
29 | use base qw(Class::Singleton); | ||||
30 | |||||
31 | use English qw(-no_match_vars); | ||||
32 | use POSIX qw(); | ||||
33 | |||||
34 | use Conf; | ||||
35 | use Sympa::Log; | ||||
36 | use Sympa::Process; | ||||
37 | |||||
38 | my $log = Sympa::Log->instance; | ||||
39 | my $process = Sympa::Process->instance; | ||||
40 | |||||
41 | my $max_arg; | ||||
42 | eval { $max_arg = POSIX::sysconf(POSIX::_SC_ARG_MAX()); }; | ||||
43 | if ($EVAL_ERROR) { | ||||
44 | $max_arg = 4096; | ||||
45 | } | ||||
46 | |||||
47 | # Constructor for Class::Singleton. | ||||
48 | # spent 13µs within Sympa::Mailer::_new_instance which was called:
# once (13µs+0s) by Class::Singleton::instance at line 61 of Class/Singleton.pm | ||||
49 | 1 | 1µs | my $class = shift; | ||
50 | |||||
51 | 1 | 12µs | bless { | ||
52 | _pids => {}, | ||||
53 | redundancy => 1, # Process redundancy (used by bulk.pl). | ||||
54 | log_smtp => undef, # SMTP logging is enabled or not. | ||||
55 | } => $class; | ||||
56 | } | ||||
57 | |||||
58 | #sub set_send_spool($spool_dir); | ||||
59 | #DEPRECATED: No longer used. | ||||
60 | |||||
61 | #sub mail_file($robot, $filename, $rcpt, $data, $return_message_as_string); | ||||
62 | ##DEPRECATED: Use Sympa::Message::Template::new() & send_message(). | ||||
63 | |||||
64 | #sub mail_message($message, $rcpt, [tag_as_last => 1]); | ||||
65 | # DEPRECATED: this is now a subroutine of Sympa::List::distribute_msg(). | ||||
66 | |||||
67 | #sub mail_forward($message, $from, $rcpt, $robot); | ||||
68 | #DEPRECATED: This is no longer used. | ||||
69 | |||||
70 | # DEPRECATED. Use Sympa::Process::reap_child(). | ||||
71 | #sub reaper; | ||||
72 | |||||
73 | #DEPRECATED. | ||||
74 | #sub sendto; | ||||
75 | |||||
76 | # DEPRECATED. Use Sympa::Mailer::store() or Sympa::Spool::Outgoing::store(). | ||||
77 | # Old name: | ||||
78 | # mail::sending(), Sympa::Mail::sending(), Sympa::Mailer::send_message(). | ||||
79 | #sub send_message ($self, $message, $rcpt, %params); | ||||
80 | |||||
81 | sub store { | ||||
82 | my $self = shift; | ||||
83 | my $message = shift; | ||||
84 | my $rcpt = shift; | ||||
85 | my %params = @_; | ||||
86 | |||||
87 | my $return_path = $message->{envelope_sender}; | ||||
88 | my $envid = $params{envid}; | ||||
89 | my $tag = $params{tag}; | ||||
90 | my $logging = (not defined $tag or $tag eq 's' or $tag eq 'z') ? 1 : 0; | ||||
91 | |||||
92 | my @all_rcpt; | ||||
93 | unless (ref $rcpt) { | ||||
94 | @all_rcpt = ($rcpt); | ||||
95 | } elsif (ref $rcpt eq 'SCALAR') { | ||||
96 | @all_rcpt = ($$rcpt); | ||||
97 | } elsif (ref $rcpt eq 'ARRAY') { | ||||
98 | @all_rcpt = @$rcpt; | ||||
99 | } | ||||
100 | |||||
101 | # Stripping Return-Path: pseudo-header field. | ||||
102 | my $msg_string = $message->as_string; | ||||
103 | $msg_string =~ s/\AReturn-Path: (.*?)\n(?![ \t])//s; | ||||
104 | |||||
105 | my $sendmail = $Conf::Conf{'sendmail'}; | ||||
106 | my @sendmail_args = split /\s+/, $Conf::Conf{'sendmail_args'}; | ||||
107 | if (defined $envid and length $envid) { | ||||
108 | # Postfix clone of sendmail command doesn't allow spaces between | ||||
109 | # "-V" and envid. | ||||
110 | # And as it denys "-V" with 2 characters, "0" are padded. | ||||
111 | push @sendmail_args, '-N', 'success,delay,failure', | ||||
112 | sprintf('-V%08s', $envid); | ||||
113 | } | ||||
114 | my $min_cmd_size = | ||||
115 | length($sendmail) + 1 + | ||||
116 | length(join ' ', @sendmail_args) + 1 + | ||||
117 | length("-f $return_path --"); | ||||
118 | my $maxsmtp = | ||||
119 | int($Conf::Conf{'maxsmtp'} / ($self->{redundancy} || 1)) || 1; | ||||
120 | |||||
121 | # Ignore SIGPIPE which may occur at the time of close(). | ||||
122 | local $SIG{PIPE} = 'IGNORE'; | ||||
123 | |||||
124 | my $numsmtp = 0; | ||||
125 | while (@all_rcpt) { | ||||
126 | # Split rcpt by max length of command line (_SC_ARG_MAX). | ||||
127 | my $cmd_size = $min_cmd_size + 1 + length($all_rcpt[0]); | ||||
128 | my @rcpt = (shift @all_rcpt); | ||||
129 | while (@all_rcpt | ||||
130 | and ($cmd_size += 1 + length($all_rcpt[0])) <= $max_arg) { | ||||
131 | push @rcpt, (shift @all_rcpt); | ||||
132 | } | ||||
133 | |||||
134 | # Get sendmail handle. | ||||
135 | |||||
136 | unless ($return_path) { | ||||
137 | $log->syslog('err', 'Missing Return-Path'); | ||||
138 | } | ||||
139 | |||||
140 | # Check how many open smtp's we have, if too many wait for a few | ||||
141 | # to terminate and then do our job. | ||||
142 | $process->sync_child(hash => $self->{_pids}); | ||||
143 | $log->syslog('debug3', 'Open = %s', scalar keys %{$self->{_pids}}); | ||||
144 | while ($maxsmtp < scalar keys %{$self->{_pids}}) { | ||||
145 | $log->syslog( | ||||
146 | 'info', | ||||
147 | 'Too many open SMTP (%s), calling reaper', | ||||
148 | scalar keys %{$self->{_pids}} | ||||
149 | ); | ||||
150 | # Blockng call to the reaper. | ||||
151 | last if $process->wait_child < 0; | ||||
152 | $process->sync_child(hash => $self->{_pids}); | ||||
153 | } | ||||
154 | |||||
155 | my ($pipein, $pipeout, $pid); | ||||
156 | unless (pipe $pipein, $pipeout) { | ||||
157 | die sprintf 'Unable to create a SMTP channel: %s', $ERRNO; | ||||
158 | # No return | ||||
159 | } | ||||
160 | $pid = _safefork($message->get_id); | ||||
161 | $self->{_pids}->{$pid} = 1; | ||||
162 | |||||
163 | unless ($pid) { # _safefork() would die if fork() had failed. | ||||
164 | # Child | ||||
165 | close $pipeout; | ||||
166 | open STDIN, '<&', $pipein; | ||||
167 | |||||
168 | # The '<>' means null sender. | ||||
169 | # Terminate options by "--" to prevent addresses beginning with "-" | ||||
170 | # being treated as options. | ||||
171 | exec $sendmail, @sendmail_args, '-f', | ||||
172 | ($return_path eq '<>' ? '' : $return_path), '--', @rcpt; | ||||
173 | |||||
174 | exit 1; # Should never get there. | ||||
175 | } else { | ||||
176 | # Parent | ||||
177 | if ($self->{log_smtp}) { | ||||
178 | $log->syslog( | ||||
179 | 'notice', | ||||
180 | 'Forked process %d: %s %s -f \'%s\' -- %s', | ||||
181 | $pid, | ||||
182 | $sendmail, | ||||
183 | join(' ', @sendmail_args), | ||||
184 | $return_path, | ||||
185 | join(' ', @rcpt) | ||||
186 | ); | ||||
187 | } | ||||
188 | unless (close $pipein) { | ||||
189 | $log->syslog('err', 'Could not close forked process %d', | ||||
190 | $pid); | ||||
191 | return undef; | ||||
192 | } | ||||
193 | select undef, undef, undef, 0.3 | ||||
194 | if scalar keys %{$self->{_pids}} < $maxsmtp; | ||||
195 | } | ||||
196 | |||||
197 | # Output to handle. | ||||
198 | |||||
199 | print $pipeout $msg_string; | ||||
200 | unless (close $pipeout) { | ||||
201 | $log->syslog('err', 'Failed to close pipe to process %d: %m', | ||||
202 | $pid); | ||||
203 | return undef; | ||||
204 | } | ||||
205 | $numsmtp++; | ||||
206 | } | ||||
207 | |||||
208 | if ($logging) { | ||||
209 | $log->syslog( | ||||
210 | 'notice', | ||||
211 | 'Done sending message %s for %s (priority %s) in %s seconds since scheduled expedition date', | ||||
212 | $message, | ||||
213 | $message->{context}, | ||||
214 | $message->{'priority'}, | ||||
215 | time() - $message->{'date'} | ||||
216 | ); | ||||
217 | } | ||||
218 | |||||
219 | return $numsmtp; | ||||
220 | } | ||||
221 | |||||
222 | # Old names: mail::smtpto(), Sympa::Mail::smtpto(), | ||||
223 | # Sympa::Mailer::get_sendmail_handle(). | ||||
224 | # DEPRECATED: Merged into store(). | ||||
225 | #sub _get_sendmail_handle; | ||||
226 | |||||
227 | #This has never been used. | ||||
228 | #sub send_in_spool($rcpt, $robot, $sympa_email, $XSympaFrom); | ||||
229 | |||||
230 | #DEPRECATED: Use Sympa::Message::reformat_utf8_message(). | ||||
231 | #sub reformat_message($;$$); | ||||
232 | |||||
233 | #DEPRECATED. Moved to Sympa::Message::_fix_utf8_parts as internal functioin. | ||||
234 | #sub fix_part; | ||||
235 | |||||
236 | ## Safefork does several tries before it gives up. | ||||
237 | ## Do 3 trials and wait 10 seconds * $i between each. | ||||
238 | ## Exit with a fatal error is fork failed after all | ||||
239 | ## tests have been exhausted. | ||||
240 | # Old name: tools::safefork(). | ||||
241 | # Note: Use store(). | ||||
242 | sub _safefork { | ||||
243 | my $tag = shift; | ||||
244 | |||||
245 | my $err; | ||||
246 | for (my $i = 1; $i < 4; $i++) { | ||||
247 | my $pid = $process->fork($tag); | ||||
248 | return $pid if defined $pid; | ||||
249 | |||||
250 | $err = $ERRNO; | ||||
251 | $log->syslog('err', 'Cannot create new process: %s', $err); | ||||
252 | #FIXME:should send a mail to the listmaster | ||||
253 | sleep(10 * $i); | ||||
254 | } | ||||
255 | die sprintf 'Exiting because cannot create new process for <%s>: %s', | ||||
256 | $tag, $err; | ||||
257 | # No return. | ||||
258 | } | ||||
259 | |||||
260 | 1; | ||||
261 | __END__ |