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