File Coverage

blib/lib/DBIx/MoCo.pm

Criterion	Covered	Total	%
statement	523	573	91.2
branch	211	312	67.6
condition	43	83	51.8
subroutine	85	89	95.5
pod	30	53	56.6
total	892	1110	80.3

package DBIx::MoCo;
use strict;
use warnings;
use base qw (Class::Data::Inheritable);

use DBIx::MoCo::Relation;
use DBIx::MoCo::List;
use DBIx::MoCo::Cache;
use DBIx::MoCo::Cache::Dummy;
use DBIx::MoCo::Schema;
use DBIx::MoCo::Column;

use Carp;
use Class::Trigger;
use Tie::IxHash;
use File::Spec;
use UNIVERSAL::require;

our $VERSION = '0.18';
our $AUTOLOAD;

my $cache_status = {
    retrieve_count        => 0,
    retrieve_cache_count  => 0,
    retrieve_icache_count => 0,
    retrieve_all_count    => 0,
    has_many_count        => 0,
    has_many_cache_count  => 0,
    has_many_icache_count => 0,
    retrieved_oids        => [],
};
my ($db,$session,$schema);

__PACKAGE__->mk_classdata($_) for
    qw(cache_object default_cache_expiration icache_expiration
       cache_null_object table cache_cols_only _db_object save_explicitly list_class);

## NOTE: INIT block does not work well under mod_perl or POE.
## Please set cache_object() explicitly if you want to use transparent caching.
# INIT {
#     unless (defined __PACKAGE__->cache_object) {
#         if (Cache::FastMmap->require) {
#             my $file = File::Spec->catfile('/tmp', __PACKAGE__);

#             File::Spec->require or die $@;
#             __PACKAGE__->cache_object(
#                 Cache::FastMmap->new(
#                     share_file     => $file,
#                     unlink_on_exit => 1,
#                     expire_time    => 600, # sec
#                 ) or die $!
#             );

#             chmod(0666, $file) or die $! if -e $file;
#         } else {
#             warn "Using DBIx::MoCo::Cache is now deprecated because of memory leak."
#                 . "Install Cache::FastMmap instead, or setup cache_object explicitly.";

#             DBIx::MoCo::Cache->require or die $@;
#             __PACKAGE__->cache_object( DBIx::MoCo::Cache->new );
#         }
#     }
# }

__PACKAGE__->default_cache_expiration(60 * 60 * 3); # 3 hours
__PACKAGE__->icache_expiration(0); # Instance cache
__PACKAGE__->cache_null_object(1);

# SESSION & CACHE CONTROLLERS
__PACKAGE__->add_trigger(after_create => sub {
    my ($class, $self) = @_;
    $self or confess '$self is not specified';
    $class->store_self_cache($self);
    $class->flush_belongs_to($self);
});
__PACKAGE__->add_trigger(before_update => sub {
    my ($class, $self) = @_;
    $self or confess '$self is not specified';
    $class->flush_self_cache($self);
});
__PACKAGE__->add_trigger(after_update => sub {
    my ($class, $self) = @_;
    $self or confess '$self is not specified';
    $class->store_self_cache($self);
});
__PACKAGE__->add_trigger(before_delete => sub {
    my ($class, $self) = @_;
    $self or confess '$self is not specified';
    $class->flush_self_cache($self);
    $class->flush_belongs_to($self);
});

sub cache_status { $cache_status }

sub cache {
    my $class = shift;
    $class = ref($class) if ref($class);

    ## It is no matter costs of creating Dummy objects because it is a singleton.
    my $cache = $class->cache_object || DBIx::MoCo::Cache::Dummy->instance;

    my ($k,$v,$ex) = @_;
    # warn "$cache in $class";
    my $s = $class->is_in_session;
    if (defined $v) {
        $ex ||= $class->default_cache_expiration;
        $ex = "+$ex" if ($ex && ref($cache) eq 'Cache::Memory');
        if ($v eq '') {
            if ($cache->can('remove')) {
                $cache->remove($k);
            }
            if ($s) {
                delete $s->{cache}->{$k} if $k;
            }
        } else {
            if ($class->cache_cols_only && ref($v) &&
                    ref($v) =~ /::/ && $v->isa($class)) {
                # remove additional elements
                my @cols = @{$v->columns};
                for (qw(changed_cols to_be_updated object_id)) {
                    push @cols, $_ if (defined $v->{$_});
                }
                my $hash = {map {$_ => $v->{$_}} @cols};
                my $o = bless $hash, $class;
                $cache->set($k,$o,$ex);
                $s->{cache}->{$k} = $o if $s;
            } else {
                $cache->set($k,$v,$ex);
                $s->{cache}->{$k} = $v if $s;
            }
        }
        # warn $cache . '->set(' . $k . ')';
        return $v;
    } elsif ($k) {
        # warn "hit session cache for $k" if ($s && $s->{cache}->{$k});
        return $s->{cache}->{$k} || $cache->get($k);
    }
}

sub flush_belongs_to {} # it's delivered from MoCo::Relation

sub flush_self_cache {
    my ($class, $self) = @_;
    if (!$self && ref $class) {
        $self = $class;
        $class = ref $self;
    }
    $self or confess '$self is not specified';

    return unless $class->cache_object;

    my $rm = $class->cache_object->can('remove') ? 'remove' : 'delete';
    for (@{$self->object_ids}) {
        # warn "flush $_";
        #weaken($class->cache($_));
        $class->cache_object->$rm($_);
    }
}

sub store_self_cache {
    my ($class, $self) = @_;
    if (!$self && ref $class) {
        $self = $class;
        $class = ref $self;
    }
    $self or confess '$self is not specified';
    # warn "store $_" for @{$self->object_ids};
    my $icache = $self->icache;
    $self->flush_icache;
    $class->cache($_, $self) for @{$self->object_ids};
    $self->icache($icache) if $icache;
}

sub icache {
    my $self = shift;
    if ($_[0]) {
        $self->{_icache} = shift;
    } else {
        my $ex = $self->icache_expiration;
        $ex > 0 or return;
        if (!$self->{_icache} ||
                ($self->{_icache}->{_created} + $ex < time())) {
            $self->{_icache} = {_created => time()};
        }
    }
    return $self->{_icache};
}

sub flush_icache {
    my $self = shift;
    $self->{_icache} or return;
    if ($_[0]) {
        # warn "flush icache $_[0] for " . $self;
        delete $self->{_icache}->{$_[0]};
    } else {
        $self->{_icache} = undef;
    }
}

sub has_many_keys_cache_name {
    my $self = shift;
    my $attr = shift or return;
    my $oid = $self->object_id or return;
    return sprintf('%s-%s_keys', $oid, $attr);
}

sub flush_has_many_keys {
    my $self = shift;
    my $attr = shift or return;
    # $self->flush($self->has_many_keys_name($attr));
    # $self->flush($self->has_many_max_offset_name($attr));
    my $key = $self->has_many_keys_cache_name($attr);
    $self->cache($key, '');
}

# session controllers
sub start_session {
    my $class = shift;
    $class->end_session if $class->is_in_session;
    $session = {
        changed_objects => [],
        cache => {},
        pid => $$,
        created => time(),
    };
}

sub is_in_session { $session }
sub session { $session }
sub session_cache {
    my $s = shift->session or return;
    return $s->{cache};
}

sub end_session {
    my $class = shift;
    $session or return;
    $class->save_changed;
    $cache_status->{retrieved_oids} = [];
    $session = undef;
}

sub save_changed {
    my $class = shift;
    $class->is_in_session or return;
    for (@{$class->session->{changed_objects}}) {
        $_ or next;
        $_->save;
    }
}

# CLASS DEFINISION METHODS
sub relation { 'DBIx::MoCo::Relation' }

sub db_object {
    my $class = shift;
    if (my $db = shift) {
        $class->_db_object($db);
    }
    $class->_db_object;
}

sub has_a {
    my $class = shift;
    $class->relation->register($class, 'has_a', @_);
}
sub has_many {
    my $class = shift;
    $class->relation->register($class, 'has_many', @_);
}

sub schema {
    my $class = shift;
    $class = ref $class if ref $class;
    unless ($schema->{$class}) {
        $schema->{$class} = DBIx::MoCo::Schema->new($class);
    }
    return $schema->{$class};
}

for my $attr (qw/primary_keys unique_keys retrieve_keys columns/) {
    my $classdata = "_" . $attr;
    __PACKAGE__->mk_classdata($classdata);

    no strict 'refs';
    *{__PACKAGE__ . "\::$attr"} = sub {
        my $class = shift;
        if (@_) {
            my @keys = (ref $_[0] and ref $_[0] eq 'ARRAY') ? @{$_[0]} : @_;
            $class->$classdata(\@keys);
        } else {
            $class->$classdata
                ? $class->$classdata
                : $class->schema->$attr;
        }
    };
}

sub has_muid {
    my $class = shift;
    return ($class->has_column('muid') &&
                scalar @{$class->primary_keys} == 1);
}

sub has_column {
    my $class = shift;
    my $col = shift or return;
    $class->columns or return;
    grep { $col eq $_ } @{$class->columns};
}

sub utf8_columns {
    my $class = shift;
    $class->schema->utf8_columns(@_);
}

sub is_utf8_column {
    my $class = shift;
    my $col = shift or return;
    my $utf8 = $class->utf8_columns or return;
    ref $utf8 eq 'ARRAY' or return;
    return grep { $_ eq $col } @$utf8;
}

# DATA OPERATIONAL METHODS
sub object_id {
    my $self = shift;
    my $class = ref($self) || $self;
    $self = undef unless ref($self);
    if ($self && $self->{object_id}) {
        return $self->{object_id};
    }
    my $prefix = $class->object_id_prefix || '';
    my ($key, $col);
    if ($self && @{$class->retrieve_keys || $class->primary_keys}) {
        if ($self->has_muid) {
            $key = $self->muid;
        } else {
            for (sort @{$class->retrieve_keys || $class->primary_keys}) {
                defined($self->{$_}) or warn "$_ is undefined for $self" and return;
                $key .= "-$_-" . $self->{$_};
            }
            $key or die "couldn't create object_id for " . $self;
            $key = $prefix . $key;
        }
    } elsif ($_[3]) {
        my %args = @_;
        $key .= "-$_-$args{$_}" for (sort keys %args);
        $key = $prefix . $key;
    } elsif (@{$class->primary_keys} == 1) {
        my @args = @_;
        $col = defined $args[1] ? $args[0] : $class->primary_keys->[0];
        my $value = defined $args[1] ? $args[1] : $args[0];
        if ($col eq 'muid') {
            $key = $value;
        } else {
            $key = $prefix . '-' . $col . '-' . $value;
        }
    }
    $self->{object_id} = $key if $self;;
    return $key;
}

sub object_id_prefix {
    my $class = shift;
    $class = ref $class if ref $class;
    return $class;
}

sub db { $_[0]->db_object }

sub retrieve {
    my $cs = $cache_status;
    $cs->{retrieve_count}++;
    my $class = shift;
    $_[0] or carp "Retrieve keys not found";
    my $oid = $class->object_id(@_);
    my $c = $class->cache($oid);
    if (defined $c) {
        # warn "use cache $oid";
        $cs->{retrieve_cache_count}++;
        return $c;
    } else {
        # warn "use db $oid";
        my $o = $class->retrieve_by_db(@_);
        if ($o) {
            $class->store_self_cache($o);
            push @{$cs->{retrieved_oids}}, $oid if $class->is_in_session;
        } else {
            # $class->cache($oid => $o) if $o;
            # cache null object for performance.
            $class->cache($oid => $o) if $class->cache_null_object;
        }
        return $o;
    }
}

sub retrieve_by_db {
    my $class = shift;
    my %args = defined $_[1] ? @_ : ($class->primary_keys->[0] => $_[0]);
    my $res = $class->db->select($class->table,'*',\%args);
    my $h = $res->[0];
    return $h ? $class->new(%$h) : '';
}

sub restore_from_db {
    my $self = shift;
    my $class = ref $self or return;
    my $hash = $self->primary_keys_hash or return;
    my $res = $class->db->select($class->table,'*',$hash);
    my $h = $res->[0] or return;
    @{$self}{keys %$h} = @{$h}{keys %$h};
    $class->store_self_cache($self);
    return $self;
}

sub retrieve_multi {
    my $class = shift;
    my @list = @_ or return $class->_list([]);

    my (@cached_objects, @non_cached_queries);
    if ($class->cache_object && $class->cache_object->can('get_multi')) {
        my $ids = [ map { $class->object_id(%$_) } @list ];
        my $hash = $class->cache_object->get_multi(@$ids) || {};

        for (my $i = 0; $i <= $#list; $i++) {
            my $object = $hash->{$ids->[$i]};
            $object
                ? push @cached_objects, $object
                : push @non_cached_queries, $list[$i];
        }
    } else {
        for (@list) {
            my $cached_object = $class->cache( $class->object_id(%$_) );
            $cached_object
                ? push @cached_objects, $cached_object
                : push @non_cached_queries, $_;
        }
    }

    ## Updating cache status
    $class->cache_status->{retrieve_count} += scalar @list;
    $class->cache_status->{retrieve_cache_count} += scalar @cached_objects;

    ## All objects were found in cache.
    if (@cached_objects == @list) {
        my @ordered= $class->_merge_objects(\@list, @cached_objects);
        wantarray ? return @ordered : return $class->_list(\@ordered);
    }

    my (@clauses, @bind_values);
    for my $cond (@non_cached_queries) {
        my $subclause = join ' AND ', map {
            push @bind_values, $cond->{$_};
            sprintf "%s = ?", $_
        } keys %$cond;

        push @clauses, $subclause;
    }
    my $where_clause = join ' OR ', map { sprintf "(%s)", $_ } @clauses;

    my @objects_from_db = $class->search( where => [ $where_clause, @bind_values ] );

    if ($class->is_in_session) {
        push @{$class->cache_status->{retrieved_oids}}, map { $_->object_id } @objects_from_db;
    }

    for my $object (@objects_from_db) {
        $class->store_self_cache($object);
    }

    my @merged = $class->_merge_objects(\@list, @cached_objects, @objects_from_db);
    wantarray ? return @merged : return $class->_list(\@merged);
}

sub _merge_objects {
    my $class = shift;
    my $order = shift;

    my $tied = tie my %idt, 'Tie::IxHash'; ## orderd Hash
    $tied->Push($class->object_id( %$_ ) => undef) for @$order;

    for (@_) {
        my $id = $_->object_id;
        die "assert" if not exists $idt{$id};
        $tied->Push($id => $_);
    }

## cache_null_object() is now deprecated
#     for (keys %idt) {
#         if (not $idt{$_} and $class->cache_null_object) {
#             $class->cache( $_ => '' );
#         }
#     }

    grep { defined $_ } values %idt;
}

sub retrieve_or_create {
    my $class = shift;
    my %args = @_;
    my %keys;
    @keys{@{$class->primary_keys}} = @args{@{$class->primary_keys}};
    $class->retrieve(%keys) || $class->create(%args);
}

sub retrieve_all {
    my $cs = $cache_status;
    $cs->{retrieve_all_count}++;
    my $class = shift;
    my %args = @_;
    my $result = [];
    my $list = $class->retrieve_all_id_hash(%args);
    push @$result, $class->retrieve(%$_) for (@$list);
    wantarray ? @$result :
        $class->_list($result);
}

sub retrieve_all_id_hash {
    my $class = shift;
    my %args = @_;
    $args{table} = $class->table;
    $args{field} = join(',', @{$class->retrieve_keys || $class->primary_keys});
    my $res = $class->db->search(%args);
    return $res;
}

sub create {
    my $class = shift;
    my %args = @_;
    $class->call_trigger('before_create', \%args);
    my $o = $class->new(%args);
#     if ($class->is_in_session && $o->has_primary_keys) {
#         $o->set(to_be_inserted => 1);
#         $o->changed_cols->{$_}++ for (keys %args);
#         push @{$class->session->{changed_objects}}, $o;
#     } else {
    if ($class->save_explicitly) {
        $o->set(to_be_inserted => 1);
        $o->changed_cols->{$_}++ for keys %args;
    } else {
        $class->db->insert($class->table,\%args) or croak 'couldnt create';
        my $pk = $class->primary_keys->[0];
        unless (defined $args{$pk}) {
            my $id = $class->db->last_insert_id;
            $o->set($pk => $id);
        }
    }
    $class->call_trigger('after_create', $o);
    return $o;
}

sub delete {
    my $self = shift;
    my $class = ref($self) ? ref($self) : $self;
    $self = shift unless ref($self);
    $self or return;
    $self->call_trigger('before_delete', $self);
    $self->has_primary_keys or return;
    my %args;
    for (@{$class->primary_keys}) {
        $args{$_} = $self->{$_};
        defined($args{$_}) or die "$self doesn't have $_";
    }
    %args or die "$self doesn't have where condition";
    my $res = $class->db->delete($class->table,\%args) or croak 'couldnt delete';
    $self = undef;
    return $res;
}

sub delete_all {
    my $class = shift;
    my %args = @_;
    ref $args{where} eq 'HASH' or die 'please specify where in hash';
    my $list = $class->retrieve_all_id_hash(%args);
    my $caches = [];
    for (@$list) {
        my $oid = $class->object_id(%$_);
        my $c = $class->cache($oid) or next;
        push @$caches, $c;
    }
    $class->call_trigger('before_delete', $_) for (@$caches);
    $class->db->delete($class->table,$args{where}) or croak 'couldnt delete';
    return 1;
}

sub search {
    my $class = shift;
    my %args = @_;

    my $with = delete $args{with};

    $args{table} = $class->table;
    my $res = $class->db->search(%args);
    $_ = $class->new(%$_) for @$res;
    $class->merge_with($res, $with) if $with;

    wantarray ? @$res : $class->_list($res);
}

sub merge_with {
    my ($class, $res, $with, $without) = @_;

    my @with_attrs = (ref $with and ref $with eq 'ARRAY') ? @$with : $with;

    if ($without) {
        my @withouts = (ref $without and ref $without eq 'ARRAY') ? @$without : $without;
        my $regex = sprintf '(?:^%s$)', join '|', @withouts;
        @with_attrs = grep { $_ !~ m/$regex/ } @with_attrs;
    }

    for my $with_attr (@with_attrs) {
        my $rel = $class->relation->find_relation_by_attr($class => $with_attr)
            or croak "No such relation for attr '$with_attr' in $class";

        my $key = $rel->{option}->{key} or next;

        my ($my_key, $other_key);
        (ref $key and ref $key eq 'HASH')
            ? ($my_key, $other_key) = %$key
            : $my_key = $other_key  = $key;

        my @queries = map { +{ $other_key => $_->$my_key } } @$res;

        ## Only creating caches for less SQL queries.
        ## Those caches will be stored to the session cache if the session is activated.
        $rel->{class}->retrieve_multi(@queries);
    }

    $res;
}

sub count {
    my $class = shift;
    my $where = '';
    if ($_[1]) {
        my %args = @_;
        $where = \%args;
    } elsif ($_[0]) {
        $where = shift;
    }
    my $res = $class->db->search(
        table => $class->table,
        field => 'COUNT(*) as count',
        where => $where,
    );
    return $res->[0]->{count} || 0;
}

sub find {
    my $class = shift;
    my $where;
    if ($_[1]) {
        my %args = @_;
        $where = \%args;
    } elsif ($_[0]) {
        $where = shift;
    } else {
        return;
    }
    $class->search(
        where => $where,
        offset => 0,
        limit => 1,
    )->first;
}

sub quote {
    my $class = shift;
    $class->db->dbh->quote(shift);
}

sub scalar {
    my ($class, $method, @args) = @_;
    scalar $class->$method(@args);
}

sub AUTOLOAD {
    my $self = $_[0];
    my $class = ref($self) || $self;
    $self = undef unless ref($self);
    (my $method = $AUTOLOAD) =~ s!.+::!!;
    return if $method eq 'DESTROY';
    no strict 'refs';
    if ($method =~ /^retrieve_by_(.+?)(_or_create)?$/o) {
        my ($by, $create) = ($1,$2);
        *$AUTOLOAD = $create ? $class->_retrieve_by_or_create_handler($by) :
            $class->_retrieve_by_handler($by);
    } elsif ($method =~ /^(\w+)_as_(\w+)$/o) {
        my ($col,$as) = ($1,$2);
        *$AUTOLOAD = $class->_column_as_handler($col, $as);
    } elsif (defined $self->{$method} || $class->has_column($method)) {
        *$AUTOLOAD = sub { shift->param($method, @_) };
    } else {
        croak sprintf 'Can\'t locate object method "%s" via package %s', $method, $class;
    }
    goto &$AUTOLOAD;
}

sub inflate_column {
    my $class = shift;
    @_ % 2 and croak "You gave me an odd number of parameters to inflate_column()";

    my %args = @_;
    while (my ($col, $as) = each %args) {
        no strict 'refs';
        no warnings 'redefine';

        if (ref $as and ref $as eq 'HASH') {
            for (qw/inflate deflate/) {
                if ($as->{$_} and ref $as->{$_} ne 'CODE') {
                    croak sprintf "parameter '%s' takes only CODE reference", $_
                }
            }

            *{"$class\::$col"} = sub {
                my $self = shift;
                if (@_) {
                    $as->{deflate}
                        ? $self->param( $col => $as->{deflate}->(@_) )
                        : $self->param( $col => @_ );
                } else {
                    $as->{inflate}
                        ? $as->{inflate}->( $self->param($col) )
                        : $self->param( $col );
                }
            }
        } else {
            *{"$class\::$col"} = $class->_column_as_handler($col, $as);
        }
    }
}

{
    my $real_can = \&UNIVERSAL::can;
    no warnings 'redefine', 'once';
    *DBIx::MoCo::can = sub {
        my ($class, $method) = @_;
        if (my $sub = $real_can->(@_)) {
            # warn "found $method in $class";
            return $sub;
        }
        no strict 'refs';
        if (my $auto = *{$class . '::AUTOLOAD'}{CODE}) {
            return $auto;
        }
        $AUTOLOAD = $class . '::' . $method;
        eval {&DBIx::MoCo::AUTOLOAD(@_)} unless *$AUTOLOAD{CODE};
        return *$AUTOLOAD{CODE};
    };
}

sub _column_as_handler {
    my $class = shift;
    my ($colname, $as) = @_;
    unless (DBIx::MoCo::Column->can($as)) {
        my $plugin = "DBIx::MoCo::Column::$as";
        $plugin->require;
        croak "Couldn't load column plugin $plugin: $@"  if $@;
        {
            no strict 'refs';
            push @{"DBIx::MoCo::Column::ISA"}, $plugin;
        }
    }
    return sub {
        my $self = shift;
        my $column = $self->column($colname) or return;
        if (my $new = shift) {
            my $as_string = $as . '_as_string'; # e.g. URI_as_string
            my $v = $column->can($as_string) ?
                $column->$as_string($new) : scalar $new;
            $self->param($colname => $v);
        }
        $self->column($colname)->$as();
    }
}

sub column {
    my $self = shift;
    my $col = shift or return;
    return DBIx::MoCo::Column->new($self->{$col});
}

sub _retrieve_by_handler {
    my $class = shift;
    my $by = shift or return;
    if ($by =~ /.+_or_.+/) {
        my @keys = split('_or_', $by);
        return sub {
            my $self = shift;
            my $v = shift;
            for (@keys) {
                my $o = $self->retrieve($_ => $v);
                return $o if $o;
            }
        };
    } else {
        my @keys = split('_and_', $by);
        return sub {
            my $self = shift;
            my %args;
            @args{@keys} = @_;
            $self->retrieve(%args);
        };
    }
}

sub _retrieve_by_or_create_handler {
    my $class = shift;
    my $by = shift or return;
    my @keys = split('_and_', $by);
    return sub {
        my $self = shift;
        my %args;
        @args{@keys} = @_;
        return $self->retrieve(%args) || $class->create(%args);
    };
}

sub _list {
    my $class = shift;

    if ($class->list_class) {
        $class->list_class->require;
        if ($@ and $@ !~ m/^Can\'t locate .+? in \@INC/) {
            die $@;
        }
        return $class->list_class->new(@_);
    } else {
        return DBIx::MoCo::List->new(@_);
    }
}

sub DESTROY {
    my $class = shift;
    $class->save_changed;
}

sub new {
    my $class = shift;
    my %args = @_;
    my $self = \%args;
    $self->{changed_cols} = {};
    bless $self, $class;
    $self;
}

sub flush {
    my $self = shift;
    my $attr = shift or return;
    # warn "flush " . $self->object_id . '->' . $attr;
    $self->{$attr} = undef;
    $self->store_self_cache($self);
}

sub param {
    my $self = shift;
    my $class = ref $self or return;
    return unless(defined $_[0]);
    # if (defined $_[1]) {
    if (@_ > 1) {
        @_ % 2 and croak "You gave me an odd number of parameters to param()!";
        my %args = @_;
        $class->call_trigger('before_update', $self, \%args);
        $self->{$_} = $args{$_} for (keys %args);
        if ($class->is_in_session) {
            $self->{to_be_updated}++;
            $self->{changed_cols}->{$_}++ for (keys %args);
            push @{$class->session->{changed_objects}}, $self;
        } elsif ($class->save_explicitly) {
            $self->{to_be_updated}++;
            $self->{changed_cols}->{$_}++ for keys %args;
        } else {
            my $where = $self->primary_keys_hash or return;
            %$where or return;
            $class->db->update($class->table,\%args,$where) or croak 'couldnt update';
        }
        $class->call_trigger('after_update', $self);
        # return 1;
    }
    return $self->{$_[0]};
}

sub primary_keys_hash {
    my $self = shift;
    my $class = ref $self or return;
    @{$class->primary_keys} or return;
    my $hash = {};
    for (@{$class->primary_keys}) {
        defined $self->{$_} or return;
        $hash->{$_} = $self->{$_};
    }
    return $hash;
}

sub set {
    my $self = shift;
    my ($k,$v) = @_;
    $self->{$k} = $v;
}

sub has_primary_keys {
    my $self = shift;
    my $class = ref $self;
    for (@{$class->primary_keys}) {
        defined $self->{$_} or return;
    }
    return 1;
}

sub save {
    my $self = shift;
    my $class = ref $self;
    keys %{$self->{changed_cols}} or return;
    my %args;
    for (keys %{$self->{changed_cols}}) {
#        defined $self->{$_} or croak "$_ is undefined";
        exists $self->{$_} or croak "$_ is undefined";
        $args{$_} = $self->{$_};
    }
    if ($self->{to_be_inserted}) {
        $class->db->insert($class->table,\%args);
        $self->{changed_cols} = {};
        $self->{to_be_inserted} = undef;
    } elsif ($self->{to_be_updated}) {
        my $where = $self->primary_keys_hash or return;
        %$where or return;
        $class->db->update($class->table,\%args,$where);
        $self->{changed_cols} = {};
        $self->{to_be_updated} = undef;
    }
}

sub object_ids { # returns all possible oids
    my $self = shift;
    my $class = ref $self or return;
    my $oids = {};
    $oids->{$self->object_id} = 1 if $self->object_id;
    for my $key (@{$class->unique_keys}) {
        next unless defined $self->{$key};
        my $oid = $class->object_id($key => $self->{$key}) or next;
        $oids->{$oid}++;
    }
    return [sort keys %$oids];
}

1;

__END__