source: perlwrap.pm @ afd0fd5

barnowl_perlaimdebianrelease-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since afd0fd5 was 1cf32e7d, checked in by Nelson Elhage <nelhage@mit.edu>, 14 years ago
Merging the PAR branch back to trunk. r20272@phanatique (orig r665): nelhage | 2007-03-14 19:25:05 -0400 Branching for the PAR module rewrite. r20274@phanatique (orig r667): nelhage | 2007-03-16 00:45:19 -0400 First phase of the module rewrite. Internals now (IMO) somewhat cleaner. r19586@phanatique: nelhage | 2007-03-14 20:35:39 -0400 First pass at a cleaned up perlwrap.pm * Using a new hook style * Modules loaded by BarnOwl::ModuleLoader (not yet written) reload is unimplemented for now. If possible, I'd like it to live elsewhere. r19587@phanatique: nelhage | 2007-03-14 20:36:58 -0400 Switching to the new underscore internal hook names. r19592@phanatique: nelhage | 2007-03-16 00:34:00 -0400 Actually switch to _receive_msg r19593@phanatique: nelhage | 2007-03-16 00:34:27 -0400 Some minor cleanup of perlwrap.pm. Shoving fake entries into @INC. r19594@phanatique: nelhage | 2007-03-16 00:34:47 -0400 First revision of ModuleLoader. r20281@phanatique (orig r669): nelhage | 2007-03-17 14:48:02 -0400 r20279@phanatique: nelhage | 2007-03-17 14:46:56 -0400 For reasons I don't claim to understand, using the old-style new was throwing odd errors about undefined functions. r20286@phanatique (orig r670): nelhage | 2007-03-18 16:28:23 -0400 r20282@phanatique: nelhage | 2007-03-17 14:48:22 -0400 Report more errors when something goes wrong r20287@phanatique (orig r671): nelhage | 2007-03-18 16:28:31 -0400 r20285@phanatique: nelhage | 2007-03-18 16:28:18 -0400 Adding the new M::Iified jabber module. There isn't a target to build the PAR yet. r20291@phanatique (orig r672): nelhage | 2007-03-18 19:14:04 -0400 r20290@phanatique: nelhage | 2007-03-18 19:13:57 -0400 Adding a Module::Install plugin for building barnowl plugins. It needs a lot of improvement. r20309@phanatique (orig r673): nelhage | 2007-03-19 14:14:23 -0400 r20301@phanatique: nelhage | 2007-03-19 13:31:07 -0400 Changing the dependency on the par target, so we don't rebuild unless we need to. r20310@phanatique (orig r674): nelhage | 2007-03-19 14:14:33 -0400 r20303@phanatique: nelhage | 2007-03-19 13:32:25 -0400 Modifying the makefile to build and install perl modules r20643@phanatique (orig r677): nelhage | 2007-03-23 15:09:45 -0400 r20640@phanatique: nelhage | 2007-03-23 15:09:38 -0400 Implement loading of unpacked modules, and module reloading. r20645@phanatique (orig r678): nelhage | 2007-03-23 15:11:05 -0400 r20644@phanatique: nelhage | 2007-03-23 15:10:57 -0400 Tighten up the reloaded regex a little. r20649@phanatique (orig r679): nelhage | 2007-03-23 16:18:44 -0400 r20648@phanatique: nelhage | 2007-03-23 16:18:25 -0400 Correctly install modules on a clean install. r20655@phanatique (orig r680): nelhage | 2007-03-25 12:53:07 -0400 r20650@phanatique: nelhage | 2007-03-23 17:01:20 -0400 Still not sure why old-style new seems to be eiting us so much... r20656@phanatique (orig r681): nelhage | 2007-03-25 12:53:11 -0400 r20653@phanatique: nelhage | 2007-03-25 12:52:38 -0400 Let's not segfault if the user asks for a nonexistant style in .owl/startup r20657@phanatique (orig r682): nelhage | 2007-03-25 12:53:16 -0400 r20654@phanatique: nelhage | 2007-03-25 12:52:59 -0400 That line doesn't need to be there twice -- probably a mismerge r20706@phanatique (orig r683): nelhage | 2007-03-26 21:04:43 -0400 r20704@phanatique: nelhage | 2007-03-26 20:00:24 -0400 We don't need two package lines.. r20707@phanatique (orig r684): nelhage | 2007-03-26 21:04:54 -0400 r20705@phanatique: nelhage | 2007-03-26 21:04:37 -0400 Getting rid of indirect object syntax new calls. Quoting perlobj: > But what if there are no arguments? In that case, Perl must guess what > you want. Even worse, it must make that guess *at compile time*. Usually > Perl gets it right, but when it doesn't you get a function call compiled > as a method, or vice versa. This can introduce subtle bugs that are hard > to detect. > > For example, a call to a method "new" in indirect notation -- as C++ > programmers are wont to make -- can be miscompiled into a subroutine > call if there's already a "new" function in scope. You'd end up calling > the current package's "new" as a subroutine, rather than the desired > class's method. The compiler tries to cheat by remembering bareword > "require"s, but the grief when it messes up just isn't worth the years > of debugging it will take you to track down such subtle bugs. r20710@phanatique (orig r685): nelhage | 2007-03-26 21:14:41 -0400 r20708@phanatique: nelhage | 2007-03-26 21:11:34 -0400 Adding a reload-modules command r20711@phanatique (orig r686): nelhage | 2007-03-26 21:14:49 -0400 r20709@phanatique: nelhage | 2007-03-26 21:14:31 -0400 Moving Net::Jabber into Jabber.par r20714@phanatique (orig r687): nelhage | 2007-03-26 21:18:13 -0400 r20713@phanatique: nelhage | 2007-03-26 21:17:59 -0400 Don't install .svn dirs r20720@phanatique (orig r688): nelhage | 2007-03-27 22:04:10 -0400 r20719@phanatique: nelhage | 2007-03-27 22:04:03 -0400 Implementing an LRU cache of the message list fmtexts. This reduces memory usage by roughly 1MB/kilo-zephyrs in steady state. r20272@phanatique (orig r665): nelhage | 2007-03-14 19:25:05 -0400 Branching for the PAR module rewrite. r20274@phanatique (orig r667): nelhage | 2007-03-16 00:45:19 -0400 First phase of the module rewrite. Internals now (IMO) somewhat cleaner. r19586@phanatique: nelhage | 2007-03-14 20:35:39 -0400 First pass at a cleaned up perlwrap.pm * Using a new hook style * Modules loaded by BarnOwl::ModuleLoader (not yet written) reload is unimplemented for now. If possible, I'd like it to live elsewhere. r19587@phanatique: nelhage | 2007-03-14 20:36:58 -0400 Switching to the new underscore internal hook names. r19592@phanatique: nelhage | 2007-03-16 00:34:00 -0400 Actually switch to _receive_msg r19593@phanatique: nelhage | 2007-03-16 00:34:27 -0400 Some minor cleanup of perlwrap.pm. Shoving fake entries into @INC. r19594@phanatique: nelhage | 2007-03-16 00:34:47 -0400 First revision of ModuleLoader. r20281@phanatique (orig r669): nelhage | 2007-03-17 14:48:02 -0400 r20279@phanatique: nelhage | 2007-03-17 14:46:56 -0400 For reasons I don't claim to understand, using the old-style new was throwing odd errors about undefined functions. r20286@phanatique (orig r670): nelhage | 2007-03-18 16:28:23 -0400 r20282@phanatique: nelhage | 2007-03-17 14:48:22 -0400 Report more errors when something goes wrong r20287@phanatique (orig r671): nelhage | 2007-03-18 16:28:31 -0400 r20285@phanatique: nelhage | 2007-03-18 16:28:18 -0400 Adding the new M::Iified jabber module. There isn't a target to build the PAR yet. r20291@phanatique (orig r672): nelhage | 2007-03-18 19:14:04 -0400 r20290@phanatique: nelhage | 2007-03-18 19:13:57 -0400 Adding a Module::Install plugin for building barnowl plugins. It needs a lot of improvement. r20309@phanatique (orig r673): nelhage | 2007-03-19 14:14:23 -0400 r20301@phanatique: nelhage | 2007-03-19 13:31:07 -0400 Changing the dependency on the par target, so we don't rebuild unless we need to. r20310@phanatique (orig r674): nelhage | 2007-03-19 14:14:33 -0400 r20303@phanatique: nelhage | 2007-03-19 13:32:25 -0400 Modifying the makefile to build and install perl modules r20643@phanatique (orig r677): nelhage | 2007-03-23 15:09:45 -0400 r20640@phanatique: nelhage | 2007-03-23 15:09:38 -0400 Implement loading of unpacked modules, and module reloading. r20645@phanatique (orig r678): nelhage | 2007-03-23 15:11:05 -0400 r20644@phanatique: nelhage | 2007-03-23 15:10:57 -0400 Tighten up the reloaded regex a little. r20649@phanatique (orig r679): nelhage | 2007-03-23 16:18:44 -0400 r20648@phanatique: nelhage | 2007-03-23 16:18:25 -0400 Correctly install modules on a clean install. r20655@phanatique (orig r680): nelhage | 2007-03-25 12:53:07 -0400 r20650@phanatique: nelhage | 2007-03-23 17:01:20 -0400 Still not sure why old-style new seems to be eiting us so much... r20656@phanatique (orig r681): nelhage | 2007-03-25 12:53:11 -0400 r20653@phanatique: nelhage | 2007-03-25 12:52:38 -0400 Let's not segfault if the user asks for a nonexistant style in .owl/startup r20657@phanatique (orig r682): nelhage | 2007-03-25 12:53:16 -0400 r20654@phanatique: nelhage | 2007-03-25 12:52:59 -0400 That line doesn't need to be there twice -- probably a mismerge r20706@phanatique (orig r683): nelhage | 2007-03-26 21:04:43 -0400 r20704@phanatique: nelhage | 2007-03-26 20:00:24 -0400 We don't need two package lines.. r20707@phanatique (orig r684): nelhage | 2007-03-26 21:04:54 -0400 r20705@phanatique: nelhage | 2007-03-26 21:04:37 -0400 Getting rid of indirect object syntax new calls. Quoting perlobj: > But what if there are no arguments? In that case, Perl must guess what > you want. Even worse, it must make that guess *at compile time*. Usually > Perl gets it right, but when it doesn't you get a function call compiled > as a method, or vice versa. This can introduce subtle bugs that are hard > to detect. > > For example, a call to a method "new" in indirect notation -- as C++ > programmers are wont to make -- can be miscompiled into a subroutine > call if there's already a "new" function in scope. You'd end up calling > the current package's "new" as a subroutine, rather than the desired > class's method. The compiler tries to cheat by remembering bareword > "require"s, but the grief when it messes up just isn't worth the years > of debugging it will take you to track down such subtle bugs. r20710@phanatique (orig r685): nelhage | 2007-03-26 21:14:41 -0400 r20708@phanatique: nelhage | 2007-03-26 21:11:34 -0400 Adding a reload-modules command r20711@phanatique (orig r686): nelhage | 2007-03-26 21:14:49 -0400 r20709@phanatique: nelhage | 2007-03-26 21:14:31 -0400 Moving Net::Jabber into Jabber.par r20714@phanatique (orig r687): nelhage | 2007-03-26 21:18:13 -0400 r20713@phanatique: nelhage | 2007-03-26 21:17:59 -0400 Don't install .svn dirs r20720@phanatique (orig r688): nelhage | 2007-03-27 22:04:10 -0400 r20719@phanatique: nelhage | 2007-03-27 22:04:03 -0400 Implementing an LRU cache of the message list fmtexts. This reduces memory usage by roughly 1MB/kilo-zephyrs in steady state.
  • Property mode set to 100644
File size: 14.7 KB
RevLine 
[f1e629d]1# $Id$
2#
3# This is all linked into the binary and evaluated when perl starts up...
4#
5#####################################################################
6#####################################################################
[b6c067a]7# XXX NOTE: This file is sourced before almost any barnowl
8# architecture is loaded. This means, for example, that it cannot
[0337203]9# execute any owl commands. Any code that needs to do so should live
10# in BarnOwl::Hooks::_startup
[f1e629d]11
[c681337]12use strict;
13use warnings;
14
[8203afd]15package BarnOwl;
[f1e629d]16
[8862725]17BEGIN {
[f1e629d]18# bootstrap in C bindings and glue
[8203afd]19    *owl:: = \*BarnOwl::;
20    bootstrap BarnOwl 1.2;
[8862725]21};
22
[3354cea5]23use lib(get_data_dir()."/lib");
[2e3b9c2]24use lib($ENV{HOME}."/.owl/lib");
[8862725]25
[00f9a7d]26our $configfile;
27
[2e3b9c2]28if(!$configfile && -f $ENV{HOME} . "/.barnowlconf") {
29    $configfile = $ENV{HOME} . "/.barnowlconf";
30}
31$configfile ||= $ENV{HOME}."/.owlconf";
[d03091c]32
[186cdc4]33# populate global variable space for legacy owlconf files
[f1e629d]34sub _format_msg_legacy_wrap {
35    my ($m) = @_;
36    $m->legacy_populate_global();
[8203afd]37    return &BarnOwl::format_msg($m);
[f1e629d]38}
39
[186cdc4]40# populate global variable space for legacy owlconf files
[f1e629d]41sub _receive_msg_legacy_wrap {
42    my ($m) = @_;
43    $m->legacy_populate_global();
[0337203]44    return &BarnOwl::Hooks::_receive_msg($m);
[f1e629d]45}
46
[8203afd]47# make BarnOwl::<command>("foo") be aliases to BarnOwl::command("<command> foo");
[f1e629d]48sub AUTOLOAD {
[c681337]49    our $AUTOLOAD;
[f1e629d]50    my $called = $AUTOLOAD;
51    $called =~ s/.*:://;
[e7ac2b6]52    $called =~ s/_/-/g;
[8203afd]53    return &BarnOwl::command("$called ".join(" ",@_));
[f1e629d]54}
55
[6922edd]56=head2 new_command NAME FUNC [{ARGS}]
57
58Add a new owl command. When owl executes the command NAME, FUNC will
59be called with the arguments passed to the command, with NAME as the
60first argument.
61
62ARGS should be a hashref containing any or all of C<summary>,
63C<usage>, or C<description> keys.
64
65=cut
66
67sub new_command {
68    my $name = shift;
69    my $func = shift;
70    my $args = shift || {};
71    my %args = (
72        summary     => undef,
73        usage       => undef,
74        description => undef,
75        %{$args}
76    );
77
[c681337]78    no warnings 'uninitialized';
[8203afd]79    BarnOwl::new_command_internal($name, $func, $args{summary}, $args{usage}, $args{description});
[6922edd]80}
81
[f1e629d]82#####################################################################
83#####################################################################
84
[8203afd]85package BarnOwl::Message;
[f1e629d]86
[dd16bdd]87sub new {
88    my $class = shift;
89    my %args = (@_);
90    if($class eq __PACKAGE__ && $args{type}) {
[8203afd]91        $class = "BarnOwl::Message::" . ucfirst $args{type};
[dd16bdd]92    }
93    return bless {%args}, $class;
94}
95
[f1e629d]96sub type        { return shift->{"type"}; }
97sub direction   { return shift->{"direction"}; }
98sub time        { return shift->{"time"}; }
99sub id          { return shift->{"id"}; }
100sub body        { return shift->{"body"}; }
101sub sender      { return shift->{"sender"}; }
102sub recipient   { return shift->{"recipient"}; }
103sub login       { return shift->{"login"}; }
[216c734]104sub is_private  { return shift->{"private"}; }
[f1e629d]105
106sub is_login    { return shift->login eq "login"; }
107sub is_logout   { return shift->login eq "logout"; }
108sub is_loginout { my $m=shift; return ($m->is_login or $m->is_logout); }
109sub is_incoming { return (shift->{"direction"} eq "in"); }
110sub is_outgoing { return (shift->{"direction"} eq "out"); }
111
112sub is_deleted  { return shift->{"deleted"}; }
113
114sub is_admin    { return (shift->{"type"} eq "admin"); }
115sub is_generic  { return (shift->{"type"} eq "generic"); }
[421c8ef7]116sub is_zephyr   { return (shift->{"type"} eq "zephyr"); }
[467aa16]117sub is_aim      { return (shift->{"type"} eq "AIM"); }
[dd16bdd]118sub is_jabber   { return (shift->{"type"} eq "jabber"); }
[421c8ef7]119sub is_icq      { return (shift->{"type"} eq "icq"); }
120sub is_yahoo    { return (shift->{"type"} eq "yahoo"); }
121sub is_msn      { return (shift->{"type"} eq "msn"); }
122sub is_loopback { return (shift->{"type"} eq "loopback"); }
[f1e629d]123
124# These are overridden by appropriate message types
125sub is_ping     { return 0; }
126sub is_mail     { return 0; }
[3c9012b]127sub is_personal { return shift->is_private; }
[f1e629d]128sub class       { return undef; }
129sub instance    { return undef; }
130sub realm       { return undef; }
131sub opcode      { return undef; }
132sub header      { return undef; }
133sub host        { return undef; }
134sub hostname    { return undef; }
135sub auth        { return undef; }
136sub fields      { return undef; }
137sub zsig        { return undef; }
138sub zwriteline  { return undef; }
[87c6ef1]139sub login_host  { return undef; }
140sub login_tty   { return undef; }
[f1e629d]141
[ae47efb]142sub pretty_sender    { return shift->sender; }
143sub pretty_recipient { return shift->recipient; }
[f1e629d]144
145sub delete {
146    my ($m) = @_;
[8203afd]147    &BarnOwl::command("delete --id ".$m->id);
[f1e629d]148}
149
150sub undelete {
151    my ($m) = @_;
[8203afd]152    &BarnOwl::command("undelete --id ".$m->id);
[f1e629d]153}
154
155# Serializes the message into something similar to the zwgc->vt format
156sub serialize {
157    my ($this) = @_;
158    my $s;
159    for my $f (keys %$this) {
160        my $val = $this->{$f};
161        if (ref($val) eq "ARRAY") {
162            for my $i (0..@$val-1) {
163                my $aval;
164                $aval = $val->[$i];
165                $aval =~ s/\n/\n$f.$i: /g;
[186cdc4]166                $s .= "$f.$i: $aval\n";
[f1e629d]167            }
168        } else {
169            $val =~ s/\n/\n$f: /g;
170            $s .= "$f: $val\n";
171        }
172    }
173    return $s;
174}
175
176# Populate the annoying legacy global variables
177sub legacy_populate_global {
178    my ($m) = @_;
[8203afd]179    $BarnOwl::direction  = $m->direction ;
180    $BarnOwl::type       = $m->type      ;
181    $BarnOwl::id         = $m->id        ;
182    $BarnOwl::class      = $m->class     ;
183    $BarnOwl::instance   = $m->instance  ;
184    $BarnOwl::recipient  = $m->recipient ;
185    $BarnOwl::sender     = $m->sender    ;
186    $BarnOwl::realm      = $m->realm     ;
187    $BarnOwl::opcode     = $m->opcode    ;
188    $BarnOwl::zsig       = $m->zsig      ;
189    $BarnOwl::msg        = $m->body      ;
190    $BarnOwl::time       = $m->time      ;
191    $BarnOwl::host       = $m->host      ;
192    $BarnOwl::login      = $m->login     ;
193    $BarnOwl::auth       = $m->auth      ;
[f1e629d]194    if ($m->fields) {
[8203afd]195        @BarnOwl::fields = @{$m->fields};
[f1e629d]196        @main::fields = @{$m->fields};
197    } else {
[8203afd]198        @BarnOwl::fields = undef;
[f1e629d]199        @main::fields = undef;
200    }
201}
202
[25729b2]203sub smartfilter {
[0337203]204    die("smartfilter not supported for this message\n");
[25729b2]205}
206
[6e6ded7]207# Display fields -- overridden by subclasses when needed
208sub login_type {""}
209sub login_extra {""}
210sub long_sender {""}
211
212# The context in which a non-personal message was sent, e.g. a chat or
213# class
214sub context {""}
215
216# Some indicator of context *within* $self->context. e.g. the zephyr
217# instance
218sub subcontext {""}
219
[f1e629d]220#####################################################################
221#####################################################################
222
[8203afd]223package BarnOwl::Message::Admin;
[f1e629d]224
[8203afd]225use base qw( BarnOwl::Message );
[f1e629d]226
227sub header       { return shift->{"header"}; }
228
229#####################################################################
230#####################################################################
231
[8203afd]232package BarnOwl::Message::Generic;
[f1e629d]233
[8203afd]234use base qw( BarnOwl::Message );
[f1e629d]235
236#####################################################################
237#####################################################################
238
[186cdc4]239package BarnOwl::Message::Loopback;
240
241use base qw( BarnOwl::Message );
242
[cb06a43]243# all loopback messages are private
244sub is_private {
[186cdc4]245  return 1;
246}
247
248#####################################################################
249#####################################################################
250
[8203afd]251package BarnOwl::Message::AIM;
[f1e629d]252
[8203afd]253use base qw( BarnOwl::Message );
[f1e629d]254
[cb06a43]255# all non-loginout AIM messages are private for now...
256sub is_private {
[f1e629d]257    return !(shift->is_loginout);
258}
259
260#####################################################################
261#####################################################################
262
[8203afd]263package BarnOwl::Message::Zephyr;
[f1e629d]264
[8203afd]265use base qw( BarnOwl::Message );
[f1e629d]266
[6e6ded7]267sub login_type {
268    return (shift->zsig eq "") ? "(PSEUDO)" : "";
269}
270
271sub login_extra {
272    my $m = shift;
273    return undef if (!$m->is_loginout);
274    my $s = lc($m->host);
275    $s .= " " . $m->login_tty if defined $m->login_tty;
276    return $s;
277}
278
279sub long_sender {
280    my $m = shift;
281    return $m->zsig;
282}
283
284sub context {
285    return shift->class;
286}
287
288sub subcontext {
289    return shift->instance;
290}
291
[186cdc4]292sub login_tty {
[f1e629d]293    my ($m) = @_;
294    return undef if (!$m->is_loginout);
295    return $m->fields->[2];
296}
297
[186cdc4]298sub login_host {
[f1e629d]299    my ($m) = @_;
300    return undef if (!$m->is_loginout);
301    return $m->fields->[0];
302}
303
304sub zwriteline  { return shift->{"zwriteline"}; }
305
306sub is_ping     { return (lc(shift->opcode) eq "ping"); }
307
[186cdc4]308sub is_personal {
[f1e629d]309    my ($m) = @_;
310    return ((lc($m->class) eq "message")
311            && (lc($m->instance) eq "personal")
312            && $m->is_private);
313}
314
[186cdc4]315sub is_mail {
[f1e629d]316    my ($m) = @_;
317    return ((lc($m->class) eq "mail") && $m->is_private);
318}
319
320sub pretty_sender {
321    my ($m) = @_;
322    my $sender = $m->sender;
[8203afd]323    my $realm = BarnOwl::zephyr_getrealm();
[f1e629d]324    $sender =~ s/\@$realm$//;
325    return $sender;
326}
327
[ae47efb]328sub pretty_recipient {
329    my ($m) = @_;
330    my $recip = $m->recipient;
331    my $realm = BarnOwl::zephyr_getrealm();
332    $recip =~ s/\@$realm$//;
333    return $recip;
334}
335
[f1e629d]336# These are arguably zephyr-specific
337sub class       { return shift->{"class"}; }
338sub instance    { return shift->{"instance"}; }
339sub realm       { return shift->{"realm"}; }
340sub opcode      { return shift->{"opcode"}; }
341sub host        { return shift->{"hostname"}; }
342sub hostname    { return shift->{"hostname"}; }
343sub header      { return shift->{"header"}; }
344sub auth        { return shift->{"auth"}; }
345sub fields      { return shift->{"fields"}; }
346sub zsig        { return shift->{"zsig"}; }
347
348#####################################################################
349#####################################################################
[7e470da]350################################################################################
351
[0337203]352package BarnOwl::Hook;
[7e470da]353
[0337203]354sub new {
355    my $class = shift;
356    return bless [], $class;
357}
[7e470da]358
[0337203]359sub run {
360    my $self = shift;
361    my @args = @_;
362    return map {$_->(@args)} @$self;
[7e470da]363}
[0337203]364
365sub add {
366    my $self = shift;
367    my $func = shift;
368    die("Not a coderef!") unless ref($func) eq 'CODE';
369    push @$self, $func;
[7e470da]370}
371
[0337203]372sub clear {
373    my $self = shift;
374    @$self = ();
[7e470da]375}
376
[0337203]377package BarnOwl::Hooks;
[7e470da]378
[0337203]379use Exporter;
380
381our @EXPORT_OK = qw($startup $shutdown
382                    $receiveMessage $mainLoop
383                    $getBuddyList);
384
385our %EXPORT_TAGS = (all => [@EXPORT_OK]);
386
387our $startup = BarnOwl::Hook->new;
388our $shutdown = BarnOwl::Hook->new;
389our $receiveMessage = BarnOwl::Hook->new;
390our $mainLoop = BarnOwl::Hook->new;
391our $getBuddyList = BarnOwl::Hook->new;
392
393# Internal startup/shutdown routines called by the C code
[7e470da]394
[b6c067a]395sub _load_owlconf {
396    # load the config  file
397    if ( -r $BarnOwl::configfile ) {
398        undef $@;
[e8bc8ac]399        package main;
[b6c067a]400        do $BarnOwl::configfile;
401        die $@ if $@;
[e8bc8ac]402        package BarnOwl;
[39dc159]403        if(*BarnOwl::format_msg{CODE}) {
404            # if the config defines a legacy formatting function, add 'perl' as a style
405            BarnOwl::_create_style("perl", "BarnOwl::_format_msg_legacy_wrap",
406                                   "User-defined perl style that calls BarnOwl::format_msg"
407                                   . " with legacy global variable support");
408            BarnOwl::set("-q default_style perl");
409        }
[b6c067a]410    }
411}
412
[0337203]413sub _startup {
414    _load_owlconf();
[8203afd]415
[0337203]416    if(eval {require BarnOwl::ModuleLoader}) {
417        eval {
418            BarnOwl::ModuleLoader->load_all;
419        };
[f60f02c]420        BarnOwl::error("Error loading modules: $@") if $@;
[0337203]421    } else {
422        BarnOwl::error("Can't load BarnOwl::ModuleLoader, loadable module support disabled:\n$@");
423    }
424   
[836e6263]425    $startup->run(0);
[8203afd]426    BarnOwl::startup() if *BarnOwl::startup{CODE};
427}
428
[0337203]429sub _shutdown {
430    $shutdown->run;
431   
[8203afd]432    BarnOwl::shutdown() if *BarnOwl::shutdown{CODE};
433}
434
[0337203]435sub _receive_msg {
[7e470da]436    my $m = shift;
[0337203]437
438    $receiveMessage->run($m);
439   
[8203afd]440    BarnOwl::receive_msg($m) if *BarnOwl::receive_msg{CODE};
[7e470da]441}
442
[0337203]443sub _mainloop_hook {
444    $mainLoop->run;
445    BarnOwl::mainloop_hook() if *BarnOwl::mainloop_hook{CODE};
446}
[7e470da]447
[0337203]448sub _get_blist {
449    return join("\n", $getBuddyList->run);
[7e470da]450}
[dd16bdd]451
[b6c067a]452################################################################################
453# Built-in perl styles
454################################################################################
455package BarnOwl::Style::Default;
456################################################################################
457# Branching point for various formatting functions in this style.
458################################################################################
459sub format_message($)
460{
461    my $m = shift;
462
[6e6ded7]463    if ( $m->is_loginout) {
464        return format_login($m);
465    } elsif($m->is_ping) {
466        return ( "\@b(PING) from \@b(" . $m->pretty_sender . ")\n" );
467    } elsif($m->is_admin) {
[b6c067a]468        return "\@bold(OWL ADMIN)\n" . indentBody($m);
[6e6ded7]469    } else {
470        return format_chat($m);
[b6c067a]471    }
472}
473
474BarnOwl::_create_style("default", "BarnOwl::Style::Default::format_message", "Default style");
475
476################################################################################
477
[6e6ded7]478sub time_hhmm {
479    my $m = shift;
[b6c067a]480    my ($time) = $m->time =~ /(\d\d:\d\d)/;
[6e6ded7]481    return $time;
[b6c067a]482}
483
[6e6ded7]484sub format_login($) {
[b6c067a]485    my $m = shift;
[6e6ded7]486    return sprintf(
487        '@b<%s%s> for @b(%s) (%s) %s',
488        uc( $m->login ),
489        $m->login_type,
490        $m->pretty_sender,
491        $m->login_extra,
492        time_hhmm($m)
493       );
[b6c067a]494}
495
[6e6ded7]496sub format_chat($) {
[b6c067a]497    my $m = shift;
[6e6ded7]498    my $header;
499    if ( $m->is_personal ) {
500        if ( $m->direction eq "out" ) {
501            $header = ucfirst $m->type . " sent to " . $m->pretty_recipient;
502        } else {
503            $header = ucfirst $m->type . " from " . $m->pretty_sender;
504        }
505    } else {
506        $header = $m->context;
[37dd88c]507        if(defined $m->subcontext) {
[c39999f]508            $header .= ' / ' . $m->subcontext;
[6e6ded7]509        }
[c39999f]510        $header .= ' / @b{' . $m->pretty_sender . '}';
[6e6ded7]511    }
[b6c067a]512
[6e6ded7]513    $header .= "  " . time_hhmm($m);
[0449730]514    my $sender = $m->long_sender;
515    $sender =~ s/\n.*$//s;
[cc5b906]516    $header .= " " x (4 - ((length $header) % 4));
517    $header .= "(" . $sender . ")";
[6e6ded7]518    my $message = $header . "\n". indentBody($m);
[cb06a43]519    if($m->is_personal && $m->direction eq "in") {
[6e6ded7]520        $message = BarnOwl::Style::boldify($message);
521    }
522    return $message;
[b6c067a]523}
524
525sub indentBody($)
526{
527    my $m = shift;
[186cdc4]528
[b6c067a]529    my $body = $m->body;
[186cdc4]530    # replace newline followed by anything with
[b6c067a]531    # newline plus four spaces and that thing.
532    $body =~ s/\n(.)/\n    $1/g;
533
534    return "    ".$body;
535}
536
537
538package BarnOwl::Style;
539
540# This takes a zephyr to be displayed and modifies it to be displayed
541# entirely in bold.
542sub boldify($)
543{
544    local $_ = shift;
545    if ( !(/\)/) ) {
546        return '@b(' . $_ . ')';
547    } elsif ( !(/\>/) ) {
548        return '@b<' . $_ . '>';
549    } elsif ( !(/\}/) ) {
550        return '@b{' . $_ . '}';
551    } elsif ( !(/\]/) ) {
552        return '@b[' . $_ . ']';
553    } else {
554        my $txt = "\@b($_";
555        $txt =~ s/\)/\)\@b\[\)\]\@b\(/g;
556        return $txt . ')';
557    }
558}
559
560
[f1e629d]561# switch to package main when we're done
562package main;
[0337203]563
564# Shove a bunch of fake entries into @INC so modules can use or
565# require them without choking
566$::INC{$_} = 1 for (qw(BarnOwl.pm BarnOwl/Hooks.pm
567                       BarnOwl/Message.pm BarnOwl/Style.pm));
[f1e629d]568
5691;
[0337203]570
Note: See TracBrowser for help on using the repository browser.