← 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/User.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sSympa::User::::AUTOLOADSympa::User::AUTOLOAD
0000s0sSympa::User::::BEGIN@241Sympa::User::BEGIN@241
0000s0sSympa::User::::BEGIN@254Sympa::User::BEGIN@254
0000s0sSympa::User::::BEGIN@30Sympa::User::BEGIN@30
0000s0sSympa::User::::BEGIN@31Sympa::User::BEGIN@31
0000s0sSympa::User::::BEGIN@32Sympa::User::BEGIN@32
0000s0sSympa::User::::BEGIN@33Sympa::User::BEGIN@33
0000s0sSympa::User::::BEGIN@34Sympa::User::BEGIN@34
0000s0sSympa::User::::BEGIN@36Sympa::User::BEGIN@36
0000s0sSympa::User::::BEGIN@37Sympa::User::BEGIN@37
0000s0sSympa::User::::BEGIN@38Sympa::User::BEGIN@38
0000s0sSympa::User::::BEGIN@39Sympa::User::BEGIN@39
0000s0sSympa::User::::BEGIN@40Sympa::User::BEGIN@40
0000s0sSympa::User::::BEGIN@41Sympa::User::BEGIN@41
0000s0sSympa::User::::BEGIN@42Sympa::User::BEGIN@42
0000s0sSympa::User::::CORE:matchSympa::User::CORE:match (opcode)
0000s0sSympa::User::::DESTROYSympa::User::DESTROY
0000s0sSympa::User::::__ANON__Sympa::User::__ANON__ (xsub)
0000s0sSympa::User::::__ANON__[:251]Sympa::User::__ANON__[:251]
0000s0sSympa::User::::__ANON__[:264]Sympa::User::__ANON__[:264]
0000s0sSympa::User::::__ANON__[:321]Sympa::User::__ANON__[:321]
0000s0sSympa::User::::__ANON__[:354]Sympa::User::__ANON__[:354]
0000s0sSympa::User::::add_global_userSympa::User::add_global_user
0000s0sSympa::User::::clean_userSympa::User::clean_user
0000s0sSympa::User::::clean_usersSympa::User::clean_users
0000s0sSympa::User::::delete_global_userSympa::User::delete_global_user
0000s0sSympa::User::::expireSympa::User::expire
0000s0sSympa::User::::get_all_global_userSympa::User::get_all_global_user
0000s0sSympa::User::::get_global_userSympa::User::get_global_user
0000s0sSympa::User::::get_idSympa::User::get_id
0000s0sSympa::User::::get_usersSympa::User::get_users
0000s0sSympa::User::::hash_typeSympa::User::hash_type
0000s0sSympa::User::::is_global_userSympa::User::is_global_user
0000s0sSympa::User::::movetoSympa::User::moveto
0000s0sSympa::User::::newSympa::User::new
0000s0sSympa::User::::password_fingerprintSympa::User::password_fingerprint
0000s0sSympa::User::::saveSympa::User::save
0000s0sSympa::User::::update_global_userSympa::User::update_global_user
0000s0sSympa::User::::update_password_hashSympa::User::update_password_hash
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 2018 The Sympa Community. See the AUTHORS.md file at the
12# 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::User;
29
30use strict;
31use warnings;
32use Carp qw();
33use Digest::MD5;
34BEGIN { eval 'use Crypt::Eksblowfish::Bcrypt qw(bcrypt en_base64)'; }
# spent 0s executing statements in string eval
35
36use Conf;
37use Sympa::DatabaseDescription;
38use Sympa::DatabaseManager;
39use Sympa::Language;
40use Sympa::Log;
41use Sympa::Tools::Data;
42use Sympa::Tools::Text;
43
44my $log = Sympa::Log->instance;
45
46## Database and SQL statement handlers
47my ($sth, @sth_stack);
48
49## mapping between var and field names
50my %db_struct = Sympa::DatabaseDescription::full_db_struct();
51my %map_field;
52foreach my $k (keys %{$db_struct{'user_table'}->{'fields'}}) {
53 if ($k =~ /^(.+)_user$/) {
54 $map_field{$1} = $k;
55 }
56}
57
58## DB fields with numeric type
59## We should not do quote() for these while inserting data
60my %numeric_field;
61foreach my $k (keys %{$db_struct{'user_table'}->{'fields'}}) {
62 if ($db_struct{'user_table'}->{'fields'}{$k}{'struct'} =~ /^int/) {
63 $numeric_field{$k} = 1;
64 }
65}
66
67=encoding utf-8
68
69=head1 NAME
70
71Sympa::User - All Users Identified by Sympa
72
73=head1 DESCRIPTION
74
75=head2 CONSTRUCTOR
76
77=over 4
78
79=item new ( EMAIL, [ KEY => VAL, ... ] )
80
81Create new Sympa::User object.
82
83=back
84
85=cut
86
87sub new {
88 my $pkg = shift;
89 my $who = Sympa::Tools::Text::canonic_email(shift);
90 my %values = @_;
91 my $self;
92 return undef unless defined $who;
93
94 ## Canonicalize lang if possible
95 $values{'lang'} = Sympa::Language::canonic_lang($values{'lang'})
96 || $values{'lang'}
97 if $values{'lang'};
98
99 if (!($self = get_global_user($who))) {
100 ## unauthenticated user would not be added to database.
101 $values{'email'} = $who;
102 if (scalar grep { $_ ne 'lang' and $_ ne 'email' } keys %values) {
103 unless (defined add_global_user(\%values)) {
104 return undef;
105 }
106 }
107 $self = \%values;
108 }
109
110 bless $self => $pkg;
111}
112
113=head2 METHODS
114
115=over 4
116
117=item expire
118
119Remove user information from user_table.
120
121=back
122
123=cut
124
125sub expire {
126 delete_global_user(shift->email);
127}
128
129=over 4
130
131=item get_id
132
133Get unique identifier of object.
134
135=back
136
137=cut
138
139sub get_id {
140 ## DO NOT use accessors since $self may not have been fully initialized.
141 shift->{'email'} || '';
142}
143
144=over 4
145
146=item moveto
147
148Change email of user.
149
150=back
151
152=cut
153
154sub moveto {
155 my $self = shift;
156 my $newemail = Sympa::Tools::Text::canonic_email(shift);
157
158 unless (defined $newemail) {
159 $log->syslog('err', 'No email');
160 return undef;
161 }
162 if ($self->email eq $newemail) {
163 return 0;
164 }
165
166 push @sth_stack, $sth;
167 my $sdm = Sympa::DatabaseManager->instance;
168
169 unless (
170 $sdm
171 and $sth = $sdm->do_prepared_query(
172 q{UPDATE user_table
173 SET email_user = ?
174 WHERE email_user = ?},
175 $newemail, $self->email
176 )
177 ) {
178 $log->syslog('err', 'Can\'t move user %s to %s', $self, $newemail);
179 $sth = pop @sth_stack;
180 return undef;
181 }
182
183 $sth = pop @sth_stack;
184
185 $self->{'email'} = $newemail;
186
187 return 1;
188}
189
190=over 4
191
192=item save
193
194Save user information to user_table.
195
196=back
197
198=cut
199
200sub save {
201 my $self = shift;
202 unless (add_global_user('email' => $self->email, %$self)
203 or update_global_user($self->email, %$self)) {
204 $log->syslog('err', 'Cannot save user %s', $self);
205 return undef;
206 }
207
208 return 1;
209}
210
211=head3 ACCESSORS
212
213=over 4
214
215=item E<lt>attributeE<gt>
216
217=item E<lt>attributeE<gt>C<( VALUE )>
218
219I<Getters/Setters>.
220Get or set user attributes.
221For example C<$user-E<gt>gecos> returns "gecos" parameter of the user,
222and C<$user-E<gt>gecos("foo")> also changes it.
223Basic user profile "email" have only getter,
224so it is read-only.
225
226=back
227
228=cut
229
230our $AUTOLOAD;
231
232sub DESTROY { } # "sub DESTROY;" may cause segfault with Perl around 5.10.1.
233
234sub AUTOLOAD {
235 $AUTOLOAD =~ m/^(.*)::(.*)/;
236
237 my $attr = $2;
238
239 if (scalar grep { $_ eq $attr } qw(email)) {
240 ## getter for user attribute.
241 no strict "refs";
242 *{$AUTOLOAD} = sub {
243 my $self = shift;
244 Carp::croak "Can't call method \"$attr\" on uninitialized "
245 . ref($self)
246 . " object"
247 unless $self->{'email'};
248 Carp::croak "Can't modify \"$attr\" attribute"
249 if scalar @_ > 1;
250 $self->{$attr};
251 };
252 } elsif (exists $map_field{$attr}) {
253 ## getter/setter for user attributes.
254 no strict "refs";
255 *{$AUTOLOAD} = sub {
256 my $self = shift;
257 Carp::croak "Can't call method \"$attr\" on uninitialized "
258 . ref($self)
259 . " object"
260 unless $self->{'email'};
261 $self->{$attr} = shift
262 if scalar @_ > 1;
263 $self->{$attr};
264 };
265 } else {
266 Carp::croak "Can't locate object method \"$2\" via package \"$1\"";
267 }
268 goto &$AUTOLOAD;
269}
270
271=head2 FUNCTIONS
272
273=over 4
274
275=item get_users ( ... )
276
277Not yet implemented.
278
279=back
280
281=cut
282
283sub get_users {
284 die;
285}
286
287=over 4
288
289=item password_fingerprint ( )
290
291Returns the password finger print.
292
293=back
294
295=cut
296
297# Old name: Sympa::Auth::password_fingerprint().
298#
299# Password fingerprint functions are stored in a table. Currently supported
300# algorithms are the default 'md5', and 'bcrypt'.
301#
302# If the algorithm uses a salt (e.g. bcrypt) and the second parameter $salt
303# is not provided, a random one will be generated.
304#
305
306my %fingerprint_hashes = (
307 # default is to use MD5, which does not use a salt
308 'md5' => sub {
309 my ($pwd, $salt) = @_;
310
311 $salt = '' unless defined $salt;
312
313 # salt parameter is not used for MD5 hashes
314 my $fingerprint = Digest::MD5::md5_hex($pwd);
315 my $match = ($fingerprint eq $salt) ? "yes" : "no";
316
317 $log->syslog('debug', 'md5: match %s salt \"%s\" fingerprint %s',
318 $match, $salt, $fingerprint);
319
320 return $fingerprint;
321 },
322 # bcrypt uses a salt and has a configurable "cost" parameter
323 'bcrypt' => sub {
324 my ($pwd, $salt) = @_;
325
326 die "bcrypt support unavailable: install Crypt::Eksblowfish::Bcrypt"
327 unless $Crypt::Eksblowfish::Bcrypt::VERSION;
328
329 # A bcrypt-encrypted password contains the settings at the front.
330 # If this not look like a settings string, create one.
331 unless (defined($salt)
332 && $salt =~ m#\A\$2(a?)\$([0-9]{2})\$([./A-Za-z0-9]{22})#x) {
333 my $bcrypt_cost = Conf::get_robot_conf('*', 'bcrypt_cost');
334 my $cost = sprintf("%02d", 0 + $bcrypt_cost);
335 my $newsalt = "";
336
337 for my $i (0 .. 15) {
338 $newsalt .= chr(rand(256));
339 }
340 $newsalt = '$2a$' . $cost . '$' . en_base64($newsalt);
341 $log->syslog('debug',
342 "bcrypt: create new salt: cost $cost \"$newsalt\"");
343
344 $salt = $newsalt;
345 }
346
347 my $fingerprint = bcrypt($pwd, $salt);
348 my $match = ($fingerprint eq $salt) ? "yes" : "no";
349
350 $log->syslog('debug', 'bcrypt: match %s salt \"%s\" fingerprint %s',
351 $match, $salt, $fingerprint);
352
353 return $fingerprint;
354 }
355);
356
357sub password_fingerprint {
358
359 my ($pwd, $salt) = @_;
360
361 $log->syslog('debug', "salt \"%s\"", $salt);
362
363 my $password_hash = Conf::get_robot_conf('*', 'password_hash');
364 my $password_hash_update =
365 Conf::get_robot_conf('*', 'password_hash_update');
366
367 if (Conf::get_robot_conf('*', 'password_case') eq 'insensitive') {
368 $pwd = lc($pwd);
369 }
370
371 # If updating hashes, honor the hash type implied by $salt. This lets
372 # the user successfully log in, after which the hash can be updated
373
374 if ($password_hash_update) {
375 if (defined($salt) && defined(my $hash_type = hash_type($salt))) {
376 $log->syslog('debug', "honoring hash_type %s", $hash_type);
377 $password_hash = $hash_type;
378 }
379 }
380
381 die "password_fingerprint: unknown password_hash \"$password_hash\""
382 unless defined($fingerprint_hashes{$password_hash});
383
384 return $fingerprint_hashes{$password_hash}->($pwd, $salt);
385}
386
387=over 4
388
389=item hash_type ( )
390
391detect the type of password fingerprint used for a hashed password
392
393Returns undef if no supported hash type is detected
394
395=back
396
397=cut
398
399sub hash_type {
400 my $hash = shift;
401
402 return 'md5' if ($hash =~ /^[a-f0-9]{32}$/i);
403 return 'bcrypt'
404 if ($hash =~ m#\A\$2(a?)\$([0-9]{2})\$([./A-Za-z0-9]{22})#);
405 return undef;
406}
407
408=over 4
409
410=item update_password_hash ( )
411
412If needed, update the hash used for the user's encrypted password entry
413
414=back
415
416=cut
417
418sub update_password_hash {
419 my ($user, $pwd) = @_;
420
421 return unless (Conf::get_robot_conf('*', 'password_hash_update'));
422
423 # here if configured to check and update the password hash algorithm
424
425 my $user_hash = hash_type($user->{'password'});
426 my $system_hash = Conf::get_robot_conf('*', 'password_hash');
427
428 return if (defined($user_hash) && ($user_hash eq $system_hash));
429
430 # note that we directly use the callback for the hash type
431 # instead of using any other logic to determine which to call
432
433 $log->syslog('debug', 'update password hash for %s from %s to %s',
434 $user->{'email'}, $user_hash, $system_hash);
435
436 # note that we use the cleartext password here, not the hash
437 update_global_user($user->{'email'}, {password => $pwd});
438
439}
440
441############################################################################
442## Old-style functions
443############################################################################
444
445=head2 OLD STYLE FUNCTIONS
446
447=over 4
448
449=item add_global_user
450
451=item delete_global_user
452
453=item is_global_user
454
455=item get_global_user
456
457=item get_all_global_user
458
459I<Obsoleted>.
460
461=item update_global_user
462
463=back
464
465=cut
466
467## Delete a user in the user_table
468sub delete_global_user {
469 my @users = @_;
470
471 $log->syslog('debug2', '');
472
473 return undef unless @users;
474
475 my $sdm = Sympa::DatabaseManager->instance;
476 foreach my $who (@users) {
477 $who = Sympa::Tools::Text::canonic_email($who);
478
479 # Update field
480 unless (
481 $sdm
482 and $sdm->do_prepared_query(
483 q{DELETE FROM user_table WHERE email_user = ?}, $who
484 )
485 ) {
486 $log->syslog('err', 'Unable to delete user %s', $who);
487 next;
488 }
489 }
490
491 return scalar @users;
492}
493
494## Returns a hash for a given user
495sub get_global_user {
496 $log->syslog('debug2', '(%s)', @_);
497 my $who = Sympa::Tools::Text::canonic_email(shift);
498
499 ## Additional subscriber fields
500 my $additional = '';
501 if ($Conf::Conf{'db_additional_user_fields'}) {
502 $additional = ', ' . $Conf::Conf{'db_additional_user_fields'};
503 }
504
505 push @sth_stack, $sth;
506 my $sdm = Sympa::DatabaseManager->instance;
507
508 unless (
509 $sdm
510 and $sth = $sdm->do_prepared_query(
511 sprintf(
512 q{SELECT email_user AS email, gecos_user AS gecos,
513 password_user AS password,
514 cookie_delay_user AS cookie_delay, lang_user AS lang,
515 attributes_user AS attributes, data_user AS data,
516 last_login_date_user AS last_login_date,
517 wrong_login_count_user AS wrong_login_count,
518 last_login_host_user AS last_login_host%s
519 FROM user_table
520 WHERE email_user = ?},
521 $additional
522 ),
523 $who
524 )
525 ) {
526 $log->syslog('err', 'Failed to prepare SQL query');
527 $sth = pop @sth_stack;
528 return undef;
529 }
530
531 my $user = $sth->fetchrow_hashref('NAME_lc');
532 $sth->finish();
533
534 $sth = pop @sth_stack;
535
536 if (defined $user) {
537 # Canonicalize lang if possible.
538 if ($user->{'lang'}) {
539 $user->{'lang'} = Sympa::Language::canonic_lang($user->{'lang'})
540 || $user->{'lang'};
541 }
542
543 ## Turn user_attributes into a hash
544 my $attributes = $user->{'attributes'};
545 if (defined $attributes and length $attributes) {
546 $user->{'attributes'} = {};
547 foreach my $attr (split(/__ATT_SEP__/, $attributes)) {
548 my ($key, $value) = split(/__PAIRS_SEP__/, $attr);
549 $user->{'attributes'}{$key} = $value;
550 }
551 delete $user->{'attributes'}
552 unless scalar keys %{$user->{'attributes'}};
553 } else {
554 delete $user->{'attributes'};
555 }
556 ## Turn data_user into a hash
557 if ($user->{'data'}) {
558 my %prefs = Sympa::Tools::Data::string_2_hash($user->{'data'});
559 $user->{'prefs'} = \%prefs;
560 }
561 }
562
563 return $user;
564}
565
566## Returns an array of all users in User table hash for a given user
567# OBSOLETED: No longer used.
568sub get_all_global_user {
569 $log->syslog('debug2', '');
570
571 my @users;
572
573 push @sth_stack, $sth;
574 my $sdm = Sympa::DatabaseManager->instance;
575
576 unless ($sdm
577 and $sth =
578 $sdm->do_prepared_query('SELECT email_user FROM user_table')) {
579 $log->syslog('err', 'Unable to gather all users in DB');
580 $sth = pop @sth_stack;
581 return undef;
582 }
583
584 while (my $email = ($sth->fetchrow_array)[0]) {
585 push @users, $email;
586 }
587 $sth->finish();
588
589 $sth = pop @sth_stack;
590
591 return @users;
592}
593
594## Is the person in user table (db only)
595sub is_global_user {
596 my $who = Sympa::Tools::Text::canonic_email(pop);
597 $log->syslog('debug3', '(%s)', $who);
598
599 return undef unless defined $who;
600
601 push @sth_stack, $sth;
602 my $sdm = Sympa::DatabaseManager->instance;
603
604 ## Query the Database
605 unless (
606 $sdm
607 and $sth = $sdm->do_prepared_query(
608 q{SELECT COUNT(*) FROM user_table WHERE email_user = ?}, $who
609 )
610 ) {
611 $log->syslog('err',
612 'Unable to check whether user %s is in the user table');
613 $sth = pop @sth_stack;
614 return undef;
615 }
616
617 my $is_user = $sth->fetchrow();
618 $sth->finish();
619
620 $sth = pop @sth_stack;
621
622 return $is_user;
623}
624
625## Sets new values for the given user in the Database
626sub update_global_user {
627 $log->syslog('debug', '(%s, ...)', @_);
628 my $who = shift;
629 my $values = $_[0];
630 if (ref $values) {
631 $values = {%$values};
632 } else {
633 $values = {@_};
634 }
635
636 $who = Sympa::Tools::Text::canonic_email($who);
637
638 ## use hash fingerprint to store password
639 ## hashes that use salts will randomly generate one
640 ## avoid rehashing passwords that are already hash strings
641 if ($values->{'password'}) {
642 if (defined(hash_type($values->{'password'}))) {
643 $log->syslog(
644 'debug',
645 'password is in %s format, not rehashing',
646 hash_type($values->{'password'})
647 );
648 } else {
649 $values->{'password'} =
650 Sympa::User::password_fingerprint($values->{'password'},
651 undef);
652 }
653 }
654
655 ## Canonicalize lang if possible.
656 $values->{'lang'} = Sympa::Language::canonic_lang($values->{'lang'})
657 || $values->{'lang'}
658 if $values->{'lang'};
659
660 my $sdm = Sympa::DatabaseManager->instance;
661 unless ($sdm) {
662 $log->syslog('err', 'Unavailable database connection');
663 return undef;
664 }
665
666 my ($field, $value);
667
668 ## Update each table
669 my @set_list;
670
671 while (($field, $value) = each %{$values}) {
672 unless ($map_field{$field}) {
673 $log->syslog('err',
674 'Unknown field %s in map_field internal error', $field);
675 next;
676 }
677 my $set;
678
679 if ($numeric_field{$map_field{$field}}) {
680 $value ||= 0; ## Can't have a null value
681 $set = sprintf '%s=%s', $map_field{$field}, $value;
682 } elsif ($field eq 'data' and ref $value eq 'HASH') {
683 $set = sprintf '%s=%s', $map_field{$field},
684 $sdm->quote(Sympa::Tools::Data::hash_2_string($value));
685 } elsif ($field eq 'attributes' and ref $value eq 'HASH') {
686 $set = sprintf '%s=%s', $map_field{$field},
687 $sdm->quote(
688 join '__ATT_SEP__',
689 map { sprintf '%s__PAIRS_SEP__%s', $_, $value->{$_} }
690 sort keys %$value
691 );
692 } else {
693 $set = sprintf '%s=%s', $map_field{$field}, $sdm->quote($value);
694 }
695 push @set_list, $set;
696 }
697
698 return undef unless @set_list;
699
700 ## Update field
701
702 push @sth_stack, $sth;
703
704 $sth = $sdm->do_query(
705 "UPDATE user_table SET %s WHERE (email_user=%s)",
706 join(',', @set_list),
707 $sdm->quote($who)
708 );
709 unless (defined $sth) {
710 $log->syslog('err',
711 'Could not update information for user %s in user_table', $who);
712 $sth = pop @sth_stack;
713 return undef;
714 }
715
716 $sth = pop @sth_stack;
717
718 return 1;
719}
720
721## Adds a user to the user_table
722sub add_global_user {
723 $log->syslog('debug3', '(...)');
724 my $values = $_[0];
725 if (ref $values) {
726 $values = {%$values};
727 } else {
728 $values = {@_};
729 }
730
731 my $sdm = Sympa::DatabaseManager->instance;
732 unless ($sdm) {
733 $log->syslog('err', 'Unavailable database connection');
734 return undef;
735 }
736
737 my ($field, $value);
738
739 ## encrypt password with the configured password hash algorithm
740 ## an salt of 'undef' means generate a new random one
741 ## avoid rehashing passwords that are already hash strings
742 if ($values->{'password'}) {
743 if (defined(hash_type($values->{'password'}))) {
744 $log->syslog(
745 'debug',
746 'password is in %s format, not rehashing',
747 hash_type($values->{'password'})
748 );
749 } else {
750 $values->{'password'} =
751 Sympa::User::password_fingerprint($values->{'password'},
752 undef);
753 }
754 }
755
756 ## Canonicalize lang if possible
757 $values->{'lang'} = Sympa::Language::canonic_lang($values->{'lang'})
758 || $values->{'lang'}
759 if $values->{'lang'};
760
761 my $who = Sympa::Tools::Text::canonic_email($values->{'email'});
762 return undef unless defined $who;
763 return undef if (is_global_user($who));
764
765 ## Update each table
766 my (@insert_field, @insert_value);
767 while (($field, $value) = each %{$values}) {
768
769 next unless ($map_field{$field});
770
771 my $insert;
772 if ($numeric_field{$map_field{$field}}) {
773 $value ||= 0; ## Can't have a null value
774 $insert = $value;
775 } else {
776 $insert = $sdm->quote($value);
777 }
778 push @insert_value, $insert;
779 push @insert_field, $map_field{$field};
780 }
781
782 unless (@insert_field) {
783 $log->syslog(
784 'err',
785 'The fields (%s) do not correspond to anything in the database',
786 join(',', keys(%{$values}))
787 );
788 return undef;
789 }
790
791 push @sth_stack, $sth;
792
793 ## Update field
794 $sth = $sdm->do_query(
795 "INSERT INTO user_table (%s) VALUES (%s)",
796 join(',', @insert_field),
797 join(',', @insert_value)
798 );
799 unless (defined $sth) {
800 $log->syslog('err',
801 'Unable to add user %s to the DB table user_table',
802 $values->{'email'});
803 $sth = pop @sth_stack;
804 return undef;
805 }
806 unless ($sth->rows) {
807 $sth = pop @sth_stack;
808 return 0;
809 }
810
811 $sth = pop @sth_stack;
812
813 return 1;
814}
815
816=head2 Miscellaneous
817
818=over 4
819
820=item clean_user ( USER_OR_HASH )
821
822=item clean_users ( ARRAYREF_OF_USERS_OR_HASHES )
823
824I<Function>.
825Warn if the argument is not a Sympa::User object.
826Return Sympa::User object, if any.
827
828I<TENTATIVE>.
829These functions will be used during transition between old and object-oriented
830styles. At last modifications have been done, they shall be removed.
831
832=back
833
834=cut
835
836sub clean_user {
837 my $user = shift;
838
839 unless (ref $user eq 'Sympa::User') {
840 local $Carp::CarpLevel = 1;
841 Carp::carp("Deprecated usage: user should be a Sympa::User object");
842
843 if (ref $user eq 'HASH') {
844 $user = bless $user => __PACKAGE__;
845 } else {
846 $user = undef;
847 }
848 }
849 $user;
850}
851
852sub clean_users {
853 my $users = shift;
854 return $users unless ref $users eq 'ARRAY';
855
856 my $warned = 0;
857 foreach my $user (@$users) {
858 unless (ref $user eq 'Sympa::User') {
859 unless ($warned) {
860 local $Carp::CarpLevel = 1;
861 Carp::carp(
862 "Deprecated usage: user should be a Sympa::User object");
863
864 $warned = 1;
865 }
866 if (ref $user eq 'HASH') {
867 $user = bless $user => __PACKAGE__;
868 } else {
869 $user = undef;
870 }
871 }
872 }
873 return $users;
874}
875
8761;