source: perl/lib/BarnOwl.pm @ 0adbce1

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