source: perlwrap.pm @ 52594d1

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