source: perlwrap.pm @ df7018f

release-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since df7018f was df7018f, checked in by Alex Dehnert <adehnert@mit.edu>, 15 years ago
Display personals better in OneLine mode. Adds short_personal_context, which enables protocol modules to specify how to fill the subcontext column for personal messages For personal zephyrs, now displays the class (for non-message) or instance (for -c message).
  • Property mode set to 100644
File size: 33.2 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# extra short version, for use where space is especially tight
396# (eg, the oneline style)
397sub short_personal_context { return ""; }
398
399sub delete {
400    my ($m) = @_;
401    &BarnOwl::command("delete --id ".$m->id);
402}
403
404sub undelete {
405    my ($m) = @_;
406    &BarnOwl::command("undelete --id ".$m->id);
407}
408
409# Serializes the message into something similar to the zwgc->vt format
410sub serialize {
411    my ($this) = @_;
412    my $s;
413    for my $f (keys %$this) {
414        my $val = $this->{$f};
415        if (ref($val) eq "ARRAY") {
416            for my $i (0..@$val-1) {
417                my $aval;
418                $aval = $val->[$i];
419                $aval =~ s/\n/\n$f.$i: /g;
420                $s .= "$f.$i: $aval\n";
421            }
422        } else {
423            $val =~ s/\n/\n$f: /g;
424            $s .= "$f: $val\n";
425        }
426    }
427    return $s;
428}
429
430# Populate the annoying legacy global variables
431sub legacy_populate_global {
432    my ($m) = @_;
433    $BarnOwl::direction  = $m->direction ;
434    $BarnOwl::type       = $m->type      ;
435    $BarnOwl::id         = $m->id        ;
436    $BarnOwl::class      = $m->class     ;
437    $BarnOwl::instance   = $m->instance  ;
438    $BarnOwl::recipient  = $m->recipient ;
439    $BarnOwl::sender     = $m->sender    ;
440    $BarnOwl::realm      = $m->realm     ;
441    $BarnOwl::opcode     = $m->opcode    ;
442    $BarnOwl::zsig       = $m->zsig      ;
443    $BarnOwl::msg        = $m->body      ;
444    $BarnOwl::time       = $m->time      ;
445    $BarnOwl::host       = $m->host      ;
446    $BarnOwl::login      = $m->login     ;
447    $BarnOwl::auth       = $m->auth      ;
448    if ($m->fields) {
449        @BarnOwl::fields = @{$m->fields};
450        @main::fields = @{$m->fields};
451    } else {
452        @BarnOwl::fields = undef;
453        @main::fields = undef;
454    }
455}
456
457sub smartfilter {
458    die("smartfilter not supported for this message\n");
459}
460
461# Display fields -- overridden by subclasses when needed
462sub login_type {""}
463sub login_extra {""}
464sub long_sender {""}
465
466# The context in which a non-personal message was sent, e.g. a chat or
467# class
468sub context {""}
469
470# Some indicator of context *within* $self->context. e.g. the zephyr
471# instance
472sub subcontext {""}
473
474#####################################################################
475#####################################################################
476
477package BarnOwl::Message::Admin;
478
479use base qw( BarnOwl::Message );
480
481sub header       { return shift->{"header"}; }
482
483#####################################################################
484#####################################################################
485
486package BarnOwl::Message::Generic;
487
488use base qw( BarnOwl::Message );
489
490#####################################################################
491#####################################################################
492
493package BarnOwl::Message::Loopback;
494
495use base qw( BarnOwl::Message );
496
497# all loopback messages are private
498sub is_private {
499  return 1;
500}
501
502sub replycmd {return 'loopwrite';}
503sub replysendercmd {return 'loopwrite';}
504
505#####################################################################
506#####################################################################
507
508package BarnOwl::Message::AIM;
509
510use base qw( BarnOwl::Message );
511
512# all non-loginout AIM messages are private for now...
513sub is_private {
514    return !(shift->is_loginout);
515}
516
517sub replycmd {
518    my $self = shift;
519    if ($self->is_incoming) {
520        return "aimwrite " . BarnOwl::quote($self->sender);
521    } else {
522        return "aimwrite " . BarnOwl::quote($self->recipient);
523    }
524}
525
526sub replysendercmd {
527    return shift->replycmd;
528}
529
530#####################################################################
531#####################################################################
532
533package BarnOwl::Message::Zephyr;
534
535use constant WEBZEPHYR_PRINCIPAL => "daemon.webzephyr";
536use constant WEBZEPHYR_CLASS     => "webzephyr";
537use constant WEBZEPHYR_OPCODE    => "webzephyr";
538
539use base qw( BarnOwl::Message );
540
541sub strip_realm {
542    my $sender = shift;
543    my $realm = BarnOwl::zephyr_getrealm();
544    $sender =~ s/\@$realm$//;
545    return $sender;
546}
547
548sub login_type {
549    return (shift->zsig eq "") ? "(PSEUDO)" : "";
550}
551
552sub login_extra {
553    my $m = shift;
554    return undef if (!$m->is_loginout);
555    my $s = lc($m->host);
556    $s .= " " . $m->login_tty if defined $m->login_tty;
557    return $s;
558}
559
560sub long_sender {
561    my $m = shift;
562    return $m->zsig;
563}
564
565sub context {
566    return shift->class;
567}
568
569sub subcontext {
570    return shift->instance;
571}
572
573sub login_tty {
574    my ($m) = @_;
575    return undef if (!$m->is_loginout);
576    return $m->fields->[2];
577}
578
579sub login_host {
580    my ($m) = @_;
581    return undef if (!$m->is_loginout);
582    return $m->fields->[0];
583}
584
585sub zwriteline  { return shift->{"zwriteline"}; }
586
587sub is_ping     { return (lc(shift->opcode) eq "ping"); }
588
589sub is_personal {
590    my ($m) = @_;
591    return ((lc($m->class) eq "message")
592            && $m->is_private);
593}
594
595sub is_mail {
596    my ($m) = @_;
597    return ((lc($m->class) eq "mail") && $m->is_private);
598}
599
600sub pretty_sender {
601    my ($m) = @_;
602    return strip_realm($m->sender);
603}
604
605sub pretty_recipient {
606    my ($m) = @_;
607    return strip_realm($m->recipient);
608}
609
610# Portion of the reply command that preserves the context
611sub context_reply_cmd {
612    my $m = shift;
613    my $class = "";
614    if (lc($m->class) ne "message") {
615        $class = "-c " . BarnOwl::quote($m->class);
616    }
617    my $instance = "";
618    if (lc($m->instance) ne "personal") {
619        $instance = "-i " . BarnOwl::quote($m->instance);
620    }
621    if (($class eq "") or  ($instance eq "")) {
622        return $class . $instance;
623    } else {
624        return $class . " " . $instance;
625    }
626}
627
628sub personal_context {
629    my ($m) = @_;
630    return $m->context_reply_cmd();
631}
632
633sub short_personal_context {
634    my ($m) = @_;
635    if(lc($m->class) eq 'message')
636    {
637        if(lc($m->instance) eq 'personal')
638        {
639            return '';
640        } else {
641            return $m->instance;
642        }
643    } else {
644        return $m->class;
645    }
646}
647
648# These are arguably zephyr-specific
649sub class       { return shift->{"class"}; }
650sub instance    { return shift->{"instance"}; }
651sub realm       { return shift->{"realm"}; }
652sub opcode      { return shift->{"opcode"}; }
653sub host        { return shift->{"hostname"}; }
654sub hostname    { return shift->{"hostname"}; }
655sub header      { return shift->{"header"}; }
656sub auth        { return shift->{"auth"}; }
657sub fields      { return shift->{"fields"}; }
658sub zsig        { return shift->{"zsig"}; }
659
660sub zephyr_cc {
661    my $self = shift;
662    return $1 if $self->body =~ /^\s*cc:\s+([^\n]+)/i;
663    return undef;
664}
665
666sub replycmd {
667    my $self = shift;
668    my $sender = shift;
669    $sender = 0 unless defined $sender;
670    my ($class, $instance, $to, $cc);
671    if($self->is_outgoing) {
672        return $self->{zwriteline};
673    }
674
675    if($sender && $self->opcode eq WEBZEPHYR_OPCODE) {
676        $class = WEBZEPHYR_CLASS;
677        $instance = $self->pretty_sender;
678        $instance =~ s/-webzephyr$//;
679        $to = WEBZEPHYR_PRINCIPAL;
680    } elsif($self->class eq WEBZEPHYR_CLASS
681            && $self->is_loginout) {
682        $class = WEBZEPHYR_CLASS;
683        $instance = $self->instance;
684        $to = WEBZEPHYR_PRINCIPAL;
685    } elsif($self->is_loginout) {
686        $class = 'MESSAGE';
687        $instance = 'PERSONAL';
688        $to = $self->sender;
689    } elsif($sender && !$self->is_private) {
690        # Possible future feature: (Optionally?) include the class and/or
691        # instance of the message being replied to in the instance of the
692        # outgoing personal reply
693        $class = 'MESSAGE';
694        $instance = 'PERSONAL';
695        $to = $self->sender;
696    } else {
697        $class = $self->class;
698        $instance = $self->instance;
699        $to = $self->recipient;
700        $cc = $self->zephyr_cc();
701        if($to eq '*' || $to eq '') {
702            $to = '';
703        } elsif($to !~ /^@/) {
704            $to = $self->sender;
705        }
706    }
707
708    my $cmd;
709    if(lc $self->opcode eq 'crypt') {
710        $cmd = 'zcrypt';
711    } else {
712        $cmd = 'zwrite';
713    }
714
715    my $context_part = $self->context_reply_cmd();
716    $cmd .= " " . $context_part unless ($context_part eq '');
717    if ($to ne '') {
718        $to = strip_realm($to);
719        if (defined $cc) {
720            my @cc = grep /^[^-]/, ($to, split /\s+/, $cc);
721            my %cc = map {$_ => 1} @cc;
722            delete $cc{strip_realm(BarnOwl::zephyr_getsender())};
723            @cc = keys %cc;
724            $cmd .= " -C " . join(" ", @cc);
725        } else {
726            if(BarnOwl::getvar('smartstrip') eq 'on') {
727                $to = BarnOwl::zephyr_smartstrip_user($to);
728            }
729            $cmd .= " $to";
730        }
731    }
732    return $cmd;
733}
734
735sub replysendercmd {
736    my $self = shift;
737    return $self->replycmd(1);
738}
739
740#####################################################################
741#####################################################################
742#####################################################################
743
744package BarnOwl::Hook;
745
746=head1 BarnOwl::Hook
747
748=head1 DESCRIPTION
749
750A C<BarnOwl::Hook> represents a list of functions to be triggered on
751some event. C<BarnOwl> exports a default set of these (see
752C<BarnOwl::Hooks>), but can also be created and used by module code.
753
754=head2 new
755
756Creates a new Hook object
757
758=cut
759
760sub new {
761    my $class = shift;
762    return bless [], $class;
763}
764
765=head2 run [ARGS]
766
767Calls each of the functions registered with this hook with the given
768arguments.
769
770=cut
771
772sub run {
773    my $self = shift;
774    my @args = @_;
775    return map {$self->_run($_,@args)} @$self;
776}
777
778sub _run {
779    my $self = shift;
780    my $fn = shift;
781    my @args = @_;
782    no strict 'refs';
783    return $fn->(@args);
784}
785
786=head2 add SUBREF
787
788Registers a given subroutine with this hook
789
790=cut
791
792sub add {
793    my $self = shift;
794    my $func = shift;
795    die("Not a coderef!") unless ref($func) eq 'CODE' || !ref($func);
796    return if grep {$_ eq $func} @$self;
797    push @$self, $func;
798}
799
800=head2 clear
801
802Remove all functions registered with this hook.
803
804=cut
805
806sub clear {
807    my $self = shift;
808    @$self = ();
809}
810
811package BarnOwl::Hooks;
812
813=head1 BarnOwl::Hooks
814
815=head1 DESCRIPTION
816
817C<BarnOwl::Hooks> exports a set of C<BarnOwl::Hook> objects made
818available by BarnOwl internally.
819
820=head2 USAGE
821
822Modules wishing to respond to events in BarnOwl should register
823functions with these hooks.
824
825=head2 EXPORTS
826
827None by default. Either import the hooks you need explicitly, or refer
828to them with fully-qualified names. Available hooks are:
829
830=over 4
831
832=item $startup
833
834Called on BarnOwl startup, and whenever modules are
835reloaded. Functions registered with the C<$startup> hook get a true
836argument if this is a reload, and false if this is a true startup
837
838=item $shutdown
839
840Called before BarnOwl shutdown
841
842=item $receiveMessage
843
844Called with a C<BarnOwl::Message> object every time BarnOwl receives a
845new incoming message.
846
847=item $newMessage
848
849Called with a C<BarnOwl::Message> object every time BarnOwl appends
850I<any> new message to the message list.
851
852=item $mainLoop
853
854Called on every pass through the C<BarnOwl> main loop. This is
855guaranteed to be called at least once/sec and may be called more
856frequently.
857
858=item $getBuddyList
859
860Called to display buddy lists for all protocol handlers. The result
861from every function registered with this hook will be appended and
862displayed in a popup window, with zephyr formatting parsed.
863
864=item $getQuickstart
865
866Called by :show quickstart to display 2-5 lines of help on how to
867start using the protocol. The result from every function registered
868with this hook will be appended and displayed in an admin message,
869with zephyr formatting parsed. The format should be
870"@b(Protocol:)\nSome text.\nMore text.\n"
871
872=back
873
874=cut
875
876use Exporter;
877
878our @EXPORT_OK = qw($startup $shutdown
879                    $receiveMessage $newMessage
880                    $mainLoop $getBuddyList
881                    $getQuickstart);
882
883our %EXPORT_TAGS = (all => [@EXPORT_OK]);
884
885our $startup = BarnOwl::Hook->new;
886our $shutdown = BarnOwl::Hook->new;
887our $receiveMessage = BarnOwl::Hook->new;
888our $newMessage = BarnOwl::Hook->new;
889our $mainLoop = BarnOwl::Hook->new;
890our $getBuddyList = BarnOwl::Hook->new;
891our $getQuickstart = BarnOwl::Hook->new;
892
893# Internal startup/shutdown routines called by the C code
894
895sub _load_perl_commands {
896    # Load builtin perl commands
897    BarnOwl::new_command(style => \&BarnOwl::Style::style_command,
898                       {
899                           summary => "creates a new style",
900                           usage   => "style <name> perl <function_name>",
901                           description =>
902                           "A style named <name> will be created that will\n" .
903                           "format messages using the perl function <function_name>.\n\n" .
904                           "SEE ALSO: show styles, view -s, filter -s\n\n" .
905                           "DEPRECATED in favor of BarnOwl::create_style(NAME, OBJECT)",
906                          });
907}
908
909sub _load_owlconf {
910    # load the config  file
911    if ( -r $BarnOwl::configfile ) {
912        undef $@;
913        package main;
914        do $BarnOwl::configfile;
915        if($@) {
916            BarnOwl::error("In startup: $@\n");
917            return;
918        }
919        package BarnOwl;
920        if(*BarnOwl::format_msg{CODE}) {
921            # if the config defines a legacy formatting function, add 'perl' as a style
922            BarnOwl::create_style("perl", BarnOwl::Style::Legacy->new(
923                "BarnOwl::format_msg",
924                "User-defined perl style that calls BarnOwl::format_msg"
925                . " with legacy global variable support",
926                1));
927             BarnOwl::set("-q default_style perl");
928        }
929    }
930}
931
932# These are the internal hooks called by the barnowl C code, which
933# take care of dispatching to the appropriate perl hooks, and deal
934# with compatibility by calling the old, fixed-name hooks.
935
936sub _startup {
937    _load_perl_commands();
938    _load_owlconf();
939
940    if(eval {require BarnOwl::ModuleLoader}) {
941        eval {
942            BarnOwl::ModuleLoader->load_all;
943        };
944        BarnOwl::error("$@") if $@;
945
946    } else {
947        BarnOwl::error("Can't load BarnOwl::ModuleLoader, loadable module support disabled:\n$@");
948    }
949   
950    $startup->run(0);
951    BarnOwl::startup() if *BarnOwl::startup{CODE};
952}
953
954sub _shutdown {
955    $shutdown->run;
956   
957    BarnOwl::shutdown() if *BarnOwl::shutdown{CODE};
958}
959
960sub _receive_msg {
961    my $m = shift;
962
963    $receiveMessage->run($m);
964   
965    BarnOwl::receive_msg($m) if *BarnOwl::receive_msg{CODE};
966}
967
968sub _new_msg {
969    my $m = shift;
970
971    $newMessage->run($m);
972   
973    BarnOwl::new_msg($m) if *BarnOwl::new_msg{CODE};
974}
975
976sub _mainloop_hook {
977    $mainLoop->run;
978    BarnOwl::mainloop_hook() if *BarnOwl::mainloop_hook{CODE};
979}
980
981sub _get_blist {
982    return join("\n", $getBuddyList->run);
983}
984
985sub _get_quickstart {
986    return join("\n", $getQuickstart->run);
987}
988
989################################################################################
990# Built-in perl styles
991################################################################################
992package BarnOwl::Style::Default;
993################################################################################
994# Branching point for various formatting functions in this style.
995################################################################################
996sub format_message
997{
998    my $self = shift;
999    my $m    = shift;
1000    my $fmt;
1001
1002    if ( $m->is_loginout) {
1003        $fmt = $self->format_login($m);
1004    } elsif($m->is_ping && $m->is_personal) {
1005        $fmt = $self->format_ping($m);
1006    } elsif($m->is_admin) {
1007        $fmt = $self->format_admin($m);
1008    } else {
1009        $fmt = $self->format_chat($m);
1010    }
1011    $fmt = BarnOwl::Style::boldify($fmt) if $self->should_bold($m);
1012    return $fmt;
1013}
1014
1015sub should_bold {
1016    my $self = shift;
1017    my $m = shift;
1018    return $m->is_personal && $m->direction eq "in";
1019}
1020
1021sub description {"Default style";}
1022
1023BarnOwl::create_style("default", "BarnOwl::Style::Default");
1024
1025################################################################################
1026
1027sub format_time {
1028    my $self = shift;
1029    my $m = shift;
1030    my ($time) = $m->time =~ /(\d\d:\d\d)/;
1031    return $time;
1032}
1033
1034sub format_login {
1035    my $self = shift;
1036    my $m = shift;
1037    return sprintf(
1038        '@b<%s%s> for @b(%s) (%s) %s',
1039        uc( $m->login ),
1040        $m->login_type,
1041        $m->pretty_sender,
1042        $m->login_extra,
1043        $self->format_time($m)
1044       );
1045}
1046
1047sub format_ping {
1048    my $self = shift;
1049    my $m = shift;
1050    my $personal_context = $m->personal_context;
1051    $personal_context = ' [' . $personal_context . ']' if $personal_context;
1052    return "\@b(PING)" . $personal_context . " from \@b(" . $m->pretty_sender . ")";
1053}
1054
1055sub format_admin {
1056    my $self = shift;
1057    my $m = shift;
1058    return "\@bold(OWL ADMIN)\n" . $self->indent_body($m);
1059}
1060
1061sub format_chat {
1062    my $self = shift;
1063    my $m = shift;
1064    my $header = $self->chat_header($m);
1065    return $header . "\n". $self->indent_body($m);
1066}
1067
1068sub chat_header {
1069    my $self = shift;
1070    my $m = shift;
1071    my $header;
1072    if ( $m->is_personal ) {
1073        my $personal_context = $m->personal_context;
1074        $personal_context = ' [' . $personal_context . ']' if $personal_context;
1075
1076        if ( $m->direction eq "out" ) {
1077            $header = ucfirst $m->type . $personal_context . " sent to " . $m->pretty_recipient;
1078        } else {
1079            $header = ucfirst $m->type . $personal_context . " from " . $m->pretty_sender;
1080        }
1081    } else {
1082        $header = $m->context;
1083        if(defined $m->subcontext) {
1084            $header .= ' / ' . $m->subcontext;
1085        }
1086        $header .= ' / @b{' . $m->pretty_sender . '}';
1087    }
1088
1089    if($m->opcode) {
1090        $header .= " [" . $m->opcode . "]";
1091    }
1092    $header .= "  " . $self->format_time($m);
1093    $header .= $self->format_sender($m);
1094    return $header;
1095}
1096
1097sub format_sender {
1098    my $self = shift;
1099    my $m = shift;
1100    my $sender = $m->long_sender;
1101    $sender =~ s/\n.*$//s;
1102    if (BarnOwl::getvar('colorztext') eq 'on') {
1103      return "  (" . $sender . '@color[default]' . ")";
1104    } else {
1105      return "  ($sender)";
1106    }
1107}
1108
1109sub indent_body
1110{
1111    my $self = shift;
1112    my $m = shift;
1113
1114    my $body = $m->body;
1115    if ($m->{should_wordwrap}) {
1116      $body = BarnOwl::wordwrap($body, BarnOwl::getnumcols()-9);
1117    }
1118    # replace newline followed by anything with
1119    # newline plus four spaces and that thing.
1120    $body =~ s/\n(.)/\n    $1/g;
1121    # Trim trailing newlines.
1122    $body =~ s/\n*$//;
1123    return "    ".$body;
1124}
1125
1126package BarnOwl::Style::Basic;
1127our @ISA=qw(BarnOwl::Style::Default);
1128
1129sub description {"Compatability alias for the default style";}
1130
1131BarnOwl::create_style("basic", "BarnOwl::Style::Basic");
1132
1133package BarnOwl::Style::OneLine;
1134# Inherit format_message to dispatch
1135our @ISA = qw(BarnOwl::Style::Default);
1136
1137use constant BASE_FORMAT => '%s %-13.13s %-11.11s %-12.12s ';
1138
1139sub description {"Formats for one-line-per-message"}
1140
1141BarnOwl::create_style("oneline", "BarnOwl::Style::OneLine");
1142
1143################################################################################
1144
1145sub maybe {
1146    my $thing = shift;
1147    return defined($thing) ? $thing : "";
1148}
1149
1150sub format_login {
1151  my $self = shift;
1152  my $m = shift;
1153  return sprintf(
1154    BASE_FORMAT,
1155    '<',
1156    $m->type,
1157    uc( $m->login ),
1158    $m->pretty_sender)
1159    . ($m->login_extra ? "at ".$m->login_extra : '');
1160}
1161
1162sub format_ping {
1163  my $self = shift;
1164  my $m = shift;
1165  return sprintf(
1166    BASE_FORMAT,
1167    '<',
1168    $m->type,
1169    'PING',
1170    $m->pretty_sender)
1171}
1172
1173sub format_chat
1174{
1175  my $self = shift;
1176  my $m = shift;
1177  my $dir = lc($m->{direction});
1178  my $dirsym = '-';
1179  if ($dir eq 'in') {
1180    $dirsym = '<';
1181  }
1182  elsif ($dir eq 'out') {
1183    $dirsym = '>';
1184  }
1185
1186  my $line;
1187  if ($m->is_personal) {
1188
1189    # Figure out what to show in the subcontext column
1190    $line= sprintf(BASE_FORMAT,
1191                   $dirsym,
1192                   $m->type,
1193                   maybe($m->short_personal_context),
1194                   ($dir eq 'out'
1195                    ? $m->pretty_recipient
1196                    : $m->pretty_sender));
1197  }
1198  else {
1199    $line = sprintf(BASE_FORMAT,
1200                    $dirsym,
1201                    maybe($m->context),
1202                    maybe($m->subcontext),
1203                    ($dir eq 'out'
1204                     ? $m->pretty_recipient
1205                     : $m->pretty_sender));
1206  }
1207
1208  my $body = $m->{body};
1209  $body =~ tr/\n/ /;
1210  $line .= $body;
1211  return $line;
1212}
1213
1214# Format owl admin messages
1215sub format_admin
1216{
1217  my $self = shift;
1218  my $m = shift;
1219  my $line = sprintf(BASE_FORMAT, '<', 'ADMIN', '', '');
1220  my $body = $m->{body};
1221  $body =~ tr/\n/ /;
1222  return $line.$body;
1223}
1224
1225package BarnOwl::Style;
1226
1227# This takes a zephyr to be displayed and modifies it to be displayed
1228# entirely in bold.
1229sub boldify
1230{
1231    local $_ = shift;
1232    if ( !(/\)/) ) {
1233        return '@b(' . $_ . ')';
1234    } elsif ( !(/\>/) ) {
1235        return '@b<' . $_ . '>';
1236    } elsif ( !(/\}/) ) {
1237        return '@b{' . $_ . '}';
1238    } elsif ( !(/\]/) ) {
1239        return '@b[' . $_ . ']';
1240    } else {
1241        my $txt = "\@b($_";
1242        $txt =~ s/\)/\)\@b\[\)\]\@b\(/g;
1243        return $txt . ')';
1244    }
1245}
1246
1247sub style_command {
1248    my $command = shift;
1249    if(scalar @_ != 3 || $_[1] ne 'perl') {
1250        die("Usage: style <name> perl <function>\n");
1251    }
1252    my $name = shift;
1253    my $perl = shift;
1254    my $fn   = shift;
1255    {
1256        # For historical reasons, assume unqualified references are
1257        # in main::
1258        package main;
1259        no strict 'refs';
1260        unless(*{$fn}{CODE}) {
1261            die("Unable to create style '$name': no perl function '$fn'\n");
1262        }
1263    }
1264    BarnOwl::create_style($name, BarnOwl::Style::Legacy->new($fn));
1265}
1266
1267package BarnOwl::Style::Legacy;
1268
1269sub new {
1270    my $class = shift;
1271    my $func  = shift;
1272    my $desc  = shift;
1273    my $useglobals = shift;
1274    $useglobals = 0 unless defined($useglobals);
1275    return bless {function    => $func,
1276                  description => $desc,
1277                  useglobals  => $useglobals}, $class;
1278}
1279
1280sub description {
1281    my $self = shift;
1282    return $self->{description} ||
1283    ("User-defined perl style that calls " . $self->{function});
1284};
1285
1286sub format_message {
1287    my $self = shift;
1288    if($self->{useglobals}) {
1289        $_[0]->legacy_populate_global();
1290    }
1291    {
1292      package main;
1293      no strict 'refs';
1294      goto \&{$self->{function}};
1295    }
1296}
1297
1298package BarnOwl::Timer;
1299
1300sub new {
1301    my $class = shift;
1302    my $args = shift;
1303
1304    my $cb = $args->{cb};
1305    die("Invalid callback pased to BarnOwl::Timer\n") unless ref($cb) eq 'CODE';
1306
1307    my $self = {cb => $cb};
1308
1309    bless($self, $class);
1310
1311    $self->{timer} = BarnOwl::Internal::add_timer($args->{after} || 0,
1312                                                  $args->{interval} || 0,
1313                                                  $self);
1314    return $self;
1315}
1316
1317sub do_callback {
1318    my $self = shift;
1319    $self->{cb}->($self);
1320}
1321
1322sub DESTROY {
1323    my $self = shift;
1324    if(defined($self->{timer})) {
1325        BarnOwl::Internal::remove_timer($self->{timer});
1326    }
1327}
1328
1329
1330# switch to package main when we're done
1331package main;
1332
1333# Shove a bunch of fake entries into @INC so modules can use or
1334# require them without choking
1335$::INC{$_} = 1 for (qw(BarnOwl.pm BarnOwl/Hooks.pm
1336                       BarnOwl/Message.pm BarnOwl/Style.pm));
1337
13381;
1339
Note: See TracBrowser for help on using the repository browser.