Merge branch 'b-3.6.1' of ../kivitendo-erp_20220811

[mfinanz.git] / SL / DB / Object.pm

diff --git a/SL/DB/Object.pm b/SL/DB/Object.pm
index 81ef97890c7cdb047f1c3d024591c7247f8b75b5..89d15c67101874c05c486005aedf0fc4691328fd 100755 (executable)
--- a/SL/DB/Object.pm
+++ b/SL/DB/Object.pm
@@ -5,12 +5,15 @@ use strict;
 use Carp;
 use English qw(-no_match_vars);
 use Rose::DB::Object;
 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;
 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);
 use SL::DB::Object::Hooks;
 
 use base qw(Rose::DB::Object);


@@ -20,6 +23,13 @@ my @rose_reserved_methods = qw(
   not_found save update import
 );
 
   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();
 sub new {
   my $class = shift;
   my $self  = $class->SUPER::new();


@@ -96,6 +106,50 @@ sub update_attributes {
   return $self;
 }
 
   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;
 sub call_sub {
   my $self = shift;
   my $sub  = shift;


@@ -139,21 +193,15 @@ sub load {
 sub save {
   my ($self, @args) = @_;
 
 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;
-    };
+  my $result;

 
 

-    return $result;
-  };
-
-  $self->db->in_transaction ? $worker->() : $self->db->do_transaction($worker);
+  $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);

 
 

-  die $exception if $exception;
+    1;
+  }) || die $self->db->error;

 
   return $result;
 }
 
   return $result;
 }


@@ -161,21 +209,15 @@ sub save {
 sub delete {
   my ($self, @args) = @_;
 
 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;
-    };
+  my $result;

 
 

-    return $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);

 
 

-  $self->db->in_transaction ? $worker->() : $self->db->do_transaction($worker);
-
-  die $exception if $exception;
+    1;
+  }) || die $self->db->error;

 
   return $result;
 }
 
   return $result;
 }


@@ -218,6 +260,60 @@ sub invalidate_cached {
   return $class_or_self;
 }
 
   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__
 1;
 
 __END__


@@ -267,6 +363,28 @@ Assigns the attributes from C<%attributes> by calling the
 C<assign_attributes> function and saves the object afterwards. Returns
 the object itself.
 
 C<assign_attributes> function and saves the object afterwards. Returns
 the object itself.
 

+=item C<update_collection $attribute, $entries, %params>
+
+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-&gt;$attribute> & updates its
+attributes with the data in the entry.
+
+All objects in C<$self-&gt;$attribute> for which no corresponding
+entry exists in C<$entries> are deleted by calling the object's
+C<delete> method.
+
+In all cases the relationship itself C<$self-&gt;$attribute> is not
+changed.
+

 =item _get_manager_class
 
 Returns the manager package for the object or class that it is called
 =item _get_manager_class
 
 Returns the manager package for the object or class that it is called


@@ -304,6 +422,14 @@ Loads objects from the database which haven't been cached before and
 caches them for the duration of the current request (see
 L<SL::Request/cache>).
 
 caches them for the duration of the current request (see
 L<SL::Request/cache>).
 

+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<cache_all> function. For example, if you expect to need all unit
+objects, you can use C<SL::DB::Manager::Unit-E<gt>cache_all> before
+you start the actual work. Later you can use
+C<SL::DB::Unit-E<gt>load_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
 C<SL::DB::Part-E<gt>load_cached(…)> and
 This method can be called both as an instance method and a class
 method. It loads objects for the corresponding class (e.g. both
 C<SL::DB::Part-E<gt>load_cached(…)> and


@@ -323,6 +449,30 @@ object's ID is used.
 
 Returns the object/class it was called on.
 
 
 Returns the object/class it was called on.
 

+=item C<clone_and_reset>
+
+This works similar to L<Rose::DB::Object::Helpers/clone_and_reset>: 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<itime>, C<mtime>.
+
+=item C<presenter>
+
+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<SL::DB::Helper::Presenter>
+
+=item C<as_debug_info>
+
+Returns a hash containing solely the essentials for dumping it with
+L<LXDebug/dump>. The returned hash consists of the column names with
+associated column values in stringified form.
+

 =back
 
 =head1 AUTHOR
 =back
 
 =head1 AUTHOR