source: perlwrap.pm @ 5ff830a

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