DBIx-QuickORM

 view release on metacpan or  search on metacpan

worktrees/audit-fixes-master/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/audit-fixes-master/lib/DBIx/QuickORM/Connection.pm  view on Meta::CPAN

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

        # A blessed manager instance carries per-connection state (its connection
        # and transaction stack). If it is still the live manager of a different,
        # still-connected connection, rebinding it here would silently repoint
        # that connection's row cache and transaction stack at us, so refuse. A
        # manager whose previous connection has been disconnected is free to
        # rebind: disconnecting the old connection first is the supported way to
        # move a blessed manager to a new connection.
        if (my $other = $manager->connection) {
            croak "This row_manager instance is already in use by another live connection; one row_manager cannot be shared across connections. Pass a class name (each connection builds its own manager), pass a fresh instance per connection, or disco...
                if $other != $self && $other->manager && $other->manager == $manager && $other->connected;
        }

        $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) {
        # Tables asserted to have no volatile columns (so the introspection
        # trigger warning is silenced): the autofill/quick assertion plus any
        # table the declared schema marked no_volatile.
        my %no_volatile;
        if (my $nv = $autofill->no_volatile) {
            if (ref($nv) eq 'ARRAY') { $no_volatile{$_} = 1 for @$nv }
            else                     { $no_volatile{'*'} = 1 }
        }
        if (my $schema2 = $orm->schema) {
            for my $tbl ($schema2->tables) {
                $no_volatile{$tbl->name} = 1 if $tbl->can('no_volatile') && $tbl->no_volatile;
            }
        }

        my $schema = $self->{+DIALECT}->build_schema_from_db(autofill => $autofill, no_volatile => \%no_volatile);

        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) = @_;

    # A reconnect drops the async registry; a handle that survived it (it ran on
    # the now-dead handle) can still try to clear itself as it finalizes. Treat a
    # missing or mismatched entry as an already-cleared no-op rather than an error.
    my $current = $self->{+IN_ASYNC} or return;
    return unless $async == $current;

    delete $self->{+IN_ASYNC};
}

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

    # A reconnect drops the aside registry; a surviving handle can still clear
    # itself as it finalizes, so a missing entry is an already-cleared no-op.
    return unless $self->{+ASIDES}->{$aside};

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

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

    # A reconnect drops the fork registry; a surviving handle can still clear
    # itself as it finalizes, so a missing entry is an already-cleared no-op.
    return 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

worktrees/audit-fixes-master/lib/DBIx/QuickORM/Connection.pm  view on Meta::CPAN

        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}++,
        connection    => $self,
        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;
    };
    my $err = $@;

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

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

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