Acrux-DBI

 view release on metacpan or  search on metacpan

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

package Acrux::DBI;
use strict;
use utf8;

=encoding utf8

=head1 NAME

Acrux::DBI - Database independent interface for Acrux applications

=head1 SYNOPSIS

    use Acrux::DBI;

=head1 DESCRIPTION

Database independent interface for Acrux applications

=head2 new

    my $dbi = Acrux::DBI->new( $db_url );
    my $dbi = Acrux::DBI->new( $db_url, { ... options ... });
    my $dbi = Acrux::DBI->new( $db_url, ... options ...);

Build new Acrux::DBI object

B<Options:>

=over 8

=item autoclean

This options turns on auto disconnecting on DESTROY phase

=back

See also list of default options in L</options>

=head1 METHODS

This class implements the following methods

=head2 begin

    $dbi->begin;
    # ...
    $dbi->commit; # ..or $dbi->rollback

This is a transaction method!

This method marks the starting point for the start of a transaction

    $dbi->begin;
    $dbi->query('insert into test values (?)', 'Foo');
    $dbi->query('insert into test values (?)', 'Bar');
    $dbi->commit;

See slso L</transaction>, L</commit>, L</rollback>

=head2 cache

    my $cache = $dbi->cache;

Returns the L<Mojo::Cache> object

=head2 cachekey

    my $cachekey = $dbi->cachekey;

Returns the key name of the cached connect (See L</connect_cached>)

=head2 cleanup

    $dbi = $dbi->cleanup;

This internal method to cleanup database handler

=head2 commit

    $dbi->begin;
    # ...
    $dbi->commit;

This is a transaction method!

This method accepts all changes to the database and marks the end
point for the transaction to complete

See also L</begin>, L</rollback>

=head2 connect

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

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;
    }
    return $self->{url};
}
sub driver { # scheme
    my $self = shift;
    $self->{driver} ||= $self->{uri}->protocol;
}
sub host {
    my $self = shift;
    return $self->{uri}->host || 'localhost';
}
sub port {
    my $self = shift;
    return $self->{uri}->port // '';
}
sub options {
    my $self = shift;
    my $opts = $self->{opts}; # defaults
    my $query = $self->{uri}->query;
    my %params = ();
       $params{$_} = $query->param($_) for @{$query->names};
    return { (%$opts, %params) } ; # merge defaults and URL params
}
sub username {
    my $self = shift;
    return $self->{uri}->username // '';
}
sub password {
    my $self = shift;
    return $self->{uri}->password // '';
}
sub userinfo {
    my $self = shift;
    return $self->{uri}->userinfo // '';
}
sub database {
    my $self = shift;
    my $u = $self->{uri};
    my $dr = $self->driver;
    my $db = '';
    if ($dr eq 'sqlite' or $dr eq 'file') {
        $db = $u->path->leading_slash(1)->trailing_slash(0)->to_string // '';
        $db =~ s/^\/+\.\///;
    } else {

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

        $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",
            join(", ", map {defined($_) ? sprintf("'%s\'", $_) : 'undef'} @$bind_values));

        $rv  = $sth->execute(@$bind_values);
    } elsif (my $cb = $args->{bind_callback} || $args->{bind_cb}) {
        unless (is_code_ref($cb)) {
            $self->error("Invalid binding callback function. Code ref expected");
            return;
        }
        $cb->($sth); # Callback! bind params
        $rv = $sth->execute;
    } else {
        $rv = $sth->execute; # Without bindings
    }
    unless (defined $rv) {
        $self->error(sprintf("Can't execute statement \"%s\"%s: %s", $sql, $argb,
            $sth->errstr || $dbh->errstr || $DBI::errstr || 'unknown error'));
        return;
    }

    # Result
    return Acrux::DBI::Res->new(
        dbi => $self,
        sth => $sth,
        affected_rows => $rv >= 0 ? 0 + $rv : -1,
    );
}

# Working with dumps
sub dump {
    my $self = shift;
    return Acrux::DBI::Dump->new(dbi => $self, @_)
}

sub cleanup {
    my $self = shift;
    undef $self->{dbh};
    return $self;
}
sub DESTROY {
    my $self = shift;
    printf STDERR "DESTROY on phase %s\n", ${^GLOBAL_PHASE} if DEBUG;
    return if ${^GLOBAL_PHASE} eq 'DESTRUCT';
    return unless $self->{autoclean};
    $self->disconnect;
    printf STDERR "Auto cleanup on DESTROY completed\n" if DEBUG;
}


1;

__END__