view release on metacpan or  search on metacpan

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

Checks the connection to database

=head2 port

    my $port = $dbi->port;

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

Default: none

=head2 query

    my $res = $dbi->query('select * from test');
    my $res = $dbi->query('insert into test values (?, ?)', @values);

Execute a blocking statement and return a L<Acrux::DBI::Res> object with the results.
You can also append a 'bind_callback' to perform binding value manually:

    my $res = $dbi->query('insert into test values (?, ?)', {
        bind_callback => sub {
            my $sth = shift;
            $sth->bind_param( ... );
          }
      });

=head2 rollback

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

This is a transaction method!

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

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

=head2 transaction

    my $tx = $dbi->transaction;

Begin transaction and return L<Acrux::DBI::Tx> object, which will automatically
roll back the transaction unless L<Acrux::DBI::Tx/commit> has been called before
it is destroyed

    # Insert rows in a transaction
    eval {
      my $tx = $dbi->transaction;
      $dbi->query( ... );
      $dbi->query( ... );
      $tx->commit;
    };
    say $@ if $@;

=head2 url

    my $url = $dbi->url;
    $dbi = $dbi->url('sqlite:///tmp/test.db?sqlite_unicode=1');
    $dbi = $dbi->url('sqlite:///./test.db?sqlite_unicode=1'); # '/./' will be removed
    $dbi = $dbi->url('postgres://foo:pass@localhost/mydb?PrintError=1');
    $dbi = $dbi->url('mysql://foo:pass@localhost/test?mysql_enable_utf8=1');

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';

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

}
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 {
        $db = $u->path->leading_slash(0)->trailing_slash(0)->to_string // '';
    }
    return $db;
}
sub dsn {
    my $self = shift;
    $self->{dsn} = shift if scalar(@_) >= 1;
    return $self->{dsn} if $self->{dsn};
    my $dr = $self->driver;

    # Set DSN
    my @params = ();
    my $dsn = '';
    my $db = $self->database;
    if ($dr eq 'sqlite' or $dr eq 'file') {
        $dsn = sprintf('DBI:SQLite:dbname=%s', $db);
    } elsif ($dr eq 'mysql') {
        push @params, sprintf("%s=%s", "database", $db) if length $db;
        push @params, sprintf("%s=%s", "host", $self->host);
        push @params, sprintf("%s=%s", "port", $self->port) if $self->port;
        $dsn = sprintf('DBI:mysql:%s', join(";", @params) || '');
    } elsif ($dr eq 'maria' or $dr eq 'mariadb') {
        push @params, sprintf("%s=%s", "database", $db) if length $db;
        push @params, sprintf("%s=%s", "host", $self->host);
        push @params, sprintf("%s=%s", "port", $self->port) if $self->port;
        $dsn = sprintf('DBI:MariaDB:%s', join(";", @params) || '');
    } elsif ($dr eq 'pg' or $dr eq 'pgsql' or $dr eq 'postgres' or $dr eq 'postgresql') {
        push @params, sprintf("%s=%s", "dbname", $db) if length $db;
        push @params, sprintf("%s=%s", "host", $self->host);
        push @params, sprintf("%s=%s", "port", $self->port) if $self->port;
        $dsn = sprintf('DBI:Pg:%s', join(";", @params) || '');
    } elsif ($dr eq 'oracle') {
        push @params, sprintf("%s=%s", "host", $self->host);
        push @params, sprintf("%s=%s", "sid", $db) if length $db;
        push @params, sprintf("%s=%s", "port", $self->port) if $self->port;
        $dsn = sprintf('DBI:Oracle:%s', join(";", @params) || '');
    } else {
        $dsn = DEFAULT_DBI_DSN;
    }

    $self->{dsn} = $dsn;
}
sub cache { shift->{cache} }
sub cachekey {
    my $self = shift;
    return $self->{cachekey} if $self->{cachekey};

    # Generate cachekey data
    my $opts = $self->{opts}; # defaults
    my @pairs = ();
    foreach my $k (sort { $a cmp $b } keys %$opts) {
        push @pairs, "$k=" . ($opts->{$k} // '');
    }
    my $sfx = join ";", @pairs;
    $self->{cachekey} = md5_sum($self->{url} . $sfx);
}
sub dbh { shift->{dbh} }

# Methods
sub error {
    my $self = shift;
    if (scalar(@_) >= 1) {
        $self->{error} = shift;
        return $self;
    }
    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 {