source: perlwrap.pm @ ddacb9c

barnowl_perlaimdebianrelease-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since ddacb9c was b441079, checked in by Nelson Elhage <nelhage@mit.edu>, 17 years ago
Make the 'style' command assume the main:: package for unqualified subroutine references. Reported by Jesse Vincent.
  • Property mode set to 100644
File size: 26.6 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 queue_message MESSAGE
71
72Enqueue a message in the BarnOwl message list, logging it and
73processing it appropriately. C<MESSAGE> should be an instance of
74BarnOwl::Message or a subclass.
75
76=head2 admin_message HEADER BODY
77
78Display a BarnOwl B<Admin> message, with the given header and body.
79
80=head2 start_question PROMPT CALLBACK
81
82Displays C<PROMPT> on the screen and lets the user enter a line of
83text, and calls C<CALLBACK>, which must be a perl subroutine
84reference, with the text the user entered
85
86=head2 start_password PROMPT CALLBACK
87
88Like C<start_question>, but echoes the user's input as C<*>s when they
89input.
90
91=head2 start_edit_win PROMPT CALLBACK
92
93Like C<start_question>, but displays C<PROMPT> on a line of its own
94and opens the editwin. If the user cancels the edit win, C<CALLBACK>
95is not invoked.
96
97=head2 get_data_dir
98
99Returns the BarnOwl system data directory, where system libraries and
100modules are stored
101
102=head2 get_config_dir
103
104Returns the BarnOwl user configuration directory, where user modules
105and configuration are stored (by default, C<$HOME/.owl>)
106
107=head2 popless_text TEXT
108
109Show a popup window containing the given C<TEXT>
110
111=head2 popless_ztext TEXT
112
113Show a popup window containing the provided zephyr-formatted C<TEXT>
114
115=head2 error STRING
116
117Reports an error and log it in `show errors'. Note that in any
118callback or hook called in perl code from BarnOwl, a C<die> will be
119caught and passed to C<error>.
120
121=head2 getnumcolors
122
123Returns the number of colors this BarnOwl is capable of displaying
124
125=head2 add_dispatch FD CALLBACK
126
127Adds a file descriptor to C<BarnOwl>'s internal C<select()>
128loop. C<CALLBACK> will be invoked whenever data is available to be
129read from C<FD>.
130
131=head2 remove_dispatch FD
132
133Remove a file descriptor previously registered via C<add_dispatch>
134
135=head2 create_style NAME OBJECT
136
137Creates a new barnowl style with the given NAME defined by the given
138object. The object must have a C<description> method which returns a
139string description of the style, and a and C<format_message> method
140which accepts a C<BarnOwl::Message> object and returns a string that
141is the result of formatting the message for display.
142
143=cut
144
145
146BEGIN {
147# bootstrap in C bindings and glue
148    *owl:: = \*BarnOwl::;
149    bootstrap BarnOwl 1.2;
150};
151
152use lib(get_data_dir() . "/lib");
153use lib(get_config_dir() . "/lib");
154
155# perlconfig.c will set this to the value of the -c command-line
156# switch, if present.
157our $configfile;
158
159if(!$configfile && -f $ENV{HOME} . "/.barnowlconf") {
160    $configfile = $ENV{HOME} . "/.barnowlconf";
161}
162$configfile ||= $ENV{HOME}."/.owlconf";
163
164# populate global variable space for legacy owlconf files
165sub _receive_msg_legacy_wrap {
166    my ($m) = @_;
167    $m->legacy_populate_global();
168    return &BarnOwl::Hooks::_receive_msg($m);
169}
170
171=head2 AUTOLOAD
172
173BarnOwl.pm has a C<AUTOLOAD> method that translates unused names in
174the BarnOwl:: namespace to a call to BarnOwl::command() with that
175command. Underscores are also translated to C<->s, so you can do
176e.g. C<BarnOwl::start_command()> and it will be translated into
177C<start-command>.
178
179So, if you're looking for functionality that you can't find in the
180perl interface, check C<:show commands> or C<commands.c> in the
181BarnOwl source tree -- there's a good chance it exists as a BarnOwl
182command.
183
184=head3 BUGS
185
186There are horrible quoting issues here. The AUTOLOAD simple joins your
187commands with spaces and passes them unmodified to C<::command>
188
189=cut
190
191# make BarnOwl::<command>("foo") be aliases to BarnOwl::command("<command> foo");
192sub AUTOLOAD {
193    our $AUTOLOAD;
194    my $called = $AUTOLOAD;
195    $called =~ s/.*:://;
196    $called =~ s/_/-/g;
197    return &BarnOwl::command("$called ".join(" ",@_));
198}
199
200=head2 new_command NAME FUNC [{ARGS}]
201
202Add a new owl command. When owl executes the command NAME, FUNC will
203be called with the arguments passed to the command, with NAME as the
204first argument.
205
206ARGS should be a hashref containing any or all of C<summary>,
207C<usage>, or C<description> keys:
208
209=over 4
210
211=item summary
212
213A one-line summary of the purpose of the command
214
215=item usage
216
217A one-line usage synopsis, showing available options and syntax
218
219=item description
220
221A longer description of the syntax and semantics of the command,
222explaining usage and options
223
224=back
225
226=cut
227
228sub new_command {
229    my $name = shift;
230    my $func = shift;
231    my $args = shift || {};
232    my %args = (
233        summary     => "",
234        usage       => "",
235        description => "",
236        %{$args}
237    );
238
239    BarnOwl::new_command_internal($name, $func, $args{summary}, $args{usage}, $args{description});
240}
241
242=head2 new_variable_int NAME [{ARGS}]
243
244=head2 new_variable_bool NAME [{ARGS}]
245
246=head2 new_variable_string NAME [{ARGS}]
247
248Add a new owl variable, either an int, a bool, or a string, with the
249specified name.
250
251ARGS can optionally contain the following keys:
252
253=over 4
254
255=item default
256
257The default and initial value for the variable
258
259=item summary
260
261A one-line summary of the variable's purpose
262
263=item description
264
265A longer description of the function of the variable
266
267=back
268
269=cut
270
271sub new_variable_int {
272    unshift @_, \&BarnOwl::new_variable_int_internal, 0;
273    goto \&_new_variable;
274}
275
276sub new_variable_bool {
277    unshift @_, \&BarnOwl::new_variable_bool_internal, 0;
278    goto \&_new_variable;
279}
280
281sub new_variable_string {
282    unshift @_, \&BarnOwl::new_variable_string_internal, "";
283    goto \&_new_variable;
284}
285
286sub _new_variable {
287    my $func = shift;
288    my $default_default = shift;
289    my $name = shift;
290    my $args = shift || {};
291    my %args = (
292        summary     => "",
293        description => "",
294        default     => $default_default,
295        %{$args});
296    $func->($name, $args{default}, $args{summary}, $args{description});
297}
298
299#####################################################################
300#####################################################################
301
302package BarnOwl::Message;
303
304sub new {
305    my $class = shift;
306    my %args = (@_);
307    if($class eq __PACKAGE__ && $args{type}) {
308        $class = "BarnOwl::Message::" . ucfirst $args{type};
309    }
310    return bless {%args}, $class;
311}
312
313sub type        { return shift->{"type"}; }
314sub direction   { return shift->{"direction"}; }
315sub time        { return shift->{"time"}; }
316sub id          { return shift->{"id"}; }
317sub body        { return shift->{"body"}; }
318sub sender      { return shift->{"sender"}; }
319sub recipient   { return shift->{"recipient"}; }
320sub login       { return shift->{"login"}; }
321sub is_private  { return shift->{"private"}; }
322
323sub is_login    { return shift->login eq "login"; }
324sub is_logout   { return shift->login eq "logout"; }
325sub is_loginout { my $m=shift; return ($m->is_login or $m->is_logout); }
326sub is_incoming { return (shift->{"direction"} eq "in"); }
327sub is_outgoing { return (shift->{"direction"} eq "out"); }
328
329sub is_deleted  { return shift->{"deleted"}; }
330
331sub is_admin    { return (shift->{"type"} eq "admin"); }
332sub is_generic  { return (shift->{"type"} eq "generic"); }
333sub is_zephyr   { return (shift->{"type"} eq "zephyr"); }
334sub is_aim      { return (shift->{"type"} eq "AIM"); }
335sub is_jabber   { return (shift->{"type"} eq "jabber"); }
336sub is_icq      { return (shift->{"type"} eq "icq"); }
337sub is_yahoo    { return (shift->{"type"} eq "yahoo"); }
338sub is_msn      { return (shift->{"type"} eq "msn"); }
339sub is_loopback { return (shift->{"type"} eq "loopback"); }
340
341# These are overridden by appropriate message types
342sub is_ping     { return 0; }
343sub is_mail     { return 0; }
344sub is_personal { return shift->is_private; }
345sub class       { return undef; }
346sub instance    { return undef; }
347sub realm       { return undef; }
348sub opcode      { return undef; }
349sub header      { return undef; }
350sub host        { return undef; }
351sub hostname    { return undef; }
352sub auth        { return undef; }
353sub fields      { return undef; }
354sub zsig        { return undef; }
355sub zwriteline  { return undef; }
356sub login_host  { return undef; }
357sub login_tty   { return undef; }
358
359sub pretty_sender    { return shift->sender; }
360sub pretty_recipient { return shift->recipient; }
361
362sub delete {
363    my ($m) = @_;
364    &BarnOwl::command("delete --id ".$m->id);
365}
366
367sub undelete {
368    my ($m) = @_;
369    &BarnOwl::command("undelete --id ".$m->id);
370}
371
372# Serializes the message into something similar to the zwgc->vt format
373sub serialize {
374    my ($this) = @_;
375    my $s;
376    for my $f (keys %$this) {
377        my $val = $this->{$f};
378        if (ref($val) eq "ARRAY") {
379            for my $i (0..@$val-1) {
380                my $aval;
381                $aval = $val->[$i];
382                $aval =~ s/\n/\n$f.$i: /g;
383                $s .= "$f.$i: $aval\n";
384            }
385        } else {
386            $val =~ s/\n/\n$f: /g;
387            $s .= "$f: $val\n";
388        }
389    }
390    return $s;
391}
392
393# Populate the annoying legacy global variables
394sub legacy_populate_global {
395    my ($m) = @_;
396    $BarnOwl::direction  = $m->direction ;
397    $BarnOwl::type       = $m->type      ;
398    $BarnOwl::id         = $m->id        ;
399    $BarnOwl::class      = $m->class     ;
400    $BarnOwl::instance   = $m->instance  ;
401    $BarnOwl::recipient  = $m->recipient ;
402    $BarnOwl::sender     = $m->sender    ;
403    $BarnOwl::realm      = $m->realm     ;
404    $BarnOwl::opcode     = $m->opcode    ;
405    $BarnOwl::zsig       = $m->zsig      ;
406    $BarnOwl::msg        = $m->body      ;
407    $BarnOwl::time       = $m->time      ;
408    $BarnOwl::host       = $m->host      ;
409    $BarnOwl::login      = $m->login     ;
410    $BarnOwl::auth       = $m->auth      ;
411    if ($m->fields) {
412        @BarnOwl::fields = @{$m->fields};
413        @main::fields = @{$m->fields};
414    } else {
415        @BarnOwl::fields = undef;
416        @main::fields = undef;
417    }
418}
419
420sub smartfilter {
421    die("smartfilter not supported for this message\n");
422}
423
424# Display fields -- overridden by subclasses when needed
425sub login_type {""}
426sub login_extra {""}
427sub long_sender {""}
428
429# The context in which a non-personal message was sent, e.g. a chat or
430# class
431sub context {""}
432
433# Some indicator of context *within* $self->context. e.g. the zephyr
434# instance
435sub subcontext {""}
436
437#####################################################################
438#####################################################################
439
440package BarnOwl::Message::Admin;
441
442use base qw( BarnOwl::Message );
443
444sub header       { return shift->{"header"}; }
445
446#####################################################################
447#####################################################################
448
449package BarnOwl::Message::Generic;
450
451use base qw( BarnOwl::Message );
452
453#####################################################################
454#####################################################################
455
456package BarnOwl::Message::Loopback;
457
458use base qw( BarnOwl::Message );
459
460# all loopback messages are private
461sub is_private {
462  return 1;
463}
464
465#####################################################################
466#####################################################################
467
468package BarnOwl::Message::AIM;
469
470use base qw( BarnOwl::Message );
471
472# all non-loginout AIM messages are private for now...
473sub is_private {
474    return !(shift->is_loginout);
475}
476
477#####################################################################
478#####################################################################
479
480package BarnOwl::Message::Zephyr;
481
482use base qw( BarnOwl::Message );
483
484sub login_type {
485    return (shift->zsig eq "") ? "(PSEUDO)" : "";
486}
487
488sub login_extra {
489    my $m = shift;
490    return undef if (!$m->is_loginout);
491    my $s = lc($m->host);
492    $s .= " " . $m->login_tty if defined $m->login_tty;
493    return $s;
494}
495
496sub long_sender {
497    my $m = shift;
498    return $m->zsig;
499}
500
501sub context {
502    return shift->class;
503}
504
505sub subcontext {
506    return shift->instance;
507}
508
509sub login_tty {
510    my ($m) = @_;
511    return undef if (!$m->is_loginout);
512    return $m->fields->[2];
513}
514
515sub login_host {
516    my ($m) = @_;
517    return undef if (!$m->is_loginout);
518    return $m->fields->[0];
519}
520
521sub zwriteline  { return shift->{"zwriteline"}; }
522
523sub is_ping     { return (lc(shift->opcode) eq "ping"); }
524
525sub is_personal {
526    my ($m) = @_;
527    return ((lc($m->class) eq "message")
528            && (lc($m->instance) eq "personal")
529            && $m->is_private);
530}
531
532sub is_mail {
533    my ($m) = @_;
534    return ((lc($m->class) eq "mail") && $m->is_private);
535}
536
537sub pretty_sender {
538    my ($m) = @_;
539    my $sender = $m->sender;
540    my $realm = BarnOwl::zephyr_getrealm();
541    $sender =~ s/\@$realm$//;
542    return $sender;
543}
544
545sub pretty_recipient {
546    my ($m) = @_;
547    my $recip = $m->recipient;
548    my $realm = BarnOwl::zephyr_getrealm();
549    $recip =~ s/\@$realm$//;
550    return $recip;
551}
552
553# These are arguably zephyr-specific
554sub class       { return shift->{"class"}; }
555sub instance    { return shift->{"instance"}; }
556sub realm       { return shift->{"realm"}; }
557sub opcode      { return shift->{"opcode"}; }
558sub host        { return shift->{"hostname"}; }
559sub hostname    { return shift->{"hostname"}; }
560sub header      { return shift->{"header"}; }
561sub auth        { return shift->{"auth"}; }
562sub fields      { return shift->{"fields"}; }
563sub zsig        { return shift->{"zsig"}; }
564
565#####################################################################
566#####################################################################
567################################################################################
568
569package BarnOwl::Hook;
570
571=head1 BarnOwl::Hook
572
573=head1 DESCRIPTION
574
575A C<BarnOwl::Hook> represents a list of functions to be triggered on
576some event. C<BarnOwl> exports a default set of these (see
577C<BarnOwl::Hooks>), but can also be created and used by module code.
578
579=head2 new
580
581Creates a new Hook object
582
583=cut
584
585sub new {
586    my $class = shift;
587    return bless [], $class;
588}
589
590=head2 run [ARGS]
591
592Calls each of the functions registered with this hook with the given
593arguments.
594
595=cut
596
597sub run {
598    my $self = shift;
599    my @args = @_;
600    return map {$_->(@args)} @$self;
601}
602
603=head2 add SUBREF
604
605Registers a given subroutine with this hook
606
607=cut
608
609sub add {
610    my $self = shift;
611    my $func = shift;
612    die("Not a coderef!") unless ref($func) eq 'CODE';
613    push @$self, $func;
614}
615
616=head2 clear
617
618Remove all functions registered with this hook.
619
620=cut
621
622sub clear {
623    my $self = shift;
624    @$self = ();
625}
626
627package BarnOwl::Hooks;
628
629=head1 BarnOwl::Hooks
630
631=head1 DESCRIPTION
632
633C<BarnOwl::Hooks> exports a set of C<BarnOwl::Hook> objects made
634available by BarnOwl internally.
635
636=head2 USAGE
637
638Modules wishing to respond to events in BarnOwl should register
639functions with these hooks.
640
641=head2 EXPORTS
642
643None by default. Either import the hooks you need explicitly, or refer
644to them with fully-qualified names. Available hooks are:
645
646=over 4
647
648=item $startup
649
650Called on BarnOwl startup, and whenever modules are
651reloaded. Functions registered with the C<$startup> hook get a true
652argument if this is a reload, and false if this is a true startup
653
654=item $shutdown
655
656Called before BarnOwl shutdown
657
658=item $receiveMessage
659
660Called with a C<BarnOwl::Message> object every time BarnOwl appends a
661new message to its message list
662
663=item $mainLoop
664
665Called on every pass through the C<BarnOwl> main loop. This is
666guaranteed to be called at least once/sec and may be called more
667frequently.
668
669=item $getBuddyList
670
671Called to display buddy lists for all protocol handlers. The result
672from every function registered with this hook will be appended and
673displayed in a popup window, with zephyr formatting parsed.
674
675=back
676
677=cut
678
679use Exporter;
680
681our @EXPORT_OK = qw($startup $shutdown
682                    $receiveMessage $mainLoop
683                    $getBuddyList);
684
685our %EXPORT_TAGS = (all => [@EXPORT_OK]);
686
687our $startup = BarnOwl::Hook->new;
688our $shutdown = BarnOwl::Hook->new;
689our $receiveMessage = BarnOwl::Hook->new;
690our $mainLoop = BarnOwl::Hook->new;
691our $getBuddyList = BarnOwl::Hook->new;
692
693# Internal startup/shutdown routines called by the C code
694
695sub _load_perl_commands {
696    # Load builtin perl commands
697    BarnOwl::new_command(style => \&BarnOwl::Style::style_command,
698                       {
699                           summary => "creates a new style",
700                           usage   => "style <name> perl <function_name>",
701                           description =>
702                           "A style named <name> will be created that will\n" .
703                           "format messages using the perl function <function_name>.\n\n" .
704                           "SEE ALSO: show styles, view -s, filter -s\n\n" .
705                           "DEPRECATED in favor of BarnOwl::create_style(NAME, OBJECT)",
706                          });
707}
708
709sub _load_owlconf {
710    # load the config  file
711    if ( -r $BarnOwl::configfile ) {
712        undef $@;
713        package main;
714        do $BarnOwl::configfile;
715        die $@ if $@;
716        package BarnOwl;
717        if(*BarnOwl::format_msg{CODE}) {
718            # if the config defines a legacy formatting function, add 'perl' as a style
719            BarnOwl::create_style("perl", BarnOwl::Style::Legacy->new(
720                "BarnOwl::format_msg",
721                "User-defined perl style that calls BarnOwl::format_msg"
722                . " with legacy global variable support",
723                1));
724             BarnOwl::set("-q default_style perl");
725        }
726    }
727}
728
729# These are the internal hooks called by the barnowl C code, which
730# take care of dispatching to the appropriate perl hooks, and deal
731# with compatibility by calling the old, fixed-name hooks.
732
733sub _startup {
734    _load_perl_commands();
735    _load_owlconf();
736
737    if(eval {require BarnOwl::ModuleLoader}) {
738        eval {
739            BarnOwl::ModuleLoader->load_all;
740        };
741        BarnOwl::error("$@") if $@;
742
743    } else {
744        BarnOwl::error("Can't load BarnOwl::ModuleLoader, loadable module support disabled:\n$@");
745    }
746   
747    $startup->run(0);
748    BarnOwl::startup() if *BarnOwl::startup{CODE};
749}
750
751sub _shutdown {
752    $shutdown->run;
753   
754    BarnOwl::shutdown() if *BarnOwl::shutdown{CODE};
755}
756
757sub _receive_msg {
758    my $m = shift;
759
760    $receiveMessage->run($m);
761   
762    BarnOwl::receive_msg($m) if *BarnOwl::receive_msg{CODE};
763}
764
765sub _mainloop_hook {
766    $mainLoop->run;
767    BarnOwl::mainloop_hook() if *BarnOwl::mainloop_hook{CODE};
768}
769
770sub _get_blist {
771    return join("\n", $getBuddyList->run);
772}
773
774################################################################################
775# Built-in perl styles
776################################################################################
777package BarnOwl::Style::Default;
778################################################################################
779# Branching point for various formatting functions in this style.
780################################################################################
781sub format_message
782{
783    my $self = shift;
784    my $m    = shift;
785    my $fmt;
786
787    if ( $m->is_loginout) {
788        $fmt = $self->format_login($m);
789    } elsif($m->is_ping && $m->is_personal) {
790        $fmt = $self->format_ping($m);
791    } elsif($m->is_admin) {
792        $fmt = $self->format_admin($m);
793    } else {
794        $fmt = $self->format_chat($m);
795    }
796    $fmt = BarnOwl::Style::boldify($fmt) if $self->should_bold($m);
797    return $fmt;
798}
799
800sub should_bold {
801    my $self = shift;
802    my $m = shift;
803    return $m->is_personal && $m->direction eq "in";
804}
805
806sub description {"Default style";}
807
808BarnOwl::create_style("default", "BarnOwl::Style::Default");
809
810################################################################################
811
812sub format_time {
813    my $self = shift;
814    my $m = shift;
815    my ($time) = $m->time =~ /(\d\d:\d\d)/;
816    return $time;
817}
818
819sub format_login {
820    my $self = shift;
821    my $m = shift;
822    return sprintf(
823        '@b<%s%s> for @b(%s) (%s) %s',
824        uc( $m->login ),
825        $m->login_type,
826        $m->pretty_sender,
827        $m->login_extra,
828        $self->format_time($m)
829       );
830}
831
832sub format_ping {
833    my $self = shift;
834    my $m = shift;
835    return "\@b(PING) from \@b(" . $m->pretty_sender . ")";
836}
837
838sub format_admin {
839    my $self = shift;
840    my $m = shift;
841    return "\@bold(OWL ADMIN)\n" . $self->indent_body($m);
842}
843
844sub format_chat {
845    my $self = shift;
846    my $m = shift;
847    my $header = $self->chat_header($m);
848    return $header . "\n". $self->indent_body($m);
849}
850
851sub chat_header {
852    my $self = shift;
853    my $m = shift;
854    my $header;
855    if ( $m->is_personal ) {
856        if ( $m->direction eq "out" ) {
857            $header = ucfirst $m->type . " sent to " . $m->pretty_recipient;
858        } else {
859            $header = ucfirst $m->type . " from " . $m->pretty_sender;
860        }
861    } else {
862        $header = $m->context;
863        if(defined $m->subcontext) {
864            $header .= ' / ' . $m->subcontext;
865        }
866        $header .= ' / @b{' . $m->pretty_sender . '}';
867    }
868
869    if($m->opcode) {
870        $header .= " [" . $m->opcode . "]";
871    }
872    $header .= "  " . $self->format_time($m);
873    $header .= $self->format_sender($m);
874    return $header;
875}
876
877sub format_sender {
878    my $self = shift;
879    my $m = shift;
880    my $sender = $m->long_sender;
881    $sender =~ s/\n.*$//s;
882    return "  (" . $sender . '@color[default]' . ")";
883}
884
885sub indent_body
886{
887    my $self = shift;
888    my $m = shift;
889
890    my $body = $m->body;
891    if ($m->{should_wordwrap}) {
892      $body = BarnOwl::wordwrap($body, BarnOwl::getnumcols()-8);
893    }
894    # replace newline followed by anything with
895    # newline plus four spaces and that thing.
896    $body =~ s/\n(.)/\n    $1/g;
897    # Trim trailing newlines.
898    $body =~ s/\n*$//;
899    return "    ".$body;
900}
901
902package BarnOwl::Style::Basic;
903our @ISA=qw(BarnOwl::Style::Default);
904
905sub description {"Compatability alias for the default style";}
906
907BarnOwl::create_style("basic", "BarnOwl::Style::Basic");
908
909package BarnOwl::Style::OneLine;
910# Inherit format_message to dispatch
911our @ISA = qw(BarnOwl::Style::Default);
912
913use constant BASE_FORMAT => '%s %-13.13s %-11.11s %-12.12s ';
914
915sub description {"Formats for one-line-per-message"}
916
917BarnOwl::create_style("oneline", "BarnOwl::Style::OneLine");
918
919################################################################################
920
921sub format_login {
922  my $self = shift;
923  my $m = shift;
924  return sprintf(
925    BASE_FORMAT,
926    '<',
927    $m->type,
928    uc( $m->login ),
929    $m->pretty_sender)
930    . ($m->login_extra ? "at ".$m->login_extra : '');
931}
932
933sub format_ping {
934  my $self = shift;
935  my $m = shift;
936  return sprintf(
937    BASE_FORMAT,
938    '<',
939    $m->type,
940    'PING',
941    $m->pretty_sender)
942}
943
944sub format_chat
945{
946  my $self = shift;
947  my $m = shift;
948  my $dir = lc($m->{direction});
949  my $dirsym = '-';
950  if ($dir eq 'in') {
951    $dirsym = '<';
952  }
953  elsif ($dir eq 'out') {
954    $dirsym = '>';
955  }
956
957  my $line;
958  if ($m->is_personal) {
959    $line= sprintf(BASE_FORMAT,
960                   $dirsym,
961                   $m->type,
962                   '',
963                   ($dir eq 'out'
964                    ? $m->pretty_recipient
965                    : $m->pretty_sender));
966  }
967  else {
968    $line = sprintf(BASE_FORMAT,
969                    $dirsym,
970                    $m->context,
971                    $m->subcontext,
972                    ($dir eq 'out'
973                     ? $m->pretty_recipient
974                     : $m->pretty_sender));
975  }
976
977  my $body = $m->{body};
978  $body =~ tr/\n/ /;
979  $line .= $body;
980  return $line;
981}
982
983# Format owl admin messages
984sub format_admin
985{
986  my $self = shift;
987  my $m = shift;
988  my $line = sprintf(BASE_FORMAT, '<', 'ADMIN', '', '');
989  my $body = $m->{body};
990  $body =~ tr/\n/ /;
991  return $line.$body;
992}
993
994package BarnOwl::Style;
995
996# This takes a zephyr to be displayed and modifies it to be displayed
997# entirely in bold.
998sub boldify
999{
1000    local $_ = shift;
1001    if ( !(/\)/) ) {
1002        return '@b(' . $_ . ')';
1003    } elsif ( !(/\>/) ) {
1004        return '@b<' . $_ . '>';
1005    } elsif ( !(/\}/) ) {
1006        return '@b{' . $_ . '}';
1007    } elsif ( !(/\]/) ) {
1008        return '@b[' . $_ . ']';
1009    } else {
1010        my $txt = "\@b($_";
1011        $txt =~ s/\)/\)\@b\[\)\]\@b\(/g;
1012        return $txt . ')';
1013    }
1014}
1015
1016sub style_command {
1017    my $command = shift;
1018    if(scalar @_ != 3 || $_[1] ne 'perl') {
1019        die("Usage: style <name> perl <function>\n");
1020    }
1021    my $name = shift;
1022    my $perl = shift;
1023    my $fn   = shift;
1024    {
1025        # For historical reasons, assume unqualified references are
1026        # in main::
1027        package main;
1028        no strict 'refs';
1029        unless(*{$fn}{CODE}) {
1030            die("Unable to create style '$name': no perl function '$fn'\n");
1031        }
1032    }
1033    BarnOwl::create_style($name, BarnOwl::Style::Legacy->new($fn));
1034}
1035
1036package BarnOwl::Style::Legacy;
1037
1038sub new {
1039    my $class = shift;
1040    my $func  = shift;
1041    my $desc  = shift;
1042    my $useglobals = shift;
1043    $useglobals = 0 unless defined($useglobals);
1044    return bless {function    => $func,
1045                  description => $desc,
1046                  useglobals  => $useglobals}, $class;
1047}
1048
1049sub description {
1050    my $self = shift;
1051    return $self->{description} ||
1052    ("User-defined perl style that calls " . $self->{function});
1053};
1054
1055sub format_message {
1056    my $self = shift;
1057    if($self->{useglobals}) {
1058        $_[0]->legacy_populate_global();
1059    }
1060    {
1061      package main;
1062      no strict 'refs';
1063      goto \&{$self->{function}};
1064    }
1065}
1066
1067
1068# switch to package main when we're done
1069package main;
1070
1071# Shove a bunch of fake entries into @INC so modules can use or
1072# require them without choking
1073$::INC{$_} = 1 for (qw(BarnOwl.pm BarnOwl/Hooks.pm
1074                       BarnOwl/Message.pm BarnOwl/Style.pm));
1075
10761;
1077
Note: See TracBrowser for help on using the repository browser.