source: perl/lib/BarnOwl/Hooks.pm @ a38becd

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