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

release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since d7bcff8 was d7bcff8, checked in by Nelson Elhage <nelhage@mit.edu>, 12 years ago
Keep a global list of all defined command names.
  • Property mode set to 100644
File size: 6.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 $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}
104
105sub _load_owlconf {
106    # load the config  file
107    if ( -r $BarnOwl::configfile ) {
108        undef $@;
109        package main;
110        do $BarnOwl::configfile;
111        if($@) {
112            BarnOwl::error("In startup: $@\n");
113            return;
114        }
115        package BarnOwl;
116        if(*BarnOwl::format_msg{CODE}) {
117            # if the config defines a legacy formatting function, add 'perl' as a style
118            BarnOwl::create_style("perl", BarnOwl::Style::Legacy->new(
119                "BarnOwl::format_msg",
120                "User-defined perl style that calls BarnOwl::format_msg"
121                . " with legacy global variable support",
122                1));
123             BarnOwl::set("-q default_style perl");
124        }
125    }
126}
127
128# These are the internal hooks called by the barnowl C code, which
129# take care of dispatching to the appropriate perl hooks, and deal
130# with compatibility by calling the old, fixed-name hooks.
131
132sub _startup {
133    _load_perl_commands();
134    _load_owlconf();
135
136    if(eval {require BarnOwl::ModuleLoader}) {
137        eval {
138            BarnOwl::ModuleLoader->load_all;
139        };
140        BarnOwl::error("$@") if $@;
141
142    } else {
143        BarnOwl::error("Can't load BarnOwl::ModuleLoader, loadable module support disabled:\n$@");
144    }
145   
146    $startup->run(0);
147    BarnOwl::startup() if *BarnOwl::startup{CODE};
148}
149
150sub _shutdown {
151    $shutdown->run;
152   
153    BarnOwl::shutdown() if *BarnOwl::shutdown{CODE};
154}
155
156sub _receive_msg {
157    my $m = shift;
158
159    $receiveMessage->run($m);
160   
161    BarnOwl::receive_msg($m) if *BarnOwl::receive_msg{CODE};
162}
163
164sub _new_msg {
165    my $m = shift;
166
167    $newMessage->run($m);
168   
169    BarnOwl::new_msg($m) if *BarnOwl::new_msg{CODE};
170}
171
172sub _mainloop_hook {
173    $mainLoop->run;
174    BarnOwl::mainloop_hook() if *BarnOwl::mainloop_hook{CODE};
175}
176
177sub _get_blist {
178    return join("\n", $getBuddyList->run);
179}
180
181sub _get_quickstart {
182    return join("\n", $getQuickstart->run);
183}
184
185sub _new_command {
186    my $command = shift;
187    (my $symbol = $command) =~ s/-/_/g;
188    my $package = "BarnOwl";
189
190    if($symbol =~ m{^edit:(.+)$}) {
191        $symbol = $1;
192        $package = "BarnOwl::Editwin";
193    } else {
194        $symbol =~ s/:/_/;
195    }
196    {
197        no strict 'refs';
198        if(defined(*{"${package}::${symbol}"}{CODE})) {
199            return;
200        }
201        *{"${package}::${symbol}"} = sub {
202            if(@_ == 1 && $_[0] =~ m{\s}) {
203                carp "DEPRECATED: ${package}::${symbol}: Tokenizing argument on ' '.\n"
204                . "In future versions, the argument list will be passed to\n"
205                . "'$command' directly. Tokenize yourself, or use BarnOwl::command()\n"
206            }
207            BarnOwl::command($command . " " . join(" ", @_))
208          };
209        if(defined(*{"${package}::EXPORT_OK"}{ARRAY})
210          && !contains(*{"${package}::EXPORT_OK"}{ARRAY}, $symbol)) {
211            push @{*{"${package}::EXPORT_OK"}{ARRAY}}, $symbol;
212        }
213    }
214
215    if(!contains(\@BarnOwl::all_commands, $command)) {
216        push @BarnOwl::all_commands, $command;
217    }
218}
219
220sub contains {
221    my $list = shift;
222    my $what = shift;
223    return defined(first {$_ eq $what} @$list);
224}
225
2261;
Note: See TracBrowser for help on using the repository browser.