add some support for customizing product options
[bse.git] / site / cgi-bin / modules / BSE / PubSub.pm
1 package BSE::PubSub;
2 use strict;
3 use BSE::CfgInfo qw(load_class);
4
5 our $VERSION = "1.000";
6
7 my %subscribers;
8
9 my %customizers;
10
11 sub _class_desc {
12   my ($class) = @_;
13
14   ref($class) ? "Object of " . ref($class) . " type" : $class;
15 }
16
17 sub _load_handlers {
18   my ($name, $cache) = @_;
19
20   $cache->{_} and return;
21
22   my $cfg = BSE::Cfg->single;
23
24   my @entries = $cfg->entries($name);
25   while (@entries) {
26     my ($key, $val) = splice @entries, 0, 2;
27     $key =~ s/\d+$//;
28     $key =~ s/-.*//;
29     push @{$cache->{$key}}, [ split /,/, $val ];
30   }
31   $cache->{_} = 1;
32
33   # preloads
34   if ($cache->{preload}) {
35     for my $handler (@{$cache->{preload}}) {
36       my ($class, $method) = @$handler;
37
38       if (ref $class || eval { load_class($class); 1 }) {
39         if (!eval { $class->$method(); 1 }) {
40           _log_error("pubsub::preload", "Call to method $method of $class for preload threw an exception",
41                      { class => $class, method => $method, message => "preload", error => $@ });
42         }
43       }
44       else {
45           _log_error("pubsub::preload", "Loading $class for preload threw an exception",
46                      { class => $class, method => $method, message => "preload", error => $@ });
47       }
48     }
49   }
50 }
51
52 sub _sub_info {
53   my ($code) = @_;
54
55   ref $code eq "CODE"
56     or return +{ type => ref($code) };
57
58   my $info = eval {
59     require B;
60     my $cv = B::svref_2object($code);
61     +{
62       file => scalar($cv->FILE),
63       stash => scalar($cv->STASH->NAME),
64      };
65   };
66
67   $info ||= { error => $@ };
68
69   return $info;
70 }
71
72 sub _log_error {
73   my ($comp, $msg, $dump) = @_;
74
75   require BSE::TB::AuditLog;
76   BSE::TB::AuditLog->log
77       (
78         component => $comp,
79         msg => $msg,
80         dump => $dump,
81         actor => "S",
82         level => "error",
83        );
84 }
85
86 sub _publish {
87   my ($self, $section, $hash, $comp, $message, $param) = @_;
88
89   _load_handlers($section => $hash);
90   $hash->{$message}
91     or return;
92
93   for my $handler (@{$hash->{$message}}) {
94     if (ref($handler) eq "CODE") {
95       eval { $handler->($param); 1 }
96         or _log_error("pubsub::publish", "Internal handler for $message threw an exception", _sub_info($handler));
97     }
98     elsif (ref($handler) eq "ARRAY") {
99       my ($class, $method) = @$handler;
100       my $cls = _class_desc($class);
101       if (ref $class || eval { load_class($class); 1 }) {
102         if (!eval { $class->$method($param); 1 }) {
103           _log_error($comp, "Call to method $method of $class for message $message threw an exception",
104                      { class => _class_desc($class), method => $method, message => $message, error => $@ });
105         }
106       }
107       else {
108           _log_error($comp, "Loading $class for message $message threw an exception",
109                      { class => _class_desc($class), method => $method, message => $message, error => $@ });
110       }
111     }
112   }
113
114   return;
115 }
116
117 sub publish {
118   my ($self, $message, $param) = @_;
119
120   $self->_publish(subscribers => \%subscribers, "pubsub::publish", $message, $param);
121 }
122
123 sub customize {
124   my ($self, $message, $param) = @_;
125
126   $self->_publish(customizers => \%customizers, "pubsub::customize", $message, $param);
127
128   if ($customizers{"*"}) {
129     for my $class (@{$customizers{"*"}}) {
130       if ($class->can($message)) {
131         if (!eval { $class->$message($param); 1 }) {
132           _log_error("pubsub::customize", "Call to method $message for " . _class_desc($class) . " threw an exception", { class => _class_desc($class), method => $message, message => $message, error => $@,  preload => 1 });
133         }
134       }
135     }
136   }
137 }
138
139 sub handle {
140   my ($class, $message, $handler) = @_;
141
142   $customizers{$message} = $handler;
143 }
144
145 sub subscribe {
146   my ($class, $message, $handler) = @_;
147
148   $subscribers{$message} = $handler;
149 }
150
151 1;
152
153 =head1 NAME
154
155 BSE::Notify - BSE's publish/subcribe system.
156
157 =head1 SYNOPSIS
158
159   use BSE::PubSub;
160
161   BSE::PubSub->publish(message_name => \%parameters);
162
163   BSE::PubSub->subscribe(message_name => \&code);
164   BSE::PubSub->subscribe(message_name => [ $class_object, $method ]);
165
166   BSE::PubSub->customize(custom_type => \%parameters);
167
168   BSE::PubSub->handle(custom_type => \&code);
169   BSE::PubSub->handle(custom_type => [ $class_object, $method ]);
170   BSE::PubSub->handle("*" => $class_object);
171
172   # in a config file somewhere
173   [subscribers]
174   messagename=classname,methodname,reserved
175
176   [customizers]
177   custom_type=classname,methodname,reserved
178
179 =head1 DESCRIPTION
180
181 A less messy, more extensible version of custom classes.
182
183 Advantages over the custom class interface:
184
185 =over
186
187 =item *
188
189 we're not passing a long list of positional arguments.
190
191 =item *
192
193 multiple handlers are better defined.
194
195 =back
196
197 The two methods are distinguished based on their purpose.
198
199 =over
200
201 =item *
202
203 C<publish> - sends off a notification, no response is expected.
204 Under some circumstances the message might be retained by the receiver
205 or passed onto another system.
206
207 =item *
208
209 C<customize> - requests customization of a data structure.  This is
210 intended for in-process use only.
211
212 =back
213
214 The return value of either method is unspecified and may change.
215
216 Typically handlers for messages will be configured in the
217 configuration file, but other parts of the system may request to
218 handle specific messages (or customizations), but this will be rare.
219
220 =cut