← 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:10 2021

Filename/usr/local/libexec/sympa/Sympa/Family.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sSympa::Family::::BEGIN@30Sympa::Family::BEGIN@30
0000s0sSympa::Family::::BEGIN@31Sympa::Family::BEGIN@31
0000s0sSympa::Family::::BEGIN@32Sympa::Family::BEGIN@32
0000s0sSympa::Family::::BEGIN@34Sympa::Family::BEGIN@34
0000s0sSympa::Family::::BEGIN@35Sympa::Family::BEGIN@35
0000s0sSympa::Family::::BEGIN@36Sympa::Family::BEGIN@36
0000s0sSympa::Family::::BEGIN@37Sympa::Family::BEGIN@37
0000s0sSympa::Family::::BEGIN@38Sympa::Family::BEGIN@38
0000s0sSympa::Family::::BEGIN@39Sympa::Family::BEGIN@39
0000s0sSympa::Family::::__ANON__Sympa::Family::__ANON__ (xsub)
0000s0sSympa::Family::::_check_mandatory_filesSympa::Family::_check_mandatory_files
0000s0sSympa::Family::::_get_directorySympa::Family::_get_directory
0000s0sSympa::Family::::_load_param_constraint_confSympa::Family::_load_param_constraint_conf
0000s0sSympa::Family::::check_param_constraintSympa::Family::check_param_constraint
0000s0sSympa::Family::::check_valuesSympa::Family::check_values
0000s0sSympa::Family::::get_available_familiesSympa::Family::get_available_families
0000s0sSympa::Family::::get_constraintsSympa::Family::get_constraints
0000s0sSympa::Family::::get_familiesSympa::Family::get_families
0000s0sSympa::Family::::get_idSympa::Family::get_id
0000s0sSympa::Family::::get_param_constraintSympa::Family::get_param_constraint
0000s0sSympa::Family::::get_uncompellable_paramSympa::Family::get_uncompellable_param
0000s0sSympa::Family::::insert_delete_exclusionSympa::Family::insert_delete_exclusion
0000s0sSympa::Family::::newSympa::Family::new
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# Copyright 2017, 2018, 2019, 2020 The Sympa Community. See the AUTHORS.md
12# file at the top-level 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
28package Sympa::Family;
29
30use strict;
31use warnings;
32use English qw(-no_match_vars);
33
34use Sympa;
35use Conf;
36use Sympa::DatabaseManager;
37use Sympa::Log;
38use Sympa::Regexps;
39use Sympa::Tools::File;
40
41my $log = Sympa::Log->instance;
42
43my %list_of_families;
44my @uncompellable_param = (
45 'msg_topic.keywords',
46 'owner_include.source_parameters',
47 'editor_include.source_parameters'
48);
49
50sub get_families {
51 my $robot_id = shift;
52
53 my @families;
54
55 foreach my $dir (
56 reverse @{Sympa::get_search_path($robot_id, subdir => 'families')}) {
57 next unless -d $dir;
58
59 unless (opendir FAMILIES, $dir) {
60 $log->syslog('err', 'Can\'t open dir %s: %m', $dir);
61 next;
62 }
63
64 # If we can create a Sympa::Family object with what we find in the
65 # family directory, then it is worth being added to the list.
66 foreach my $subdir (grep !/^\.\.?$/, readdir FAMILIES) {
67 next unless -d ("$dir/$subdir");
68 if (my $family = Sympa::Family->new($subdir, $robot_id)) {
69 push @families, $family;
70 }
71 }
72 }
73
74 return \@families;
75}
76
77sub get_available_families {
78 my $robot_id = shift;
79 my $families;
80 my %hash;
81 if ($families = get_families($robot_id)) {
82 foreach my $family (@$families) {
83 if (ref $family eq 'Sympa::Family') {
84 $hash{$family->{'name'}} = $family;
85 }
86 }
87 return %hash;
88 } else {
89 return undef;
90 }
91}
92
93sub new {
94 my $class = shift;
95 my $name = shift;
96 my $robot = shift;
97 $log->syslog('debug2', '(%s, %s)', $name, $robot);
98
99 my $self = {};
100
101 if ($list_of_families{$robot}{$name}) {
102 # use the current family in memory and update it
103 $self = $list_of_families{$robot}{$name};
104 ###########
105 # the robot can be different from latest new ...
106 if ($robot eq $self->{'domain'}) {
107 return $self;
108 } else {
109 $self = {};
110 }
111 }
112 # create a new object family
113 bless $self, $class;
114 $list_of_families{$robot}{$name} = $self;
115
116 my $family_name_regexp = Sympa::Regexps::family_name();
117
118 ## family name
119 unless ($name && ($name =~ /^$family_name_regexp$/io)) {
120 $log->syslog('err', 'Incorrect family name "%s"', $name);
121 return undef;
122 }
123
124 ## Lowercase the family name.
125 $name =~ tr/A-Z/a-z/;
126 $self->{'name'} = $name;
127 $self->{'domain'} = $robot;
128
129 $self->{'robot'} = $self->{'domain'}; # Compat.<=6.2.52
130
131 ## Adding configuration related to automatic lists.
132 my $all_families_config =
133 Conf::get_robot_conf($robot, 'automatic_list_families');
134 my $family_config = $all_families_config->{$name};
135 foreach my $key (keys %{$family_config}) {
136 $self->{$key} = $family_config->{$key};
137 }
138
139 ## family directory
140 $self->{'dir'} = $self->_get_directory();
141 unless (defined $self->{'dir'}) {
142 $log->syslog('err', '(%s, %s) The family directory does not exist',
143 $name, $robot);
144 return undef;
145 }
146
147 ## family files
148 if (my $file_names = $self->_check_mandatory_files()) {
149 $log->syslog('err',
150 '(%s, %s) Definition family files are missing: %s',
151 $name, $robot, $file_names);
152 return undef;
153 }
154
155 ## file mtime
156 $self->{'mtime'}{'param_constraint_conf'} = undef;
157
158 ## hash of parameters constraint
159 $self->{'param_constraint_conf'} = undef;
160
161 return $self;
162}
163
164# Merged to: Sympa::Request::Handler::create_automatic_list::_twist().
165#sub add_list;
166
167# Deprecated. Use sympa.pl --modify_list.
168#sub modify_list;
169
170# Old name: Sympa::Admin::update_list().
171# Moved: Use Sympa::Request::Handler::update_automatic_list handler.
172#sub _update_list;
173
174# Deprecated. Use sympa.pl --close_family.
175#sub close_family;
176
177# Moved to: instantiate() in sympa.pl.
178#sub instantiate;
179
180# moved to: get_instantiation_results() in sympa.pl.
181#sub get_instantiation_results;
182
183sub check_param_constraint {
184 $log->syslog('debug2', '(%s, %s)', @_);
185 my $self = shift;
186 my $list = shift;
187
188 my @error;
189
190 ## checking
191 my $constraint = $self->get_constraints();
192 unless (defined $constraint) {
193 $log->syslog('err', '(%s, %s) Unable to get family constraints',
194 $self->{'name'}, $list->{'name'});
195 return undef;
196 }
197 foreach my $param (keys %{$constraint}) {
198 my $constraint_value = $constraint->{$param};
199 my $param_value;
200 my $value_error;
201
202 unless (defined $constraint_value) {
203 $log->syslog(
204 'err',
205 'No value constraint on parameter %s in param_constraint.conf',
206 $param
207 );
208 next;
209 }
210
211 $param_value = $list->get_param_value($param);
212
213 # exception for uncompellable parameter
214 foreach my $forbidden (@uncompellable_param) {
215 if ($param eq $forbidden) {
216 next;
217 }
218 }
219
220 $value_error = $self->check_values($param_value, $constraint_value);
221
222 if (ref($value_error)) {
223 foreach my $v (@{$value_error}) {
224 push(@error, $param);
225 $log->syslog('err',
226 'Error constraint on parameter %s, value: %s',
227 $param, $v);
228 }
229 }
230 }
231
232 if (scalar @error) {
233 return \@error;
234 } else {
235 return 1;
236 }
237}
238
239sub get_constraints {
240 my $self = shift;
241 $log->syslog('debug3', '(%s)', $self->{'name'});
242
243 ## load param_constraint.conf
244 my $time_file =
245 Sympa::Tools::File::get_mtime("$self->{'dir'}/param_constraint.conf");
246 unless (defined($self->{'param_constraint_conf'})
247 and $self->{'mtime'}{'param_constraint_conf'} >= $time_file) {
248 $self->{'param_constraint_conf'} =
249 $self->_load_param_constraint_conf();
250 unless (defined $self->{'param_constraint_conf'}) {
251 $log->syslog('err', 'Cannot load file param_constraint.conf');
252 return undef;
253 }
254 $self->{'mtime'}{'param_constraint_conf'} = $time_file;
255 }
256
257 return $self->{'param_constraint_conf'};
258}
259
260sub check_values {
261 my ($self, $param_value, $constraint_value) = @_;
262 $log->syslog('debug3', '');
263
264 my @param_values;
265 my @error;
266
267 # just in case
268 if ($constraint_value eq '0') {
269 return [];
270 }
271
272 if (ref($param_value) eq 'ARRAY') {
273 @param_values = @{$param_value}; # for multiple parameters
274 } else {
275 push @param_values, $param_value; # for single parameters
276 }
277
278 foreach my $p_val (@param_values) {
279 # multiple values
280 if (ref($p_val) eq 'ARRAY') {
281
282 foreach my $p (@{$p_val}) {
283 ## controlled parameter
284 if (ref($constraint_value) eq 'HASH') {
285 unless ($constraint_value->{$p}) {
286 push(@error, $p);
287 }
288 ## fixed parameter
289 } else {
290 unless ($constraint_value eq $p) {
291 push(@error, $p);
292 }
293 }
294 }
295 ## single value
296 } else {
297 ## controlled parameter
298 if (ref($constraint_value) eq 'HASH') {
299 unless ($constraint_value->{$p_val}) {
300 push(@error, $p_val);
301 }
302 ## fixed parameter
303 } else {
304 unless ($constraint_value eq $p_val) {
305 push(@error, $p_val);
306 }
307 }
308 }
309 }
310
311 return \@error;
312}
313
314sub get_param_constraint {
315 my $self = shift;
316 my $param = shift;
317 $log->syslog('debug3', '(%s, %s)', $self->{'name'}, $param);
318
319 unless (defined $self->get_constraints()) {
320 return undef;
321 }
322
323 if (defined $self->{'param_constraint_conf'}{$param}) {
324 ## fixed or controlled parameter
325 return $self->{'param_constraint_conf'}{$param};
326
327 } else { ## free parameter
328 return '0';
329 }
330}
331
332# DEPRECATED: Use Sympa::List::get_lists($family).
333#sub get_family_lists;
334
335# DEPRECATED: Use Sympa::List::get_lists($family).
336#sub get_hash_family_lists;
337
338sub get_uncompellable_param {
339 my %list_of_param;
340 $log->syslog('debug3', '');
341
342 foreach my $param (@uncompellable_param) {
343 if ($param =~ /^([\w-]+)\.([\w-]+)$/) {
344 $list_of_param{$1} = $2;
345
346 } else {
347 $list_of_param{$param} = '';
348 }
349 }
350
351 return \%list_of_param;
352}
353
354# Gets the family directory, look for it in the robot, then in the site and
355# finally in the distrib.
356# OUT : -directory name or undef if the directory does not exist
357sub _get_directory {
358 $log->syslog('debug3', '(%s)', @_);
359 my $self = shift;
360
361 my $name = $self->{'name'};
362 my $robot = $self->{'domain'};
363
364 my @try = @{Sympa::get_search_path($robot, subdir => 'families')};
365
366 foreach my $d (@try) {
367 if (-d "$d/$name") {
368 return "$d/$name";
369 }
370 }
371 return undef;
372}
373
374# Checks the existence of the mandatory files (param_constraint.conf and
375# config.tt2) in the family directory.
376# OUT : -0 (if OK) or $string containing missing file names
377sub _check_mandatory_files {
378 my $self = shift;
379 my $dir = $self->{'dir'};
380 my $string = "";
381 $log->syslog('debug3', '(%s)', $self->{'name'});
382
383 foreach my $f ('config.tt2') {
384 unless (-f "$dir/$f") {
385 $string .= $f . " ";
386 }
387 }
388
389 if ($string eq "") {
390 return 0;
391 } else {
392 return $string;
393 }
394}
395
396# Moved to: _initialize_instantiation() in sympa.pl.
397#sub _initialize_instantiation;
398
399# Moved to: _split_xml_file() in sympa.pl.
400#sub _split_xml_file;
401
402# Deprecated. No longer used.
403#sub _update_existing_list;
404
405# Moved:
406# Use Sympa::Request::Handler::update_automatic_list::_get_customizing().
407#sub _get_customizing;
408
409# No longer used.
410#sub _set_status_changes;
411
412# Moved to part of: Sympa::Request::Handler::update_automatic_list::_twist().
413#sub _end_update_list;
414
415# No longer used.
416#sub _copy_files;
417
418# Loads the param_constraint.conf file in a hash.
419# OUT : -$constraint : ref on a hash or undef
420sub _load_param_constraint_conf {
421 my $self = shift;
422 $log->syslog('debug2', '(%s)', $self->{'name'});
423
424 my $file = "$self->{'dir'}/param_constraint.conf";
425
426 my $constraint = {};
427
428 unless (-e $file) {
429 $log->syslog('err', 'No file %s. Assuming no constraints to apply',
430 $file);
431 return $constraint;
432 }
433
434 unless (open(FILE, $file)) {
435 $log->syslog('err', 'File %s exists, but unable to open it: %m',
436 $file);
437 return undef;
438 }
439
440 my $error = 0;
441
442 ## Just in case...
443 local $RS = "\n";
444
445 while (<FILE>) {
446 next if /^\s*(\#.*|\s*)$/;
447
448 if (/^\s*([\w\-\.]+)\s+(.+)\s*$/) {
449 my $param = $1;
450 my $value = $2;
451 my @values = split /,/, $value;
452
453 unless (($param =~ /^([\w-]+)\.([\w-]+)$/)
454 || ($param =~ /^([\w-]+)$/)) {
455 $log->syslog('err', '(%s) Unknown parameter "%s" in %s',
456 $self->{'name'}, $_, $file);
457 $error = 1;
458 next;
459 }
460
461 if (scalar(@values) == 1) {
462 $constraint->{$param} = shift @values;
463 } else {
464 foreach my $v (@values) {
465 $constraint->{$param}{$v} = 1;
466 }
467 }
468 } else {
469 $log->syslog('err', '(%s) Bad line: %s in %s',
470 $self->{'name'}, $_, $file);
471 $error = 1;
472 next;
473 }
474 }
475 if ($error) {
476 Sympa::send_notify_to_listmaster($self->{'domain'},
477 'param_constraint_conf_error', [$file]);
478 }
479 close FILE;
480
481 # Parameters not allowed in param_constraint.conf file :
482 foreach my $forbidden (@uncompellable_param) {
483 if (defined $constraint->{$forbidden}) {
484 delete $constraint->{$forbidden};
485 }
486 }
487
488 return $constraint;
489}
490
491#Deprecated. Use Sympa::Request::Handler::create_automatic_list request handler.
492#sub create_automatic_list;
493
494# Returns 1 if the user is allowed to create lists based on the family.
495#Deprecated. Use Sympa::Request::Handler::create_automatic_list request handler.
496#sub is_allowed_to_create_automatic_lists;
497
498## Handle exclusion table for family
499sub insert_delete_exclusion {
500 $log->syslog('debug2', '(%s, %s, %s)', @_);
501 my $self = shift;
502 my $email = shift;
503 my $action = shift;
504
505 my $name = $self->{'name'};
506 my $robot_id = $self->{'domain'};
507
508 if ($action eq 'insert') {
509 ##FXIME: Check if user belong to any list of family
510 my $date = time;
511
512 ## Insert: family, user and date
513 ## Add dummy list_exclusion column to satisfy constraint.
514 my $sdm;
515 unless (
516 $sdm = Sympa::DatabaseManager->instance
517 and $sdm->do_prepared_query(
518 q{INSERT INTO exclusion_table
519 (list_exclusion, family_exclusion, robot_exclusion,
520 user_exclusion, date_exclusion)
521 VALUES (?, ?, ?, ?, ?)},
522 sprintf('family:%s', $name), $name, $robot_id, $email, $date
523 )
524 ) {
525 $log->syslog('err', 'Unable to exclude user %s from family %s',
526 $email, $self);
527 return undef;
528 }
529 return 1;
530 } elsif ($action eq 'delete') {
531 ##FIXME: Not implemented yet.
532 return undef;
533 } else {
534 $log->syslog('err', 'Unknown action %s', $action);
535 return undef;
536 }
537
538 return 1;
539}
540
541sub get_id {
542 my $self = shift;
543
544 return '' unless $self->{'name'} and $self->{'domain'};
545 return sprintf '%s@%s', $self->{'name'}, $self->{'domain'};
546}
547
5481;
549__END__