X-Git-Url: http://wagnertech.de/gitweb/gitweb.cgi/kivitendo-erp.git/blobdiff_plain/11dd30f1740f4b539c2a576626117ff6da91d2f2..c65e8fcc568f54001e277a8d7d8d2bd21cf80f4d:/SL/DB/Object.pm
diff --git a/SL/DB/Object.pm b/SL/DB/Object.pm
index c11fb3f5a..fa474643a 100755
--- a/SL/DB/Object.pm
+++ b/SL/DB/Object.pm
@@ -2,9 +2,11 @@ package SL::DB::Object;
use strict;
+use Carp;
use English qw(-no_match_vars);
use Rose::DB::Object;
-use List::MoreUtils qw(any);
+use Rose::DB::Object::Constants qw();
+use List::MoreUtils qw(any pairwise);
use SL::DB;
use SL::DB::Helper::Attr;
@@ -179,12 +181,83 @@ sub delete {
return $result;
}
+sub load_cached {
+ my $class_or_self = shift;
+ my @ids = @_;
+ my $class = ref($class_or_self) || $class_or_self;
+ my $cache = $::request->cache("::SL::DB::Object::object_cache::${class}");
+
+ croak "Missing ID" unless @ids;
+
+ my @missing_ids = grep { !exists $cache->{$_} } @ids;
+
+ return $cache->{$ids[0]} if !@missing_ids;
+
+ croak "Caching can only be used with classes with exactly one primary key column" if 1 != scalar(@{ $class->meta->primary_key_columns });
+
+ my $primary_key = $class->meta->primary_key_columns->[0]->name;
+ my $objects = $class->_get_manager_class->get_all(where => [ $primary_key => \@missing_ids ]);
+
+ $cache->{$_->$primary_key} = $_ for @{ $objects};
+
+ return $cache->{$ids[0]};
+}
+
+sub invalidate_cached {
+ my ($class_or_self, @ids) = @_;
+ my $class = ref($class_or_self) || $class_or_self;
+
+ if (ref($class_or_self) && !@ids) {
+ croak "Caching can only be used with classes with exactly one primary key column" if 1 != scalar(@{ $class->meta->primary_key_columns });
+
+ my $primary_key = $class->meta->primary_key_columns->[0]->name;
+ @ids = ($class_or_self->$primary_key);
+ }
+
+ delete @{ $::request->cache("::SL::DB::Object::object_cache::${class}") }{ @ids };
+
+ return $class_or_self;
+}
+
+my %_skip_fields_when_cloning = map { ($_ => 1) } qw(itime mtime);
+
+sub clone_and_reset {
+ my($self) = shift;
+ my $class = ref $self;
+ my $cloning = Rose::DB::Object::Constants::STATE_CLONING();
+ local $self->{$cloning} = 1;
+
+ my $meta = $class->meta;
+ my @accessors = $meta->column_accessor_method_names;
+ my @mutators = $meta->column_mutator_method_names;
+ my @column_names =
+ grep { $_->[0] && $_->[1] && !$_skip_fields_when_cloning{ $_->[0] } }
+ pairwise { no warnings qw(once); [ $a, $b] } @accessors, @mutators;
+
+ my $clone = $class->new(map { my $method = $_->[0]; ($_->[1] => $self->$method) } @column_names);
+
+ # Blank all primary and unique key columns
+ my @keys = (
+ $meta->primary_key_column_mutator_names,
+ map { my $uk = $_; map { $meta->column_mutator_method_name($_) } ($uk->columns) } ($meta->unique_keys)
+ );
+
+ $clone->$_(undef) for @keys;
+
+ # Also copy db object, if any
+ $clone->db($self->{db}) if $self->{db};
+
+ return $clone;
+}
+
1;
__END__
=pod
+=encoding utf8
+
=head1 NAME
SL::DB::Object: Base class for all of our model classes
@@ -257,6 +330,41 @@ C<@attributes> equal those in C<$self> but which is not C<$self>. Can
be used to check whether or not an object's columns are unique before
saving or during validation.
+=item C
+
+Loads objects from the database which haven't been cached before and
+caches them for the duration of the current request (see
+L).
+
+This method can be called both as an instance method and a class
+method. It loads objects for the corresponding class (e.g. both
+Cload_cached(â¦)> and
+C<$some_part-Eload_cached(â¦)> will load parts).
+
+Currently only classes with a single primary key column are supported.
+
+Returns the cached object for the first ID.
+
+=item C
+
+Deletes all cached instances of this class (see L) for
+the given IDs.
+
+If called as an instance method without further arguments then the
+object's ID is used.
+
+Returns the object/class it was called on.
+
+=item C
+
+This works similar to L: it
+returns a cloned instance of C<$self>. All primary and unique key
+fields have been reset.
+
+The difference between Rose's and this function is that this function
+will also skip setting the following fields if such columns exist for
+C<$self>: C, C.
+
=back
=head1 AUTHOR