source: perlwrap.pm @ a695a68

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