source: perlwrap.pm @ 2622450

barnowl_perlaimdebianrelease-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 2622450 was 0337203, checked in by Nelson Elhage <nelhage@mit.edu>, 18 years ago
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.
  • Property mode set to 100644
File size: 14.8 KB
Line 
1# $Id$
2#
3# This is all linked into the binary and evaluated when perl starts up...
4#
5#####################################################################
6#####################################################################
7# XXX NOTE: This file is sourced before almost any barnowl
8# architecture is loaded. This means, for example, that it cannot
9# execute any owl commands. Any code that needs to do so should live
10# in BarnOwl::Hooks::_startup
11
12use strict;
13use warnings;
14
15package BarnOwl;
16
17package BarnOwl;
18
19
20BEGIN {
21# bootstrap in C bindings and glue
22    *owl:: = \*BarnOwl::;
23    bootstrap BarnOwl 1.2;
24};
25
26use lib(get_data_dir()."/lib");
27use lib($ENV{HOME}."/.owl/lib");
28
29our $configfile;
30
31if(!$configfile && -f $ENV{HOME} . "/.barnowlconf") {
32    $configfile = $ENV{HOME} . "/.barnowlconf";
33}
34$configfile ||= $ENV{HOME}."/.owlconf";
35
36# populate global variable space for legacy owlconf files
37sub _format_msg_legacy_wrap {
38    my ($m) = @_;
39    $m->legacy_populate_global();
40    return &BarnOwl::format_msg($m);
41}
42
43# populate global variable space for legacy owlconf files
44sub _receive_msg_legacy_wrap {
45    my ($m) = @_;
46    $m->legacy_populate_global();
47    return &BarnOwl::Hooks::_receive_msg($m);
48}
49
50# make BarnOwl::<command>("foo") be aliases to BarnOwl::command("<command> foo");
51sub AUTOLOAD {
52    our $AUTOLOAD;
53    my $called = $AUTOLOAD;
54    $called =~ s/.*:://;
55    $called =~ s/_/-/g;
56    return &BarnOwl::command("$called ".join(" ",@_));
57}
58
59=head2 new_command NAME FUNC [{ARGS}]
60
61Add a new owl command. When owl executes the command NAME, FUNC will
62be called with the arguments passed to the command, with NAME as the
63first argument.
64
65ARGS should be a hashref containing any or all of C<summary>,
66C<usage>, or C<description> keys.
67
68=cut
69
70sub new_command {
71    my $name = shift;
72    my $func = shift;
73    my $args = shift || {};
74    my %args = (
75        summary     => undef,
76        usage       => undef,
77        description => undef,
78        %{$args}
79    );
80
81    no warnings 'uninitialized';
82    BarnOwl::new_command_internal($name, $func, $args{summary}, $args{usage}, $args{description});
83}
84
85#####################################################################
86#####################################################################
87
88package BarnOwl::Message;
89
90sub new {
91    my $class = shift;
92    my %args = (@_);
93    if($class eq __PACKAGE__ && $args{type}) {
94        $class = "BarnOwl::Message::" . ucfirst $args{type};
95    }
96    return bless {%args}, $class;
97}
98
99sub type        { return shift->{"type"}; }
100sub direction   { return shift->{"direction"}; }
101sub time        { return shift->{"time"}; }
102sub id          { return shift->{"id"}; }
103sub body        { return shift->{"body"}; }
104sub sender      { return shift->{"sender"}; }
105sub recipient   { return shift->{"recipient"}; }
106sub login       { return shift->{"login"}; }
107sub is_private  { return shift->{"private"}; }
108
109sub is_login    { return shift->login eq "login"; }
110sub is_logout   { return shift->login eq "logout"; }
111sub is_loginout { my $m=shift; return ($m->is_login or $m->is_logout); }
112sub is_incoming { return (shift->{"direction"} eq "in"); }
113sub is_outgoing { return (shift->{"direction"} eq "out"); }
114
115sub is_deleted  { return shift->{"deleted"}; }
116
117sub is_admin    { return (shift->{"type"} eq "admin"); }
118sub is_generic  { return (shift->{"type"} eq "generic"); }
119sub is_zephyr   { return (shift->{"type"} eq "zephyr"); }
120sub is_aim      { return (shift->{"type"} eq "AIM"); }
121sub is_jabber   { return (shift->{"type"} eq "jabber"); }
122sub is_icq      { return (shift->{"type"} eq "icq"); }
123sub is_yahoo    { return (shift->{"type"} eq "yahoo"); }
124sub is_msn      { return (shift->{"type"} eq "msn"); }
125sub is_loopback { return (shift->{"type"} eq "loopback"); }
126
127# These are overridden by appropriate message types
128sub is_ping     { return 0; }
129sub is_mail     { return 0; }
130sub is_personal { return shift->is_private; }
131sub class       { return undef; }
132sub instance    { return undef; }
133sub realm       { return undef; }
134sub opcode      { return undef; }
135sub header      { return undef; }
136sub host        { return undef; }
137sub hostname    { return undef; }
138sub auth        { return undef; }
139sub fields      { return undef; }
140sub zsig        { return undef; }
141sub zwriteline  { return undef; }
142sub login_host  { return undef; }
143sub login_tty   { return undef; }
144
145sub pretty_sender    { return shift->sender; }
146sub pretty_recipient { return shift->recipient; }
147
148sub delete {
149    my ($m) = @_;
150    &BarnOwl::command("delete --id ".$m->id);
151}
152
153sub undelete {
154    my ($m) = @_;
155    &BarnOwl::command("undelete --id ".$m->id);
156}
157
158# Serializes the message into something similar to the zwgc->vt format
159sub serialize {
160    my ($this) = @_;
161    my $s;
162    for my $f (keys %$this) {
163        my $val = $this->{$f};
164        if (ref($val) eq "ARRAY") {
165            for my $i (0..@$val-1) {
166                my $aval;
167                $aval = $val->[$i];
168                $aval =~ s/\n/\n$f.$i: /g;
169                $s .= "$f.$i: $aval\n";
170            }
171        } else {
172            $val =~ s/\n/\n$f: /g;
173            $s .= "$f: $val\n";
174        }
175    }
176    return $s;
177}
178
179# Populate the annoying legacy global variables
180sub legacy_populate_global {
181    my ($m) = @_;
182    $BarnOwl::direction  = $m->direction ;
183    $BarnOwl::type       = $m->type      ;
184    $BarnOwl::id         = $m->id        ;
185    $BarnOwl::class      = $m->class     ;
186    $BarnOwl::instance   = $m->instance  ;
187    $BarnOwl::recipient  = $m->recipient ;
188    $BarnOwl::sender     = $m->sender    ;
189    $BarnOwl::realm      = $m->realm     ;
190    $BarnOwl::opcode     = $m->opcode    ;
191    $BarnOwl::zsig       = $m->zsig      ;
192    $BarnOwl::msg        = $m->body      ;
193    $BarnOwl::time       = $m->time      ;
194    $BarnOwl::host       = $m->host      ;
195    $BarnOwl::login      = $m->login     ;
196    $BarnOwl::auth       = $m->auth      ;
197    if ($m->fields) {
198        @BarnOwl::fields = @{$m->fields};
199        @main::fields = @{$m->fields};
200    } else {
201        @BarnOwl::fields = undef;
202        @main::fields = undef;
203    }
204}
205
206sub smartfilter {
207    die("smartfilter not supported for this message\n");
208}
209
210# Display fields -- overridden by subclasses when needed
211sub login_type {""}
212sub login_extra {""}
213sub long_sender {""}
214
215# The context in which a non-personal message was sent, e.g. a chat or
216# class
217sub context {""}
218
219# Some indicator of context *within* $self->context. e.g. the zephyr
220# instance
221sub subcontext {""}
222
223#####################################################################
224#####################################################################
225
226package BarnOwl::Message::Admin;
227
228use base qw( BarnOwl::Message );
229
230sub header       { return shift->{"header"}; }
231
232#####################################################################
233#####################################################################
234
235package BarnOwl::Message::Generic;
236
237use base qw( BarnOwl::Message );
238
239#####################################################################
240#####################################################################
241
242package BarnOwl::Message::Loopback;
243
244use base qw( BarnOwl::Message );
245
246# all loopback messages are personal
247sub is_personal {
248  return 1;
249}
250
251#####################################################################
252#####################################################################
253
254package BarnOwl::Message::AIM;
255
256use base qw( BarnOwl::Message );
257
258# all non-loginout AIM messages are personal for now...
259sub is_personal {
260    return !(shift->is_loginout);
261}
262
263#####################################################################
264#####################################################################
265
266package BarnOwl::Message::Zephyr;
267
268use base qw( BarnOwl::Message );
269
270sub login_type {
271    return (shift->zsig eq "") ? "(PSEUDO)" : "";
272}
273
274sub login_extra {
275    my $m = shift;
276    return undef if (!$m->is_loginout);
277    my $s = lc($m->host);
278    $s .= " " . $m->login_tty if defined $m->login_tty;
279    return $s;
280}
281
282sub long_sender {
283    my $m = shift;
284    return $m->zsig;
285}
286
287sub context {
288    return shift->class;
289}
290
291sub subcontext {
292    return shift->instance;
293}
294
295sub login_tty {
296    my ($m) = @_;
297    return undef if (!$m->is_loginout);
298    return $m->fields->[2];
299}
300
301sub login_host {
302    my ($m) = @_;
303    return undef if (!$m->is_loginout);
304    return $m->fields->[0];
305}
306
307sub zwriteline  { return shift->{"zwriteline"}; }
308
309sub is_ping     { return (lc(shift->opcode) eq "ping"); }
310
311sub is_personal {
312    my ($m) = @_;
313    return ((lc($m->class) eq "message")
314            && (lc($m->instance) eq "personal")
315            && $m->is_private);
316}
317
318sub is_mail {
319    my ($m) = @_;
320    return ((lc($m->class) eq "mail") && $m->is_private);
321}
322
323sub pretty_sender {
324    my ($m) = @_;
325    my $sender = $m->sender;
326    my $realm = BarnOwl::zephyr_getrealm();
327    $sender =~ s/\@$realm$//;
328    return $sender;
329}
330
331sub pretty_recipient {
332    my ($m) = @_;
333    my $recip = $m->recipient;
334    my $realm = BarnOwl::zephyr_getrealm();
335    $recip =~ s/\@$realm$//;
336    return $recip;
337}
338
339# These are arguably zephyr-specific
340sub class       { return shift->{"class"}; }
341sub instance    { return shift->{"instance"}; }
342sub realm       { return shift->{"realm"}; }
343sub opcode      { return shift->{"opcode"}; }
344sub host        { return shift->{"hostname"}; }
345sub hostname    { return shift->{"hostname"}; }
346sub header      { return shift->{"header"}; }
347sub auth        { return shift->{"auth"}; }
348sub fields      { return shift->{"fields"}; }
349sub zsig        { return shift->{"zsig"}; }
350
351#####################################################################
352#####################################################################
353################################################################################
354
355package BarnOwl::Hook;
356
357sub new {
358    my $class = shift;
359    return bless [], $class;
360}
361
362sub run {
363    my $self = shift;
364    my @args = @_;
365    return map {$_->(@args)} @$self;
366}
367
368sub add {
369    my $self = shift;
370    my $func = shift;
371    die("Not a coderef!") unless ref($func) eq 'CODE';
372    push @$self, $func;
373}
374
375sub clear {
376    my $self = shift;
377    @$self = ();
378}
379
380package BarnOwl::Hooks;
381
382use Exporter;
383
384our @EXPORT_OK = qw($startup $shutdown
385                    $receiveMessage $mainLoop
386                    $getBuddyList);
387
388our %EXPORT_TAGS = (all => [@EXPORT_OK]);
389
390our $startup = BarnOwl::Hook->new;
391our $shutdown = BarnOwl::Hook->new;
392our $receiveMessage = BarnOwl::Hook->new;
393our $mainLoop = BarnOwl::Hook->new;
394our $getBuddyList = BarnOwl::Hook->new;
395
396# Internal startup/shutdown routines called by the C code
397
398sub _load_owlconf {
399    # load the config  file
400    if ( -r $BarnOwl::configfile ) {
401        undef $@;
402        package main;
403        do $BarnOwl::configfile;
404        die $@ if $@;
405        package BarnOwl;
406        if(*BarnOwl::format_msg{CODE}) {
407            # if the config defines a legacy formatting function, add 'perl' as a style
408            BarnOwl::_create_style("perl", "BarnOwl::_format_msg_legacy_wrap",
409                                   "User-defined perl style that calls BarnOwl::format_msg"
410                                   . " with legacy global variable support");
411            BarnOwl::set("-q default_style perl");
412        }
413    }
414}
415
416sub _startup {
417    _load_owlconf();
418
419    if(eval {require BarnOwl::ModuleLoader}) {
420        eval {
421            BarnOwl::ModuleLoader->load_all;
422        };
423    } else {
424        BarnOwl::error("Can't load BarnOwl::ModuleLoader, loadable module support disabled:\n$@");
425    }
426   
427    $startup->run;
428    BarnOwl::startup() if *BarnOwl::startup{CODE};
429}
430
431sub _shutdown {
432    $shutdown->run;
433   
434    BarnOwl::shutdown() if *BarnOwl::shutdown{CODE};
435}
436
437sub _receive_msg {
438    my $m = shift;
439
440    $receiveMessage->run($m);
441   
442    BarnOwl::receive_msg($m) if *BarnOwl::receive_msg{CODE};
443}
444
445sub _mainloop_hook {
446    $mainLoop->run;
447    BarnOwl::mainloop_hook() if *BarnOwl::mainloop_hook{CODE};
448}
449
450sub _get_blist {
451    return join("\n", $getBuddyList->run);
452}
453
454################################################################################
455# Built-in perl styles
456################################################################################
457package BarnOwl::Style::Default;
458################################################################################
459# Branching point for various formatting functions in this style.
460################################################################################
461sub format_message($)
462{
463    my $m = shift;
464
465    if ( $m->is_loginout) {
466        return format_login($m);
467    } elsif($m->is_ping) {
468        return ( "\@b(PING) from \@b(" . $m->pretty_sender . ")\n" );
469    } elsif($m->is_admin) {
470        return "\@bold(OWL ADMIN)\n" . indentBody($m);
471    } else {
472        return format_chat($m);
473    }
474}
475
476BarnOwl::_create_style("default", "BarnOwl::Style::Default::format_message", "Default style");
477
478BarnOwl::_create_style("default", "BarnOwl::Style::Default::format_message", "Default style");
479
480################################################################################
481
482sub time_hhmm {
483    my $m = shift;
484    my ($time) = $m->time =~ /(\d\d:\d\d)/;
485    return $time;
486}
487
488sub format_login($) {
489    my $m = shift;
490    return sprintf(
491        '@b<%s%s> for @b(%s) (%s) %s',
492        uc( $m->login ),
493        $m->login_type,
494        $m->pretty_sender,
495        $m->login_extra,
496        time_hhmm($m)
497       );
498}
499
500sub format_chat($) {
501    my $m = shift;
502    my $header;
503    if ( $m->is_personal ) {
504        if ( $m->direction eq "out" ) {
505            $header = ucfirst $m->type . " sent to " . $m->pretty_recipient;
506        } else {
507            $header = ucfirst $m->type . " from " . $m->pretty_sender;
508        }
509    } else {
510        $header = $m->context;
511        if($m->subcontext) {
512            $header .= ' / ' . $m->subcontext;
513        }
514        $header .= ' / @b{' . $m->pretty_sender . '}';
515    }
516
517    $header .= "  " . time_hhmm($m);
518    my $sender = $m->long_sender;
519    $sender =~ s/\n.*$//s;
520    $header .= " " x (4 - ((length $header) % 4));
521    $header .= "(" . $sender . ")";
522    my $message = $header . "\n". indentBody($m);
523    if($m->is_private && $m->direction eq "in") {
524        $message = BarnOwl::Style::boldify($message);
525    }
526    return $message;
527}
528
529sub indentBody($)
530{
531    my $m = shift;
532
533    my $body = $m->body;
534    # replace newline followed by anything with
535    # newline plus four spaces and that thing.
536    $body =~ s/\n(.)/\n    $1/g;
537
538    return "    ".$body;
539}
540
541
542package BarnOwl::Style;
543
544# This takes a zephyr to be displayed and modifies it to be displayed
545# entirely in bold.
546sub boldify($)
547{
548    local $_ = shift;
549    if ( !(/\)/) ) {
550        return '@b(' . $_ . ')';
551    } elsif ( !(/\>/) ) {
552        return '@b<' . $_ . '>';
553    } elsif ( !(/\}/) ) {
554        return '@b{' . $_ . '}';
555    } elsif ( !(/\]/) ) {
556        return '@b[' . $_ . ']';
557    } else {
558        my $txt = "\@b($_";
559        $txt =~ s/\)/\)\@b\[\)\]\@b\(/g;
560        return $txt . ')';
561    }
562}
563
564
565# switch to package main when we're done
566package main;
567
568# Shove a bunch of fake entries into @INC so modules can use or
569# require them without choking
570$::INC{$_} = 1 for (qw(BarnOwl.pm BarnOwl/Hooks.pm
571                       BarnOwl/Message.pm BarnOwl/Style.pm));
572
5731;
574
Note: See TracBrowser for help on using the repository browser.