source: perlwrap.pm @ feabce2

barnowl_perlaimdebianrelease-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since feabce2 was 0eaa488, checked in by Nelson Elhage <nelhage@mit.edu>, 16 years ago
Document create_style
  • Property mode set to 100644
File size: 26.4 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 time_hhmm {
813    my $m = shift;
814    my ($time) = $m->time =~ /(\d\d:\d\d)/;
815    return $time;
816}
817
818sub format_login($) {
819    my $self = shift;
820    my $m = shift;
821    return sprintf(
822        '@b<%s%s> for @b(%s) (%s) %s',
823        uc( $m->login ),
824        $m->login_type,
825        $m->pretty_sender,
826        $m->login_extra,
827        time_hhmm($m)
828       );
829}
830
831sub format_ping {
832    my $self = shift;
833    my $m = shift;
834    return "\@b(PING) from \@b(" . $m->pretty_sender . ")";
835}
836
837sub format_admin {
838    my $self = shift;
839    my $m = shift;
840    return "\@bold(OWL ADMIN)\n" . $self->indent_body($m);
841}
842
843sub format_chat($) {
844    my $self = shift;
845    my $m = shift;
846    my $header = $self->chat_header($m);
847    return $header . "\n". $self->indent_body($m);
848}
849
850sub chat_header {
851    my $self = shift;
852    my $m = shift;
853    my $header;
854    if ( $m->is_personal ) {
855        if ( $m->direction eq "out" ) {
856            $header = ucfirst $m->type . " sent to " . $m->pretty_recipient;
857        } else {
858            $header = ucfirst $m->type . " from " . $m->pretty_sender;
859        }
860    } else {
861        $header = $m->context;
862        if(defined $m->subcontext) {
863            $header .= ' / ' . $m->subcontext;
864        }
865        $header .= ' / @b{' . $m->pretty_sender . '}';
866    }
867
868    if($m->opcode) {
869        $header .= " [" . $m->opcode . "]";
870    }
871    $header .= "  " . time_hhmm($m);
872    $header .= $self->format_sender($m);
873    return $header;
874}
875
876sub format_sender {
877    my $self = shift;
878    my $m = shift;
879    my $sender = $m->long_sender;
880    $sender =~ s/\n.*$//s;
881    return "  (" . $sender . '@color[default]' . ")";
882}
883
884sub indent_body($)
885{
886    my $self = shift;
887    my $m = shift;
888
889    my $body = $m->body;
890    if ($m->{should_wordwrap}) {
891      $body = BarnOwl::wordwrap($body, BarnOwl::getnumcols()-8);
892    }
893    # replace newline followed by anything with
894    # newline plus four spaces and that thing.
895    $body =~ s/\n(.)/\n    $1/g;
896    # Trim trailing newlines.
897    $body =~ s/\n*$//;
898    return "    ".$body;
899}
900
901package BarnOwl::Style::Basic;
902our @ISA=qw(BarnOwl::Style::Default);
903
904sub description {"Compatability alias for the default style";}
905
906BarnOwl::create_style("basic", "BarnOwl::Style::Basic");
907
908package BarnOwl::Style::OneLine;
909# Inherit format_message to dispatch
910our @ISA = qw(BarnOwl::Style::Default);
911
912use constant BASE_FORMAT => '%s %-13.13s %-11.11s %-12.12s ';
913
914sub description {"Formats for one-line-per-message"}
915
916BarnOwl::create_style("oneline", "BarnOwl::Style::OneLine");
917
918################################################################################
919
920sub format_login($) {
921  my $self = shift;
922  my $m = shift;
923  return sprintf(
924    BASE_FORMAT,
925    '<',
926    $m->type,
927    uc( $m->login ),
928    $m->pretty_sender)
929    . ($m->login_extra ? "at ".$m->login_extra : '');
930}
931
932sub format_ping($) {
933  my $self = shift;
934  my $m = shift;
935  return sprintf(
936    BASE_FORMAT,
937    '<',
938    $m->type,
939    'PING',
940    $m->pretty_sender)
941}
942
943sub format_chat($)
944{
945  my $self = shift;
946  my $m = shift;
947  my $dir = lc($m->{direction});
948  my $dirsym = '-';
949  if ($dir eq 'in') {
950    $dirsym = '<';
951  }
952  elsif ($dir eq 'out') {
953    $dirsym = '>';
954  }
955
956  my $line;
957  if ($m->is_personal) {
958    $line= sprintf(BASE_FORMAT,
959                   $dirsym,
960                   $m->type,
961                   '',
962                   ($dir eq 'out'
963                    ? $m->pretty_recipient
964                    : $m->pretty_sender));
965  }
966  else {
967    $line = sprintf(BASE_FORMAT,
968                    $dirsym,
969                    $m->context,
970                    $m->subcontext,
971                    ($dir eq 'out'
972                     ? $m->pretty_recipient
973                     : $m->pretty_sender));
974  }
975
976  my $body = $m->{body};
977  $body =~ tr/\n/ /;
978  $line .= $body;
979  return $line;
980}
981
982# Format owl admin messages
983sub format_admin($)
984{
985  my $self = shift;
986  my $m = shift;
987  my $line = sprintf(BASE_FORMAT, '<', 'ADMIN', '', '');
988  my $body = $m->{body};
989  $body =~ tr/\n/ /;
990  return $line.$body;
991}
992
993package BarnOwl::Style;
994
995# This takes a zephyr to be displayed and modifies it to be displayed
996# entirely in bold.
997sub boldify($)
998{
999    local $_ = shift;
1000    if ( !(/\)/) ) {
1001        return '@b(' . $_ . ')';
1002    } elsif ( !(/\>/) ) {
1003        return '@b<' . $_ . '>';
1004    } elsif ( !(/\}/) ) {
1005        return '@b{' . $_ . '}';
1006    } elsif ( !(/\]/) ) {
1007        return '@b[' . $_ . ']';
1008    } else {
1009        my $txt = "\@b($_";
1010        $txt =~ s/\)/\)\@b\[\)\]\@b\(/g;
1011        return $txt . ')';
1012    }
1013}
1014
1015sub style_command {
1016    my $command = shift;
1017    if(scalar @_ != 3 || $_[1] ne 'perl') {
1018        die("Usage: style <name> perl <function>\n");
1019    }
1020    my $name = shift;
1021    my $perl = shift;
1022    my $fn   = shift;
1023    {
1024        no strict 'refs';
1025        unless(*{$fn}{CODE}) {
1026            die("Unable to create style '$name': no perl function '$fn'\n");
1027        }
1028    }
1029    BarnOwl::create_style($name, BarnOwl::Style::Legacy->new($fn));
1030}
1031
1032package BarnOwl::Style::Legacy;
1033
1034sub new {
1035    my $class = shift;
1036    my $func  = shift;
1037    my $desc  = shift;
1038    my $useglobals = shift;
1039    $useglobals = 0 unless defined($useglobals);
1040    return bless {function    => $func,
1041                  description => $desc,
1042                  useglobals  => $useglobals}, $class;
1043}
1044
1045sub description {
1046    my $self = shift;
1047    return $self->{description} ||
1048    ("User-defined perl style that calls " . $self->{function});
1049};
1050
1051sub format_message {
1052    my $self = shift;
1053    if($self->{useglobals}) {
1054        $_[0]->legacy_populate_global();
1055    }
1056    no strict 'refs';
1057    goto \&{$self->{function}};
1058}
1059
1060
1061# switch to package main when we're done
1062package main;
1063
1064# Shove a bunch of fake entries into @INC so modules can use or
1065# require them without choking
1066$::INC{$_} = 1 for (qw(BarnOwl.pm BarnOwl/Hooks.pm
1067                       BarnOwl/Message.pm BarnOwl/Style.pm));
1068
10691;
1070
Note: See TracBrowser for help on using the repository browser.