source: perl/lib/BarnOwl.pm @ f0a7c09

release-1.10
Last change on this file since f0a7c09 was e26abb6, checked in by David Benjamin <davidben@mit.edu>, 12 years ago
Add new_variable_enum This seems to work. Yay.
  • Property mode set to 100644
File size: 20.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                    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
430=cut
431
432sub new_variable_int {
433    my ($name, $args) = @_;
434    my $storage = defined($args->{default}) ? $args->{default} : 0;
435    BarnOwl::new_variable_full($name, {
436            %{$args},
437            get_tostring => sub { "$storage" },
438            set_fromstring => sub {
439                return -1 unless $_[0] =~ /^-?[0-9]+$/;
440                $storage = 0 + $_[0];
441                return 0;
442            },
443            validsettings => "<int>",
444            takes_on_off => 0,
445        });
446}
447
448sub new_variable_bool {
449    my ($name, $args) = @_;
450    my $storage = defined($args->{default}) ? $args->{default} : 0;
451    BarnOwl::new_variable_full($name, {
452            %{$args},
453            get_tostring => sub { $storage ? "on" : "off" },
454            set_fromstring => sub {
455                return -1 unless $_[0] eq "on" || $_[0] eq "off";
456                $storage = $_[0] eq "on";
457                return 0;
458            },
459            validsettings => "on,off",
460            takes_on_off => 1,
461        });
462}
463
464sub new_variable_string {
465    my ($name, $args) = @_;
466    my $storage = defined($args->{default}) ? $args->{default} : "";
467    BarnOwl::new_variable_full($name, {
468            %{$args},
469            get_tostring => sub { $storage },
470            set_fromstring => sub {
471                $storage = $_[0];
472                return 0;
473            },
474            validsettings => "<string>",
475            takes_on_off => 0,
476        });
477}
478
479sub new_variable_enum {
480    my ($name, $args) = @_;
481
482    # Gather the valid settings.
483    die "validsettings is required" unless defined($args->{validsettings});
484    my %valid;
485    map { $valid{$_} = 1 } @{$args->{validsettings}};
486
487    my $storage = (defined($args->{default}) ?
488                   $args->{default} :
489                   $args->{validsettings}->[0]);
490    BarnOwl::new_variable_full($name, {
491            %{$args},
492            get_tostring => sub { $storage },
493            set_fromstring => sub {
494                return -1 unless $valid{$_[0]};
495                $storage = $_[0];
496                return 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 returns 0 on success.
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      $args{set_fromstring}->($val);
542    };
543
544    BarnOwl::Internal::new_variable($name, $args{summary}, $args{description}, $args{validsettings},
545                                    $args{takes_on_off}, $get_tostring_fn, $set_fromstring_fn, undef);
546}
547
548=head2 quote LIST
549
550Quotes each of the strings in LIST and returns a string that will be
551correctly decoded to LIST by the BarnOwl command parser.  For example:
552
553    quote('zwrite', 'andersk', '-m', 'Hello, world!')
554    # returns "zwrite andersk -m 'Hello, world!'"
555
556=cut
557
558sub quote {
559    my @quoted;
560    for my $str (@_) {
561        if ($str eq '') {
562            push @quoted, "''";
563        } elsif ($str !~ /['" \n\t]/) {
564            push @quoted, "$str";
565        } elsif ($str !~ /'/) {
566            push @quoted, "'$str'";
567        } else {
568            (my $qstr = $str) =~ s/"/"'"'"/g;
569            push @quoted, '"' . $qstr . '"';
570        }
571    }
572    return join(' ', @quoted);
573}
574
575=head2 Modify filters by appending text
576
577=cut
578
579sub register_builtin_commands {
580    # Filter modification
581    BarnOwl::new_command("filterappend",
582                         sub { filter_append_helper('appending', '', @_); },
583                       {
584                           summary => "append '<text>' to filter",
585                           usage => "filterappend <filter> <text>",
586                       });
587
588    BarnOwl::new_command("filterand",
589                         sub { filter_append_helper('and-ing', 'and', @_); },
590                       {
591                           summary => "append 'and <text>' to filter",
592                           usage => "filterand <filter> <text>",
593                       });
594
595    BarnOwl::new_command("filteror",
596                         sub { filter_append_helper('or-ing', 'or', @_); },
597                       {
598                           summary => "append 'or <text>' to filter",
599                           usage => "filteror <filter> <text>",
600                       });
601
602    # Date formatting
603    BarnOwl::new_command("showdate",
604                         sub { BarnOwl::time_format('showdate', '%Y-%m-%d %H:%M'); },
605                       {
606                           summary => "Show date in timestamps for supporting styles.",
607                           usage => "showdate",
608                       });
609
610    BarnOwl::new_command("hidedate",
611                         sub { BarnOwl::time_format('hidedate', '%H:%M'); },
612                       {
613                           summary => "Don't show date in timestamps for supporting styles.",
614                           usage => "hidedate",
615                       });
616
617    BarnOwl::new_command("timeformat",
618                         \&BarnOwl::time_format,
619                       {
620                           summary => "Set the format for timestamps and re-display messages",
621                           usage => "timeformat <format>",
622                       });
623
624    # Receive window scrolling
625    BarnOwl::new_command("recv:shiftleft",
626                        \&BarnOwl::recv_shift_left,
627                        {
628                            summary => "scrolls receive window to the left",
629                            usage => "recv:shiftleft [<amount>]",
630                            description => <<END_DESCR
631By default, scroll left by 10 columns. Passing no arguments or 0 activates this default behavior.
632Otherwise, scroll by the number of columns specified as the argument.
633END_DESCR
634                        });
635
636    BarnOwl::new_command("recv:shiftright",
637                        \&BarnOwl::recv_shift_right,
638                        {
639                            summary => "scrolls receive window to the right",
640                            usage => "recv:shiftright [<amount>]",
641                            description => <<END_DESCR
642By default, scroll right by 10 columns. Passing no arguments or 0 activates this default behavior.
643Otherwise, scroll by the number of columns specified as the argument.
644END_DESCR
645                        });
646
647}
648
649$BarnOwl::Hooks::startup->add("BarnOwl::register_builtin_commands");
650
651=head3 filter_append_helper ACTION SEP FUNC FILTER APPEND_TEXT
652
653Helper to append to filters.
654
655=cut
656
657sub filter_append_helper
658{
659    my $action = shift;
660    my $sep = shift;
661    my $func = shift;
662    my $filter = shift;
663    my @append = @_;
664    my $oldfilter = BarnOwl::getfilter($filter);
665    chomp $oldfilter;
666    my $newfilter = "$oldfilter $sep " . quote(@append);
667    my $msgtext = "To filter " . quote($filter) . " $action\n" . quote(@append) . "\nto get\n$newfilter";
668    if (BarnOwl::getvar('showfilterchange') eq 'on') {
669        BarnOwl::admin_message("Filter", $msgtext);
670    }
671    set_filter($filter, $newfilter);
672    return;
673}
674BarnOwl::new_variable_bool("showfilterchange",
675                           { default => 1,
676                             summary => 'Show modifications to filters by filterappend and friends.'});
677
678sub set_filter
679{
680    my $filtername = shift;
681    my $filtertext = shift;
682    my $cmd = 'filter ' . BarnOwl::quote($filtername) . ' ' . $filtertext;
683    BarnOwl::command($cmd);
684}
685
686=head3 time_format FORMAT
687
688Set the format for displaying times (variable timeformat) and redisplay
689messages.
690
691=cut
692
693my $timeformat = '%H:%M';
694
695sub time_format
696{
697    my $function = shift;
698    my $format = shift;
699    if(!$format)
700    {
701        return $timeformat;
702    }
703    if(shift)
704    {
705        return "Wrong number of arguments for command";
706    }
707    $timeformat = $format;
708    redisplay();
709}
710
711=head3 Receive window scrolling
712
713Permit scrolling the receive window left or right by arbitrary
714amounts (with a default of 10 characters).
715
716=cut
717
718sub recv_shift_left
719{
720    my $func = shift;
721    my $delta = shift;
722    $delta = 10 unless defined($delta) && int($delta) > 0;
723    my $shift = BarnOwl::recv_getshift();
724    if($shift > 0) {
725        BarnOwl::recv_setshift(max(0, $shift-$delta));
726    } else {
727        return "Already full left";
728    }
729}
730
731sub recv_shift_right
732{
733    my $func = shift;
734    my $delta = shift;
735    $delta = 10 unless defined($delta) && int($delta) > 0;
736    my $shift = BarnOwl::recv_getshift();
737    BarnOwl::recv_setshift($shift+$delta);
738}
739
740=head3 default_zephyr_signature
741
742Compute the default zephyr signature.
743
744=cut
745
746sub default_zephyr_signature
747{
748  my $zsig = getvar('zsig');
749  if (!defined($zsig) || $zsig eq '') {
750      my $zsigproc = getvar('zsigproc');
751      if (defined($zsigproc) && $zsigproc ne '') {
752          $zsig = `$zsigproc`;
753      } elsif (!defined($zsig = get_zephyr_variable('zwrite-signature'))) {
754          $zsig = ((getpwuid($<))[6]);
755          $zsig =~ s/,.*//;
756      }
757  }
758  chomp($zsig);
759  return $zsig;
760}
761
762=head3 random_zephyr_signature
763
764Retrieve a random line from ~/.zsigs (except those beginning with '#')
765and use it as the zephyr signature.
766
767=cut
768
769sub random_zephyr_signature
770{
771    my $zsigfile = "$ENV{'HOME'}/.zsigs";
772    open my $file, '<', $zsigfile or die "Error opening file $zsigfile: $!";
773    my @lines = grep !(/^#/ || /^\s*$/), <$file>;
774    close $file;
775    return '' if !@lines;
776    my $zsig = "$lines[int(rand(scalar @lines))]";
777    chomp $zsig;
778    return $zsig;
779}
780
781# Stub for owl::startup / BarnOwl::startup, so it isn't bound to the
782# startup command. This may be redefined in a user's configfile.
783sub startup
784{
785}
786
7871;
Note: See TracBrowser for help on using the repository browser.