view release on metacpan or  search on metacpan

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

Database connect url

The database connection URL from which all other attributes can be derived.
C<"url"> must be specified before the first call to C<"connect"> is made,
otherwise it will have no effect on setting the defaults.

For using SQLite databases with files relative to current directory you cat use '/./' prefix:

    # '/./' will be removed automatically
    $dbi = $dbi->url('sqlite:///./test.db?sqlite_unicode=1');

Default: C<"sponge://">

=head2 username

    my $username = $dbi->username;

This is the L<Mojo::URL/username> that will be used for generating the connection DSN

default: none

=head2 userinfo

    my $userinfo = $dbi->userinfo;

This is the L<Mojo::URL/userinfo> that will be used for generating the connection DSN

default: none

=head1 HISTORY

See C<Changes> file

=head1 TO DO

See C<TODO> file

=head1 SEE ALSO

L<Mojo::mysql>, L<Mojo::Pg>, L<Mojo::DB::Connector>, L<CTK::DBI>, L<DBI>

=head1 AUTHOR

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

=head1 COPYRIGHT

Copyright (C) 1998-2026 D&D Corporation

=head1 LICENSE

This program is distributed under the terms of the Artistic License Version 2.0

See the C<LICENSE> file or L<https://opensource.org/license/artistic-2-0> for details

=cut

our $VERSION = '0.04';

use Carp qw/carp croak/;
use Scalar::Util 'weaken';
use DBI qw//;
use Mojo::Util qw/monkey_patch md5_sum/;
use Mojo::URL qw//;
use Mojo::Cache;
use Acrux::Util qw//;
use Acrux::RefUtil qw/is_array_ref is_code_ref/;
use Acrux::DBI::Res;
use Acrux::DBI::Tx;
use Acrux::DBI::Dump;

use constant {
    DEBUG            => $ENV{ACRUX_DBI_DEBUG} || 0,
    DEFAULT_DBI_URL  => 'sponge://',
    DEFAULT_DBI_DSN  => 'DBI:Sponge:',
    DEFAULT_DBI_OPTS => {
            RaiseError  => 0,
            PrintError  => 0,
            PrintWarn   => 0,
        },
};

# Set method ping to DBD::Sponge
monkey_patch 'DBD::Sponge::db', ping => sub { 1 };

sub new {
    my $class = shift;
    my $url = shift || DEFAULT_DBI_URL;
       croak 'Invalid DBI URL' unless $url;
    my $opts = scalar(@_) ? scalar(@_) > 1 ? {@_} : {%{$_[0]}} : {};
    my $uri = Mojo::URL->new($url);

    # Default attributes
    my %_opts = (%{(DEFAULT_DBI_OPTS)}, %$opts);
    my $autoclean = delete $_opts{autoclean};

    my $self  = bless {
            url     => $url,
            uri     => $uri,
            dsn     => '',
            cachekey=> '',
            driver  => '',
            dbh     => undef,
            error   => "", # Ok
            autoclean => $autoclean ? 1 : 0,
            opts    => {%_opts},
            cache   => Mojo::Cache->new,
        }, $class;
    return $self;
}

# Attributes
sub url {
    my $self = shift;
    if (scalar(@_) >= 1) {
        $self->{url} = shift;
        $self->{uri}->parse($self->{url});
        $self->{dsn} = '';
        $self->{cachekey} = '';
        $self->{driver} = '';
        return $self;

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

    return $self->{error};
}
sub err {
    my $self = shift;
    return $self->dbh->err // $DBI::err if defined($self->dbh) && $self->dbh->can('err');
    return $DBI::err;
}
sub errstr {
    my $self = shift;
    return $self->dbh->errstr // $DBI::errstr if defined($self->dbh) && $self->dbh->can('errstr');
    return $DBI::errstr;
}

# Database methods
sub connect {
    my $self = shift;
    $self->{error} = '';
    my $dbh = DBI->connect($self->dsn, $self->username, $self->password, $self->options);
    if ($dbh) {
        $self->{dbh} = $dbh;
        printf STDERR "Connected to '%s'\n", $self->dsn if DEBUG;
    } else {
        $self->{error} = $DBI::errstr || "DBI->connect failed";
        $self->{dbh} = undef;
    }
    return $self;
}
sub connect_cached {
    my $self = shift;
    $self->{error} = '';
    my %opts = %{($self->options)};
       $opts{private_cachekey} = $self->cachekey;
    my $dbh = DBI->connect_cached($self->dsn, $self->username, $self->password, {%opts});
    if ($dbh) {
        $self->{dbh} = $dbh;
        printf STDERR "Connected (cached) to '%s'\n", $self->dsn if DEBUG;
    } else {
        $self->{error} = $DBI::errstr || "DBI->connect failed";
        $self->{dbh} = undef;
    }
    return $self;
}
sub disconnect {
    my $self = shift;
    return unless my $dbh = $self->dbh;
    $dbh->disconnect;
    printf STDERR "Disconnected from '%s'\n", $self->dsn if DEBUG;
    $self->cleanup;
}
sub ping {
    my $self = shift;
    return 0 unless $self->{dsn};
    return 0 unless my $dbh = $self->dbh;
    return 0 unless $dbh->can('ping');
    return $dbh->ping();
}

# Transaction methods
sub transaction {
    my $tx = Acrux::DBI::Tx->new(dbi => shift);
    weaken $tx->{dbi};
    return $tx;
}
sub begin {
    my $self = shift;
    return unless my $dbh = $self->dbh;
    $dbh->begin_work;
    return $self;
}
sub commit {
    my $self = shift;
    return unless my $dbh = $self->dbh;
    $dbh->commit;
    return $self;
}
sub rollback {
    my $self = shift;
    return unless my $dbh = $self->dbh;
    $dbh->rollback;
    return $self;
}

# Request methods
sub query { # SQL, { args }
    my $self = shift;
    my $sql = shift // '';
    my $args = @_
      ? @_ > 1
        ? {bind_values => [@_]}
        : ref($_[0]) eq 'HASH'
          ? {%{$_[0]}}
          : {bind_values => [@_]}
      : {};
    $self->{error} = '';
    return unless my $dbh = $self->dbh;
    unless (length($sql)) {
        $self->error("No statement specified");
        return;
    }

    # Prepare
    my $sth = $dbh->prepare($sql);
    unless ($sth) {
        $self->error(sprintf("Can't prepare statement \"%s\": %s", $sql,
            $dbh->errstr || $DBI::errstr || 'unknown error'));
        return;
    }

    # HandleError
    local $sth->{HandleError} = sub { $_[0] = Carp::shortmess($_[0]); 0 };

    # Binding params and execute
    my $bind_values = $args->{bind_values} || [];
    unless (is_array_ref($bind_values)) {
        $self->error("Invalid list of binding values. Array ref expected");
        return;
    }
    my $rv;
    my $argb = '';
    if (scalar @$bind_values) {
        $argb = sprintf(" with bind values: %s",