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, 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::DatabaseDriver::MySQL;
29
30use strict;
31use warnings;
32
33use Sympa::Log;
34
35use base qw(Sympa::DatabaseDriver);
36
37my $log = Sympa::Log->instance;
38
39use constant required_modules => [qw(DBD::mysql)];
40
41sub build_connect_string {
42    my $self = shift;
43
44    my $connect_string =
45          'DBI:mysql:'
46        . $self->{'db_name'} . ':'
47        . ($self->{'db_host'} || 'localhost');
48    $connect_string .= ';port=' . $self->{'db_port'}
49        if defined $self->{'db_port'};
50    $connect_string .= ';' . $self->{'db_options'}
51        if defined $self->{'db_options'};
52    return $connect_string;
53}
54
55sub connect {
56    my $self = shift;
57
58    $self->SUPER::connect() or return undef;
59
60    # - At first, reset "mysql_auto_reconnect" driver attribute.
61    #   DBI::connect() sets it to true not according to \%attr argument
62    #   when the processes are running under mod_perl or CGI environment
63    #   so that "SET NAMES utf8" will be skipped.
64    # - Set client-side character set to "utf8" or "utf8mb4".
65    # - Reset SQL mode that is given various default by versions of MySQL.
66    $self->__dbh->{'mysql_auto_reconnect'} = 0;
67    unless (defined $self->__dbh->do("SET NAMES 'utf8mb4'")
68        or defined $self->__dbh->do("SET NAMES 'utf8'")) {
69        $log->syslog('err', 'Cannot set client-side character set: %s',
70            $self->error);
71    }
72    unless (defined $self->__dbh->do("SET SESSION sql_mode=''")) {
73        $log->syslog('err', 'Cannot reset SQL mode: %s', $self->error);
74        return undef;
75    }
76
77    return 1;
78}
79
80sub get_substring_clause {
81    my $self  = shift;
82    my $param = shift;
83    $log->syslog('debug', 'Building substring caluse');
84    return
85          "REVERSE(SUBSTRING("
86        . $param->{'source_field'}
87        . " FROM position('"
88        . $param->{'separator'} . "' IN "
89        . $param->{'source_field'}
90        . ") FOR "
91        . $param->{'substring_length'} . "))";
92}
93
94# DEPRECATED.
95#sub get_limit_clause ( { rows_count => $rows, offset => $offset } );
96
97# DEPRECATED.
98#sub get_formatted_date;
99
100sub is_autoinc {
101    my $self  = shift;
102    my $param = shift;
103    $log->syslog('debug', 'Checking whether field %s.%s is autoincremental',
104        $param->{'field'}, $param->{'table'});
105    my $sth;
106    unless (
107        $sth = $self->do_query(
108            "SHOW FIELDS FROM `%s` WHERE Extra ='auto_increment' and Field = '%s'",
109            $param->{'table'},
110            $param->{'field'}
111        )
112    ) {
113        $log->syslog('err',
114            'Unable to gather autoincrement field named %s for table %s',
115            $param->{'field'}, $param->{'table'});
116        return undef;
117    }
118    my $ref = $sth->fetchrow_hashref('NAME_lc');
119    return ($ref->{'field'} eq $param->{'field'});
120}
121
122sub set_autoinc {
123    my $self  = shift;
124    my $param = shift;
125    my $field_type =
126        defined($param->{'field_type'})
127        ? $param->{'field_type'}
128        : 'BIGINT( 20 )';
129    $log->syslog('debug', 'Setting field %s.%s as autoincremental',
130        $param->{'field'}, $param->{'table'});
131    unless (
132        $self->do_query(
133            "ALTER TABLE `%s` CHANGE `%s` `%s` %s NOT NULL AUTO_INCREMENT",
134            $param->{'table'}, $param->{'field'},
135            $param->{'field'}, $field_type
136        )
137    ) {
138        $log->syslog('err',
139            'Unable to set field %s in table %s as autoincrement',
140            $param->{'field'}, $param->{'table'});
141        return undef;
142    }
143    return 1;
144}
145
146sub get_tables {
147    my $self = shift;
148    $log->syslog('debug', 'Retrieving all tables in database %s',
149        $self->{'db_name'});
150    my @raw_tables;
151    my @result;
152    unless (@raw_tables = $self->__dbh->tables()) {
153        $log->syslog('err',
154            'Unable to retrieve the list of tables from database %s',
155            $self->{'db_name'});
156        return undef;
157    }
158
159    foreach my $t (@raw_tables) {
160        # Clean table names that would look like `databaseName`.`tableName`
161        # (mysql)
162        $t =~ s/^\`[^\`]+\`\.//;
163        # Clean table names that could be surrounded by `` (recent DBD::mysql
164        # release)
165        $t =~ s/^\`(.+)\`$/$1/;
166        push @result, $t;
167    }
168    return \@result;
169}
170
171sub add_table {
172    my $self  = shift;
173    my $param = shift;
174    $log->syslog('debug', 'Adding table %s to database %s',
175        $param->{'table'}, $self->{'db_name'});
176    unless (
177        $self->do_query(
178            "CREATE TABLE %s (temporary INT) DEFAULT CHARACTER SET utf8",
179            $param->{'table'}
180        )
181    ) {
182        $log->syslog('err', 'Could not create table %s in database %s',
183            $param->{'table'}, $self->{'db_name'});
184        return undef;
185    }
186    return sprintf "Table %s created in database %s", $param->{'table'},
187        $self->{'db_name'};
188}
189
190sub get_fields {
191    my $self  = shift;
192    my $param = shift;
193    $log->syslog('debug', 'Getting fields list from table %s in database %s',
194        $param->{'table'}, $self->{'db_name'});
195    my $sth;
196    my %result;
197    unless ($sth = $self->do_query("SHOW FIELDS FROM %s", $param->{'table'}))
198    {
199        $log->syslog('err',
200            'Could not get the list of fields from table %s in database %s',
201            $param->{'table'}, $self->{'db_name'});
202        return undef;
203    }
204    while (my $ref = $sth->fetchrow_hashref('NAME_lc')) {
205        $result{$ref->{'field'}} = $ref->{'type'};
206    }
207    return \%result;
208}
209
210sub update_field {
211    my $self  = shift;
212    my $param = shift;
213    $log->syslog('debug', 'Updating field %s in table %s (%s, %s)',
214        $param->{'field'}, $param->{'table'}, $param->{'type'},
215        $param->{'notnull'});
216    my $options = '';
217    if ($param->{'notnull'}) {
218        $options .= ' NOT NULL ';
219    }
220    my $report = sprintf(
221        "ALTER TABLE %s CHANGE %s %s %s %s",
222        $param->{'table'}, $param->{'field'}, $param->{'field'},
223        $param->{'type'},  $options
224    );
225    $log->syslog('notice', "ALTER TABLE %s CHANGE %s %s %s %s",
226        $param->{'table'}, $param->{'field'}, $param->{'field'},
227        $param->{'type'}, $options);
228    unless (
229        $self->do_query(
230            "ALTER TABLE %s CHANGE %s %s %s %s",
231            $param->{'table'}, $param->{'field'}, $param->{'field'},
232            $param->{'type'},  $options
233        )
234    ) {
235        $log->syslog('err', 'Could not change field "%s" in table "%s"',
236            $param->{'field'}, $param->{'table'});
237        return undef;
238    }
239    $report .= sprintf("\nField %s in table %s, structure updated",
240        $param->{'field'}, $param->{'table'});
241    $log->syslog('info', 'Field %s in table %s, structure updated',
242        $param->{'field'}, $param->{'table'});
243    return $report;
244}
245
246sub add_field {
247    my $self  = shift;
248    my $param = shift;
249    $log->syslog(
250        'debug',             'Adding field %s in table %s (%s, %s, %s, %s)',
251        $param->{'field'},   $param->{'table'},
252        $param->{'type'},    $param->{'notnull'},
253        $param->{'autoinc'}, $param->{'primary'}
254    );
255    my $options = '';
256    # To prevent "Cannot add a NOT NULL column with default value NULL" errors
257    if ($param->{'notnull'}) {
258        $options .= 'NOT NULL ';
259    }
260    if ($param->{'autoinc'}) {
261        $options .= ' AUTO_INCREMENT ';
262    }
263    if ($param->{'primary'}) {
264        $options .= ' PRIMARY KEY ';
265    }
266    unless (
267        $self->do_query(
268            "ALTER TABLE %s ADD %s %s %s", $param->{'table'},
269            $param->{'field'},             $param->{'type'},
270            $options
271        )
272    ) {
273        $log->syslog('err',
274            'Could not add field %s to table %s in database %s',
275            $param->{'field'}, $param->{'table'}, $self->{'db_name'});
276        return undef;
277    }
278
279    my $report = sprintf('Field %s added to table %s (options : %s)',
280        $param->{'field'}, $param->{'table'}, $options);
281    $log->syslog('info', 'Field %s added to table %s (options: %s)',
282        $param->{'field'}, $param->{'table'}, $options);
283
284    return $report;
285}
286
287sub delete_field {
288    my $self  = shift;
289    my $param = shift;
290    $log->syslog('debug', 'Deleting field %s from table %s',
291        $param->{'field'}, $param->{'table'});
292
293    unless (
294        $self->do_query(
295            "ALTER TABLE %s DROP COLUMN `%s`", $param->{'table'},
296            $param->{'field'}
297        )
298    ) {
299        $log->syslog('err',
300            'Could not delete field %s from table %s in database %s',
301            $param->{'field'}, $param->{'table'}, $self->{'db_name'});
302        return undef;
303    }
304
305    my $report = sprintf('Field %s removed from table %s',
306        $param->{'field'}, $param->{'table'});
307    $log->syslog('info', 'Field %s removed from table %s',
308        $param->{'field'}, $param->{'table'});
309
310    return $report;
311}
312
313sub get_primary_key {
314    my $self  = shift;
315    my $param = shift;
316    $log->syslog('debug', 'Getting primary key for table %s',
317        $param->{'table'});
318
319    my %found_keys;
320    my $sth;
321    unless ($sth = $self->do_query("SHOW COLUMNS FROM %s", $param->{'table'}))
322    {
323        $log->syslog('err',
324            'Could not get field list from table %s in database %s',
325            $param->{'table'}, $self->{'db_name'});
326        return undef;
327    }
328
329    my $test_request_result = $sth->fetchall_hashref('field');
330    foreach my $scannedResult (keys %$test_request_result) {
331        if ($test_request_result->{$scannedResult}{'key'} eq "PRI") {
332            $found_keys{$scannedResult} = 1;
333        }
334    }
335    return \%found_keys;
336}
337
338sub unset_primary_key {
339    my $self  = shift;
340    my $param = shift;
341    $log->syslog('debug', 'Removing primary key from table %s',
342        $param->{'table'});
343
344    my $sth;
345    unless ($sth =
346        $self->do_query("ALTER TABLE %s DROP PRIMARY KEY", $param->{'table'}))
347    {
348        $log->syslog('err',
349            'Could not drop primary key from table %s in database %s',
350            $param->{'table'}, $self->{'db_name'});
351        return undef;
352    }
353    my $report = "Table $param->{'table'}, PRIMARY KEY dropped";
354    $log->syslog('info', 'Table %s, PRIMARY KEY dropped', $param->{'table'});
355
356    return $report;
357}
358
359sub set_primary_key {
360    my $self  = shift;
361    my $param = shift;
362
363    my $sth;
364    my $fields = join ',', @{$param->{'fields'}};
365    $log->syslog('debug', 'Setting primary key for table %s (%s)',
366        $param->{'table'}, $fields);
367    unless (
368        $sth = $self->do_query(
369            "ALTER TABLE %s ADD PRIMARY KEY (%s)", $param->{'table'},
370            $fields
371        )
372    ) {
373        $log->syslog(
374            'err',
375            'Could not set fields %s as primary key for table %s in database %s',
376            $fields,
377            $param->{'table'},
378            $self->{'db_name'}
379        );
380        return undef;
381    }
382    my $report = "Table $param->{'table'}, PRIMARY KEY set on $fields";
383    $log->syslog('info', 'Table %s, PRIMARY KEY set on %s',
384        $param->{'table'}, $fields);
385    return $report;
386}
387
388sub get_indexes {
389    my $self  = shift;
390    my $param = shift;
391    $log->syslog('debug', 'Looking for indexes in %s', $param->{'table'});
392
393    my %found_indexes;
394    my $sth;
395    unless ($sth = $self->do_query("SHOW INDEX FROM %s", $param->{'table'})) {
396        $log->syslog(
397            'err',
398            'Could not get the list of indexes from table %s in database %s',
399            $param->{'table'},
400            $self->{'db_name'}
401        );
402        return undef;
403    }
404    my $index_part;
405    while ($index_part = $sth->fetchrow_hashref('NAME_lc')) {
406        if ($index_part->{'key_name'} ne "PRIMARY") {
407            my $index_name = $index_part->{'key_name'};
408            my $field_name = $index_part->{'column_name'};
409            $found_indexes{$index_name}{$field_name} = 1;
410        }
411    }
412    return \%found_indexes;
413}
414
415sub unset_index {
416    my $self  = shift;
417    my $param = shift;
418    $log->syslog('debug', 'Removing index %s from table %s',
419        $param->{'index'}, $param->{'table'});
420
421    my $sth;
422    unless (
423        $sth = $self->do_query(
424            "ALTER TABLE %s DROP INDEX %s", $param->{'table'},
425            $param->{'index'}
426        )
427    ) {
428        $log->syslog('err',
429            'Could not drop index %s from table %s in database %s',
430            $param->{'index'}, $param->{'table'}, $self->{'db_name'});
431        return undef;
432    }
433    my $report = "Table $param->{'table'}, index $param->{'index'} dropped";
434    $log->syslog('info', 'Table %s, index %s dropped',
435        $param->{'table'}, $param->{'index'});
436
437    return $report;
438}
439
440sub set_index {
441    my $self  = shift;
442    my $param = shift;
443
444    my $sth;
445    my $fields = join ',', @{$param->{'fields'}};
446    $log->syslog(
447        'debug',
448        'Setting index %s for table %s using fields %s',
449        $param->{'index_name'},
450        $param->{'table'}, $fields
451    );
452    unless (
453        $sth = $self->do_query(
454            "ALTER TABLE %s ADD INDEX %s (%s)", $param->{'table'},
455            $param->{'index_name'},             $fields
456        )
457    ) {
458        $log->syslog(
459            'err',
460            'Could not add index %s using field %s for table %s in database %s',
461            $fields,
462            $param->{'table'},
463            $self->{'db_name'}
464        );
465        return undef;
466    }
467    my $report = sprintf 'Table %s, index %s set using fields %s',
468        $param->{'table'}, $param->{'index_name'}, $fields;
469    $log->syslog('info', 'Table %s, index %s set using fields %s',
470        $param->{'table'}, $param->{'index_name'}, $fields);
471    return $report;
472}
473
474## For DOUBLE type.
475sub AS_DOUBLE {
476    return ({'mysql_type' => DBD::mysql::FIELD_TYPE_DOUBLE()} => $_[1])
477        if scalar @_ > 1;
478    return ();
479}
480
4811;
482__END__
483
484=encoding utf-8
485
486=head1 NAME
487
488Sympa::DatabaseDriver::MySQL - Database driver for MySQL / MariaDB
489
490=head1 SEE ALSO
491
492L<Sympa::DatabaseDriver>.
493
494=cut
495