source: perl/lib/BarnOwl.pm @ 523146b

Last change on this file since 523146b was 523146b, checked in by David Benjamin <davidben@mit.edu>, 10 years ago
Add new_variable_full Route everything through that.
  • Property mode set to 100644
File size: 19.6 KB
Line 
1use strict;
2use warnings;
3
4package BarnOwl;
5
6use base qw(Exporter);
7our @EXPORT_OK = qw(command getcurmsg getnumcols getnumlines getidletime
8                    zephyr_getsender zephyr_getrealm zephyr_zwrite
9                    zephyr_stylestrip zephyr_smartstrip_user zephyr_getsubs
10                    queue_message admin_message
11                    start_edit
12                    start_question start_password start_edit_win
13                    get_data_dir get_config_dir popless_text popless_ztext
14                    error debug
15                    create_style getnumcolors wordwrap
16                    add_dispatch remove_dispatch
17                    add_io_dispatch remove_io_dispatch
18                    new_command
19                    new_variable_int new_variable_bool new_variable_string
20                    quote redisplay);
21our %EXPORT_TAGS = (all => \@EXPORT_OK);
22
23BEGIN {
24# bootstrap in C bindings and glue
25    *owl:: = \*BarnOwl::;
26    bootstrap BarnOwl 1.2;
27};
28
29use lib(get_data_dir() . "/lib");
30use lib(get_config_dir() . "/lib");
31
32use Glib;
33use AnyEvent;
34
35use BarnOwl::Hook;
36use BarnOwl::Hooks;
37use BarnOwl::Message;
38use BarnOwl::Style;
39use BarnOwl::Zephyr;
40use BarnOwl::Timer;
41use BarnOwl::Editwin;
42use BarnOwl::Completion;
43use BarnOwl::Help;
44
45use List::Util qw(max);
46
47=head1 NAME
48
49BarnOwl
50
51=head1 DESCRIPTION
52
53The BarnOwl module contains the core of BarnOwl's perl
54bindings. Source in this module is also run at startup to bootstrap
55BarnOwl by defining things like the default style.
56
57=for NOTE
58These following functions are defined in perlglue.xs. Keep the
59documentation here in sync with the user-visible commands defined
60there!
61
62=head2 command STRING
63
64Executes a BarnOwl command in the same manner as if the user had
65executed it at the BarnOwl command prompt. If the command returns a
66value, return it as a string, otherwise return undef.
67
68=head2 getcurmsg
69
70Returns the current message as a C<BarnOwl::Message> subclass, or
71undef if there is no message selected
72=head2 getnumcols
73
74Returns the width of the display window BarnOwl is currently using
75
76=head2 getidletime
77
78Returns the length of time since the user has pressed a key, in
79seconds.
80
81=head2 zephyr_getrealm
82
83Returns the zephyr realm BarnOwl is running in
84
85=head2 zephyr_getsender
86
87Returns the fully-qualified name of the zephyr sender BarnOwl is
88running as, e.g. C<nelhage@ATHENA.MIT.EDU>
89
90=head2 zephyr_zwrite COMMAND MESSAGE
91
92Sends a zephyr programmatically. C<COMMAND> should be a C<zwrite>
93command line, and C<MESSAGE> is the zephyr body to send.
94
95=cut
96
97sub zephyr_zwrite {
98    my ($command, $message) = @_;
99    my $ret = BarnOwl::Internal::zephyr_zwrite($command, $message);
100    die "Error sending zephyr" unless $ret == 0;
101}
102
103=head2 ztext_stylestrip STRING
104
105Strips zephyr formatting from a string and returns the result
106
107=head2 zephyr_getsubs
108
109Returns the list of subscription triples <class,instance,recipient>,
110separated by newlines.
111
112=head2 queue_message MESSAGE
113
114Enqueue a message in the BarnOwl message list, logging it and
115processing it appropriately. C<MESSAGE> should be an instance of
116BarnOwl::Message or a subclass.
117
118=head2 admin_message HEADER BODY
119
120Display a BarnOwl B<Admin> message, with the given header and body.
121
122=head2 start_edit %ARGS
123
124Displays a prompt on the screen and lets the user enter text,
125and calls a callback when the editwin is closed.
126
127C<%ARGS> must contain the following keys:
128
129=over 4
130
131=item prompt
132
133The line to display on the screen
134
135=item type
136
137One of:
138
139=over 4
140
141=item edit_win
142
143Displays the prompt on a line of its own and opens the edit_win.
144
145=item question
146
147Displays prompt on the screen and lets the user enter a line of
148text.
149
150=item password
151
152Like question, but echoes the user's input as C<*>s when they
153input.
154
155=back
156
157=item callback
158
159A Perl subroutine that is called when the user closes the edit_win.
160C<CALLBACK> gets called with two parameters: the text the user entered,
161and a C<SUCCESS> boolean parameter which is false if the user canceled
162the edit_win and true otherwise.
163
164=back
165
166=head2 start_question PROMPT CALLBACK
167
168=head2 start_password PROMPT CALLBACK
169
170=head2 start_edit_win PROMPT CALLBACK
171
172Roughly equivalent to C<start_edit> called with the appropriate parameters.
173C<CALLBACK> is only called on success, for compatibility.
174
175These are deprecated wrappers around L<BarnOwl::start_edit>, and should not
176be uesd in new code.
177
178=cut
179
180sub start_edit {
181    my %args = (@_);
182    BarnOwl::Internal::start_edit($args{type}, $args{prompt}, $args{callback});
183}
184
185sub start_question {
186    my ($prompt, $callback) = @_;
187    BarnOwl::start_edit(type => 'question', prompt => $prompt, callback => sub {
188            my ($text, $success) = @_;
189            $callback->($text) if $success;
190        });
191}
192
193sub start_password {
194    my ($prompt, $callback) = @_;
195    BarnOwl::start_edit(type => 'password', prompt => $prompt, callback => sub {
196            my ($text, $success) = @_;
197            $callback->($text) if $success;
198        });
199}
200
201sub start_edit_win {
202    my ($prompt, $callback) = @_;
203    BarnOwl::start_edit(type => 'edit_win', prompt => $prompt, callback => sub {
204            my ($text, $success) = @_;
205            $callback->($text) if $success;
206        });
207}
208
209=head2 get_data_dir
210
211Returns the BarnOwl system data directory, where system libraries and
212modules are stored
213
214=head2 get_config_dir
215
216Returns the BarnOwl user configuration directory, where user modules
217and configuration are stored (by default, C<$HOME/.owl>)
218
219=head2 popless_text TEXT
220
221Show a popup window containing the given C<TEXT>
222
223=head2 popless_ztext TEXT
224
225Show a popup window containing the provided zephyr-formatted C<TEXT>
226
227=head2 error STRING
228
229Reports an error and log it in `show errors'. Note that in any
230callback or hook called in perl code from BarnOwl, a C<die> will be
231caught and passed to C<error>.
232
233=head2 debug STRING
234
235Logs a debugging message to BarnOwl's debug log
236
237=head2 getnumcolors
238
239Returns the number of colors this BarnOwl is capable of displaying
240
241=head2 add_dispatch FD CALLBACK
242
243Adds a file descriptor to C<BarnOwl>'s internal C<select()>
244loop. C<CALLBACK> will be invoked whenever data is available to be
245read from C<FD>.
246
247C<add_dispatch> has been deprecated in favor of C<AnyEvent>, and is
248now a wrapper for C<add_io_dispatch> called with C<mode> set to
249C<'r'>.
250
251=cut
252
253sub add_dispatch {
254    my $fd = shift;
255    my $cb = shift;
256    add_io_dispatch($fd, 'r', $cb);
257}
258
259=head2 remove_dispatch FD
260
261Remove a file descriptor previously registered via C<add_dispatch>
262
263C<remove_dispatch> has been deprecated in favor of C<AnyEvent>.
264
265=cut
266
267*remove_dispatch = \&remove_io_dispatch;
268
269=head2 add_io_dispatch FD MODE CB
270
271Adds a file descriptor to C<BarnOwl>'s internal C<select()>
272loop. <MODE> can be 'r', 'w', or 'rw'. C<CALLBACK> will be invoked
273whenever C<FD> becomes ready, as specified by <MODE>.
274
275Only one callback can be registered per FD. If a new callback is
276registered, the old one is removed.
277
278C<add_io_dispatch> has been deprecated in favor of C<AnyEvent>.
279
280=cut
281
282our %_io_dispatches;
283
284sub add_io_dispatch {
285    my $fd = shift;
286    my $modeStr = shift;
287    my $cb = shift;
288    my @modes;
289
290    push @modes, 'r' if $modeStr =~ /r/i; # Read
291    push @modes, 'w' if $modeStr =~ /w/i; # Write
292    if (@modes) {
293        BarnOwl::remove_io_dispatch($fd);
294        for my $mode (@modes) {
295            push @{$_io_dispatches{$fd}}, AnyEvent->io(fh => $fd,
296                                                       poll => $mode,
297                                                       cb => $cb);
298        }
299    } else {
300        die("Invalid I/O Dispatch mode: $modeStr");
301    }
302}
303
304=head2 remove_io_dispatch FD
305
306Remove a file descriptor previously registered via C<add_io_dispatch>
307
308C<remove_io_dispatch> has been deprecated in favor of C<AnyEvent>.
309
310=cut
311
312sub remove_io_dispatch {
313    my $fd = shift;
314    undef $_ foreach @{$_io_dispatches{$fd}};
315    delete $_io_dispatches{$fd};
316}
317
318=head2 create_style NAME OBJECT
319
320Creates a new BarnOwl style with the given NAME defined by the given
321object. The object must have a C<description> method which returns a
322string description of the style, and a and C<format_message> method
323which accepts a C<BarnOwl::Message> object and returns a string that
324is the result of formatting the message for display.
325
326=head2 redisplay
327
328Redraw all of the messages on screen. This is useful if you've just
329changed how a style renders messages.
330
331=cut
332
333# perlconfig.c will set this to the value of the -c command-line
334# switch, if present.
335our $configfile;
336
337our @all_commands;
338
339if(!$configfile) {
340    if (-f get_config_dir() . "/init.pl") {
341        $configfile = get_config_dir() . "/init.pl";
342    } elsif (-f $ENV{HOME} . "/.barnowlconf") {
343        $configfile = $ENV{HOME} . "/.barnowlconf";
344    } else {
345        $configfile = $ENV{HOME}."/.owlconf";
346    }
347}
348
349# populate global variable space for legacy owlconf files
350sub _receive_msg_legacy_wrap {
351    my ($m) = @_;
352    $m->legacy_populate_global();
353    return &BarnOwl::Hooks::_receive_msg($m);
354}
355
356=head2 new_command NAME FUNC [{ARGS}]
357
358Add a new owl command. When owl executes the command NAME, FUNC will
359be called with the arguments passed to the command, with NAME as the
360first argument.
361
362ARGS should be a hashref containing any or all of C<summary>,
363C<usage>, or C<description> keys:
364
365=over 4
366
367=item summary
368
369A one-line summary of the purpose of the command
370
371=item usage
372
373A one-line usage synopsis, showing available options and syntax
374
375=item description
376
377A longer description of the syntax and semantics of the command,
378explaining usage and options
379
380=back
381
382=cut
383
384sub new_command {
385    my $name = shift;
386    my $func = shift;
387    my $args = shift || {};
388    my %args = (
389        summary     => "",
390        usage       => "",
391        description => "",
392        %{$args}
393    );
394
395    BarnOwl::Internal::new_command($name, $func, $args{summary}, $args{usage}, $args{description});
396}
397
398=head2 new_variable_int NAME [{ARGS}]
399
400=head2 new_variable_bool NAME [{ARGS}]
401
402=head2 new_variable_string NAME [{ARGS}]
403
404Add a new owl variable, either an int, a bool, or a string, with the
405specified name.
406
407ARGS can optionally contain the following keys:
408
409=over 4
410
411=item default
412
413The default and initial value for the variable
414
415=item summary
416
417A one-line summary of the variable's purpose
418
419=item description
420
421A longer description of the function of the variable
422
423=back
424
425=cut
426
427sub new_variable_int {
428    my ($name, $args) = @_;
429    my $storage = defined($args->{default}) ? $args->{default} : 0;
430    BarnOwl::new_variable_full($name, {
431            %{$args},
432            get_tostring => sub { "$storage" },
433            set_fromstring => sub {
434                return -1 unless $_[0] =~ /^-?[0-9]+$/;
435                $storage = 0 + $_[0];
436                return 0;
437            },
438            validsettings => "<int>",
439            takes_on_off => 0,
440        });
441}
442
443sub new_variable_bool {
444    my ($name, $args) = @_;
445    my $storage = defined($args->{default}) ? $args->{default} : 0;
446    BarnOwl::new_variable_full($name, {
447            %{$args},
448            get_tostring => sub { $storage ? "on" : "off" },
449            set_fromstring => sub {
450                return -1 unless $_[0] eq "on" || $_[0] eq "off";
451                $storage = $_[0] eq "on";
452                return 0;
453            },
454            validsettings => "on,off",
455            takes_on_off => 1,
456        });
457}
458
459sub new_variable_string {
460    my ($name, $args) = @_;
461    my $storage = defined($args->{default}) ? $args->{default} : "";
462    BarnOwl::new_variable_full($name, {
463            %{$args},
464            get_tostring => sub { $storage },
465            set_fromstring => sub {
466                $storage = $_[0];
467                return 0;
468            },
469            validsettings => "<string>",
470            takes_on_off => 0,
471        });
472}
473
474=head2 new_variable_full NAME {ARGS}
475
476Create a variable, in full generality. The keyword arguments have types below:
477
478 get_tostring : ()  -> string
479 set_fromstring : string -> int
480 -- optional --
481 summary : string
482 description : string
483 validsettings : string
484 takes_on_off : int
485
486The get/set functions are required. Note that the caller manages storage for the
487variable. get_tostring/set_fromstring both convert AND store the value.
488set_fromstring returns 0 on success.
489
490If the variable takes parameters 'on' and 'off' (i.e. is boolean-looking), set
491takes_on_off to 1. This makes :set VAR and :unset VAR work. set_fromstring will
492be called with those arguments.
493
494=cut
495
496sub new_variable_full {
497    my $name = shift;
498    my $args = shift || {};
499    my %args = (
500        summary => "",
501        description => "",
502        takes_on_off => 0,
503        validsettings => "<string>",
504        %{$args});
505
506    die "get_tostring required" unless $args{get_tostring};
507    die "set_fromstring required" unless $args{set_fromstring};
508
509    # Strip off the bogus dummy argument. Aargh perl-Glib.
510    my $get_tostring_fn = sub { $args{get_tostring}->() };
511    my $set_fromstring_fn = sub {
512      my ($dummy, $val) = @_;
513      $args{set_fromstring}->($val);
514    };
515
516    BarnOwl::Internal::new_variable($name, $args{summary}, $args{description}, $args{validsettings},
517                                    $args{takes_on_off}, $get_tostring_fn, $set_fromstring_fn, undef);
518}
519
520=head2 quote LIST
521
522Quotes each of the strings in LIST and returns a string that will be
523correctly decoded to LIST by the BarnOwl command parser.  For example:
524
525    quote('zwrite', 'andersk', '-m', 'Hello, world!')
526    # returns "zwrite andersk -m 'Hello, world!'"
527
528=cut
529
530sub quote {
531    my @quoted;
532    for my $str (@_) {
533        if ($str eq '') {
534            push @quoted, "''";
535        } elsif ($str !~ /['" \n\t]/) {
536            push @quoted, "$str";
537        } elsif ($str !~ /'/) {
538            push @quoted, "'$str'";
539        } else {
540            (my $qstr = $str) =~ s/"/"'"'"/g;
541            push @quoted, '"' . $qstr . '"';
542        }
543    }
544    return join(' ', @quoted);
545}
546
547=head2 Modify filters by appending text
548
549=cut
550
551sub register_builtin_commands {
552    # Filter modification
553    BarnOwl::new_command("filterappend",
554                         sub { filter_append_helper('appending', '', @_); },
555                       {
556                           summary => "append '<text>' to filter",
557                           usage => "filterappend <filter> <text>",
558                       });
559
560    BarnOwl::new_command("filterand",
561                         sub { filter_append_helper('and-ing', 'and', @_); },
562                       {
563                           summary => "append 'and <text>' to filter",
564                           usage => "filterand <filter> <text>",
565                       });
566
567    BarnOwl::new_command("filteror",
568                         sub { filter_append_helper('or-ing', 'or', @_); },
569                       {
570                           summary => "append 'or <text>' to filter",
571                           usage => "filteror <filter> <text>",
572                       });
573
574    # Date formatting
575    BarnOwl::new_command("showdate",
576                         sub { BarnOwl::time_format('showdate', '%Y-%m-%d %H:%M'); },
577                       {
578                           summary => "Show date in timestamps for supporting styles.",
579                           usage => "showdate",
580                       });
581
582    BarnOwl::new_command("hidedate",
583                         sub { BarnOwl::time_format('hidedate', '%H:%M'); },
584                       {
585                           summary => "Don't show date in timestamps for supporting styles.",
586                           usage => "hidedate",
587                       });
588
589    BarnOwl::new_command("timeformat",
590                         \&BarnOwl::time_format,
591                       {
592                           summary => "Set the format for timestamps and re-display messages",
593                           usage => "timeformat <format>",
594                       });
595
596    # Receive window scrolling
597    BarnOwl::new_command("recv:shiftleft",
598                        \&BarnOwl::recv_shift_left,
599                        {
600                            summary => "scrolls receive window to the left",
601                            usage => "recv:shiftleft [<amount>]",
602                            description => <<END_DESCR
603By default, scroll left by 10 columns. Passing no arguments or 0 activates this default behavior.
604Otherwise, scroll by the number of columns specified as the argument.
605END_DESCR
606                        });
607
608    BarnOwl::new_command("recv:shiftright",
609                        \&BarnOwl::recv_shift_right,
610                        {
611                            summary => "scrolls receive window to the right",
612                            usage => "recv:shiftright [<amount>]",
613                            description => <<END_DESCR
614By default, scroll right by 10 columns. Passing no arguments or 0 activates this default behavior.
615Otherwise, scroll by the number of columns specified as the argument.
616END_DESCR
617                        });
618
619}
620
621$BarnOwl::Hooks::startup->add("BarnOwl::register_builtin_commands");
622
623=head3 filter_append_helper ACTION SEP FUNC FILTER APPEND_TEXT
624
625Helper to append to filters.
626
627=cut
628
629sub filter_append_helper
630{
631    my $action = shift;
632    my $sep = shift;
633    my $func = shift;
634    my $filter = shift;
635    my @append = @_;
636    my $oldfilter = BarnOwl::getfilter($filter);
637    chomp $oldfilter;
638    my $newfilter = "$oldfilter $sep " . quote(@append);
639    my $msgtext = "To filter " . quote($filter) . " $action\n" . quote(@append) . "\nto get\n$newfilter";
640    if (BarnOwl::getvar('showfilterchange') eq 'on') {
641        BarnOwl::admin_message("Filter", $msgtext);
642    }
643    set_filter($filter, $newfilter);
644    return;
645}
646BarnOwl::new_variable_bool("showfilterchange",
647                           { default => 1,
648                             summary => 'Show modifications to filters by filterappend and friends.'});
649
650sub set_filter
651{
652    my $filtername = shift;
653    my $filtertext = shift;
654    my $cmd = 'filter ' . BarnOwl::quote($filtername) . ' ' . $filtertext;
655    BarnOwl::command($cmd);
656}
657
658=head3 time_format FORMAT
659
660Set the format for displaying times (variable timeformat) and redisplay
661messages.
662
663=cut
664
665my $timeformat = '%H:%M';
666
667sub time_format
668{
669    my $function = shift;
670    my $format = shift;
671    if(!$format)
672    {
673        return $timeformat;
674    }
675    if(shift)
676    {
677        return "Wrong number of arguments for command";
678    }
679    $timeformat = $format;
680    redisplay();
681}
682
683=head3 Receive window scrolling
684
685Permit scrolling the receive window left or right by arbitrary
686amounts (with a default of 10 characters).
687
688=cut
689
690sub recv_shift_left
691{
692    my $func = shift;
693    my $delta = shift;
694    $delta = 10 unless defined($delta) && int($delta) > 0;
695    my $shift = BarnOwl::recv_getshift();
696    if($shift > 0) {
697        BarnOwl::recv_setshift(max(0, $shift-$delta));
698    } else {
699        return "Already full left";
700    }
701}
702
703sub recv_shift_right
704{
705    my $func = shift;
706    my $delta = shift;
707    $delta = 10 unless defined($delta) && int($delta) > 0;
708    my $shift = BarnOwl::recv_getshift();
709    BarnOwl::recv_setshift($shift+$delta);
710}
711
712=head3 default_zephyr_signature
713
714Compute the default zephyr signature.
715
716=cut
717
718sub default_zephyr_signature
719{
720  my $zsig = getvar('zsig');
721  if (!defined($zsig) || $zsig eq '') {
722      my $zsigproc = getvar('zsigproc');
723      if (defined($zsigproc) && $zsigproc ne '') {
724          $zsig = `$zsigproc`;
725      } elsif (!defined($zsig = get_zephyr_variable('zwrite-signature'))) {
726          $zsig = ((getpwuid($<))[6]);
727          $zsig =~ s/,.*//;
728      }
729  }
730  chomp($zsig);
731  return $zsig;
732}
733
734=head3 random_zephyr_signature
735
736Retrieve a random line from ~/.zsigs (except those beginning with '#')
737and use it as the zephyr signature.
738
739=cut
740
741sub random_zephyr_signature
742{
743    my $zsigfile = "$ENV{'HOME'}/.zsigs";
744    open my $file, '<', $zsigfile or die "Error opening file $zsigfile: $!";
745    my @lines = grep !(/^#/ || /^\s*$/), <$file>;
746    close $file;
747    return '' if !@lines;
748    my $zsig = "$lines[int(rand(scalar @lines))]";
749    chomp $zsig;
750    return $zsig;
751}
752
753# Stub for owl::startup / BarnOwl::startup, so it isn't bound to the
754# startup command. This may be redefined in a user's configfile.
755sub startup
756{
757}
758
7591;
Note: See TracBrowser for help on using the repository browser.