source: perlwrap.pm @ c0c4449c

barnowl_perlaimdebianrelease-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since c0c4449c was 9815e2e, checked in by Nelson Elhage <nelhage@mit.edu>, 16 years ago
Typo fix in docs
  • Property mode set to 100644
File size: 24.1 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 $m = shift;
766
767    if ( $m->is_loginout) {
768        return format_login($m);
769    } elsif($m->is_ping && $m->is_personal) {
770        return ( "\@b(PING) from \@b(" . $m->pretty_sender . ")\n" );
771    } elsif($m->is_admin) {
772        return "\@bold(OWL ADMIN)\n" . indentBody($m);
773    } else {
774        return format_chat($m);
775    }
776}
777
778BarnOwl::_create_style("default", "BarnOwl::Style::Default::format_message", "Default style");
779
780################################################################################
781
782sub time_hhmm {
783    my $m = shift;
784    my ($time) = $m->time =~ /(\d\d:\d\d)/;
785    return $time;
786}
787
788sub format_login($) {
789    my $m = shift;
790    return sprintf(
791        '@b<%s%s> for @b(%s) (%s) %s',
792        uc( $m->login ),
793        $m->login_type,
794        $m->pretty_sender,
795        $m->login_extra,
796        time_hhmm($m)
797       );
798}
799
800sub format_chat($) {
801    my $m = shift;
802    my $header;
803    if ( $m->is_personal ) {
804        if ( $m->direction eq "out" ) {
805            $header = ucfirst $m->type . " sent to " . $m->pretty_recipient;
806        } else {
807            $header = ucfirst $m->type . " from " . $m->pretty_sender;
808        }
809    } else {
810        $header = $m->context;
811        if(defined $m->subcontext) {
812            $header .= ' / ' . $m->subcontext;
813        }
814        $header .= ' / @b{' . $m->pretty_sender . '}';
815    }
816
817    if($m->opcode) {
818        $header .= " [" . $m->opcode . "]";
819    }
820    $header .= "  " . time_hhmm($m);
821    my $sender = $m->long_sender;
822    $sender =~ s/\n.*$//s;
823    $header .= " " x (4 - ((length $header) % 4));
824    $header .= "(" . $sender . '@color[default]' . ")";
825    my $message = $header . "\n". indentBody($m);
826    if($m->is_personal && $m->direction eq "in") {
827        $message = BarnOwl::Style::boldify($message);
828    }
829    return $message;
830}
831
832sub indentBody($)
833{
834    my $m = shift;
835
836    my $body = $m->body;
837    if ($m->{should_wordwrap}) {
838      $body = BarnOwl::wordwrap($body, BarnOwl::getnumcols()-8);
839    }
840    # replace newline followed by anything with
841    # newline plus four spaces and that thing.
842    $body =~ s/\n(.)/\n    $1/g;
843    # Trim trailing newlines.
844    $body =~ s/\n*$//;
845    return "    ".$body;
846}
847
848package BarnOwl::Style::OneLine;
849################################################################################
850# Branching point for various formatting functions in this style.
851################################################################################
852use constant BASE_FORMAT => '%s %-13.13s %-11.11s %-12.12s ';
853sub format_message($) {
854  my $m = shift;
855
856#  if ( $m->is_zephyr ) {
857#    return format_zephyr($m);
858#  }
859  if ( $m->is_loginout ) {
860    return format_login($m);
861  }
862  elsif ( $m->is_ping) {
863    return format_ping($m);
864  }
865  elsif ( $m->is_admin || $m->is_loopback) {
866    return format_local($m);
867  }
868  else {
869    return format_chat($m);
870  }
871}
872
873BarnOwl::_create_style("oneline", "BarnOwl::Style::OneLine::format_message", "Formats for one-line-per-message");
874
875################################################################################
876
877sub format_login($) {
878  my $m = shift;
879  return sprintf(
880    BASE_FORMAT,
881    '<',
882    $m->type,
883    uc( $m->login ),
884    $m->pretty_sender)
885    . ($m->login_extra ? "at ".$m->login_extra : '');
886}
887
888sub format_ping($) {
889  my $m = shift;
890  return sprintf(
891    BASE_FORMAT,
892    '<',
893    $m->type,
894    'PING',
895    $m->pretty_sender)
896}
897
898sub format_chat($)
899{
900  my $m = shift;
901  my $dir = lc($m->{direction});
902  my $dirsym = '-';
903  if ($dir eq 'in') {
904    $dirsym = '<';
905  }
906  elsif ($dir eq 'out') {
907    $dirsym = '>';
908  }
909
910  my $line;
911  if ($m->is_personal) {
912    $line= sprintf(BASE_FORMAT,
913                   $dirsym,
914                   $m->type,
915                   '',
916                   ($dir eq 'out'
917                      ? $m->pretty_recipient
918                      : $m->pretty_sender));
919  }
920  else {
921    $line = sprintf(BASE_FORMAT,
922                    $dirsym,
923                    $m->context,
924                    $m->subcontext,
925                    ($dir eq 'out'
926                       ? $m->pretty_recipient
927                       : $m->pretty_sender));
928  }
929
930  my $body = $m->{body};
931  $body =~ tr/\n/ /;
932  $line .= $body;
933  $line = BarnOwl::Style::boldify($line) if ($m->is_personal && lc($m->direction) eq 'in');
934  return $line;
935}
936
937# Format locally generated messages
938sub format_local($)
939{
940  my $m = shift;
941  my $type = uc($m->{type});
942  my $line = sprintf(BASE_FORMAT, '<', $type, '', '');
943  my $body = $m->{body};
944  $body =~ tr/\n/ /;
945  return $line.$body;
946}
947
948package BarnOwl::Style;
949
950# This takes a zephyr to be displayed and modifies it to be displayed
951# entirely in bold.
952sub boldify($)
953{
954    local $_ = shift;
955    if ( !(/\)/) ) {
956        return '@b(' . $_ . ')';
957    } elsif ( !(/\>/) ) {
958        return '@b<' . $_ . '>';
959    } elsif ( !(/\}/) ) {
960        return '@b{' . $_ . '}';
961    } elsif ( !(/\]/) ) {
962        return '@b[' . $_ . ']';
963    } else {
964        my $txt = "\@b($_";
965        $txt =~ s/\)/\)\@b\[\)\]\@b\(/g;
966        return $txt . ')';
967    }
968}
969
970
971# switch to package main when we're done
972package main;
973
974# Shove a bunch of fake entries into @INC so modules can use or
975# require them without choking
976$::INC{$_} = 1 for (qw(BarnOwl.pm BarnOwl/Hooks.pm
977                       BarnOwl/Message.pm BarnOwl/Style.pm));
978
9791;
980
Note: See TracBrowser for help on using the repository browser.