← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:11 2021

Filename/usr/local/libexec/sympa/Sympa/Mailer.pm
StatementsExecuted 2 statements in 13µs
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
11113µs13µsSympa::Mailer::::_new_instanceSympa::Mailer::_new_instance
0000s0sSympa::Mailer::::BEGIN@27Sympa::Mailer::BEGIN@27
0000s0sSympa::Mailer::::BEGIN@28Sympa::Mailer::BEGIN@28
0000s0sSympa::Mailer::::BEGIN@29Sympa::Mailer::BEGIN@29
0000s0sSympa::Mailer::::BEGIN@31Sympa::Mailer::BEGIN@31
0000s0sSympa::Mailer::::BEGIN@32Sympa::Mailer::BEGIN@32
0000s0sSympa::Mailer::::BEGIN@34Sympa::Mailer::BEGIN@34
0000s0sSympa::Mailer::::BEGIN@35Sympa::Mailer::BEGIN@35
0000s0sSympa::Mailer::::BEGIN@36Sympa::Mailer::BEGIN@36
0000s0sSympa::Mailer::::__ANON__Sympa::Mailer::__ANON__ (xsub)
0000s0sSympa::Mailer::::_safeforkSympa::Mailer::_safefork
0000s0sSympa::Mailer::::storeSympa::Mailer::store
Call graph for these subroutines as a Graphviz dot language file.
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
25package Sympa::Mailer;
26
27use strict;
28use warnings;
29use base qw(Class::Singleton);
30
31use English qw(-no_match_vars);
32use POSIX qw();
33
34use Conf;
35use Sympa::Log;
36use Sympa::Process;
37
38my $log = Sympa::Log->instance;
39my $process = Sympa::Process->instance;
40
41my $max_arg;
42eval { $max_arg = POSIX::sysconf(POSIX::_SC_ARG_MAX()); };
43if ($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
sub _new_instance {
4911µs my $class = shift;
50
51112µ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
81sub 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().
242sub _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
2601;
261__END__