DBIx-QuickORM

 view release on metacpan or  search on metacpan

worktrees/dbic-compat-native-features/lib/DBIx/QuickORM/Connection.pm  view on Meta::CPAN

package DBIx::QuickORM::Connection;
use strict;
use warnings;

our $VERSION = '0.000028';

use Carp qw/confess croak carp/;
use Scalar::Util qw/blessed weaken/;
use DBIx::QuickORM::Util qw/load_class/;

use DBIx::QuickORM::Handle;
use DBIx::QuickORM::Connection::Transaction;

use Object::HashBase qw{
    <orm
    <dbh
    <dialect
    <pid
    <schema
    <transactions
    +_savepoint_counter
    +_txn_counter
    <manager
    <in_async
    <asides
    <forks
    <default_sql_builder
    <default_internal_txn
    <default_handle_class
};

=pod

=encoding UTF-8

=head1 NAME

DBIx::QuickORM::Connection - ORM connection to database.

=head1 DESCRIPTION

This module is the primary interface when using the ORM to connect to a
database. This contains the database connection itself, a clone of the original
schema along with any connection specific changes (temp tables, etc). You use
this class to interact with the database, manage transactions, and get
L<DBIx::QuickORM::Handle> objects that can be used to make queries against the
database.

=head1 SYNOPSIS

    use My::Orm qw/orm/;

    # Get the orm's connection.
    # Note: This will return the same connection each time, no need to cache it yourself.
    my $con = orm('my_orm')->connection;

    # Do something to all rows in the 'people' table.
    my $people_handle = $con->handle('people');
    for my $person ($people_handle->all) {
        ...
    }

    # Find all people with the surname 'smith' and print their first names.
    my $smith_handle = $people_handle->where({surname => 'smith'});
    for my $person ($smith_handle->all) {
        print $person->field('first_name') . "\n";
    }

worktrees/dbic-compat-native-features/lib/DBIx/QuickORM/Connection.pm  view on Meta::CPAN

=head1 PUBLIC METHODS

=over 4

=item $con->init

Object construction hook invoked by L<Object::HashBase>. Establishes the
database handle, dialect, schema, and row manager. Not called directly.

=cut

sub init {
    my $self = shift;

    my $orm = $self->{+ORM} or croak "An orm is required";
    my $db = $orm->db;

    $self->{+_SAVEPOINT_COUNTER} //= 1;
    $self->{+_TXN_COUNTER} //= 1;

    $self->{+PID} = $$;

    $self->{+DBH} = $db->new_dbh;

    $self->{+DIALECT} = $self->_build_dialect;

    $self->{+DEFAULT_INTERNAL_TXN} //= 1;

    $self->{+ASIDES} = {};
    $self->{+FORKS}  = {};

    $self->{+DEFAULT_HANDLE_CLASS} //= $orm->default_handle_class // 'DBIx::QuickORM::Handle';

    $self->{+DEFAULT_SQL_BUILDER} //= do {
        require DBIx::QuickORM::SQLBuilder::SQLAbstract;
        # Quote identifiers so attacker-influenceable names (order_by, where
        # keys, field and returning lists) cannot break out of their identifier
        # slot into raw SQL. Without quote_char SQL::Abstract emits identifiers
        # verbatim, and field_db_name() passes unknown names through unchanged,
        # which together allow SQL injection at any identifier position. The
        # quote char comes from the live driver (SQL_IDENTIFIER_QUOTE_CHAR) so
        # it is correct per-dialect (double-quote for SQLite/Postgres, backtick
        # for MySQL); fall back to the ANSI double-quote when the driver reports
        # nothing usable (a single space means quoting is unsupported).
        my $qc = eval { $self->dbh->get_info(29) };
        $qc = '"' unless defined($qc) && $qc =~ /\S/;
        DBIx::QuickORM::SQLBuilder::SQLAbstract->new(quote_char => $qc, name_sep => '.');
    };

    my $txns = $self->{+TRANSACTIONS} = [];
    my $manager = $self->{+MANAGER} // 'DBIx::QuickORM::RowManager::Cached';
    if (blessed($manager)) {
        croak "Manager '$manager' does not subclass 'DBIx::QuickORM::RowManager'"
            unless $manager->DOES('DBIx::QuickORM::RowManager');

        $manager->set_connection($self);

        # The HashBase setter stores a strong reference, which would create a
        # connection <-> manager cycle; the manager holds its connection weakly.
        weaken($manager->{DBIx::QuickORM::RowManager::CONNECTION()});

        $manager->set_transactions($txns);
    }
    else {
        my $class = load_class($manager) or die $@;
        $self->{+MANAGER} = $class->new(transactions => $txns, connection => $self);
    }

    if (my $autofill = $orm->autofill) {
        my $schema = $self->{+DIALECT}->build_schema_from_db(autofill => $autofill);

        if (my $schema2 = $orm->schema) {
            $self->{+SCHEMA} = $schema->merge($schema2);
        }
        else {
            $self->{+SCHEMA} = $schema->clone;
        }
    }
    else {
        $self->{+SCHEMA} = $orm->schema->clone;
    }
}

########################
# {{{ Async/Aside/Fork #
########################

=pod

=item $con->set_async($async)

Change state to be inside an async query, argument must be an
L<DBIx::QuickORM::STH::Async> instance.

=item $con->add_aside($aside)

Register an "aside" query.

=item $con->add_fork($fork)

Register a "forked" query.

=item $con->clear_async($async)

Change state to be outside of an async query. The argument must be an
L<DBIx::QuickORM::STH::Async> instance, and it must be the same object as the
one returned by C<in_async()>.

=item $con->clear_aside($aside)

Clear a previously registered "aside" query.

=item $con->clear_fork($fork)

Clear a previously registered "forked" query.

=cut

sub set_async {
    my $self = shift;
    my ($async) = @_;

    croak "There is already an async query in progress" if $self->{+IN_ASYNC} && !$self->{+IN_ASYNC}->done;

    $self->{+IN_ASYNC} = $async;
    weaken($self->{+IN_ASYNC});

    return $async;
}

sub add_aside {
    my $self = shift;
    my ($aside) = @_;

    $self->{+ASIDES}->{$aside} = $aside;
    weaken($self->{+ASIDES}->{$aside});

    return $aside;
}

sub add_fork {
    my $self = shift;
    my ($fork) = @_;

    $self->{+FORKS}->{$fork} = $fork;
    weaken($self->{+FORKS}->{$fork});

    return $fork;
}

sub clear_async {
    my $self = shift;
    my ($async) = @_;

    croak "Not currently running an async query" unless $self->{+IN_ASYNC};

    croak "Mismatch, we are in an async query, but not the one we are trying to clear"
        unless $async == $self->{+IN_ASYNC};

    delete $self->{+IN_ASYNC};
}

sub clear_aside {
    my $self = shift;
    my ($aside) = @_;

    croak "Not currently running that aside query" unless $self->{+ASIDES}->{$aside};

    delete $self->{+ASIDES}->{$aside};
}

sub clear_fork {
    my $self = shift;
    my ($fork) = @_;

    croak "Not currently running that fork query" unless $self->{+FORKS}->{$fork};

    delete $self->{+FORKS}->{$fork};
}

########################
# }}} Async/Aside/Fork #
########################

#####################
# {{{ SANITY CHECKS #
#####################

=pod

=item $con->pid_and_async_check

Throws an exception if the PID does not match, or if there is an async query
running.

=item $con->pid_check

Throws an exception if the current PID does not match the connection's PID.

=item $con->async_check

Throws an exception if there is an async query running.

=cut

sub pid_and_async_check {

worktrees/dbic-compat-native-features/lib/DBIx/QuickORM/Connection.pm  view on Meta::CPAN

        ignore_aside => $BOOL, # Allow a transaction even if an aside query is active
        ignore_forks => $BOOL, # Allow a transaction even if a forked query is active

        # Things to run at the end of the transaction.
        on_fail       => sub { ... }, # Only runs if the txn is rolled back
        on_success    => sub { ... }, # Only runs if the txn is committed
        on_completion => sub { ... }, # Runs when the txn is done regardless of status.

        # Same as above, except you are adding them to a direct parent txn (if one exists, otherwise they are no-ops)
        on_parent_fail       => sub { ... },
        on_parent_success    => sub { ... },
        on_parent_completion => sub { ... },

        # Same as above, except they are applied to the root transaction, no
        # matter how deeply nested it is.
        on_root_fail       => sub { ... },
        on_root_success    => sub { ... },
        on_root_completion => sub { ... },
    );

An L<DBIx::QuickORM::Connection::Transaction> instance is always returned. If
an action callback was provided then the instance will already be complete, but
you can check and see what the status was. If you did not provide an action
callback then the txn will be "live" and you can use the instance to commit it
or roll it back.

=cut

{
    no warnings 'once';
    *transaction = \&txn;
}
sub txn {
    my $self = shift;
    $self->pid_check;

    my @caller = caller;

    my $cb = (@_ && ref($_[0]) eq 'CODE') ? shift : undef;
    my %params = @_;
    $cb //= $params{action};

    $self->_txn_guards(\%params);

    my $txns = $self->{+TRANSACTIONS};

    my $sp = $self->_txn_begin;

    my $txn = DBIx::QuickORM::Connection::Transaction->new(
        id            => $self->{+_TXN_COUNTER}++,
        savepoint     => $sp,
        trace         => \@caller,
        on_fail       => $params{on_fail},
        on_success    => $params{on_success},
        on_completion => $params{on_completion},
    );

    $self->_txn_attach_relative_callbacks($txn, \%params);

    push @{$txns} => $txn;
    weaken($txns->[-1]);

    my $finalize = $self->_txn_finalizer($sp);

    unless($cb) {
        $txn->set_no_last(1);
        $txn->set_finalize($finalize);
        return $txn;
    }

    local $@;
    my $ok = eval {
        QORM_TRANSACTION: { $cb->($txn) };
        1;
    };

    # The body threw - record the exception that forced the rollback.
    $txn->set_exception($@) unless $ok;

    $finalize->($txn, $ok, $@);

    return $txn;
}

=pod

=item $bool_or_txn = $con->in_transaction

=item $bool_or_txn = $con->in_txn

Returns true if there is a transaction active. If the transaction is managed by
L<DBIx::QuickORM> then the L<DBIx::QuickORM::Connection::Transaction> object
will be returned.

=cut

{
    no warnings 'once';
    *in_transaction = \&in_txn;
}
sub in_txn {
    my $self = shift;
    return $self->current_txn // $self->dialect->in_txn;
}

=pod

=item $txn = $con->current_transaction

=item $txn = $con->current_txn

Return the current L<DBIx::QuickORM::Connection::Transaction> if one is active.

B<Note:> Do not use this to check for a transaction, it will return false if
there is a transaction that is not managed by L<DBIx::QuickORM>.

=cut

{
    no warnings 'once';
    *current_transaction = \&current_txn;