source: perlwrap.pm @ fa8f439

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