source: perlwrap.pm @ 4789b17

debianrelease-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 4789b17 was acb13bb, checked in by Geoffrey Thomas <geofft@mit.edu>, 16 years ago
Add BarnOwl::zephyr_getsubs(), a thin Perl wrapper around owl_zephyr_getsubs()
  • Property mode set to 100644
File size: 26.7 KB
RevLine 
[f1e629d]1# $Id$
2#
3# This is all linked into the binary and evaluated when perl starts up...
4#
5#####################################################################
6#####################################################################
[b6c067a]7# XXX NOTE: This file is sourced before almost any barnowl
8# architecture is loaded. This means, for example, that it cannot
[0337203]9# execute any owl commands. Any code that needs to do so should live
10# in BarnOwl::Hooks::_startup
[f1e629d]11
[c681337]12use strict;
13use warnings;
14
[8203afd]15package BarnOwl;
[f1e629d]16
[74fc22a]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
[acb13bb]70=head2 zephyr_getsubs
71
72Returns the list of subscription triples <class,instance,recipient>,
73separated by newlines.
74
[74fc22a]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
[9815e2e]96=head2 start_edit_win PROMPT CALLBACK
[74fc22a]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
[b07d8c8]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
[0eaa488]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
[74fc22a]148=cut
149
150
[8862725]151BEGIN {
[f1e629d]152# bootstrap in C bindings and glue
[8203afd]153    *owl:: = \*BarnOwl::;
154    bootstrap BarnOwl 1.2;
[8862725]155};
156
[b363d83]157use lib(get_data_dir() . "/lib");
158use lib(get_config_dir() . "/lib");
[8862725]159
[b363d83]160# perlconfig.c will set this to the value of the -c command-line
161# switch, if present.
[00f9a7d]162our $configfile;
163
[2e3b9c2]164if(!$configfile && -f $ENV{HOME} . "/.barnowlconf") {
165    $configfile = $ENV{HOME} . "/.barnowlconf";
166}
167$configfile ||= $ENV{HOME}."/.owlconf";
[d03091c]168
[186cdc4]169# populate global variable space for legacy owlconf files
[f1e629d]170sub _receive_msg_legacy_wrap {
171    my ($m) = @_;
172    $m->legacy_populate_global();
[0337203]173    return &BarnOwl::Hooks::_receive_msg($m);
[f1e629d]174}
175
[74fc22a]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
[8203afd]196# make BarnOwl::<command>("foo") be aliases to BarnOwl::command("<command> foo");
[f1e629d]197sub AUTOLOAD {
[c681337]198    our $AUTOLOAD;
[f1e629d]199    my $called = $AUTOLOAD;
200    $called =~ s/.*:://;
[e7ac2b6]201    $called =~ s/_/-/g;
[8203afd]202    return &BarnOwl::command("$called ".join(" ",@_));
[f1e629d]203}
204
[6922edd]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>,
[74fc22a]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
[6922edd]230
231=cut
232
233sub new_command {
234    my $name = shift;
235    my $func = shift;
236    my $args = shift || {};
237    my %args = (
[8757122]238        summary     => "",
239        usage       => "",
240        description => "",
[6922edd]241        %{$args}
242    );
243
[8203afd]244    BarnOwl::new_command_internal($name, $func, $args{summary}, $args{usage}, $args{description});
[6922edd]245}
246
[cd57601]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
[a695a68]276sub new_variable_int {
277    unshift @_, \&BarnOwl::new_variable_int_internal, 0;
278    goto \&_new_variable;
279}
280
281sub new_variable_bool {
282    unshift @_, \&BarnOwl::new_variable_bool_internal, 0;
283    goto \&_new_variable;
284}
285
286sub new_variable_string {
287    unshift @_, \&BarnOwl::new_variable_string_internal, "";
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
[f1e629d]304#####################################################################
305#####################################################################
306
[8203afd]307package BarnOwl::Message;
[f1e629d]308
[dd16bdd]309sub new {
310    my $class = shift;
311    my %args = (@_);
312    if($class eq __PACKAGE__ && $args{type}) {
[8203afd]313        $class = "BarnOwl::Message::" . ucfirst $args{type};
[dd16bdd]314    }
315    return bless {%args}, $class;
316}
317
[f1e629d]318sub type        { return shift->{"type"}; }
319sub direction   { return shift->{"direction"}; }
320sub time        { return shift->{"time"}; }
321sub id          { return shift->{"id"}; }
322sub body        { return shift->{"body"}; }
323sub sender      { return shift->{"sender"}; }
324sub recipient   { return shift->{"recipient"}; }
325sub login       { return shift->{"login"}; }
[216c734]326sub is_private  { return shift->{"private"}; }
[f1e629d]327
328sub is_login    { return shift->login eq "login"; }
329sub is_logout   { return shift->login eq "logout"; }
330sub is_loginout { my $m=shift; return ($m->is_login or $m->is_logout); }
331sub is_incoming { return (shift->{"direction"} eq "in"); }
332sub is_outgoing { return (shift->{"direction"} eq "out"); }
333
334sub is_deleted  { return shift->{"deleted"}; }
335
336sub is_admin    { return (shift->{"type"} eq "admin"); }
337sub is_generic  { return (shift->{"type"} eq "generic"); }
[421c8ef7]338sub is_zephyr   { return (shift->{"type"} eq "zephyr"); }
[467aa16]339sub is_aim      { return (shift->{"type"} eq "AIM"); }
[dd16bdd]340sub is_jabber   { return (shift->{"type"} eq "jabber"); }
[421c8ef7]341sub is_icq      { return (shift->{"type"} eq "icq"); }
342sub is_yahoo    { return (shift->{"type"} eq "yahoo"); }
343sub is_msn      { return (shift->{"type"} eq "msn"); }
344sub is_loopback { return (shift->{"type"} eq "loopback"); }
[f1e629d]345
346# These are overridden by appropriate message types
347sub is_ping     { return 0; }
348sub is_mail     { return 0; }
[3c9012b]349sub is_personal { return shift->is_private; }
[f1e629d]350sub class       { return undef; }
351sub instance    { return undef; }
352sub realm       { return undef; }
353sub opcode      { return undef; }
354sub header      { return undef; }
355sub host        { return undef; }
356sub hostname    { return undef; }
357sub auth        { return undef; }
358sub fields      { return undef; }
359sub zsig        { return undef; }
360sub zwriteline  { return undef; }
[87c6ef1]361sub login_host  { return undef; }
362sub login_tty   { return undef; }
[f1e629d]363
[ae47efb]364sub pretty_sender    { return shift->sender; }
365sub pretty_recipient { return shift->recipient; }
[f1e629d]366
367sub delete {
368    my ($m) = @_;
[8203afd]369    &BarnOwl::command("delete --id ".$m->id);
[f1e629d]370}
371
372sub undelete {
373    my ($m) = @_;
[8203afd]374    &BarnOwl::command("undelete --id ".$m->id);
[f1e629d]375}
376
377# Serializes the message into something similar to the zwgc->vt format
378sub serialize {
379    my ($this) = @_;
380    my $s;
381    for my $f (keys %$this) {
382        my $val = $this->{$f};
383        if (ref($val) eq "ARRAY") {
384            for my $i (0..@$val-1) {
385                my $aval;
386                $aval = $val->[$i];
387                $aval =~ s/\n/\n$f.$i: /g;
[186cdc4]388                $s .= "$f.$i: $aval\n";
[f1e629d]389            }
390        } else {
391            $val =~ s/\n/\n$f: /g;
392            $s .= "$f: $val\n";
393        }
394    }
395    return $s;
396}
397
398# Populate the annoying legacy global variables
399sub legacy_populate_global {
400    my ($m) = @_;
[8203afd]401    $BarnOwl::direction  = $m->direction ;
402    $BarnOwl::type       = $m->type      ;
403    $BarnOwl::id         = $m->id        ;
404    $BarnOwl::class      = $m->class     ;
405    $BarnOwl::instance   = $m->instance  ;
406    $BarnOwl::recipient  = $m->recipient ;
407    $BarnOwl::sender     = $m->sender    ;
408    $BarnOwl::realm      = $m->realm     ;
409    $BarnOwl::opcode     = $m->opcode    ;
410    $BarnOwl::zsig       = $m->zsig      ;
411    $BarnOwl::msg        = $m->body      ;
412    $BarnOwl::time       = $m->time      ;
413    $BarnOwl::host       = $m->host      ;
414    $BarnOwl::login      = $m->login     ;
415    $BarnOwl::auth       = $m->auth      ;
[f1e629d]416    if ($m->fields) {
[8203afd]417        @BarnOwl::fields = @{$m->fields};
[f1e629d]418        @main::fields = @{$m->fields};
419    } else {
[8203afd]420        @BarnOwl::fields = undef;
[f1e629d]421        @main::fields = undef;
422    }
423}
424
[25729b2]425sub smartfilter {
[0337203]426    die("smartfilter not supported for this message\n");
[25729b2]427}
428
[6e6ded7]429# Display fields -- overridden by subclasses when needed
430sub login_type {""}
431sub login_extra {""}
432sub long_sender {""}
433
434# The context in which a non-personal message was sent, e.g. a chat or
435# class
436sub context {""}
437
438# Some indicator of context *within* $self->context. e.g. the zephyr
439# instance
440sub subcontext {""}
441
[f1e629d]442#####################################################################
443#####################################################################
444
[8203afd]445package BarnOwl::Message::Admin;
[f1e629d]446
[8203afd]447use base qw( BarnOwl::Message );
[f1e629d]448
449sub header       { return shift->{"header"}; }
450
451#####################################################################
452#####################################################################
453
[8203afd]454package BarnOwl::Message::Generic;
[f1e629d]455
[8203afd]456use base qw( BarnOwl::Message );
[f1e629d]457
458#####################################################################
459#####################################################################
460
[186cdc4]461package BarnOwl::Message::Loopback;
462
463use base qw( BarnOwl::Message );
464
[cb06a43]465# all loopback messages are private
466sub is_private {
[186cdc4]467  return 1;
468}
469
470#####################################################################
471#####################################################################
472
[8203afd]473package BarnOwl::Message::AIM;
[f1e629d]474
[8203afd]475use base qw( BarnOwl::Message );
[f1e629d]476
[cb06a43]477# all non-loginout AIM messages are private for now...
478sub is_private {
[f1e629d]479    return !(shift->is_loginout);
480}
481
482#####################################################################
483#####################################################################
484
[8203afd]485package BarnOwl::Message::Zephyr;
[f1e629d]486
[8203afd]487use base qw( BarnOwl::Message );
[f1e629d]488
[6e6ded7]489sub login_type {
490    return (shift->zsig eq "") ? "(PSEUDO)" : "";
491}
492
493sub login_extra {
494    my $m = shift;
495    return undef if (!$m->is_loginout);
496    my $s = lc($m->host);
497    $s .= " " . $m->login_tty if defined $m->login_tty;
498    return $s;
499}
500
501sub long_sender {
502    my $m = shift;
503    return $m->zsig;
504}
505
506sub context {
507    return shift->class;
508}
509
510sub subcontext {
511    return shift->instance;
512}
513
[186cdc4]514sub login_tty {
[f1e629d]515    my ($m) = @_;
516    return undef if (!$m->is_loginout);
517    return $m->fields->[2];
518}
519
[186cdc4]520sub login_host {
[f1e629d]521    my ($m) = @_;
522    return undef if (!$m->is_loginout);
523    return $m->fields->[0];
524}
525
526sub zwriteline  { return shift->{"zwriteline"}; }
527
528sub is_ping     { return (lc(shift->opcode) eq "ping"); }
529
[186cdc4]530sub is_personal {
[f1e629d]531    my ($m) = @_;
532    return ((lc($m->class) eq "message")
533            && (lc($m->instance) eq "personal")
534            && $m->is_private);
535}
536
[186cdc4]537sub is_mail {
[f1e629d]538    my ($m) = @_;
539    return ((lc($m->class) eq "mail") && $m->is_private);
540}
541
542sub pretty_sender {
543    my ($m) = @_;
544    my $sender = $m->sender;
[8203afd]545    my $realm = BarnOwl::zephyr_getrealm();
[f1e629d]546    $sender =~ s/\@$realm$//;
547    return $sender;
548}
549
[ae47efb]550sub pretty_recipient {
551    my ($m) = @_;
552    my $recip = $m->recipient;
553    my $realm = BarnOwl::zephyr_getrealm();
554    $recip =~ s/\@$realm$//;
555    return $recip;
556}
557
[f1e629d]558# These are arguably zephyr-specific
559sub class       { return shift->{"class"}; }
560sub instance    { return shift->{"instance"}; }
561sub realm       { return shift->{"realm"}; }
562sub opcode      { return shift->{"opcode"}; }
563sub host        { return shift->{"hostname"}; }
564sub hostname    { return shift->{"hostname"}; }
565sub header      { return shift->{"header"}; }
566sub auth        { return shift->{"auth"}; }
567sub fields      { return shift->{"fields"}; }
568sub zsig        { return shift->{"zsig"}; }
569
570#####################################################################
571#####################################################################
[7e470da]572################################################################################
573
[0337203]574package BarnOwl::Hook;
[7e470da]575
[1a64de6]576=head1 BarnOwl::Hook
577
578=head1 DESCRIPTION
579
580A C<BarnOwl::Hook> represents a list of functions to be triggered on
581some event. C<BarnOwl> exports a default set of these (see
582C<BarnOwl::Hooks>), but can also be created and used by module code.
583
584=head2 new
585
586Creates a new Hook object
587
588=cut
589
[0337203]590sub new {
591    my $class = shift;
592    return bless [], $class;
593}
[7e470da]594
[1a64de6]595=head2 run [ARGS]
596
597Calls each of the functions registered with this hook with the given
598arguments.
599
600=cut
601
[0337203]602sub run {
603    my $self = shift;
604    my @args = @_;
605    return map {$_->(@args)} @$self;
[7e470da]606}
[0337203]607
[1a64de6]608=head2 add SUBREF
609
610Registers a given subroutine with this hook
611
612=cut
613
[0337203]614sub add {
615    my $self = shift;
616    my $func = shift;
617    die("Not a coderef!") unless ref($func) eq 'CODE';
618    push @$self, $func;
[7e470da]619}
620
[1a64de6]621=head2 clear
622
623Remove all functions registered with this hook.
624
625=cut
626
[0337203]627sub clear {
628    my $self = shift;
629    @$self = ();
[7e470da]630}
631
[0337203]632package BarnOwl::Hooks;
[7e470da]633
[1a64de6]634=head1 BarnOwl::Hooks
635
636=head1 DESCRIPTION
637
638C<BarnOwl::Hooks> exports a set of C<BarnOwl::Hook> objects made
639available by BarnOwl internally.
640
641=head2 USAGE
642
643Modules wishing to respond to events in BarnOwl should register
644functions with these hooks.
645
646=head2 EXPORTS
647
648None by default. Either import the hooks you need explicitly, or refer
649to them with fully-qualified names. Available hooks are:
650
651=over 4
652
653=item $startup
654
655Called on BarnOwl startup, and whenever modules are
656reloaded. Functions registered with the C<$startup> hook get a true
657argument if this is a reload, and false if this is a true startup
658
659=item $shutdown
660
661Called before BarnOwl shutdown
662
663=item $receiveMessage
664
665Called with a C<BarnOwl::Message> object every time BarnOwl appends a
666new message to its message list
667
668=item $mainLoop
669
[b07d8c8]670Called on every pass through the C<BarnOwl> main loop. This is
671guaranteed to be called at least once/sec and may be called more
672frequently.
[1a64de6]673
674=item $getBuddyList
675
676Called to display buddy lists for all protocol handlers. The result
677from every function registered with this hook will be appended and
678displayed in a popup window, with zephyr formatting parsed.
679
680=back
681
682=cut
683
[0337203]684use Exporter;
685
686our @EXPORT_OK = qw($startup $shutdown
687                    $receiveMessage $mainLoop
688                    $getBuddyList);
689
690our %EXPORT_TAGS = (all => [@EXPORT_OK]);
691
692our $startup = BarnOwl::Hook->new;
693our $shutdown = BarnOwl::Hook->new;
694our $receiveMessage = BarnOwl::Hook->new;
695our $mainLoop = BarnOwl::Hook->new;
696our $getBuddyList = BarnOwl::Hook->new;
697
698# Internal startup/shutdown routines called by the C code
[7e470da]699
[2650a10]700sub _load_perl_commands {
701    # Load builtin perl commands
702    BarnOwl::new_command(style => \&BarnOwl::Style::style_command,
703                       {
704                           summary => "creates a new style",
705                           usage   => "style <name> perl <function_name>",
706                           description =>
707                           "A style named <name> will be created that will\n" .
708                           "format messages using the perl function <function_name>.\n\n" .
709                           "SEE ALSO: show styles, view -s, filter -s\n\n" .
710                           "DEPRECATED in favor of BarnOwl::create_style(NAME, OBJECT)",
711                          });
712}
713
[b6c067a]714sub _load_owlconf {
715    # load the config  file
716    if ( -r $BarnOwl::configfile ) {
717        undef $@;
[e8bc8ac]718        package main;
[b6c067a]719        do $BarnOwl::configfile;
[e2257be]720        if($@) {
721            BarnOwl::error("In startup: $@\n");
722            return;
723        }
[e8bc8ac]724        package BarnOwl;
[39dc159]725        if(*BarnOwl::format_msg{CODE}) {
726            # if the config defines a legacy formatting function, add 'perl' as a style
[b67ab6b]727            BarnOwl::create_style("perl", BarnOwl::Style::Legacy->new(
728                "BarnOwl::format_msg",
729                "User-defined perl style that calls BarnOwl::format_msg"
730                . " with legacy global variable support",
731                1));
732             BarnOwl::set("-q default_style perl");
[39dc159]733        }
[b6c067a]734    }
735}
736
[b0c8011]737# These are the internal hooks called by the barnowl C code, which
738# take care of dispatching to the appropriate perl hooks, and deal
739# with compatibility by calling the old, fixed-name hooks.
740
[0337203]741sub _startup {
[2650a10]742    _load_perl_commands();
[0337203]743    _load_owlconf();
[8203afd]744
[0337203]745    if(eval {require BarnOwl::ModuleLoader}) {
746        eval {
747            BarnOwl::ModuleLoader->load_all;
748        };
[f6b319c]749        BarnOwl::error("$@") if $@;
750
[0337203]751    } else {
752        BarnOwl::error("Can't load BarnOwl::ModuleLoader, loadable module support disabled:\n$@");
753    }
754   
[836e6263]755    $startup->run(0);
[8203afd]756    BarnOwl::startup() if *BarnOwl::startup{CODE};
757}
758
[0337203]759sub _shutdown {
760    $shutdown->run;
761   
[8203afd]762    BarnOwl::shutdown() if *BarnOwl::shutdown{CODE};
763}
764
[0337203]765sub _receive_msg {
[7e470da]766    my $m = shift;
[0337203]767
768    $receiveMessage->run($m);
769   
[8203afd]770    BarnOwl::receive_msg($m) if *BarnOwl::receive_msg{CODE};
[7e470da]771}
772
[0337203]773sub _mainloop_hook {
774    $mainLoop->run;
775    BarnOwl::mainloop_hook() if *BarnOwl::mainloop_hook{CODE};
776}
[7e470da]777
[0337203]778sub _get_blist {
779    return join("\n", $getBuddyList->run);
[7e470da]780}
[dd16bdd]781
[b6c067a]782################################################################################
783# Built-in perl styles
784################################################################################
785package BarnOwl::Style::Default;
786################################################################################
787# Branching point for various formatting functions in this style.
788################################################################################
[426735d]789sub format_message
[b6c067a]790{
[864ed35]791    my $self = shift;
[811ad93]792    my $m    = shift;
793    my $fmt;
[b6c067a]794
[6e6ded7]795    if ( $m->is_loginout) {
[811ad93]796        $fmt = $self->format_login($m);
[18fb3d4f]797    } elsif($m->is_ping && $m->is_personal) {
[811ad93]798        $fmt = $self->format_ping($m);
[6e6ded7]799    } elsif($m->is_admin) {
[811ad93]800        $fmt = $self->format_admin($m);
[6e6ded7]801    } else {
[811ad93]802        $fmt = $self->format_chat($m);
[b6c067a]803    }
[811ad93]804    $fmt = BarnOwl::Style::boldify($fmt) if $self->should_bold($m);
805    return $fmt;
806}
807
808sub should_bold {
809    my $self = shift;
810    my $m = shift;
811    return $m->is_personal && $m->direction eq "in";
[b6c067a]812}
813
[864ed35]814sub description {"Default style";}
815
[b67ab6b]816BarnOwl::create_style("default", "BarnOwl::Style::Default");
[b6c067a]817
818################################################################################
819
[426735d]820sub format_time {
[6b3878b]821    my $self = shift;
[6e6ded7]822    my $m = shift;
[b6c067a]823    my ($time) = $m->time =~ /(\d\d:\d\d)/;
[6e6ded7]824    return $time;
[b6c067a]825}
826
[426735d]827sub format_login {
[864ed35]828    my $self = shift;
[b6c067a]829    my $m = shift;
[6e6ded7]830    return sprintf(
831        '@b<%s%s> for @b(%s) (%s) %s',
832        uc( $m->login ),
833        $m->login_type,
834        $m->pretty_sender,
835        $m->login_extra,
[426735d]836        $self->format_time($m)
[6e6ded7]837       );
[b6c067a]838}
839
[864ed35]840sub format_ping {
841    my $self = shift;
842    my $m = shift;
[2017d07]843    return "\@b(PING) from \@b(" . $m->pretty_sender . ")";
[864ed35]844}
845
846sub format_admin {
847    my $self = shift;
848    my $m = shift;
[811ad93]849    return "\@bold(OWL ADMIN)\n" . $self->indent_body($m);
[864ed35]850}
851
[426735d]852sub format_chat {
[864ed35]853    my $self = shift;
[b6c067a]854    my $m = shift;
[811ad93]855    my $header = $self->chat_header($m);
856    return $header . "\n". $self->indent_body($m);
857}
858
859sub chat_header {
860    my $self = shift;
861    my $m = shift;
[6e6ded7]862    my $header;
863    if ( $m->is_personal ) {
864        if ( $m->direction eq "out" ) {
865            $header = ucfirst $m->type . " sent to " . $m->pretty_recipient;
866        } else {
867            $header = ucfirst $m->type . " from " . $m->pretty_sender;
868        }
869    } else {
870        $header = $m->context;
[37dd88c]871        if(defined $m->subcontext) {
[c39999f]872            $header .= ' / ' . $m->subcontext;
[6e6ded7]873        }
[c39999f]874        $header .= ' / @b{' . $m->pretty_sender . '}';
[6e6ded7]875    }
[b6c067a]876
[b51d257]877    if($m->opcode) {
878        $header .= " [" . $m->opcode . "]";
879    }
[426735d]880    $header .= "  " . $self->format_time($m);
[811ad93]881    $header .= $self->format_sender($m);
882    return $header;
883}
884
885sub format_sender {
886    my $self = shift;
887    my $m = shift;
[0449730]888    my $sender = $m->long_sender;
889    $sender =~ s/\n.*$//s;
[811ad93]890    return "  (" . $sender . '@color[default]' . ")";
[b6c067a]891}
892
[426735d]893sub indent_body
[b6c067a]894{
[811ad93]895    my $self = shift;
[b6c067a]896    my $m = shift;
[186cdc4]897
[b6c067a]898    my $body = $m->body;
[f6b319c]899    if ($m->{should_wordwrap}) {
900      $body = BarnOwl::wordwrap($body, BarnOwl::getnumcols()-8);
901    }
[186cdc4]902    # replace newline followed by anything with
[b6c067a]903    # newline plus four spaces and that thing.
904    $body =~ s/\n(.)/\n    $1/g;
[f2d72128]905    # Trim trailing newlines.
906    $body =~ s/\n*$//;
[b6c067a]907    return "    ".$body;
908}
909
[864ed35]910package BarnOwl::Style::Basic;
911our @ISA=qw(BarnOwl::Style::Default);
912
913sub description {"Compatability alias for the default style";}
914
[b67ab6b]915BarnOwl::create_style("basic", "BarnOwl::Style::Basic");
[864ed35]916
[f2d72128]917package BarnOwl::Style::OneLine;
[811ad93]918# Inherit format_message to dispatch
919our @ISA = qw(BarnOwl::Style::Default);
[f2d72128]920
[811ad93]921use constant BASE_FORMAT => '%s %-13.13s %-11.11s %-12.12s ';
[f2d72128]922
[864ed35]923sub description {"Formats for one-line-per-message"}
924
[b67ab6b]925BarnOwl::create_style("oneline", "BarnOwl::Style::OneLine");
[f2d72128]926
927################################################################################
928
[426735d]929sub format_login {
[864ed35]930  my $self = shift;
[f2d72128]931  my $m = shift;
932  return sprintf(
933    BASE_FORMAT,
934    '<',
935    $m->type,
936    uc( $m->login ),
937    $m->pretty_sender)
938    . ($m->login_extra ? "at ".$m->login_extra : '');
939}
940
[426735d]941sub format_ping {
[2017d07]942  my $self = shift;
[f2d72128]943  my $m = shift;
944  return sprintf(
945    BASE_FORMAT,
946    '<',
947    $m->type,
948    'PING',
949    $m->pretty_sender)
950}
951
[426735d]952sub format_chat
[f2d72128]953{
[864ed35]954  my $self = shift;
[f2d72128]955  my $m = shift;
956  my $dir = lc($m->{direction});
957  my $dirsym = '-';
958  if ($dir eq 'in') {
959    $dirsym = '<';
960  }
961  elsif ($dir eq 'out') {
962    $dirsym = '>';
963  }
964
965  my $line;
966  if ($m->is_personal) {
967    $line= sprintf(BASE_FORMAT,
[811ad93]968                   $dirsym,
969                   $m->type,
970                   '',
971                   ($dir eq 'out'
972                    ? $m->pretty_recipient
973                    : $m->pretty_sender));
[f2d72128]974  }
975  else {
976    $line = sprintf(BASE_FORMAT,
[811ad93]977                    $dirsym,
978                    $m->context,
979                    $m->subcontext,
980                    ($dir eq 'out'
981                     ? $m->pretty_recipient
982                     : $m->pretty_sender));
[f2d72128]983  }
984
985  my $body = $m->{body};
986  $body =~ tr/\n/ /;
987  $line .= $body;
988  return $line;
989}
990
[811ad93]991# Format owl admin messages
[426735d]992sub format_admin
[f2d72128]993{
[864ed35]994  my $self = shift;
[f2d72128]995  my $m = shift;
[811ad93]996  my $line = sprintf(BASE_FORMAT, '<', 'ADMIN', '', '');
[f2d72128]997  my $body = $m->{body};
998  $body =~ tr/\n/ /;
999  return $line.$body;
1000}
[b6c067a]1001
1002package BarnOwl::Style;
1003
1004# This takes a zephyr to be displayed and modifies it to be displayed
1005# entirely in bold.
[426735d]1006sub boldify
[b6c067a]1007{
1008    local $_ = shift;
1009    if ( !(/\)/) ) {
1010        return '@b(' . $_ . ')';
1011    } elsif ( !(/\>/) ) {
1012        return '@b<' . $_ . '>';
1013    } elsif ( !(/\}/) ) {
1014        return '@b{' . $_ . '}';
1015    } elsif ( !(/\]/) ) {
1016        return '@b[' . $_ . ']';
1017    } else {
1018        my $txt = "\@b($_";
1019        $txt =~ s/\)/\)\@b\[\)\]\@b\(/g;
1020        return $txt . ')';
1021    }
1022}
1023
[2650a10]1024sub style_command {
1025    my $command = shift;
1026    if(scalar @_ != 3 || $_[1] ne 'perl') {
1027        die("Usage: style <name> perl <function>\n");
1028    }
1029    my $name = shift;
1030    my $perl = shift;
1031    my $fn   = shift;
1032    {
[b441079]1033        # For historical reasons, assume unqualified references are
1034        # in main::
1035        package main;
[2650a10]1036        no strict 'refs';
1037        unless(*{$fn}{CODE}) {
1038            die("Unable to create style '$name': no perl function '$fn'\n");
1039        }
1040    }
1041    BarnOwl::create_style($name, BarnOwl::Style::Legacy->new($fn));
1042}
1043
[b67ab6b]1044package BarnOwl::Style::Legacy;
1045
1046sub new {
1047    my $class = shift;
1048    my $func  = shift;
1049    my $desc  = shift;
1050    my $useglobals = shift;
1051    $useglobals = 0 unless defined($useglobals);
1052    return bless {function    => $func,
1053                  description => $desc,
1054                  useglobals  => $useglobals}, $class;
1055}
1056
[2650a10]1057sub description {
1058    my $self = shift;
1059    return $self->{description} ||
1060    ("User-defined perl style that calls " . $self->{function});
1061};
[b67ab6b]1062
1063sub format_message {
1064    my $self = shift;
1065    if($self->{useglobals}) {
1066        $_[0]->legacy_populate_global();
1067    }
[b441079]1068    {
1069      package main;
1070      no strict 'refs';
1071      goto \&{$self->{function}};
1072    }
[b67ab6b]1073}
1074
[b6c067a]1075
[f1e629d]1076# switch to package main when we're done
1077package main;
[0337203]1078
1079# Shove a bunch of fake entries into @INC so modules can use or
1080# require them without choking
1081$::INC{$_} = 1 for (qw(BarnOwl.pm BarnOwl/Hooks.pm
1082                       BarnOwl/Message.pm BarnOwl/Style.pm));
[f1e629d]1083
10841;
[0337203]1085
Note: See TracBrowser for help on using the repository browser.