Filename | /usr/local/libexec/sympa/Sympa/Log.pm |
Statements | Executed 1204696 statements in 2.05s |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
35436 | 26 | 7 | 1.81s | 7.00s | syslog | Sympa::Log::
70870 | 2 | 1 | 98.2ms | 98.2ms | CORE:match (opcode) | Sympa::Log::
120600 | 1 | 1 | 75.6ms | 75.6ms | CORE:substcont (opcode) | Sympa::Log::
70872 | 2 | 1 | 53.0ms | 53.0ms | CORE:subst (opcode) | Sympa::Log::
0 | 0 | 0 | 0s | 0s | BEGIN@30 | Sympa::Log::
0 | 0 | 0 | 0s | 0s | BEGIN@31 | Sympa::Log::
0 | 0 | 0 | 0s | 0s | BEGIN@32 | Sympa::Log::
0 | 0 | 0 | 0s | 0s | BEGIN@33 | Sympa::Log::
0 | 0 | 0 | 0s | 0s | BEGIN@34 | Sympa::Log::
0 | 0 | 0 | 0s | 0s | BEGIN@35 | Sympa::Log::
0 | 0 | 0 | 0s | 0s | BEGIN@36 | Sympa::Log::
0 | 0 | 0 | 0s | 0s | BEGIN@38 | Sympa::Log::
0 | 0 | 0 | 0s | 0s | BEGIN@40 | Sympa::Log::
0 | 0 | 0 | 0s | 0s | __ANON__ (xsub) | Sympa::Log::
0 | 0 | 0 | 0s | 0s | _aggregate_data | Sympa::Log::
0 | 0 | 0 | 0s | 0s | _connect | Sympa::Log::
0 | 0 | 0 | 0s | 0s | _daemon_name | Sympa::Log::
0 | 0 | 0 | 0s | 0s | _new_instance | Sympa::Log::
0 | 0 | 0 | 0s | 0s | _warn_handler | Sympa::Log::
0 | 0 | 0 | 0s | 0s | add_stat | Sympa::Log::
0 | 0 | 0 | 0s | 0s | aggregate_daily_data | Sympa::Log::
0 | 0 | 0 | 0s | 0s | aggregate_stat | Sympa::Log::
0 | 0 | 0 | 0s | 0s | db_log | Sympa::Log::
0 | 0 | 0 | 0s | 0s | get_first_db_log | Sympa::Log::
0 | 0 | 0 | 0s | 0s | get_log_date | Sympa::Log::
0 | 0 | 0 | 0s | 0s | get_next_db_log | Sympa::Log::
0 | 0 | 0 | 0s | 0s | openlog | Sympa::Log::
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 | # Copyright 2017 The Sympa Community. See the AUTHORS.md file at the top-level | ||||
12 | # directory of this distribution and at | ||||
13 | # <https://github.com/sympa-community/sympa.git>. | ||||
14 | # | ||||
15 | # This program is free software; you can redistribute it and/or modify | ||||
16 | # it under the terms of the GNU General Public License as published by | ||||
17 | # the Free Software Foundation; either version 2 of the License, or | ||||
18 | # (at your option) any later version. | ||||
19 | # | ||||
20 | # This program is distributed in the hope that it will be useful, | ||||
21 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | ||||
22 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||||
23 | # GNU General Public License for more details. | ||||
24 | # | ||||
25 | # You should have received a copy of the GNU General Public License | ||||
26 | # along with this program. If not, see <http://www.gnu.org/licenses/>. | ||||
27 | |||||
28 | package Sympa::Log; | ||||
29 | |||||
30 | use strict; | ||||
31 | use warnings; | ||||
32 | use English qw(-no_match_vars); | ||||
33 | use POSIX qw(); | ||||
34 | use Scalar::Util; | ||||
35 | use Sys::Syslog qw(); | ||||
36 | use Time::Local qw(); | ||||
37 | |||||
38 | use Sympa::Tools::Time; | ||||
39 | |||||
40 | use base qw(Class::Singleton); | ||||
41 | |||||
42 | # Constructor for Class::Singleton. | ||||
43 | sub _new_instance { | ||||
44 | my $class = shift; | ||||
45 | |||||
46 | bless {} => $class; | ||||
47 | } | ||||
48 | |||||
49 | # Old name: Log::do_openlog(). | ||||
50 | sub openlog { | ||||
51 | my $self = shift; | ||||
52 | my $facility = shift; | ||||
53 | my $socket_type = shift; | ||||
54 | my %options = @_; | ||||
55 | |||||
56 | $self->{_facility} = $facility; | ||||
57 | $self->{_socket_type} = $socket_type; | ||||
58 | $self->{_service} = $options{service} || _daemon_name() || 'sympa'; | ||||
59 | $self->{_database_backend} = | ||||
60 | (exists $options{database_backend}) | ||||
61 | ? $options{database_backend} | ||||
62 | : 'Sympa::DatabaseManager'; | ||||
63 | |||||
64 | return $self->_connect(); | ||||
65 | } | ||||
66 | |||||
67 | # When logs are not available, period of time to wait before sending another | ||||
68 | # warning to listmaster. | ||||
69 | my $warning_timeout = 600; | ||||
70 | # Date of the last time a message was sent to warn the listmaster that the | ||||
71 | # logs are unavailable. | ||||
72 | my $warning_date = 0; | ||||
73 | |||||
74 | my %levels = ( | ||||
75 | err => 0, | ||||
76 | info => 0, | ||||
77 | notice => 0, | ||||
78 | trace => 0, | ||||
79 | debug => 1, | ||||
80 | debug2 => 2, | ||||
81 | debug3 => 3, | ||||
82 | ); | ||||
83 | |||||
84 | # Deprecated: No longer used. | ||||
85 | #sub fatal_err; | ||||
86 | |||||
87 | # Old name: Log::do_log(). | ||||
88 | # spent 7.00s (1.81+5.20) within Sympa::Log::syslog which was called 35436 times, avg 198µs/call:
# 5750 times (215ms+746ms) by Sympa::Task::_chk_line at line 330 of /usr/local/libexec/sympa/Sympa/Task.pm, avg 167µs/call
# 3001 times (196ms+483ms) by Sympa::search_fullpath at line 89 of /usr/local/libexec/sympa/Sympa.pm, avg 226µs/call
# 3001 times (156ms+454ms) by Sympa::search_fullpath at line 65 of /usr/local/libexec/sympa/Sympa.pm, avg 203µs/call
# 3001 times (136ms+385ms) by Sympa::get_search_path at line 109 of /usr/local/libexec/sympa/Sympa.pm, avg 174µs/call
# 2754 times (111ms+406ms) by Sympa::Database::do_prepared_query at line 320 of /usr/local/libexec/sympa/Sympa/Database.pm, avg 188µs/call
# 2300 times (184ms+405ms) by Sympa::Spool::unmarshal_metadata at line 389 of /usr/local/libexec/sympa/Sympa/Spool.pm, avg 256µs/call
# 2300 times (107ms+328ms) by Sympa::Spool::unmarshal_metadata at line 457 of /usr/local/libexec/sympa/Sympa/Spool.pm, avg 189µs/call
# 2300 times (111ms+292ms) by Sympa::Task::_chk_cmd at line 414 of /usr/local/libexec/sympa/Sympa/Task.pm, avg 175µs/call
# 1507 times (94.5ms+262ms) by Sympa::Robot::load_topics at line 186 of /usr/local/libexec/sympa/Sympa/Robot.pm, avg 236µs/call
# 1494 times (111ms+233ms) by Sympa::List::_load_edit_list_conf at line 6151 of /usr/local/libexec/sympa/Sympa/List.pm, avg 230µs/call
# 1494 times (75.2ms+230ms) by Sympa::List::load at line 603 of /usr/local/libexec/sympa/Sympa/List.pm, avg 204µs/call
# 1494 times (63.7ms+237ms) by Sympa::List::new at line 108 of /usr/local/libexec/sympa/Sympa/List.pm, avg 202µs/call
# 1377 times (66.0ms+219ms) by Sympa::Task::new at line 109 of /usr/local/libexec/sympa/Sympa/Task.pm, avg 207µs/call
# 1343 times (77.4ms+187ms) by Sympa::List::_load_list_param at line 4869 of /usr/local/libexec/sympa/Sympa/List.pm, avg 197µs/call
# 1150 times (53.7ms+157ms) by Sympa::Task::_parse at line 215 of /usr/local/libexec/sympa/Sympa/Task.pm, avg 183µs/call
# 345 times (19.5ms+50.9ms) by Sympa::List::get_lists at line 4518 of /usr/local/libexec/sympa/Sympa/List.pm, avg 204µs/call
# 345 times (12.7ms+57.2ms) by Sympa::List::get_lists at line 4256 of /usr/local/libexec/sympa/Sympa/List.pm, avg 203µs/call
# 345 times (13.5ms+47.0ms) by Sympa::List::get_lists at line 4464 of /usr/local/libexec/sympa/Sympa/List.pm, avg 175µs/call
# 115 times (2.38ms+13.8ms) by Sympa::List::get_robots at line 4706 of /usr/local/libexec/sympa/Sympa/List.pm, avg 141µs/call
# 13 times (644µs+1.71ms) by Sympa::List::_load_list_config_file at line 4982 of /usr/local/libexec/sympa/Sympa/List.pm, avg 181µs/call
# 2 times (54µs+236µs) by Sympa::Database::do_prepared_query at line 325 of /usr/local/libexec/sympa/Sympa/Database.pm, avg 145µs/call
# once (201µs+489µs) by main::RUNTIME at line 137 of /usr/local/libexec/sympa/task_manager-debug.pl
# once (62µs+188µs) by main::sigterm at line 221 of /usr/local/libexec/sympa/task_manager-debug.pl
# once (50µs+199µs) by Sympa::Database::connect at line 102 of /usr/local/libexec/sympa/Sympa/Database.pm
# once (44µs+197µs) by Sympa::Database::connect at line 185 of /usr/local/libexec/sympa/Sympa/Database.pm
# once (38µs+141µs) by main::RUNTIME at line 159 of /usr/local/libexec/sympa/task_manager-debug.pl | ||||
89 | 35436 | 7.22ms | my $self = shift; | ||
90 | 35436 | 7.19ms | my $level = shift; | ||
91 | 35436 | 6.83ms | my $message = shift; | ||
92 | 35436 | 183ms | my $errno = $ERRNO; | ||
93 | |||||
94 | 35436 | 11.9ms | unless (exists $levels{$level}) { | ||
95 | $self->syslog('err', 'Invalid $level: "%s"', $level); | ||||
96 | $level = 'info'; | ||||
97 | } | ||||
98 | |||||
99 | # do not log if log level is too high regarding the log requested by user | ||||
100 | 35436 | 20.0ms | return if defined $self->{level} and $levels{$level} > $self->{level}; | ||
101 | 35436 | 9.48ms | return if !defined $self->{level} and $levels{$level} > 0; | ||
102 | |||||
103 | # Skip stack frame when warnings are issued. | ||||
104 | 35436 | 59.1ms | local $SIG{__WARN__} = \&_warn_handler; | ||
105 | |||||
106 | ## Do not display variables which are references. | ||||
107 | 35436 | 8.70ms | my @param = (); | ||
108 | 35436 | 159ms | 35436 | 68.4ms | foreach my $fstring (($message =~ /(%.)/g)) { # spent 68.4ms making 35436 calls to Sympa::Log::CORE:match, avg 2µs/call |
109 | 85280 | 19.7ms | next if $fstring eq '%%' or $fstring eq '%m'; | ||
110 | |||||
111 | 85280 | 23.4ms | my $p = shift @_; | ||
112 | 85280 | 342ms | 91169 | 66.8ms | unless (defined $p) { # spent 34.0ms making 69147 calls to Scalar::Util::blessed, avg 492ns/call
# spent 16.6ms making 8709 calls to Sympa::List::get_id, avg 2µs/call
# spent 12.3ms making 12161 calls to UNIVERSAL::can, avg 1µs/call
# spent 3.81ms making 1150 calls to Sympa::Task::get_id, avg 3µs/call
# spent 75µs making 2 calls to Sympa::Database::get_id, avg 38µs/call |
113 | # prevent 'Use of uninitialized value' warning | ||||
114 | push @param, ''; | ||||
115 | } elsif (ref $p eq 'Template::Exception') { | ||||
116 | push @param, $p->as_string; | ||||
117 | } elsif (Scalar::Util::blessed($p) and $p->can('get_id')) { | ||||
118 | push @param, sprintf('%s <%s>', ref $p, $p->get_id); | ||||
119 | } elsif (ref $p eq 'Regexp') { | ||||
120 | push @param, "qr<$p>"; | ||||
121 | } elsif (ref $p) { | ||||
122 | push @param, ref $p; | ||||
123 | } else { | ||||
124 | 52715 | 17.6ms | push @param, $p; | ||
125 | } | ||||
126 | } | ||||
127 | 35436 | 491ms | 156036 | 114ms | $message =~ s/(%.)/($1 eq '%m') ? '%%%%errno%%%%' : $1/eg; # spent 75.6ms making 120600 calls to Sympa::Log::CORE:substcont, avg 627ns/call
# spent 38.1ms making 35436 calls to Sympa::Log::CORE:subst, avg 1µs/call |
128 | 35436 | 44.4ms | $message = sprintf $message, @param; | ||
129 | 35436 | 84.2ms | 35436 | 14.9ms | $message =~ s/%%errno%%/$errno/g; # spent 14.9ms making 35436 calls to Sympa::Log::CORE:subst, avg 421ns/call |
130 | |||||
131 | ## If in 'err' level, build a stack trace, | ||||
132 | ## except if syslog has not been setup yet. | ||||
133 | 35436 | 17.9ms | if (defined $self->{level} and $level eq 'err') { | ||
134 | my $go_back = 0; | ||||
135 | my @calls; | ||||
136 | |||||
137 | my @f = caller($go_back); | ||||
138 | #if ($f[3] and $f[3] =~ /wwslog$/) { | ||||
139 | # ## If called via wwslog, go one step ahead | ||||
140 | # @f = caller(++$go_back); | ||||
141 | #} | ||||
142 | @calls = '#' . $f[2]; | ||||
143 | while (@f = caller(++$go_back)) { | ||||
144 | if ($f[3] and $f[3] =~ /\ASympa::Crash::/) { | ||||
145 | # Discard trace inside crash handler. | ||||
146 | @calls = '#' . $f[2]; | ||||
147 | } else { | ||||
148 | $calls[0] = ($f[3] || '') . $calls[0]; | ||||
149 | unshift @calls, '#' . $f[2]; | ||||
150 | } | ||||
151 | } | ||||
152 | $calls[0] = 'main::' . $calls[0]; | ||||
153 | |||||
154 | my $caller_string = join ' > ', @calls; | ||||
155 | $message = "$caller_string $message"; | ||||
156 | } else { | ||||
157 | 35436 | 97.9ms | my @call = caller(1); | ||
158 | ## If called via wwslog, go one step ahead | ||||
159 | #if ($call[3] and $call[3] =~ /wwslog$/) { | ||||
160 | # @call = caller(2); | ||||
161 | #} | ||||
162 | |||||
163 | 35436 | 8.59ms | my $caller_string = $call[3]; | ||
164 | 35436 | 36.6ms | if (defined $caller_string and length $caller_string) { | ||
165 | 35434 | 137ms | 35434 | 29.8ms | if ($message =~ /\A[(].*[)]/) { # spent 29.8ms making 35434 calls to Sympa::Log::CORE:match, avg 841ns/call |
166 | $message = "$caller_string$message"; | ||||
167 | } else { | ||||
168 | 10241 | 9.28ms | $message = "$caller_string() $message"; | ||
169 | } | ||||
170 | } else { | ||||
171 | 2 | 2µs | $message = "main:: $message"; | ||
172 | } | ||||
173 | } | ||||
174 | |||||
175 | ## Add facility to log entry | ||||
176 | 35436 | 15.6ms | $message = "$level $message"; | ||
177 | |||||
178 | # map to standard syslog facility if needed | ||||
179 | 35436 | 18.7ms | if ($level eq 'trace') { | ||
180 | $message = "###### TRACE MESSAGE ######: " . $message; | ||||
181 | $level = 'notice'; | ||||
182 | } elsif ($level eq 'debug2' or $level eq 'debug3') { | ||||
183 | $level = 'debug'; | ||||
184 | } | ||||
185 | |||||
186 | ## Output to STDERR if needed | ||||
187 | 35436 | 13.8ms | if (not defined $self->{level} | ||
188 | or ($self->{log_to_stderr} | ||||
189 | and ($self->{log_to_stderr} eq 'all' | ||||
190 | or 0 <= index($self->{log_to_stderr}, $level)) | ||||
191 | ) | ||||
192 | ) { | ||||
193 | print STDERR "$message\n"; | ||||
194 | } | ||||
195 | 35436 | 6.90ms | return unless defined $self->{level}; | ||
196 | |||||
197 | # Output to syslog | ||||
198 | # Note: Sys::Syslog <= 0.07 which are bundled in Perl <= 5.8.7 pass | ||||
199 | # $message to sprintf() even when no arguments are given. As a | ||||
200 | # workaround, always pass format string '%s' along with $message. | ||||
201 | 35436 | 11.2ms | eval { | ||
202 | 35436 | 39.9ms | 35436 | 4.90s | unless (Sys::Syslog::syslog($level, '%s', $message)) { # spent 4.90s making 35436 calls to Sys::Syslog::syslog, avg 138µs/call |
203 | $self->_connect(); | ||||
204 | Sys::Syslog::syslog($level, '%s', $message); | ||||
205 | } | ||||
206 | }; | ||||
207 | 35436 | 146ms | if ($EVAL_ERROR and $warning_date < time - $warning_timeout) { | ||
208 | warn sprintf 'No logs available: %s', $EVAL_ERROR; | ||||
209 | $warning_date = time + $warning_timeout; | ||||
210 | } | ||||
211 | } | ||||
212 | |||||
213 | # Old names: Log::set_daemon(), Sympa::Tools::Daemon::get_daemon_name(). | ||||
214 | sub _daemon_name { | ||||
215 | my @path = split /\//, $PROGRAM_NAME; | ||||
216 | my $service = $path[$#path]; | ||||
217 | $service =~ s/(\.[^\.]+)$//; | ||||
218 | return $service; | ||||
219 | } | ||||
220 | |||||
221 | # Old name: Log::do_connect(). | ||||
222 | sub _connect { | ||||
223 | my $self = shift; | ||||
224 | |||||
225 | if ($self->{_socket_type} =~ /^(unix|inet)$/i) { | ||||
226 | Sys::Syslog::setlogsock(lc($self->{_socket_type})); | ||||
227 | } | ||||
228 | # Close log may be useful: If parent processus did open log child | ||||
229 | # process inherit the openlog with parameters from parent process. | ||||
230 | Sys::Syslog::closelog; | ||||
231 | eval { | ||||
232 | Sys::Syslog::openlog(sprintf('%s[%s]', $self->{_service}, $PID), | ||||
233 | 'ndelay,nofatal', $self->{_facility}); | ||||
234 | }; | ||||
235 | if ($EVAL_ERROR && ($warning_date < time - $warning_timeout)) { | ||||
236 | warn sprintf 'No logs available: %s', $EVAL_ERROR; | ||||
237 | $warning_date = time + $warning_timeout; | ||||
238 | return undef; | ||||
239 | } | ||||
240 | |||||
241 | return $self; | ||||
242 | } | ||||
243 | |||||
244 | sub _warn_handler { | ||||
245 | my $message = shift; | ||||
246 | |||||
247 | my $go_back = 0; | ||||
248 | my @f; | ||||
249 | do { @f = caller(++$go_back) } while @f and $f[0] eq __PACKAGE__; | ||||
250 | $message =~ s/ at \S+ line \S+\n*\z/ at $f[1] line $f[2]\n/ if @f; | ||||
251 | print STDERR $message; | ||||
252 | } | ||||
253 | |||||
254 | sub get_log_date { | ||||
255 | my $self = shift; | ||||
256 | |||||
257 | my $sdm; | ||||
258 | unless ($self->{_database_backend} | ||||
259 | and $sdm = $self->{_database_backend}->instance) { | ||||
260 | $self->syslog('err', 'Database backend is not available'); | ||||
261 | return; | ||||
262 | } | ||||
263 | |||||
264 | my $sth; | ||||
265 | my @dates; | ||||
266 | foreach my $query ('MIN', 'MAX') { | ||||
267 | unless ($sth = | ||||
268 | $sdm->do_query("SELECT $query(date_logs) FROM logs_table")) { | ||||
269 | $self->syslog('err', 'Unable to get %s date from logs_table', | ||||
270 | $query); | ||||
271 | return; | ||||
272 | } | ||||
273 | while (my $d = ($sth->fetchrow_array)[0]) { | ||||
274 | push @dates, $d; | ||||
275 | } | ||||
276 | } | ||||
277 | |||||
278 | return @dates; | ||||
279 | } | ||||
280 | |||||
281 | # add log in RDBMS | ||||
282 | sub db_log { | ||||
283 | my $self = shift; | ||||
284 | my %options = @_; | ||||
285 | |||||
286 | my $sdm; | ||||
287 | unless ($self->{_database_backend} | ||||
288 | and $sdm = $self->{_database_backend}->instance) { | ||||
289 | $self->syslog('err', 'Database backend is not available'); | ||||
290 | return undef; | ||||
291 | } | ||||
292 | |||||
293 | my $list = $options{'list'}; | ||||
294 | my $robot = $options{'robot'}; | ||||
295 | my $action = $options{'action'}; | ||||
296 | my $parameters = $options{'parameters'}; | ||||
297 | my $target_email = $options{'target_email'}; | ||||
298 | my $msg_id = $options{'msg_id'}; | ||||
299 | my $status = $options{'status'}; | ||||
300 | my $error_type = $options{'error_type'}; | ||||
301 | my $user_email = $options{'user_email'}; | ||||
302 | my $client = $options{'client'}; | ||||
303 | my $daemon = $self->{_service} || 'sympa'; | ||||
304 | my ($date, $usec) = Sympa::Tools::Time::gettimeofday(); | ||||
305 | |||||
306 | unless ($user_email) { | ||||
307 | $user_email = 'anonymous'; | ||||
308 | } | ||||
309 | unless (defined $list and length $list) { | ||||
310 | $list = ''; | ||||
311 | } elsif ($list =~ /(.+)\@(.+)/) { | ||||
312 | #remove the robot name of the list name | ||||
313 | $list = $1; | ||||
314 | unless ($robot) { | ||||
315 | $robot = $2; | ||||
316 | } | ||||
317 | } | ||||
318 | |||||
319 | # Insert in log_table | ||||
320 | unless ( | ||||
321 | $sdm->do_prepared_query( | ||||
322 | q{INSERT INTO logs_table | ||||
323 | (date_logs, usec_logs, robot_logs, list_logs, action_logs, | ||||
324 | parameters_logs, | ||||
325 | target_email_logs, msg_id_logs, status_logs, error_type_logs, | ||||
326 | user_email_logs, client_logs, daemon_logs) | ||||
327 | VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)}, | ||||
328 | $date, $usec, $robot, $list, $action, | ||||
329 | substr($parameters || '', 0, 100), | ||||
330 | $target_email, $msg_id, $status, $error_type, | ||||
331 | $user_email, $client, $daemon | ||||
332 | ) | ||||
333 | ) { | ||||
334 | $self->syslog('err', | ||||
335 | 'Unable to insert new db_log entry in the database'); | ||||
336 | return undef; | ||||
337 | } | ||||
338 | |||||
339 | return 1; | ||||
340 | } | ||||
341 | |||||
342 | #insert data in stats table | ||||
343 | # Old name: Log::db_stat_log(). | ||||
344 | sub add_stat { | ||||
345 | my $self = shift; | ||||
346 | my %options = @_; | ||||
347 | |||||
348 | my $sdm; | ||||
349 | unless ($self->{_database_backend} | ||||
350 | and $sdm = $self->{_database_backend}->instance) { | ||||
351 | $self->syslog('err', 'Database backend is not available'); | ||||
352 | return undef; | ||||
353 | } | ||||
354 | |||||
355 | my $list = $options{'list'}; | ||||
356 | my $operation = $options{'operation'}; | ||||
357 | my $date = time; | ||||
358 | my $mail = $options{'mail'}; | ||||
359 | my $daemon = $self->{_service} || 'sympa'; | ||||
360 | my $ip = $options{'client'}; | ||||
361 | my $robot = $options{'robot'}; | ||||
362 | my $parameter = $options{'parameter'}; | ||||
363 | my $read = 0; | ||||
364 | |||||
365 | if (ref $list eq 'Sympa::List') { | ||||
366 | $list = $list->{'name'}; | ||||
367 | } elsif ($list and $list =~ /(.+)\@(.+)/) { | ||||
368 | #remove the robot name of the list name | ||||
369 | $list = $1; | ||||
370 | unless ($robot) { | ||||
371 | $robot = $2; | ||||
372 | } | ||||
373 | } | ||||
374 | |||||
375 | ##insert in stat table | ||||
376 | unless ( | ||||
377 | $sdm->do_prepared_query( | ||||
378 | q{INSERT INTO stat_table | ||||
379 | (date_stat, email_stat, operation_stat, list_stat, | ||||
380 | daemon_stat, user_ip_stat, robot_stat, parameter_stat, | ||||
381 | read_stat) | ||||
382 | VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?)}, | ||||
383 | $date, $mail, $operation, $list, | ||||
384 | $daemon, $ip, $robot, $parameter, | ||||
385 | $read | ||||
386 | ) | ||||
387 | ) { | ||||
388 | $self->syslog('err', | ||||
389 | 'Unable to insert new stat entry in the database'); | ||||
390 | return undef; | ||||
391 | } | ||||
392 | return 1; | ||||
393 | } | ||||
394 | |||||
395 | # delete logs in RDBMS | ||||
396 | # MOVED to _db_log_del() in task_manager.pl. | ||||
397 | #sub db_log_del; | ||||
398 | |||||
399 | # Scan log_table with appropriate select | ||||
400 | sub get_first_db_log { | ||||
401 | my $self = shift; | ||||
402 | my $select = shift; | ||||
403 | |||||
404 | my $sdm; | ||||
405 | unless ($self->{_database_backend} | ||||
406 | and $sdm = $self->{_database_backend}->instance) { | ||||
407 | $self->syslog('err', 'Database backend is not available'); | ||||
408 | return undef; | ||||
409 | } | ||||
410 | |||||
411 | # Clear state. | ||||
412 | if ($self->{_sth}) { | ||||
413 | eval { $self->{_sth}->finish; }; | ||||
414 | delete $self->{_sth}; | ||||
415 | } | ||||
416 | |||||
417 | my %action_type = ( | ||||
418 | 'message' => [ | ||||
419 | 'reject', 'distribute', 'arc_delete', 'arc_download', | ||||
420 | 'sendMessage', 'remove', 'record_email', 'send_me', | ||||
421 | 'd_remove_arc', 'rebuildarc', 'remind', 'send_mail', | ||||
422 | 'DoFile', 'sendMessage', 'DoForward', 'DoMessage', | ||||
423 | 'DoCommand', 'SendDigest' | ||||
424 | ], | ||||
425 | 'authentication' => [ | ||||
426 | 'login', 'logout', | ||||
427 | 'loginrequest', 'requestpasswd', | ||||
428 | 'ssologin', 'ssologin_succeses', | ||||
429 | 'remindpasswd', 'choosepasswd' | ||||
430 | ], | ||||
431 | 'subscription' => | ||||
432 | ['subscribe', 'signoff', 'add', 'del', 'ignoresub', 'subindex'], | ||||
433 | 'list_management' => [ | ||||
434 | 'create_list', 'rename_list', | ||||
435 | 'close_list', 'edit_list', | ||||
436 | 'admin', 'blocklist', | ||||
437 | 'install_pending_list', 'purge_list', | ||||
438 | 'edit_template', 'copy_template', | ||||
439 | 'remove_template' | ||||
440 | ], | ||||
441 | 'bounced' => ['resetbounce', 'get_bounce'], | ||||
442 | 'preferences' => [ | ||||
443 | 'set', 'setpref', 'pref', 'change_email', | ||||
444 | 'setpasswd', 'editsubscriber' | ||||
445 | ], | ||||
446 | 'shared' => [ | ||||
447 | 'd_unzip', 'd_upload', | ||||
448 | 'd_read', 'd_delete', | ||||
449 | 'd_savefile', 'd_overwrite', | ||||
450 | 'd_create_dir', 'd_set_owner', | ||||
451 | 'd_change_access', 'd_describe', | ||||
452 | 'd_rename', 'd_editfile', | ||||
453 | 'd_admin', 'd_install_shared', | ||||
454 | 'd_reject_shared', 'd_properties', | ||||
455 | 'creation_shared_file', 'd_unzip_shared_file', | ||||
456 | 'install_file_hierarchy', 'd_copy_rec_dir', | ||||
457 | 'd_copy_file', 'change_email', | ||||
458 | 'set_lang', 'new_d_read', | ||||
459 | 'd_control' | ||||
460 | ], | ||||
461 | ); | ||||
462 | |||||
463 | my $statement = sprintf q{SELECT date_logs, usec_logs AS usec, | ||||
464 | robot_logs AS robot, list_logs AS list, | ||||
465 | action_logs AS action, | ||||
466 | parameters_logs AS parameters, | ||||
467 | target_email_logs AS target_email, | ||||
468 | msg_id_logs AS msg_id, status_logs AS status, | ||||
469 | error_type_logs AS error_type, | ||||
470 | user_email_logs AS user_email, | ||||
471 | client_logs AS client, daemon_logs AS daemon | ||||
472 | FROM logs_table | ||||
473 | WHERE robot_logs = %s }, $sdm->quote($select->{'robot'}); | ||||
474 | |||||
475 | if ( $select->{target_type} | ||||
476 | and $select->{target_type} ne 'none' | ||||
477 | and $select->{target_type} =~ /\A\w+\z/ | ||||
478 | and $select->{target}) { | ||||
479 | # If a type of target and a target are specified: | ||||
480 | $statement .= sprintf 'AND %s_logs = %s ', | ||||
481 | lc $select->{target_type}, $sdm->quote(lc $select->{target}); | ||||
482 | } elsif ($select->{type} | ||||
483 | and $select->{type} ne 'none' | ||||
484 | and $select->{type} ne 'all_actions' | ||||
485 | and $action_type{$select->{type}}) { | ||||
486 | # If the search is on a precise type: | ||||
487 | $statement .= sprintf 'AND (%s) ', | ||||
488 | join ' OR ', | ||||
489 | map { sprintf "logs_table.action_logs = '%s'", $_ } | ||||
490 | @{$action_type{$select->{'type'}}}; | ||||
491 | } | ||||
492 | |||||
493 | #if the search is between two date | ||||
494 | if ($select->{'date_from'}) { | ||||
495 | my ($yyyy, $mm, $dd) = split /[^\da-z]/i, $select->{'date_from'}; | ||||
496 | ($dd, $mm, $yyyy) = ($yyyy, $mm, $dd) if 31 < $dd; | ||||
497 | $yyyy += ($yyyy < 50 ? 2000 : $yyyy < 100 ? 1900 : 0); | ||||
498 | |||||
499 | my $date_from = POSIX::mktime(0, 0, -1, $dd, $mm - 1, $yyyy - 1900); | ||||
500 | unless ($select->{'date_to'}) { | ||||
501 | my $date_from2 = | ||||
502 | POSIX::mktime(0, 0, 25, $dd, $mm - 1, $yyyy - 1900); | ||||
503 | $statement .= sprintf "AND date_logs >= %s AND date_logs <= %s ", | ||||
504 | $date_from, $date_from2; | ||||
505 | } else { | ||||
506 | my ($yyyy, $mm, $dd) = split /[^\da-z]/i, $select->{'date_to'}; | ||||
507 | ($dd, $mm, $yyyy) = ($yyyy, $mm, $dd) if 31 < $dd; | ||||
508 | $yyyy += ($yyyy < 50 ? 2000 : $yyyy < 100 ? 1900 : 0); | ||||
509 | |||||
510 | my $date_to = POSIX::mktime(0, 0, 25, $dd, $mm - 1, $yyyy - 1900); | ||||
511 | $statement .= sprintf "AND date_logs >= %s AND date_logs <= %s ", | ||||
512 | $date_from, $date_to; | ||||
513 | } | ||||
514 | } | ||||
515 | |||||
516 | # if the listmaster want to make a search by an IP address. | ||||
517 | if ($select->{'ip'}) { | ||||
518 | $statement .= sprintf ' AND client_logs = %s ', | ||||
519 | $sdm->quote($select->{'ip'}); | ||||
520 | } | ||||
521 | |||||
522 | ## Currently not used | ||||
523 | #if the search is on the actor of the action | ||||
524 | if ($select->{'user_email'}) { | ||||
525 | $select->{'user_email'} = lc($select->{'user_email'}); | ||||
526 | $statement .= sprintf "AND user_email_logs = '%s' ", | ||||
527 | $select->{'user_email'}; | ||||
528 | } | ||||
529 | |||||
530 | #if a list is specified -just for owner or above- | ||||
531 | if ($select->{'list'}) { | ||||
532 | $select->{'list'} = lc($select->{'list'}); | ||||
533 | $statement .= sprintf "AND list_logs = '%s' ", $select->{'list'}; | ||||
534 | } | ||||
535 | |||||
536 | # Unknown sort key as 'date'. | ||||
537 | my $sortby = $select->{'sortby'}; | ||||
538 | unless ( | ||||
539 | $sortby | ||||
540 | and grep { $sortby eq $_ } | ||||
541 | qw(date robot list action parameters target_email msg_id | ||||
542 | status error_type user_email client daemon) | ||||
543 | ) { | ||||
544 | $sortby = 'date'; | ||||
545 | } | ||||
546 | $statement .= sprintf 'ORDER BY %s ', | ||||
547 | ($sortby eq 'date' ? 'date_logs, usec_logs' : $sortby . '_logs'); | ||||
548 | |||||
549 | my $sth; | ||||
550 | unless ($sth = $sdm->do_query($statement)) { | ||||
551 | $self->syslog('err', | ||||
552 | 'Unable to retrieve logs entry from the database'); | ||||
553 | return undef; | ||||
554 | } | ||||
555 | $self->{_sth} = $sth; | ||||
556 | |||||
557 | my $row = $sth->fetchrow_hashref('NAME_lc'); | ||||
558 | |||||
559 | ## If no rows returned, return an empty hash | ||||
560 | ## Required to differenciate errors and empty results | ||||
561 | unless ($row) { | ||||
562 | return {}; | ||||
563 | } | ||||
564 | |||||
565 | ## We can't use the "AS date" directive in the SELECT statement because | ||||
566 | ## "date" is a reserved keywork with Oracle | ||||
567 | $row->{date} = $row->{date_logs} if defined $row->{date_logs}; | ||||
568 | return $row; | ||||
569 | |||||
570 | } | ||||
571 | |||||
572 | sub get_next_db_log { | ||||
573 | my $self = shift; | ||||
574 | |||||
575 | my $sth = $self->{_sth}; | ||||
576 | die 'Bug in logic. Ask developer' unless $sth; | ||||
577 | |||||
578 | my $row = $sth->fetchrow_hashref('NAME_lc'); | ||||
579 | |||||
580 | unless (defined $row) { | ||||
581 | $sth->finish; | ||||
582 | delete $self->{_sth}; | ||||
583 | } | ||||
584 | |||||
585 | ## We can't use the "AS date" directive in the SELECT statement because | ||||
586 | ## "date" is a reserved keywork with Oracle | ||||
587 | $row->{date} = $row->{date_logs} if defined $row->{date_logs}; | ||||
588 | |||||
589 | return $row; | ||||
590 | } | ||||
591 | |||||
592 | # Data aggregation, to make statistics. | ||||
593 | sub aggregate_stat { | ||||
594 | my $self = shift; | ||||
595 | |||||
596 | my $sdm; | ||||
597 | unless ($self->{_database_backend} | ||||
598 | and $sdm = $self->{_database_backend}->instance) { | ||||
599 | $self->syslog('err', 'Database backend is not available'); | ||||
600 | return undef; | ||||
601 | } | ||||
602 | |||||
603 | my (@time, $sth); | ||||
604 | |||||
605 | @time = localtime time; | ||||
606 | $time[0] = $time[1] = 0; | ||||
607 | my $date_end = Time::Local::timelocal(@time); | ||||
608 | |||||
609 | unless ( | ||||
610 | $sth = $sdm->do_prepared_query( | ||||
611 | q{SELECT date_stat | ||||
612 | FROM stat_table | ||||
613 | WHERE read_stat = 0 | ||||
614 | ORDER BY date_stat ASC} | ||||
615 | ) | ||||
616 | ) { | ||||
617 | $self->syslog('err', 'Unable to retrieve oldest non processed stat'); | ||||
618 | return undef; | ||||
619 | } | ||||
620 | my @res = $sth->fetchrow_array; | ||||
621 | $sth->finish; # Fetch only the oldest row. | ||||
622 | |||||
623 | # If the array is emty, then we don't have anything to aggregate. | ||||
624 | # Simply return and carry on. | ||||
625 | unless (@res) { | ||||
626 | return 0; | ||||
627 | } | ||||
628 | my $date_deb = $res[0] - ($res[0] % 3600); | ||||
629 | |||||
630 | # Hour to hour | ||||
631 | my @slots; | ||||
632 | for (my $i = $date_deb; $i <= $date_end; $i = $i + 3600) { | ||||
633 | push @slots, $i; | ||||
634 | } | ||||
635 | |||||
636 | for (my $j = 1; $j <= scalar(@slots); $j++) { | ||||
637 | $self->_aggregate_data($slots[$j - 1] || $date_deb, | ||||
638 | $slots[$j] || $date_end); | ||||
639 | } | ||||
640 | |||||
641 | return 1; | ||||
642 | } | ||||
643 | |||||
644 | # Aggregate data from stat_table to stat_counter_table. | ||||
645 | # Dates must be in epoch format. | ||||
646 | my @robot_operations = qw{close_list copy_list create_list list_rejected | ||||
647 | login logout purge_list restore_list}; | ||||
648 | |||||
649 | # Old name: Log::aggregate_data(). | ||||
650 | sub _aggregate_data { | ||||
651 | my $self = shift; | ||||
652 | my ($begin_date, $end_date) = @_; | ||||
653 | |||||
654 | my $sdm; | ||||
655 | unless ($self->{_database_backend} | ||||
656 | and $sdm = $self->{_database_backend}->instance) { | ||||
657 | $self->syslog('err', 'Database backend is not available'); | ||||
658 | return; | ||||
659 | } | ||||
660 | |||||
661 | # Store reslults in stat_counter_table. | ||||
662 | my $cond; | ||||
663 | |||||
664 | # Store data by each list. | ||||
665 | $cond = join ' AND ', map {"operation_stat <> '$_'"} @robot_operations; | ||||
666 | $sdm->do_prepared_query( | ||||
667 | sprintf( | ||||
668 | q{INSERT INTO stat_counter_table | ||||
669 | (beginning_date_counter, end_date_counter, data_counter, | ||||
670 | robot_counter, list_counter, count_counter) | ||||
671 | SELECT ?, ?, operation_stat, robot_stat, list_stat, COUNT(*) | ||||
672 | FROM stat_table | ||||
673 | WHERE ? <= date_stat AND date_stat < ? | ||||
674 | AND list_stat IS NOT NULL AND list_stat <> '' | ||||
675 | AND read_stat = 0 AND %s | ||||
676 | GROUP BY robot_stat, list_stat, operation_stat}, | ||||
677 | $cond | ||||
678 | ), | ||||
679 | $begin_date, | ||||
680 | $end_date, | ||||
681 | $begin_date, | ||||
682 | $end_date | ||||
683 | ); | ||||
684 | |||||
685 | # Store data by each robot. | ||||
686 | $cond = join ' OR ', map {"operation_stat = '$_'"} @robot_operations; | ||||
687 | $sdm->do_prepared_query( | ||||
688 | sprintf( | ||||
689 | q{INSERT INTO stat_counter_table | ||||
690 | (beginning_date_counter, end_date_counter, data_counter, | ||||
691 | robot_counter, list_counter, count_counter) | ||||
692 | SELECT ?, ?, operation_stat, robot_stat, '', COUNT(*) | ||||
693 | FROM stat_table | ||||
694 | WHERE ? <= date_stat AND date_stat < ? | ||||
695 | AND read_stat = 0 AND (%s) | ||||
696 | GROUP BY robot_stat, operation_stat}, | ||||
697 | $cond | ||||
698 | ), | ||||
699 | $begin_date, | ||||
700 | $end_date, | ||||
701 | $begin_date, | ||||
702 | $end_date | ||||
703 | ); | ||||
704 | |||||
705 | # Update subscriber_table about messages sent, upgrade field | ||||
706 | # number_messages_subscriber. | ||||
707 | my $sth; | ||||
708 | my $row; | ||||
709 | if ($sth = $sdm->do_prepared_query( | ||||
710 | q{SELECT COUNT(*) AS "count", | ||||
711 | robot_stat AS robot, list_stat AS list, | ||||
712 | email_stat AS email | ||||
713 | FROM stat_table | ||||
714 | WHERE ? <= date_stat AND date_stat < ? | ||||
715 | AND read_stat = 0 AND operation_stat = 'send_mail' | ||||
716 | GROUP BY robot_stat, list_stat, email_stat}, | ||||
717 | $begin_date, $end_date | ||||
718 | ) | ||||
719 | ) { | ||||
720 | while ($row = $sth->fetchrow_hashref('NAME_lc')) { | ||||
721 | $sdm->do_prepared_query( | ||||
722 | q{UPDATE subscriber_table | ||||
723 | SET number_messages_subscriber = | ||||
724 | number_messages_subscriber + ? | ||||
725 | WHERE robot_subscriber = ? AND list_subscriber = ? AND | ||||
726 | user_subscriber = ?}, | ||||
727 | $row->{'count'}, | ||||
728 | $row->{'robot'}, $row->{'list'}, | ||||
729 | $row->{'email'} | ||||
730 | ); | ||||
731 | } | ||||
732 | $sth->finish; | ||||
733 | } | ||||
734 | |||||
735 | # The rows were read, so update the read_stat from 0 to 1. | ||||
736 | unless ( | ||||
737 | $sth = $sdm->do_prepared_query( | ||||
738 | q{UPDATE stat_table | ||||
739 | SET read_stat = 1 | ||||
740 | WHERE ? <= date_stat AND date_stat < ?}, | ||||
741 | $begin_date, $end_date | ||||
742 | ) | ||||
743 | ) { | ||||
744 | $self->syslog('err', | ||||
745 | 'Unable to set stat entries between date % and date %s as read', | ||||
746 | $begin_date, $end_date); | ||||
747 | return undef; | ||||
748 | } | ||||
749 | |||||
750 | my $d_deb = localtime($begin_date); | ||||
751 | my $d_fin = localtime($end_date) if defined $end_date; | ||||
752 | $self->syslog('debug2', 'data aggregated from %s to %s', $d_deb, $d_fin); | ||||
753 | } | ||||
754 | |||||
755 | #get date of the last time we have aggregated data | ||||
756 | # Never used. | ||||
757 | #sub get_last_date_aggregation; | ||||
758 | |||||
759 | sub aggregate_daily_data { | ||||
760 | my $self = shift; | ||||
761 | $self->syslog('debug2', '(%s, %s)', @_); | ||||
762 | my $list = shift; | ||||
763 | my $operation = shift; | ||||
764 | |||||
765 | my $sdm; | ||||
766 | unless ($self->{_database_backend} | ||||
767 | and $sdm = $self->{_database_backend}->instance) { | ||||
768 | $self->syslog('err', 'Database backend is not available'); | ||||
769 | return; | ||||
770 | } | ||||
771 | |||||
772 | my $result; | ||||
773 | |||||
774 | my $sth; | ||||
775 | my $row; | ||||
776 | unless ( | ||||
777 | $sth = $sdm->do_prepared_query( | ||||
778 | q{SELECT beginning_date_counter AS "date", | ||||
779 | count_counter AS "count" | ||||
780 | FROM stat_counter_table | ||||
781 | WHERE data_counter = ? AND | ||||
782 | robot_counter = ? AND list_counter = ?}, | ||||
783 | $operation, | ||||
784 | $list->{'domain'}, $list->{'name'} | ||||
785 | ) | ||||
786 | ) { | ||||
787 | $self->syslog('err', 'Unable to get stat data %s for list %s', | ||||
788 | $operation, $list); | ||||
789 | return; | ||||
790 | } | ||||
791 | while ($row = $sth->fetchrow_hashref('NAME_lc')) { | ||||
792 | my $midnight = Sympa::Tools::Time::get_midnight_time($row->{'date'}); | ||||
793 | $result->{$midnight} = 0 unless defined $result->{$midnight}; | ||||
794 | $result->{$midnight} += $row->{'count'}; | ||||
795 | } | ||||
796 | $sth->finish; | ||||
797 | |||||
798 | my @dates = sort { $a <=> $b } keys %$result; | ||||
799 | return {} unless @dates; | ||||
800 | |||||
801 | for (my $date = $dates[0]; $date < $dates[-1]; $date += 86400) { | ||||
802 | my $midnight = Sympa::Tools::Time::get_midnight_time($date); | ||||
803 | $result->{$midnight} = 0 unless defined $result->{$midnight}; | ||||
804 | } | ||||
805 | return $result; | ||||
806 | } | ||||
807 | |||||
808 | 1; | ||||
809 | __END__ | ||||
sub Sympa::Log::CORE:match; # opcode | |||||
sub Sympa::Log::CORE:subst; # opcode | |||||
# spent 75.6ms within Sympa::Log::CORE:substcont which was called 120600 times, avg 627ns/call:
# 120600 times (75.6ms+0s) by Sympa::Log::syslog at line 127, avg 627ns/call |