source: perl/lib/BarnOwl/Hooks.pm

Last change on this file was 120dac7, checked in by Edward Z. Yang <ezyang@mit.edu>, 8 years ago
Added a hook for wakeup/user input. I wanted to add a hook that got called on all user-input, but any non-trivial use of that hook incurred too much overhead (about 7 ms per paragraph for entry into perl, and another 100 ms or so per paragraph for execution of the hook; tests run on pasting lorem ipusm, on linerva). This hook is called at most once a second (approximately).
  • Property mode set to 100644
File size: 8.0 KB
Line 
1use strict;
2use warnings;
3
4package BarnOwl::Hooks;
5
6use Carp;
7use List::Util qw(first);
8
9=head1 BarnOwl::Hooks
10
11=head1 DESCRIPTION
12
13C<BarnOwl::Hooks> exports a set of C<BarnOwl::Hook> objects made
14available by BarnOwl internally.
15
16=head2 USAGE
17
18Modules wishing to respond to events in BarnOwl should register
19functions with these hooks.
20
21=head2 EXPORTS
22
23None by default. Either import the hooks you need explicitly, or refer
24to them with fully-qualified names. Available hooks are:
25
26=over 4
27
28=item $startup
29
30Called on BarnOwl startup, and whenever modules are
31reloaded. Functions registered with the C<$startup> hook get a true
32argument if this is a reload, and false if this is a true startup
33
34=item $shutdown
35
36Called before BarnOwl shutdown
37
38=item $wakeup
39
40Called, at most once per second, on user input
41
42=item $receiveMessage
43
44Called with a C<BarnOwl::Message> object every time BarnOwl receives a
45new incoming message.
46
47=item $newMessage
48
49Called with a C<BarnOwl::Message> object every time BarnOwl appends
50I<any> new message to the message list.
51
52=item $mainLoop
53
54Called on every pass through the C<BarnOwl> main loop. This is
55guaranteed to be called at least once/sec and may be called more
56frequently.
57
58=item $getBuddyList
59
60Called to display buddy lists for all protocol handlers. The result
61from every function registered with this hook will be appended and
62displayed in a popup window, with zephyr formatting parsed.
63
64=item $awayOn
65
66Called, for all protocol handlers, to go away, with the away message,
67if any.
68
69=item $awayOff
70
71Called, for all protocol handlers, to come back from away.
72
73=item $getIsAway
74
75Called to check away status for all protocol handlers.  Protocol
76handlers should return a true value if any account of the user is away
77for the given protocol, and a false value otherwise.
78
79=item $getQuickstart
80
81Called by :show quickstart to display 2-5 lines of help on how to
82start using the protocol. The result from every function registered
83with this hook will be appended and displayed in an admin message,
84with zephyr formatting parsed. The format should be
85"@b(Protocol:)\nSome text.\nMore text.\n"
86
87=back
88
89=cut
90
91use Exporter;
92
93our @EXPORT_OK = qw($startup $shutdown
94                    $wakeup
95                    $receiveMessage $newMessage
96                    $mainLoop $getBuddyList
97                    $awayOn $awayOff $getIsAway
98                    $getQuickstart);
99
100our %EXPORT_TAGS = (all => [@EXPORT_OK]);
101
102use BarnOwl::MainLoopCompatHook;
103
104our $startup = BarnOwl::Hook->new;
105our $shutdown = BarnOwl::Hook->new;
106our $wakeup = BarnOwl::Hook->new;
107our $receiveMessage = BarnOwl::Hook->new;
108our $newMessage = BarnOwl::Hook->new;
109our $mainLoop = BarnOwl::MainLoopCompatHook->new;
110our $getBuddyList = BarnOwl::Hook->new;
111our $getQuickstart = BarnOwl::Hook->new;
112our $awayOn = BarnOwl::Hook->new;
113our $awayOff = BarnOwl::Hook->new;
114our $getIsAway = BarnOwl::Hook->new;
115
116# Internal startup/shutdown routines called by the C code
117
118sub _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
150sub _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
177sub _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
196sub _shutdown {
197    $shutdown->run;
198   
199    BarnOwl::shutdown() if *BarnOwl::shutdown{CODE};
200}
201
202sub _wakeup {
203    $wakeup->run;
204}
205
206sub _receive_msg {
207    my $m = shift;
208
209    $receiveMessage->run($m);
210   
211    BarnOwl::receive_msg($m) if *BarnOwl::receive_msg{CODE};
212}
213
214sub _new_msg {
215    my $m = shift;
216
217    $newMessage->run($m);
218   
219    BarnOwl::new_msg($m) if *BarnOwl::new_msg{CODE};
220}
221
222sub _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
228sub _get_quickstart {
229    return join("\n", $getQuickstart->run);
230}
231
232sub _away_on {
233    $awayOn->run(@_);
234}
235
236sub _away_off {
237    $awayOff->run();
238}
239
240sub _get_is_away {
241    my @is_away = grep { $_ } $getIsAway->run();
242    return scalar @is_away;
243}
244
245sub _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
283sub contains {
284    my $list = shift;
285    my $what = shift;
286    return defined(first {$_ eq $what} @$list);
287}
288
2891;
Note: See TracBrowser for help on using the repository browser.