source: perl/lib/BarnOwl.pm @ 69f74c2

Last change on this file since 69f74c2 was 69f74c2, checked in by David Benjamin <davidben@mit.edu>, 9 years ago
And now... the moment you've all been waiting for... Expose OWL_VARIABLE_OTHER variables to perl. Rewrite all perl variable entry points to use that one. From now on, C only thinks of these variables as strings. (This has one regression to be fixed in a later commit: you can't set/unset with no arguments since we don't know how to set from boolean.)
  • Property mode set to 100644
File size: 18.4 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    unshift @_, 0, "<int>", sub { "$_[0]" }, # to string
429                            sub { $_[0] =~ /^-?[0-9]+$/ }, # validate
430                            sub { 0 + $_[0] }; # from string
431    goto \&_new_variable;
432}
433
434sub new_variable_bool {
435    unshift @_, 0, "on,off", sub { $_[0] ? "on" : "off" }, # to string
436                             sub { $_[0] eq "on" || $_[0] eq "off" }, # validate
437                             sub { $_[0] eq "on" }; # from string
438    goto \&_new_variable;
439}
440
441sub new_variable_string {
442    unshift @_, "", "<string>", sub { $_[0] }, # to string
443                                sub { 1 }, # validate
444                                sub { $_[0] }; # from string
445    goto \&_new_variable;
446}
447
448sub _new_variable {
449    my $default_default = shift;
450    my $validsettings = shift;
451    my $tostring_fn = shift;
452    my $validate_fn = shift;
453    my $fromstring_fn = shift;
454
455    my $name = shift;
456    my $args = shift || {};
457    my %args = (
458        summary     => "",
459        description => "",
460        default     => $default_default,
461        %{$args});
462
463    # Store the value in a closure.
464    my $value = $args{default};
465
466    my $get_tostring_fn = sub { $tostring_fn->($value) };
467    my $set_fromstring_fn = sub {
468      my ($dummy, $newval) = @_;
469      return -1 unless $validate_fn->($newval);
470      $value = $fromstring_fn->($newval);
471      return 0;
472    };
473
474    BarnOwl::Internal::new_variable($name, $args{summary}, $args{description}, $validsettings,
475                                    $get_tostring_fn, $set_fromstring_fn, undef);
476}
477
478=head2 quote LIST
479
480Quotes each of the strings in LIST and returns a string that will be
481correctly decoded to LIST by the BarnOwl command parser.  For example:
482
483    quote('zwrite', 'andersk', '-m', 'Hello, world!')
484    # returns "zwrite andersk -m 'Hello, world!'"
485
486=cut
487
488sub quote {
489    my @quoted;
490    for my $str (@_) {
491        if ($str eq '') {
492            push @quoted, "''";
493        } elsif ($str !~ /['" \n\t]/) {
494            push @quoted, "$str";
495        } elsif ($str !~ /'/) {
496            push @quoted, "'$str'";
497        } else {
498            (my $qstr = $str) =~ s/"/"'"'"/g;
499            push @quoted, '"' . $qstr . '"';
500        }
501    }
502    return join(' ', @quoted);
503}
504
505=head2 Modify filters by appending text
506
507=cut
508
509sub register_builtin_commands {
510    # Filter modification
511    BarnOwl::new_command("filterappend",
512                         sub { filter_append_helper('appending', '', @_); },
513                       {
514                           summary => "append '<text>' to filter",
515                           usage => "filterappend <filter> <text>",
516                       });
517
518    BarnOwl::new_command("filterand",
519                         sub { filter_append_helper('and-ing', 'and', @_); },
520                       {
521                           summary => "append 'and <text>' to filter",
522                           usage => "filterand <filter> <text>",
523                       });
524
525    BarnOwl::new_command("filteror",
526                         sub { filter_append_helper('or-ing', 'or', @_); },
527                       {
528                           summary => "append 'or <text>' to filter",
529                           usage => "filteror <filter> <text>",
530                       });
531
532    # Date formatting
533    BarnOwl::new_command("showdate",
534                         sub { BarnOwl::time_format('showdate', '%Y-%m-%d %H:%M'); },
535                       {
536                           summary => "Show date in timestamps for supporting styles.",
537                           usage => "showdate",
538                       });
539
540    BarnOwl::new_command("hidedate",
541                         sub { BarnOwl::time_format('hidedate', '%H:%M'); },
542                       {
543                           summary => "Don't show date in timestamps for supporting styles.",
544                           usage => "hidedate",
545                       });
546
547    BarnOwl::new_command("timeformat",
548                         \&BarnOwl::time_format,
549                       {
550                           summary => "Set the format for timestamps and re-display messages",
551                           usage => "timeformat <format>",
552                       });
553
554    # Receive window scrolling
555    BarnOwl::new_command("recv:shiftleft",
556                        \&BarnOwl::recv_shift_left,
557                        {
558                            summary => "scrolls receive window to the left",
559                            usage => "recv:shiftleft [<amount>]",
560                            description => <<END_DESCR
561By default, scroll left by 10 columns. Passing no arguments or 0 activates this default behavior.
562Otherwise, scroll by the number of columns specified as the argument.
563END_DESCR
564                        });
565
566    BarnOwl::new_command("recv:shiftright",
567                        \&BarnOwl::recv_shift_right,
568                        {
569                            summary => "scrolls receive window to the right",
570                            usage => "recv:shiftright [<amount>]",
571                            description => <<END_DESCR
572By default, scroll right by 10 columns. Passing no arguments or 0 activates this default behavior.
573Otherwise, scroll by the number of columns specified as the argument.
574END_DESCR
575                        });
576
577}
578
579$BarnOwl::Hooks::startup->add("BarnOwl::register_builtin_commands");
580
581=head3 filter_append_helper ACTION SEP FUNC FILTER APPEND_TEXT
582
583Helper to append to filters.
584
585=cut
586
587sub filter_append_helper
588{
589    my $action = shift;
590    my $sep = shift;
591    my $func = shift;
592    my $filter = shift;
593    my @append = @_;
594    my $oldfilter = BarnOwl::getfilter($filter);
595    chomp $oldfilter;
596    my $newfilter = "$oldfilter $sep " . quote(@append);
597    my $msgtext = "To filter " . quote($filter) . " $action\n" . quote(@append) . "\nto get\n$newfilter";
598    if (BarnOwl::getvar('showfilterchange') eq 'on') {
599        BarnOwl::admin_message("Filter", $msgtext);
600    }
601    set_filter($filter, $newfilter);
602    return;
603}
604BarnOwl::new_variable_bool("showfilterchange",
605                           { default => 1,
606                             summary => 'Show modifications to filters by filterappend and friends.'});
607
608sub set_filter
609{
610    my $filtername = shift;
611    my $filtertext = shift;
612    my $cmd = 'filter ' . BarnOwl::quote($filtername) . ' ' . $filtertext;
613    BarnOwl::command($cmd);
614}
615
616=head3 time_format FORMAT
617
618Set the format for displaying times (variable timeformat) and redisplay
619messages.
620
621=cut
622
623my $timeformat = '%H:%M';
624
625sub time_format
626{
627    my $function = shift;
628    my $format = shift;
629    if(!$format)
630    {
631        return $timeformat;
632    }
633    if(shift)
634    {
635        return "Wrong number of arguments for command";
636    }
637    $timeformat = $format;
638    redisplay();
639}
640
641=head3 Receive window scrolling
642
643Permit scrolling the receive window left or right by arbitrary
644amounts (with a default of 10 characters).
645
646=cut
647
648sub recv_shift_left
649{
650    my $func = shift;
651    my $delta = shift;
652    $delta = 10 unless defined($delta) && int($delta) > 0;
653    my $shift = BarnOwl::recv_getshift();
654    if($shift > 0) {
655        BarnOwl::recv_setshift(max(0, $shift-$delta));
656    } else {
657        return "Already full left";
658    }
659}
660
661sub recv_shift_right
662{
663    my $func = shift;
664    my $delta = shift;
665    $delta = 10 unless defined($delta) && int($delta) > 0;
666    my $shift = BarnOwl::recv_getshift();
667    BarnOwl::recv_setshift($shift+$delta);
668}
669
670=head3 default_zephyr_signature
671
672Compute the default zephyr signature.
673
674=cut
675
676sub default_zephyr_signature
677{
678  my $zsig = getvar('zsig');
679  if (!defined($zsig) || $zsig eq '') {
680      my $zsigproc = getvar('zsigproc');
681      if (defined($zsigproc) && $zsigproc ne '') {
682          $zsig = `$zsigproc`;
683      } elsif (!defined($zsig = get_zephyr_variable('zwrite-signature'))) {
684          $zsig = ((getpwuid($<))[6]);
685          $zsig =~ s/,.*//;
686      }
687  }
688  chomp($zsig);
689  return $zsig;
690}
691
692=head3 random_zephyr_signature
693
694Retrieve a random line from ~/.zsigs (except those beginning with '#')
695and use it as the zephyr signature.
696
697=cut
698
699sub random_zephyr_signature
700{
701    my $zsigfile = "$ENV{'HOME'}/.zsigs";
702    open my $file, '<', $zsigfile or die "Error opening file $zsigfile: $!";
703    my @lines = grep !(/^#/ || /^\s*$/), <$file>;
704    close $file;
705    return '' if !@lines;
706    my $zsig = "$lines[int(rand(scalar @lines))]";
707    chomp $zsig;
708    return $zsig;
709}
710
711# Stub for owl::startup / BarnOwl::startup, so it isn't bound to the
712# startup command. This may be redefined in a user's configfile.
713sub startup
714{
715}
716
7171;
Note: See TracBrowser for help on using the repository browser.