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