source: perlwrap.pm @ bb2c60d

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