X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FDB%2FObject.pm;h=81ef97890c7cdb047f1c3d024591c7247f8b75b5;hb=cbb59a58cac23f3973badcf52d4e0ec999453033;hp=f138518007537b98aebb07d5c69c1e0754a1c08f;hpb=6cf3f7762efd40bee49a2b8f11bb4ab6915d9071;p=kivitendo-erp.git diff --git a/SL/DB/Object.pm b/SL/DB/Object.pm old mode 100644 new mode 100755 index f13851800..81ef97890 --- a/SL/DB/Object.pm +++ b/SL/DB/Object.pm @@ -2,17 +2,24 @@ package SL::DB::Object; use strict; -use Readonly; +use Carp; +use English qw(-no_match_vars); use Rose::DB::Object; use List::MoreUtils qw(any); use SL::DB; -use SL::DB::Helpers::Attr; -use SL::DB::Helpers::Metadata; -use SL::DB::Helpers::Manager; +use SL::DB::Helper::Attr; +use SL::DB::Helper::Metadata; +use SL::DB::Helper::Manager; +use SL::DB::Object::Hooks; use base qw(Rose::DB::Object); +my @rose_reserved_methods = qw( + db dbh delete DESTROY error init_db _init_db insert load meta meta_class + not_found save update import +); + sub new { my $class = shift; my $self = $class->SUPER::new(); @@ -25,13 +32,13 @@ sub new { sub init_db { my $class_or_self = shift; my $class = ref($class_or_self) || $class_or_self; - my $type = 'LXOFFICE'; + my $type = $class =~ m/::Auth/ ? 'KIVITENDO_AUTH' : 'KIVITENDO'; return SL::DB::create(undef, $type); } sub meta_class { - return 'SL::DB::Helpers::Metadata'; + return 'SL::DB::Helper::Metadata'; } sub _get_manager_class { @@ -41,7 +48,7 @@ sub _get_manager_class { return $class->meta->convention_manager->auto_manager_class_name($class); } -Readonly my %text_column_types => (text => 1, char => 1, varchar => 1); +my %text_column_types = (text => 1, char => 1, varchar => 1); sub assign_attributes { my $self = shift; @@ -49,6 +56,7 @@ sub assign_attributes { my $pk = ref($self)->meta->primary_key; delete @attributes{$pk->column_names} if $pk; + delete @attributes{@rose_reserved_methods}; return $self->_assign_attributes(%attributes); } @@ -59,11 +67,21 @@ sub _assign_attributes { my %types = map { $_->name => $_->type } ref($self)->meta->columns; + # Special case for *_as_man_days / *_as_man_days_string / + # *_as_man_days_unit: the _unit variation must always be called + # after the non-unit methods. + my @man_days_attributes = grep { m/_as_man_days(?:_string)?$/ } keys %attributes; + foreach my $attribute (@man_days_attributes) { + my $value = delete $attributes{$attribute}; + $self->$attribute(defined($value) && ($value eq '') ? undef : $value); + } + while (my ($attribute, $value) = each %attributes) { my $type = lc($types{$attribute} || 'text'); - $value = $type eq 'boolean' ? ($value ? 't' : 'f') - : $text_column_types{$type} ? $value - : ($value || undef); + $value = $type eq 'boolean' ? ($value ? 't' : 'f') + : $text_column_types{$type} ? $value + : defined($value) && ($value eq '') ? undef + : $value; $self->$attribute($value); } @@ -78,12 +96,136 @@ sub update_attributes { return $self; } +sub call_sub { + my $self = shift; + my $sub = shift; + return $self->$sub(@_); +} + +sub call_sub_if { + my $self = shift; + my $sub = shift; + my $check = shift; + + $check = $check->($self) if ref($check) eq 'CODE'; + + return $check ? $self->$sub(@_) : $self; +} + +sub get_first_conflicting { + my ($self, @attributes) = @_; + + my $primary_key = ($self->meta->primary_key)[0]; + my @where = map { ($_ => $self->$_) } @attributes; + + push @where, ("!$primary_key" => $self->$primary_key) if $self->$primary_key; + + return $self->_get_manager_class->get_first(where => [ and => \@where ]); +} + +# These three functions cannot sit in SL::DB::Object::Hooks because +# mixins don't deal well with super classes (SUPER is the current +# package's super class, not $self's). +sub load { + my ($self, @args) = @_; + + SL::DB::Object::Hooks::run_hooks($self, 'before_load'); + my $result = $self->SUPER::load(@args); + SL::DB::Object::Hooks::run_hooks($self, 'after_load', $result); + + return $result; +} + +sub save { + my ($self, @args) = @_; + + my ($result, $exception); + my $worker = sub { + $exception = $EVAL_ERROR unless eval { + SL::DB::Object::Hooks::run_hooks($self, 'before_save'); + $result = $self->SUPER::save(@args); + SL::DB::Object::Hooks::run_hooks($self, 'after_save', $result); + 1; + }; + + return $result; + }; + + $self->db->in_transaction ? $worker->() : $self->db->do_transaction($worker); + + die $exception if $exception; + + return $result; +} + +sub delete { + my ($self, @args) = @_; + + my ($result, $exception); + my $worker = sub { + $exception = $EVAL_ERROR unless eval { + SL::DB::Object::Hooks::run_hooks($self, 'before_delete'); + $result = $self->SUPER::delete(@args); + SL::DB::Object::Hooks::run_hooks($self, 'after_delete', $result); + 1; + }; + + return $result; + }; + + $self->db->in_transaction ? $worker->() : $self->db->do_transaction($worker); + + die $exception if $exception; + + 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; +} + 1; __END__ =pod +=encoding utf8 + =head1 NAME SL::DB::Object: Base class for all of our model classes @@ -131,6 +273,56 @@ Returns the manager package for the object or class that it is called on. Can be used from methods in this package for getting the actual object's manager. +=item C + +Calls the sub C<$name> on C<$self> with the arguments C<@args> and +returns its result. This is meant for situations in which the sub's +name is a composite, e.g. + + my $chart_id = $buchungsgruppe->call_sub(($is_sales ? "income" : "expense") . "_accno_id_${taxzone_id}"); + +=item C + +Calls the sub C<$name> on C<$self> with the arguments C<@args> if +C<$check> is trueish. If C<$check> is a code reference then it will be +called with C<$self> as the only argument and its result determines +whether or not C<$name> is called. + +Returns the sub's result if the check is positive and C<$self> +otherwise. + +=item C + +Returns the first object for which all properties listed in +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. + =back =head1 AUTHOR