X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FDB%2FObject.pm;h=89d15c67101874c05c486005aedf0fc4691328fd;hb=feb6f563968f53e59511578429b1dd61fda52008;hp=71e0a3939b3f76b147aaa89eb8db49c0c9706f50;hpb=d18df453f55190d4807af324725ea82a8835d7fc;p=kivitendo-erp.git diff --git a/SL/DB/Object.pm b/SL/DB/Object.pm old mode 100644 new mode 100755 index 71e0a3939..89d15c671 --- a/SL/DB/Object.pm +++ b/SL/DB/Object.pm @@ -2,16 +2,34 @@ 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 List::Util qw(first); use SL::DB; use SL::DB::Helper::Attr; use SL::DB::Helper::Metadata; use SL::DB::Helper::Manager; +use SL::DB::Helper::Presenter; +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 +); + +my %db_to_presenter_mapping = ( + Customer => 'CustomerVendor', + PurchaseInvoice => 'Invoice', + Vendor => 'CustomerVendor', + GLTransaction => 'GL', +); + sub new { my $class = shift; my $self = $class->SUPER::new(); @@ -24,7 +42,7 @@ sub new { sub init_db { my $class_or_self = shift; my $class = ref($class_or_self) || $class_or_self; - my $type = $class =~ m/::Auth/ ? 'LXOFFICE_AUTH' : 'LXOFFICE'; + my $type = $class =~ m/::Auth/ ? 'KIVITENDO_AUTH' : 'KIVITENDO'; return SL::DB::create(undef, $type); } @@ -48,6 +66,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); } @@ -58,6 +77,15 @@ 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') @@ -78,18 +106,222 @@ sub update_attributes { return $self; } +sub update_collection { + my ($self, $attribute, $entries) = @_; + + my $self_primary_key = "" . ($self->meta->primary_key_columns)[0]; + + croak "\$self hasn't been saved yet" if !$self->$self_primary_key; + + my $relationship = first { $_->name eq $attribute } @{ $self->meta->relationships }; + + croak "No relationship found for attribute '$attribute'" if !$relationship; + + my @primary_key_columns = $relationship->class->meta->primary_key_columns; + + croak "Classes with multiple primary key columns are not supported" if scalar(@primary_key_columns) > 1; + + my $class = $relationship->class; + my $manager_class = "SL::DB::Manager::" . substr($class, 8); + my $other_primary_key = "" . $primary_key_columns[0]; + my $column_map = $relationship->column_map; + my @new_entries = @{ $entries // [] }; + my @existing_entries = @{ $self->$attribute // [] }; + my @to_delete = grep { my $value = $_->$other_primary_key; !any { $_->{$other_primary_key} == $value } @new_entries } @existing_entries; + + $_->delete for @to_delete; + + foreach my $entry (@new_entries) { + if (!$entry->{$other_primary_key}) { + my $new_instance = $class->new(%{ $entry }); + + foreach my $self_attribute (keys %{ $column_map }) { + my $other_attribute = $column_map->{$self_attribute}; + $new_instance->$other_attribute($self->$self_attribute); + } + + $new_instance->save; + + next; + } + + my $existing = first { $_->$other_primary_key == $entry->{$other_primary_key} } @existing_entries; + $existing->update_attributes(%{ $entry }) if $existing; + } +} + 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; + + $self->db->with_transaction(sub { + 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; + }) || die $self->db->error; + + return $result; +} + +sub delete { + my ($self, @args) = @_; + + my $result; + + $self->db->with_transaction(sub { + 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; + }) || die $self->db->error; + + 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; +} + +sub presenter { + my ($self) = @_; + + my $class = ref $self; + $class =~ s{^SL::DB::}{}; + $class = "SL::Presenter::" . ($db_to_presenter_mapping{$class} // $class); + + return SL::DB::Helper::Presenter->new($class, $self); +} + +sub as_debug_info { + my ($self) = @_; + + return { + map { + my $column_name = $_->name; + my $value = $self->$column_name; + $value = !defined($value) ? undef : "${value}"; + ($_ => $value) + } $self->meta->columns + }; +} + 1; __END__ =pod +=encoding utf8 + =head1 NAME SL::DB::Object: Base class for all of our model classes @@ -131,6 +363,28 @@ Assigns the attributes from C<%attributes> by calling the C function and saves the object afterwards. Returns the object itself. +=item C + +Updates a one-to-many relationship named C<$attribute> to match the +entries in C<$entries>. C<$entries> is supposed to be an array ref of +hash refs. + +For each hash ref in C<$entries> that does not contain a field for the +relationship's primary key column, this function creates a new entry +in the database with its attributes set to the data in the entry. + +For each hash ref in C<$entries> that contains a field for the +relationship's primary key column, this function looks up the +corresponding entry in C<$self->$attribute> & updates its +attributes with the data in the entry. + +All objects in C<$self->$attribute> for which no corresponding +entry exists in C<$entries> are deleted by calling the object's +C method. + +In all cases the relationship itself C<$self->$attribute> is not +changed. + =item _get_manager_class Returns the manager package for the object or class that it is called @@ -145,6 +399,80 @@ 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). + +If you know in advance that you will likely need all objects of a +particular type then you can pre-cache them by calling the manager's +C function. For example, if you expect to need all unit +objects, you can use Ccache_all> before +you start the actual work. Later you can use +Cload_cached> to retrieve individual objects and be +sure that they're already cached. + +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. + +=item C + +Returns a proxy wrapper that will dispatch all method calls to the presenter +with the same name as the class of the involking object. + +For the full documentation about its capabilites see +L + +=item C + +Returns a hash containing solely the essentials for dumping it with +L. The returned hash consists of the column names with +associated column values in stringified form. + =back =head1 AUTHOR