source: perlwrap.pm @ 57cf4f9

debianrelease-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 57cf4f9 was 57cf4f9, checked in by Nelson Elhage <nelhage@mit.edu>, 13 years ago
Make owl_function_reply call methods to get the replycmd. For backwards compatibility, we add default sub replycmd and sub replysendercmd to BarnOwl::Message, which just return the value of the property.
  • Property mode set to 100644
File size: 27.3 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::new_command_internal($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::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
304#####################################################################
305#####################################################################
306
307package BarnOwl::Message;
308
309sub new {
310    my $class = shift;
311    my %args = (@_);
312    if($class eq __PACKAGE__ && $args{type}) {
313        $class = "BarnOwl::Message::" . ucfirst $args{type};
314    }
315    return bless {%args}, $class;
316}
317
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"}; }
326sub is_private  { return shift->{"private"}; }
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"); }
338sub is_zephyr   { return (shift->{"type"} eq "zephyr"); }
339sub is_aim      { return (shift->{"type"} eq "AIM"); }
340sub is_jabber   { return (shift->{"type"} eq "jabber"); }
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"); }
345
346# These are overridden by appropriate message types
347sub is_ping     { return 0; }
348sub is_mail     { return 0; }
349sub is_personal { return shift->is_private; }
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; }
361sub login_host  { return undef; }
362sub login_tty   { return undef; }
363
364# This is for back-compat with old messages that set these properties
365# New protocol implementations are encourages to user override these
366# methods.
367sub replycmd         { return shift->{replycmd}};
368sub replysendercmd   { return shift->{replysendercmd}};
369
370sub pretty_sender    { return shift->sender; }
371sub pretty_recipient { return shift->recipient; }
372
373sub delete {
374    my ($m) = @_;
375    &BarnOwl::command("delete --id ".$m->id);
376}
377
378sub undelete {
379    my ($m) = @_;
380    &BarnOwl::command("undelete --id ".$m->id);
381}
382
383# Serializes the message into something similar to the zwgc->vt format
384sub serialize {
385    my ($this) = @_;
386    my $s;
387    for my $f (keys %$this) {
388        my $val = $this->{$f};
389        if (ref($val) eq "ARRAY") {
390            for my $i (0..@$val-1) {
391                my $aval;
392                $aval = $val->[$i];
393                $aval =~ s/\n/\n$f.$i: /g;
394                $s .= "$f.$i: $aval\n";
395            }
396        } else {
397            $val =~ s/\n/\n$f: /g;
398            $s .= "$f: $val\n";
399        }
400    }
401    return $s;
402}
403
404# Populate the annoying legacy global variables
405sub legacy_populate_global {
406    my ($m) = @_;
407    $BarnOwl::direction  = $m->direction ;
408    $BarnOwl::type       = $m->type      ;
409    $BarnOwl::id         = $m->id        ;
410    $BarnOwl::class      = $m->class     ;
411    $BarnOwl::instance   = $m->instance  ;
412    $BarnOwl::recipient  = $m->recipient ;
413    $BarnOwl::sender     = $m->sender    ;
414    $BarnOwl::realm      = $m->realm     ;
415    $BarnOwl::opcode     = $m->opcode    ;
416    $BarnOwl::zsig       = $m->zsig      ;
417    $BarnOwl::msg        = $m->body      ;
418    $BarnOwl::time       = $m->time      ;
419    $BarnOwl::host       = $m->host      ;
420    $BarnOwl::login      = $m->login     ;
421    $BarnOwl::auth       = $m->auth      ;
422    if ($m->fields) {
423        @BarnOwl::fields = @{$m->fields};
424        @main::fields = @{$m->fields};
425    } else {
426        @BarnOwl::fields = undef;
427        @main::fields = undef;
428    }
429}
430
431sub smartfilter {
432    die("smartfilter not supported for this message\n");
433}
434
435# Display fields -- overridden by subclasses when needed
436sub login_type {""}
437sub login_extra {""}
438sub long_sender {""}
439
440# The context in which a non-personal message was sent, e.g. a chat or
441# class
442sub context {""}
443
444# Some indicator of context *within* $self->context. e.g. the zephyr
445# instance
446sub subcontext {""}
447
448#####################################################################
449#####################################################################
450
451package BarnOwl::Message::Admin;
452
453use base qw( BarnOwl::Message );
454
455sub header       { return shift->{"header"}; }
456
457#####################################################################
458#####################################################################
459
460package BarnOwl::Message::Generic;
461
462use base qw( BarnOwl::Message );
463
464#####################################################################
465#####################################################################
466
467package BarnOwl::Message::Loopback;
468
469use base qw( BarnOwl::Message );
470
471# all loopback messages are private
472sub is_private {
473  return 1;
474}
475
476#####################################################################
477#####################################################################
478
479package BarnOwl::Message::AIM;
480
481use base qw( BarnOwl::Message );
482
483# all non-loginout AIM messages are private for now...
484sub is_private {
485    return !(shift->is_loginout);
486}
487
488#####################################################################
489#####################################################################
490
491package BarnOwl::Message::Zephyr;
492
493use base qw( BarnOwl::Message );
494
495sub login_type {
496    return (shift->zsig eq "") ? "(PSEUDO)" : "";
497}
498
499sub login_extra {
500    my $m = shift;
501    return undef if (!$m->is_loginout);
502    my $s = lc($m->host);
503    $s .= " " . $m->login_tty if defined $m->login_tty;
504    return $s;
505}
506
507sub long_sender {
508    my $m = shift;
509    return $m->zsig;
510}
511
512sub context {
513    return shift->class;
514}
515
516sub subcontext {
517    return shift->instance;
518}
519
520sub login_tty {
521    my ($m) = @_;
522    return undef if (!$m->is_loginout);
523    return $m->fields->[2];
524}
525
526sub login_host {
527    my ($m) = @_;
528    return undef if (!$m->is_loginout);
529    return $m->fields->[0];
530}
531
532sub zwriteline  { return shift->{"zwriteline"}; }
533
534sub is_ping     { return (lc(shift->opcode) eq "ping"); }
535
536sub is_personal {
537    my ($m) = @_;
538    return ((lc($m->class) eq "message")
539            && (lc($m->instance) eq "personal")
540            && $m->is_private);
541}
542
543sub is_mail {
544    my ($m) = @_;
545    return ((lc($m->class) eq "mail") && $m->is_private);
546}
547
548sub pretty_sender {
549    my ($m) = @_;
550    my $sender = $m->sender;
551    my $realm = BarnOwl::zephyr_getrealm();
552    $sender =~ s/\@$realm$//;
553    return $sender;
554}
555
556sub pretty_recipient {
557    my ($m) = @_;
558    my $recip = $m->recipient;
559    my $realm = BarnOwl::zephyr_getrealm();
560    $recip =~ s/\@$realm$//;
561    return $recip;
562}
563
564# These are arguably zephyr-specific
565sub class       { return shift->{"class"}; }
566sub instance    { return shift->{"instance"}; }
567sub realm       { return shift->{"realm"}; }
568sub opcode      { return shift->{"opcode"}; }
569sub host        { return shift->{"hostname"}; }
570sub hostname    { return shift->{"hostname"}; }
571sub header      { return shift->{"header"}; }
572sub auth        { return shift->{"auth"}; }
573sub fields      { return shift->{"fields"}; }
574sub zsig        { return shift->{"zsig"}; }
575
576#####################################################################
577#####################################################################
578################################################################################
579
580package BarnOwl::Hook;
581
582=head1 BarnOwl::Hook
583
584=head1 DESCRIPTION
585
586A C<BarnOwl::Hook> represents a list of functions to be triggered on
587some event. C<BarnOwl> exports a default set of these (see
588C<BarnOwl::Hooks>), but can also be created and used by module code.
589
590=head2 new
591
592Creates a new Hook object
593
594=cut
595
596sub new {
597    my $class = shift;
598    return bless [], $class;
599}
600
601=head2 run [ARGS]
602
603Calls each of the functions registered with this hook with the given
604arguments.
605
606=cut
607
608sub run {
609    my $self = shift;
610    my @args = @_;
611    return map {$self->_run($_,@args)} @$self;
612}
613
614sub _run {
615    my $self = shift;
616    my $fn = shift;
617    my @args = @_;
618    no strict 'refs';
619    return $fn->(@args);
620}
621
622=head2 add SUBREF
623
624Registers a given subroutine with this hook
625
626=cut
627
628sub add {
629    my $self = shift;
630    my $func = shift;
631    die("Not a coderef!") unless ref($func) eq 'CODE' || !ref($func);
632    return if grep {$_ eq $func} @$self;
633    push @$self, $func;
634}
635
636=head2 clear
637
638Remove all functions registered with this hook.
639
640=cut
641
642sub clear {
643    my $self = shift;
644    @$self = ();
645}
646
647package BarnOwl::Hooks;
648
649=head1 BarnOwl::Hooks
650
651=head1 DESCRIPTION
652
653C<BarnOwl::Hooks> exports a set of C<BarnOwl::Hook> objects made
654available by BarnOwl internally.
655
656=head2 USAGE
657
658Modules wishing to respond to events in BarnOwl should register
659functions with these hooks.
660
661=head2 EXPORTS
662
663None by default. Either import the hooks you need explicitly, or refer
664to them with fully-qualified names. Available hooks are:
665
666=over 4
667
668=item $startup
669
670Called on BarnOwl startup, and whenever modules are
671reloaded. Functions registered with the C<$startup> hook get a true
672argument if this is a reload, and false if this is a true startup
673
674=item $shutdown
675
676Called before BarnOwl shutdown
677
678=item $receiveMessage
679
680Called with a C<BarnOwl::Message> object every time BarnOwl appends a
681new message to its message list
682
683=item $mainLoop
684
685Called on every pass through the C<BarnOwl> main loop. This is
686guaranteed to be called at least once/sec and may be called more
687frequently.
688
689=item $getBuddyList
690
691Called to display buddy lists for all protocol handlers. The result
692from every function registered with this hook will be appended and
693displayed in a popup window, with zephyr formatting parsed.
694
695=back
696
697=cut
698
699use Exporter;
700
701our @EXPORT_OK = qw($startup $shutdown
702                    $receiveMessage $newMessage
703                    $mainLoop $getBuddyList);
704
705our %EXPORT_TAGS = (all => [@EXPORT_OK]);
706
707our $startup = BarnOwl::Hook->new;
708our $shutdown = BarnOwl::Hook->new;
709our $receiveMessage = BarnOwl::Hook->new;
710our $newMessage = BarnOwl::Hook->new;
711our $mainLoop = BarnOwl::Hook->new;
712our $getBuddyList = BarnOwl::Hook->new;
713
714# Internal startup/shutdown routines called by the C code
715
716sub _load_perl_commands {
717    # Load builtin perl commands
718    BarnOwl::new_command(style => \&BarnOwl::Style::style_command,
719                       {
720                           summary => "creates a new style",
721                           usage   => "style <name> perl <function_name>",
722                           description =>
723                           "A style named <name> will be created that will\n" .
724                           "format messages using the perl function <function_name>.\n\n" .
725                           "SEE ALSO: show styles, view -s, filter -s\n\n" .
726                           "DEPRECATED in favor of BarnOwl::create_style(NAME, OBJECT)",
727                          });
728}
729
730sub _load_owlconf {
731    # load the config  file
732    if ( -r $BarnOwl::configfile ) {
733        undef $@;
734        package main;
735        do $BarnOwl::configfile;
736        if($@) {
737            BarnOwl::error("In startup: $@\n");
738            return;
739        }
740        package BarnOwl;
741        if(*BarnOwl::format_msg{CODE}) {
742            # if the config defines a legacy formatting function, add 'perl' as a style
743            BarnOwl::create_style("perl", BarnOwl::Style::Legacy->new(
744                "BarnOwl::format_msg",
745                "User-defined perl style that calls BarnOwl::format_msg"
746                . " with legacy global variable support",
747                1));
748             BarnOwl::set("-q default_style perl");
749        }
750    }
751}
752
753# These are the internal hooks called by the barnowl C code, which
754# take care of dispatching to the appropriate perl hooks, and deal
755# with compatibility by calling the old, fixed-name hooks.
756
757sub _startup {
758    _load_perl_commands();
759    _load_owlconf();
760
761    if(eval {require BarnOwl::ModuleLoader}) {
762        eval {
763            BarnOwl::ModuleLoader->load_all;
764        };
765        BarnOwl::error("$@") if $@;
766
767    } else {
768        BarnOwl::error("Can't load BarnOwl::ModuleLoader, loadable module support disabled:\n$@");
769    }
770   
771    $startup->run(0);
772    BarnOwl::startup() if *BarnOwl::startup{CODE};
773}
774
775sub _shutdown {
776    $shutdown->run;
777   
778    BarnOwl::shutdown() if *BarnOwl::shutdown{CODE};
779}
780
781sub _receive_msg {
782    my $m = shift;
783
784    $receiveMessage->run($m);
785   
786    BarnOwl::receive_msg($m) if *BarnOwl::receive_msg{CODE};
787}
788
789sub _new_msg {
790    my $m = shift;
791
792    $newMessage->run($m);
793   
794    BarnOwl::new_msg($m) if *BarnOwl::new_msg{CODE};
795}
796
797sub _mainloop_hook {
798    $mainLoop->run;
799    BarnOwl::mainloop_hook() if *BarnOwl::mainloop_hook{CODE};
800}
801
802sub _get_blist {
803    return join("\n", $getBuddyList->run);
804}
805
806################################################################################
807# Built-in perl styles
808################################################################################
809package BarnOwl::Style::Default;
810################################################################################
811# Branching point for various formatting functions in this style.
812################################################################################
813sub format_message
814{
815    my $self = shift;
816    my $m    = shift;
817    my $fmt;
818
819    if ( $m->is_loginout) {
820        $fmt = $self->format_login($m);
821    } elsif($m->is_ping && $m->is_personal) {
822        $fmt = $self->format_ping($m);
823    } elsif($m->is_admin) {
824        $fmt = $self->format_admin($m);
825    } else {
826        $fmt = $self->format_chat($m);
827    }
828    $fmt = BarnOwl::Style::boldify($fmt) if $self->should_bold($m);
829    return $fmt;
830}
831
832sub should_bold {
833    my $self = shift;
834    my $m = shift;
835    return $m->is_personal && $m->direction eq "in";
836}
837
838sub description {"Default style";}
839
840BarnOwl::create_style("default", "BarnOwl::Style::Default");
841
842################################################################################
843
844sub format_time {
845    my $self = shift;
846    my $m = shift;
847    my ($time) = $m->time =~ /(\d\d:\d\d)/;
848    return $time;
849}
850
851sub format_login {
852    my $self = shift;
853    my $m = shift;
854    return sprintf(
855        '@b<%s%s> for @b(%s) (%s) %s',
856        uc( $m->login ),
857        $m->login_type,
858        $m->pretty_sender,
859        $m->login_extra,
860        $self->format_time($m)
861       );
862}
863
864sub format_ping {
865    my $self = shift;
866    my $m = shift;
867    return "\@b(PING) from \@b(" . $m->pretty_sender . ")";
868}
869
870sub format_admin {
871    my $self = shift;
872    my $m = shift;
873    return "\@bold(OWL ADMIN)\n" . $self->indent_body($m);
874}
875
876sub format_chat {
877    my $self = shift;
878    my $m = shift;
879    my $header = $self->chat_header($m);
880    return $header . "\n". $self->indent_body($m);
881}
882
883sub chat_header {
884    my $self = shift;
885    my $m = shift;
886    my $header;
887    if ( $m->is_personal ) {
888        if ( $m->direction eq "out" ) {
889            $header = ucfirst $m->type . " sent to " . $m->pretty_recipient;
890        } else {
891            $header = ucfirst $m->type . " from " . $m->pretty_sender;
892        }
893    } else {
894        $header = $m->context;
895        if(defined $m->subcontext) {
896            $header .= ' / ' . $m->subcontext;
897        }
898        $header .= ' / @b{' . $m->pretty_sender . '}';
899    }
900
901    if($m->opcode) {
902        $header .= " [" . $m->opcode . "]";
903    }
904    $header .= "  " . $self->format_time($m);
905    $header .= $self->format_sender($m);
906    return $header;
907}
908
909sub format_sender {
910    my $self = shift;
911    my $m = shift;
912    my $sender = $m->long_sender;
913    $sender =~ s/\n.*$//s;
914    return "  (" . $sender . '@color[default]' . ")";
915}
916
917sub indent_body
918{
919    my $self = shift;
920    my $m = shift;
921
922    my $body = $m->body;
923    if ($m->{should_wordwrap}) {
924      $body = BarnOwl::wordwrap($body, BarnOwl::getnumcols()-8);
925    }
926    # replace newline followed by anything with
927    # newline plus four spaces and that thing.
928    $body =~ s/\n(.)/\n    $1/g;
929    # Trim trailing newlines.
930    $body =~ s/\n*$//;
931    return "    ".$body;
932}
933
934package BarnOwl::Style::Basic;
935our @ISA=qw(BarnOwl::Style::Default);
936
937sub description {"Compatability alias for the default style";}
938
939BarnOwl::create_style("basic", "BarnOwl::Style::Basic");
940
941package BarnOwl::Style::OneLine;
942# Inherit format_message to dispatch
943our @ISA = qw(BarnOwl::Style::Default);
944
945use constant BASE_FORMAT => '%s %-13.13s %-11.11s %-12.12s ';
946
947sub description {"Formats for one-line-per-message"}
948
949BarnOwl::create_style("oneline", "BarnOwl::Style::OneLine");
950
951################################################################################
952
953sub format_login {
954  my $self = shift;
955  my $m = shift;
956  return sprintf(
957    BASE_FORMAT,
958    '<',
959    $m->type,
960    uc( $m->login ),
961    $m->pretty_sender)
962    . ($m->login_extra ? "at ".$m->login_extra : '');
963}
964
965sub format_ping {
966  my $self = shift;
967  my $m = shift;
968  return sprintf(
969    BASE_FORMAT,
970    '<',
971    $m->type,
972    'PING',
973    $m->pretty_sender)
974}
975
976sub format_chat
977{
978  my $self = shift;
979  my $m = shift;
980  my $dir = lc($m->{direction});
981  my $dirsym = '-';
982  if ($dir eq 'in') {
983    $dirsym = '<';
984  }
985  elsif ($dir eq 'out') {
986    $dirsym = '>';
987  }
988
989  my $line;
990  if ($m->is_personal) {
991    $line= sprintf(BASE_FORMAT,
992                   $dirsym,
993                   $m->type,
994                   '',
995                   ($dir eq 'out'
996                    ? $m->pretty_recipient
997                    : $m->pretty_sender));
998  }
999  else {
1000    $line = sprintf(BASE_FORMAT,
1001                    $dirsym,
1002                    $m->context,
1003                    $m->subcontext,
1004                    ($dir eq 'out'
1005                     ? $m->pretty_recipient
1006                     : $m->pretty_sender));
1007  }
1008
1009  my $body = $m->{body};
1010  $body =~ tr/\n/ /;
1011  $line .= $body;
1012  return $line;
1013}
1014
1015# Format owl admin messages
1016sub format_admin
1017{
1018  my $self = shift;
1019  my $m = shift;
1020  my $line = sprintf(BASE_FORMAT, '<', 'ADMIN', '', '');
1021  my $body = $m->{body};
1022  $body =~ tr/\n/ /;
1023  return $line.$body;
1024}
1025
1026package BarnOwl::Style;
1027
1028# This takes a zephyr to be displayed and modifies it to be displayed
1029# entirely in bold.
1030sub boldify
1031{
1032    local $_ = shift;
1033    if ( !(/\)/) ) {
1034        return '@b(' . $_ . ')';
1035    } elsif ( !(/\>/) ) {
1036        return '@b<' . $_ . '>';
1037    } elsif ( !(/\}/) ) {
1038        return '@b{' . $_ . '}';
1039    } elsif ( !(/\]/) ) {
1040        return '@b[' . $_ . ']';
1041    } else {
1042        my $txt = "\@b($_";
1043        $txt =~ s/\)/\)\@b\[\)\]\@b\(/g;
1044        return $txt . ')';
1045    }
1046}
1047
1048sub style_command {
1049    my $command = shift;
1050    if(scalar @_ != 3 || $_[1] ne 'perl') {
1051        die("Usage: style <name> perl <function>\n");
1052    }
1053    my $name = shift;
1054    my $perl = shift;
1055    my $fn   = shift;
1056    {
1057        # For historical reasons, assume unqualified references are
1058        # in main::
1059        package main;
1060        no strict 'refs';
1061        unless(*{$fn}{CODE}) {
1062            die("Unable to create style '$name': no perl function '$fn'\n");
1063        }
1064    }
1065    BarnOwl::create_style($name, BarnOwl::Style::Legacy->new($fn));
1066}
1067
1068package BarnOwl::Style::Legacy;
1069
1070sub new {
1071    my $class = shift;
1072    my $func  = shift;
1073    my $desc  = shift;
1074    my $useglobals = shift;
1075    $useglobals = 0 unless defined($useglobals);
1076    return bless {function    => $func,
1077                  description => $desc,
1078                  useglobals  => $useglobals}, $class;
1079}
1080
1081sub description {
1082    my $self = shift;
1083    return $self->{description} ||
1084    ("User-defined perl style that calls " . $self->{function});
1085};
1086
1087sub format_message {
1088    my $self = shift;
1089    if($self->{useglobals}) {
1090        $_[0]->legacy_populate_global();
1091    }
1092    {
1093      package main;
1094      no strict 'refs';
1095      goto \&{$self->{function}};
1096    }
1097}
1098
1099
1100# switch to package main when we're done
1101package main;
1102
1103# Shove a bunch of fake entries into @INC so modules can use or
1104# require them without choking
1105$::INC{$_} = 1 for (qw(BarnOwl.pm BarnOwl/Hooks.pm
1106                       BarnOwl/Message.pm BarnOwl/Style.pm));
1107
11081;
1109
Note: See TracBrowser for help on using the repository browser.