source: perl/lib/BarnOwl/Hooks.pm @ 42a0c8b

release-1.10release-1.8release-1.9
Last change on this file since 42a0c8b was b8a3e00, checked in by David Benjamin <davidben@mit.edu>, 13 years ago
Consistently use BarnOwl or barnowl BarnOwl refers to the program, barnowl is the executable and any other identifiers that are conventionally lowercase.
  • Property mode set to 100644
File size: 7.1 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
81use BarnOwl::MainLoopCompatHook;
82
83our $startup = BarnOwl::Hook->new;
84our $shutdown = BarnOwl::Hook->new;
85our $receiveMessage = BarnOwl::Hook->new;
86our $newMessage = BarnOwl::Hook->new;
87our $mainLoop = BarnOwl::MainLoopCompatHook->new;
88our $getBuddyList = BarnOwl::Hook->new;
89our $getQuickstart = BarnOwl::Hook->new;
90
91# Internal startup/shutdown routines called by the C code
92
93sub _load_perl_commands {
94    # Load builtin perl commands
95    BarnOwl::new_command(style => \&BarnOwl::Style::style_command,
96                       {
97                           summary => "creates a new style",
98                           usage   => "style <name> perl <function_name>",
99                           description =>
100                           "A style named <name> will be created that will\n" .
101                           "format messages using the perl function <function_name>.\n\n" .
102                           "SEE ALSO: show styles, view -s, filter -s\n\n" .
103                           "DEPRECATED in favor of BarnOwl::create_style(NAME, OBJECT)",
104                          });
105    BarnOwl::new_command('edit:complete' => \&BarnOwl::Completion::do_complete,
106                       {
107                           summary     => "Complete the word at point",
108                           usage       => "complete",
109                           description =>
110                           "This is the function responsible for tab-completion."
111                       });
112    BarnOwl::new_command('edit:help' => \&BarnOwl::Help::show_help,
113                       {
114                           summary     => "Display help for the current command",
115                           usage       => "help",
116                           description =>
117                           "Opens the help information on the current command.\n" .
118                           "Returns to the previous editing context afterwards.\n\n" .
119                           "SEE ALSO: help"
120                         });
121    BarnOwl::bindkey(editline => TAB => command => 'edit:complete');
122    BarnOwl::bindkey(editline => 'M-h' => command => 'edit:help');
123}
124
125sub _load_owlconf {
126    # load the config  file
127    if ( -r $BarnOwl::configfile ) {
128        undef $@;
129        package main;
130        do $BarnOwl::configfile;
131        if($@) {
132            BarnOwl::error("In startup: $@\n");
133            return;
134        }
135        package BarnOwl;
136        if(*BarnOwl::format_msg{CODE}) {
137            # if the config defines a legacy formatting function, add 'perl' as a style
138            BarnOwl::create_style("perl", BarnOwl::Style::Legacy->new(
139                "BarnOwl::format_msg",
140                "User-defined perl style that calls BarnOwl::format_msg"
141                . " with legacy global variable support",
142                1));
143             BarnOwl::set("-q default_style perl");
144        }
145    }
146}
147
148# These are the internal hooks called by the BarnOwl C code, which
149# take care of dispatching to the appropriate perl hooks, and deal
150# with compatibility by calling the old, fixed-name hooks.
151
152sub _startup {
153    _load_perl_commands();
154    _load_owlconf();
155
156    if(eval {require BarnOwl::ModuleLoader}) {
157        eval {
158            BarnOwl::ModuleLoader->load_all;
159        };
160        BarnOwl::error("$@") if $@;
161
162    } else {
163        BarnOwl::error("Can't load BarnOwl::ModuleLoader, loadable module support disabled:\n$@");
164    }
165   
166    $mainLoop->check_owlconf();
167    $startup->run(0);
168    BarnOwl::startup() if *BarnOwl::startup{CODE};
169}
170
171sub _shutdown {
172    $shutdown->run;
173   
174    BarnOwl::shutdown() if *BarnOwl::shutdown{CODE};
175}
176
177sub _receive_msg {
178    my $m = shift;
179
180    $receiveMessage->run($m);
181   
182    BarnOwl::receive_msg($m) if *BarnOwl::receive_msg{CODE};
183}
184
185sub _new_msg {
186    my $m = shift;
187
188    $newMessage->run($m);
189   
190    BarnOwl::new_msg($m) if *BarnOwl::new_msg{CODE};
191}
192
193sub _get_blist {
194    my @results = grep defined, $getBuddyList->run;
195    s/^\s+|\s+$//sg for (@results);
196    return join("\n", grep {length($_)} @results);
197}
198
199sub _get_quickstart {
200    return join("\n", $getQuickstart->run);
201}
202
203sub _new_command {
204    my $command = shift;
205    (my $symbol = $command) =~ s/-/_/g;
206    my $package = "BarnOwl";
207
208
209    if(!contains(\@BarnOwl::all_commands, $command)) {
210        push @BarnOwl::all_commands, $command;
211    }
212
213    if($symbol =~ m{^edit:(.+)$}) {
214        $symbol = $1;
215        $package = "BarnOwl::Editwin";
216    } else {
217        $symbol =~ s/:/_/;
218    }
219    {
220        no strict 'refs';
221        if(defined(*{"${package}::${symbol}"}{CODE})) {
222            return;
223        }
224        *{"${package}::${symbol}"} = sub {
225            if(@_ == 1 && $_[0] =~ m{\s}) {
226                carp "DEPRECATED: ${package}::${symbol}: Tokenizing argument on ' '.\n"
227                . "In future versions, the argument list will be passed to\n"
228                . "'$command' directly. Tokenize yourself, or use BarnOwl::command()\n";
229                BarnOwl::command("$command $_[0]");
230            } else {
231                BarnOwl::command($command, @_);
232            }
233          };
234        if(defined(*{"${package}::EXPORT_OK"}{ARRAY})
235          && !contains(*{"${package}::EXPORT_OK"}{ARRAY}, $symbol)) {
236            push @{*{"${package}::EXPORT_OK"}{ARRAY}}, $symbol;
237        }
238    }
239}
240
241sub contains {
242    my $list = shift;
243    my $what = shift;
244    return defined(first {$_ eq $what} @$list);
245}
246
2471;
Note: See TracBrowser for help on using the repository browser.