source: perlwrap.pm @ 34509d5

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