view release on metacpan or  search on metacpan

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

        my ($dbh, $sth) = @_;
        my $source = $self->{+SOURCE};

        if ($rows) {
            $con->state_delete_row(source => $source, fetched => $_) for @$rows;
            return;
        }

        if ($row) {
            $con->state_delete_row(source => $source, row => $row);
            return;
        }

        if ($has_ret) {
            while (my $r = $sth->fetchrow_hashref) {
                $con->state_delete_row(source => $source, fetched => $r);
            }

            return;
        }

        confess "This error should be unreachable, please report it along with this dump:\n==== start ====\n" . debug($self) . "\n==== stop ====\n";
    };

    my $sth;
    if ($has_ret || $row) {
        # A forked write maintains the parent cache in the parent at reap (via
        # on_finish) using the bound row's data; it cannot stream RETURNING rows
        # back through this path, so a bulk forked delete needs a bound row.
        croak "Cannot do a forked delete without a specific row to delete"
            if $self->is_forked && !$row;

        $sth = $self->_make_sth(
            $sql,
            (($self->is_forked && $row) ? (on_finish => $finish) : (on_ready => $finish)),
            no_rows => 1,
        );
    }
    else {
        croak "Cannot do an async delete without a specific row to delete on a database that does not support 'returning on delete'" unless $sync;

        $self->_internal_txn(
            sub {
                my $row_sql = $self->sql_builder->qorm_select(%$builder_args, fields => $has_pk);
                my ($row_sth, $row_res) = $self->_execute($self->{+CONNECTION}->dbh, $row_sql);
                $rows = $row_sth->fetchall_arrayref({});
                $sth = $self->_make_sth($sql, on_ready => $finish, no_rows => 1);
            },
            die => "Cannot delete without a specific row on a database that does not support 'returning on delete' when internal transactions are disabled",
        );
    }

    return $sth unless $sync;

    $finish->($sth->dbh, $sth->sth);

    return undef;
}

sub update {
    my $changes;
    my $self = shift->_row_or_hashref(sub {$changes = pop; $_[0]}, @_);

    my $con = $self->{+CONNECTION};
    $con->pid_and_async_check;

    croak "update() with data_only set is not currently supported"        if $self->{+DATA_ONLY};
    croak "update() with a 'limit' clause is not currently supported"     if defined $self->{+LIMIT};
    croak "update() with an 'offset' clause is not currently supported"   if defined $self->{+OFFSET};
    croak "update() with an 'order_by' clause is not currently supported" if $self->{+ORDER_BY};
    croak "update() with a 'group_by' clause is not currently supported"  if $self->{+GROUP_BY};
    croak "update() with a 'having' clause is not currently supported"    if $self->{+HAVING};
    croak "update() with distinct set is not currently supported"         if $self->{+DISTINCT};

    # A bound row normally provides the WHERE clause via its primary key. With
    # no primary key there is no WHERE at all and the update would hit every
    # row in the table.
    croak "Cannot update a row bound to a handle when its table has no primary key (no WHERE clause can be derived)"
        if $self->{+ROW} && !$self->_has_pk;

    my $row = $self->{+ROW};
    if ($changes) {
        if ($row) {
            if (my $pending = $row->pending_data) {
                croak "Attempt to update row with pending changes and additional changes"
                    if $changes && $pending && keys(%$changes) && keys(%$pending);
            }
        }
    }
    elsif ($row) {
        $changes = $row->pending_data;
    }

    croak "No changes for update"                    unless $changes;
    croak "Changes must be a hashref (got $changes)" unless ref($changes) eq 'HASH';

    my $sync              = $self->is_sync;
    my $dialect           = $self->dialect;
    my $pk_fields         = $self->_has_pk;
    my $builder_args      = $self->_builder_args;
    my $source            = $self->{+SOURCE};

    # Drop database-generated columns from the update set; the database will
    # reject any explicit write, and they cannot end up as legitimate pending
    # data (the row layer croaks if a setter targets one), so silently
    # filtering keeps the contract symmetric with insert/upsert.
    $changes = { map { $_ => $changes->{$_} } grep { !$source->field_is_generated($_) } keys %$changes };

    croak "Changes may not be empty" unless keys %$changes;
    my $do_cache          = $pk_fields && @$pk_fields && $con->state_does_cache;
    my $changes_pk_fields = $pk_fields ? (grep { exists $changes->{$_} } @$pk_fields) : ();

    # Literal SQL write values (\'NOW()', [\'expr ?', @binds]) are computed by the
    # database, so the cached row takes their value from the database: via
    # UPDATE ... RETURNING when the dialect supports it (no extra round trip),
    # otherwise via a refresh.
    my @literal_fields    = grep { literal_write_value($changes->{$_}) } keys %$changes;
    my $literal_returning = @literal_fields && $row && $sync && $pk_fields && @$pk_fields && $dialect->supports_returning_update;
    if ($literal_returning) {
        my %seen;