File: //usr/share/perl5/vendor_perl/Amavis/Out/SQL/Connection.pm
# SPDX-License-Identifier: GPL-2.0-or-later
package Amavis::Out::SQL::Connection;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';
BEGIN {
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
$VERSION = '2.412';
@ISA = qw(Exporter);
}
use DBI qw(:sql_types);
use Amavis::Conf qw(:platform c cr ca);
use Amavis::Timing qw(section_time);
use Amavis::Util qw(ll do_log do_log_safe);
# one object per connection (normally exactly one) to a database server;
# connection need not exist at all times, stores info on how to connect;
# when connected it holds a database handle
#
sub new {
my($class, @dsns) = @_; # a list of DSNs to try connecting to sequentially
bless { dbh=>undef, sth=>undef, incarnation=>1, in_transaction=>0,
dsn_list=>\@dsns, dsn_current=>undef }, $class;
}
sub dsn_current { # get/set information on currently connected data set name
my $self = shift; !@_ ? $self->{dsn_current} : ($self->{dsn_current}=shift);
}
sub dbh { # get/set database handle
my $self = shift; !@_ ? $self->{dbh} : ($self->{dbh}=shift);
}
sub sth { # get/set statement handle
my $self = shift; my $clause = shift;
!@_ ? $self->{sth}{$clause} : ($self->{sth}{$clause}=shift);
}
sub dbh_inactive { # get/set dbh "InactiveDestroy" attribute
my $self = shift;
my $dbh = $self->dbh;
return if !$dbh;
!@_ ? $dbh->{'InactiveDestroy'} : ($dbh->{'InactiveDestroy'}=shift);
}
sub DESTROY {
my $self = $_[0]; local($@,$!,$_);
do_log_safe(5,"Amavis::Out::SQL::Connection DESTROY called");
# ignore failures, make perlcritic happy
eval { $self->disconnect_from_sql } or 1;
}
# returns current connection version; works like cache versioning/invalidation:
# SQL statement handles need to be rebuilt and caches cleared when SQL
# connection is re-established and a new database handle provided
#
sub incarnation { my $self = $_[0]; $self->{incarnation} }
sub in_transaction {
my $self = shift;
!@_ ? $self->{in_transaction} : ($self->{in_transaction}=shift)
}
# returns DBD driver name such as 'Pg', 'mysql'; or undef if unknown
#
sub driver_name {
my $self = $_[0]; my $dbh = $self->dbh;
$dbh or die "sql driver_name: dbh not available";
!$dbh->{Driver} ? undef : $dbh->{Driver}->{Name};
}
# DBI method wrappers:
#
sub begin_work {
my $self = shift; do_log(5,"sql begin transaction");
# DBD::mysql man page: if you detect an error while changing
# the AutoCommit mode, you should no longer use the database handle.
# In other words, you should disconnect and reconnect again
$self->dbh or $self->connect_to_sql;
my $stat; my $eval_stat;
eval {
$stat = $self->dbh->begin_work(@_); 1;
} or do {
$eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
};
if (defined $eval_stat || !$stat) {
do_log(-1,"sql begin transaction failed, ".
"probably disconnected by server, reconnecting (%s)", $eval_stat);
$self->disconnect_from_sql;
die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout
$self->connect_to_sql;
$stat = $self->dbh->begin_work(@_);
}
$self->in_transaction(1);
$stat;
};
sub begin_work_nontransaction {
my $self = $_[0]; do_log(5,"sql begin, nontransaction");
$self->dbh or $self->connect_to_sql;
};
sub commit {
my $self = shift; do_log(5,"sql commit");
$self->in_transaction(0);
my $dbh = $self->dbh;
$dbh or die "commit: dbh not available";
$dbh->commit(@_); my($rv_err,$rv_str) = ($dbh->err, $dbh->errstr);
do_log(2,"sql commit status: err=%s, errstr=%s",
$rv_err,$rv_str) if defined $rv_err;
($rv_err,$rv_str); # potentially useful to see non-fatal errors
};
sub rollback {
my $self = shift; do_log(5,"sql rollback");
$self->in_transaction(0);
$self->dbh or die "rollback: dbh not available";
eval {
$self->dbh->rollback(@_); 1;
} or do {
my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
do_log(-1,"sql rollback error, reconnecting (%s)", $eval_stat);
$self->disconnect_from_sql;
die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout
$self->connect_to_sql;
# $self->dbh->rollback(@_); # too late now, hopefully implied in disconnect
};
};
sub fetchrow_arrayref {
my($self,$clause,@args) = @_;
$self->dbh or die "fetchrow_arrayref: dbh not available";
my $sth = $self->sth($clause);
$sth or die "fetchrow_arrayref: statement handle not available";
$sth->fetchrow_arrayref(@args);
};
sub finish {
my($self,$clause,@args) = @_;
$self->dbh or die "finish: dbh not available";
my $sth = $self->sth($clause);
$sth or die "finish: statement handle not available";
$sth->finish(@args);
};
sub execute {
my($self,$clause,@args) = @_;
$self->dbh or die "sql execute: dbh not available";
my $sth = $self->sth($clause); # fetch cached st. handle or prepare new
if ($sth) {
ll(5) && do_log(5, "sql: executing clause (%d args): %s",
scalar(@args), $clause);
} else {
ll(4) && do_log(4,"sql: preparing and executing (%d args): %s",
scalar(@args), $clause);
$sth = $self->dbh->prepare($clause); $self->sth($clause,$sth);
$sth or die "sql: prepare failed: ".$DBI::errstr;
}
my($rv_err,$rv_str);
eval {
for my $j (0..$#args) { # arg can be a scalar or [val,type] or [val,\%attr]
my $arg = $args[$j];
$sth->bind_param($j+1, !ref($arg) ? $arg : @$arg);
# ll(5) && do_log(5, "sql: bind %d: %s",
# $j+1, !ref($arg) ? $arg : '['.join(',',@$arg).']' );
}
$sth->execute; $rv_err = $sth->err; $rv_str = $sth->errstr; 1;
} or do {
my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
# man DBI: ->err code is typically an integer but you should not assume so
# $DBI::errstr is normally already contained in $eval_stat
my $sqlerr = $sth ? $sth->err : $DBI::err;
my $sqlstate = $sth ? $sth->state : $DBI::state;
my $msg = sprintf("err=%s, %s, %s", $sqlerr, $sqlstate, $eval_stat);
if (!$sth) {
die "sql execute (no handle): ".$msg;
} elsif (! ($sqlerr eq '2006' || $sqlerr eq '2013' || # MySQL
($sqlerr == -1 && $sqlstate eq 'S1000') || # PostgreSQL 7
($sqlerr == 7 && $sqlstate =~ /^(S8|08|57)...\z/i) )) { #PgSQL
# libpq-fe.h: ExecStatusType PGRES_FATAL_ERROR=7
# ignore failures, make perlcritic happy
eval { $self->disconnect_from_sql } or 1; # better safe than sorry
die "sql exec: $msg\n";
} else { # Server has gone away; Lost connection to...
# MySQL: 2006, 2013; PostgreSQL: 7
if ($self->in_transaction) {
# ignore failures, make perlcritic happy
eval { $self->disconnect_from_sql } or 1;
die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout
die "sql execute failed within transaction, $msg";
} else { # try one more time
do_log(0,"NOTICE: reconnecting in response to: %s", $msg);
# ignore failures, make perlcritic happy
eval { $self->disconnect_from_sql } or 1;
die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout
$self->connect_to_sql;
$self->dbh or die "sql execute: reconnect failed";
do_log(4,"sql: preparing and executing (again): %s", $clause);
$sth = $self->dbh->prepare($clause); $self->sth($clause,$sth);
$sth or die "sql: prepare (reconnected) failed: ".$DBI::errstr;
$rv_err = $rv_str = undef;
eval {
for my $j (0..$#args) { # a scalar or [val,type] or [val,\%attr]
$sth->bind_param($j+1, !ref($args[$j]) ? $args[$j] : @{$args[$j]});
}
$sth->execute; $rv_err = $sth->err; $rv_str = $sth->errstr; 1;
} or do {
$eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
$msg = sprintf("err=%s, %s, %s", $DBI::err,$DBI::state,$eval_stat);
$self->disconnect_from_sql;
die $eval_stat if $eval_stat =~ /^timed out\b/; # resignal timeout
die "sql execute failed again, $msg";
};
}
}
};
# $rv_err: undef indicates success, "" indicates an 'information',
# "0" indicates a 'warning', true indicates an error
do_log(2,"sql execute status: err=%s, errstr=%s",
$rv_err,$rv_str) if defined $rv_err;
($rv_err,$rv_str); # potentially useful to see non-fatal errors
}
# Connect to a database. Take a list of database connection
# parameters and try each until one succeeds.
# -- based on code from Ben Ransford <amavis@uce.ransford.org> 2002-09-22
#
sub connect_to_sql {
my $self = shift; # a list of DSNs to try connecting to sequentially
my $dbh; my(@dsns) = @{$self->{dsn_list}};
do_log(3,"Connecting to SQL database server");
for my $tmpdsn (@dsns) {
my($dsn, $username, $password) = @$tmpdsn;
do_log(4,"connect_to_sql: trying '%s'", $dsn);
$dbh = DBI->connect($dsn, $username, $password,
{PrintError => 0, RaiseError => 0, Taint => 1, AutoCommit => 1} );
if ($dbh) {
$self->dsn_current($dsn);
do_log(3,"connect_to_sql: '%s' succeeded", $dsn);
last;
}
do_log(-1,"connect_to_sql: unable to connect to DSN '%s': %s",
$dsn, $DBI::errstr);
}
$self->dbh($dbh); delete($self->{sth});
$self->in_transaction(0); $self->{incarnation}++;
$dbh or die "connect_to_sql: unable to connect to any dataset";
$dbh->{'RaiseError'} = 1;
# $dbh->{mysql_auto_reconnect} = 1; # questionable benefit
# $dbh->func(30000,'busy_timeout'); # milliseconds (SQLite)
# https://mathiasbynens.be/notes/mysql-utf8mb4
# Never use utf8 in MySQL — always use utf8mb4 instead.
# SET NAMES utf8mb4 COLLATE utf8mb4_unicode_ci
my $cmd = $self->driver_name eq 'mysql' ? "SET NAMES 'utf8mb4'"
: "SET NAMES 'utf8'";
eval {
$dbh->do($cmd); 1;
} or do {
my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
do_log(2,"connect_to_sql: %s failed: %s", $cmd, $eval_stat);
};
section_time('sql-connect');
$self;
}
sub disconnect_from_sql($) {
my $self = $_[0];
my $did_disconnect;
$self->in_transaction(0);
if ($self->dbh) {
do_log(4,"disconnecting from SQL");
$self->dbh->disconnect; $self->dbh(undef);
$did_disconnect = 1;
}
delete $self->{sth}; $self->dsn_current(undef);
$did_disconnect;
}
1;