source: perlwrap.pm @ 864ed35

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