source: perlwrap.pm @ 33539f7

release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 33539f7 was 33539f7, checked in by Alex Dehnert <adehnert@mit.edu>, 12 years ago
Display context for pings
  • Property mode set to 100644
File size: 32.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 live
10# in BarnOwl::Hooks::_startup
11
12use strict;
13use warnings;
14
15package BarnOwl;
16
17=head1 NAME
18
19BarnOwl
20
21=head1 DESCRIPTION
22
23The BarnOwl module contains the core of BarnOwl's perl
24bindings. Source in this module is also run at startup to bootstrap
25barnowl by defining things like the default style.
26
27=for NOTE
28These following functions are defined in perlglue.xs. Keep the
29documentation here in sync with the user-visible commands defined
30there!
31
32=head2 command STRING
33
34Executes a BarnOwl command in the same manner as if the user had
35executed it at the BarnOwl command prompt. If the command returns a
36value, return it as a string, otherwise return undef.
37
38=head2 getcurmsg
39
40Returns the current message as a C<BarnOwl::Message> subclass, or
41undef if there is no message selected
42
43=head2 getnumcols
44
45Returns the width of the display window BarnOwl is currently using
46
47=head2 getidletime
48
49Returns the length of time since the user has pressed a key, in
50seconds.
51
52=head2 zephyr_getrealm
53
54Returns the zephyr realm barnowl is running in
55
56=head2 zephyr_getsender
57
58Returns the fully-qualified name of the zephyr sender barnowl is
59running as, e.g. C<nelhage@ATHENA.MIT.EDU>
60
61=head2 zephyr_zwrite COMMAND MESSAGE
62
63Sends a zephyr programmatically. C<COMMAND> should be a C<zwrite>
64command line, and C<MESSAGE> is the zephyr body to send.
65
66=head2 ztext_stylestrip STRING
67
68Strips zephyr formatting from a string and returns the result
69
70=head2 zephyr_getsubs
71
72Returns the list of subscription triples <class,instance,recipient>,
73separated by newlines.
74
75=head2 queue_message MESSAGE
76
77Enqueue a message in the BarnOwl message list, logging it and
78processing it appropriately. C<MESSAGE> should be an instance of
79BarnOwl::Message or a subclass.
80
81=head2 admin_message HEADER BODY
82
83Display a BarnOwl B<Admin> message, with the given header and body.
84
85=head2 start_question PROMPT CALLBACK
86
87Displays C<PROMPT> on the screen and lets the user enter a line of
88text, and calls C<CALLBACK>, which must be a perl subroutine
89reference, with the text the user entered
90
91=head2 start_password PROMPT CALLBACK
92
93Like C<start_question>, but echoes the user's input as C<*>s when they
94input.
95
96=head2 start_edit_win PROMPT CALLBACK
97
98Like C<start_question>, but displays C<PROMPT> on a line of its own
99and opens the editwin. If the user cancels the edit win, C<CALLBACK>
100is not invoked.
101
102=head2 get_data_dir
103
104Returns the BarnOwl system data directory, where system libraries and
105modules are stored
106
107=head2 get_config_dir
108
109Returns the BarnOwl user configuration directory, where user modules
110and configuration are stored (by default, C<$HOME/.owl>)
111
112=head2 popless_text TEXT
113
114Show a popup window containing the given C<TEXT>
115
116=head2 popless_ztext TEXT
117
118Show a popup window containing the provided zephyr-formatted C<TEXT>
119
120=head2 error STRING
121
122Reports an error and log it in `show errors'. Note that in any
123callback or hook called in perl code from BarnOwl, a C<die> will be
124caught and passed to C<error>.
125
126=head2 getnumcolors
127
128Returns the number of colors this BarnOwl is capable of displaying
129
130=head2 add_dispatch FD CALLBACK
131
132Adds a file descriptor to C<BarnOwl>'s internal C<select()>
133loop. C<CALLBACK> will be invoked whenever data is available to be
134read from C<FD>.
135
136=head2 remove_dispatch FD
137
138Remove a file descriptor previously registered via C<add_dispatch>
139
140=head2 create_style NAME OBJECT
141
142Creates a new barnowl style with the given NAME defined by the given
143object. The object must have a C<description> method which returns a
144string description of the style, and a and C<format_message> method
145which accepts a C<BarnOwl::Message> object and returns a string that
146is the result of formatting the message for display.
147
148=cut
149
150
151BEGIN {
152# bootstrap in C bindings and glue
153    *owl:: = \*BarnOwl::;
154    bootstrap BarnOwl 1.2;
155};
156
157use lib(get_data_dir() . "/lib");
158use lib(get_config_dir() . "/lib");
159
160# perlconfig.c will set this to the value of the -c command-line
161# switch, if present.
162our $configfile;
163
164if(!$configfile && -f $ENV{HOME} . "/.barnowlconf") {
165    $configfile = $ENV{HOME} . "/.barnowlconf";
166}
167$configfile ||= $ENV{HOME}."/.owlconf";
168
169# populate global variable space for legacy owlconf files
170sub _receive_msg_legacy_wrap {
171    my ($m) = @_;
172    $m->legacy_populate_global();
173    return &BarnOwl::Hooks::_receive_msg($m);
174}
175
176=head2 AUTOLOAD
177
178BarnOwl.pm has a C<AUTOLOAD> method that translates unused names in
179the BarnOwl:: namespace to a call to BarnOwl::command() with that
180command. Underscores are also translated to C<->s, so you can do
181e.g. C<BarnOwl::start_command()> and it will be translated into
182C<start-command>.
183
184So, if you're looking for functionality that you can't find in the
185perl interface, check C<:show commands> or C<commands.c> in the
186BarnOwl source tree -- there's a good chance it exists as a BarnOwl
187command.
188
189=head3 BUGS
190
191There are horrible quoting issues here. The AUTOLOAD simple joins your
192commands with spaces and passes them unmodified to C<::command>
193
194=cut
195
196# make BarnOwl::<command>("foo") be aliases to BarnOwl::command("<command> foo");
197sub AUTOLOAD {
198    our $AUTOLOAD;
199    my $called = $AUTOLOAD;
200    $called =~ s/.*:://;
201    $called =~ s/_/-/g;
202    return &BarnOwl::command("$called ".join(" ",@_));
203}
204
205=head2 new_command NAME FUNC [{ARGS}]
206
207Add a new owl command. When owl executes the command NAME, FUNC will
208be called with the arguments passed to the command, with NAME as the
209first argument.
210
211ARGS should be a hashref containing any or all of C<summary>,
212C<usage>, or C<description> keys:
213
214=over 4
215
216=item summary
217
218A one-line summary of the purpose of the command
219
220=item usage
221
222A one-line usage synopsis, showing available options and syntax
223
224=item description
225
226A longer description of the syntax and semantics of the command,
227explaining usage and options
228
229=back
230
231=cut
232
233sub new_command {
234    my $name = shift;
235    my $func = shift;
236    my $args = shift || {};
237    my %args = (
238        summary     => "",
239        usage       => "",
240        description => "",
241        %{$args}
242    );
243
244    BarnOwl::Internal::new_command($name, $func, $args{summary}, $args{usage}, $args{description});
245}
246
247=head2 new_variable_int NAME [{ARGS}]
248
249=head2 new_variable_bool NAME [{ARGS}]
250
251=head2 new_variable_string NAME [{ARGS}]
252
253Add a new owl variable, either an int, a bool, or a string, with the
254specified name.
255
256ARGS can optionally contain the following keys:
257
258=over 4
259
260=item default
261
262The default and initial value for the variable
263
264=item summary
265
266A one-line summary of the variable's purpose
267
268=item description
269
270A longer description of the function of the variable
271
272=back
273
274=cut
275
276sub new_variable_int {
277    unshift @_, \&BarnOwl::Internal::new_variable_int, 0;
278    goto \&_new_variable;
279}
280
281sub new_variable_bool {
282    unshift @_, \&BarnOwl::Internal::new_variable_bool, 0;
283    goto \&_new_variable;
284}
285
286sub new_variable_string {
287    unshift @_, \&BarnOwl::Internal::new_variable_string, "";
288    goto \&_new_variable;
289}
290
291sub _new_variable {
292    my $func = shift;
293    my $default_default = shift;
294    my $name = shift;
295    my $args = shift || {};
296    my %args = (
297        summary     => "",
298        description => "",
299        default     => $default_default,
300        %{$args});
301    $func->($name, $args{default}, $args{summary}, $args{description});
302}
303
304=head2 quote STRING
305
306Return a version of STRING fully quoted to survive processing by
307BarnOwl's command parser.
308
309=cut
310
311sub quote {
312    my $str = shift;
313    return "''" if $str eq '';
314    if ($str !~ /['" ]/) {
315        return "$str";
316    }
317    if ($str !~ /'/) {
318        return "'$str'";
319    }
320    $str =~ s/"/"'"'"/g;
321    return '"' . $str . '"';
322}
323
324#####################################################################
325#####################################################################
326
327package BarnOwl::Message;
328
329sub new {
330    my $class = shift;
331    my %args = (@_);
332    if($class eq __PACKAGE__ && $args{type}) {
333        $class = "BarnOwl::Message::" . ucfirst $args{type};
334    }
335    return bless {%args}, $class;
336}
337
338sub type        { return shift->{"type"}; }
339sub direction   { return shift->{"direction"}; }
340sub time        { return shift->{"time"}; }
341sub id          { return shift->{"id"}; }
342sub body        { return shift->{"body"}; }
343sub sender      { return shift->{"sender"}; }
344sub recipient   { return shift->{"recipient"}; }
345sub login       { return shift->{"login"}; }
346sub is_private  { return shift->{"private"}; }
347
348sub is_login    { return shift->login eq "login"; }
349sub is_logout   { return shift->login eq "logout"; }
350sub is_loginout { my $m=shift; return ($m->is_login or $m->is_logout); }
351sub is_incoming { return (shift->{"direction"} eq "in"); }
352sub is_outgoing { return (shift->{"direction"} eq "out"); }
353
354sub is_deleted  { return shift->{"deleted"}; }
355
356sub is_admin    { return (shift->{"type"} eq "admin"); }
357sub is_generic  { return (shift->{"type"} eq "generic"); }
358sub is_zephyr   { return (shift->{"type"} eq "zephyr"); }
359sub is_aim      { return (shift->{"type"} eq "AIM"); }
360sub is_jabber   { return (shift->{"type"} eq "jabber"); }
361sub is_icq      { return (shift->{"type"} eq "icq"); }
362sub is_yahoo    { return (shift->{"type"} eq "yahoo"); }
363sub is_msn      { return (shift->{"type"} eq "msn"); }
364sub is_loopback { return (shift->{"type"} eq "loopback"); }
365
366# These are overridden by appropriate message types
367sub is_ping     { return 0; }
368sub is_mail     { return 0; }
369sub is_personal { return shift->is_private; }
370sub class       { return undef; }
371sub instance    { return undef; }
372sub realm       { return undef; }
373sub opcode      { return undef; }
374sub header      { return undef; }
375sub host        { return undef; }
376sub hostname    { return undef; }
377sub auth        { return undef; }
378sub fields      { return undef; }
379sub zsig        { return undef; }
380sub zwriteline  { return undef; }
381sub login_host  { return undef; }
382sub login_tty   { return undef; }
383
384# This is for back-compat with old messages that set these properties
385# New protocol implementations are encourages to user override these
386# methods.
387sub replycmd         { return shift->{replycmd}};
388sub replysendercmd   { return shift->{replysendercmd}};
389
390sub pretty_sender    { return shift->sender; }
391sub pretty_recipient { return shift->recipient; }
392
393# Override if you want a context (instance, network, etc.) on personals
394sub personal_context { return ""; }
395
396sub delete {
397    my ($m) = @_;
398    &BarnOwl::command("delete --id ".$m->id);
399}
400
401sub undelete {
402    my ($m) = @_;
403    &BarnOwl::command("undelete --id ".$m->id);
404}
405
406# Serializes the message into something similar to the zwgc->vt format
407sub serialize {
408    my ($this) = @_;
409    my $s;
410    for my $f (keys %$this) {
411        my $val = $this->{$f};
412        if (ref($val) eq "ARRAY") {
413            for my $i (0..@$val-1) {
414                my $aval;
415                $aval = $val->[$i];
416                $aval =~ s/\n/\n$f.$i: /g;
417                $s .= "$f.$i: $aval\n";
418            }
419        } else {
420            $val =~ s/\n/\n$f: /g;
421            $s .= "$f: $val\n";
422        }
423    }
424    return $s;
425}
426
427# Populate the annoying legacy global variables
428sub legacy_populate_global {
429    my ($m) = @_;
430    $BarnOwl::direction  = $m->direction ;
431    $BarnOwl::type       = $m->type      ;
432    $BarnOwl::id         = $m->id        ;
433    $BarnOwl::class      = $m->class     ;
434    $BarnOwl::instance   = $m->instance  ;
435    $BarnOwl::recipient  = $m->recipient ;
436    $BarnOwl::sender     = $m->sender    ;
437    $BarnOwl::realm      = $m->realm     ;
438    $BarnOwl::opcode     = $m->opcode    ;
439    $BarnOwl::zsig       = $m->zsig      ;
440    $BarnOwl::msg        = $m->body      ;
441    $BarnOwl::time       = $m->time      ;
442    $BarnOwl::host       = $m->host      ;
443    $BarnOwl::login      = $m->login     ;
444    $BarnOwl::auth       = $m->auth      ;
445    if ($m->fields) {
446        @BarnOwl::fields = @{$m->fields};
447        @main::fields = @{$m->fields};
448    } else {
449        @BarnOwl::fields = undef;
450        @main::fields = undef;
451    }
452}
453
454sub smartfilter {
455    die("smartfilter not supported for this message\n");
456}
457
458# Display fields -- overridden by subclasses when needed
459sub login_type {""}
460sub login_extra {""}
461sub long_sender {""}
462
463# The context in which a non-personal message was sent, e.g. a chat or
464# class
465sub context {""}
466
467# Some indicator of context *within* $self->context. e.g. the zephyr
468# instance
469sub subcontext {""}
470
471#####################################################################
472#####################################################################
473
474package BarnOwl::Message::Admin;
475
476use base qw( BarnOwl::Message );
477
478sub header       { return shift->{"header"}; }
479
480#####################################################################
481#####################################################################
482
483package BarnOwl::Message::Generic;
484
485use base qw( BarnOwl::Message );
486
487#####################################################################
488#####################################################################
489
490package BarnOwl::Message::Loopback;
491
492use base qw( BarnOwl::Message );
493
494# all loopback messages are private
495sub is_private {
496  return 1;
497}
498
499sub replycmd {return 'loopwrite';}
500sub replysendercmd {return 'loopwrite';}
501
502#####################################################################
503#####################################################################
504
505package BarnOwl::Message::AIM;
506
507use base qw( BarnOwl::Message );
508
509# all non-loginout AIM messages are private for now...
510sub is_private {
511    return !(shift->is_loginout);
512}
513
514sub replycmd {
515    my $self = shift;
516    if ($self->is_incoming) {
517        return "aimwrite " . BarnOwl::quote($self->sender);
518    } else {
519        return "aimwrite " . BarnOwl::quote($self->recipient);
520    }
521}
522
523sub replysendercmd {
524    return shift->replycmd;
525}
526
527#####################################################################
528#####################################################################
529
530package BarnOwl::Message::Zephyr;
531
532use constant WEBZEPHYR_PRINCIPAL => "daemon.webzephyr";
533use constant WEBZEPHYR_CLASS     => "webzephyr";
534use constant WEBZEPHYR_OPCODE    => "webzephyr";
535
536use base qw( BarnOwl::Message );
537
538sub strip_realm {
539    my $sender = shift;
540    my $realm = BarnOwl::zephyr_getrealm();
541    $sender =~ s/\@$realm$//;
542    return $sender;
543}
544
545sub login_type {
546    return (shift->zsig eq "") ? "(PSEUDO)" : "";
547}
548
549sub login_extra {
550    my $m = shift;
551    return undef if (!$m->is_loginout);
552    my $s = lc($m->host);
553    $s .= " " . $m->login_tty if defined $m->login_tty;
554    return $s;
555}
556
557sub long_sender {
558    my $m = shift;
559    return $m->zsig;
560}
561
562sub context {
563    return shift->class;
564}
565
566sub subcontext {
567    return shift->instance;
568}
569
570sub login_tty {
571    my ($m) = @_;
572    return undef if (!$m->is_loginout);
573    return $m->fields->[2];
574}
575
576sub login_host {
577    my ($m) = @_;
578    return undef if (!$m->is_loginout);
579    return $m->fields->[0];
580}
581
582sub zwriteline  { return shift->{"zwriteline"}; }
583
584sub is_ping     { return (lc(shift->opcode) eq "ping"); }
585
586sub is_personal {
587    my ($m) = @_;
588    return ((lc($m->class) eq "message")
589            && $m->is_private);
590}
591
592sub is_mail {
593    my ($m) = @_;
594    return ((lc($m->class) eq "mail") && $m->is_private);
595}
596
597sub pretty_sender {
598    my ($m) = @_;
599    return strip_realm($m->sender);
600}
601
602sub pretty_recipient {
603    my ($m) = @_;
604    return strip_realm($m->recipient);
605}
606
607sub personal_context {
608    my ($m) = @_;
609    if (lc($m->instance) eq "personal") {
610        return "";
611    } else {
612        return "-i " . $m->instance;
613    }
614}
615
616# These are arguably zephyr-specific
617sub class       { return shift->{"class"}; }
618sub instance    { return shift->{"instance"}; }
619sub realm       { return shift->{"realm"}; }
620sub opcode      { return shift->{"opcode"}; }
621sub host        { return shift->{"hostname"}; }
622sub hostname    { return shift->{"hostname"}; }
623sub header      { return shift->{"header"}; }
624sub auth        { return shift->{"auth"}; }
625sub fields      { return shift->{"fields"}; }
626sub zsig        { return shift->{"zsig"}; }
627
628sub zephyr_cc {
629    my $self = shift;
630    return $1 if $self->body =~ /^\s*cc:\s+([^\n]+)/i;
631    return undef;
632}
633
634sub replycmd {
635    my $self = shift;
636    my $sender = shift;
637    $sender = 0 unless defined $sender;
638    my ($class, $instance, $to, $cc);
639    if($self->is_outgoing) {
640        return $self->{zwriteline};
641    }
642
643    if($sender && $self->opcode eq WEBZEPHYR_OPCODE) {
644        $class = WEBZEPHYR_CLASS;
645        $instance = $self->pretty_sender;
646        $instance =~ s/-webzephyr$//;
647        $to = WEBZEPHYR_PRINCIPAL;
648    } elsif($self->class eq WEBZEPHYR_CLASS
649            && $self->is_loginout) {
650        $class = WEBZEPHYR_CLASS;
651        $instance = $self->instance;
652        $to = WEBZEPHYR_PRINCIPAL;
653    } elsif($self->is_loginout) {
654        $class = 'MESSAGE';
655        $instance = 'PERSONAL';
656        $to = $self->sender;
657    } elsif($sender && !$self->is_private) {
658        # Possible future feature: (Optionally?) include the class and/or
659        # instance of the message being replied to in the instance of the
660        # outgoing personal reply
661        $class = 'MESSAGE';
662        $instance = 'PERSONAL';
663        $to = $self->sender;
664    } else {
665        $class = $self->class;
666        $instance = $self->instance;
667        $to = $self->recipient;
668        $cc = $self->zephyr_cc();
669        if($to eq '*' || $to eq '') {
670            $to = '';
671        } elsif($to !~ /^@/) {
672            $to = $self->sender;
673        }
674    }
675
676    my $cmd;
677    if(lc $self->opcode eq 'crypt') {
678        $cmd = 'zcrypt';
679    } else {
680        $cmd = 'zwrite';
681    }
682
683    if (lc $class ne 'message') {
684        $cmd .= " -c " . BarnOwl::quote($class);
685    }
686    if (lc $instance ne 'personal') {
687        $cmd .= " -i " . BarnOwl::quote($instance);
688    }
689    if ($to ne '') {
690        $to = strip_realm($to);
691        if (defined $cc) {
692            my @cc = grep /^[^-]/, ($to, split /\s+/, $cc);
693            my %cc = map {$_ => 1} @cc;
694            delete $cc{strip_realm(BarnOwl::zephyr_getsender())};
695            @cc = keys %cc;
696            $cmd .= " -C " . join(" ", @cc);
697        } else {
698            if(BarnOwl::getvar('smartstrip') eq 'on') {
699                $to = BarnOwl::zephyr_smartstrip_user($to);
700            }
701            $cmd .= " $to";
702        }
703    }
704    return $cmd;
705}
706
707sub replysendercmd {
708    my $self = shift;
709    return $self->replycmd(1);
710}
711
712#####################################################################
713#####################################################################
714#####################################################################
715
716package BarnOwl::Hook;
717
718=head1 BarnOwl::Hook
719
720=head1 DESCRIPTION
721
722A C<BarnOwl::Hook> represents a list of functions to be triggered on
723some event. C<BarnOwl> exports a default set of these (see
724C<BarnOwl::Hooks>), but can also be created and used by module code.
725
726=head2 new
727
728Creates a new Hook object
729
730=cut
731
732sub new {
733    my $class = shift;
734    return bless [], $class;
735}
736
737=head2 run [ARGS]
738
739Calls each of the functions registered with this hook with the given
740arguments.
741
742=cut
743
744sub run {
745    my $self = shift;
746    my @args = @_;
747    return map {$self->_run($_,@args)} @$self;
748}
749
750sub _run {
751    my $self = shift;
752    my $fn = shift;
753    my @args = @_;
754    no strict 'refs';
755    return $fn->(@args);
756}
757
758=head2 add SUBREF
759
760Registers a given subroutine with this hook
761
762=cut
763
764sub add {
765    my $self = shift;
766    my $func = shift;
767    die("Not a coderef!") unless ref($func) eq 'CODE' || !ref($func);
768    return if grep {$_ eq $func} @$self;
769    push @$self, $func;
770}
771
772=head2 clear
773
774Remove all functions registered with this hook.
775
776=cut
777
778sub clear {
779    my $self = shift;
780    @$self = ();
781}
782
783package BarnOwl::Hooks;
784
785=head1 BarnOwl::Hooks
786
787=head1 DESCRIPTION
788
789C<BarnOwl::Hooks> exports a set of C<BarnOwl::Hook> objects made
790available by BarnOwl internally.
791
792=head2 USAGE
793
794Modules wishing to respond to events in BarnOwl should register
795functions with these hooks.
796
797=head2 EXPORTS
798
799None by default. Either import the hooks you need explicitly, or refer
800to them with fully-qualified names. Available hooks are:
801
802=over 4
803
804=item $startup
805
806Called on BarnOwl startup, and whenever modules are
807reloaded. Functions registered with the C<$startup> hook get a true
808argument if this is a reload, and false if this is a true startup
809
810=item $shutdown
811
812Called before BarnOwl shutdown
813
814=item $receiveMessage
815
816Called with a C<BarnOwl::Message> object every time BarnOwl receives a
817new incoming message.
818
819=item $newMessage
820
821Called with a C<BarnOwl::Message> object every time BarnOwl appends
822I<any> new message to the message list.
823
824=item $mainLoop
825
826Called on every pass through the C<BarnOwl> main loop. This is
827guaranteed to be called at least once/sec and may be called more
828frequently.
829
830=item $getBuddyList
831
832Called to display buddy lists for all protocol handlers. The result
833from every function registered with this hook will be appended and
834displayed in a popup window, with zephyr formatting parsed.
835
836=item $getQuickstart
837
838Called by :show quickstart to display 2-5 lines of help on how to
839start using the protocol. The result from every function registered
840with this hook will be appended and displayed in an admin message,
841with zephyr formatting parsed. The format should be
842"@b(Protocol:)\nSome text.\nMore text.\n"
843
844=back
845
846=cut
847
848use Exporter;
849
850our @EXPORT_OK = qw($startup $shutdown
851                    $receiveMessage $newMessage
852                    $mainLoop $getBuddyList
853                    $getQuickstart);
854
855our %EXPORT_TAGS = (all => [@EXPORT_OK]);
856
857our $startup = BarnOwl::Hook->new;
858our $shutdown = BarnOwl::Hook->new;
859our $receiveMessage = BarnOwl::Hook->new;
860our $newMessage = BarnOwl::Hook->new;
861our $mainLoop = BarnOwl::Hook->new;
862our $getBuddyList = BarnOwl::Hook->new;
863our $getQuickstart = BarnOwl::Hook->new;
864
865# Internal startup/shutdown routines called by the C code
866
867sub _load_perl_commands {
868    # Load builtin perl commands
869    BarnOwl::new_command(style => \&BarnOwl::Style::style_command,
870                       {
871                           summary => "creates a new style",
872                           usage   => "style <name> perl <function_name>",
873                           description =>
874                           "A style named <name> will be created that will\n" .
875                           "format messages using the perl function <function_name>.\n\n" .
876                           "SEE ALSO: show styles, view -s, filter -s\n\n" .
877                           "DEPRECATED in favor of BarnOwl::create_style(NAME, OBJECT)",
878                          });
879}
880
881sub _load_owlconf {
882    # load the config  file
883    if ( -r $BarnOwl::configfile ) {
884        undef $@;
885        package main;
886        do $BarnOwl::configfile;
887        if($@) {
888            BarnOwl::error("In startup: $@\n");
889            return;
890        }
891        package BarnOwl;
892        if(*BarnOwl::format_msg{CODE}) {
893            # if the config defines a legacy formatting function, add 'perl' as a style
894            BarnOwl::create_style("perl", BarnOwl::Style::Legacy->new(
895                "BarnOwl::format_msg",
896                "User-defined perl style that calls BarnOwl::format_msg"
897                . " with legacy global variable support",
898                1));
899             BarnOwl::set("-q default_style perl");
900        }
901    }
902}
903
904# These are the internal hooks called by the barnowl C code, which
905# take care of dispatching to the appropriate perl hooks, and deal
906# with compatibility by calling the old, fixed-name hooks.
907
908sub _startup {
909    _load_perl_commands();
910    _load_owlconf();
911
912    if(eval {require BarnOwl::ModuleLoader}) {
913        eval {
914            BarnOwl::ModuleLoader->load_all;
915        };
916        BarnOwl::error("$@") if $@;
917
918    } else {
919        BarnOwl::error("Can't load BarnOwl::ModuleLoader, loadable module support disabled:\n$@");
920    }
921   
922    $startup->run(0);
923    BarnOwl::startup() if *BarnOwl::startup{CODE};
924}
925
926sub _shutdown {
927    $shutdown->run;
928   
929    BarnOwl::shutdown() if *BarnOwl::shutdown{CODE};
930}
931
932sub _receive_msg {
933    my $m = shift;
934
935    $receiveMessage->run($m);
936   
937    BarnOwl::receive_msg($m) if *BarnOwl::receive_msg{CODE};
938}
939
940sub _new_msg {
941    my $m = shift;
942
943    $newMessage->run($m);
944   
945    BarnOwl::new_msg($m) if *BarnOwl::new_msg{CODE};
946}
947
948sub _mainloop_hook {
949    $mainLoop->run;
950    BarnOwl::mainloop_hook() if *BarnOwl::mainloop_hook{CODE};
951}
952
953sub _get_blist {
954    return join("\n", $getBuddyList->run);
955}
956
957sub _get_quickstart {
958    return join("\n", $getQuickstart->run);
959}
960
961################################################################################
962# Built-in perl styles
963################################################################################
964package BarnOwl::Style::Default;
965################################################################################
966# Branching point for various formatting functions in this style.
967################################################################################
968sub format_message
969{
970    my $self = shift;
971    my $m    = shift;
972    my $fmt;
973
974    if ( $m->is_loginout) {
975        $fmt = $self->format_login($m);
976    } elsif($m->is_ping && $m->is_personal) {
977        $fmt = $self->format_ping($m);
978    } elsif($m->is_admin) {
979        $fmt = $self->format_admin($m);
980    } else {
981        $fmt = $self->format_chat($m);
982    }
983    $fmt = BarnOwl::Style::boldify($fmt) if $self->should_bold($m);
984    return $fmt;
985}
986
987sub should_bold {
988    my $self = shift;
989    my $m = shift;
990    return $m->is_personal && $m->direction eq "in";
991}
992
993sub description {"Default style";}
994
995BarnOwl::create_style("default", "BarnOwl::Style::Default");
996
997################################################################################
998
999sub format_time {
1000    my $self = shift;
1001    my $m = shift;
1002    my ($time) = $m->time =~ /(\d\d:\d\d)/;
1003    return $time;
1004}
1005
1006sub format_login {
1007    my $self = shift;
1008    my $m = shift;
1009    return sprintf(
1010        '@b<%s%s> for @b(%s) (%s) %s',
1011        uc( $m->login ),
1012        $m->login_type,
1013        $m->pretty_sender,
1014        $m->login_extra,
1015        $self->format_time($m)
1016       );
1017}
1018
1019sub format_ping {
1020    my $self = shift;
1021    my $m = shift;
1022    my $personal_context = $m->personal_context;
1023    $personal_context = ' [' . $personal_context . ']' if $personal_context;
1024    return "\@b(PING)" . $personal_context . " from \@b(" . $m->pretty_sender . ")";
1025}
1026
1027sub format_admin {
1028    my $self = shift;
1029    my $m = shift;
1030    return "\@bold(OWL ADMIN)\n" . $self->indent_body($m);
1031}
1032
1033sub format_chat {
1034    my $self = shift;
1035    my $m = shift;
1036    my $header = $self->chat_header($m);
1037    return $header . "\n". $self->indent_body($m);
1038}
1039
1040sub chat_header {
1041    my $self = shift;
1042    my $m = shift;
1043    my $header;
1044    if ( $m->is_personal ) {
1045        my $personal_context = $m->personal_context;
1046        $personal_context = ' [' . $personal_context . ']' if $personal_context;
1047
1048        if ( $m->direction eq "out" ) {
1049            $header = ucfirst $m->type . $personal_context . " sent to " . $m->pretty_recipient;
1050        } else {
1051            $header = ucfirst $m->type . $personal_context . " from " . $m->pretty_sender;
1052        }
1053    } else {
1054        $header = $m->context;
1055        if(defined $m->subcontext) {
1056            $header .= ' / ' . $m->subcontext;
1057        }
1058        $header .= ' / @b{' . $m->pretty_sender . '}';
1059    }
1060
1061    if($m->opcode) {
1062        $header .= " [" . $m->opcode . "]";
1063    }
1064    $header .= "  " . $self->format_time($m);
1065    $header .= $self->format_sender($m);
1066    return $header;
1067}
1068
1069sub format_sender {
1070    my $self = shift;
1071    my $m = shift;
1072    my $sender = $m->long_sender;
1073    $sender =~ s/\n.*$//s;
1074    if (BarnOwl::getvar('colorztext') eq 'on') {
1075      return "  (" . $sender . '@color[default]' . ")";
1076    } else {
1077      return "  ($sender)";
1078    }
1079}
1080
1081sub indent_body
1082{
1083    my $self = shift;
1084    my $m = shift;
1085
1086    my $body = $m->body;
1087    if ($m->{should_wordwrap}) {
1088      $body = BarnOwl::wordwrap($body, BarnOwl::getnumcols()-9);
1089    }
1090    # replace newline followed by anything with
1091    # newline plus four spaces and that thing.
1092    $body =~ s/\n(.)/\n    $1/g;
1093    # Trim trailing newlines.
1094    $body =~ s/\n*$//;
1095    return "    ".$body;
1096}
1097
1098package BarnOwl::Style::Basic;
1099our @ISA=qw(BarnOwl::Style::Default);
1100
1101sub description {"Compatability alias for the default style";}
1102
1103BarnOwl::create_style("basic", "BarnOwl::Style::Basic");
1104
1105package BarnOwl::Style::OneLine;
1106# Inherit format_message to dispatch
1107our @ISA = qw(BarnOwl::Style::Default);
1108
1109use constant BASE_FORMAT => '%s %-13.13s %-11.11s %-12.12s ';
1110
1111sub description {"Formats for one-line-per-message"}
1112
1113BarnOwl::create_style("oneline", "BarnOwl::Style::OneLine");
1114
1115################################################################################
1116
1117sub maybe {
1118    my $thing = shift;
1119    return defined($thing) ? $thing : "";
1120}
1121
1122sub format_login {
1123  my $self = shift;
1124  my $m = shift;
1125  return sprintf(
1126    BASE_FORMAT,
1127    '<',
1128    $m->type,
1129    uc( $m->login ),
1130    $m->pretty_sender)
1131    . ($m->login_extra ? "at ".$m->login_extra : '');
1132}
1133
1134sub format_ping {
1135  my $self = shift;
1136  my $m = shift;
1137  return sprintf(
1138    BASE_FORMAT,
1139    '<',
1140    $m->type,
1141    'PING',
1142    $m->pretty_sender)
1143}
1144
1145sub format_chat
1146{
1147  my $self = shift;
1148  my $m = shift;
1149  my $dir = lc($m->{direction});
1150  my $dirsym = '-';
1151  if ($dir eq 'in') {
1152    $dirsym = '<';
1153  }
1154  elsif ($dir eq 'out') {
1155    $dirsym = '>';
1156  }
1157
1158  my $line;
1159  if ($m->is_personal) {
1160    $line= sprintf(BASE_FORMAT,
1161                   $dirsym,
1162                   $m->type,
1163                   '',
1164                   ($dir eq 'out'
1165                    ? $m->pretty_recipient
1166                    : $m->pretty_sender));
1167  }
1168  else {
1169    $line = sprintf(BASE_FORMAT,
1170                    $dirsym,
1171                    maybe($m->context),
1172                    maybe($m->subcontext),
1173                    ($dir eq 'out'
1174                     ? $m->pretty_recipient
1175                     : $m->pretty_sender));
1176  }
1177
1178  my $body = $m->{body};
1179  $body =~ tr/\n/ /;
1180  $line .= $body;
1181  return $line;
1182}
1183
1184# Format owl admin messages
1185sub format_admin
1186{
1187  my $self = shift;
1188  my $m = shift;
1189  my $line = sprintf(BASE_FORMAT, '<', 'ADMIN', '', '');
1190  my $body = $m->{body};
1191  $body =~ tr/\n/ /;
1192  return $line.$body;
1193}
1194
1195package BarnOwl::Style;
1196
1197# This takes a zephyr to be displayed and modifies it to be displayed
1198# entirely in bold.
1199sub boldify
1200{
1201    local $_ = shift;
1202    if ( !(/\)/) ) {
1203        return '@b(' . $_ . ')';
1204    } elsif ( !(/\>/) ) {
1205        return '@b<' . $_ . '>';
1206    } elsif ( !(/\}/) ) {
1207        return '@b{' . $_ . '}';
1208    } elsif ( !(/\]/) ) {
1209        return '@b[' . $_ . ']';
1210    } else {
1211        my $txt = "\@b($_";
1212        $txt =~ s/\)/\)\@b\[\)\]\@b\(/g;
1213        return $txt . ')';
1214    }
1215}
1216
1217sub style_command {
1218    my $command = shift;
1219    if(scalar @_ != 3 || $_[1] ne 'perl') {
1220        die("Usage: style <name> perl <function>\n");
1221    }
1222    my $name = shift;
1223    my $perl = shift;
1224    my $fn   = shift;
1225    {
1226        # For historical reasons, assume unqualified references are
1227        # in main::
1228        package main;
1229        no strict 'refs';
1230        unless(*{$fn}{CODE}) {
1231            die("Unable to create style '$name': no perl function '$fn'\n");
1232        }
1233    }
1234    BarnOwl::create_style($name, BarnOwl::Style::Legacy->new($fn));
1235}
1236
1237package BarnOwl::Style::Legacy;
1238
1239sub new {
1240    my $class = shift;
1241    my $func  = shift;
1242    my $desc  = shift;
1243    my $useglobals = shift;
1244    $useglobals = 0 unless defined($useglobals);
1245    return bless {function    => $func,
1246                  description => $desc,
1247                  useglobals  => $useglobals}, $class;
1248}
1249
1250sub description {
1251    my $self = shift;
1252    return $self->{description} ||
1253    ("User-defined perl style that calls " . $self->{function});
1254};
1255
1256sub format_message {
1257    my $self = shift;
1258    if($self->{useglobals}) {
1259        $_[0]->legacy_populate_global();
1260    }
1261    {
1262      package main;
1263      no strict 'refs';
1264      goto \&{$self->{function}};
1265    }
1266}
1267
1268package BarnOwl::Timer;
1269
1270sub new {
1271    my $class = shift;
1272    my $args = shift;
1273
1274    my $cb = $args->{cb};
1275    die("Invalid callback pased to BarnOwl::Timer\n") unless ref($cb) eq 'CODE';
1276
1277    my $self = {cb => $cb};
1278
1279    bless($self, $class);
1280
1281    $self->{timer} = BarnOwl::Internal::add_timer($args->{after} || 0,
1282                                                  $args->{interval} || 0,
1283                                                  $self);
1284    return $self;
1285}
1286
1287sub do_callback {
1288    my $self = shift;
1289    $self->{cb}->($self);
1290}
1291
1292sub DESTROY {
1293    my $self = shift;
1294    if(defined($self->{timer})) {
1295        BarnOwl::Internal::remove_timer($self->{timer});
1296    }
1297}
1298
1299
1300# switch to package main when we're done
1301package main;
1302
1303# Shove a bunch of fake entries into @INC so modules can use or
1304# require them without choking
1305$::INC{$_} = 1 for (qw(BarnOwl.pm BarnOwl/Hooks.pm
1306                       BarnOwl/Message.pm BarnOwl/Style.pm));
1307
13081;
1309
Note: See TracBrowser for help on using the repository browser.