SL::DB::Helper::LinkedRecords: rekursive Suche in linked_records

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

diff --git a/SL/DB/Object.pm b/SL/DB/Object.pm
old mode 100644 (file)
new mode 100755 (executable)
index 0a69826..c11fb3f
--- a/SL/DB/Object.pm
+++ b/SL/DB/Object.pm
@@ -2,7 +2,7 @@ package SL::DB::Object;
 
 use strict;
 
 
 use strict;
 

-use Readonly;
+use English qw(-no_match_vars);

 use Rose::DB::Object;
 use List::MoreUtils qw(any);
 
 use Rose::DB::Object;
 use List::MoreUtils qw(any);
 


@@ -10,9 +10,15 @@ use SL::DB;
 use SL::DB::Helper::Attr;
 use SL::DB::Helper::Metadata;
 use SL::DB::Helper::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);
 
 
 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();
 sub new {
   my $class = shift;
   my $self  = $class->SUPER::new();


@@ -25,7 +31,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);
 }


@@ -41,7 +47,7 @@ sub _get_manager_class {
   return $class->meta->convention_manager->auto_manager_class_name($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;
 
 sub assign_attributes {
   my $self       = shift;


@@ -49,6 +55,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);
 }


@@ -59,6 +66,15 @@ sub _assign_attributes {
 
   my %types      = map { $_->name => $_->type } ref($self)->meta->columns;
 
 
   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')
   while (my ($attribute, $value) = each %attributes) {
     my $type = lc($types{$attribute} || 'text');
     $value   = $type eq 'boolean'                ? ($value ? 't' : 'f')


@@ -79,6 +95,90 @@ sub update_attributes {
   return $self;
 }
 
   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;
+}
+

 1;
 
 __END__
 1;
 
 __END__


@@ -132,6 +232,31 @@ 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.
 
 on. Can be used from methods in this package for getting the actual
 object's manager.
 

+=item C<call_sub $name, @args>
+
+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<call_sub_if $name, $check, @args>
+
+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<get_first_conflicting @attributes>
+
+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.
+

 =back
 
 =head1 AUTHOR
 =back
 
 =head1 AUTHOR