source: perlwrap.pm @ a55abb3

barnowl_perlaimdebianrelease-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since a55abb3 was f2f5815, checked in by Nelson Elhage <nelhage@mit.edu>, 18 years ago
Refactoring hook code
  • Property mode set to 100644
File size: 11.9 KB
Line 
1# $Id$
2#
3# This is all linked into the binary and evaluated when perl starts up...
4#
5#####################################################################
6#####################################################################
7
8package owl;
9
10
11BEGIN {
12# bootstrap in C bindings and glue
13bootstrap owl 1.2;
14};
15
16use lib(get_data_dir()."/owl/lib");
17use lib($::ENV{'HOME'}."/.owl/lib");
18
19
20our $configfile = $::ENV{'HOME'}."/.owlconf";
21
22# populate global variable space for legacy owlconf files
23sub _format_msg_legacy_wrap {
24    my ($m) = @_;
25    $m->legacy_populate_global();
26    return &owl::format_msg($m);
27}
28
29# populate global variable space for legacy owlconf files
30sub _receive_msg_legacy_wrap {
31    my ($m) = @_;
32    $m->legacy_populate_global();
33    return &owl::receive_msg($m);
34}
35
36# make owl::<command>("foo") be aliases to owl::command("<command> foo");
37sub AUTOLOAD {
38    my $called = $AUTOLOAD;
39    $called =~ s/.*:://;
40    $called =~ s/_/-/g;
41    return &owl::command("$called ".join(" ",@_));
42}
43
44=head2 new_command NAME FUNC [{ARGS}]
45
46Add a new owl command. When owl executes the command NAME, FUNC will
47be called with the arguments passed to the command, with NAME as the
48first argument.
49
50ARGS should be a hashref containing any or all of C<summary>,
51C<usage>, or C<description> keys.
52
53=cut
54
55sub new_command {
56    my $name = shift;
57    my $func = shift;
58    my $args = shift || {};
59    my %args = (
60        summary     => undef,
61        usage       => undef,
62        description => undef,
63        %{$args}
64    );
65
66    owl::new_command_internal($name, $func, $args{summary}, $args{usage}, $args{description});
67}
68
69#####################################################################
70#####################################################################
71
72package owl::Message;
73
74sub new {
75    my $class = shift;
76    my %args = (@_);
77    if($class eq __PACKAGE__ && $args{type}) {
78        $class = "owl::Message::" . ucfirst $args{type};
79    }
80    return bless {%args}, $class;
81}
82
83sub type        { return shift->{"type"}; }
84sub direction   { return shift->{"direction"}; }
85sub time        { return shift->{"time"}; }
86sub id          { return shift->{"id"}; }
87sub body        { return shift->{"body"}; }
88sub sender      { return shift->{"sender"}; }
89sub recipient   { return shift->{"recipient"}; }
90sub login       { return shift->{"login"}; }
91sub is_private  { return shift->{"private"}; }
92
93sub is_login    { return shift->login eq "login"; }
94sub is_logout   { return shift->login eq "logout"; }
95sub is_loginout { my $m=shift; return ($m->is_login or $m->is_logout); }
96sub is_incoming { return (shift->{"direction"} eq "in"); }
97sub is_outgoing { return (shift->{"direction"} eq "out"); }
98
99sub is_deleted  { return shift->{"deleted"}; }
100
101sub is_admin    { return (shift->{"type"} eq "admin"); }
102sub is_generic  { return (shift->{"type"} eq "generic"); }
103sub is_zephyr   { return (shift->{"type"} eq "zephyr"); }
104sub is_aim      { return (shift->{"type"} eq "aim"); }
105sub is_jabber   { return (shift->{"type"} eq "jabber"); }
106sub is_icq      { return (shift->{"type"} eq "icq"); }
107sub is_yahoo    { return (shift->{"type"} eq "yahoo"); }
108sub is_msn      { return (shift->{"type"} eq "msn"); }
109sub is_loopback { return (shift->{"type"} eq "loopback"); }
110
111# These are overridden by appropriate message types
112sub is_ping     { return 0; }
113sub is_mail     { return 0; }
114sub is_personal { return shift->is_private; }
115sub class       { return undef; }
116sub instance    { return undef; }
117sub realm       { return undef; }
118sub opcode      { return undef; }
119sub header      { return undef; }
120sub host        { return undef; }
121sub hostname    { return undef; }
122sub auth        { return undef; }
123sub fields      { return undef; }
124sub zsig        { return undef; }
125sub zwriteline  { return undef; }
126sub login_host  { return undef; }
127sub login_tty   { return undef; }
128
129sub pretty_sender { return shift->sender; }
130
131sub delete {
132    my ($m) = @_;
133    &owl::command("delete --id ".$m->id);
134}
135
136sub undelete {
137    my ($m) = @_;
138    &owl::command("undelete --id ".$m->id);
139}
140
141# Serializes the message into something similar to the zwgc->vt format
142sub serialize {
143    my ($this) = @_;
144    my $s;
145    for my $f (keys %$this) {
146        my $val = $this->{$f};
147        if (ref($val) eq "ARRAY") {
148            for my $i (0..@$val-1) {
149                my $aval;
150                $aval = $val->[$i];
151                $aval =~ s/\n/\n$f.$i: /g;
152                $s .= "$f.$i: $aval\n";   
153            }
154        } else {
155            $val =~ s/\n/\n$f: /g;
156            $s .= "$f: $val\n";
157        }
158    }
159    return $s;
160}
161
162# Populate the annoying legacy global variables
163sub legacy_populate_global {
164    my ($m) = @_;
165    $owl::direction  = $m->direction ;
166    $owl::type       = $m->type      ;
167    $owl::id         = $m->id        ;
168    $owl::class      = $m->class     ;
169    $owl::instance   = $m->instance  ;
170    $owl::recipient  = $m->recipient ;
171    $owl::sender     = $m->sender    ;
172    $owl::realm      = $m->realm     ;
173    $owl::opcode     = $m->opcode    ;
174    $owl::zsig       = $m->zsig      ;
175    $owl::msg        = $m->body      ;
176    $owl::time       = $m->time      ;
177    $owl::host       = $m->host      ;
178    $owl::login      = $m->login     ;
179    $owl::auth       = $m->auth      ;
180    if ($m->fields) {
181        @owl::fields = @{$m->fields};
182        @main::fields = @{$m->fields};
183    } else {
184        @owl::fields = undef;
185        @main::fields = undef;
186    }
187}
188
189#####################################################################
190#####################################################################
191
192package owl::Message::Admin;
193
194@ISA = qw( owl::Message );
195
196sub header       { return shift->{"header"}; }
197
198#####################################################################
199#####################################################################
200
201package owl::Message::Generic;
202
203@ISA = qw( owl::Message );
204
205#####################################################################
206#####################################################################
207
208package owl::Message::AIM;
209
210@ISA = qw( owl::Message );
211
212# all non-loginout AIM messages are personal for now...
213sub is_personal { 
214    return !(shift->is_loginout);
215}
216
217#####################################################################
218#####################################################################
219
220package owl::Message::Zephyr;
221
222@ISA = qw( owl::Message );
223
224sub login_tty { 
225    my ($m) = @_;
226    return undef if (!$m->is_loginout);
227    return $m->fields->[2];
228}
229
230sub login_host { 
231    my ($m) = @_;
232    return undef if (!$m->is_loginout);
233    return $m->fields->[0];
234}
235
236sub zwriteline  { return shift->{"zwriteline"}; }
237
238sub zsig        { return shift->{"zsig"}; }
239
240sub is_ping     { return (lc(shift->opcode) eq "ping"); }
241
242sub is_personal { 
243    my ($m) = @_;
244    return ((lc($m->class) eq "message")
245            && (lc($m->instance) eq "personal")
246            && $m->is_private);
247}
248
249sub is_mail { 
250    my ($m) = @_;
251    return ((lc($m->class) eq "mail") && $m->is_private);
252}
253
254sub pretty_sender {
255    my ($m) = @_;
256    my $sender = $m->sender;
257    my $realm = owl::zephyr_getrealm();
258    $sender =~ s/\@$realm$//;
259    return $sender;
260}
261
262# These are arguably zephyr-specific
263sub class       { return shift->{"class"}; }
264sub instance    { return shift->{"instance"}; }
265sub realm       { return shift->{"realm"}; }
266sub opcode      { return shift->{"opcode"}; }
267sub host        { return shift->{"hostname"}; }
268sub hostname    { return shift->{"hostname"}; }
269sub header      { return shift->{"header"}; }
270sub auth        { return shift->{"auth"}; }
271sub fields      { return shift->{"fields"}; }
272sub zsig        { return shift->{"zsig"}; }
273
274#####################################################################
275#####################################################################
276
277package owl::Message::Jabber;
278
279@ISA = qw( owl::Message );
280
281#####################################################################
282#####################################################################
283################################################################################
284package owl;
285
286# Arrays of subrefs to be called at specific times.
287our @onStartSubs = ();
288our @onReceiveMsg = ();
289our @onMainLoop = ();
290our @onGetBuddyList = ();
291
292################################################################################
293# Mainloop hook and threading.
294################################################################################
295
296use threads;
297use threads::shared;
298
299# Shared thread shutdown flag.
300# Consider adding a reload flag, so threads that should persist across reloads
301# can distinguish the two events. We wouldn't want a reload to cause us to
302# log out of and in to a perl-based IM session.
303our $shutdown : shared;
304$shutdown = 0;
305our $reload : shared;
306$reload = 0;
307
308# Functions to call hook lists
309sub runHook($@)
310{
311    my $hook = shift;
312    my @args = @_;
313    $_->(@args) for (@$hook);
314}
315
316sub runHook_accumulate($@)
317{
318    my $hook = shift;
319    use Data::Dumper;
320    my @args = @_;
321    return join("\n", map {$_->(@args)} @$hook);
322}
323
324sub mainloop_hook
325{
326    runHook(\@onMainLoop);
327}
328
329################################################################################
330# Startup and Shutdown code
331################################################################################
332sub startup
333{
334# Modern versions of owl provides a great place to have startup stuff.
335# Put things in ~/.owl/startup
336    onStart();
337}
338
339sub shutdown
340{
341# Modern versions of owl provides a great place to have shutdown stuff.
342# Put things in ~/.owl/shutdown
343
344# At this point I use owl::shutdown to tell any auxillary threads that they
345# should terminate.
346    $shutdown = 1;
347    mainloop_hook();
348}
349
350#Run this on start and reload. Adds modules and runs their startup functions.
351sub onStart
352{
353    reload_init();
354    #So that the user's .owlconf can have startsubs, we don't clear
355    #onStartSubs; reload does however
356    @onReceiveMsg = ();
357    @onMainLoop = ();
358    @onGetBuddyList = ();
359
360    loadModules();
361    runHook(\@onStartSubs);
362}
363################################################################################
364# Reload Code, taken from /afs/sipb/user/jdaniel/project/owl/perl
365################################################################################
366sub reload_hook (@) 
367{
368   
369
370    onStart();
371    return 1;
372}
373
374sub reload 
375{
376    # Shutdown existing threads.
377    $reload = 1;
378    owl::mainloop_hook();
379    $reload = 0;
380    @onMainLoop = ();
381  @onStartSubs = ();
382   
383    # Do reload
384    package main;
385    if (do "$ENV{HOME}/.owlconf" && owl::reload_hook(@_))
386    {
387        return "owlconf reloaded";
388    } 
389    else
390    {
391        return "$ENV{HOME}/.owlconf load attempted, but error encountered:\n$@";
392    }
393package owl;
394}
395
396sub reload_init () 
397{
398    owl::command('alias reload perl owl::reload()');
399    owl::command('bindkey global "C-x C-r" command reload');
400}
401
402################################################################################
403# Loads modules from ~/.owl/modules and owl's data directory
404################################################################################
405
406sub loadModules () {
407    my @modules;
408    foreach my $dir ( owl::get_data_dir() . "/owl/modules",
409        $ENV{HOME} . "/.owl/modules" )
410    {
411        opendir( MODULES, $dir );
412
413        # source ./modules/*.pl
414        @modules = grep( /\.pl$/, readdir(MODULES) );
415
416        foreach my $mod (@modules) {
417            do "$dir/$mod";
418        }
419        closedir(MODULES);
420    }
421
422}
423
424
425
426################################################################################
427# Hooks into receive_msg()
428################################################################################
429
430sub receive_msg
431{
432    my $m = shift;
433    runHook(\@onReceiveMsg, $m);
434}
435
436################################################################################
437# Hooks into get_blist()
438################################################################################
439
440sub get_blist
441{
442    my $m = shift;
443    return runHook_accumulate(\@onGetBuddyList, $m);
444}
445
446# switch to package main when we're done
447package main;
448# alias the hooks
449foreach my $hook  qw (onStartSubs
450onReceiveMsg
451onMainLoop
452onGetBuddyList ) {
453  *{"main::".$hook} = \*{"owl::".$hook};
454}
455
456# load the config  file
457if (-r $owl::configfile) {
458do $owl::configfile or die $@;
459}
460
4611;
Note: See TracBrowser for help on using the repository browser.