perl/lib/Thrasher/Callbacks.pm

   1 package Thrasher::Callbacks;
   2 use strict;
   3 use warnings;
   4
   5 =pod
   6
   7 =head1 NAME
   8
   9 Thrasher::Callbacks - abstract out recurring callback patterns
  10
  11 =head1 DESCRIPTION
  12
  13 Some recurring callback patterns keep arising; this centralizes them
  14 so everything can freely use them.
  15
  16 Two recurring patterns arise in the Jabber client code:
  17
  18 =over
  19
  20 =item *
  21
  22 A need to perform a given task only after some criteria has been met,
  23 which may succeed or fail, which may need different actions depending
  24 on whether there was success or failure, and which, after the
  25 condition has been passed, should be immediately acted upon.
  26
  27 For example, a directed presence at a legacy user should be held until
  28 the user has finished logging in to the legacy service. If the log in
  29 fails, the presence should be forgotten.
  30
  31 =item *
  32
  33 A need to call a callback with a certain name, which may be aborted
  34 if a callback requests for the rest of the chain to be aborted.
  35
  36 =back
  37
  38 This centralizes these actions into a single central interface.
  39
  40 =cut
  41
  42 use base 'Exporter';
  43
  44 our @EXPORT_OK = qw(do_when succeeded failed event_superceded
  45
  46                     callbacks register_callback unregister_callback);
  47 our %EXPORT_TAGS = (all => \@EXPORT_OK);
  48
  49 use Thrasher::Log qw(log);
  50
  51 use Data::Dumper;
  52 use Carp qw(confess);
  53
  54 # $DO_WHEN{x} => [] means stacked up actions
  55 # $DO_WHEN{x} => 1 means the action has succeeded
  56 # $DO_WHEN{x} => 0 means the action failed.
  57 # $DO_WHEN{x} => undef means no callbacks registered
  58 my %DO_WHEN;
  59
  60 sub do_when {
  61     my $action_name = shift;
  62     my $success_action = shift;
  63     my $failure_action = shift;
  64
  65     my $do_when_data = $DO_WHEN{$action_name};
  66     if (!defined($do_when_data)) {
  67         $DO_WHEN{$action_name} = [];
  68         return do_when($action_name, $success_action, $failure_action);
  69     } elsif (ref($do_when_data) eq 'ARRAY') {
  70         my $spec = {success => $success_action};
  71         if ($failure_action) {
  72             $spec->{failure} = $failure_action;
  73         }
  74         push @$do_when_data, $spec;
  75         return;
  76     } elsif ($do_when_data == 1) {
  77         local $@;
  78         eval {
  79             $success_action->();
  80         };
  81         log "Failure in success callback: $@" if $@;
  82         return;
  83     }
  84
  85     die "Bad call to do_when: " .
  86         Dumper([$action_name, $success_action, $failure_action, @_]);
  87 }
  88
  89 sub succeeded {
  90     process_actions($_[0], 'success');
  91 }
  92
  93 sub failed {
  94     process_actions($_[0], 'failure');
  95 }
  96
  97 # Call this when you were using an event, but now it will never
  98 # be used again.
  99 sub event_superceded {
 100     delete $DO_WHEN{$_[0]};
 101 }
 102
 103 # Note: Not exported; use succeeded or failed
 104 sub process_actions {
 105     my $action_name = shift;
 106     my $type = shift;
 107
 108     my $deferred_actions = $DO_WHEN{$action_name};
 109
 110     if (defined($deferred_actions)) {
 111         if (!ref($deferred_actions)) {
 112             return;
 113         }
 114
 115         for my $deferred (@$deferred_actions) {
 116             my $success_action = $deferred->{$type};
 117             if (ref($success_action) eq 'CODE') {
 118                 local $@;
 119                 eval {
 120                     $success_action->();
 121                 };
 122                 log("For action $action_name ($type), failure: $@") if $@;
 123             }
 124         }
 125     }
 126
 127     $DO_WHEN{$action_name} = $type eq 'success';
 128 }
 129
 130 my %CALLBACKS;
 131
 132 sub register_callback {
 133     my $type = shift;
 134     my $name = shift;
 135     my $callback = shift;
 136
 137     $CALLBACKS{$type}->{$name} = $callback;
 138 }
 139
 140 sub unregister_callback {
 141     my $type = shift;
 142     my $name = shift;
 143     delete $CALLBACKS{$type}->{$name};
 144 }
 145
 146 # Returning undef cancels the rest of the callbacks and of the
 147 # processing. Returning anything defined continues the chain.
 148 # It is expected that if you need to make changes that you
 149 # make them directly, since everything is passed by ref.
 150 sub callbacks {
 151     my $callback_type = shift;
 152     my $extra = shift;
 153     my $final_action = shift;
 154     my @data = @_;
 155
 156     my $callbacks = $CALLBACKS{$callback_type};
 157     if (!defined($callbacks)) {
 158         if (defined($final_action) && ref($final_action) ne 'CODE') {
 159             confess "Not a code ref passed to callbacks.";
 160         }
 161
 162         if ($final_action) {
 163             return $final_action->(@data);
 164         } else {
 165             return;
 166         }
 167     }
 168
 169     for my $name (keys %$callbacks) {
 170         my $callback = $callbacks->{$name};
 171         local $@;
 172         my $result;
 173         eval {
 174             $result = $callback->($extra, @data);
 175         };
 176         if ($@) {
 177             my $message = "Failure in presence callback $name: $@";
 178             if ($Thrasher::TESTING) {
 179                 print $message;
 180             } else {
 181                 log($message);
 182             }
 183         }
 184         if (!defined($result)) {
 185             return;
 186         }
 187     }
 188
 189     # Passed the callback chain
 190     if ($final_action) {
 191         return $final_action->(@data);
 192     }
 193     return;
 194 }
 195
 196 1;