source: perlwrap.pm @ e3cc184

barnowl_perlaimdebianrelease-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since e3cc184 was 0449730, checked in by Nelson Elhage <nelhage@mit.edu>, 14 years ago
Only show the first line of zsigs
  • Property mode set to 100644
File size: 16.5 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
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
[f1e629d]12
[c681337]13use strict;
14use warnings;
15
[8203afd]16package BarnOwl;
[f1e629d]17
[8862725]18
19BEGIN {
[f1e629d]20# bootstrap in C bindings and glue
[8203afd]21    *owl:: = \*BarnOwl::;
22    bootstrap BarnOwl 1.2;
[8862725]23};
24
[3354cea5]25use lib(get_data_dir()."/lib");
[8862725]26use lib($::ENV{'HOME'}."/.owl/lib");
27
[00f9a7d]28our $configfile;
29
30$configfile ||= $::ENV{'HOME'}."/.owlconf";
[d03091c]31
[f1e629d]32# populate global variable space for legacy owlconf files
33sub _format_msg_legacy_wrap {
34    my ($m) = @_;
35    $m->legacy_populate_global();
[8203afd]36    return &BarnOwl::format_msg($m);
[f1e629d]37}
38
39# populate global variable space for legacy owlconf files
40sub _receive_msg_legacy_wrap {
41    my ($m) = @_;
42    $m->legacy_populate_global();
[8203afd]43    return &BarnOwl::Hooks::receive_msg($m);
[f1e629d]44}
45
[8203afd]46# make BarnOwl::<command>("foo") be aliases to BarnOwl::command("<command> foo");
[f1e629d]47sub AUTOLOAD {
[c681337]48    our $AUTOLOAD;
[f1e629d]49    my $called = $AUTOLOAD;
50    $called =~ s/.*:://;
[e7ac2b6]51    $called =~ s/_/-/g;
[8203afd]52    return &BarnOwl::command("$called ".join(" ",@_));
[f1e629d]53}
54
[6922edd]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
[c681337]77    no warnings 'uninitialized';
[8203afd]78    BarnOwl::new_command_internal($name, $func, $args{summary}, $args{usage}, $args{description});
[6922edd]79}
80
[f1e629d]81#####################################################################
82#####################################################################
83
[8203afd]84package BarnOwl::Message;
[f1e629d]85
[dd16bdd]86sub new {
87    my $class = shift;
88    my %args = (@_);
89    if($class eq __PACKAGE__ && $args{type}) {
[8203afd]90        $class = "BarnOwl::Message::" . ucfirst $args{type};
[dd16bdd]91    }
92    return bless {%args}, $class;
93}
94
[f1e629d]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"}; }
[216c734]103sub is_private  { return shift->{"private"}; }
[f1e629d]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"); }
[421c8ef7]115sub is_zephyr   { return (shift->{"type"} eq "zephyr"); }
[467aa16]116sub is_aim      { return (shift->{"type"} eq "AIM"); }
[dd16bdd]117sub is_jabber   { return (shift->{"type"} eq "jabber"); }
[421c8ef7]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"); }
[f1e629d]122
123# These are overridden by appropriate message types
124sub is_ping     { return 0; }
125sub is_mail     { return 0; }
[3c9012b]126sub is_personal { return shift->is_private; }
[f1e629d]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; }
[87c6ef1]138sub login_host  { return undef; }
139sub login_tty   { return undef; }
[f1e629d]140
[ae47efb]141sub pretty_sender    { return shift->sender; }
142sub pretty_recipient { return shift->recipient; }
[f1e629d]143
144sub delete {
145    my ($m) = @_;
[8203afd]146    &BarnOwl::command("delete --id ".$m->id);
[f1e629d]147}
148
149sub undelete {
150    my ($m) = @_;
[8203afd]151    &BarnOwl::command("undelete --id ".$m->id);
[f1e629d]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) = @_;
[8203afd]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      ;
[f1e629d]193    if ($m->fields) {
[8203afd]194        @BarnOwl::fields = @{$m->fields};
[f1e629d]195        @main::fields = @{$m->fields};
196    } else {
[8203afd]197        @BarnOwl::fields = undef;
[f1e629d]198        @main::fields = undef;
199    }
200}
201
[25729b2]202sub smartfilter {
203    die("smartfilter not supported for this message");
204}
205
[6e6ded7]206# Display fields -- overridden by subclasses when needed
207sub login_type {""}
208sub login_extra {""}
209sub long_sender {""}
210
211# The context in which a non-personal message was sent, e.g. a chat or
212# class
213sub context {""}
214
215# Some indicator of context *within* $self->context. e.g. the zephyr
216# instance
217sub subcontext {""}
218
[f1e629d]219#####################################################################
220#####################################################################
221
[8203afd]222package BarnOwl::Message::Admin;
[f1e629d]223
[8203afd]224use base qw( BarnOwl::Message );
[f1e629d]225
226sub header       { return shift->{"header"}; }
227
228#####################################################################
229#####################################################################
230
[8203afd]231package BarnOwl::Message::Generic;
[f1e629d]232
[8203afd]233use base qw( BarnOwl::Message );
[f1e629d]234
235#####################################################################
236#####################################################################
237
[8203afd]238package BarnOwl::Message::AIM;
[f1e629d]239
[8203afd]240use base qw( BarnOwl::Message );
[f1e629d]241
242# all non-loginout AIM messages are personal for now...
243sub is_personal { 
244    return !(shift->is_loginout);
245}
246
247#####################################################################
248#####################################################################
249
[8203afd]250package BarnOwl::Message::Zephyr;
[f1e629d]251
[8203afd]252use base qw( BarnOwl::Message );
[f1e629d]253
[6e6ded7]254sub login_type {
255    return (shift->zsig eq "") ? "(PSEUDO)" : "";
256}
257
258sub login_extra {
259    my $m = shift;
260    return undef if (!$m->is_loginout);
261    my $s = lc($m->host);
262    $s .= " " . $m->login_tty if defined $m->login_tty;
263    return $s;
264}
265
266sub long_sender {
267    my $m = shift;
268    return $m->zsig;
269}
270
271sub context {
272    return shift->class;
273}
274
275sub subcontext {
276    return shift->instance;
277}
278
[f1e629d]279sub login_tty { 
280    my ($m) = @_;
281    return undef if (!$m->is_loginout);
282    return $m->fields->[2];
283}
284
285sub login_host { 
286    my ($m) = @_;
287    return undef if (!$m->is_loginout);
288    return $m->fields->[0];
289}
290
291sub zwriteline  { return shift->{"zwriteline"}; }
292
293sub is_ping     { return (lc(shift->opcode) eq "ping"); }
294
295sub is_personal { 
296    my ($m) = @_;
297    return ((lc($m->class) eq "message")
298            && (lc($m->instance) eq "personal")
299            && $m->is_private);
300}
301
302sub is_mail { 
303    my ($m) = @_;
304    return ((lc($m->class) eq "mail") && $m->is_private);
305}
306
307sub pretty_sender {
308    my ($m) = @_;
309    my $sender = $m->sender;
[8203afd]310    my $realm = BarnOwl::zephyr_getrealm();
[f1e629d]311    $sender =~ s/\@$realm$//;
312    return $sender;
313}
314
[ae47efb]315sub pretty_recipient {
316    my ($m) = @_;
317    my $recip = $m->recipient;
318    my $realm = BarnOwl::zephyr_getrealm();
319    $recip =~ s/\@$realm$//;
320    return $recip;
321}
322
[f1e629d]323# These are arguably zephyr-specific
324sub class       { return shift->{"class"}; }
325sub instance    { return shift->{"instance"}; }
326sub realm       { return shift->{"realm"}; }
327sub opcode      { return shift->{"opcode"}; }
328sub host        { return shift->{"hostname"}; }
329sub hostname    { return shift->{"hostname"}; }
330sub header      { return shift->{"header"}; }
331sub auth        { return shift->{"auth"}; }
332sub fields      { return shift->{"fields"}; }
333sub zsig        { return shift->{"zsig"}; }
334
335#####################################################################
336#####################################################################
[7e470da]337################################################################################
[b6c067a]338package BarnOwl;
[7e470da]339
340################################################################################
[f265f94]341# Mainloop hook
[7e470da]342################################################################################
343
[f265f94]344our $shutdown;
[7e470da]345$shutdown = 0;
[f265f94]346our $reload;
[7e470da]347$reload = 0;
348
[8203afd]349#Run this on start and reload. Adds modules
[7e470da]350sub onStart
351{
352    reload_init();
353    loadModules();
354}
355################################################################################
356# Reload Code, taken from /afs/sipb/user/jdaniel/project/owl/perl
357################################################################################
[f265f94]358sub reload_hook (@)
[7e470da]359{
[8203afd]360    BarnOwl::Hooks::startup();
[7e470da]361    return 1;
362}
363
[f265f94]364sub reload
[7e470da]365{
[f265f94]366    # Use $reload to tell modules that we're performing a reload.
[8203afd]367  {
368      local $reload = 1;
[16138b0]369      BarnOwl::mainloop_hook() if *BarnOwl::mainloop_hook{CODE};
[8203afd]370  }
[b6c067a]371   
[8203afd]372  @BarnOwl::Hooks::onMainLoop = ();
373  @BarnOwl::Hooks::onStartSubs = ();
374
375  # Do reload
376  package main;
[1a9c761]377  if (-r $BarnOwl::configfile) {
378      undef $@;
379      do $BarnOwl::configfile;
[b6c067a]380      BarnOwl::error("Error reloading $BarnOwl::configfile: $@") if $@;
[8203afd]381  }
[1a9c761]382  BarnOwl::reload_hook(@_);
[b6c067a]383  package BarnOwl;
[7e470da]384}
385
386sub reload_init () 
387{
[8203afd]388    BarnOwl::command('alias reload perl BarnOwl::reload()');
389    BarnOwl::command('bindkey global "C-x C-r" command reload');
[7e470da]390}
391
392################################################################################
393# Loads modules from ~/.owl/modules and owl's data directory
394################################################################################
395
[f2f5815]396sub loadModules () {
397    my @modules;
[23be736]398    my $rv;
[8203afd]399    foreach my $dir ( BarnOwl::get_data_dir() . "/modules",
[23be736]400                      $ENV{HOME} . "/.owl/modules" )
[f2f5815]401    {
402        opendir( MODULES, $dir );
403
404        # source ./modules/*.pl
[4ee1cf4]405        @modules = sort grep( /\.pl$/, readdir(MODULES) );
[f2f5815]406
407        foreach my $mod (@modules) {
[23be736]408            unless ($rv = do "$dir/$mod") {
[8203afd]409                BarnOwl::error("Couldn't load $dir/$mod:\n $@") if $@;
410                BarnOwl::error("Couldn't run $dir/$mod:\n $!") unless defined $rv;
[23be736]411            }
[f2f5815]412        }
413        closedir(MODULES);
414    }
[7e470da]415}
416
[b6c067a]417sub _load_owlconf {
418    # Only do this the first time
419    return if $BarnOwl::reload;
420    # load the config  file
421    if ( -r $BarnOwl::configfile ) {
422        undef $@;
423        do $BarnOwl::configfile;
424        die $@ if $@;
425    }
426}
427
428push @BarnOwl::Hooks::onStartSubs, \&_load_owlconf;
429
[8203afd]430package BarnOwl::Hooks;
431
432# Arrays of subrefs to be called at specific times.
433our @onStartSubs = ();
434our @onReceiveMsg = ();
435our @onMainLoop = ();
436our @onGetBuddyList = ();
[7e470da]437
[8203afd]438# Functions to call hook lists
439sub runHook($@)
440{
441    my $hook = shift;
442    my @args = @_;
443    $_->(@args) for (@$hook);
444}
445
446sub runHook_accumulate($@)
447{
448    my $hook = shift;
449    my @args = @_;
450    return join("\n", map {$_->(@args)} @$hook);
451}
452
453################################################################################
454# Startup and Shutdown code
455################################################################################
456sub startup
457{
458    # Modern versions of owl provides a great place to have startup stuff.
459    # Put things in ~/.owl/startup
460
461    #So that the user's .owlconf can have startsubs, we don't clear
462    #onStartSubs; reload does however
463    @onReceiveMsg = ();
464    @onMainLoop = ();
465    @onGetBuddyList = ();
466
467    BarnOwl::onStart();
468
469    runHook(\@onStartSubs);
470
471    BarnOwl::startup() if *BarnOwl::startup{CODE};
472}
473
474sub shutdown
475{
476# Modern versions of owl provides a great place to have shutdown stuff.
477# Put things in ~/.owl/shutdown
478
479    # use $shutdown to tell modules that that's what we're doing.
480    $BarnOwl::shutdown = 1;
481    BarnOwl::mainloop_hook();
482
483    BarnOwl::shutdown() if *BarnOwl::shutdown{CODE};
484}
485
486sub mainloop_hook
487{
488    runHook(\@onMainLoop);
[16138b0]489    BarnOwl::mainloop_hook() if *BarnOwl::mainloop_hook{CODE};
[8203afd]490}
[f2f5815]491
[7e470da]492################################################################################
493# Hooks into receive_msg()
494################################################################################
495
[f2f5815]496sub receive_msg
[7e470da]497{
498    my $m = shift;
[f2f5815]499    runHook(\@onReceiveMsg, $m);
[8203afd]500    BarnOwl::receive_msg($m) if *BarnOwl::receive_msg{CODE};
[7e470da]501}
502
503################################################################################
504# Hooks into get_blist()
505################################################################################
506
[f2f5815]507sub get_blist
[7e470da]508{
[8203afd]509    return runHook_accumulate(\@onGetBuddyList);
[7e470da]510}
[dd16bdd]511
[b6c067a]512################################################################################
513# Built-in perl styles
514################################################################################
515package BarnOwl::Style::Default;
516################################################################################
517# Branching point for various formatting functions in this style.
518################################################################################
519sub format_message($)
520{
521    my $m = shift;
522
[6e6ded7]523    if ( $m->is_loginout) {
524        return format_login($m);
525    } elsif($m->is_ping) {
526        return ( "\@b(PING) from \@b(" . $m->pretty_sender . ")\n" );
527    } elsif($m->is_admin) {
[b6c067a]528        return "\@bold(OWL ADMIN)\n" . indentBody($m);
[6e6ded7]529    } else {
530        return format_chat($m);
[b6c067a]531    }
532}
533
534BarnOwl::_create_style("default", "BarnOwl::Style::Default::format_message", "Default style");
535
536################################################################################
537
[6e6ded7]538sub time_hhmm {
539    my $m = shift;
[b6c067a]540    my ($time) = $m->time =~ /(\d\d:\d\d)/;
[6e6ded7]541    return $time;
[b6c067a]542}
543
[6e6ded7]544sub format_login($) {
[b6c067a]545    my $m = shift;
[6e6ded7]546    return sprintf(
547        '@b<%s%s> for @b(%s) (%s) %s',
548        uc( $m->login ),
549        $m->login_type,
550        $m->pretty_sender,
551        $m->login_extra,
552        time_hhmm($m)
553       );
[b6c067a]554}
555
[6e6ded7]556sub format_chat($) {
[b6c067a]557    my $m = shift;
[6e6ded7]558    my $header;
559    if ( $m->is_personal ) {
560        if ( $m->direction eq "out" ) {
561            $header = ucfirst $m->type . " sent to " . $m->pretty_recipient;
562        } else {
563            $header = ucfirst $m->type . " from " . $m->pretty_sender;
564        }
565    } else {
566        $header = $m->context;
567        if($m->subcontext) {
568            $header .= " / " . $m->subcontext;
569        }
570        $header .= " / " . $m->pretty_sender;
571    }
[b6c067a]572
[6e6ded7]573    $header .= "  " . time_hhmm($m);
[0449730]574    my $sender = $m->long_sender;
575    $sender =~ s/\n.*$//s;
576    $header .= "\t(" . $sender . ")";
[6e6ded7]577    my $message = $header . "\n". indentBody($m);
578    if($m->is_private && $m->direction eq "in") {
579        $message = BarnOwl::Style::boldify($message);
580    }
581    return $message;
[b6c067a]582}
583
584sub indentBody($)
585{
586    my $m = shift;
587   
588    my $body = $m->body;
589    # replace newline followed by anything with
590    # newline plus four spaces and that thing.
591    $body =~ s/\n(.)/\n    $1/g;
592
593    return "    ".$body;
594}
595
596
597package BarnOwl::Style;
598
599# This takes a zephyr to be displayed and modifies it to be displayed
600# entirely in bold.
601sub boldify($)
602{
603    local $_ = shift;
604    if ( !(/\)/) ) {
605        return '@b(' . $_ . ')';
606    } elsif ( !(/\>/) ) {
607        return '@b<' . $_ . '>';
608    } elsif ( !(/\}/) ) {
609        return '@b{' . $_ . '}';
610    } elsif ( !(/\]/) ) {
611        return '@b[' . $_ . ']';
612    } else {
613        my $txt = "\@b($_";
614        $txt =~ s/\)/\)\@b\[\)\]\@b\(/g;
615        return $txt . ')';
616    }
617}
618
619
[f1e629d]620# switch to package main when we're done
621package main;
[7e470da]622# alias the hooks
[c681337]623{
624    no strict 'refs';
625    foreach my $hook  qw (onStartSubs
626                          onReceiveMsg
627                          onMainLoop
628                          onGetBuddyList ) {
[8203afd]629        *{"main::".$hook} = \*{"BarnOwl::Hooks::".$hook};
630        *{"owl::".$hook} = \*{"BarnOwl::Hooks::".$hook};
[c681337]631    }
[7e470da]632}
[f1e629d]633
6341;
Note: See TracBrowser for help on using the repository browser.