source: perl/lib/BarnOwl/Hooks.pm @ 4d26776

release-1.10release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 4d26776 was 7574eed, checked in by Nelson Elhage <nelhage@mit.edu>, 14 years ago
_get_blist: Ignore undefined or empty buddy list entries.
  • Property mode set to 100644
File size: 6.6 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 $getQuickstart
61
62Called by :show quickstart to display 2-5 lines of help on how to
63start using the protocol. The result from every function registered
64with this hook will be appended and displayed in an admin message,
65with zephyr formatting parsed. The format should be
66"@b(Protocol:)\nSome text.\nMore text.\n"
67
68=back
69
70=cut
71
72use Exporter;
73
74our @EXPORT_OK = qw($startup $shutdown
75                    $receiveMessage $newMessage
76                    $mainLoop $getBuddyList
77                    $getQuickstart);
78
79our %EXPORT_TAGS = (all => [@EXPORT_OK]);
80
81our $startup = BarnOwl::Hook->new;
82our $shutdown = BarnOwl::Hook->new;
83our $receiveMessage = BarnOwl::Hook->new;
84our $newMessage = BarnOwl::Hook->new;
85our $mainLoop = BarnOwl::Hook->new;
86our $getBuddyList = BarnOwl::Hook->new;
87our $getQuickstart = BarnOwl::Hook->new;
88
89# Internal startup/shutdown routines called by the C code
90
91sub _load_perl_commands {
92    # Load builtin perl commands
93    BarnOwl::new_command(style => \&BarnOwl::Style::style_command,
94                       {
95                           summary => "creates a new style",
96                           usage   => "style <name> perl <function_name>",
97                           description =>
98                           "A style named <name> will be created that will\n" .
99                           "format messages using the perl function <function_name>.\n\n" .
100                           "SEE ALSO: show styles, view -s, filter -s\n\n" .
101                           "DEPRECATED in favor of BarnOwl::create_style(NAME, OBJECT)",
102                          });
103    BarnOwl::new_command('edit:complete' => \&BarnOwl::Completion::do_complete,
104                       {
105                           summary     => "Complete the word at point",
106                           usage       => "complete",
107                           description =>
108                           "This is the function responsible for tab-completion."
109                       });
110    BarnOwl::bindkey(editline => TAB => command => 'edit:complete');
111}
112
113sub _load_owlconf {
114    # load the config  file
115    if ( -r $BarnOwl::configfile ) {
116        undef $@;
117        package main;
118        do $BarnOwl::configfile;
119        if($@) {
120            BarnOwl::error("In startup: $@\n");
121            return;
122        }
123        package BarnOwl;
124        if(*BarnOwl::format_msg{CODE}) {
125            # if the config defines a legacy formatting function, add 'perl' as a style
126            BarnOwl::create_style("perl", BarnOwl::Style::Legacy->new(
127                "BarnOwl::format_msg",
128                "User-defined perl style that calls BarnOwl::format_msg"
129                . " with legacy global variable support",
130                1));
131             BarnOwl::set("-q default_style perl");
132        }
133    }
134}
135
136# These are the internal hooks called by the barnowl C code, which
137# take care of dispatching to the appropriate perl hooks, and deal
138# with compatibility by calling the old, fixed-name hooks.
139
140sub _startup {
141    _load_perl_commands();
142    _load_owlconf();
143
144    if(eval {require BarnOwl::ModuleLoader}) {
145        eval {
146            BarnOwl::ModuleLoader->load_all;
147        };
148        BarnOwl::error("$@") if $@;
149
150    } else {
151        BarnOwl::error("Can't load BarnOwl::ModuleLoader, loadable module support disabled:\n$@");
152    }
153   
154    $startup->run(0);
155    BarnOwl::startup() if *BarnOwl::startup{CODE};
156}
157
158sub _shutdown {
159    $shutdown->run;
160   
161    BarnOwl::shutdown() if *BarnOwl::shutdown{CODE};
162}
163
164sub _receive_msg {
165    my $m = shift;
166
167    $receiveMessage->run($m);
168   
169    BarnOwl::receive_msg($m) if *BarnOwl::receive_msg{CODE};
170}
171
172sub _new_msg {
173    my $m = shift;
174
175    $newMessage->run($m);
176   
177    BarnOwl::new_msg($m) if *BarnOwl::new_msg{CODE};
178}
179
180sub _mainloop_hook {
181    $mainLoop->run;
182    BarnOwl::mainloop_hook() if *BarnOwl::mainloop_hook{CODE};
183}
184
185sub _get_blist {
186    my @results = grep defined, $getBuddyList->run;
187    s/^\s+|\s+$//sg for (@results);
188    return join("\n", grep {length($_)} @results);
189}
190
191sub _get_quickstart {
192    return join("\n", $getQuickstart->run);
193}
194
195sub _new_command {
196    my $command = shift;
197    (my $symbol = $command) =~ s/-/_/g;
198    my $package = "BarnOwl";
199
200
201    if(!contains(\@BarnOwl::all_commands, $command)) {
202        push @BarnOwl::all_commands, $command;
203    }
204
205    if($symbol =~ m{^edit:(.+)$}) {
206        $symbol = $1;
207        $package = "BarnOwl::Editwin";
208    } else {
209        $symbol =~ s/:/_/;
210    }
211    {
212        no strict 'refs';
213        if(defined(*{"${package}::${symbol}"}{CODE})) {
214            return;
215        }
216        *{"${package}::${symbol}"} = sub {
217            if(@_ == 1 && $_[0] =~ m{\s}) {
218                carp "DEPRECATED: ${package}::${symbol}: Tokenizing argument on ' '.\n"
219                . "In future versions, the argument list will be passed to\n"
220                . "'$command' directly. Tokenize yourself, or use BarnOwl::command()\n";
221                BarnOwl::command("$command $_[0]");
222            } else {
223                BarnOwl::command($command, @_);
224            }
225          };
226        if(defined(*{"${package}::EXPORT_OK"}{ARRAY})
227          && !contains(*{"${package}::EXPORT_OK"}{ARRAY}, $symbol)) {
228            push @{*{"${package}::EXPORT_OK"}{ARRAY}}, $symbol;
229        }
230    }
231}
232
233sub contains {
234    my $list = shift;
235    my $what = shift;
236    return defined(first {$_ eq $what} @$list);
237}
238
2391;
Note: See TracBrowser for help on using the repository browser.