Merge pull request #29 from TeXhackse/marei-reimplement-table

[kivitendo-erp.git] / SL / DB / Object.pm

diff --git a/SL/DB/Object.pm b/SL/DB/Object.pm
index 1c7c050..89d15c6 100755 (executable)
--- a/SL/DB/Object.pm
+++ b/SL/DB/Object.pm
@@ -2,18 +2,34 @@ package SL::DB::Object;
 
 use strict;
 
 
 use strict;
 

+use Carp;

 use English qw(-no_match_vars);
 use Rose::DB::Object;
 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);
 

+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();
 sub new {
   my $class = shift;
   my $self  = $class->SUPER::new();


@@ -26,7 +42,7 @@ sub new {
 sub init_db {
   my $class_or_self = shift;
   my $class         = ref($class_or_self) || $class_or_self;
 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);
 }
 
   return SL::DB::create(undef, $type);
 }


@@ -50,6 +66,7 @@ sub assign_attributes {
 
   my $pk         = ref($self)->meta->primary_key;
   delete @attributes{$pk->column_names} if $pk;
 
   my $pk         = ref($self)->meta->primary_key;
   delete @attributes{$pk->column_names} if $pk;

+  delete @attributes{@rose_reserved_methods};

 
   return $self->_assign_attributes(%attributes);
 }
 
   return $self->_assign_attributes(%attributes);
 }


@@ -89,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;


@@ -132,21 +193,15 @@ sub load {
 sub save {
   my ($self, @args) = @_;
 
 sub save {
   my ($self, @args) = @_;
 

-  my ($result, $exception);
-  my $worker = sub {
+  my $result;
+
+  $self->db->with_transaction(sub {

     SL::DB::Object::Hooks::run_hooks($self, 'before_save');
     SL::DB::Object::Hooks::run_hooks($self, 'before_save');

-    $exception = $EVAL_ERROR unless eval {
-      $result = $self->SUPER::save(@args);
-      1;
-    };
+    $result = $self->SUPER::save(@args);

     SL::DB::Object::Hooks::run_hooks($self, 'after_save', $result);
 
     SL::DB::Object::Hooks::run_hooks($self, 'after_save', $result);
 

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

 
   return $result;
 }
 
   return $result;
 }


@@ -154,23 +209,109 @@ sub save {
 sub delete {
   my ($self, @args) = @_;
 
 sub delete {
   my ($self, @args) = @_;
 

-  my ($result, $exception);
-  my $worker = sub {
+  my $result;
+
+  $self->db->with_transaction(sub {

     SL::DB::Object::Hooks::run_hooks($self, 'before_delete');
     SL::DB::Object::Hooks::run_hooks($self, 'before_delete');

-    $exception = $EVAL_ERROR unless eval {
-      $result = $self->SUPER::delete(@args);
-      1;
-    };
+    $result = $self->SUPER::delete(@args);

     SL::DB::Object::Hooks::run_hooks($self, 'after_delete', $result);
 
     SL::DB::Object::Hooks::run_hooks($self, 'after_delete', $result);
 

-    return $result;
-  };
+    1;
+  }) || die $self->db->error;

 
 

-  $self->db->in_transaction ? $worker->() : $self->db->do_transaction($worker);
+  return $result;
+}

 
 

-  die $exception if $exception;
+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}");

 
 

-  return $result;
+  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;
 }
 
 1;


@@ -179,6 +320,8 @@ __END__
 
 =pod
 
 
 =pod
 

+=encoding utf8
+

 =head1 NAME
 
 SL::DB::Object: Base class for all of our model classes
 =head1 NAME
 
 SL::DB::Object: Base class for all of our model classes


@@ -220,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


@@ -251,6 +416,63 @@ 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.
 
 be used to check whether or not an object's columns are unique before
 saving or during validation.
 

+=item C<load_cached @ids>
+
+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>).
+
+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
+C<$some_part-E<gt>load_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<invalidate_cached @ids>
+
+Deletes all cached instances of this class (see L</load_cached>) 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<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