source: perl/lib/BarnOwl.pm @ 104a4eb

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