DBIx-QuickORM
view release on metacpan or search on metacpan
pass 'hunter2'; # Do not store any real passwords in plaintext in code!!!!
};
Can be nested under db or server.
creds sub { return \%CREDS }
Allows you to provide a coderef that will return a hashref with all
the necessary database connection fields.
This is mainly useful if you credentials are in an encrypted YAML or
JSON file and you have a method to decrypt and read it returning it
as a hash.
db mydb => sub {
creds sub { ... };
};
Can be nested under db or server.
connect sub { ... }
db mydb => sub {
dsn "dbi:Pg:dbname=foo";
};
Can be nested under db or server.
server $NAME => sub { ... }
Used to define a server with multiple databases. This is a way to
avoid re-specifying credentials for each database you connect to.
You can use db('server_name.db_name') to fetch the database.
Basically this allows you to specify any database fields once in the
server, then define any number of databases that inherit them.
Example:
server pg => sub {
host 'pg.myapp.com';
pass 'hunter2'; # Do not store any real passwords in plaintext in code!!!!
};
Can be nested under `db` or `server`.
- `creds sub { return \%CREDS }`
Allows you to provide a coderef that will return a hashref with all the
necessary database connection fields.
This is mainly useful if you credentials are in an encrypted YAML or JSON file
and you have a method to decrypt and read it returning it as a hash.
db mydb => sub {
creds sub { ... };
};
Can be nested under `db` or `server`.
- `connect sub { ... }`
- `connect \&connect`
db mydb => sub {
dsn "dbi:Pg:dbname=foo";
};
Can be nested under `db` or `server`.
- `server $NAME => sub { ... }`
Used to define a server with multiple databases. This is a way to avoid
re-specifying credentials for each database you connect to.
You can use `db('server_name.db_name')` to fetch the database.
Basically this allows you to specify any database fields once in the server, then
define any number of databases that inherit them.
Example:
server pg => sub {
host 'pg.myapp.com';
lib/DBIx/QuickORM.pm view on Meta::CPAN
$params{+SCHEMAS} //= {};
$params{+SERVERS} //= {};
return bless(\%params, $class);
}
sub quick {
my $class = shift;
my %params = @_;
my $creds = delete $params{credentials};
my $connect = delete $params{connect};
my $types = delete $params{auto_types} // [];
my $dialect = delete $params{dialect};
my $autorow = delete $params{autorow}; # 0 = off (default), 1 = generated namespace, or a class-name prefix
my $row_manager = delete $params{row_manager} // 'DBIx::QuickORM::RowManager::Cached';
my $no_volatile = delete $params{no_volatile}; # 1 = every table, or an arrayref of table names
croak "Unknown parameter(s) to quick(): " . join(', ', sort keys %params) if keys %params;
croak "'no_volatile' must be a true scalar (every table) or an arrayref of table names"
if defined($no_volatile) && ref($no_volatile) && ref($no_volatile) ne 'ARRAY';
croak "quick() requires exactly one of 'credentials' or 'connect'"
unless (($creds ? 1 : 0) + ($connect ? 1 : 0)) == 1;
croak "'credentials' must be a hashref" if $creds && ref($creds) ne 'HASH';
croak "'connect' must be a coderef" if $connect && ref($connect) ne 'CODE';
croak "'auto_types' must be an arrayref" if ref($types) ne 'ARRAY';
my ($dialect_class, $db_name) = $class->_quick_detect($dialect, $creds, $connect);
require DBIx::QuickORM::DB;
my %db_params = (dialect => $dialect_class, db_name => $db_name);
if ($creds) {
if (my @bad = grep { $_ !~ /^(?:dsn|user|pass|attrs|dbd)$/ } keys %$creds) {
croak "Unknown credentials key(s): " . join(', ' => sort @bad) . " (valid: dsn, user, pass, attrs, dbd)";
}
$db_params{dsn} = $creds->{dsn} if defined $creds->{dsn};
$db_params{user} = $creds->{user} if defined $creds->{user};
$db_params{pass} = $creds->{pass} if defined $creds->{pass};
$db_params{attributes} = $creds->{attrs} if defined $creds->{attrs};
$db_params{dbi_driver} = $creds->{dbd} if defined $creds->{dbd};
}
else {
$db_params{connect} = $connect;
}
lib/DBIx/QuickORM.pm view on Meta::CPAN
if ($creds) {
$name_source = $creds->{dsn};
if (my $dbd = $creds->{dbd}) {
($driver = $dbd) =~ s/^DBD:://;
}
elsif (my $dsn = $creds->{dsn}) {
($driver) = $dsn =~ m/^dbi:([^:]+):/i
or croak "Could not parse a driver from the dsn '$dsn'";
}
elsif (!$explicit) {
croak "quick() credentials need a 'dsn' or 'dbd' to detect the dialect, or pass an explicit 'dialect'";
}
}
else {
my $dbh = $connect->() or croak "The 'connect' callback did not return a database handle";
$driver = $dbh->{Driver}->{Name};
$name_source = $dbh->{Name};
$dbh->disconnect;
}
my $dialect;
lib/DBIx/QuickORM.pm view on Meta::CPAN
pass 'hunter2'; # Do not store any real passwords in plaintext in code!!!!
};
Can be nested under C<db> or C<server>.
=item C<creds sub { return \%CREDS }>
Allows you to provide a coderef that will return a hashref with all the
necessary database connection fields.
This is mainly useful if you credentials are in an encrypted YAML or JSON file
and you have a method to decrypt and read it returning it as a hash.
db mydb => sub {
creds sub { ... };
};
Can be nested under C<db> or C<server>.
=item C<connect sub { ... }>
lib/DBIx/QuickORM.pm view on Meta::CPAN
db mydb => sub {
dsn "dbi:Pg:dbname=foo";
};
Can be nested under C<db> or C<server>.
=item C<< server $NAME => sub { ... } >>
Used to define a server with multiple databases. This is a way to avoid
re-specifying credentials for each database you connect to.
You can use C<< db('server_name.db_name') >> to fetch the database.
Basically this allows you to specify any database fields once in the server, then
define any number of databases that inherit them.
Example:
server pg => sub {
host 'pg.myapp.com';
lib/DBIx/QuickORM/DB.pm view on Meta::CPAN
my $self = shift;
return $self->{+DSN} if $self->{+DSN};
return $self->{+DSN} = $self->{+DIALECT}->dsn($self);
}
=pod
=item $dbh = $db->new_dbh
Returns a new DBI handle, using the C<connect> callback when present or
C<< DBI->connect >> with the resolved DSN and credentials otherwise. Croaks if
the connection attempt throws or fails to produce a handle (possible when
C<RaiseError> is disabled or the callback misbehaves).
=back
=cut
sub new_dbh {
my $self = shift;
lib/DBIx/QuickORM/Manual/Connections.pm view on Meta::CPAN
Alternatively, supply a C<connect> coderef that returns a fresh C<DBI> handle.
When present it is used instead of the DSN-based path, giving you full control
over how the handle is opened (custom drivers, connection pools, extra setup,
and so on):
connect => sub { DBI->connect($dsn, $user, $pass, \%attrs) },
Each new handle - whether for the first connection, a reconnect, or a forked
child - is produced the same way: via your callback if you provided one,
otherwise via C<< DBI->connect >> with the resolved DSN and credentials. See
L<DBIx::QuickORM::DB> for the full set of configuration attributes.
=head1 SEE ALSO
=over 4
=item L<DBIx::QuickORM::Connection>
The connection object itself: transactions, handles, async/aside/forked
queries, and the state operations backing the row cache.
lib/DBIx/QuickORM/Manual/Features.pm view on Meta::CPAN
Connect to a database and work with its rows as objects with no DSL, using
C<< DBIx::QuickORM->quick(...) >>. See L<DBIx::QuickORM::Manual::QuickStart>.
=item Connection lifecycle
A memoized connection per ORM, in-place reconnect, and fork safety. See
L<DBIx::QuickORM::Manual::Connections>.
=item Credentials or connect callback
Configure a connection from a DSN/credentials or your own connect callback.
See L<DBIx::QuickORM::Manual::Connections> and L<DBIx::QuickORM/db>.
=back
=head1 DEFINING AN ORM (THE DSL)
=over 4
=item Schemas, tables, columns
lib/DBIx/QuickORM/Manual/QuickStart.pm view on Meta::CPAN
The idea: point C<quick()> at a database, and DBIx::QuickORM introspects all
the table and column metadata directly from the live database. You get back a
ready-to-use connection and start treating rows as objects immediately.
When you want more control (defining your own schema, custom row classes,
joins, and so on) follow the links at the end of this page. For the bigger
picture and the full set of guides, see L<DBIx::QuickORM::Manual>.
=head1 CONNECT
Use the C<quick()> class method. Provide exactly one of C<credentials> or
C<connect>. The SQL dialect is detected automatically from the DSN (or the
C<dbd>), so you usually do not need to think about it.
use DBIx::QuickORM;
my $con = DBIx::QuickORM->quick(
credentials => {
dsn => $dsn, # e.g. "dbi:Pg:dbname=myapp;host=..."
user => $user,
pass => $pass,
},
# Type classes (under DBIx::QuickORM::Type unless fully qualified)
# used to auto inflate/deflate matching columns.
auto_types => ['JSON', 'UUID'],
);
If you would rather hand DBIx::QuickORM a callback that produces a fresh DBI
handle, use C<connect> instead of C<credentials>:
my $con = DBIx::QuickORM->quick(
connect => sub { DBI->connect($dsn, $user, $pass) },
);
C<$con> is a L<DBIx::QuickORM::Connection>. It self-heals: it can reconnect in
place and retry work, preserving its row cache. That is the only object you
need to keep around.
=head2 OPTIONS
lib/DBIx/QuickORM/Manual/Recipes.pm view on Meta::CPAN
=head1 DESCRIPTION
This is a hub of focused, task-oriented recipes for L<DBIx::QuickORM>. Each
recipe below solves a specific problem; for broader topics see the guides
linked under L</SEE ALSO>.
=head2 DEFINE DB LATER
In some cases you may want to define your orm/schema before you have your
database credentials. Then you want to add the database later in an app/script
bootstrap process.
Schema:
package My::Schema;
use DBIx::QuickORM;
orm MyORM => sub {
autofill;
};
lib/DBIx/QuickORM/Manual/Recipes.pm view on Meta::CPAN
use My::Schema;
# This will do the db bootstrap
use My::Bootstrap;
# Connect to the database with the ORM
my $con = qorm('MyORM');
=head2 SCHEMA WITH NO DATABASE, ADD A CONNECT CALLBACK LATER
Like L</"DEFINE DB LATER">, but instead of credentials you attach your own
C<connect> callback (any sub that returns a fresh L<DBI> handle) right before
you need the connection. This is handy when the connection comes from
something you build yourself - a pool, a tunnel, an already-open handle, and
so on.
Define the schema with no database at all:
package My::Schema;
use DBIx::QuickORM;
lib/DBIx/QuickORM/Manual/Schema.pm view on Meta::CPAN
table events => sub {
no_volatile;
...
};
Or from the C<quick> interface, for one or more tables (or C<< => 1 >> for every
table):
my $con = DBIx::QuickORM->quick(
credentials => { dsn => $dsn },
no_volatile => [ 'events', 'audit_log' ],
);
A volatile-free assertion skips both the best-effort trigger flagging and the
warning for that table; it does not clear the generated/identity auto-detection,
which is based on declared facts rather than trigger guesses.
To see which tables are safe (every column non-volatile) at a glance:
my @safe = $con->volatile_free_tables; # sorted table names
t/AI/async_row_proxy.t view on Meta::CPAN
my $file = "$dir/async.sqlite";
my $dsn = "dbi:SQLite:dbname=$file";
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE items (item_id INTEGER PRIMARY KEY, name TEXT NOT NULL)');
$dbh->do("INSERT INTO items (item_id, name) VALUES (1, 'one'), (2, 'two'), (3, 'three')");
$dbh->disconnect;
}
my $con = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $source = $con->source('items');
sub mock_proxy {
my %params = @_;
my $rows = delete $params{rows} // [];
my $async = My::Mock::Async->new(connection => $con, source => $source, rows => $rows);
my $proxy = DBIx::QuickORM::Row::Async->new(async => $async, %params);
return ($proxy, $async);
}
t/AI/batch_introspect_methods.t view on Meta::CPAN
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE owners (id INTEGER PRIMARY KEY AUTOINCREMENT, name TEXT NOT NULL UNIQUE, note TEXT)');
$dbh->do('CREATE TABLE pets (id INTEGER PRIMARY KEY, owner_id INTEGER REFERENCES owners(id), name TEXT NOT NULL, tag INTEGER UNIQUE)');
$dbh->do('CREATE INDEX pets_owner_idx ON pets(owner_id)');
$dbh->do('CREATE TABLE memberships (owner_id INTEGER NOT NULL, pet_id INTEGER NOT NULL, kind TEXT, PRIMARY KEY (owner_id, pet_id))');
$dbh->do('CREATE TABLE gen (id INTEGER PRIMARY KEY, base INTEGER NOT NULL, doubled INTEGER GENERATED ALWAYS AS (base * 2) VIRTUAL)');
$dbh->do('CREATE TABLE wr (code TEXT PRIMARY KEY, total INTEGER) WITHOUT ROWID');
$dbh->disconnect;
}
my $con = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $dialect = $con->dialect;
my $all_xinfo = $dialect->_fetch_all_xinfo;
my $all_idx = $dialect->_fetch_all_index_info;
my $all_fks = $dialect->_fetch_all_fks;
my $all_ddl = $dialect->_fetch_all_ddl;
# Every permanent table is keyed under the is_temp=0 dimension. The sweep
# also surfaces SQLite-internal tables (e.g. sqlite_sequence from the
# AUTOINCREMENT column); build_tables_from_db skips those by name, so ignore
t/AI/batch_introspect_methods.t view on Meta::CPAN
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0, AutoCommit => 1});
$dbh->do('CREATE SEQUENCE owners_seq');
$dbh->do(q{CREATE TABLE owners (id INTEGER PRIMARY KEY DEFAULT nextval('owners_seq'), name TEXT NOT NULL UNIQUE, note TEXT)});
$dbh->do('CREATE TABLE pets (id INTEGER PRIMARY KEY, owner_id INTEGER REFERENCES owners(id), name TEXT NOT NULL, tag INTEGER UNIQUE)');
$dbh->do('CREATE TABLE memberships (owner_id INTEGER NOT NULL, pet_id INTEGER NOT NULL, kind TEXT, PRIMARY KEY (owner_id, pet_id))');
$dbh->disconnect;
1;
};
skip_all "DuckDB unavailable: $@" unless $built;
my $con = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $dialect = $con->dialect;
# Primary-key membership comes from the shared constraint sweep, the same way
# build_tables_from_db feeds it to _fetch_all_columns.
my $all_con = $dialect->_fetch_all_constraints;
my %pk_by_table;
for my $tname (keys %$all_con) {
for my $con_row (@{$all_con->{$tname}}) {
next unless $con_row->{constraint_type} eq 'PRIMARY KEY';
$pk_by_table{$tname}{$_} = 1 for @{$con_row->{constraint_column_names} // []};
t/AI/cache_fixes.t view on Meta::CPAN
my $sep = chr(31);
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE pairs (k1 TEXT NOT NULL, k2 TEXT NOT NULL, val TEXT, PRIMARY KEY (k1, k2))');
$dbh->do('CREATE TABLE solo (solo_id INTEGER PRIMARY KEY, name TEXT)');
$dbh->disconnect;
}
my $con = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $h = $con->handle('pairs');
my $manager = $con->manager;
subtest composite_keys_with_separator_and_backslash => sub {
my $row_a = $h->insert({k1 => "a${sep}b", k2 => "c", val => 'A'});
my $row_b = $h->insert({k1 => "a", k2 => "b${sep}c", val => 'B'});
my $row_c = $h->insert({k1 => "x\\", k2 => "${sep}y", val => 'C'});
my $row_d = $h->insert({k1 => "x\\${sep}", k2 => "y", val => 'D'});
my $key_a = $manager->cache_key(["a${sep}b", "c"]);
t/AI/caching.t view on Meta::CPAN
$dbh->do('CREATE TABLE logs (message TEXT NOT NULL)');
$dbh->do('INSERT INTO logs (message) VALUES (?)', undef, 'hello');
$dbh->do('INSERT INTO logs (message) VALUES (?)', undef, 'world');
$dbh->disconnect;
return $dsn;
}
sub connect_orm {
my $dsn = shift // fresh_db();
return DBIx::QuickORM->quick(credentials => {dsn => $dsn});
}
subtest default_manager_is_cached => sub {
my $con = connect_orm();
isa_ok($con->manager, ['DBIx::QuickORM::RowManager::Cached'], "default manager is Cached");
ok($con->manager->does_cache, "does_cache is true for the default manager");
ok($con->state_does_cache, "connection reports caching is on");
};
subtest identity_same_object => sub {
t/AI/connection.t view on Meta::CPAN
my $file = "$dir/connection.sqlite";
my $dsn = "dbi:SQLite:dbname=$file";
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE users (user_id INTEGER PRIMARY KEY, name TEXT NOT NULL)');
$dbh->do('INSERT INTO users (user_id, name) VALUES (1, ?)', undef, 'bob');
$dbh->disconnect;
}
sub connect_orm { DBIx::QuickORM->quick(credentials => {dsn => $dsn}, @_) }
subtest connection_is_memoized_singleton => sub {
my $con = connect_orm();
my $orm = $con->orm;
ref_is($orm->connection, $con, "quick() returns the ORM's memoized connection");
ref_is($orm->connection, $orm->connection, "connection() returns the same object every call");
my $fresh = $orm->connect;
ref_is_not($fresh, $con, "connect() builds a brand new, independent connection");
t/AI/connection_audit.t view on Meta::CPAN
my $file = "$dir/connection_audit.sqlite";
my $dsn = "dbi:SQLite:dbname=$file";
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE users (user_id INTEGER PRIMARY KEY, name TEXT NOT NULL)');
$dbh->do('INSERT INTO users (user_id, name) VALUES (1, ?)', undef, 'bob');
$dbh->disconnect;
}
sub connect_orm { DBIx::QuickORM->quick(credentials => {dsn => $dsn}, @_) }
sub raw_names {
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
my $names = $dbh->selectcol_arrayref('SELECT name FROM users ORDER BY name');
$dbh->disconnect;
return $names;
}
subtest reconnect_rebuilds_dialect => sub {
my $con = connect_orm();
t/AI/datetime.t view on Meta::CPAN
# ---- DateTime type over a real SQLite db ----
my $dir = tempdir(CLEANUP => 1);
my $dsn = "dbi:SQLite:dbname=$dir/dt.sqlite";
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE events (id INTEGER PRIMARY KEY, created DATETIME)');
$dbh->do("INSERT INTO events (created) VALUES ('2020-01-02 03:04:05')");
$dbh->disconnect;
}
my $con = DBIx::QuickORM->quick(credentials => {dsn => $dsn}, auto_types => ['DateTime']);
subtest lazy_inflate => sub {
my ($row) = $con->handle('events')->all;
my $v = $row->field('created');
ok(masked($v), "datetime column inflated to a mask");
ok($v->isa('DBIx::QuickORM::Type::DateTime'), "isa the type (no build needed)");
ok(!$v->qorm_mask_inflated, "isa(type) did not build the DateTime");
is("$v", '2020-01-02 03:04:05', "stringifies to the database string");
t/AI/desync_guard.t view on Meta::CPAN
}
sub db_value {
my ($col, $pk) = @_;
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
my ($val) = $dbh->selectrow_array("SELECT $col FROM people WHERE person_id = ?", undef, $pk);
$dbh->disconnect;
return $val;
}
my $con = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $h = $con->handle('people');
sub desynced_row {
my (%fields) = @_;
my $row = $h->insert({name => 'sync', email => 'sync@example.com', age => 1, %fields});
my $pk = $row->field('person_id');
$row->field(name => 'mine');
db_change($pk, name => 'theirs');
$row->refresh;
t/AI/dialect_sqlite_identity.t view on Meta::CPAN
$dbh->do(<<' EOT');
CREATE TRIGGER with_trig_autoincrement AFTER INSERT ON with_trig
BEGIN
UPDATE with_trig SET note = 'AUTOINCREMENT mentioned here' WHERE id = NEW.id;
END
EOT
$dbh->disconnect;
}
my $con = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $schema = $con->schema;
my $dialect = $con->dialect;
subtest rowid_alias_identity => sub {
ok($schema->table('plain_pk')->column('id')->identity, "plain INTEGER PRIMARY KEY (rowid alias) is identity");
ok($schema->table('auto_pk')->column('id')->identity, "INTEGER PRIMARY KEY AUTOINCREMENT is identity");
ok(!$schema->table('text_pk')->column('id')->identity, "TEXT PRIMARY KEY is not identity");
ok(!$schema->table('int_pk')->column('id')->identity, "INT (not INTEGER) PRIMARY KEY does not alias rowid, not identity");
ok(!$schema->table('no_rowid')->column('id')->identity, "INTEGER PRIMARY KEY in a WITHOUT ROWID table is not identity");
t/AI/dialect_sqlite_indexes.t view on Meta::CPAN
my $dsn = "dbi:SQLite:dbname=$dir/idx.sqlite";
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE t (id INTEGER PRIMARY KEY, email TEXT, name TEXT, deleted INTEGER)');
$dbh->do('CREATE UNIQUE INDEX u_email ON t (email)'); # real unique
$dbh->do('CREATE UNIQUE INDEX u_name_active ON t (name) WHERE deleted = 0'); # partial unique
$dbh->do('CREATE UNIQUE INDEX u_lower ON t (lower(email))'); # expression unique
$dbh->disconnect;
}
my $con = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $unique = $con->schema->table('t')->unique;
my $email_key = DBIx::QuickORM::Util::column_key('email');
my $name_key = DBIx::QuickORM::Util::column_key('name');
ok(exists $unique->{$email_key}, "a plain unique index is recorded as a unique constraint");
ok(!exists $unique->{$name_key}, "a partial unique index is NOT recorded as a table unique constraint");
ok(!(grep { !defined($_) || $_ eq '' } keys %$unique), "no garbage/undef unique key from the expression index");
ok(!(grep { !defined } map { @$_ } values %$unique), "no unique key contains an undef column");
t/AI/dialect_sqlite_keys.t view on Meta::CPAN
id INTEGER PRIMARY KEY,
foo_id INTEGER NOT NULL REFERENCES foo(id),
tag TEXT
)
EOT
$dbh->do('CREATE INDEX bar_foo_idx ON bar(foo_id)');
$dbh->do('CREATE UNIQUE INDEX bar_tag_idx ON bar(tag)');
$dbh->disconnect;
}
my $con = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $schema = $con->schema;
my $bar = $schema->table('bar');
subtest unique_constraints => sub {
ok(!$bar->unique->{'foo_id'}, "plain index on foo_id is NOT recorded as a unique constraint");
ok($bar->unique->{'tag'}, "unique index on tag IS recorded as a unique constraint");
ok($bar->unique->{'id'}, "primary key is recorded as a unique constraint");
};
subtest link_cardinality => sub {
t/AI/dialect_sqlite_partial_expr_index.t view on Meta::CPAN
$dbh->do('CREATE TABLE t (a INTEGER, b TEXT)');
$dbh->do('CREATE UNIQUE INDEX u_partial ON t(a) WHERE b IS NOT NULL');
$dbh->do('CREATE UNIQUE INDEX u_expr ON t(lower(a))');
$dbh->do('CREATE UNIQUE INDEX u_plain ON t(b)');
$dbh->disconnect;
}
my $warnings = '';
local $SIG{__WARN__} = sub { $warnings .= $_[0] };
my $con = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $t = $con->schema->table('t');
subtest partial_unique_index => sub {
ok(!$t->unique->{'a'}, "partial unique index on (a) is NOT a table unique constraint");
my ($partial) = grep { $_->{name} eq 'u_partial' } @{$t->indexes};
ok($partial, "partial index still appears under indexes");
is($partial->{columns}, ['a'], "partial index keeps its column");
};
t/AI/dsl_correctness.t view on Meta::CPAN
use Test2::V0 '!meta', '!pass';
use DBI;
use File::Temp qw/tempdir/;
# Correctness fixes for the DSL:
# I3: quick() rejects unknown credentials keys instead of silently ignoring them.
# B13: columns(@names, sub {...}) applies the builder to each named column.
BEGIN {
skip_all "DBD::SQLite is required for these tests"
unless eval { require DBD::SQLite; 1 };
}
require DBIx::QuickORM;
subtest quick_rejects_unknown_credentials => sub {
my $dir = tempdir(CLEANUP => 1);
my $dsn = "dbi:SQLite:dbname=$dir/x.sqlite";
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE t (id INTEGER PRIMARY KEY)');
$dbh->disconnect;
}
like(
dies { DBIx::QuickORM->quick(credentials => {dsn => $dsn, passsword => 'typo'}) },
qr/Unknown credentials key\(s\): passsword/,
"a misspelled credentials key croaks instead of connecting wrong",
);
ok(lives { DBIx::QuickORM->quick(credentials => {dsn => $dsn}) }, "valid credentials still connect");
};
subtest columns_with_trailing_builder => sub {
{
package My::Test::DSL::B13;
use DBIx::QuickORM;
schema b13 => sub {
table t => sub {
column id => sub { affinity 'numeric'; primary_key };
t/AI/handle/by_id.t view on Meta::CPAN
my $dir = tempdir(CLEANUP => 1);
my $dsn = "dbi:SQLite:dbname=$dir/by_id.sqlite";
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE users (id INTEGER PRIMARY KEY, name TEXT NOT NULL, color TEXT)');
$dbh->do('CREATE TABLE pairs (a INTEGER NOT NULL, b INTEGER NOT NULL, label TEXT, PRIMARY KEY (a, b))');
$dbh->disconnect;
}
my $con = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $users = $con->handle('users');
my $pairs = $con->handle('pairs');
subtest cache_hit_with_extra_constraints => sub {
my $row = $users->insert({id => 1, name => 'alice', color => 'red'});
ref_is($users->by_id(1), $row, "bare by_id hits the cache");
is($users->by_id({id => 1, name => 'alice'})->field('color'), 'red', "matching extra hash constraint can still fetch");
is($users->by_id({id => 1, name => 'bob'}), undef, "non-matching extra hash constraint does not return the cached row");
};
t/AI/handle/cas.t view on Meta::CPAN
my $dir = tempdir(CLEANUP => 1);
my $dsn = "dbi:SQLite:dbname=$dir/cas.sqlite";
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE docs (id INTEGER PRIMARY KEY, revision INTEGER, note TEXT)');
$dbh->do(q{INSERT INTO docs (id, revision, note) VALUES (1, 1, 'loaded'), (2, 1, NULL)});
$dbh->disconnect;
}
my $con = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $h = $con->handle('docs');
subtest field_list_guard_requires_fetched_field => sub {
my $row = $h->fields(['id', 'revision'])->by_id(1);
like(
dies { $row->cas('note', {revision => 2}) },
qr/cas\(\) guard field 'note' was not fetched for this row/,
"field-list CAS guard croaks when the guard field was never fetched",
);
t/AI/handle/cas_clause_guards.t view on Meta::CPAN
my $dir = tempdir(CLEANUP => 1);
my $dsn = "dbi:SQLite:dbname=$dir/cas_clause_guards.sqlite";
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE example (id INTEGER PRIMARY KEY, name TEXT, revision INTEGER)');
$dbh->disconnect;
}
my $con = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $h = $con->handle('example');
my $row = $h->insert({name => 'a', revision => 1});
like(
dies { $h->row($row)->limit(1)->cas([qw/revision/], {revision => 2}) },
qr/limit.*not currently supported/,
"limit clause croaks",
);
like(
t/AI/handle/count.t view on Meta::CPAN
my $dir = tempdir(CLEANUP => 1);
my $dsn = "dbi:SQLite:dbname=$dir/count.sqlite";
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE foo (foo_id INTEGER PRIMARY KEY AUTOINCREMENT, name TEXT NOT NULL)');
$dbh->do('CREATE TABLE bar (bar_id INTEGER PRIMARY KEY AUTOINCREMENT, foo_id INTEGER REFERENCES foo(foo_id), name TEXT NOT NULL)');
$dbh->disconnect;
}
my $con = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $foo_a = $con->handle('foo')->insert({name => 'a'});
my $foo_b = $con->handle('foo')->insert({name => 'b'});
my $foo_c = $con->handle('foo')->insert({name => 'c'});
$con->handle('bar')->insert({foo_id => $foo_a->field('foo_id'), name => 'a1'});
$con->handle('bar')->insert({foo_id => $foo_a->field('foo_id'), name => 'a2'});
$con->handle('bar')->insert({foo_id => $foo_a->field('foo_id'), name => 'a3'});
$con->handle('bar')->insert({foo_id => $foo_b->field('foo_id'), name => 'b1'});
t/AI/handle/count.t view on Meta::CPAN
is($con->handle('bar')->distinct->count, 4, "distinct count over the primary key");
};
subtest distinct_count_no_pk => sub {
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE nopk (name TEXT NOT NULL)');
$dbh->disconnect;
}
my $con2 = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
like(
dies { $con2->handle('nopk')->distinct->count },
qr/Cannot count distinct rows on a source without a primary key/,
"distinct count on a pk-less source croaks"
);
};
done_testing;
t/AI/handle/insert.t view on Meta::CPAN
my $dir = tempdir(CLEANUP => 1);
my $dsn = "dbi:SQLite:dbname=$dir/insert.sqlite";
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do("CREATE TABLE example (id INTEGER PRIMARY KEY AUTOINCREMENT, name TEXT NOT NULL, xxx TEXT NOT NULL DEFAULT 'dflt')");
$dbh->disconnect;
}
my $con = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $h = $con->handle('example');
subtest caller_data_not_mutated => sub {
my $data = {name => 'a'};
my $row = $h->insert($data);
ok($row, "inserted the row");
is($data, {name => 'a'}, "the caller's data hashref was not mutated");
};
t/AI/handle/insert.t view on Meta::CPAN
};
subtest non_returning_insert_preserves_supplied_pk => sub {
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE natural (id TEXT PRIMARY KEY, name TEXT NOT NULL)');
$dbh->disconnect;
}
my $con2 = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
{
package DBIx::QuickORM::Dialect::SQLite::NoReturningInsert;
use parent -norequire, 'DBIx::QuickORM::Dialect::SQLite';
sub supports_returning_insert { 0 }
}
bless $con2->dialect, 'DBIx::QuickORM::Dialect::SQLite::NoReturningInsert';
my $h2 = $con2->handle('natural');
t/AI/handle/insert.t view on Meta::CPAN
is($h2->count, 1, "only the inserted row exists");
};
subtest pk_update_to_zero_rekeys_cache => sub {
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE other (id INTEGER PRIMARY KEY, name TEXT NOT NULL)');
$dbh->disconnect;
}
my $con2 = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $h2 = $con2->handle('other');
# Updating a pk to 0 must rekey the cache instead of leaving the row
# cached under the old key.
my $row = $h2->insert({id => 50, name => 'fifty'});
$h2->where({id => 50})->update({id => 0});
ok(!$con2->state_cache_lookup($h2->source, [50]), "old pk is no longer cached after a pk change to 0");
ref_is($con2->state_cache_lookup($h2->source, [0]), $row, "row moved to pk 0 in the cache");
is($row->field('id'), 0, "row identity reflects the new pk 0");
t/AI/handle/row_source_guard.t view on Meta::CPAN
my $file = "$dir/row-source.sqlite";
my $dsn = "dbi:SQLite:dbname=$file";
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE users (id INTEGER PRIMARY KEY, name TEXT NOT NULL)');
$dbh->do('CREATE TABLE posts (id INTEGER PRIMARY KEY, title TEXT NOT NULL)');
$dbh->disconnect;
}
my $con = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $users = $con->handle('users');
my $posts = $con->handle('posts');
my $user = $users->insert({id => 1, name => 'alice'});
my $post = $posts->insert({id => 1, title => 'hello'});
subtest row_source_must_match_handle_source => sub {
like(
dies { $users->delete($post) },
qr/The row is from source 'posts', but this handle uses source 'users'/,
t/AI/handle/row_source_guard.t view on Meta::CPAN
ok($posts->one({id => 1}), "the post row was not deleted");
like(
dies { $users->data_only->one($post) },
qr/The row is from source 'posts', but this handle uses source 'users'/,
"data_only one() rejects a row from another source",
);
};
subtest row_connection_must_match_handle_connection => sub {
my $other = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
like(
dies { $other->handle('users')->one($user) },
qr/The row is bound to a different connection than this handle/,
"one() rejects a row from another connection",
);
};
subtest matching_row_is_still_accepted => sub {
ref_is($con->handle($user)->one, $user, "a matching row can still bind a handle");
t/AI/handle/update.t view on Meta::CPAN
my $dir = tempdir(CLEANUP => 1);
my $dsn = "dbi:SQLite:dbname=$dir/update.sqlite";
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE example (id INTEGER PRIMARY KEY AUTOINCREMENT, name TEXT NOT NULL)');
$dbh->disconnect;
}
my $con = DBIx::QuickORM->quick(
credentials => {dsn => $dsn},
row_manager => 'DBIx::QuickORM::RowManager',
);
ok(!$con->state_does_cache, "using the base non-caching row manager");
my $h = $con->handle('example');
my $row = $h->insert({name => 'a'});
subtest save_updates_row_state => sub {
$row->update({name => 'b'});
t/AI/handle/upsert.t view on Meta::CPAN
my $dir = tempdir(CLEANUP => 1);
my $dsn = "dbi:SQLite:dbname=$dir/upsert.sqlite";
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE tags (name TEXT NOT NULL PRIMARY KEY)');
$dbh->disconnect;
}
my $con = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $h = $con->handle('tags');
subtest insert_case => sub {
my $row = $h->upsert({name => 'perl'});
ok($row, "pk-only upsert returned a row when inserting");
is($row->field('name'), 'perl', "row carries the inserted key");
is($h->count, 1, "one row in the table");
};
subtest conflict_case => sub {
t/AI/handle/upsert.t view on Meta::CPAN
is($h->count, 1, "still one row in the table");
};
subtest mixed_still_updates => sub {
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE example (id INTEGER PRIMARY KEY, name TEXT)');
$dbh->disconnect;
}
my $con2 = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $h2 = $con2->handle('example');
my $row = $h2->upsert({id => 1, name => 'a'});
is($row->field('name'), 'a', "upsert with non-key fields inserts them");
my $row2 = $h2->upsert({id => 1, name => 'b'});
is($row2->field('name'), 'b', "upsert with non-key fields still updates on conflict");
is($h2->count, 1, "no duplicate row");
};
subtest literal_value_containing_returning => sub {
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE phrases (id INTEGER PRIMARY KEY, note TEXT)');
$dbh->disconnect;
}
my $con2 = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $h2 = $con2->handle('phrases');
my $row;
ok(
lives { $row = $h2->upsert({id => 1, note => \"'contains returning token'"}) },
"upsert keeps the RETURNING clause separate from a literal value containing the word",
) or note $@;
is($row->field('id'), 1, "upsert returned the row primary key");
is($h2->by_id(1)->field('note'), 'contains returning token', "literal value was written intact");
t/AI/handle/upsert.t view on Meta::CPAN
# On a dialect with no RETURNING-on-insert support the built statement has
# no RETURNING clause, so a literal write value containing the word
# "returning" must not be mistaken for one and split. Exercise qorm_upsert
# directly since the SQLite Handle path always requests RETURNING.
{
my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
$dbh->do('CREATE TABLE lit (id INTEGER PRIMARY KEY, note TEXT)');
$dbh->disconnect;
}
my $con2 = DBIx::QuickORM->quick(credentials => {dsn => $dsn});
my $h2 = $con2->handle('lit');
my $sb = $h2->sql_builder;
my $sql = $sb->qorm_upsert(
source => $h2->source,
dialect => $con2->dialect,
insert => {id => 1, note => \"'x returning y'"},
);
like(
$sql->{statement},
( run in 1.041 second using v1.01-cache-2.11-cpan-f4a522933cf )