view release on metacpan or  search on metacpan

lib/CTK/DBI.pm  view on Meta::CPAN

=head1 HISTORY

See C<Changes> file

=head1 VARIABLES

=over 4

=item B<$CTK::DBI::CTK_DBI_DEBUG>

Debug mode flag. Default: 0

=item B<$CTK::DBI::CTK_DBI_ERROR>

General error string

=back

=head1 DEPENDENCIES

L<DBI>

=head1 TO DO

See C<TODO> file

=head1 BUGS

* none noted

=head1 SEE ALSO

L<DBI>

=head1 AUTHOR

Serż Minus (Sergey Lepenkov) L<https://www.serzik.com> E<lt>abalama@cpan.orgE<gt>

=head1 COPYRIGHT

Copyright (C) 1998-2022 D&D Corporation. All Rights Reserved

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See C<LICENSE> file and L<https://dev.perl.org/licenses/>

=cut

use vars qw/$VERSION/;
$VERSION = '2.31';

our $CTK_DBI_DEBUG = 0;
our $CTK_DBI_ERROR = "";

use Carp;
use CTK::Util qw( :API );
use CTK::Timeout;
use DBI qw();

# Create global Timeout object
my $to = CTK::Timeout->new();

sub new {
    my $class = shift;
    my @in = read_attributes([
          ['DSN','STRING','STR'],
          ['USER','USERNAME','LOGIN'],
          ['PASSWORD','PASS'],
          ['TIMEOUT_CONNECT','CONNECT_TIMEOUT','CNT_TIMEOUT','TIMEOUT_CNT','TO_CONNECT','CONNECT_TO'],
          ['TIMEOUT_REQUEST','REQUEST_TIMEOUT','REQ_TIMEOUT','TIMEOUT_REQ','TO_REQUEST','REQUEST_TO'],
          ['ATTRIBUTES','ATTR','ATTRS','ATTRHASH','PARAMS'],
          ['PREPARE_ATTRIBUTES','PREPARE_ATTR','PREPARE_ATTRS'],
          ['DEBUG'],
        ], @_);
    if ($in[7]) {
        $CTK_DBI_DEBUG = 1;
    }

    # General arguments
    my %args = (
            dsn         => $in[0] || '',
            user        => $in[1] // '',
            password    => $in[2] // '',
            connect_to  => $in[3] // 0,
            request_to  => $in[4] // 0,
            attr        => $in[5] || undef,
            prepare_attr=> $in[6] || undef,
            debug       => $in[7] // 0,
            dbh         => undef,
            error       => "", # Ok
        );

    # Connect
    my $_err = "";
    $args{dbh} = DBI_CONNECT($args{dsn}, $args{user}, $args{password}, $args{attr}, $args{connect_to}, \$_err);

    # Create CTK::DBI object
    my $self = bless {%args}, $class;
    if ($args{dbh}) { # Ok
        _debug(sprintf("--- CTK::DBI CONNECT {%s} ---", $args{dsn}));
    } else {
        $self->_set_error($_err);
    }

    return $self;
}

sub _set_error {
    my $self = shift;
    my $merr = shift;
    my $dbh = $self->{dbh};

    # Set error string
    $self->{error} = "";
    if (defined($merr)) {
        $self->{error} = $merr;
    } else {
        if ($dbh && $dbh->can('errstr')) {
            $self->{error} = $dbh->errstr // '';
        }
        unless (length($self->{error})) {

lib/CTK/DBI.pm  view on Meta::CPAN

    my $sth = $self->execute(@_);
    return () unless $sth;
    my $rslt = $sth->fetchall_hashref($key_field);
       $rslt = {} unless $rslt && ref($rslt) eq 'HASH';
    my %result = %$rslt;
    $sth->finish;
    return %result;
}
sub execute {
    my $self = shift;
    my $sql = shift // '';
    my @inargs = @_;
    my $dbh = $self->{dbh} || return;
    $self->_set_error(""); # Flush errors first
    return $self->_set_error("No statement specified") unless length($sql);

    # Prepare
    my $prepare_attr = $self->{prepare_attr};
    my %attr = ($prepare_attr && ref($prepare_attr) eq 'HASH') ? %$prepare_attr : ();
    my $sth_ex = keys(%attr)
        ? $dbh->prepare($sql, {%attr})
        : $dbh->prepare($sql);
    unless ($sth_ex) {
        return $self->_set_error(sprintf("Can't prepare statement \"%s\": %s", $sql, $dbh->errstr // 'unknown error'));
    }

    # Execute
    my $err = "";
    my $retval = $to->timeout_call(sub {
            unless ($sth_ex->execute(@inargs)) {
                $err = $dbh->errstr || "the DBI::execute method has returned false status";
            }
            1;
        }, $self->{request_to});
    unless ($retval) {
        $err = $to->error || "unknown error";
    }

    # Errors
    if ($err) {
        my @repsrgs = @inargs;
        my $argb = "";
        $argb = sprintf(" with bind variables: %s", join(", ", map {defined($_) ? sprintf("\"%s\"", $_) : 'undef'} @repsrgs))
            if exists($inargs[0]);
        return $self->_set_error(sprintf("Can't execute statement \"%s\"%s: %s", $sql, $argb, $err));
    }

    return $sth_ex;
}

sub DESTROY {
    my $self = shift;
    $self->disconnect();
}
sub DBI_CONNECT {
    # $dbh = DBI_CONNECT($dsn, $user, $password, $attr, $timeout, \$error)
    my $db_dsn      = shift || ''; # DSN
    my $db_user     = shift // ''; # DB Username
    my $db_password = shift // ''; # DB Password
    my $db_attr     = shift || {}; # Attributes DBD::* (hash-ref) E.g., {ORACLE_enable_utf8 => 1}
    my $db_tocnt    = shift // 0;  # Timeout value
    my $rerr        = shift;       # Reference to error scalar
       $rerr = \$CTK_DBI_ERROR unless $rerr && ref($rerr) eq 'SCALAR';
    my $dbh;

    # Connect
    my $err = "";
    my $retval = $to->timeout_call(sub {
            $dbh = DBI->connect($db_dsn, "$db_user", "$db_password", $db_attr);
            unless ($dbh) {
                $err = $DBI::errstr || "the DBI::connect method has returned false status";
            }
            1;
        }, $db_tocnt);
    unless ($retval) {
        $err = $to->error || "unknown error";
    }

    # Errors
    if ($err) {
        $$rerr = sprintf("Can't connect to \"%s\", %s", $db_dsn, $err);
    }

    # DBI handler or undef
    return $dbh;
}

sub _debug { $CTK_DBI_DEBUG ? carp(@_) : 1 }

1;

__END__