Acrux-DBI
view release on metacpan or search on metacpan
# Version/Revision history
0.03 Web 17 Apr 2024 18:04:54 MSK
* Added Acrux::DBI::Dump class
* Added set-context of dsn method
* Added database URL-string to examples
* Added dump method to faster access to Acrux::DBI::Dump
0.02 Sat 13 Apr 2024 17:27:46 MSK
* Documentation modified
* Added rules for error message getting
0.01 Sun 04 Feb 2024 14:24:05 MSK
* Initial release
lib/Acrux/DBI.pm view on Meta::CPAN
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
my $dbi = $dbi->connect;
die $dbi->error if $dbi->error;
This method makes a connection to the database
=head2 connect_cached
my $dbi = $dbi->connect_cached;
die $dbi->error if $dbi->error;
This method makes a cached connection to the database. See L<DBI/connect_cached> for details
=head2 database
my $database = $dbi->database;
This method returns the database that will be used for generating the connection DSN
This will be used as L<Mojo::URL/path>
lib/Acrux/DBI.pm view on Meta::CPAN
my $err = $dbi->err;
This method just returns C<$DBI::err> value
=head2 errstr
my $errstr = $dbi->errstr;
This method just returns C<$DBI::errstr> value
=head2 error
my $error = $dbi->error;
Returns error string if occurred any errors while working with database
$dbi = $dbi->error( "error text" );
Sets new error message and returns object
=head2 host
my $host = $dbi->host;
This is the L<Mojo::URL/host> that will be used for generating the connection DSN
Default: C<localhost>
=head2 options
lib/Acrux/DBI.pm view on Meta::CPAN
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;
lib/Acrux/DBI.pm view on Meta::CPAN
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 {
$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;
lib/Acrux/DBI.pm view on Meta::CPAN
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",
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,
);
}
t/03-connect.t view on Meta::CPAN
plan skip_all => "Currently a developer-only test" unless -d ".git";
my $url = $ENV{DB_CONNECT_URL} or plan skip_all => "DB_CONNECT_URL required";
ok($url, 'DB_CONNECT_URL is correct') and note $url;
# Connect
my $dbi;
subtest 'Connecting' => sub {
$dbi = Acrux::DBI->new($url, autoclean => 1);
is($dbi->{autoclean}, 1, 'autoclean = 1');
$dbi->connect;
ok(!$dbi->error, 'Connect to ' . $dbi->dsn) or diag $dbi->error;
ok $dbi->ping, 'Connected';
#is($dbi->driver, 'postgres', 'Driver (scheme) is postgres');
#is($dbi->host, 'localhost', 'Host is localhost');
#is($dbi->port, '', 'Port is null');
#is($dbi->userinfo, 'foo:pass', 'Userinfo is foo:pass');
#is($dbi->password, 'pass', 'Password is pass');
#is($dbi->database, 'mydb', 'Password is mydb');
#is($dbi->dsn, 'DBI:Pg:dbname=mydb;host=localhost', 'DSN is DBI:Pg:dbname=mydb;host=localhost');
#note explain {(DBI->installed_drivers)};
#my $res = $dbi->query('select * from monm');
#ok($res, 'select * from monm') or diag $dbi->error;
#note explain $res;
#note explain $res->array;
#note explain $res->arrays;
#note explain $res->collection_list;
#note explain $res->columns;
#note explain $res->hash;
#note explain $res->hashes;
#note explain $res->collection;
#note $res->rows;
#note $res->text;
t/03-connect.t view on Meta::CPAN
#note explain $dbi->dbh->{Driver};
#note $dbi->dbh->{Driver}{Name}
#note explain $res->{'mysql_type'};
#note explain $res->{'pg_type'};
};
subtest 'Create' => sub {
my $res = $dbi->query('CREATE TABLE IF NOT EXISTS `names` (`id` INTEGER AUTO_INCREMENT PRIMARY KEY, `name` VARCHAR(255))');
ok($res, 'Create table') or diag $dbi->error;
if (ref $res) {
# Insert a few rows
ok($dbi->query('INSERT INTO `names` (name) VALUES (?)', 'Bob'), 'Add Bob') or diag $dbi->error;
ok($dbi->query('INSERT INTO `names` (name) VALUES (?)', 'Alice'), 'Add Alice') or diag $dbi->error;
}
};
subtest 'Read' => sub {
my $res = $dbi->query('SELECT `name` FROM `names` WHERE `name` = ?', 'Bob');
ok($res, 'Read Bob') or diag $dbi->error;
if (ref $res) {
is($res->hash->{name}, 'Bob', 'Bob user found');
#note explain $res->hash;
}
};
subtest 'Update' => sub {
my $res = $dbi->query('UPDATE `names` SET `name` = ? WHERE `name` = ?', 'Fred', 'Bob');
ok($res, 'Update Bob to Fred') or diag $dbi->error;
if (ref $res) {
my $r2 = $dbi->query('SELECT `name` FROM `names` WHERE `name` = ?', 'Fred');
ok($r2 && $r2->rows, 'Fred user found');
}
};
subtest 'Delete' => sub {
my $res = $dbi->query('DELETE FROM `names` WHERE `name` = ?', 'Alice');
ok($res, 'Delete Alice') or diag $dbi->error;
if (ref $res) {
my $r2 = $dbi->query('SELECT `name` FROM `names` WHERE `name` = ?', 'Alice');
ok($r2 && !$r2->rows, 'Alice user not found');
}
};
subtest 'Cleanup' => sub {
my $res = $dbi->query('DROP TABLE IF EXISTS `names`');
ok($res, 'Drop table') or diag $dbi->error;
};
done_testing;
1;
__END__
DB_CONNECT_URL='postgres://foo:pass@localhost/mydb?PrintError=1&foo=123' prove -lv t/03-connect.t
DB_CONNECT_URL='mysql://test:test@192.168.0.1/test?mysql_auto_reconnect=1&mysql_enable_utf8=1' prove -lv t/03-connect.t
t/04-transaction.t view on Meta::CPAN
use Acrux::DBI;
plan skip_all => "Currently a developer-only test" unless -d ".git";
my $url = $ENV{DB_CONNECT_URL} or plan skip_all => "DB_CONNECT_URL required";
ok($url, 'DB_CONNECT_URL is correct') and note $url;
# Connect
my $dbi;
subtest 'Connecting' => sub {
$dbi = Acrux::DBI->new($url, autoclean => 1)->connect;
ok(!$dbi->error, 'Connect to ' . $dbi->dsn) or diag $dbi->error;
ok $dbi->ping, 'Connected' or return;
};
subtest 'Create table' => sub {
my $res = $dbi->query('CREATE TABLE IF NOT EXISTS `names` (`id` INTEGER AUTO_INCREMENT PRIMARY KEY, `name` VARCHAR(255))');
ok($res, 'Create table') or do { diag $dbi->error; return }
};
subtest 'Transactions1' => sub {
$dbi->dbh->{AutoCommit} = 0; # enable transactions, if possible
eval {
my $tx = $dbi->transaction;
$dbi->query("INSERT INTO `names` (name) values ('foo')") or die $dbi->error;
$dbi->query("INSERT INTO `names` (name_bad) values ('bar')") or die $dbi->error;
$tx->commit;
};
ok($@, 'Transaction 1 completed with errors') and diag $@ // 'oops';
};
subtest 'Transactions2' => sub {
$dbi->dbh->{AutoCommit} = 0; # enable transactions, if possible
eval {
my $tx = $dbi->transaction;
$dbi->query("INSERT INTO `names` (name) values ('baz')") or die $dbi->error;
$dbi->query("INSERT INTO `names` (name) values ('qux')") or die $dbi->error;
$tx->commit;
};
ok(!$@, 'Transaction 2 completed without errors') or diag $@ // 'oops';
};
subtest 'Cleanup' => sub {
my $res = $dbi->query('DROP TABLE IF EXISTS `names`');
ok($res, 'Drop table') or diag $dbi->error;
};
done_testing;
1;
__END__
DB_CONNECT_URL='mysql://test:test@192.168.0.1/test?mysql_auto_reconnect=1&mysql_enable_utf8=1' prove -lv t/04-transaction.t
t/05-dump.t view on Meta::CPAN
my $is_new = 0;
subtest 'Connecting' => sub {
$dbi = Acrux::DBI->new($url, autoclean => 1)->connect;
if (defined($dbi->dbh) && $dbi->driver eq 'sqlite') {
my $file = $dbi->dbh->sqlite_db_filename();
unless ($file && (-e $file) && !(-z $file)) {
touch($file);
$is_new = 1;
}
}
ok(!$dbi->error, 'Connect to ' . $dbi->dsn) or diag $dbi->error;
ok $dbi->ping, 'Connected' or return;
};
my $string = <<EOL;
CREATE TABLE `test` (`message` TEXT);
-- #foo
CREATE TABLE `pets` (`pet` TEXT);
INSERT INTO `pets` VALUES ('cat');
INSERT INTO `pets` VALUES ('dog');
t/05-dump.t view on Meta::CPAN
my $bar = $dump->peek('bar');
is(scalar @$bar, 2, 'The "bar" block contains 2 statements') or diag explain $bar;
my $none = $dump->peek('none');
is(scalar @$none, 0, 'The "none" block is empty or not exists') or diag explain $none;
my @baz = $dump->peek('baz');
is(scalar @baz, 1, 'The "baz" block contains 2 statements') or diag explain \@baz;
};
subtest 'Create table' => sub {
$dump->poke('test');
ok(!$dbi->error, 'Poked test dump') or diag $dbi->error;
} if $is_new;
subtest 'Transaction' => sub {
$dump->poke('tx');
ok(!$dbi->error, 'Poked tx dump') or diag $dbi->error;
};
#$dbi->disconnect; # Disabled this: see autoclean option
done_testing;
1;
__END__
( run in 0.382 second using v1.01-cache-2.11-cpan-65fba6d93b7 )