1 | use strict; |
---|
2 | use warnings; |
---|
3 | |
---|
4 | package BarnOwl::Hooks; |
---|
5 | |
---|
6 | use Carp; |
---|
7 | use List::Util qw(first); |
---|
8 | |
---|
9 | =head1 BarnOwl::Hooks |
---|
10 | |
---|
11 | =head1 DESCRIPTION |
---|
12 | |
---|
13 | C<BarnOwl::Hooks> exports a set of C<BarnOwl::Hook> objects made |
---|
14 | available by BarnOwl internally. |
---|
15 | |
---|
16 | =head2 USAGE |
---|
17 | |
---|
18 | Modules wishing to respond to events in BarnOwl should register |
---|
19 | functions with these hooks. |
---|
20 | |
---|
21 | =head2 EXPORTS |
---|
22 | |
---|
23 | None by default. Either import the hooks you need explicitly, or refer |
---|
24 | to them with fully-qualified names. Available hooks are: |
---|
25 | |
---|
26 | =over 4 |
---|
27 | |
---|
28 | =item $startup |
---|
29 | |
---|
30 | Called on BarnOwl startup, and whenever modules are |
---|
31 | reloaded. Functions registered with the C<$startup> hook get a true |
---|
32 | argument if this is a reload, and false if this is a true startup |
---|
33 | |
---|
34 | =item $shutdown |
---|
35 | |
---|
36 | Called before BarnOwl shutdown |
---|
37 | |
---|
38 | =item $wakeup |
---|
39 | |
---|
40 | Called, at most once per second, on user input |
---|
41 | |
---|
42 | =item $receiveMessage |
---|
43 | |
---|
44 | Called with a C<BarnOwl::Message> object every time BarnOwl receives a |
---|
45 | new incoming message. |
---|
46 | |
---|
47 | =item $newMessage |
---|
48 | |
---|
49 | Called with a C<BarnOwl::Message> object every time BarnOwl appends |
---|
50 | I<any> new message to the message list. |
---|
51 | |
---|
52 | =item $mainLoop |
---|
53 | |
---|
54 | Called on every pass through the C<BarnOwl> main loop. This is |
---|
55 | guaranteed to be called at least once/sec and may be called more |
---|
56 | frequently. |
---|
57 | |
---|
58 | =item $getBuddyList |
---|
59 | |
---|
60 | Called to display buddy lists for all protocol handlers. The result |
---|
61 | from every function registered with this hook will be appended and |
---|
62 | displayed in a popup window, with zephyr formatting parsed. |
---|
63 | |
---|
64 | =item $awayOn |
---|
65 | |
---|
66 | Called, for all protocol handlers, to go away, with the away message, |
---|
67 | if any. |
---|
68 | |
---|
69 | =item $awayOff |
---|
70 | |
---|
71 | Called, for all protocol handlers, to come back from away. |
---|
72 | |
---|
73 | =item $getIsAway |
---|
74 | |
---|
75 | Called to check away status for all protocol handlers. Protocol |
---|
76 | handlers should return a true value if any account of the user is away |
---|
77 | for the given protocol, and a false value otherwise. |
---|
78 | |
---|
79 | =item $getQuickstart |
---|
80 | |
---|
81 | Called by :show quickstart to display 2-5 lines of help on how to |
---|
82 | start using the protocol. The result from every function registered |
---|
83 | with this hook will be appended and displayed in an admin message, |
---|
84 | with zephyr formatting parsed. The format should be |
---|
85 | "@b(Protocol:)\nSome text.\nMore text.\n" |
---|
86 | |
---|
87 | =back |
---|
88 | |
---|
89 | =cut |
---|
90 | |
---|
91 | use Exporter; |
---|
92 | |
---|
93 | our @EXPORT_OK = qw($startup $shutdown |
---|
94 | $wakeup |
---|
95 | $receiveMessage $newMessage |
---|
96 | $mainLoop $getBuddyList |
---|
97 | $awayOn $awayOff $getIsAway |
---|
98 | $getQuickstart); |
---|
99 | |
---|
100 | our %EXPORT_TAGS = (all => [@EXPORT_OK]); |
---|
101 | |
---|
102 | use BarnOwl::MainLoopCompatHook; |
---|
103 | |
---|
104 | our $startup = BarnOwl::Hook->new; |
---|
105 | our $shutdown = BarnOwl::Hook->new; |
---|
106 | our $wakeup = BarnOwl::Hook->new; |
---|
107 | our $receiveMessage = BarnOwl::Hook->new; |
---|
108 | our $newMessage = BarnOwl::Hook->new; |
---|
109 | our $mainLoop = BarnOwl::MainLoopCompatHook->new; |
---|
110 | our $getBuddyList = BarnOwl::Hook->new; |
---|
111 | our $getQuickstart = BarnOwl::Hook->new; |
---|
112 | our $awayOn = BarnOwl::Hook->new; |
---|
113 | our $awayOff = BarnOwl::Hook->new; |
---|
114 | our $getIsAway = BarnOwl::Hook->new; |
---|
115 | |
---|
116 | # Internal startup/shutdown routines called by the C code |
---|
117 | |
---|
118 | sub _load_perl_commands { |
---|
119 | # Load builtin perl commands |
---|
120 | BarnOwl::new_command(style => \&BarnOwl::Style::style_command, |
---|
121 | { |
---|
122 | summary => "creates a new style", |
---|
123 | usage => "style <name> perl <function_name>", |
---|
124 | description => |
---|
125 | "A style named <name> will be created that will\n" . |
---|
126 | "format messages using the perl function <function_name>.\n\n" . |
---|
127 | "SEE ALSO: show styles, view -s, filter -s\n\n" . |
---|
128 | "DEPRECATED in favor of BarnOwl::create_style(NAME, OBJECT)", |
---|
129 | }); |
---|
130 | BarnOwl::new_command('edit:complete' => \&BarnOwl::Completion::do_complete, |
---|
131 | { |
---|
132 | summary => "Complete the word at point", |
---|
133 | usage => "complete", |
---|
134 | description => |
---|
135 | "This is the function responsible for tab-completion." |
---|
136 | }); |
---|
137 | BarnOwl::new_command('edit:help' => \&BarnOwl::Help::show_help, |
---|
138 | { |
---|
139 | summary => "Display help for the current command", |
---|
140 | usage => "help", |
---|
141 | description => |
---|
142 | "Opens the help information on the current command.\n" . |
---|
143 | "Returns to the previous editing context afterwards.\n\n" . |
---|
144 | "SEE ALSO: help" |
---|
145 | }); |
---|
146 | BarnOwl::bindkey(editline => TAB => command => 'edit:complete'); |
---|
147 | BarnOwl::bindkey(editline => 'M-h' => command => 'edit:help'); |
---|
148 | } |
---|
149 | |
---|
150 | sub _load_owlconf { |
---|
151 | # load the config file |
---|
152 | if ( -r $BarnOwl::configfile ) { |
---|
153 | undef $@; |
---|
154 | package main; |
---|
155 | do $BarnOwl::configfile; |
---|
156 | if($@) { |
---|
157 | BarnOwl::error("In startup: $@\n"); |
---|
158 | return; |
---|
159 | } |
---|
160 | package BarnOwl; |
---|
161 | if(*BarnOwl::format_msg{CODE}) { |
---|
162 | # if the config defines a legacy formatting function, add 'perl' as a style |
---|
163 | BarnOwl::create_style("perl", BarnOwl::Style::Legacy->new( |
---|
164 | "BarnOwl::format_msg", |
---|
165 | "User-defined perl style that calls BarnOwl::format_msg" |
---|
166 | . " with legacy global variable support", |
---|
167 | 1)); |
---|
168 | BarnOwl::set("-q default_style perl"); |
---|
169 | } |
---|
170 | } |
---|
171 | } |
---|
172 | |
---|
173 | # These are the internal hooks called by the BarnOwl C code, which |
---|
174 | # take care of dispatching to the appropriate perl hooks, and deal |
---|
175 | # with compatibility by calling the old, fixed-name hooks. |
---|
176 | |
---|
177 | sub _startup { |
---|
178 | _load_perl_commands(); |
---|
179 | _load_owlconf(); |
---|
180 | |
---|
181 | if(eval {require BarnOwl::ModuleLoader}) { |
---|
182 | eval { |
---|
183 | BarnOwl::ModuleLoader->load_all; |
---|
184 | }; |
---|
185 | BarnOwl::error("$@") if $@; |
---|
186 | |
---|
187 | } else { |
---|
188 | BarnOwl::error("Can't load BarnOwl::ModuleLoader, loadable module support disabled:\n$@"); |
---|
189 | } |
---|
190 | |
---|
191 | $mainLoop->check_owlconf(); |
---|
192 | $startup->run(0); |
---|
193 | BarnOwl::startup() if *BarnOwl::startup{CODE}; |
---|
194 | } |
---|
195 | |
---|
196 | sub _shutdown { |
---|
197 | $shutdown->run; |
---|
198 | |
---|
199 | BarnOwl::shutdown() if *BarnOwl::shutdown{CODE}; |
---|
200 | } |
---|
201 | |
---|
202 | sub _wakeup { |
---|
203 | $wakeup->run; |
---|
204 | } |
---|
205 | |
---|
206 | sub _receive_msg { |
---|
207 | my $m = shift; |
---|
208 | |
---|
209 | $receiveMessage->run($m); |
---|
210 | |
---|
211 | BarnOwl::receive_msg($m) if *BarnOwl::receive_msg{CODE}; |
---|
212 | } |
---|
213 | |
---|
214 | sub _new_msg { |
---|
215 | my $m = shift; |
---|
216 | |
---|
217 | $newMessage->run($m); |
---|
218 | |
---|
219 | BarnOwl::new_msg($m) if *BarnOwl::new_msg{CODE}; |
---|
220 | } |
---|
221 | |
---|
222 | sub _get_blist { |
---|
223 | my @results = grep defined, $getBuddyList->run; |
---|
224 | s/^\s+|\s+$//sg for (@results); |
---|
225 | return join("\n", grep {length($_)} @results); |
---|
226 | } |
---|
227 | |
---|
228 | sub _get_quickstart { |
---|
229 | return join("\n", $getQuickstart->run); |
---|
230 | } |
---|
231 | |
---|
232 | sub _away_on { |
---|
233 | $awayOn->run(@_); |
---|
234 | } |
---|
235 | |
---|
236 | sub _away_off { |
---|
237 | $awayOff->run(); |
---|
238 | } |
---|
239 | |
---|
240 | sub _get_is_away { |
---|
241 | my @is_away = grep { $_ } $getIsAway->run(); |
---|
242 | return scalar @is_away; |
---|
243 | } |
---|
244 | |
---|
245 | sub _new_command { |
---|
246 | my $command = shift; |
---|
247 | (my $symbol = $command) =~ s/-/_/g; |
---|
248 | my $package = "BarnOwl"; |
---|
249 | |
---|
250 | |
---|
251 | if(!contains(\@BarnOwl::all_commands, $command)) { |
---|
252 | push @BarnOwl::all_commands, $command; |
---|
253 | } |
---|
254 | |
---|
255 | if($symbol =~ m{^edit:(.+)$}) { |
---|
256 | $symbol = $1; |
---|
257 | $package = "BarnOwl::Editwin"; |
---|
258 | } else { |
---|
259 | $symbol =~ s/:/_/; |
---|
260 | } |
---|
261 | { |
---|
262 | no strict 'refs'; |
---|
263 | if(defined(*{"${package}::${symbol}"}{CODE})) { |
---|
264 | return; |
---|
265 | } |
---|
266 | *{"${package}::${symbol}"} = sub { |
---|
267 | if(@_ == 1 && $_[0] =~ m{\s}) { |
---|
268 | carp "DEPRECATED: ${package}::${symbol}: Tokenizing argument on ' '.\n" |
---|
269 | . "In future versions, the argument list will be passed to\n" |
---|
270 | . "'$command' directly. Tokenize yourself, or use BarnOwl::command()\n"; |
---|
271 | BarnOwl::command("$command $_[0]"); |
---|
272 | } else { |
---|
273 | BarnOwl::command($command, @_); |
---|
274 | } |
---|
275 | }; |
---|
276 | if(defined(*{"${package}::EXPORT_OK"}{ARRAY}) |
---|
277 | && !contains(*{"${package}::EXPORT_OK"}{ARRAY}, $symbol)) { |
---|
278 | push @{*{"${package}::EXPORT_OK"}{ARRAY}}, $symbol; |
---|
279 | } |
---|
280 | } |
---|
281 | } |
---|
282 | |
---|
283 | sub contains { |
---|
284 | my $list = shift; |
---|
285 | my $what = shift; |
---|
286 | return defined(first {$_ eq $what} @$list); |
---|
287 | } |
---|
288 | |
---|
289 | 1; |
---|