view release on metacpan or  search on metacpan

lib/DB/Handy.pm  view on Meta::CPAN

            @rows = @d;
        }
        elsif ($sep eq 'INTERSECT_ALL') {
            # INTERSECT ALL: keep rows present in both (with multiplicity)
            my %rhs_cnt;
            for my $row (@rhs) { $rhs_cnt{$_key->($row)}++ }
            my %used; my @d;
            for my $row (@rows) {
                my $k = $_key->($row);
                if (($rhs_cnt{$k} || 0) > ($used{$k} || 0)) {
                    push @d, $row;
                    $used{$k}++;
                }
            }
            @rows = @d;
        }
        elsif ($sep eq 'EXCEPT') {
            # EXCEPT: remove rows that appear in rhs (deduplicated)
            my %in_rhs;
            for my $row (@rhs) { $in_rhs{$_key->($row)} = 1 }
            my %seen; my @d;
            for my $row (@rows) {
                my $k = $_key->($row);
                push @d, $row if !$in_rhs{$k} && !$seen{$k}++;
            }
            @rows = @d;
        }
        elsif ($sep eq 'EXCEPT_ALL') {
            # EXCEPT ALL: remove rows with multiplicity
            my %rhs_cnt;
            for my $row (@rhs) { $rhs_cnt{$_key->($row)}++ }
            my %removed; my @d;
            for my $row (@rows) {
                my $k = $_key->($row);
                if (($rhs_cnt{$k} || 0) > ($removed{$k} || 0)) {
                    $removed{$k}++;
                }
                else {
                    push @d, $row;
                }
            }
            @rows = @d;
        }
    }
    return { type=>'rows', data=>[ @rows ] };
}

# =============================================================================
# UPDATE with expression SET
# =============================================================================
sub parse_set_exprs {
    my($str) = @_;
    my %set;
    for my $part (args($str)) {
        $part =~ s/^\s+|\s+$//g;
        $set{$1} = $2 if $part =~ /^(\w+)\s*=\s*(.+)$/;
    }
    return %set;
}

sub update {
    my($self, $table, $set_exprs, $ws) = @_;
    return $self->_err("No database selected") unless $self->{db_name};
    my $sch = $self->_load_schema($table) or return undef;
    my $dat = $self->_file($table, 'dat');
    my $rs  = $sch->{recsize};
    my $n   = 0;
    local *FH;
    open(FH, "+< $dat") or return $self->_err("Cannot open dat: $!");
    binmode FH;
    _lock_ex(\*FH);
    seek(FH, 0, 0);
    my $pos = 0;
    my $rno = 0;
    while (1) {
        seek(FH, $pos, 0);
        my $raw = '';
        my $x   = read(FH, $raw, $rs);
        last unless defined($x) && ($x == $rs);
        if (substr($raw, 0, 1) ne RECORD_DELETED) {
            my $row = $self->_unpack_record($sch, $raw);
            if (!$ws || $ws->($row)) {
                my %old;
                for my $ix (values %{$sch->{indexes}}) {
                    $old{$ix->{name}} = $row->{$ix->{col}}
                }
                my %orig = %$row;
                $row->{$_} = eval_expr($set_exprs->{$_}, { %orig }) for keys %$set_exprs;
                for my $ix (values %{$sch->{indexes}}) {
                    next unless $ix->{unique} && exists $set_exprs->{$ix->{col}};
                    my $nv = $row->{$ix->{col}};
                    my $ep = $self->_idx_lookup_exact($table, $ix, $nv);
                    if ($ep >= 0) {
                        my $ef = $self->_idx_file($table, $ix->{name});
                        my $es = $ix->{keysize} + REC_NO_SIZE;
                        local *IF_FH;
                        open(IF_FH, "< $ef") or next;
                        binmode IF_FH;
                        seek(IF_FH, IDX_MAGIC_LEN + $ep * $es + $ix->{keysize}, 0);
                        my $rn = '';
                        read(IF_FH, $rn, REC_NO_SIZE);
                        close IF_FH;
                        if (unpack('N', $rn) != $rno) {
                            _unlock(\*FH);
                            close FH;
                            return $self->_err("UNIQUE constraint violated on '$ix->{name}'");
                        }
                    }
                }

                # NOT NULL constraint check on UPDATE
                for my $cn (keys %{$sch->{notnull} || {}}) {
                    next unless exists $set_exprs->{$cn};
                    unless (defined($row->{$cn}) && ($row->{$cn} ne '')) {
                        _unlock(\*FH);
                        close FH;
                        return $self->_err("NOT NULL constraint violated on column '$cn'");
                    }
                }
                # CHECK constraint check on UPDATE
                for my $cn (keys %{$sch->{checks} || {}}) {