Database.pm 18.5 KB
Newer Older
1
2
3
# -*- indent-tabs-mode: nil; -*-
# vim:ft=perl:et:sw=4
# $Id$
4
5

# Sympa - SYsteme de Multi-Postage Automatique
6
7
8
9
#
# Copyright (c) 1997, 1998, 1999 Institut Pasteur & Christophe Wolfhugel
# Copyright (c) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
# 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, 2021 The Sympa Community. See the
12
# AUTHORS.md file at the top-level directory of this distribution and at
13
# <https://github.com/sympa-community/sympa.git>.
14
15
16
17
18
19
20
21
22
23
24
25
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# 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::Database;
29
30

use strict;
31
use warnings;
32
use DBI;
33
use English qw(-no_match_vars);
34

35
use Sympa;
36
use Sympa::Log;
37

38
my $log = Sympa::Log->instance;
39

40
41
42
43
# Structure to keep track of active connections/connection status
# Keys: unique ID of connection (includes type, server, port, dbname and user).
# Values: database handler.
our %connection_of;
sikeda's avatar
sikeda committed
44
our %persistent_connection_of;
45

46
47
48
49
50
# Map to driver names from older format of db_type parameter.
my %driver_aliases = (
    mysql => 'Sympa::DatabaseDriver::MySQL',
    Pg    => 'Sympa::DatabaseDriver::PostgreSQL',
);
51

52
53
# Sympa::Database is the proxy class of Sympa::DatabaseDriver subclasses.
# The constructor may be overridden by _new() method.
54
sub new {
55
    $log->syslog('debug2', '(%s, %s)', @_);
56
57
58
    my $class   = shift;
    my $db_type = shift;
    my %params  = @_;
59

60
    my $driver = $driver_aliases{$db_type} || $db_type;
61
62
63
64
    $driver = 'Sympa::DatabaseDriver::' . $driver
        unless $driver =~ /::/;
    unless (eval "require $driver"
        and $driver->isa('Sympa::DatabaseDriver')) {
65
        $log->syslog('err', 'Unable to use %s module: %s',
sikeda's avatar
sikeda committed
66
            $driver, $EVAL_ERROR || 'Not a Sympa::DatabaseDriver class');
67
        return undef;
68
    }
69

70
71
    return $driver->_new(
        $db_type,
72
73
74
75
        map {
                  (exists $params{$_} and defined $params{$_})
                ? ($_ => $params{$_})
                : ()
Luc Didry's avatar
Luc Didry committed
76
77
        } ( @{$driver->required_parameters}, @{$driver->optional_parameters}
        )
78
79
    );
}
80

81
82
83
84
85
86
sub _new {
    my $class   = shift;
    my $db_type = shift;
    my %params  = @_;

    return bless {%params} => $class;
87
88
}

89
############################################################
90
#  connect
91
############################################################
92
#  Connect to an SQL database.
93
#
94
# IN : $options : ref to a hash. Options for the connection process.
95
96
97
#         currently accepts 'keep_trying' : wait and retry until
#         db connection is ok (boolean) ; 'warn' : warn
#         listmaster if connection fails (boolean)
98
# OUT : 1 | undef
99
100
#
##############################################################
101
sub connect {
102
    $log->syslog('debug3', '(%s)', @_);
103
    my $self = shift;
104

105
106
    # First check if we have an active connection with this server
    if ($self->ping) {
107
        $log->syslog('debug3', 'Connection to database %s already available',
108
109
110
            $self);
        return 1;
    }
111
112
113
114
115
116
117
    # Disconnected: Transaction (if any) was aborted.
    if (delete $self->{_sdbTransactionLevel}) {
        $log->syslog('err', 'Transaction on database %s was aborted: %s',
            $self, $DBI::errstr);
        $self->set_persistent($self->{_sdbPrevPersistency});
        return undef;
    }
118
119
120
121

    # Do we have required parameters?
    foreach my $param (@{$self->required_parameters}) {
        unless (defined $self->{$param}) {
122
            $log->syslog('info', 'Missing parameter %s for DBI connection',
123
                $param);
124
125
            return undef;
        }
126
    }
127
128
129
130

    # Check if required module such as DBD is installed.
    foreach my $module (@{$self->required_modules}) {
        unless (eval "require $module") {
131
            $log->syslog(
132
133
134
135
136
                'err',
                'A module for %s is not installed. You should download and install %s',
                ref($self),
                $module
            );
137
            Sympa::send_notify_to_listmaster('*', 'missing_dbd',
138
139
                {'db_type' => ref($self), 'db_module' => $module});
            return undef;
140
        }
141
    }
142
143
144
    foreach my $module (@{$self->optional_modules}) {
        eval "require $module";
    }
145

146
147
    # Set unique ID to determine connection.
    $self->{_id} = $self->get_id;
148

149
150
151
152
153
154
155
156
157
    # Establish new connection.

    # Set environment variables
    # Used by Oracle (ORACLE_HOME) etc.
    if ($self->{'db_env'}) {
        foreach my $env (split /;/, $self->{'db_env'}) {
            my ($key, $value) = split /=/, $env, 2;
            $ENV{$key} = $value if ($key);
        }
158
    }
159

160
    $connection_of{$self->{_id}} = eval { $self->_connect };
161

162
    unless ($self->ping) {
sikeda's avatar
sikeda committed
163
        unless ($persistent_connection_of{$self->{_id}}) {
Luc Didry's avatar
Luc Didry committed
164
165
            $log->syslog('err', 'Can\'t connect to Database %s: %s',
                $self, $DBI::errstr);
166
167
168
            $self->{_status} = 'failed';
            return undef;
        }
169

170
        # Notify listmaster unless the 'failed' status was set earlier.
171
        $log->syslog('err', 'Can\'t connect to Database %s, still trying...',
172
173
            $self);
        unless ($self->{_status} and $self->{_status} eq 'failed') {
174
            Sympa::send_notify_to_listmaster('*', 'no_db', {});
175
176
        }

177
178
179
180
181
182
183
        # Loop until connect works
        my $sleep_delay = 60;
        while (1) {
            sleep $sleep_delay;
            $connection_of{$self->{_id}} = eval { $self->_connect };
            last if $self->ping;
            $sleep_delay += 10;
184
185
        }

186
        delete $self->{_status};
187

188
        $log->syslog('notice', 'Connection to Database %s restored', $self);
189
        Sympa::send_notify_to_listmaster('*', 'db_restored', {});
190
    }
191

192
    $log->syslog('debug2', 'Connected to Database %s', $self);
193

194
195
    return 1;
}
196

197
198
# Merged into connect(().
#sub establish_connection();
199

200
201
sub _connect {
    my $self = shift;
202

203
204
205
206
207
208
209
210
    my $connection = DBI->connect(
        $self->build_connect_string, $self->{'db_user'},
        $self->{'db_passwd'}, {PrintError => 0}
    );
    # Force field names to be lowercased.
    # This has has been added after some problems of field names
    # upercased with Oracle.
    $connection->{FetchHashKeyName} = 'NAME_lc' if $connection;
211

212
213
    return $connection;
}
214

215
216
217
sub __dbh {
    my $self = shift;
    return $connection_of{$self->{_id} || ''};
218
219
}

220
221
222
223
sub do_operation {
    die 'Not implemented';
}

224
sub do_query {
225
226
    my $self   = shift;
    my $query  = shift;
227
228
    my @params = @_;

229
230
    my $sth;

sikeda's avatar
sikeda committed
231
232
    $query =~ s/^\s+//;
    $query =~ s/\s+$//;
233
234
    my $statement = sprintf $query, @params;

sikeda's avatar
sikeda committed
235
236
    my $s = $statement;
    $s =~ s/\n\s*/ /g;
237
    $log->syslog('debug3', 'Will perform query "%s"', $s);
sikeda's avatar
sikeda committed
238

sikeda's avatar
sikeda committed
239
    unless ($self->__dbh and $sth = $self->__dbh->prepare($statement)) {
240
241
242
        # Check connection to database in case it would be the cause of the
        # problem.
        unless ($self->connect()) {
243
            $log->syslog('err', 'Unable to get a handle to %s database',
244
245
246
                $self->{'db_name'});
            return undef;
        } else {
sikeda's avatar
sikeda committed
247
248
            unless ($self->__dbh and $sth = $self->__dbh->prepare($statement))
            {
249
250
                my $trace_statement = sprintf $query,
                    @{$self->prepare_query_log_values(@params)};
251
                $log->syslog('err', 'Unable to prepare SQL statement %s: %s',
252
                    $trace_statement, $self->error);
253
254
255
                return undef;
            }
        }
256
    }
257
    unless ($sth->execute) {
258
259
260
        # Check connection to database in case it would be the cause of the
        # problem.
        unless ($self->connect()) {
261
            $log->syslog('err', 'Unable to get a handle to %s database',
262
263
264
                $self->{'db_name'});
            return undef;
        } else {
265
            unless ($sth = $self->__dbh->prepare($statement)) {
266
267
268
                # Check connection to database in case it would be the cause
                # of the problem.
                unless ($self->connect()) {
269
                    $log->syslog('err',
270
271
272
273
                        'Unable to get a handle to %s database',
                        $self->{'db_name'});
                    return undef;
                } else {
274
                    unless ($sth = $self->__dbh->prepare($statement)) {
275
276
                        my $trace_statement = sprintf $query,
                            @{$self->prepare_query_log_values(@params)};
277
                        $log->syslog('err',
278
                            'Unable to prepare SQL statement %s: %s',
279
                            $trace_statement, $self->error);
280
281
282
283
                        return undef;
                    }
                }
            }
284
            unless ($sth->execute) {
285
286
                my $trace_statement = sprintf $query,
                    @{$self->prepare_query_log_values(@params)};
287
288
                $log->syslog('err',
                    'Unable to execute SQL statement "%s": %s',
289
                    $trace_statement, $self->error);
290
291
292
                return undef;
            }
        }
293
294
    }

295
    return $sth;
296
297
298
}

sub do_prepared_query {
299
300
    my $self   = shift;
    my $query  = shift;
sikeda's avatar
sikeda committed
301
    my @params = ();
302
    my %types  = ();
sikeda's avatar
sikeda committed
303

304
305
    my $sth;

sikeda's avatar
sikeda committed
306
307
308
    ## get binding types and parameters
    my $i = 0;
    while (scalar @_) {
309
310
311
312
313
314
        my $p = shift;
        if (ref $p eq 'HASH') {
            # a hashref { sql_type => SQL_type } etc.
            $types{$i} = $p;
            push @params, shift;
        } elsif (ref $p) {
315
            $log->syslog('err', 'Unexpected %s object.  Ask developer',
316
317
318
319
320
321
                ref $p);
            return undef;
        } else {
            push @params, $p;
        }
        $i++;
sikeda's avatar
sikeda committed
322
    }
323

sikeda's avatar
sikeda committed
324
325
326
    $query =~ s/^\s+//;
    $query =~ s/\s+$//;
    $query =~ s/\n\s*/ /g;
327
    $log->syslog('debug3', 'Will perform query "%s"', $query);
sikeda's avatar
sikeda committed
328
329

    if ($self->{'cached_prepared_statements'}{$query}) {
330
        $sth = $self->{'cached_prepared_statements'}{$query};
sikeda's avatar
sikeda committed
331
    } else {
332
        $log->syslog('debug3',
333
            'Did not find prepared statement for %s. Doing it', $query);
sikeda's avatar
sikeda committed
334
        unless ($self->__dbh and $sth = $self->__dbh->prepare($query)) {
335
            unless ($self->connect()) {
336
                $log->syslog('err', 'Unable to get a handle to %s database',
337
338
339
                    $self->{'db_name'});
                return undef;
            } else {
sikeda's avatar
sikeda committed
340
341
                unless ($self->__dbh and $sth = $self->__dbh->prepare($query))
                {
342
                    $log->syslog('err', 'Unable to prepare SQL statement: %s',
343
                        $self->error);
344
345
346
347
348
349
350
351
352
353
354
355
356
                    return undef;
                }
            }
        }

        ## bind parameters with special types
        ## this may be done only once when handle is prepared.
        foreach my $i (sort keys %types) {
            $sth->bind_param($i + 1, $params[$i], $types{$i});
        }

        $self->{'cached_prepared_statements'}{$query} = $sth;
    }
sikeda's avatar
sikeda committed
357
    unless ($sth->execute(@params)) {
358
359
360
        # Check database connection in case it would be the cause of the
        # problem.
        unless ($self->connect()) {
361
            $log->syslog('err', 'Unable to get a handle to %s database',
362
363
364
                $self->{'db_name'});
            return undef;
        } else {
365
            unless ($sth = $self->__dbh->prepare($query)) {
366
                unless ($self->connect()) {
367
                    $log->syslog('err',
368
369
370
371
                        'Unable to get a handle to %s database',
                        $self->{'db_name'});
                    return undef;
                } else {
372
                    unless ($sth = $self->__dbh->prepare($query)) {
373
                        $log->syslog('err',
374
                            'Unable to prepare SQL statement: %s',
375
                            $self->error);
376
377
378
379
380
381
382
383
384
385
386
387
388
                        return undef;
                    }
                }
            }

            ## bind parameters with special types
            ## this may be done only once when handle is prepared.
            foreach my $i (sort keys %types) {
                $sth->bind_param($i + 1, $params[$i], $types{$i});
            }

            $self->{'cached_prepared_statements'}{$query} = $sth;
            unless ($sth->execute(@params)) {
389
390
                $log->syslog('err',
                    'Unable to execute SQL statement "%s": %s',
391
                    $query, $self->error);
392
393
394
                return undef;
            }
        }
395
396
    }

sikeda's avatar
sikeda committed
397
    return $sth;
398
399
400
401
402
403
}

sub prepare_query_log_values {
    my $self = shift;
    my @result;
    foreach my $value (@_) {
404
405
406
407
408
        my $cropped = substr($value, 0, 100);
        if ($cropped ne $value) {
            $cropped .= "...[shortened]";
        }
        push @result, $cropped;
409
410
    }
    return \@result;
411
412
}

413
414
# DEPRECATED: Use tools::eval_in_time() and fetchall_arrayref().
#sub fetch();
415

416
417
sub begin {
    my $self = shift;
418

419
    my $dbh = $self->__dbh;
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
    return undef unless $dbh;

    return undef unless $dbh->begin_work;

    $self->{_sdbTransactionLevel} //= 0;
    unless ($self->{_sdbTransactionLevel}++) {
        $self->{_sdbPrevPersistency} = $self->set_persistent(0);
    }

    return 1;
}

sub _finalize_transaction {
    my $self = shift;

435
436
437
    unless (defined $self->{_sdbTransactionLevel}) {
        return;
    }
438
439
440
441
442
443
    unless ($self->{_sdbTransactionLevel}) {
        die 'bug in logic. Ask developer';
    }
    unless (--$self->{_sdbTransactionLevel}) {
        $self->set_persistent($self->{_sdbPrevPersistency});
    }
444
445
446
447
}

sub commit {
    my $self = shift;
448

449
    my $dbh = $self->__dbh;
450
451
452
453
    return undef unless $dbh;

    $self->_finalize_transaction;
    return $dbh->commit;
454
455
456
457
}

sub rollback {
    my $self = shift;
458

459
    my $dbh = $self->__dbh;
460
461
462
463
    return undef unless $dbh;

    $self->_finalize_transaction;
    return $dbh->rollback;
464
465
}

466
467
468
sub disconnect {
    my $self = shift;

sikeda's avatar
sikeda committed
469
    my $id = $self->get_id;
470

sikeda's avatar
sikeda committed
471
472
    # Don't disconnect persistent connection.
    return 0 if $persistent_connection_of{$id};
sikeda's avatar
sikeda committed
473

sikeda's avatar
sikeda committed
474
475
476
    $connection_of{$id}->disconnect if $connection_of{$id};
    delete $connection_of{$id};
    return 1;
477
478
}

479
480
481
# NOT YET USED.
#sub create_db;

482
483
484
485
486
487
488
489
sub error {
    my $self = shift;

    my $dbh = $self->__dbh;
    return sprintf '(%s) %s', $dbh->state, ($dbh->errstr || '') if $dbh;
    return undef;
}

490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
# Old name: Sympa::DatabaseManager::_check_db_field_type().
sub is_sufficient_field_type {
    my $self      = shift;
    my $required  = shift;
    my $effective = shift;

    my ($required_type, $required_size, $effective_type, $effective_size);

    if ($required =~ /^(\w+)(\((\d+)\))?$/) {
        ($required_type, $required_size) = ($1, $3);
    }

    if ($effective =~ /^(\w+)(\((\d+)\))?$/) {
        ($effective_type, $effective_size) = ($1, $3);
    }

    if (    ($effective_type // '') eq ($required_type // '')
        and (not defined $required_size or $effective_size >= $required_size))
    {
        return 1;
    }

    return 0;
}

sikeda's avatar
sikeda committed
515
516
517
518
sub set_persistent {
    my $self = shift;
    my $flag = shift;

519
    my $ret = $persistent_connection_of{$self->get_id};
sikeda's avatar
sikeda committed
520
521
522
523
524
    if ($flag) {
        $persistent_connection_of{$self->get_id} = 1;
    } elsif (defined $flag) {
        delete $persistent_connection_of{$self->get_id};
    }
525
526
    # Returns the previous value of the flag (6.2.65b.1 or later)
    return $ret;
sikeda's avatar
sikeda committed
527
528
}

529
530
sub ping {
    my $self = shift;
531
532
533
534
535
536
537
538

    my $dbh = $self->__dbh;

    # Disconnected explicitly.
    return undef unless $dbh;
    # Some drivers don't have ping().
    return 1 unless $dbh->can('ping');
    return $dbh->ping;
539
540
541
}

sub quote {
542
543
544
    my $self = shift;
    my ($string, $datatype) = @_;

sikeda's avatar
sikeda committed
545
546
547
548
    # quote() does not need actual connection but driver handle.
    unless ($self->__dbh or $self->connect) {
        return undef;
    }
549
    return $self->__dbh->quote($string, $datatype);
550
551
}

sikeda's avatar
sikeda committed
552
553
# No longer used.
#sub set_fetch_timeout($timeout);
554

555
556
557
558
559
## Returns a character string corresponding to the expression to use in
## a read query (e.g. SELECT) for the field given as argument.
## This sub takes a single argument: the name of the field to be used in
## the query.
##
560
561
# Moved to Sympa::Upgrade::_get_canonical_write_date().
#sub get_canonical_write_date;
562

563
## Returns a character string corresponding to the expression to use in
564
565
566
567
## a write query (e.g. UPDATE or INSERT) for the value given as argument.
## This sub takes a single argument: the value of the date to be used in
## the query.
##
568
569
# Moved to Sympa::Upgrade::_get_canonical_read_date().
#sub get_canonical_read_date;
570

571
572
573
574
575
576
577
578
579
580
581
582
583
584
# We require that user also matches (except SQLite).
sub get_id {
    my $self = shift;

    return join ';', map {"$_=$self->{$_}"}
        grep {
               !ref($self->{$_})
            and defined $self->{$_}
            and !/\A_/
            and !/passw(or)?d/
        }
        sort keys %$self;
}

sikeda's avatar
sikeda committed
585
586
587
588
sub DESTROY {
    shift->disconnect;
}

589
1;
sikeda's avatar
sikeda committed
590
__END__
591
592
593
594
595
596
597
598
599

=encoding utf-8

=head1 NAME

Sympa::Database - Handling databases

=head1 SYNOPSIS

sikeda's avatar
sikeda committed
600
601
602
603
604
605
606
  use Sympa::Database;

  $database = Sympa::Database->new('SQLite', db_name => '...');
      or die 'Cannot connect to database';
  $sth = $database->do_prepared_query('SELECT FROM ...', ...)
      or die 'Cannot execute query';
  $database->disconnect;
607
608
609
610
611
612
613
614
615
616
617
618

=head1 DESCRIPTION

TBD.

=head2 Methods

=over

=item new ( $db_type, [ option => value, ... ] )

I<Constructor>.
sikeda's avatar
sikeda committed
619
Creates new database instance.
620

621
622
623
624
625
626
627
628
629
630
=item begin ( )

I<Instance method>, I<only for SQL>.
Begin transaction.

=item commit ( )

I<Instance method>, I<only for SQL>.
Commit transaction.

631
632
633
=item do_operation ( $operation, options... )

I<Instance method>, I<only for LDAP>.
sikeda's avatar
sikeda committed
634
635
636
637
638
639
Performs LDAP search operation.
About options see L<Net::LDAP/search>.

Returns:

Operation handle (L<LDAP::Search> object or such), or C<undef>.
640
641
642
643

=item do_prepared_query ( $statement, parameters... )

I<Instance method>, I<only for SQL>.
sikeda's avatar
sikeda committed
644
645
646
647
648
649
Prepares and executes SQL query.
$statement is an SQL statement that may contain placeholders C<?>.

Returns:

Statement handle (L<DBI::st> object or such), or C<undef>.
650
651
652
653

=item do_query ( $statement, parameters... )

I<Instance method>, I<only for SQL>.
sikeda's avatar
sikeda committed
654
655
Executes SQL query.
$statement and parameters will be fed to sprintf().
656

sikeda's avatar
sikeda committed
657
658
659
Returns:

Statement handle (L<DBI::st> object or such), or C<undef>.
660

661
662
663
664
665
=item rollback ( )

I<Instance method>, I<only for SQL>.
Rollback transaction.

666
667
668
669
=back

=head1 SEE ALSO

IKEDA Soji's avatar
IKEDA Soji committed
670
L<Sympa::DatabaseDriver>.
671

sikeda's avatar
sikeda committed
672
673
674
675
=head1 HISTORY

Sympa Database Manager (SDM) appeared on Sympa 6.2.

676
=cut