source: perlwrap.pm @ 6223638

release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 6223638 was 6223638, checked in by Alex Dehnert <adehnert@mit.edu>, 14 years ago
Include non-default class in personal_context I think this turns out to be a no-op, because only the default class is ever set. Regardless, this feels like the right thing to do. Also, slightly refactors to make getting a -c class -i instance string without default class or instance easier. Further, quotes instance in personal context, which seems reasonable since the syntax seems intended to be that of zwrite.
  • Property mode set to 100644
File size: 32.7 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
607# Portion of the reply command that preserves the context
608sub context_reply_cmd {
609    my $m = shift;
610    my $class = "";
611    if (lc($m->class) ne "message") {
612        $class = "-c " . BarnOwl::quote($m->class);
613    }
614    my $instance = "";
615    if (lc($m->instance) ne "personal") {
616        $instance = "-i " . BarnOwl::quote($m->instance);
617    }
618    if (($class eq "") or  ($instance eq "")) {
619        return $class . $instance;
620    } else {
621        return $class . " " . $instance;
622    }
623}
624
625sub personal_context {
626    my ($m) = @_;
627    return $m->context_reply_cmd();
628}
629
630# These are arguably zephyr-specific
631sub class       { return shift->{"class"}; }
632sub instance    { return shift->{"instance"}; }
633sub realm       { return shift->{"realm"}; }
634sub opcode      { return shift->{"opcode"}; }
635sub host        { return shift->{"hostname"}; }
636sub hostname    { return shift->{"hostname"}; }
637sub header      { return shift->{"header"}; }
638sub auth        { return shift->{"auth"}; }
639sub fields      { return shift->{"fields"}; }
640sub zsig        { return shift->{"zsig"}; }
641
642sub zephyr_cc {
643    my $self = shift;
644    return $1 if $self->body =~ /^\s*cc:\s+([^\n]+)/i;
645    return undef;
646}
647
648sub replycmd {
649    my $self = shift;
650    my $sender = shift;
651    $sender = 0 unless defined $sender;
652    my ($class, $instance, $to, $cc);
653    if($self->is_outgoing) {
654        return $self->{zwriteline};
655    }
656
657    if($sender && $self->opcode eq WEBZEPHYR_OPCODE) {
658        $class = WEBZEPHYR_CLASS;
659        $instance = $self->pretty_sender;
660        $instance =~ s/-webzephyr$//;
661        $to = WEBZEPHYR_PRINCIPAL;
662    } elsif($self->class eq WEBZEPHYR_CLASS
663            && $self->is_loginout) {
664        $class = WEBZEPHYR_CLASS;
665        $instance = $self->instance;
666        $to = WEBZEPHYR_PRINCIPAL;
667    } elsif($self->is_loginout) {
668        $class = 'MESSAGE';
669        $instance = 'PERSONAL';
670        $to = $self->sender;
671    } elsif($sender && !$self->is_private) {
672        # Possible future feature: (Optionally?) include the class and/or
673        # instance of the message being replied to in the instance of the
674        # outgoing personal reply
675        $class = 'MESSAGE';
676        $instance = 'PERSONAL';
677        $to = $self->sender;
678    } else {
679        $class = $self->class;
680        $instance = $self->instance;
681        $to = $self->recipient;
682        $cc = $self->zephyr_cc();
683        if($to eq '*' || $to eq '') {
684            $to = '';
685        } elsif($to !~ /^@/) {
686            $to = $self->sender;
687        }
688    }
689
690    my $cmd;
691    if(lc $self->opcode eq 'crypt') {
692        $cmd = 'zcrypt';
693    } else {
694        $cmd = 'zwrite';
695    }
696
697    my $context_part = $self->context_reply_cmd();
698    $cmd .= " " . $context_part unless ($context_part eq '');
699    if ($to ne '') {
700        $to = strip_realm($to);
701        if (defined $cc) {
702            my @cc = grep /^[^-]/, ($to, split /\s+/, $cc);
703            my %cc = map {$_ => 1} @cc;
704            delete $cc{strip_realm(BarnOwl::zephyr_getsender())};
705            @cc = keys %cc;
706            $cmd .= " -C " . join(" ", @cc);
707        } else {
708            if(BarnOwl::getvar('smartstrip') eq 'on') {
709                $to = BarnOwl::zephyr_smartstrip_user($to);
710            }
711            $cmd .= " $to";
712        }
713    }
714    return $cmd;
715}
716
717sub replysendercmd {
718    my $self = shift;
719    return $self->replycmd(1);
720}
721
722#####################################################################
723#####################################################################
724#####################################################################
725
726package BarnOwl::Hook;
727
728=head1 BarnOwl::Hook
729
730=head1 DESCRIPTION
731
732A C<BarnOwl::Hook> represents a list of functions to be triggered on
733some event. C<BarnOwl> exports a default set of these (see
734C<BarnOwl::Hooks>), but can also be created and used by module code.
735
736=head2 new
737
738Creates a new Hook object
739
740=cut
741
742sub new {
743    my $class = shift;
744    return bless [], $class;
745}
746
747=head2 run [ARGS]
748
749Calls each of the functions registered with this hook with the given
750arguments.
751
752=cut
753
754sub run {
755    my $self = shift;
756    my @args = @_;
757    return map {$self->_run($_,@args)} @$self;
758}
759
760sub _run {
761    my $self = shift;
762    my $fn = shift;
763    my @args = @_;
764    no strict 'refs';
765    return $fn->(@args);
766}
767
768=head2 add SUBREF
769
770Registers a given subroutine with this hook
771
772=cut
773
774sub add {
775    my $self = shift;
776    my $func = shift;
777    die("Not a coderef!") unless ref($func) eq 'CODE' || !ref($func);
778    return if grep {$_ eq $func} @$self;
779    push @$self, $func;
780}
781
782=head2 clear
783
784Remove all functions registered with this hook.
785
786=cut
787
788sub clear {
789    my $self = shift;
790    @$self = ();
791}
792
793package BarnOwl::Hooks;
794
795=head1 BarnOwl::Hooks
796
797=head1 DESCRIPTION
798
799C<BarnOwl::Hooks> exports a set of C<BarnOwl::Hook> objects made
800available by BarnOwl internally.
801
802=head2 USAGE
803
804Modules wishing to respond to events in BarnOwl should register
805functions with these hooks.
806
807=head2 EXPORTS
808
809None by default. Either import the hooks you need explicitly, or refer
810to them with fully-qualified names. Available hooks are:
811
812=over 4
813
814=item $startup
815
816Called on BarnOwl startup, and whenever modules are
817reloaded. Functions registered with the C<$startup> hook get a true
818argument if this is a reload, and false if this is a true startup
819
820=item $shutdown
821
822Called before BarnOwl shutdown
823
824=item $receiveMessage
825
826Called with a C<BarnOwl::Message> object every time BarnOwl receives a
827new incoming message.
828
829=item $newMessage
830
831Called with a C<BarnOwl::Message> object every time BarnOwl appends
832I<any> new message to the message list.
833
834=item $mainLoop
835
836Called on every pass through the C<BarnOwl> main loop. This is
837guaranteed to be called at least once/sec and may be called more
838frequently.
839
840=item $getBuddyList
841
842Called to display buddy lists for all protocol handlers. The result
843from every function registered with this hook will be appended and
844displayed in a popup window, with zephyr formatting parsed.
845
846=item $getQuickstart
847
848Called by :show quickstart to display 2-5 lines of help on how to
849start using the protocol. The result from every function registered
850with this hook will be appended and displayed in an admin message,
851with zephyr formatting parsed. The format should be
852"@b(Protocol:)\nSome text.\nMore text.\n"
853
854=back
855
856=cut
857
858use Exporter;
859
860our @EXPORT_OK = qw($startup $shutdown
861                    $receiveMessage $newMessage
862                    $mainLoop $getBuddyList
863                    $getQuickstart);
864
865our %EXPORT_TAGS = (all => [@EXPORT_OK]);
866
867our $startup = BarnOwl::Hook->new;
868our $shutdown = BarnOwl::Hook->new;
869our $receiveMessage = BarnOwl::Hook->new;
870our $newMessage = BarnOwl::Hook->new;
871our $mainLoop = BarnOwl::Hook->new;
872our $getBuddyList = BarnOwl::Hook->new;
873our $getQuickstart = BarnOwl::Hook->new;
874
875# Internal startup/shutdown routines called by the C code
876
877sub _load_perl_commands {
878    # Load builtin perl commands
879    BarnOwl::new_command(style => \&BarnOwl::Style::style_command,
880                       {
881                           summary => "creates a new style",
882                           usage   => "style <name> perl <function_name>",
883                           description =>
884                           "A style named <name> will be created that will\n" .
885                           "format messages using the perl function <function_name>.\n\n" .
886                           "SEE ALSO: show styles, view -s, filter -s\n\n" .
887                           "DEPRECATED in favor of BarnOwl::create_style(NAME, OBJECT)",
888                          });
889}
890
891sub _load_owlconf {
892    # load the config  file
893    if ( -r $BarnOwl::configfile ) {
894        undef $@;
895        package main;
896        do $BarnOwl::configfile;
897        if($@) {
898            BarnOwl::error("In startup: $@\n");
899            return;
900        }
901        package BarnOwl;
902        if(*BarnOwl::format_msg{CODE}) {
903            # if the config defines a legacy formatting function, add 'perl' as a style
904            BarnOwl::create_style("perl", BarnOwl::Style::Legacy->new(
905                "BarnOwl::format_msg",
906                "User-defined perl style that calls BarnOwl::format_msg"
907                . " with legacy global variable support",
908                1));
909             BarnOwl::set("-q default_style perl");
910        }
911    }
912}
913
914# These are the internal hooks called by the barnowl C code, which
915# take care of dispatching to the appropriate perl hooks, and deal
916# with compatibility by calling the old, fixed-name hooks.
917
918sub _startup {
919    _load_perl_commands();
920    _load_owlconf();
921
922    if(eval {require BarnOwl::ModuleLoader}) {
923        eval {
924            BarnOwl::ModuleLoader->load_all;
925        };
926        BarnOwl::error("$@") if $@;
927
928    } else {
929        BarnOwl::error("Can't load BarnOwl::ModuleLoader, loadable module support disabled:\n$@");
930    }
931   
932    $startup->run(0);
933    BarnOwl::startup() if *BarnOwl::startup{CODE};
934}
935
936sub _shutdown {
937    $shutdown->run;
938   
939    BarnOwl::shutdown() if *BarnOwl::shutdown{CODE};
940}
941
942sub _receive_msg {
943    my $m = shift;
944
945    $receiveMessage->run($m);
946   
947    BarnOwl::receive_msg($m) if *BarnOwl::receive_msg{CODE};
948}
949
950sub _new_msg {
951    my $m = shift;
952
953    $newMessage->run($m);
954   
955    BarnOwl::new_msg($m) if *BarnOwl::new_msg{CODE};
956}
957
958sub _mainloop_hook {
959    $mainLoop->run;
960    BarnOwl::mainloop_hook() if *BarnOwl::mainloop_hook{CODE};
961}
962
963sub _get_blist {
964    return join("\n", $getBuddyList->run);
965}
966
967sub _get_quickstart {
968    return join("\n", $getQuickstart->run);
969}
970
971################################################################################
972# Built-in perl styles
973################################################################################
974package BarnOwl::Style::Default;
975################################################################################
976# Branching point for various formatting functions in this style.
977################################################################################
978sub format_message
979{
980    my $self = shift;
981    my $m    = shift;
982    my $fmt;
983
984    if ( $m->is_loginout) {
985        $fmt = $self->format_login($m);
986    } elsif($m->is_ping && $m->is_personal) {
987        $fmt = $self->format_ping($m);
988    } elsif($m->is_admin) {
989        $fmt = $self->format_admin($m);
990    } else {
991        $fmt = $self->format_chat($m);
992    }
993    $fmt = BarnOwl::Style::boldify($fmt) if $self->should_bold($m);
994    return $fmt;
995}
996
997sub should_bold {
998    my $self = shift;
999    my $m = shift;
1000    return $m->is_personal && $m->direction eq "in";
1001}
1002
1003sub description {"Default style";}
1004
1005BarnOwl::create_style("default", "BarnOwl::Style::Default");
1006
1007################################################################################
1008
1009sub format_time {
1010    my $self = shift;
1011    my $m = shift;
1012    my ($time) = $m->time =~ /(\d\d:\d\d)/;
1013    return $time;
1014}
1015
1016sub format_login {
1017    my $self = shift;
1018    my $m = shift;
1019    return sprintf(
1020        '@b<%s%s> for @b(%s) (%s) %s',
1021        uc( $m->login ),
1022        $m->login_type,
1023        $m->pretty_sender,
1024        $m->login_extra,
1025        $self->format_time($m)
1026       );
1027}
1028
1029sub format_ping {
1030    my $self = shift;
1031    my $m = shift;
1032    my $personal_context = $m->personal_context;
1033    $personal_context = ' [' . $personal_context . ']' if $personal_context;
1034    return "\@b(PING)" . $personal_context . " from \@b(" . $m->pretty_sender . ")";
1035}
1036
1037sub format_admin {
1038    my $self = shift;
1039    my $m = shift;
1040    return "\@bold(OWL ADMIN)\n" . $self->indent_body($m);
1041}
1042
1043sub format_chat {
1044    my $self = shift;
1045    my $m = shift;
1046    my $header = $self->chat_header($m);
1047    return $header . "\n". $self->indent_body($m);
1048}
1049
1050sub chat_header {
1051    my $self = shift;
1052    my $m = shift;
1053    my $header;
1054    if ( $m->is_personal ) {
1055        my $personal_context = $m->personal_context;
1056        $personal_context = ' [' . $personal_context . ']' if $personal_context;
1057
1058        if ( $m->direction eq "out" ) {
1059            $header = ucfirst $m->type . $personal_context . " sent to " . $m->pretty_recipient;
1060        } else {
1061            $header = ucfirst $m->type . $personal_context . " from " . $m->pretty_sender;
1062        }
1063    } else {
1064        $header = $m->context;
1065        if(defined $m->subcontext) {
1066            $header .= ' / ' . $m->subcontext;
1067        }
1068        $header .= ' / @b{' . $m->pretty_sender . '}';
1069    }
1070
1071    if($m->opcode) {
1072        $header .= " [" . $m->opcode . "]";
1073    }
1074    $header .= "  " . $self->format_time($m);
1075    $header .= $self->format_sender($m);
1076    return $header;
1077}
1078
1079sub format_sender {
1080    my $self = shift;
1081    my $m = shift;
1082    my $sender = $m->long_sender;
1083    $sender =~ s/\n.*$//s;
1084    if (BarnOwl::getvar('colorztext') eq 'on') {
1085      return "  (" . $sender . '@color[default]' . ")";
1086    } else {
1087      return "  ($sender)";
1088    }
1089}
1090
1091sub indent_body
1092{
1093    my $self = shift;
1094    my $m = shift;
1095
1096    my $body = $m->body;
1097    if ($m->{should_wordwrap}) {
1098      $body = BarnOwl::wordwrap($body, BarnOwl::getnumcols()-9);
1099    }
1100    # replace newline followed by anything with
1101    # newline plus four spaces and that thing.
1102    $body =~ s/\n(.)/\n    $1/g;
1103    # Trim trailing newlines.
1104    $body =~ s/\n*$//;
1105    return "    ".$body;
1106}
1107
1108package BarnOwl::Style::Basic;
1109our @ISA=qw(BarnOwl::Style::Default);
1110
1111sub description {"Compatability alias for the default style";}
1112
1113BarnOwl::create_style("basic", "BarnOwl::Style::Basic");
1114
1115package BarnOwl::Style::OneLine;
1116# Inherit format_message to dispatch
1117our @ISA = qw(BarnOwl::Style::Default);
1118
1119use constant BASE_FORMAT => '%s %-13.13s %-11.11s %-12.12s ';
1120
1121sub description {"Formats for one-line-per-message"}
1122
1123BarnOwl::create_style("oneline", "BarnOwl::Style::OneLine");
1124
1125################################################################################
1126
1127sub maybe {
1128    my $thing = shift;
1129    return defined($thing) ? $thing : "";
1130}
1131
1132sub format_login {
1133  my $self = shift;
1134  my $m = shift;
1135  return sprintf(
1136    BASE_FORMAT,
1137    '<',
1138    $m->type,
1139    uc( $m->login ),
1140    $m->pretty_sender)
1141    . ($m->login_extra ? "at ".$m->login_extra : '');
1142}
1143
1144sub format_ping {
1145  my $self = shift;
1146  my $m = shift;
1147  return sprintf(
1148    BASE_FORMAT,
1149    '<',
1150    $m->type,
1151    'PING',
1152    $m->pretty_sender)
1153}
1154
1155sub format_chat
1156{
1157  my $self = shift;
1158  my $m = shift;
1159  my $dir = lc($m->{direction});
1160  my $dirsym = '-';
1161  if ($dir eq 'in') {
1162    $dirsym = '<';
1163  }
1164  elsif ($dir eq 'out') {
1165    $dirsym = '>';
1166  }
1167
1168  my $line;
1169  if ($m->is_personal) {
1170    $line= sprintf(BASE_FORMAT,
1171                   $dirsym,
1172                   $m->type,
1173                   '',
1174                   ($dir eq 'out'
1175                    ? $m->pretty_recipient
1176                    : $m->pretty_sender));
1177  }
1178  else {
1179    $line = sprintf(BASE_FORMAT,
1180                    $dirsym,
1181                    maybe($m->context),
1182                    maybe($m->subcontext),
1183                    ($dir eq 'out'
1184                     ? $m->pretty_recipient
1185                     : $m->pretty_sender));
1186  }
1187
1188  my $body = $m->{body};
1189  $body =~ tr/\n/ /;
1190  $line .= $body;
1191  return $line;
1192}
1193
1194# Format owl admin messages
1195sub format_admin
1196{
1197  my $self = shift;
1198  my $m = shift;
1199  my $line = sprintf(BASE_FORMAT, '<', 'ADMIN', '', '');
1200  my $body = $m->{body};
1201  $body =~ tr/\n/ /;
1202  return $line.$body;
1203}
1204
1205package BarnOwl::Style;
1206
1207# This takes a zephyr to be displayed and modifies it to be displayed
1208# entirely in bold.
1209sub boldify
1210{
1211    local $_ = shift;
1212    if ( !(/\)/) ) {
1213        return '@b(' . $_ . ')';
1214    } elsif ( !(/\>/) ) {
1215        return '@b<' . $_ . '>';
1216    } elsif ( !(/\}/) ) {
1217        return '@b{' . $_ . '}';
1218    } elsif ( !(/\]/) ) {
1219        return '@b[' . $_ . ']';
1220    } else {
1221        my $txt = "\@b($_";
1222        $txt =~ s/\)/\)\@b\[\)\]\@b\(/g;
1223        return $txt . ')';
1224    }
1225}
1226
1227sub style_command {
1228    my $command = shift;
1229    if(scalar @_ != 3 || $_[1] ne 'perl') {
1230        die("Usage: style <name> perl <function>\n");
1231    }
1232    my $name = shift;
1233    my $perl = shift;
1234    my $fn   = shift;
1235    {
1236        # For historical reasons, assume unqualified references are
1237        # in main::
1238        package main;
1239        no strict 'refs';
1240        unless(*{$fn}{CODE}) {
1241            die("Unable to create style '$name': no perl function '$fn'\n");
1242        }
1243    }
1244    BarnOwl::create_style($name, BarnOwl::Style::Legacy->new($fn));
1245}
1246
1247package BarnOwl::Style::Legacy;
1248
1249sub new {
1250    my $class = shift;
1251    my $func  = shift;
1252    my $desc  = shift;
1253    my $useglobals = shift;
1254    $useglobals = 0 unless defined($useglobals);
1255    return bless {function    => $func,
1256                  description => $desc,
1257                  useglobals  => $useglobals}, $class;
1258}
1259
1260sub description {
1261    my $self = shift;
1262    return $self->{description} ||
1263    ("User-defined perl style that calls " . $self->{function});
1264};
1265
1266sub format_message {
1267    my $self = shift;
1268    if($self->{useglobals}) {
1269        $_[0]->legacy_populate_global();
1270    }
1271    {
1272      package main;
1273      no strict 'refs';
1274      goto \&{$self->{function}};
1275    }
1276}
1277
1278package BarnOwl::Timer;
1279
1280sub new {
1281    my $class = shift;
1282    my $args = shift;
1283
1284    my $cb = $args->{cb};
1285    die("Invalid callback pased to BarnOwl::Timer\n") unless ref($cb) eq 'CODE';
1286
1287    my $self = {cb => $cb};
1288
1289    bless($self, $class);
1290
1291    $self->{timer} = BarnOwl::Internal::add_timer($args->{after} || 0,
1292                                                  $args->{interval} || 0,
1293                                                  $self);
1294    return $self;
1295}
1296
1297sub do_callback {
1298    my $self = shift;
1299    $self->{cb}->($self);
1300}
1301
1302sub DESTROY {
1303    my $self = shift;
1304    if(defined($self->{timer})) {
1305        BarnOwl::Internal::remove_timer($self->{timer});
1306    }
1307}
1308
1309
1310# switch to package main when we're done
1311package main;
1312
1313# Shove a bunch of fake entries into @INC so modules can use or
1314# require them without choking
1315$::INC{$_} = 1 for (qw(BarnOwl.pm BarnOwl/Hooks.pm
1316                       BarnOwl/Message.pm BarnOwl/Style.pm));
1317
13181;
1319
Note: See TracBrowser for help on using the repository browser.