source: perlwrap.pm @ cd57601

barnowl_perlaimdebianrelease-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since cd57601 was cd57601, checked in by Nelson Elhage <nelhage@mit.edu>, 14 years ago
Documenting BarnOwl::new_variable_*
  • Property mode set to 100644
File size: 15.9 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
17BEGIN {
18# bootstrap in C bindings and glue
19    *owl:: = \*BarnOwl::;
20    bootstrap BarnOwl 1.2;
21};
22
23use lib(get_data_dir()."/lib");
24use lib($ENV{HOME}."/.owl/lib");
25
26our $configfile;
27
28if(!$configfile && -f $ENV{HOME} . "/.barnowlconf") {
29    $configfile = $ENV{HOME} . "/.barnowlconf";
30}
31$configfile ||= $ENV{HOME}."/.owlconf";
32
33# populate global variable space for legacy owlconf files
34sub _format_msg_legacy_wrap {
35    my ($m) = @_;
36    $m->legacy_populate_global();
37    return &BarnOwl::format_msg($m);
38}
39
40# populate global variable space for legacy owlconf files
41sub _receive_msg_legacy_wrap {
42    my ($m) = @_;
43    $m->legacy_populate_global();
44    return &BarnOwl::Hooks::_receive_msg($m);
45}
46
47# make BarnOwl::<command>("foo") be aliases to BarnOwl::command("<command> foo");
48sub AUTOLOAD {
49    our $AUTOLOAD;
50    my $called = $AUTOLOAD;
51    $called =~ s/.*:://;
52    $called =~ s/_/-/g;
53    return &BarnOwl::command("$called ".join(" ",@_));
54}
55
56=head2 new_command NAME FUNC [{ARGS}]
57
58Add a new owl command. When owl executes the command NAME, FUNC will
59be called with the arguments passed to the command, with NAME as the
60first argument.
61
62ARGS should be a hashref containing any or all of C<summary>,
63C<usage>, or C<description> keys.
64
65=cut
66
67sub new_command {
68    my $name = shift;
69    my $func = shift;
70    my $args = shift || {};
71    my %args = (
72        summary     => undef,
73        usage       => undef,
74        description => undef,
75        %{$args}
76    );
77
78    no warnings 'uninitialized';
79    BarnOwl::new_command_internal($name, $func, $args{summary}, $args{usage}, $args{description});
80}
81
82=head2 new_variable_int NAME [{ARGS}]
83
84=head2 new_variable_bool NAME [{ARGS}]
85
86=head2 new_variable_string NAME [{ARGS}]
87
88Add a new owl variable, either an int, a bool, or a string, with the
89specified name.
90
91ARGS can optionally contain the following keys:
92
93=over 4
94
95=item default
96
97The default and initial value for the variable
98
99=item summary
100
101A one-line summary of the variable's purpose
102
103=item description
104
105A longer description of the function of the variable
106
107=back
108
109=cut
110
111sub new_variable_int {
112    unshift @_, \&BarnOwl::new_variable_int_internal, 0;
113    goto \&_new_variable;
114}
115
116sub new_variable_bool {
117    unshift @_, \&BarnOwl::new_variable_bool_internal, 0;
118    goto \&_new_variable;
119}
120
121sub new_variable_string {
122    unshift @_, \&BarnOwl::new_variable_string_internal, "";
123    goto \&_new_variable;
124}
125
126sub _new_variable {
127    my $func = shift;
128    my $default_default = shift;
129    my $name = shift;
130    my $args = shift || {};
131    my %args = (
132        summary     => "",
133        description => "",
134        default     => $default_default,
135        %{$args});
136    $func->($name, $args{default}, $args{summary}, $args{description});
137}
138
139#####################################################################
140#####################################################################
141
142package BarnOwl::Message;
143
144sub new {
145    my $class = shift;
146    my %args = (@_);
147    if($class eq __PACKAGE__ && $args{type}) {
148        $class = "BarnOwl::Message::" . ucfirst $args{type};
149    }
150    return bless {%args}, $class;
151}
152
153sub type        { return shift->{"type"}; }
154sub direction   { return shift->{"direction"}; }
155sub time        { return shift->{"time"}; }
156sub id          { return shift->{"id"}; }
157sub body        { return shift->{"body"}; }
158sub sender      { return shift->{"sender"}; }
159sub recipient   { return shift->{"recipient"}; }
160sub login       { return shift->{"login"}; }
161sub is_private  { return shift->{"private"}; }
162
163sub is_login    { return shift->login eq "login"; }
164sub is_logout   { return shift->login eq "logout"; }
165sub is_loginout { my $m=shift; return ($m->is_login or $m->is_logout); }
166sub is_incoming { return (shift->{"direction"} eq "in"); }
167sub is_outgoing { return (shift->{"direction"} eq "out"); }
168
169sub is_deleted  { return shift->{"deleted"}; }
170
171sub is_admin    { return (shift->{"type"} eq "admin"); }
172sub is_generic  { return (shift->{"type"} eq "generic"); }
173sub is_zephyr   { return (shift->{"type"} eq "zephyr"); }
174sub is_aim      { return (shift->{"type"} eq "AIM"); }
175sub is_jabber   { return (shift->{"type"} eq "jabber"); }
176sub is_icq      { return (shift->{"type"} eq "icq"); }
177sub is_yahoo    { return (shift->{"type"} eq "yahoo"); }
178sub is_msn      { return (shift->{"type"} eq "msn"); }
179sub is_loopback { return (shift->{"type"} eq "loopback"); }
180
181# These are overridden by appropriate message types
182sub is_ping     { return 0; }
183sub is_mail     { return 0; }
184sub is_personal { return shift->is_private; }
185sub class       { return undef; }
186sub instance    { return undef; }
187sub realm       { return undef; }
188sub opcode      { return undef; }
189sub header      { return undef; }
190sub host        { return undef; }
191sub hostname    { return undef; }
192sub auth        { return undef; }
193sub fields      { return undef; }
194sub zsig        { return undef; }
195sub zwriteline  { return undef; }
196sub login_host  { return undef; }
197sub login_tty   { return undef; }
198
199sub pretty_sender    { return shift->sender; }
200sub pretty_recipient { return shift->recipient; }
201
202sub delete {
203    my ($m) = @_;
204    &BarnOwl::command("delete --id ".$m->id);
205}
206
207sub undelete {
208    my ($m) = @_;
209    &BarnOwl::command("undelete --id ".$m->id);
210}
211
212# Serializes the message into something similar to the zwgc->vt format
213sub serialize {
214    my ($this) = @_;
215    my $s;
216    for my $f (keys %$this) {
217        my $val = $this->{$f};
218        if (ref($val) eq "ARRAY") {
219            for my $i (0..@$val-1) {
220                my $aval;
221                $aval = $val->[$i];
222                $aval =~ s/\n/\n$f.$i: /g;
223                $s .= "$f.$i: $aval\n";
224            }
225        } else {
226            $val =~ s/\n/\n$f: /g;
227            $s .= "$f: $val\n";
228        }
229    }
230    return $s;
231}
232
233# Populate the annoying legacy global variables
234sub legacy_populate_global {
235    my ($m) = @_;
236    $BarnOwl::direction  = $m->direction ;
237    $BarnOwl::type       = $m->type      ;
238    $BarnOwl::id         = $m->id        ;
239    $BarnOwl::class      = $m->class     ;
240    $BarnOwl::instance   = $m->instance  ;
241    $BarnOwl::recipient  = $m->recipient ;
242    $BarnOwl::sender     = $m->sender    ;
243    $BarnOwl::realm      = $m->realm     ;
244    $BarnOwl::opcode     = $m->opcode    ;
245    $BarnOwl::zsig       = $m->zsig      ;
246    $BarnOwl::msg        = $m->body      ;
247    $BarnOwl::time       = $m->time      ;
248    $BarnOwl::host       = $m->host      ;
249    $BarnOwl::login      = $m->login     ;
250    $BarnOwl::auth       = $m->auth      ;
251    if ($m->fields) {
252        @BarnOwl::fields = @{$m->fields};
253        @main::fields = @{$m->fields};
254    } else {
255        @BarnOwl::fields = undef;
256        @main::fields = undef;
257    }
258}
259
260sub smartfilter {
261    die("smartfilter not supported for this message\n");
262}
263
264# Display fields -- overridden by subclasses when needed
265sub login_type {""}
266sub login_extra {""}
267sub long_sender {""}
268
269# The context in which a non-personal message was sent, e.g. a chat or
270# class
271sub context {""}
272
273# Some indicator of context *within* $self->context. e.g. the zephyr
274# instance
275sub subcontext {""}
276
277#####################################################################
278#####################################################################
279
280package BarnOwl::Message::Admin;
281
282use base qw( BarnOwl::Message );
283
284sub header       { return shift->{"header"}; }
285
286#####################################################################
287#####################################################################
288
289package BarnOwl::Message::Generic;
290
291use base qw( BarnOwl::Message );
292
293#####################################################################
294#####################################################################
295
296package BarnOwl::Message::Loopback;
297
298use base qw( BarnOwl::Message );
299
300# all loopback messages are private
301sub is_private {
302  return 1;
303}
304
305#####################################################################
306#####################################################################
307
308package BarnOwl::Message::AIM;
309
310use base qw( BarnOwl::Message );
311
312# all non-loginout AIM messages are private for now...
313sub is_private {
314    return !(shift->is_loginout);
315}
316
317#####################################################################
318#####################################################################
319
320package BarnOwl::Message::Zephyr;
321
322use base qw( BarnOwl::Message );
323
324sub login_type {
325    return (shift->zsig eq "") ? "(PSEUDO)" : "";
326}
327
328sub login_extra {
329    my $m = shift;
330    return undef if (!$m->is_loginout);
331    my $s = lc($m->host);
332    $s .= " " . $m->login_tty if defined $m->login_tty;
333    return $s;
334}
335
336sub long_sender {
337    my $m = shift;
338    return $m->zsig;
339}
340
341sub context {
342    return shift->class;
343}
344
345sub subcontext {
346    return shift->instance;
347}
348
349sub login_tty {
350    my ($m) = @_;
351    return undef if (!$m->is_loginout);
352    return $m->fields->[2];
353}
354
355sub login_host {
356    my ($m) = @_;
357    return undef if (!$m->is_loginout);
358    return $m->fields->[0];
359}
360
361sub zwriteline  { return shift->{"zwriteline"}; }
362
363sub is_ping     { return (lc(shift->opcode) eq "ping"); }
364
365sub is_personal {
366    my ($m) = @_;
367    return ((lc($m->class) eq "message")
368            && (lc($m->instance) eq "personal")
369            && $m->is_private);
370}
371
372sub is_mail {
373    my ($m) = @_;
374    return ((lc($m->class) eq "mail") && $m->is_private);
375}
376
377sub pretty_sender {
378    my ($m) = @_;
379    my $sender = $m->sender;
380    my $realm = BarnOwl::zephyr_getrealm();
381    $sender =~ s/\@$realm$//;
382    return $sender;
383}
384
385sub pretty_recipient {
386    my ($m) = @_;
387    my $recip = $m->recipient;
388    my $realm = BarnOwl::zephyr_getrealm();
389    $recip =~ s/\@$realm$//;
390    return $recip;
391}
392
393# These are arguably zephyr-specific
394sub class       { return shift->{"class"}; }
395sub instance    { return shift->{"instance"}; }
396sub realm       { return shift->{"realm"}; }
397sub opcode      { return shift->{"opcode"}; }
398sub host        { return shift->{"hostname"}; }
399sub hostname    { return shift->{"hostname"}; }
400sub header      { return shift->{"header"}; }
401sub auth        { return shift->{"auth"}; }
402sub fields      { return shift->{"fields"}; }
403sub zsig        { return shift->{"zsig"}; }
404
405#####################################################################
406#####################################################################
407################################################################################
408
409package BarnOwl::Hook;
410
411sub new {
412    my $class = shift;
413    return bless [], $class;
414}
415
416sub run {
417    my $self = shift;
418    my @args = @_;
419    return map {$_->(@args)} @$self;
420}
421
422sub add {
423    my $self = shift;
424    my $func = shift;
425    die("Not a coderef!") unless ref($func) eq 'CODE';
426    push @$self, $func;
427}
428
429sub clear {
430    my $self = shift;
431    @$self = ();
432}
433
434package BarnOwl::Hooks;
435
436use Exporter;
437
438our @EXPORT_OK = qw($startup $shutdown
439                    $receiveMessage $mainLoop
440                    $getBuddyList);
441
442our %EXPORT_TAGS = (all => [@EXPORT_OK]);
443
444our $startup = BarnOwl::Hook->new;
445our $shutdown = BarnOwl::Hook->new;
446our $receiveMessage = BarnOwl::Hook->new;
447our $mainLoop = BarnOwl::Hook->new;
448our $getBuddyList = BarnOwl::Hook->new;
449
450# Internal startup/shutdown routines called by the C code
451
452sub _load_owlconf {
453    # load the config  file
454    if ( -r $BarnOwl::configfile ) {
455        undef $@;
456        package main;
457        do $BarnOwl::configfile;
458        die $@ if $@;
459        package BarnOwl;
460        if(*BarnOwl::format_msg{CODE}) {
461            # if the config defines a legacy formatting function, add 'perl' as a style
462            BarnOwl::_create_style("perl", "BarnOwl::_format_msg_legacy_wrap",
463                                   "User-defined perl style that calls BarnOwl::format_msg"
464                                   . " with legacy global variable support");
465            BarnOwl::set("-q default_style perl");
466        }
467    }
468}
469
470sub _startup {
471    _load_owlconf();
472
473    if(eval {require BarnOwl::ModuleLoader}) {
474        eval {
475            BarnOwl::ModuleLoader->load_all;
476        };
477        BarnOwl::error("$@") if $@;
478open TMP, ">/tmp/error";
479print TMP $@;
480
481    } else {
482        BarnOwl::error("Can't load BarnOwl::ModuleLoader, loadable module support disabled:\n$@");
483    }
484   
485    $startup->run(0);
486    BarnOwl::startup() if *BarnOwl::startup{CODE};
487}
488
489sub _shutdown {
490    $shutdown->run;
491   
492    BarnOwl::shutdown() if *BarnOwl::shutdown{CODE};
493}
494
495sub _receive_msg {
496    my $m = shift;
497
498    $receiveMessage->run($m);
499   
500    BarnOwl::receive_msg($m) if *BarnOwl::receive_msg{CODE};
501}
502
503sub _mainloop_hook {
504    $mainLoop->run;
505    BarnOwl::mainloop_hook() if *BarnOwl::mainloop_hook{CODE};
506}
507
508sub _get_blist {
509    return join("\n", $getBuddyList->run);
510}
511
512################################################################################
513# Built-in perl styles
514################################################################################
515package BarnOwl::Style::Default;
516################################################################################
517# Branching point for various formatting functions in this style.
518################################################################################
519sub format_message($)
520{
521    my $m = shift;
522
523    if ( $m->is_loginout) {
524        return format_login($m);
525    } elsif($m->is_ping) {
526        return ( "\@b(PING) from \@b(" . $m->pretty_sender . ")\n" );
527    } elsif($m->is_admin) {
528        return "\@bold(OWL ADMIN)\n" . indentBody($m);
529    } else {
530        return format_chat($m);
531    }
532}
533
534BarnOwl::_create_style("default", "BarnOwl::Style::Default::format_message", "Default style");
535
536################################################################################
537
538sub time_hhmm {
539    my $m = shift;
540    my ($time) = $m->time =~ /(\d\d:\d\d)/;
541    return $time;
542}
543
544sub format_login($) {
545    my $m = shift;
546    return sprintf(
547        '@b<%s%s> for @b(%s) (%s) %s',
548        uc( $m->login ),
549        $m->login_type,
550        $m->pretty_sender,
551        $m->login_extra,
552        time_hhmm($m)
553       );
554}
555
556sub format_chat($) {
557    my $m = shift;
558    my $header;
559    if ( $m->is_personal ) {
560        if ( $m->direction eq "out" ) {
561            $header = ucfirst $m->type . " sent to " . $m->pretty_recipient;
562        } else {
563            $header = ucfirst $m->type . " from " . $m->pretty_sender;
564        }
565    } else {
566        $header = $m->context;
567        if(defined $m->subcontext) {
568            $header .= ' / ' . $m->subcontext;
569        }
570        $header .= ' / @b{' . $m->pretty_sender . '}';
571    }
572
573    $header .= "  " . time_hhmm($m);
574    my $sender = $m->long_sender;
575    $sender =~ s/\n.*$//s;
576    $header .= " " x (4 - ((length $header) % 4));
577    $header .= "(" . $sender . ")";
578    my $message = $header . "\n". indentBody($m);
579    if($m->is_personal && $m->direction eq "in") {
580        $message = BarnOwl::Style::boldify($message);
581    }
582    return $message;
583}
584
585sub indentBody($)
586{
587    my $m = shift;
588
589    my $body = $m->body;
590    if ($m->{should_wordwrap}) {
591      $body = BarnOwl::wordwrap($body, BarnOwl::getnumcols()-8);
592    }
593    # replace newline followed by anything with
594    # newline plus four spaces and that thing.
595    $body =~ s/\n(.)/\n    $1/g;
596
597    return "    ".$body;
598}
599
600
601package BarnOwl::Style;
602
603# This takes a zephyr to be displayed and modifies it to be displayed
604# entirely in bold.
605sub boldify($)
606{
607    local $_ = shift;
608    if ( !(/\)/) ) {
609        return '@b(' . $_ . ')';
610    } elsif ( !(/\>/) ) {
611        return '@b<' . $_ . '>';
612    } elsif ( !(/\}/) ) {
613        return '@b{' . $_ . '}';
614    } elsif ( !(/\]/) ) {
615        return '@b[' . $_ . ']';
616    } else {
617        my $txt = "\@b($_";
618        $txt =~ s/\)/\)\@b\[\)\]\@b\(/g;
619        return $txt . ')';
620    }
621}
622
623
624# switch to package main when we're done
625package main;
626
627# Shove a bunch of fake entries into @INC so modules can use or
628# require them without choking
629$::INC{$_} = 1 for (qw(BarnOwl.pm BarnOwl/Hooks.pm
630                       BarnOwl/Message.pm BarnOwl/Style.pm));
631
6321;
633
Note: See TracBrowser for help on using the repository browser.