← 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/Config.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sSympa::Config::::BEGIN@26Sympa::Config::BEGIN@26
0000s0sSympa::Config::::BEGIN@27Sympa::Config::BEGIN@27
0000s0sSympa::Config::::BEGIN@29Sympa::Config::BEGIN@29
0000s0sSympa::Config::::BEGIN@30Sympa::Config::BEGIN@30
0000s0sSympa::Config::::BEGIN@31Sympa::Config::BEGIN@31
0000s0sSympa::Config::::__ANON__Sympa::Config::__ANON__ (xsub)
0000s0sSympa::Config::::__ANON__[:555]Sympa::Config::__ANON__[:555]
0000s0sSympa::Config::::__ANON__[:560]Sympa::Config::__ANON__[:560]
0000s0sSympa::Config::::__ANON__[:566]Sympa::Config::__ANON__[:566]
0000s0sSympa::Config::::__ANON__[:571]Sympa::Config::__ANON__[:571]
0000s0sSympa::Config::::__init_schemaSympa::Config::__init_schema
0000s0sSympa::Config::::_apply_defaultsSympa::Config::_apply_defaults
0000s0sSympa::Config::::_getSympa::Config::_get
0000s0sSympa::Config::::_get_changeSympa::Config::_get_change
0000s0sSympa::Config::::_global_validationsSympa::Config::_global_validations
0000s0sSympa::Config::::_init_schema_itemSympa::Config::_init_schema_item
0000s0sSympa::Config::::_keysSympa::Config::_keys
0000s0sSympa::Config::::_local_validationsSympa::Config::_local_validations
0000s0sSympa::Config::::_merge_changes_multipleSympa::Config::_merge_changes_multiple
0000s0sSympa::Config::::_merge_changes_paragraphSympa::Config::_merge_changes_paragraph
0000s0sSympa::Config::::_pfullnameSympa::Config::_pfullname
0000s0sSympa::Config::::_pnameSympa::Config::_pname
0000s0sSympa::Config::::_sanitize_changesSympa::Config::_sanitize_changes
0000s0sSympa::Config::::_sanitize_changes_arraySympa::Config::_sanitize_changes_array
0000s0sSympa::Config::::_sanitize_changes_leafSympa::Config::_sanitize_changes_leaf
0000s0sSympa::Config::::_sanitize_changes_paragraphSympa::Config::_sanitize_changes_paragraph
0000s0sSympa::Config::::_sanitize_changes_setSympa::Config::_sanitize_changes_set
0000s0sSympa::Config::::_validate_changesSympa::Config::_validate_changes
0000s0sSympa::Config::::_validate_changes_leafSympa::Config::_validate_changes_leaf
0000s0sSympa::Config::::_validate_changes_multipleSympa::Config::_validate_changes_multiple
0000s0sSympa::Config::::_validate_changes_paragraphSympa::Config::_validate_changes_paragraph
0000s0sSympa::Config::::commitSympa::Config::commit
0000s0sSympa::Config::::getSympa::Config::get
0000s0sSympa::Config::::get_changeSympa::Config::get_change
0000s0sSympa::Config::::get_changesetSympa::Config::get_changeset
0000s0sSympa::Config::::get_idSympa::Config::get_id
0000s0sSympa::Config::::get_schemaSympa::Config::get_schema
0000s0sSympa::Config::::keysSympa::Config::keys
0000s0sSympa::Config::::newSympa::Config::new
0000s0sSympa::Config::::submitSympa::Config::submit
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 2018 The Sympa Community. See the AUTHORS.md file at the
8# top-level directory of this distribution and at
9# <https://github.com/sympa-community/sympa.git>.
10#
11# This program is free software; you can redistribute it and/or modify
12# it under the terms of the GNU General Public License as published by
13# the Free Software Foundation; either version 2 of the License, or
14# (at your option) any later version.
15#
16# This program is distributed in the hope that it will be useful,
17# but WITHOUT ANY WARRANTY; without even the implied warranty of
18# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19# GNU General Public License for more details.
20#
21# You should have received a copy of the GNU General Public License
22# along with this program. If not, see <http://www.gnu.org/licenses/>.
23
24package Sympa::Config;
25
26use strict;
27use warnings;
28
29use Sympa::Language;
30use Sympa::Tools::Data;
31use Sympa::Tools::Text;
32
33sub new {
34 my $class = shift;
35 my $context = shift;
36 my %options = @_;
37
38 # The undef means list creation.
39 # Empty hashref (default) means loading existing config.
40 my $config;
41 if (exists $options{config}) {
42 $config = $options{config};
43 } else {
44 $config = {};
45 }
46 $config = Sympa::Tools::Data::clone_var($config)
47 if $options{copy};
48
49 #FIXME:Should $config be sanitized?
50 my $self =
51 bless {context => $context, _config => $config, _changes => {}} =>
52 $class;
53
54 my $pinfo = $self->_schema;
55 foreach my $pname (_keys($pinfo)) {
56 $self->__init_schema($pinfo->{$pname}, [$pname], %options);
57 }
58 $self->{_pinfo} = $pinfo;
59
60 return $self;
61}
62
63#sub _schema;
64
65# Initialize default values.
66sub __init_schema {
67 my $self = shift;
68 my $phash = shift;
69 my $pnames = shift;
70 my %options = @_;
71
72 my $subres;
73 if (ref $phash->{format} eq 'HASH') {
74 foreach my $pname (_keys($phash->{format})) {
75 my $pii = $phash->{format}->{$pname};
76
77 $subres->{$pname} =
78 $self->__init_schema($pii, [@$pnames, $pname], %options);
79 }
80 }
81 return $self->_init_schema_item($phash, $pnames, $subres, %options);
82}
83
84sub _init_schema_item {
85 my $self = shift;
86 my $pitem = shift;
87 my $pnames = shift;
88 my $subres = shift;
89 my %options = @_;
90
91 return undef
92 unless ref $pitem->{format} ne 'HASH' and exists $pitem->{default};
93
94 my $default = $pitem->{default};
95
96 if ($pitem->{occurrence} =~ /n$/) { # The set or the array of scalars
97 if (ref $default) {
98 ;
99 } elsif (defined $default) {
100 my $re = quotemeta($pitem->{split_char} || ',');
101 $pitem->{default} = [split /\s*$re\s*/, $default];
102 } else {
103 $pitem->{default} = [];
104 }
105 } elsif ($pitem->{scenario} or $pitem->{task}) {
106 if (ref $default) {
107 ;
108 } elsif (defined $default) {
109 $pitem->{default} = {name => $default};
110 }
111 }
112
113 return undef;
114}
115
116sub get {
117 my $self = shift;
118 my $ppath = shift;
119
120 my @ppaths = split /[.]/, $ppath;
121 return unless @ppaths;
122
123 my @value = _get($self->{_config}, @ppaths);
124 return unless @value;
125 return $value[0] unless ref $value[0];
126 return Sympa::Tools::Data::clone_var($value[0]);
127}
128
129sub _get {
130 my $cur = shift;
131 my @ppaths = @_;
132
133 while (1) {
134 my $key = shift @ppaths;
135
136 if ($key =~ /\A\d+\z/) {
137 unless (ref $cur eq 'ARRAY' and exists $cur->[$key]) {
138 return;
139 } elsif (not @ppaths) {
140 return ($cur->[$key]);
141 } else {
142 $cur = $cur->[$key];
143 }
144 } else {
145 unless (ref $cur eq 'HASH' and exists $cur->{$key}) {
146 return;
147 } elsif (not @ppaths) {
148 return $cur->{$key};
149 } else {
150 $cur = $cur->{$key};
151 }
152 }
153 }
154}
155
156sub get_change {
157 my $self = shift;
158 my $ppath = shift;
159
160 my @ppaths = split /[.]/, $ppath;
161 return unless @ppaths;
162
163 my @value = _get_change($self->{_changes}, @ppaths);
164 return unless @value;
165 return $value[0] unless ref $value[0];
166 return Sympa::Tools::Data::clone_var($value[0]);
167}
168
169sub _get_change {
170 my $new = shift;
171 my @ppaths = @_;
172
173 while (1) {
174 my $key = shift @ppaths;
175
176 unless (ref $new eq 'HASH' and exists $new->{$key}) {
177 return;
178 } elsif (not @ppaths) {
179 return $new->{$key};
180 } else {
181 $new = $new->{$key};
182 }
183 }
184}
185
186sub get_changeset {
187 my $self = shift;
188
189 return $self->{_changes};
190}
191
192# Apply default values, if elements are mandatory and are scalar.
193# The init option means list/node creation.
194sub _apply_defaults {
195 my $self = shift;
196 my $cur = shift;
197 my $phash = shift;
198 my %options = @_;
199
200 foreach my $key (_keys($phash)) {
201 my $pii = $phash->{$key};
202
203 if (exists $cur->{$key}) {
204 next;
205 } elsif (ref $pii->{format} eq 'HASH') { # Not a scalar
206 next;
207 } elsif (exists $pii->{default}) {
208 if ($options{init} or $pii->{occurrence} =~ /^1/) {
209 if (ref $pii->{default}) {
210 $cur->{$key} =
211 Sympa::Tools::Data::clone_var($pii->{default});
212 } else {
213 $cur->{$key} = $pii->{default};
214 }
215 }
216 }
217 }
218}
219
220sub get_schema {
221 my $self = shift;
222
223 return Sympa::Tools::Data::clone_var($self->{_pinfo});
224}
225
226sub keys {
227 my $self = shift;
228 my $pname = shift;
229
230 return _keys($self->{_pinfo}) unless $pname;
231 my @pnames = split /[.]/, $pname;
232
233 my $phash = $self->{_pinfo};
234 while (1) {
235 my $key = shift @pnames;
236
237 unless (ref $phash eq 'HASH'
238 and exists $phash->{$key}
239 and exists $phash->{$key}->{format}) {
240 return;
241 } elsif (not @pnames) {
242 return _keys($phash->{$key}->{format});
243 } else {
244 $phash = $phash->{$key}->{format};
245 }
246 }
247}
248
249sub _keys {
250 my $hash = shift;
251 my $phash = shift || $hash;
252
253 return sort {
254 ($phash->{$a}->{order} || 999) <=> ($phash->{$b}->{order} || 999)
255 } CORE::keys %$hash;
256}
257
258# Gets parameter name of node from list of parameter paths.
259sub _pname {
260 my $ppaths = shift;
261 return undef unless $ppaths and @$ppaths;
262 [grep { !/\A\d+\z/ } @$ppaths]->[-1];
263}
264
265# Gets full parameter name of node from list of parameter paths.
266sub _pfullname {
267 my $ppaths = shift;
268 return undef unless $ppaths and @$ppaths;
269 return join '.', grep { !/\A\d+\z/ } @$ppaths;
270}
271
272sub submit {
273 my $self = shift;
274 my $new = shift;
275 my $user = shift;
276 my $errors = shift;
277 my %options = @_;
278
279 my $changes = $self->_sanitize_changes($new, $user);
280
281 # Error if no parameter was edited.
282 unless ($changes and %$changes) {
283 $self->{_changes} = {};
284 push @$errors, ['notice', 'no_parameter_edited'];
285 return '';
286 }
287
288 $self->{_changes} = $changes;
289 return $self->_validate_changes($changes, $errors, %options);
290}
291
292# Sanitizes parsed input including changes.
293# Parameters:
294# $new: Change information.
295# $user: Operating user. $param->{'user'}{'email'}.
296# Returns:
297# Sanitized input, where "owner.0.gecos" will be stores in
298# $hashref->{'owner'}{'0'}{'gecos'}.
299sub _sanitize_changes {
300 my $self = shift;
301 my $new = shift;
302 my $user = shift;
303
304 return undef unless ref $new eq 'HASH'; # Sanity check
305
306 # Apply privileges: {privilege} will keep 'hidden', 'read' or 'write'.
307 my $pinfo = $self->get_schema($user);
308
309 # Undefined {_config} means list creation.
310 # Empty hashref means loading existing config.
311 my $init = (not defined $self->{_config});
312 my $loading = ($self->{_config} and not %{$self->{_config}});
313 my $cur = $init ? {} : Sympa::Tools::Data::clone_var($self->{_config});
314 $self->_apply_defaults($cur, $pinfo, init => ($init and not $loading));
315
316 my %ret = map {
317 unless (exists $pinfo->{$_} and $pinfo->{$_}) {
318 (); # Sanity check: unknown parameter
319 } else {
320 # Resolve alias.
321 my ($k, $o) = ($_, $_);
322 do {
323 ($k, $o) = ($o, $pinfo->{$o}->{obsolete});
324 } while ($o and $pinfo->{$o});
325 unless ($k eq $_) {
326 $new->{$k} = $new->{$_};
327 delete $new->{$_};
328 }
329
330 my $pii = $pinfo->{$k};
331 my $ppi = [$k];
332 my $newi = $new->{$k};
333 my $curi = $cur->{$k};
334
335 my @r;
336 if ($pii->{occurrence} =~ /n$/) {
337 if (ref $pii->{format} eq 'ARRAY') {
338 @r =
339 $self->_sanitize_changes_set($curi, $newi, $pii,
340 $ppi);
341 } else {
342 @r =
343 $self->_sanitize_changes_array($curi, $newi, $pii,
344 $ppi, loading => $loading);
345 }
346 } elsif (ref $pii->{format} eq 'HASH') {
347 @r = $self->_sanitize_changes_paragraph(
348 $curi, $newi, $pii, $ppi,
349 init => (not defined $curi),
350 loading => $loading
351 );
352 } else {
353 @r = $self->_sanitize_changes_leaf($curi, $newi, $pii, $ppi);
354 }
355
356 # Omit removal if current configuration is already empty.
357 (@r and not defined $r[1] and not defined $curi) ? () : @r;
358 }
359 } _keys($new, $pinfo);
360
361 return {%ret};
362}
363
364# Sanitizes set.
365sub _sanitize_changes_set {
366 my $self = shift;
367 my $cur = shift || [];
368 my $new = shift;
369 my $pitem = shift;
370 my $ppaths = shift;
371
372 return () unless ref $new eq 'ARRAY'; # Sanity check
373 return () if $pitem->{obsolete};
374 return () unless $pitem->{privilege} eq 'write';
375
376 # Resolve synonym.
377 if (ref $pitem->{synonym} eq 'HASH') {
378 @$new = map {
379 if (defined $_) {
380 my $synonym = $pitem->{synonym}->{$_};
381 (defined $synonym) ? $synonym : $_;
382 } else {
383 undef;
384 }
385 } @$new;
386 }
387
388 my $i = -1;
389 my %updated = map {
390 $i++;
391 my $curi = $_;
392 (grep { Sympa::Tools::Data::smart_eq($curi, $_) } @$new)
393 ? ()
394 : ($i => undef);
395 } @$cur;
396 my %added = map {
397 my $newi = $_;
398 (grep { Sympa::Tools::Data::smart_eq($newi, $_) } @$cur)
399 ? ()
400 : (++$i => $_);
401 } @$new;
402 my %ret = (%updated, %added);
403
404 # If all children are removed, remove parent.
405 while (my ($k, $v) = each %ret) {
406 $cur->[$k] = $v;
407 }
408 return (_pname($ppaths) => undef) unless grep { defined $_ } @$cur;
409
410 unless (%ret) {
411 return (); # No valid changes
412 } else {
413 return (_pname($ppaths) => {%ret});
414 }
415}
416
417# Sanitizes array.
418sub _sanitize_changes_array {
419 my $self = shift;
420 my $cur = shift || [];
421 my $new = shift;
422 my $pitem = shift;
423 my $ppaths = shift;
424 my %options = @_;
425
426 return () unless ref $new eq 'ARRAY'; # Sanity check
427 return () if $pitem->{obsolete};
428 return () unless $pitem->{privilege} eq 'write';
429
430 my $i = -1;
431 my %ret = map {
432 $i++;
433 my $curi = $cur->[$i];
434 my $ppi = [@$ppaths, $i];
435
436 my @r;
437 if (ref $pitem->{format} eq 'HASH') {
438 @r = $self->_sanitize_changes_paragraph(
439 $curi, $_, $pitem, $ppi,
440 init => (not defined $curi),
441 loading => $options{loading}
442 );
443 } else {
444 @r = $self->_sanitize_changes_leaf($curi, $_, $pitem, $ppi);
445 }
446
447 # Omit removal if current configuration is already empty.
448 (@r and not defined $r[1] and not defined $curi)
449 ? ()
450 : (@r ? ($i => $r[1]) : ());
451 } @$new;
452
453 # If all children are removed, remove parent.
454 while (my ($k, $v) = each %ret) {
455 $cur->[$k] = $v;
456 }
457 return (_pname($ppaths) => undef) unless grep { defined $_ } @$cur;
458
459 unless (%ret) {
460 return (); # No valid changes
461 } else {
462 return (_pname($ppaths) => {%ret});
463 }
464}
465
466# Sanitizes paragraph.
467# The init option means node creation.
468sub _sanitize_changes_paragraph {
469 my $self = shift;
470 my $cur = shift || {};
471 my $new = shift;
472 my $pitem = shift;
473 my $ppaths = shift;
474 my %options = @_;
475
476 return () unless ref $new eq 'HASH'; # Sanity check
477 return () if $pitem->{obsolete};
478 return () unless $pitem->{privilege} eq 'write';
479
480 $self->_apply_defaults($cur, $pitem->{format},
481 init => ($options{init} and not $options{loading}));
482
483 my %ret = map {
484 unless (exists $pitem->{format}->{$_} and $pitem->{format}->{$_}) {
485 (); # Sanity check: unknown parameter
486 } else {
487 # Resolve alias.
488 my ($k, $o) = ($_, $_);
489 do {
490 ($k, $o) = ($o, $pitem->{format}->{$o}->{obsolete});
491 } while ($o and $pitem->{format}->{$o});
492 unless ($k eq $_) {
493 $new->{$k} = $new->{$_};
494 delete $new->{$_};
495 }
496
497 my $pii = $pitem->{format}->{$k};
498 my $ppi = [@$ppaths, $k];
499 my $newi = $new->{$k};
500 my $curi = $cur->{$k};
501
502 my @r;
503 if ($pii->{occurrence} =~ /n$/) {
504 if (ref $pii->{format} eq 'ARRAY') {
505 @r =
506 $self->_sanitize_changes_set($curi, $newi, $pii,
507 $ppi);
508 } else {
509 @r =
510 $self->_sanitize_changes_array($curi, $newi, $pii,
511 $ppi, loading => $options{loading});
512 }
513 } elsif (ref $pii->{format} eq 'HASH') {
514 @r = $self->_sanitize_changes_paragraph(
515 $curi, $newi, $pii, $ppi,
516 init => (not defined $curi),
517 loading => $options{loading}
518 );
519 } else {
520 @r = $self->_sanitize_changes_leaf($curi, $newi, $pii, $ppi);
521 }
522
523 # Omit removal if current configuration is already empty.
524 (@r and not defined $r[1] and not defined $curi) ? () : @r;
525 }
526 } _keys($new, $pitem->{format});
527
528 while (my ($k, $v) = each %ret) {
529 $cur->{$k} = $v;
530 }
531 # As soon as a required component is found to be removed,
532 # the whole parameter instance is removed.
533 return (_pname($ppaths) => undef)
534 if grep {
535 not $pitem->{format}->{$_}->{obsolete}
536 and $pitem->{format}->{$_}->{occurrence} =~ /^1/
537 and not defined $cur->{$_}
538 } _keys($pitem->{format});
539 # If all children are removed, remove parent.
540 return (_pname($ppaths) => undef)
541 unless grep { defined $_ } values %$cur;
542
543 unless (%ret) {
544 return (); # No valid changes
545 } else {
546 return (_pname($ppaths) => {%ret});
547 }
548}
549
550my %filters = (
551 canonic_domain => sub {
552 my $self = shift;
553 my $new = shift;
554 return lc $new; #FIXME:how about i18n'ed domains?
555 },
556 canonic_email => sub {
557 my $self = shift;
558 my $new = shift;
559 return Sympa::Tools::Text::canonic_email($new);
560 },
561 canonic_lang => sub {
562 my $self = shift;
563 my $new = shift;
564 $new = Sympa::Language::canonic_lang($new); # be scalar
565 return $new;
566 },
567 lc => sub {
568 my $self = shift;
569 my $new = shift;
570 return lc $new;
571 },
572);
573
574# Sanitizes leaf.
575sub _sanitize_changes_leaf {
576 my $self = shift;
577 my $cur = shift;
578 my $new = shift;
579 my $pitem = shift;
580 my $ppaths = shift;
581
582 return () if ref $new eq 'ARRAY'; # Sanity check: Hashref or scalar
583 return () if $pitem->{obsolete};
584 return () unless $pitem->{privilege} eq 'write';
585
586 # If the parameter corresponds to a scenario or a task, mark it
587 # as changed if its name was changed. Example: 'subscribe'.
588 if ($pitem->{scenario} or $pitem->{task}) {
589 return () unless ref($new || {}) eq 'HASH'; # Sanity check
590 $cur = ($cur || {})->{name};
591 $new = ($new || {})->{name};
592 }
593
594 # Resolve synonym.
595 if (defined $new and ref $pitem->{synonym} eq 'HASH') {
596 my $synonym = $pitem->{synonym}->{$new};
597 $new = $synonym if defined $synonym;
598 }
599 # Apply filters.
600 # Note: Erroneous values are overlooked and _not_ eliminated in this step.
601 # We should eliminate them in the step of validation.
602 if (defined $new) {
603 my $f_new = $new;
604 foreach my $filter (@{$pitem->{filters} || []}) {
605 next unless ref $filters{$filter} eq 'CODE';
606 $f_new = $filters{$filter}->($self, $f_new);
607 last unless defined $f_new;
608 }
609 $new = $f_new if defined $f_new;
610 }
611
612 if (Sympa::Tools::Data::smart_eq($cur, $new)) {
613 return (); # Not changed
614 }
615
616 if ($pitem->{scenario} or $pitem->{task}) {
617 return (_pname($ppaths) => {name => $new});
618 } else {
619 return (_pname($ppaths) => $new);
620 }
621}
622
623# Global validations examine the entire configuration for semantic errors or
624# requirements that can't be detected within a single paragraph.
625#
626# Error data is returned in a hashref with the usual keys.
627#
628sub _global_validations { {} }
629
630# Validates changes on list configuration.
631#
632# Parameters:
633# - $new: Hashref including changes.
634# - $errors: Error information, initially may be empty arrayref.
635# Returns:
636# - 'valid' if changes are valid; 'invalid' otherwise;
637# '' if no changes necessary; undef if internal error occurred.
638# - $new may be modified, if there are any omittable changes.
639# - Error information will be added to $errors.
640sub _validate_changes {
641 my $self = shift;
642 my $new = shift;
643 my $errors = shift;
644 my %options = @_;
645
646 my $pinfo = $self->{_pinfo};
647
648 my $ret = 'valid';
649 foreach my $pname (_keys($new, $pinfo)) {
650 my $newi = $new->{$pname};
651 my $pii = $pinfo->{$pname};
652 my $ppi = [$pname];
653
654 my $r;
655 if ($pii->{occurrence} =~ /n$/) {
656 $r =
657 $self->_validate_changes_multiple($newi, $pii, $ppi, $errors);
658 } elsif (ref $pii->{format} eq 'HASH') {
659 $r =
660 $self->_validate_changes_paragraph($newi, $pii, $ppi,
661 $errors);
662 } else {
663 $r = $self->_validate_changes_leaf($newi, $pii, $ppi, $errors);
664 }
665
666 return undef unless defined $r;
667 delete $new->{$pname} if $r eq 'omit';
668 $ret = 'invalid' if $r eq 'invalid';
669 }
670
671 my %global_validations = %{$self->_global_validations || {}}
672 unless $options{no_global_validations};
673 # review the entire new configuration as a whole
674 foreach my $validation (CORE::keys %global_validations) {
675 next unless ref $global_validations{$validation} eq 'CODE';
676 my ($error, $err_info) =
677 $global_validations{$validation}->($self, $new);
678 next unless $error;
679
680 push @$errors, ['user', $error, $err_info];
681 $ret = 'invalid';
682 }
683 return '' unless %$new;
684 return $ret;
685}
686
687# Validates array or set.
688sub _validate_changes_multiple {
689 my $self = shift;
690 my $new = shift;
691 my $pitem = shift;
692 my $ppaths = shift;
693 my $errors = shift;
694
695 if (not defined $new and $pitem->{occurrence} =~ /^1/) {
696 push @$errors,
697 [
698 'user', 'mandatory_parameter',
699 {p_info => $pitem, p_paths => $ppaths}
700 ];
701 return 'omit';
702 }
703
704 my $ret = 'valid';
705 if (defined $new) {
706 foreach my $i (sort { $a <=> $b } CORE::keys %$new) {
707 my $newi = $new->{$i};
708 my $ppi = [@$ppaths, $i];
709
710 if (defined $newi) {
711 my $r;
712 if (ref $pitem->{format} eq 'HASH') {
713 $r =
714 $self->_validate_changes_paragraph($newi, $pitem,
715 $ppi, $errors);
716 } else {
717 $r =
718 $self->_validate_changes_leaf($newi, $pitem, $ppi,
719 $errors);
720 }
721
722 return undef unless defined $r;
723 delete $new->{$i} if $r eq 'omit';
724 $ret = 'invalid' if $r eq 'invalid';
725 }
726 }
727
728 return 'omit' unless %$new;
729 }
730
731 return $ret;
732}
733
734# Validates paragraph.
735sub _validate_changes_paragraph {
736 my $self = shift;
737 my $new = shift;
738 my $pitem = shift;
739 my $ppaths = shift;
740 my $errors = shift;
741
742 if (not defined $new and $pitem->{occurrence} =~ /^1/) {
743 push @$errors,
744 [
745 'user', 'mandatory_parameter',
746 {p_info => $pitem, p_paths => $ppaths}
747 ];
748 return 'omit';
749 }
750
751 my $ret = 'valid';
752 if (defined $new) {
753 foreach my $key (_keys($new, $pitem->{format})) {
754 my $pii = $pitem->{format}->{$key};
755 my $ppi = [@$ppaths, $key];
756 my $newi = $new->{$key};
757
758 my $r;
759 if ($pii->{occurrence} =~ /n$/) {
760 $r =
761 $self->_validate_changes_multiple($newi, $pii, $ppi,
762 $errors);
763 } elsif (ref $pii->{format} eq 'HASH') {
764 $r =
765 $self->_validate_changes_paragraph($newi, $pii, $ppi,
766 $errors);
767 } else {
768 $r =
769 $self->_validate_changes_leaf($newi, $pii, $ppi, $errors);
770 }
771
772 return undef unless defined $r;
773 delete $new->{$key} if $r eq 'omit';
774 $ret = 'invalid' if $r eq 'invalid';
775 }
776
777 return 'omit' unless %$new;
778 }
779
780 return $ret;
781}
782
783sub _local_validations { {} }
784
785# Validates leaf.
786sub _validate_changes_leaf {
787 my $self = shift;
788 my $new = shift;
789 my $pitem = shift;
790 my $ppaths = shift;
791 my $errors = shift;
792
793 # If the parameter corresponds to a scenario or a task, mark it
794 # as changed if its name was changed. Example: 'subscribe'.
795 if ($pitem->{scenario} or $pitem->{task}) {
796 $new = $new->{name} if defined $new;
797 }
798
799 if (not defined $new and $pitem->{occurrence} =~ /^1/) {
800 push @$errors,
801 [
802 'user', 'mandatory_parameter',
803 {p_info => $pitem, p_paths => $ppaths}
804 ];
805 return 'omit';
806 }
807
808 # Check that the new values have the right syntax.
809 if (defined $new) {
810 my $format = $pitem->{format};
811 if (ref $format eq 'ARRAY' and not grep { $new eq $_ } @$format) {
812 push @$errors,
813 [
814 'user', 'syntax_errors',
815 {p_info => $pitem, p_paths => $ppaths, value => $new}
816 ];
817 return 'invalid';
818 } elsif (ref $format ne 'ARRAY' and not $new =~ /^$format$/) {
819 push @$errors,
820 [
821 'user', 'syntax_errors',
822 {p_info => $pitem, p_paths => $ppaths, value => $new}
823 ];
824 return 'invalid';
825 }
826
827 my %validations = %{$self->_local_validations || {}};
828 foreach my $validation (@{$pitem->{validations} || []}) {
829 next unless ref $validations{$validation} eq 'CODE';
830 my ($error, $validity) =
831 $validations{$validation}->($self, $new, $pitem, $ppaths);
832 next unless $error;
833
834 push @$errors,
835 [
836 'user', $error,
837 {p_info => $pitem, p_paths => $ppaths, value => $new}
838 ];
839 return $validity || 'invalid';
840 }
841 }
842
843 return 'valid';
844}
845
846sub commit {
847 my $self = shift;
848 my $errors = shift || [];
849
850 my $pinfo = $self->{_pinfo};
851
852 # Undefined {_config} means list creation.
853 # Empty hashref means loading existing config.
854 my $init = (not defined $self->{_config});
855 my $loading = ($self->{_config} and not %{$self->{_config}});
856 my $cur = $init ? {} : $self->{_config};
857 $self->_apply_defaults($cur, $pinfo, init => ($init and not $loading));
858
859 foreach my $pname (_keys($self->{_changes}, $pinfo)) {
860 my $curi = $cur->{$pname};
861 my $newi = $self->{_changes}->{$pname};
862 my $pii = $pinfo->{$pname};
863
864 unless (defined $newi) {
865 delete $cur->{$pname};
866 } elsif ($pii->{occurrence} =~ /n$/) {
867 $curi = $cur->{$pname} = [] unless defined $curi;
868 $self->_merge_changes_multiple($curi, $newi, $pii,
869 loading => $loading);
870 } elsif (ref $pii->{format} eq 'HASH') {
871 my $init = (not defined $curi);
872 $curi = $cur->{$pname} = {} if $init;
873 $self->_merge_changes_paragraph(
874 $curi, $newi, $pii,
875 init => $init,
876 loading => $loading
877 );
878 } else {
879 $cur->{$pname} = $newi;
880 }
881 }
882
883 $self->{_config} = $cur if $init;
884
885 # Update 'defaults' item to indicate default settings, for compatibility.
886 #FIXME:Multiple levels of keys should be possible.
887 foreach my $pname (_keys($self->{_changes}, $pinfo)) {
888 if (defined $self->{_changes}->{$pname}
889 or $pinfo->{$pname}->{internal}) {
890 delete $self->{_config}->{defaults}->{$pname};
891 } else {
892 $self->{_config}->{defaults}->{$pname} = 1;
893 }
894 }
895}
896
897sub _merge_changes_multiple {
898 my $self = shift;
899 my $cur = shift;
900 my $new = shift;
901 my $pitem = shift;
902 my %options = @_;
903
904 foreach my $i (reverse sort { $a <=> $b } CORE::keys %$new) {
905 my $curi = $cur->[$i];
906 my $newi = $new->{$i};
907
908 unless (defined $new->{$i}) {
909 splice @$cur, $i, 1;
910 } elsif (ref $pitem->{format} eq 'HASH') {
911 my $init = (not defined $curi);
912 $curi = $cur->[$i] = {} if $init;
913 $self->_merge_changes_paragraph(
914 $curi, $newi, $pitem,
915 init => $init,
916 loading => $options{loading}
917 );
918 } else {
919 $cur->[$i] = $newi;
920 }
921 }
922
923 # The set: Dedupe and sort.
924 if (ref $pitem->{format} eq 'ARRAY') {
925 my %elements = map { ($_ => 1) } grep { defined $_ } @$cur;
926 @$cur = sort(CORE::keys %elements);
927 }
928}
929
930# Merges changes on paragraph node.
931# The init option means node creation.
932sub _merge_changes_paragraph {
933 my $self = shift;
934 my $cur = shift;
935 my $new = shift;
936 my $pitem = shift;
937 my %options = @_;
938
939 $self->_apply_defaults($cur, $pitem->{format},
940 init => ($options{init} and not $options{loading}));
941
942 foreach my $key (_keys($new, $pitem->{format})) {
943 my $curi = $cur->{$key};
944 my $newi = $new->{$key};
945 my $pii = $pitem->{format}->{$key};
946
947 unless (defined $newi) {
948 delete $cur->{$key};
949 } elsif ($pii->{occurrence} =~ /n$/) {
950 $curi = $cur->{$key} = [] unless defined $curi;
951 $self->_merge_changes_multiple($curi, $newi, $pii,
952 loading => $options{loading});
953 } elsif (ref $pii->{format} eq 'HASH') {
954 my $init = (not defined $curi);
955 $curi = $cur->{$key} = {} if $init;
956 $self->_merge_changes_paragraph(
957 $curi, $newi, $pii,
958 init => $init,
959 loading => $options{loading}
960 );
961 } else {
962 $cur->{$key} = $newi;
963 }
964 }
965}
966
967sub get_id {
968 my $that = shift->{context};
969 (ref $that eq 'Sympa::List') ? $that->get_id
970 : (defined $that) ? $that
971 : '';
972}
973
9741;
975__END__