From 07d690e4c520994e05ba6aa89ee1b5b1c82bbcd4 Mon Sep 17 00:00:00 2001
From: Moritz Bunkus <m.bunkus@linet-services.de>
Date: Thu, 12 May 2011 10:34:49 +0200
Subject: [PATCH] =?utf8?q?Framework=20f=C3=BCr=20after/before-Hooks=20bei?=
 =?utf8?q?=20load/save/delete?=
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

Conflicts:

	SL/X.pm
---
 SL/DB/Object.pm       |  36 +++++++++++
 SL/DB/Object/Hooks.pm | 139 ++++++++++++++++++++++++++++++++++++++++++
 SL/X.pm               |   1 +
 3 files changed, 176 insertions(+)
 mode change 100644 => 100755 SL/DB/Object.pm
 create mode 100644 SL/DB/Object/Hooks.pm

diff --git a/SL/DB/Object.pm b/SL/DB/Object.pm
old mode 100644
new mode 100755
index a2db47f48..4e6e15c4c
--- a/SL/DB/Object.pm
+++ b/SL/DB/Object.pm
@@ -9,6 +9,7 @@ use SL::DB;
 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);
 
@@ -94,6 +95,41 @@ sub call_sub_if {
   return $check ? $self->$sub(@_) : $self;
 }
 
+# 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 $worker        = sub {
+    SL::DB::Object::Hooks::run_hooks($self, 'before_save');
+    my $result = $self->SUPER::save(@args);
+    SL::DB::Object::Hooks::run_hooks($self, 'after_save', $result);
+  };
+
+  return $self->db->in_transaction ? $worker->() : $self->db->do_transaction($worker);
+}
+
+sub delete {
+  my ($self, @args) = @_;
+  my $worker        = sub {
+    SL::DB::Object::Hooks::run_hooks($self, 'before_delete');
+    my $result = $self->SUPER::delete(@args);
+    SL::DB::Object::Hooks::run_hooks($self, 'after_delete', $result);
+  };
+
+  return $self->db->in_transaction ? $worker->() : $self->db->do_transaction($worker);
+}
+
 1;
 
 __END__
diff --git a/SL/DB/Object/Hooks.pm b/SL/DB/Object/Hooks.pm
new file mode 100644
index 000000000..f2dfde49b
--- /dev/null
+++ b/SL/DB/Object/Hooks.pm
@@ -0,0 +1,139 @@
+package SL::DB::Object::Hooks;
+
+use strict;
+
+use SL::X;
+
+use parent qw(Exporter);
+our @EXPORT = qw(before_load   after_load
+                 before_save   after_save
+                 before_delete after_delete);
+
+my %hooks;
+
+# Adding hooks
+
+sub before_save {
+  _add_hook('before_save', @_);
+}
+
+sub after_save {
+  _add_hook('after_save', @_);
+}
+
+sub before_load {
+  _add_hook('before_load', @_);
+}
+
+sub after_load {
+  _add_hook('after_load', @_);
+}
+
+sub before_delete {
+  _add_hook('before_delete', @_);
+}
+
+sub after_delete {
+  _add_hook('after_delete', @_);
+}
+
+# Running hooks
+
+sub run_hooks {
+  my ($object, $when, @args) = @_;
+
+  foreach my $sub (@{ ( $hooks{$when} || { })->{ ref($object) } || [ ] }) {
+    my $result = ref($sub) eq 'CODE' ? $sub->($object, @args) : $object->call_sub($sub, @args);
+    SL::X::DBHookError->throw(error => "${when} hook '" . (ref($sub) eq 'CODE' ? '<anonymous sub>' : $sub) . "' failed") if !$result;
+  }
+}
+
+# Internals
+
+sub _add_hook {
+  my ($when, $class, $sub_name, $code) = @_;
+  $hooks{$when}           ||= { };
+  $hooks{$when}->{$class} ||= [ ];
+  push @{ $hooks{$when}->{$class} }, $sub_name;
+}
+
+1;
+__END__
+
+=pod
+
+=encoding utf8
+
+=head1 NAME
+
+SL::DB::Object::Hooks - Hooks that are run before/after a
+load/save/delete
+
+=head1 SYNOPSIS
+
+Hooks are functions that are called before or after an object is
+loaded, saved or deleted. The package defines the hooks, and those
+hooks themselves are run as instance methods.
+
+Hooks are run in the order they're added.
+
+Hooks must return a trueish value in order to continue processing. If
+any hook returns a falsish value then an exception (instance of
+C<SL::X::DBHookError>) is thrown. However, C<SL::DB::Object> usually
+runs the hooks from within a transaction, catches the exception and
+only returns falsish in error cases.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item C<before_load $sub>
+
+=item C<before_save $sub>
+
+=item C<before_delete $sub>
+
+=item C<after_load $sub>
+
+=item C<after_save $sub>
+
+=item C<after_delete $sub>
+
+Adds a new hook that is called at the appropriate time. C<$sub> can be
+either a name of an existing sub or a code reference. If it is a code
+reference then the then-current C<$self> will be passed as the first
+argument.
+
+C<before> hooks are called without arguments.
+
+C<after> hooks are called with a single argument: the result of the
+C<save> or C<delete> operation.
+
+=item C<run_hooks $object, $when, @args>
+
+Runs all hooks for the object C<$object> that are defined for
+C<$when>. C<$when> is the same as one of the C<before_xyz> or
+C<after_xyz> function names above.
+
+An exception of C<SL::X::DBHookError> is thrown if any of the hooks
+returns a falsish value.
+
+This function is supposed to be called by L</SL::DB::Object::load>,
+L</SL::DB::Object::save> or L</SL::DB::Object::delete>.
+
+=back
+
+=head1 EXPORTS
+
+This mixin exports the functions L</before_load>, L</after_load>,
+L</before_save>, L</after_save>, L</before_delete>, L</after_delete>.
+
+=head1 BUGS
+
+Nothing here yet.
+
+=head1 AUTHOR
+
+Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
+
+=cut
diff --git a/SL/X.pm b/SL/X.pm
index ce7552c1e..8c130c3c9 100644
--- a/SL/X.pm
+++ b/SL/X.pm
@@ -5,5 +5,6 @@ use strict;
 use Exception::Lite qw(declareExceptionClass);
 
 declareExceptionClass('SL::X::FormError');
+declareExceptionClass('SL::X::DBHookError');
 
 1;
-- 
2.20.1