source: perlwrap.pm @ b6c067a

barnowl_perlaimdebianrelease-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since b6c067a was b6c067a, checked in by Nelson Elhage <nelhage@mit.edu>, 14 years ago
Moving the default style into perl, and reorganizing things so we can bootstrap the style into place in time.
  • Property mode set to 100644
File size: 17.3 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
10# create a function wrapping it and push it onto @onStartSubs
11
12
13use strict;
14use warnings;
15
16package BarnOwl;
17
18
19BEGIN {
20# bootstrap in C bindings and glue
21    *owl:: = \*BarnOwl::;
22    bootstrap BarnOwl 1.2;
23};
24
25use lib(get_data_dir()."/lib");
26use lib($::ENV{'HOME'}."/.owl/lib");
27
28our $configfile;
29
30$configfile ||= $::ENV{'HOME'}."/.owlconf";
31
32# populate global variable space for legacy owlconf files
33sub _format_msg_legacy_wrap {
34    my ($m) = @_;
35    $m->legacy_populate_global();
36    return &BarnOwl::format_msg($m);
37}
38
39# populate global variable space for legacy owlconf files
40sub _receive_msg_legacy_wrap {
41    my ($m) = @_;
42    $m->legacy_populate_global();
43    return &BarnOwl::Hooks::receive_msg($m);
44}
45
46# make BarnOwl::<command>("foo") be aliases to BarnOwl::command("<command> foo");
47sub AUTOLOAD {
48    our $AUTOLOAD;
49    my $called = $AUTOLOAD;
50    $called =~ s/.*:://;
51    $called =~ s/_/-/g;
52    return &BarnOwl::command("$called ".join(" ",@_));
53}
54
55=head2 new_command NAME FUNC [{ARGS}]
56
57Add a new owl command. When owl executes the command NAME, FUNC will
58be called with the arguments passed to the command, with NAME as the
59first argument.
60
61ARGS should be a hashref containing any or all of C<summary>,
62C<usage>, or C<description> keys.
63
64=cut
65
66sub new_command {
67    my $name = shift;
68    my $func = shift;
69    my $args = shift || {};
70    my %args = (
71        summary     => undef,
72        usage       => undef,
73        description => undef,
74        %{$args}
75    );
76
77    no warnings 'uninitialized';
78    BarnOwl::new_command_internal($name, $func, $args{summary}, $args{usage}, $args{description});
79}
80
81#####################################################################
82#####################################################################
83
84package BarnOwl::Message;
85
86sub new {
87    my $class = shift;
88    my %args = (@_);
89    if($class eq __PACKAGE__ && $args{type}) {
90        $class = "BarnOwl::Message::" . ucfirst $args{type};
91    }
92    return bless {%args}, $class;
93}
94
95sub type        { return shift->{"type"}; }
96sub direction   { return shift->{"direction"}; }
97sub time        { return shift->{"time"}; }
98sub id          { return shift->{"id"}; }
99sub body        { return shift->{"body"}; }
100sub sender      { return shift->{"sender"}; }
101sub recipient   { return shift->{"recipient"}; }
102sub login       { return shift->{"login"}; }
103sub is_private  { return shift->{"private"}; }
104
105sub is_login    { return shift->login eq "login"; }
106sub is_logout   { return shift->login eq "logout"; }
107sub is_loginout { my $m=shift; return ($m->is_login or $m->is_logout); }
108sub is_incoming { return (shift->{"direction"} eq "in"); }
109sub is_outgoing { return (shift->{"direction"} eq "out"); }
110
111sub is_deleted  { return shift->{"deleted"}; }
112
113sub is_admin    { return (shift->{"type"} eq "admin"); }
114sub is_generic  { return (shift->{"type"} eq "generic"); }
115sub is_zephyr   { return (shift->{"type"} eq "zephyr"); }
116sub is_aim      { return (shift->{"type"} eq "AIM"); }
117sub is_jabber   { return (shift->{"type"} eq "jabber"); }
118sub is_icq      { return (shift->{"type"} eq "icq"); }
119sub is_yahoo    { return (shift->{"type"} eq "yahoo"); }
120sub is_msn      { return (shift->{"type"} eq "msn"); }
121sub is_loopback { return (shift->{"type"} eq "loopback"); }
122
123# These are overridden by appropriate message types
124sub is_ping     { return 0; }
125sub is_mail     { return 0; }
126sub is_personal { return shift->is_private; }
127sub class       { return undef; }
128sub instance    { return undef; }
129sub realm       { return undef; }
130sub opcode      { return undef; }
131sub header      { return undef; }
132sub host        { return undef; }
133sub hostname    { return undef; }
134sub auth        { return undef; }
135sub fields      { return undef; }
136sub zsig        { return undef; }
137sub zwriteline  { return undef; }
138sub login_host  { return undef; }
139sub login_tty   { return undef; }
140
141sub pretty_sender    { return shift->sender; }
142sub pretty_recipient { return shift->recipient; }
143
144sub delete {
145    my ($m) = @_;
146    &BarnOwl::command("delete --id ".$m->id);
147}
148
149sub undelete {
150    my ($m) = @_;
151    &BarnOwl::command("undelete --id ".$m->id);
152}
153
154# Serializes the message into something similar to the zwgc->vt format
155sub serialize {
156    my ($this) = @_;
157    my $s;
158    for my $f (keys %$this) {
159        my $val = $this->{$f};
160        if (ref($val) eq "ARRAY") {
161            for my $i (0..@$val-1) {
162                my $aval;
163                $aval = $val->[$i];
164                $aval =~ s/\n/\n$f.$i: /g;
165                $s .= "$f.$i: $aval\n";   
166            }
167        } else {
168            $val =~ s/\n/\n$f: /g;
169            $s .= "$f: $val\n";
170        }
171    }
172    return $s;
173}
174
175# Populate the annoying legacy global variables
176sub legacy_populate_global {
177    my ($m) = @_;
178    $BarnOwl::direction  = $m->direction ;
179    $BarnOwl::type       = $m->type      ;
180    $BarnOwl::id         = $m->id        ;
181    $BarnOwl::class      = $m->class     ;
182    $BarnOwl::instance   = $m->instance  ;
183    $BarnOwl::recipient  = $m->recipient ;
184    $BarnOwl::sender     = $m->sender    ;
185    $BarnOwl::realm      = $m->realm     ;
186    $BarnOwl::opcode     = $m->opcode    ;
187    $BarnOwl::zsig       = $m->zsig      ;
188    $BarnOwl::msg        = $m->body      ;
189    $BarnOwl::time       = $m->time      ;
190    $BarnOwl::host       = $m->host      ;
191    $BarnOwl::login      = $m->login     ;
192    $BarnOwl::auth       = $m->auth      ;
193    if ($m->fields) {
194        @BarnOwl::fields = @{$m->fields};
195        @main::fields = @{$m->fields};
196    } else {
197        @BarnOwl::fields = undef;
198        @main::fields = undef;
199    }
200}
201
202sub smartfilter {
203    die("smartfilter not supported for this message");
204}
205
206#####################################################################
207#####################################################################
208
209package BarnOwl::Message::Admin;
210
211use base qw( BarnOwl::Message );
212
213sub header       { return shift->{"header"}; }
214
215#####################################################################
216#####################################################################
217
218package BarnOwl::Message::Generic;
219
220use base qw( BarnOwl::Message );
221
222#####################################################################
223#####################################################################
224
225package BarnOwl::Message::AIM;
226
227use base qw( BarnOwl::Message );
228
229# all non-loginout AIM messages are personal for now...
230sub is_personal { 
231    return !(shift->is_loginout);
232}
233
234#####################################################################
235#####################################################################
236
237package BarnOwl::Message::Zephyr;
238
239use base qw( BarnOwl::Message );
240
241sub login_tty { 
242    my ($m) = @_;
243    return undef if (!$m->is_loginout);
244    return $m->fields->[2];
245}
246
247sub login_host { 
248    my ($m) = @_;
249    return undef if (!$m->is_loginout);
250    return $m->fields->[0];
251}
252
253sub zwriteline  { return shift->{"zwriteline"}; }
254
255sub is_ping     { return (lc(shift->opcode) eq "ping"); }
256
257sub is_personal { 
258    my ($m) = @_;
259    return ((lc($m->class) eq "message")
260            && (lc($m->instance) eq "personal")
261            && $m->is_private);
262}
263
264sub is_mail { 
265    my ($m) = @_;
266    return ((lc($m->class) eq "mail") && $m->is_private);
267}
268
269sub pretty_sender {
270    my ($m) = @_;
271    my $sender = $m->sender;
272    my $realm = BarnOwl::zephyr_getrealm();
273    $sender =~ s/\@$realm$//;
274    return $sender;
275}
276
277sub pretty_recipient {
278    my ($m) = @_;
279    my $recip = $m->recipient;
280    my $realm = BarnOwl::zephyr_getrealm();
281    $recip =~ s/\@$realm$//;
282    return $recip;
283}
284
285# These are arguably zephyr-specific
286sub class       { return shift->{"class"}; }
287sub instance    { return shift->{"instance"}; }
288sub realm       { return shift->{"realm"}; }
289sub opcode      { return shift->{"opcode"}; }
290sub host        { return shift->{"hostname"}; }
291sub hostname    { return shift->{"hostname"}; }
292sub header      { return shift->{"header"}; }
293sub auth        { return shift->{"auth"}; }
294sub fields      { return shift->{"fields"}; }
295sub zsig        { return shift->{"zsig"}; }
296
297#####################################################################
298#####################################################################
299################################################################################
300package BarnOwl;
301
302################################################################################
303# Mainloop hook
304################################################################################
305
306our $shutdown;
307$shutdown = 0;
308our $reload;
309$reload = 0;
310
311#Run this on start and reload. Adds modules
312sub onStart
313{
314    reload_init();
315    loadModules();
316}
317################################################################################
318# Reload Code, taken from /afs/sipb/user/jdaniel/project/owl/perl
319################################################################################
320sub reload_hook (@)
321{
322    BarnOwl::Hooks::startup();
323    return 1;
324}
325
326sub reload
327{
328    # Use $reload to tell modules that we're performing a reload.
329  {
330      local $reload = 1;
331      BarnOwl::mainloop_hook() if *BarnOwl::mainloop_hook{CODE};
332  }
333   
334  @BarnOwl::Hooks::onMainLoop = ();
335  @BarnOwl::Hooks::onStartSubs = ();
336
337  # Do reload
338  package main;
339  if (-r $BarnOwl::configfile) {
340      undef $@;
341      do $BarnOwl::configfile;
342      BarnOwl::error("Error reloading $BarnOwl::configfile: $@") if $@;
343  }
344  BarnOwl::reload_hook(@_);
345  package BarnOwl;
346}
347
348sub reload_init () 
349{
350    BarnOwl::command('alias reload perl BarnOwl::reload()');
351    BarnOwl::command('bindkey global "C-x C-r" command reload');
352}
353
354################################################################################
355# Loads modules from ~/.owl/modules and owl's data directory
356################################################################################
357
358sub loadModules () {
359    my @modules;
360    my $rv;
361    foreach my $dir ( BarnOwl::get_data_dir() . "/modules",
362                      $ENV{HOME} . "/.owl/modules" )
363    {
364        opendir( MODULES, $dir );
365
366        # source ./modules/*.pl
367        @modules = sort grep( /\.pl$/, readdir(MODULES) );
368
369        foreach my $mod (@modules) {
370            unless ($rv = do "$dir/$mod") {
371                BarnOwl::error("Couldn't load $dir/$mod:\n $@") if $@;
372                BarnOwl::error("Couldn't run $dir/$mod:\n $!") unless defined $rv;
373            }
374        }
375        closedir(MODULES);
376    }
377}
378
379sub _load_owlconf {
380    # Only do this the first time
381    return if $BarnOwl::reload;
382    # load the config  file
383    if ( -r $BarnOwl::configfile ) {
384        undef $@;
385        do $BarnOwl::configfile;
386        die $@ if $@;
387    }
388}
389
390push @BarnOwl::Hooks::onStartSubs, \&_load_owlconf;
391
392package BarnOwl::Hooks;
393
394# Arrays of subrefs to be called at specific times.
395our @onStartSubs = ();
396our @onReceiveMsg = ();
397our @onMainLoop = ();
398our @onGetBuddyList = ();
399
400# Functions to call hook lists
401sub runHook($@)
402{
403    my $hook = shift;
404    my @args = @_;
405    $_->(@args) for (@$hook);
406}
407
408sub runHook_accumulate($@)
409{
410    my $hook = shift;
411    my @args = @_;
412    return join("\n", map {$_->(@args)} @$hook);
413}
414
415################################################################################
416# Startup and Shutdown code
417################################################################################
418sub startup
419{
420    # Modern versions of owl provides a great place to have startup stuff.
421    # Put things in ~/.owl/startup
422
423    #So that the user's .owlconf can have startsubs, we don't clear
424    #onStartSubs; reload does however
425    @onReceiveMsg = ();
426    @onMainLoop = ();
427    @onGetBuddyList = ();
428
429    BarnOwl::onStart();
430
431    runHook(\@onStartSubs);
432
433    BarnOwl::startup() if *BarnOwl::startup{CODE};
434}
435
436sub shutdown
437{
438# Modern versions of owl provides a great place to have shutdown stuff.
439# Put things in ~/.owl/shutdown
440
441    # use $shutdown to tell modules that that's what we're doing.
442    $BarnOwl::shutdown = 1;
443    BarnOwl::mainloop_hook();
444
445    BarnOwl::shutdown() if *BarnOwl::shutdown{CODE};
446}
447
448sub mainloop_hook
449{
450    runHook(\@onMainLoop);
451    BarnOwl::mainloop_hook() if *BarnOwl::mainloop_hook{CODE};
452}
453
454################################################################################
455# Hooks into receive_msg()
456################################################################################
457
458sub receive_msg
459{
460    my $m = shift;
461    runHook(\@onReceiveMsg, $m);
462    BarnOwl::receive_msg($m) if *BarnOwl::receive_msg{CODE};
463}
464
465################################################################################
466# Hooks into get_blist()
467################################################################################
468
469sub get_blist
470{
471    return runHook_accumulate(\@onGetBuddyList);
472}
473
474################################################################################
475# Built-in perl styles
476################################################################################
477package BarnOwl::Style::Default;
478################################################################################
479# Branching point for various formatting functions in this style.
480################################################################################
481sub format_message($)
482{
483    my $m = shift;
484
485    if ( $m->is_zephyr ) {
486        return format_zephyr($m);
487    }
488    elsif ( $m->is_admin ) {
489        return "\@bold(OWL ADMIN)\n" . indentBody($m);
490    }
491    elsif ( $m->is_aim ) {
492        return format_aim($m);
493    }
494    elsif ( lc( $m->type ) eq 'loopback' ) {
495        return format_loopback($m);
496    }
497    else {
498        return "Unexpected message type.";
499    }
500}
501
502BarnOwl::_create_style("default", "BarnOwl::Style::Default::format_message", "Default style");
503
504################################################################################
505sub format_zephyr($)
506{
507    my $m = shift;
508
509    # Extract time from message
510    my ($time) = $m->time =~ /(\d\d:\d\d)/;
511
512    # Deal with PING messages, assuming owl's rxping variable is true.
513    if ( $m->is_ping && $m->recipient ne "" ) {
514        return ( "\@b(PING) from \@b(" . $m->pretty_sender . ")\n" );
515    }
516
517    # Deal with login/logout messages
518    elsif ( $m->is_loginout ) {
519        return sprintf(
520            '@b<%s%s> for @b(%s) at %s %s %s',
521            uc( $m->login ),
522
523            # This is a hack, owl does not export "pseudo"-ness
524            ( $m->zsig ) ? "" : " (PSEUDO)",
525            $m->pretty_sender,
526            lc( $m->host ),
527            $m->login_tty,
528            $time
529        );
530    }
531
532    # Deal with outbound zephyrs (personal, we don't see outbound non-personal)
533    elsif ( lc( $m->direction ) eq 'out' ) {
534        my $user = $m->recipient;
535        $user =~ s/\@ATHENA[.]MIT[.]EDU$//;
536
537        my $zsig = $m->zsig;
538        $zsig =~ s/\n.*$//s;
539
540        return sprintf( "Zephyr sent to %s  %s  (Zsig: %s)\n%s",
541            $user, $time, $zsig, indentBody($m) );
542    }
543
544    # Deal with everything else
545    else {
546        my $zsig = $m->zsig;
547        $zsig =~ s/\n.*$//s;
548
549        my $msg = sprintf(
550            "%s / %s / \@b<%s>%s  %s    (%s)\n%s",
551            $m->class, $m->instance, $m->pretty_sender,
552            ( $m->opcode ? " [@{[$m->opcode]}]" : "" ),
553            $time, $zsig, indentBody($m)
554        );
555        return BarnOwl::Style::boldify($msg) if ( $m->is_private );
556        return $msg;
557    }
558}
559
560
561sub format_aim($)
562{
563    my $m = shift;
564
565    # Extract time from message
566    my ($time) = $m->time =~ /(\d\d:\d\d)/;
567
568    # Deal with login/logout messages
569    if ( $m->is_loginout ) {
570        return
571          sprintf( "\@b(AIM %s) for %s %s",
572                   uc( $m->login ),
573                   $m->sender,
574                   $time );
575    }
576    elsif ( lc( $m->direction ) eq 'out' ) {
577        return sprintf( "AIM sent to %s  %s\n%s",
578                        $m->recipient,
579                        $time,
580                        indentBody($m) );
581    }
582    else {
583        return sprintf( "\@b(AIM from %s)  %s\n%s",
584                        $m->sender,
585                        $time,
586                        BarnOwl::Style::boldify( indentBody($m) ) );
587    }
588}
589
590
591sub format_loopback($)
592{
593    my $m = shift;
594
595    # Extract time from message
596    my ($time) = $m->time =~ /(\d\d:\d\d)/;
597
598    return sprintf( "loopback from: %s to: %s  %s\n%s",
599        $m->sender, $m->recipient, $time, indentBody($m) );
600}
601
602
603sub indentBody($)
604{
605    my $m = shift;
606   
607    my $body = $m->body;
608    # replace newline followed by anything with
609    # newline plus four spaces and that thing.
610    $body =~ s/\n(.)/\n    $1/g;
611
612    return "    ".$body;
613}
614
615
616package BarnOwl::Style;
617
618# This takes a zephyr to be displayed and modifies it to be displayed
619# entirely in bold.
620sub boldify($)
621{
622    local $_ = shift;
623    if ( !(/\)/) ) {
624        return '@b(' . $_ . ')';
625    } elsif ( !(/\>/) ) {
626        return '@b<' . $_ . '>';
627    } elsif ( !(/\}/) ) {
628        return '@b{' . $_ . '}';
629    } elsif ( !(/\]/) ) {
630        return '@b[' . $_ . ']';
631    } else {
632        my $txt = "\@b($_";
633        $txt =~ s/\)/\)\@b\[\)\]\@b\(/g;
634        return $txt . ')';
635    }
636}
637
638
639# switch to package main when we're done
640package main;
641# alias the hooks
642{
643    no strict 'refs';
644    foreach my $hook  qw (onStartSubs
645                          onReceiveMsg
646                          onMainLoop
647                          onGetBuddyList ) {
648        *{"main::".$hook} = \*{"BarnOwl::Hooks::".$hook};
649        *{"owl::".$hook} = \*{"BarnOwl::Hooks::".$hook};
650    }
651}
652
6531;
Note: See TracBrowser for help on using the repository browser.