source: perlwrap.pm @ 25729b2

barnowl_perlaimdebianrelease-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 25729b2 was 25729b2, checked in by Nelson Elhage <nelhage@mit.edu>, 18 years ago
Adding basic smartnarrow support for jabber, and infrastructure to make it extensible.
  • 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
13    bootstrap 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
189sub smartfilter {
190    die("smartfilter not supported for this message");
191}
192
193#####################################################################
194#####################################################################
195
196package owl::Message::Admin;
197
198@ISA = qw( owl::Message );
199
200sub header       { return shift->{"header"}; }
201
202#####################################################################
203#####################################################################
204
205package owl::Message::Generic;
206
207@ISA = qw( owl::Message );
208
209#####################################################################
210#####################################################################
211
212package owl::Message::AIM;
213
214@ISA = qw( owl::Message );
215
216# all non-loginout AIM messages are personal for now...
217sub is_personal { 
218    return !(shift->is_loginout);
219}
220
221#####################################################################
222#####################################################################
223
224package owl::Message::Zephyr;
225
226@ISA = qw( owl::Message );
227
228sub login_tty { 
229    my ($m) = @_;
230    return undef if (!$m->is_loginout);
231    return $m->fields->[2];
232}
233
234sub login_host { 
235    my ($m) = @_;
236    return undef if (!$m->is_loginout);
237    return $m->fields->[0];
238}
239
240sub zwriteline  { return shift->{"zwriteline"}; }
241
242sub zsig        { return shift->{"zsig"}; }
243
244sub is_ping     { return (lc(shift->opcode) eq "ping"); }
245
246sub is_personal { 
247    my ($m) = @_;
248    return ((lc($m->class) eq "message")
249            && (lc($m->instance) eq "personal")
250            && $m->is_private);
251}
252
253sub is_mail { 
254    my ($m) = @_;
255    return ((lc($m->class) eq "mail") && $m->is_private);
256}
257
258sub pretty_sender {
259    my ($m) = @_;
260    my $sender = $m->sender;
261    my $realm = owl::zephyr_getrealm();
262    $sender =~ s/\@$realm$//;
263    return $sender;
264}
265
266# These are arguably zephyr-specific
267sub class       { return shift->{"class"}; }
268sub instance    { return shift->{"instance"}; }
269sub realm       { return shift->{"realm"}; }
270sub opcode      { return shift->{"opcode"}; }
271sub host        { return shift->{"hostname"}; }
272sub hostname    { return shift->{"hostname"}; }
273sub header      { return shift->{"header"}; }
274sub auth        { return shift->{"auth"}; }
275sub fields      { return shift->{"fields"}; }
276sub zsig        { return shift->{"zsig"}; }
277
278#####################################################################
279#####################################################################
280################################################################################
281package owl;
282
283# Arrays of subrefs to be called at specific times.
284our @onStartSubs = ();
285our @onReceiveMsg = ();
286our @onMainLoop = ();
287our @onGetBuddyList = ();
288
289################################################################################
290# Mainloop hook and threading.
291################################################################################
292
293use threads;
294use threads::shared;
295
296# Shared thread shutdown flag.
297# Consider adding a reload flag, so threads that should persist across reloads
298# can distinguish the two events. We wouldn't want a reload to cause us to
299# log out of and in to a perl-based IM session.
300our $shutdown : shared;
301$shutdown = 0;
302our $reload : shared;
303$reload = 0;
304
305# Functions to call hook lists
306sub runHook($@)
307{
308    my $hook = shift;
309    my @args = @_;
310    $_->(@args) for (@$hook);
311}
312
313sub runHook_accumulate($@)
314{
315    my $hook = shift;
316    my @args = @_;
317    return join("\n", map {$_->(@args)} @$hook);
318}
319
320sub mainloop_hook
321{
322    runHook(\@onMainLoop);
323}
324
325################################################################################
326# Startup and Shutdown code
327################################################################################
328sub startup
329{
330# Modern versions of owl provides a great place to have startup stuff.
331# Put things in ~/.owl/startup
332    onStart();
333}
334
335sub shutdown
336{
337# Modern versions of owl provides a great place to have shutdown stuff.
338# Put things in ~/.owl/shutdown
339
340# At this point I use owl::shutdown to tell any auxillary threads that they
341# should terminate.
342    $shutdown = 1;
343    mainloop_hook();
344}
345
346#Run this on start and reload. Adds modules and runs their startup functions.
347sub onStart
348{
349    reload_init();
350    #So that the user's .owlconf can have startsubs, we don't clear
351    #onStartSubs; reload does however
352    @onReceiveMsg = ();
353    @onMainLoop = ();
354    @onGetBuddyList = ();
355
356    loadModules();
357    runHook(\@onStartSubs);
358}
359################################################################################
360# Reload Code, taken from /afs/sipb/user/jdaniel/project/owl/perl
361################################################################################
362sub reload_hook (@) 
363{
364   
365
366    onStart();
367    return 1;
368}
369
370sub reload 
371{
372    # Shutdown existing threads.
373    $reload = 1;
374    owl::mainloop_hook();
375    $reload = 0;
376    @onMainLoop = ();
377    @onStartSubs = ();
378   
379    # Do reload
380    package main;
381    if (do "$ENV{HOME}/.owlconf" && owl::reload_hook(@_))
382    {
383        return "owlconf reloaded";
384    } 
385    else
386    {
387        return "$ENV{HOME}/.owlconf load attempted, but error encountered:\n$@";
388    }
389    package owl;
390}
391
392sub reload_init () 
393{
394    owl::command('alias reload perl owl::reload()');
395    owl::command('bindkey global "C-x C-r" command reload');
396}
397
398################################################################################
399# Loads modules from ~/.owl/modules and owl's data directory
400################################################################################
401
402sub loadModules () {
403    my @modules;
404    my $rv;
405    foreach my $dir ( owl::get_data_dir() . "/owl/modules",
406                      $ENV{HOME} . "/.owl/modules" )
407    {
408        opendir( MODULES, $dir );
409
410        # source ./modules/*.pl
411        @modules = grep( /\.pl$/, readdir(MODULES) );
412
413        foreach my $mod (@modules) {
414            unless ($rv = do "$dir/$mod") {
415                owl::error("Couldn't load $dir/$mod:\n $@") if $@;
416                owl::error("Couldn't run $dir/$mod:\n $!") unless defined $rv;
417            }
418        }
419        closedir(MODULES);
420    }
421}
422
423
424
425################################################################################
426# Hooks into receive_msg()
427################################################################################
428
429sub receive_msg
430{
431    my $m = shift;
432    runHook(\@onReceiveMsg, $m);
433}
434
435################################################################################
436# Hooks into get_blist()
437################################################################################
438
439sub get_blist
440{
441    my $m = shift;
442    return runHook_accumulate(\@onGetBuddyList, $m);
443}
444
445# switch to package main when we're done
446package main;
447# alias the hooks
448foreach my $hook  qw (onStartSubs
449onReceiveMsg
450onMainLoop
451onGetBuddyList ) {
452  *{"main::".$hook} = \*{"owl::".$hook};
453}
454
455# load the config  file
456if (-r $owl::configfile) {
457do $owl::configfile or die $@;
458}
459
4601;
Note: See TracBrowser for help on using the repository browser.