source: perlwrap.pm @ 2650a10

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