SL/DB/Object/Hooks.pm

   1 package SL::DB::Object::Hooks;
   2
   3 use strict;
   4
   5 use SL::X;
   6
   7 use parent qw(Exporter);
   8 our @EXPORT = qw(before_load   after_load
   9                  before_save   after_save
  10                  before_delete after_delete);
  11
  12 my %hooks;
  13
  14 # Adding hooks
  15
  16 sub before_save {
  17   _add_hook('before_save', @_);
  18 }
  19
  20 sub after_save {
  21   _add_hook('after_save', @_);
  22 }
  23
  24 sub before_load {
  25   _add_hook('before_load', @_);
  26 }
  27
  28 sub after_load {
  29   _add_hook('after_load', @_);
  30 }
  31
  32 sub before_delete {
  33   _add_hook('before_delete', @_);
  34 }
  35
  36 sub after_delete {
  37   _add_hook('after_delete', @_);
  38 }
  39
  40 # Running hooks
  41
  42 sub run_hooks {
  43   my ($object, $when, @args) = @_;
  44
  45   foreach my $sub (@{ ( $hooks{$when} || { })->{ ref($object) } || [ ] }) {
  46     my $result = ref($sub) eq 'CODE' ? $sub->($object, @args) : $object->call_sub($sub, @args);
  47     SL::X::DBHookError->throw(error => "${when} hook '" . (ref($sub) eq 'CODE' ? '<anonymous sub>' : $sub) . "' failed") if !$result;
  48   }
  49 }
  50
  51 # Internals
  52
  53 sub _add_hook {
  54   my ($when, $class, $sub_name, $code) = @_;
  55   $hooks{$when}           ||= { };
  56   $hooks{$when}->{$class} ||= [ ];
  57   push @{ $hooks{$when}->{$class} }, $sub_name;
  58 }
  59
  60 1;
  61 __END__
  62
  63 =pod
  64
  65 =encoding utf8
  66
  67 =head1 NAME
  68
  69 SL::DB::Object::Hooks - Hooks that are run before/after a
  70 load/save/delete
  71
  72 =head1 SYNOPSIS
  73
  74 Hooks are functions that are called before or after an object is
  75 loaded, saved or deleted. The package defines the hooks, and those
  76 hooks themselves are run as instance methods.
  77
  78 Hooks are run in the order they're added.
  79
  80 Hooks must return a trueish value in order to continue processing. If
  81 any hook returns a falsish value then an exception (instance of
  82 C<SL::X::DBHookError>) is thrown. However, C<SL::DB::Object> usually
  83 runs the hooks from within a transaction, catches the exception and
  84 only returns falsish in error cases.
  85
  86 =head1 FUNCTIONS
  87
  88 =over 4
  89
  90 =item C<before_load $sub>
  91
  92 =item C<before_save $sub>
  93
  94 =item C<before_delete $sub>
  95
  96 =item C<after_load $sub>
  97
  98 =item C<after_save $sub>
  99
 100 =item C<after_delete $sub>
 101
 102 Adds a new hook that is called at the appropriate time. C<$sub> can be
 103 either a name of an existing sub or a code reference. If it is a code
 104 reference then the then-current C<$self> will be passed as the first
 105 argument.
 106
 107 C<before> hooks are called without arguments.
 108
 109 C<after> hooks are called with a single argument: the result of the
 110 C<save> or C<delete> operation.
 111
 112 =item C<run_hooks $object, $when, @args>
 113
 114 Runs all hooks for the object C<$object> that are defined for
 115 C<$when>. C<$when> is the same as one of the C<before_xyz> or
 116 C<after_xyz> function names above.
 117
 118 An exception of C<SL::X::DBHookError> is thrown if any of the hooks
 119 returns a falsish value.
 120
 121 This function is supposed to be called by L</SL::DB::Object::load>,
 122 L</SL::DB::Object::save> or L</SL::DB::Object::delete>.
 123
 124 =back
 125
 126 =head1 EXPORTS
 127
 128 This mixin exports the functions L</before_load>, L</after_load>,
 129 L</before_save>, L</after_save>, L</before_delete>, L</after_delete>.
 130
 131 =head1 BUGS
 132
 133 Nothing here yet.
 134
 135 =head1 AUTHOR
 136
 137 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 138
 139 =cut