source: perlwrap.pm @ da466e0

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