source: perlwrap.pm @ fa1b15b

debianrelease-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since fa1b15b was e2257be, checked in by Nelson Elhage <nelhage@mit.edu>, 12 years ago
perlwrap.pm: Don't fail to load modules because .owlconf died This is not jesse's bug, but I noticed while looking for his.
  • 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        if($@) {
716            BarnOwl::error("In startup: $@\n");
717            return;
718        }
719        package BarnOwl;
720        if(*BarnOwl::format_msg{CODE}) {
721            # if the config defines a legacy formatting function, add 'perl' as a style
722            BarnOwl::create_style("perl", BarnOwl::Style::Legacy->new(
723                "BarnOwl::format_msg",
724                "User-defined perl style that calls BarnOwl::format_msg"
725                . " with legacy global variable support",
726                1));
727             BarnOwl::set("-q default_style perl");
728        }
729    }
730}
731
732# These are the internal hooks called by the barnowl C code, which
733# take care of dispatching to the appropriate perl hooks, and deal
734# with compatibility by calling the old, fixed-name hooks.
735
736sub _startup {
737    _load_perl_commands();
738    _load_owlconf();
739
740    if(eval {require BarnOwl::ModuleLoader}) {
741        eval {
742            BarnOwl::ModuleLoader->load_all;
743        };
744        BarnOwl::error("$@") if $@;
745
746    } else {
747        BarnOwl::error("Can't load BarnOwl::ModuleLoader, loadable module support disabled:\n$@");
748    }
749   
750    $startup->run(0);
751    BarnOwl::startup() if *BarnOwl::startup{CODE};
752}
753
754sub _shutdown {
755    $shutdown->run;
756   
757    BarnOwl::shutdown() if *BarnOwl::shutdown{CODE};
758}
759
760sub _receive_msg {
761    my $m = shift;
762
763    $receiveMessage->run($m);
764   
765    BarnOwl::receive_msg($m) if *BarnOwl::receive_msg{CODE};
766}
767
768sub _mainloop_hook {
769    $mainLoop->run;
770    BarnOwl::mainloop_hook() if *BarnOwl::mainloop_hook{CODE};
771}
772
773sub _get_blist {
774    return join("\n", $getBuddyList->run);
775}
776
777################################################################################
778# Built-in perl styles
779################################################################################
780package BarnOwl::Style::Default;
781################################################################################
782# Branching point for various formatting functions in this style.
783################################################################################
784sub format_message
785{
786    my $self = shift;
787    my $m    = shift;
788    my $fmt;
789
790    if ( $m->is_loginout) {
791        $fmt = $self->format_login($m);
792    } elsif($m->is_ping && $m->is_personal) {
793        $fmt = $self->format_ping($m);
794    } elsif($m->is_admin) {
795        $fmt = $self->format_admin($m);
796    } else {
797        $fmt = $self->format_chat($m);
798    }
799    $fmt = BarnOwl::Style::boldify($fmt) if $self->should_bold($m);
800    return $fmt;
801}
802
803sub should_bold {
804    my $self = shift;
805    my $m = shift;
806    return $m->is_personal && $m->direction eq "in";
807}
808
809sub description {"Default style";}
810
811BarnOwl::create_style("default", "BarnOwl::Style::Default");
812
813################################################################################
814
815sub format_time {
816    my $self = shift;
817    my $m = shift;
818    my ($time) = $m->time =~ /(\d\d:\d\d)/;
819    return $time;
820}
821
822sub format_login {
823    my $self = shift;
824    my $m = shift;
825    return sprintf(
826        '@b<%s%s> for @b(%s) (%s) %s',
827        uc( $m->login ),
828        $m->login_type,
829        $m->pretty_sender,
830        $m->login_extra,
831        $self->format_time($m)
832       );
833}
834
835sub format_ping {
836    my $self = shift;
837    my $m = shift;
838    return "\@b(PING) from \@b(" . $m->pretty_sender . ")";
839}
840
841sub format_admin {
842    my $self = shift;
843    my $m = shift;
844    return "\@bold(OWL ADMIN)\n" . $self->indent_body($m);
845}
846
847sub format_chat {
848    my $self = shift;
849    my $m = shift;
850    my $header = $self->chat_header($m);
851    return $header . "\n". $self->indent_body($m);
852}
853
854sub chat_header {
855    my $self = shift;
856    my $m = shift;
857    my $header;
858    if ( $m->is_personal ) {
859        if ( $m->direction eq "out" ) {
860            $header = ucfirst $m->type . " sent to " . $m->pretty_recipient;
861        } else {
862            $header = ucfirst $m->type . " from " . $m->pretty_sender;
863        }
864    } else {
865        $header = $m->context;
866        if(defined $m->subcontext) {
867            $header .= ' / ' . $m->subcontext;
868        }
869        $header .= ' / @b{' . $m->pretty_sender . '}';
870    }
871
872    if($m->opcode) {
873        $header .= " [" . $m->opcode . "]";
874    }
875    $header .= "  " . $self->format_time($m);
876    $header .= $self->format_sender($m);
877    return $header;
878}
879
880sub format_sender {
881    my $self = shift;
882    my $m = shift;
883    my $sender = $m->long_sender;
884    $sender =~ s/\n.*$//s;
885    return "  (" . $sender . '@color[default]' . ")";
886}
887
888sub indent_body
889{
890    my $self = shift;
891    my $m = shift;
892
893    my $body = $m->body;
894    if ($m->{should_wordwrap}) {
895      $body = BarnOwl::wordwrap($body, BarnOwl::getnumcols()-8);
896    }
897    # replace newline followed by anything with
898    # newline plus four spaces and that thing.
899    $body =~ s/\n(.)/\n    $1/g;
900    # Trim trailing newlines.
901    $body =~ s/\n*$//;
902    return "    ".$body;
903}
904
905package BarnOwl::Style::Basic;
906our @ISA=qw(BarnOwl::Style::Default);
907
908sub description {"Compatability alias for the default style";}
909
910BarnOwl::create_style("basic", "BarnOwl::Style::Basic");
911
912package BarnOwl::Style::OneLine;
913# Inherit format_message to dispatch
914our @ISA = qw(BarnOwl::Style::Default);
915
916use constant BASE_FORMAT => '%s %-13.13s %-11.11s %-12.12s ';
917
918sub description {"Formats for one-line-per-message"}
919
920BarnOwl::create_style("oneline", "BarnOwl::Style::OneLine");
921
922################################################################################
923
924sub format_login {
925  my $self = shift;
926  my $m = shift;
927  return sprintf(
928    BASE_FORMAT,
929    '<',
930    $m->type,
931    uc( $m->login ),
932    $m->pretty_sender)
933    . ($m->login_extra ? "at ".$m->login_extra : '');
934}
935
936sub format_ping {
937  my $self = shift;
938  my $m = shift;
939  return sprintf(
940    BASE_FORMAT,
941    '<',
942    $m->type,
943    'PING',
944    $m->pretty_sender)
945}
946
947sub format_chat
948{
949  my $self = shift;
950  my $m = shift;
951  my $dir = lc($m->{direction});
952  my $dirsym = '-';
953  if ($dir eq 'in') {
954    $dirsym = '<';
955  }
956  elsif ($dir eq 'out') {
957    $dirsym = '>';
958  }
959
960  my $line;
961  if ($m->is_personal) {
962    $line= sprintf(BASE_FORMAT,
963                   $dirsym,
964                   $m->type,
965                   '',
966                   ($dir eq 'out'
967                    ? $m->pretty_recipient
968                    : $m->pretty_sender));
969  }
970  else {
971    $line = sprintf(BASE_FORMAT,
972                    $dirsym,
973                    $m->context,
974                    $m->subcontext,
975                    ($dir eq 'out'
976                     ? $m->pretty_recipient
977                     : $m->pretty_sender));
978  }
979
980  my $body = $m->{body};
981  $body =~ tr/\n/ /;
982  $line .= $body;
983  return $line;
984}
985
986# Format owl admin messages
987sub format_admin
988{
989  my $self = shift;
990  my $m = shift;
991  my $line = sprintf(BASE_FORMAT, '<', 'ADMIN', '', '');
992  my $body = $m->{body};
993  $body =~ tr/\n/ /;
994  return $line.$body;
995}
996
997package BarnOwl::Style;
998
999# This takes a zephyr to be displayed and modifies it to be displayed
1000# entirely in bold.
1001sub boldify
1002{
1003    local $_ = shift;
1004    if ( !(/\)/) ) {
1005        return '@b(' . $_ . ')';
1006    } elsif ( !(/\>/) ) {
1007        return '@b<' . $_ . '>';
1008    } elsif ( !(/\}/) ) {
1009        return '@b{' . $_ . '}';
1010    } elsif ( !(/\]/) ) {
1011        return '@b[' . $_ . ']';
1012    } else {
1013        my $txt = "\@b($_";
1014        $txt =~ s/\)/\)\@b\[\)\]\@b\(/g;
1015        return $txt . ')';
1016    }
1017}
1018
1019sub style_command {
1020    my $command = shift;
1021    if(scalar @_ != 3 || $_[1] ne 'perl') {
1022        die("Usage: style <name> perl <function>\n");
1023    }
1024    my $name = shift;
1025    my $perl = shift;
1026    my $fn   = shift;
1027    {
1028        # For historical reasons, assume unqualified references are
1029        # in main::
1030        package main;
1031        no strict 'refs';
1032        unless(*{$fn}{CODE}) {
1033            die("Unable to create style '$name': no perl function '$fn'\n");
1034        }
1035    }
1036    BarnOwl::create_style($name, BarnOwl::Style::Legacy->new($fn));
1037}
1038
1039package BarnOwl::Style::Legacy;
1040
1041sub new {
1042    my $class = shift;
1043    my $func  = shift;
1044    my $desc  = shift;
1045    my $useglobals = shift;
1046    $useglobals = 0 unless defined($useglobals);
1047    return bless {function    => $func,
1048                  description => $desc,
1049                  useglobals  => $useglobals}, $class;
1050}
1051
1052sub description {
1053    my $self = shift;
1054    return $self->{description} ||
1055    ("User-defined perl style that calls " . $self->{function});
1056};
1057
1058sub format_message {
1059    my $self = shift;
1060    if($self->{useglobals}) {
1061        $_[0]->legacy_populate_global();
1062    }
1063    {
1064      package main;
1065      no strict 'refs';
1066      goto \&{$self->{function}};
1067    }
1068}
1069
1070
1071# switch to package main when we're done
1072package main;
1073
1074# Shove a bunch of fake entries into @INC so modules can use or
1075# require them without choking
1076$::INC{$_} = 1 for (qw(BarnOwl.pm BarnOwl/Hooks.pm
1077                       BarnOwl/Message.pm BarnOwl/Style.pm));
1078
10791;
1080
Note: See TracBrowser for help on using the repository browser.