view release on metacpan or  search on metacpan

DBIx/DBStag.pm  view on Meta::CPAN

sub cached_tables {
    my $self = shift;
    $self->{_cached_tables} = shift if @_;
    return $self->{_cached_tables};
}

sub is_caching_on {
    my $self = shift;
    my $element  = shift;
    $self->{_is_caching_on} = {}
      unless $self->{_is_caching_on};
    if (@_) {
        $self->{_is_caching_on}->{$element} = shift;
    }
    return $self->{_is_caching_on}->{$element};
}

sub query_cache {
    my $self = shift;
    my $element = shift;
    my $constr = shift;
    my $update_h = shift;
    my @keycols = sort keys %$constr;
    my $cache = $self->get_tuple_idx($element, \@keycols);
    my $valstr = join("\t", map {$constr->{$_}} @keycols);
#    use Data::Dumper;
#    print Dumper $cache;
    if ($update_h) {
        my $current_h = $cache->{$valstr} || {};
        $current_h->{$_} = $update_h->{$_} foreach keys %$update_h;
        $cache->{$valstr} = $current_h;
    }
    return $cache->{$valstr};
}

sub insert_into_cache {
    my $self = shift;
    my $element = shift;
    my $insert_h = shift;
    my $usets = shift;
    foreach my $uset (@$usets) {
        my @undef = grep {!defined $insert_h->{$_}} @$uset;
        if (@undef) {
            my @defined = grep {defined $insert_h->{$_}} @$uset;
            trace(1, 
                  "undefined column in unique key: @$uset IN $element/[@$uset] ".
                  join('; ', 
                       map {"$_=$insert_h->{$_}"} @defined,
                      )
                 ) if $TRACE;
            # cannot cache undefined values
            next;
        }
        my $cache = $self->get_tuple_idx($element, $uset);
        my $valstr = join("\t", map {$insert_h->{$_}} sort @$uset);
        $cache->{$valstr} = $insert_h;
    }
    return 1;
}

sub update_cache {
    my $self = shift;
    my $element = shift;
    my $store_hash = shift;
    my $unique_constr = shift;

    my $tuple = $self->query_cache($element,
                                   $unique_constr,
                                   $store_hash);
    return;
}

sub get_tuple_idx {
    my $self = shift;
    my $element = shift;
    my $ukey = shift;
    my @keycols = @$ukey;
    @keycols = sort @keycols;
    @keycols || die;

    my $cache = $self->cache;
    if (!$cache->{$element}) {
        $cache->{$element} = {};
    }
    my $eltcache = $cache->{$element};
    # we just use a flat perl hash - flatten the list of unique cols
    # to a string with spaces between
    my $k = "@keycols";
    if (!$eltcache->{$k}) {
        $eltcache->{$k} = {};
    }
    
    return $eltcache->{$k};    
}

sub cache_summary {
    my $self = shift;
    my $s = Data::Stag->new(cache_summary=>[]);
    my $cache = $self->cache || {};
    my @elts = keys %$cache;
    foreach my $elt (@elts) {
        my $cnode = $cache->{$elt} || {};
        my @keys = keys %$cnode;
        $s->add($elt=>[map {[$_=>scalar(keys %{$cnode->{$_}})]} @keys]);
    }
    return $s;
}

sub cache {
    my $self = shift;
    $self->{_cache} = shift if @_;
    $self->{_cache} = {} unless $self->{_cache};
    return $self->{_cache};
}

sub clear_cache {
    my $self = shift;
    $self->cache({});
}

# ---- END OF CACHE METHODS ----

DBIx/DBStag.pm  view on Meta::CPAN

              join(", ", @cols),
              #join(", ", @vals),
              join(", ", @placeholders),
             );
    if (!@cols) {
	$sql = "INSERT INTO $table DEFAULT VALUES";
    }

    trace(0, "SQL:$sql") if $TRACE;
    my $succeeded = 0;
    eval {
        my $sth = $self->dbh->prepare($sql);
        my $rval = $sth->execute(@vals);
        $succeeded = 1 if defined $rval;
    };
    if ($@) {
	if ($self->force) {
	    # what about transactions??
	    $self->warn("IN SQL: $sql\nWARNING: $@\n");
            return;
	}
	else {
	    confess $@;
	}
    }
    return unless $succeeded;
    my $pkval;
    if ($pkcol) {
        # primary key value may have been specified in the xml
        # (this is necessary for non-surrogate pks in tables that
        #  are to be linked to via foreign keys)
        $pkval = $colvalh->{$pkcol};

        # pk was not supplied - perhaps this is a SERIAL/AUTO_INCREMENT
        # column (ie surrogate integer primary key)
        if (!$pkval) {
            # assume pk is a SERIAL / AUTO_INCREMENT
            if ($driver eq 'Pg') {
                my $seqn = sprintf("%s_%s_seq",
                                   $table,
                                   $pkcol);
                $pkval  = $self->selectval("select currval('$seqn')");        
                trace(0, "CURRVAL $seqn = $pkval     [Pg]") if $TRACE;
            }
            # this doesn't work on older
            # versions of DBI/DBD::mysql
            # seems to have been fixed Oct 2004 release
            elsif ($driver eq 'mysql') {
                $pkval = $self->dbh->last_insert_id(undef,undef,$table,$pkcol);
                trace(0, "CURRVAL mysql_insert_id $pkval   [mysql]") if $TRACE;
            }
            else {
                $pkval  = $self->selectval("select max($pkcol) from $table");
            }
        }
        trace(0, "PKVAL = $pkval") if $TRACE;
    }
    return $pkval;
}

sub updaterow {
    my $self = shift;
    my ($table, $set, $where) = @_;

    confess("must specify table") unless $table;

    my $dbh = $self->dbh;

    # array of WHERE cols
    if (ref($where)) {
        if (ref($where) eq "HASH") {
            $where =
              [
               map {
                   "$_ = ".$dbh->quote($where->{$_})
               } keys %$where
              ];
        }
    }
    else {
        $where = [$where];
    }
    confess("must specify constraints") unless @$where;

    confess("must set update vals") unless $set;
    my @bind = ();
    # array of SET colvals
    if (ref($set)) {
        if (ref($set) eq "HASH") {
            $set =
              [
               map {
                   push(@bind, defined $set->{$_} ? $set->{$_} : 'NULL');
                   "$_ = ?"
               } keys %$set
              ];
        }
    }
    else {
        $set = [$set];
    }
    
    my $sql =
      sprintf("UPDATE %s SET %s WHERE %s",
              $table,
              join(', ', @$set),
              join(' AND ', @$where),
             );
    trace(0, "SQL:$sql [",join(', ',@bind)."]") if $TRACE;

    my $sth = $dbh->prepare($sql) || confess($sql."\n\t".$dbh->errstr);
    return $sth->execute(@bind) || confess($sql."\n\t".$sth->errstr);
}

sub deleterow {
    my $self = shift;
    my ($table, $where) = @_;

    confess("must specify table") unless $table;

    my $dbh = $self->dbh;