move debug() to Screen class
[fcscs/fcscs.git] / bin / fcscs
1 #!/usr/bin/perl
2
3 # fcscs - fast curses screen content select
4
5 # Copyright (C) 2013-2016  Simon Ruderich
6 #
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
11 #
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 # GNU General Public License for more details.
16 #
17 # You should have received a copy of the GNU General Public License
18 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
19
20
21 use strict;
22 use warnings;
23
24 use v5.10; # say, state
25
26 use Encode ();
27 use Fcntl ();
28 use I18N::Langinfo ();
29
30 use Curses ();
31
32 our $VERSION = '0.01';
33
34
35 =head1 NAME
36
37 fcscs - fast curses screen content select
38
39 =head1 SYNOPSIS
40
41 B<fcscs> [I<options>] I<path/to/screen/capture/file>
42
43 =head1 DESCRIPTION
44
45 B<fcscs> is a small tool which allows quick selection of terminal screen
46 contents (like URLs, paths, regex matches, etc.) and passes the selection to
47 GNU Screen's or Tmux's buffer or any other program. The selection can then
48 quickly be pasted, e.g. in the shell. Requires GNU Screen or Tmux. It's
49 licensed under the GPL 3 or later.
50
51 =head1 OPTIONS
52
53 None so far.
54
55 =head1 USAGE
56
57 Short overview of the general usage, details below:
58
59     - start fcscs
60     - configure actions (optional)
61         - enable pasting
62         - ...
63     - select mode (optional, URL mode is used on startup):
64         - f: file paths
65         - u: URLs
66         - ...
67         - /: search mode
68     - for `normal' modes:
69         - select match by displayed number or <return> for lowest numbered
70           match
71         - configured action is run, e.g. URL is opened with browser
72     - for `search' mode:
73         - perform incremental search
74         - on <return> go to `normal' mode to select a match
75         - after the match is selected wait for confirmation or extension
76         - confirmation: <return> run previously selected action
77         - extension: change match, e.g. select complete word or line
78
79 GNU Screen setup (add to F<~/.screenrc>):
80
81     bind ^B eval "hardcopy $HOME/.tmp/screen-fcscs" "screen fcscs $HOME/.tmp/screen-fcscs"
82
83 Tmux setup (add to F<~/.tmux.conf>):
84
85     bind-key C-b capture-pane \; save-buffer ~/.tmp/tmux-fcscs \; delete-buffer \; new-window "fcscs ~/.tmp/tmux-fcscs"
86
87 This requires a writable ~/.tmp directory. Adapt the mapping according to your
88 preferences. Ensure these files are not readable by others as they can contain
89 private data (umask or protected directory). B<fcscs> must be in your C<$PATH>
90 for the above mappings to work.
91
92 Pressing the configured mapping (Prefix Ctrl-B in this example) opens B<fcscs>
93 in a new GNU screen/Tmux window. After selection, the content is either passed
94 to external programs (e.g. for URLs) or copied to the paste buffer or directly
95 pasted in your previous window and the new window is closed.
96
97 To select a match just type its number. If the match is unique, the entry is
98 automatically selected (e.g. you press 2 and there are only 19 matches). If
99 there are multiple matches left (e.g. you press 1 and there are more than ten
100 matches available), press return to select the current match (1 in this case)
101 or another number to select the longer match. Use backspace to remove the last
102 entered number.
103
104 Press return before entering a number to select the last (lowest numbered)
105 match. To abort without selecting any match either use "q".
106
107 To change the selection mode (e.g. paths, files, etc.) use one of the mappings
108 explained below. Per default URLs are selected, see options for a way to
109 change this.
110
111 I<NOTE>: When yanking (copying) a temporary file is used to pass the data to
112 GNU screen/Tmux without exposing it to C<ps aux> or C<top>. However this may
113 leak data if those temporary files are written to disk. To prevent this change
114 your C<$TMP> to point to a memory-only location or encrypted storage.
115
116 If no window appears, try running B<fcscs> manually to catch the error message
117 and please report the bug:
118
119     fcscs /path/to/screen-or-tmux-fcscs-file
120
121
122 =head1 MODES
123
124 =cut
125
126
127 # CLASSES
128
129 # Helper class for drawing on the screen using Curses.
130 package Screen {
131     sub init {
132         my ($class, $encoding) = @_;
133
134         # Prefer strict UTF-8 handling (see perldoc Encode); just in case.
135         if (lc $encoding eq 'utf8') {
136             $encoding = 'UTF-8';
137         }
138         # Get Encode object to speed up decode()/encode().
139         my $encoding_object = Encode::find_encoding($encoding);
140         die "unsupported encoding '$encoding'" unless ref $encoding_object;
141
142         my $curses = Curses->new or die $!;
143
144         my $self = {
145             encoding        => $encoding,
146             encoding_object => $encoding_object,
147             curses          => $curses,
148             debug           => 0,
149             prompt          => {
150                 flags => undef,
151                 name  => undef,
152                 value => undef,
153             },
154         };
155         bless $self, $class;
156
157         Curses::start_color;
158         # Allow default colors by passing -1 to init_pair. A default color is
159         # not drawn on screen thus allowing terminals with pseudo-transparency
160         # to use the transparent background in place of the default color.
161         Curses::use_default_colors;
162
163         Curses::cbreak;
164         Curses::noecho;
165         $self->cursor(0);
166
167         return $self;
168     }
169     sub deinit {
170         my ($self) = @_;
171
172         Curses::nocbreak;
173         Curses::echo;
174         $self->cursor(1);
175
176         Curses::endwin;
177         return;
178     }
179
180     # Convert between Perl's internal encoding and the terminal's encoding.
181     sub encode {
182         my ($self, $string) = @_;
183         return $self->{encoding_object}->encode($string);
184     }
185     sub decode {
186         my ($self, $string) = @_;
187         return eval { # returns undef on decode failure
188             $self->{encoding_object}->decode($string, Encode::FB_CROAK);
189         };
190     }
191
192     # Create attribute for the given fore-/background colors.
193     sub color_pair {
194         my ($self, $fg, $bg) = @_;
195
196         state $next_color_pair = 1; # must start at 1 for init_pair()
197
198         Curses::init_pair($next_color_pair, $fg, $bg);
199         return Curses::COLOR_PAIR($next_color_pair++);
200     }
201
202     # Draw a string which must fit in the current line. Wrapping/clipping is
203     # not supported and must be handled by the caller.
204     sub draw_simple {
205         my ($self, $y, $x, $attributes, $string) = @_;
206
207         die if $string =~ /\n/;
208         # FIXME: wide characters
209         die if $x + length $string > $self->width;
210
211         $self->{curses}->attron($attributes) if defined $attributes;
212         $self->{curses}->addstr($y, $x, $self->encode($string));
213         $self->{curses}->attroff($attributes) if defined $attributes;
214         return;
215     }
216     # Like draw_simple(), but the string is automatically clipped.
217     sub draw_clipped {
218         my ($self, $y, $x, $attributes, $string) = @_;
219
220         # FIXME: wide characters
221         $string = substr $string, 0, $self->width - $x;
222         $self->draw_simple($y, $x, $attributes, $string);
223         return;
224     }
225     sub draw {
226         my ($self, $y, $x, $attributes, $string) = @_;
227
228         die unless defined $string;
229
230         while (1) {
231             my $offset;
232             # We must print each line separately. Search for next newline or
233             # line end, whichever is closer.
234             if ($string =~ /\n/) {
235                 $offset = $-[0];
236             }
237             # FIXME: wide characters
238             if ($x + length $string > $self->width) {
239                 my $new_offset = $self->width - $x;
240                 if (not defined $offset or $offset > $new_offset) {
241                     $offset = $new_offset;
242                 }
243             }
244             last unless defined $offset;
245
246             # FIXME: wide characters
247             $self->draw_simple($y, $x, $attributes, substr $string, 0, $offset);
248
249             # Don't draw "\n" itself.
250             if ("\n" eq substr $string, $offset, 1) {
251                 $offset++;
252             }
253
254             $string = substr $string, $offset;
255
256             $y++;
257             $x = 0;
258         }
259
260         $self->draw_simple($y, $x, $attributes, $string);
261         return $y;
262     }
263
264     sub draw_prompt {
265         my ($self, $config) = @_;
266
267         my $x = 0;
268         my $y = $self->height - 1;
269
270         # Clear line for better visibility.
271         $self->draw_simple($y, $x, undef, ' ' x $self->width);
272
273         # Draw prompt flags.
274         if (defined (my $s = $self->{prompt}{flags})) {
275             $s = "[$s]";
276             $self->draw_clipped($y, $x, $config->{attribute}{prompt_flags}, $s);
277             $x += length($s) + 1; # space between next element
278         }
279         # Draw prompt name.
280         if (defined (my $s = $self->{prompt}{name})) {
281             $s = "[$s]";
282             $self->draw_clipped($y, $x, $config->{attribute}{prompt_name}, $s);
283             $x += length($s) + 1;
284         }
285         # Draw prompt value, e.g. a search field.
286         if (defined (my $s = $self->{prompt}{value})) {
287             $self->draw_clipped($y, $x, undef, $s);
288             $x += length($s) + 1;
289         }
290         return;
291     }
292
293     sub draw_matches {
294         my ($self, $config, $matches_remove, $matches_add) = @_;
295
296         foreach (@{$matches_remove}) {
297             $self->draw($_->{y}, $_->{x}, Curses::A_NORMAL, $_->{string});
298         }
299
300         my $attr_id     = $config->{attribute}{match_id};
301         my $attr_string = $config->{attribute}{match_string};
302
303         foreach (@{$matches_add}) {
304             $self->draw($_->{y}, $_->{x}, $attr_string, $_->{string});
305             if (defined $_->{id}) {
306                 $self->draw($_->{y}, $_->{x}, $attr_id, $_->{id});
307             }
308         }
309         return;
310     }
311
312     sub die {
313         my ($self, @args) = @_;
314
315         my $attr = $self->color_pair(Curses::COLOR_RED, -1) | Curses::A_BOLD;
316
317         # Clear the screen to improve visibility of the error message.
318         $self->{curses}->clear;
319
320         my $y = $self->draw(0, 0, $attr, "@args");
321
322         if ($self->{debug}) {
323             my $msg;
324             eval {
325                 require Devel::StackTrace;
326             };
327             if ($@) {
328                 $msg = "Devel::StackTrace missing, no stack trace.\n";
329             } else {
330                 my $trace = Devel::StackTrace->new;
331                 $msg = "Stack trace:\n" . $trace->as_string;
332             }
333             $y = $self->draw($y + 1, 0, Curses::A_NORMAL, $msg);
334         }
335
336         $self->draw($y + 1, 0, Curses::A_NORMAL,
337                     'Press any key to terminate fcscs.');
338         $self->refresh;
339
340         $self->getch;
341         $self->deinit;
342         exit 1;
343     }
344     sub debug {
345         my ($self, $module, @args) = @_;
346
347         return if not $self->{debug};
348
349         state $fh; # only open the file once per run
350         if (not defined $fh) {
351             # Ignore errors if the directory doesn't exist.
352             if (not open $fh, '>', "$ENV{HOME}/.config/fcscs/log") {
353                 $fh = undef; # a failed open still writes a value to $fh
354                 return;
355             }
356         }
357
358         say $fh "$module: @args";
359         return;
360     }
361
362
363     sub prompt {
364         my ($self, %settings) = @_;
365
366         foreach (keys %settings) {
367             CORE::die if not exists $self->{prompt}{$_};
368             $self->{prompt}{$_} = $settings{$_};
369         }
370         return;
371     }
372
373     # Wrapper for Curses.
374     sub width   { return $Curses::COLS; }
375     sub height  { return $Curses::LINES; }
376     sub refresh { return $_[0]->{curses}->refresh; }
377     sub getch   { return $_[0]->{curses}->getch; }
378     sub cursor  { Curses::curs_set($_[1]); return; }
379 }
380
381
382
383 # FUNCTIONS
384
385 sub prepare_input {
386     my ($screen, $input_ref) = @_;
387
388     # Make sure the input fits on the screen by removing the top lines if
389     # necessary.
390     splice @{$input_ref}, 0, -$screen->height;
391
392     # Pad each line with spaces to the screen width to correctly handle
393     # multi-line regexes.
394     # FIXME: wide characters
395     my @padded = map { sprintf '%-*s', $screen->width, $_ } @{$input_ref};
396
397     my $string = join "\n", @padded;
398     return {
399         string => $string,
400         lines  => $input_ref,
401         width  => $screen->width + 1,
402                   # + 1 = "\n", used in input_match_offset_to_coordinates
403     };
404 }
405
406 sub input_match_offset_to_coordinates {
407     my ($width, $offset) = @_;
408
409     die unless defined $offset;
410
411     my $y = int($offset / $width);
412     my $x = $offset - $y * $width;
413     return ($x, $y);
414 }
415
416 sub get_regex_matches {
417     my ($input, $regex) = @_;
418
419     my @matches;
420     while ($input->{string} =~ /$regex/g) {
421         my $offset = $-[1];
422         die "Match group required in regex '$regex'" if not defined $offset;
423
424         my ($x, $y) = input_match_offset_to_coordinates($input->{width},
425                                                         $offset);
426         push @matches, { x => $x, y => $y, offset => $offset, string => $1 };
427     }
428     return @matches;
429 }
430
431
432 sub run_command {
433     my ($screen, $config, $cmd) = @_;
434
435     $screen->debug('run_command', "running @{$cmd}");
436
437     my $exit = do {
438         # Perl's system() combined with a $SIG{__WARN__} which die()s has
439         # issues due to the fork. The die() in the __WARN__ handler doesn't
440         # die but the program continues after the system().
441         #
442         # If the forked process fails to exec (e.g. program not found) then
443         # the __WARN__ handler is called (because a warning is about to be
444         # displayed) and the die() should display a message and terminate the
445         # process. But due to the fork it doesn't terminate the parent process
446         # and instead changes the return value of system(); it's no longer -1
447         # which makes it impossible to detect that case.
448         #
449         # Perl < 5.18 (found in 5.14) doesn't setup $$ during system() which
450         # makes it impossible to detect if the handler was called from inside
451         # the child.
452         #
453         # Instead, just ignore any warnings during the system(). Thanks to
454         # mauke in #perl on Freenode (2013-10-29 23:30 CET) for the idea to
455         # use no warnings and anno for testing a more recent Perl version with
456         # a working $$.
457         no warnings;
458
459         system { $cmd->[0] } @{$cmd};
460     };
461     if ($exit != 0) {
462         my $msg;
463         if ($? == -1) {
464             $msg = 'failed to execute: ' . $!;
465         } elsif ($? & 127) {
466             $msg = 'killed by signal ' . ($? & 127);
467         } else {
468             $msg = 'exited with code ' . ($? >> 8);
469         }
470         die "system(@{$cmd}) $msg.";
471     }
472     return;
473 }
474 sub run_in_background {
475     my ($screen, $sub) = @_;
476
477     $screen->debug('run_in_background', "running $sub");
478
479     my $pid = fork;
480     defined $pid or die $!;
481
482     if ($pid == 0) {
483         # The terminal multiplexer sends a SIGHUP to the process when it
484         # closes the window (because the parent process has exited).
485         local $SIG{HUP} = 'IGNORE';
486
487         # Necessary for GNU screen or it'll keep the window open until the
488         # paste command has run.
489         close STDIN  or die $!;
490         close STDOUT or die $!;
491         close STDERR or die $!;
492
493         # Double-fork to prevent zombies.
494         my $pid = fork;
495         defined $pid or die $!;
496         if ($pid == 0) { # child
497             $sub->();
498         }
499         exit;
500     }
501     waitpid $pid, 0 or die $!;
502     return;
503 }
504
505
506 sub select_match {
507     my ($name, $screen, $config, $input, $matches) = @_;
508
509     $screen->debug('select_match', 'started');
510
511     return if @{$matches} == 0;
512     # Don't return on initial run to give the user a chance to select another
513     # mode, e.g. to switch from URL selection to search selection.
514     if (@{$matches} == 1 and not $config->{state}{initial}) {
515         return { match => $matches->[0] };
516     }
517     $config->{state}{initial} = 0;
518
519     my @sorted = sort { $b->{y} <=> $a->{y} or $b->{x} <=> $a->{x} } @{$matches};
520
521     my $i = 1;
522     foreach (@sorted) {
523         $_->{id} = $i++;
524     }
525
526     $screen->prompt(name => $name, value => undef);
527     $screen->draw_prompt($config);
528
529     $screen->draw_matches($config, [], $matches);
530     $screen->refresh;
531
532     my $number = 0;
533     while (1) {
534         my $char = $screen->getch;
535         if ($char =~ /^\d$/) {
536             $number = $number * 10 + $char;
537         } elsif ($char eq "\b" or $char eq "\x7f") { # backspace
538             $number = int($number / 10);
539         } elsif ($char eq "\n") {
540             if ($number == 0) { # number without selection matches last entry
541                 $number = 1;
542             }
543             last;
544
545         # Selecting a new mode requires falling through into the main input
546         # loop and then starting the new mode.
547         } elsif (defined $config->{mapping}{mode}{$char}) {
548             $screen->draw_matches($config, $matches, []); # clear matches
549             return { key => $char };
550         # All other mappings stay in the current mode.
551         } elsif (defined (my $m = $config->{mapping}{simple}{$char})) {
552             $m->($char, $screen, $config, $input);
553             next;
554
555         } else {
556             next; # ignore unknown mappings
557         }
558
559         last if $number > 0 and $number * 10 > @{$matches}; # unique match
560
561         my @remaining = $number == 0
562                       ? @{$matches}
563                       : grep { $_->{id} =~ /^$number/ } @{$matches};
564         $screen->draw_matches($config, $matches, \@remaining);
565         $screen->refresh;
566     }
567
568     $screen->draw_matches($config, $matches, []); # remove matches
569
570     foreach (@{$matches}) {
571         return { match => $_ } if $_->{id} == $number;
572     }
573     $screen->debug('select_match', 'no match selected');
574     return { match => undef };
575 }
576
577 sub extend_match_regex_left {
578     my ($line, $match, $regex) = @_;
579
580     my $s = reverse substr $line, 0, $match->{x};
581     if ($s =~ /^($regex)/) {
582         $match->{string}  = reverse($1) . $match->{string};
583         $match->{x}      -= length $1;
584         $match->{offset} -= length $1;
585     }
586     return;
587 }
588 sub extend_match_regex_right {
589     my ($line, $match, $regex) = @_;
590
591     my $s = substr $line, $match->{x} + length $match->{string};
592     if ($s =~ /^($regex)/) {
593         $match->{string} .= $1;
594     }
595     return;
596 }
597 sub extend_match {
598     my ($screen, $config, $input, $match) = @_;
599
600     $screen->debug('extend_match', 'started');
601
602     $screen->prompt(name => 'extend', value => undef);
603     $screen->draw_prompt($config);
604
605     delete $match->{id}; # don't draw any match ids
606     $screen->draw_matches($config, [], [$match]);
607     $screen->refresh;
608
609     my $line = $input->{lines}[$match->{y}];
610
611     while (1) {
612         my $match_old = \%{$match};
613
614         my $char = $screen->getch;
615         if ($char eq "\n") { # accept match
616             last;
617
618         } elsif ($char eq 'w') { # select current word (both directions)
619             extend_match_regex_left($line,  $match, qr/\w+/);
620             extend_match_regex_right($line, $match, qr/\w+/);
621         } elsif ($char eq 'b') { # select current word (only left)
622             extend_match_regex_left($line,  $match, qr/\w+/);
623         } elsif ($char eq 'e') { # select current word (only right)
624             extend_match_regex_right($line, $match, qr/\w+/);
625
626         } elsif ($char eq 'W') { # select current WORD (both directions)
627             extend_match_regex_left($line,  $match, qr/\S+/);
628             extend_match_regex_right($line, $match, qr/\S+/);
629         } elsif ($char eq 'B') { # select current WORD (only left)
630             extend_match_regex_left($line,  $match, qr/\S+/);
631         } elsif ($char eq 'E') { # select current WORD (only right)
632             extend_match_regex_right($line, $match, qr/\S+/);
633
634         } elsif ($char eq '^') { # select to beginning of line
635             extend_match_regex_left($line, $match, qr/.+/);
636         } elsif ($char eq '$') { # select to end of line
637             extend_match_regex_right($line, $match, qr/.+/);
638
639         # Allow mode changes if not overwritten by local mappings.
640         } elsif (defined $config->{mapping}{mode}{$char}) {
641             $screen->draw_matches($config, [$match_old], []); # clear match
642             return { key => $char };
643
644         } else {
645             next; # ignore unknown mappings
646         }
647
648         $screen->draw_matches($config, [$match_old], [$match]);
649         $screen->refresh;
650     }
651
652     $screen->debug('extend_match', 'done');
653
654     return { match => $match };
655 }
656
657
658 sub mapping_paste {
659     my ($key, $screen, $config, $input) = @_;
660
661     $screen->debug('mapping_paste', 'started');
662
663     $config->{state}{handler} = $config->{handler}{paste};
664
665     $screen->prompt(flags => 'P'); # paste
666     $screen->draw_prompt($config);
667     $screen->refresh;
668
669     return {};
670 }
671 sub mapping_yank {
672     my ($key, $screen, $config, $input) = @_;
673
674     $screen->debug('mapping_yank', 'started');
675
676     $config->{state}{handler} = $config->{handler}{yank};
677
678     $screen->prompt(flags => 'Y'); # yank
679     $screen->draw_prompt($config);
680     $screen->refresh;
681
682     return {};
683 }
684
685
686 =head2 NORMAL MODES
687
688 Normal modes select matches by calling a function which returns them, e.g. by
689 using a regex.
690
691 The following normal modes are available:
692
693 =over 4
694
695 =item B<path mode> select relative/absolute paths
696
697 =item B<url mode>  select URLs
698
699 =back
700
701 =cut
702 sub mapping_mode_path {
703     my ($key, $screen, $config, $input) = @_;
704
705     $screen->debug('mapping_mode_path', 'started');
706
707     my @matches = get_regex_matches($input, $config->{regex}{path});
708     return {
709         select  => 'path select',
710         matches => \@matches,
711         handler => $config->{handler}{yank},
712     };
713 }
714 sub mapping_mode_url {
715     my ($key, $screen, $config, $input) = @_;
716
717     $screen->debug('mapping_mode_url', 'started');
718
719     my @matches = get_regex_matches($input, $config->{regex}{url});
720     return {
721         select  => 'url select',
722         matches => \@matches,
723         handler => $config->{handler}{url},
724     };
725 }
726
727 =head2 SEARCH MODE (AND EXTEND MODE)
728
729 Search mode is a special mode which lets you type a search string (a Perl
730 regex) and then select one of the matches. Afterwards you can extend the
731 match. For example select the complete word or to the end of the line. This
732 allows quick selection of arbitrary text.
733
734 The following mappings are available during the extension mode (not
735 configurable at the moment):
736
737 =over 4
738
739 =item B<w> select current word
740
741 =item B<b> extend word to the left
742
743 =item B<e> extend word to the right
744
745 =item B<W> select current WORD
746
747 =item B<B> extend WORD to the left
748
749 =item B<E> extend WORD to the right
750
751 =item B<^> extend to beginning of line
752
753 =item B<$> extend to end of line
754
755 =back
756
757 C<word> includes any characters matching C<\w+>, C<WORD> any non-whitespace
758 characters (C<\S+>), just like in Vim.
759
760 =cut
761 sub mapping_mode_search {
762     my ($key, $screen, $config, $input) = @_;
763
764     $screen->debug('mapping_mode_search', 'started');
765
766     $screen->cursor(1);
767
768     my $search = ''; # encoded
769     my @last_matches;
770     while (1) {
771         # getch doesn't return decoded characters but raw input bytes. Wait
772         # until the input character is complete.
773         my $value = $screen->decode($search);
774         $value = '' unless defined $value; # undef on decode failure
775
776         $screen->prompt(name => 'search', value => $value);
777         $screen->draw_prompt($config);
778         $screen->refresh;
779
780         my $char = $screen->getch;
781         # TODO: readline editing support
782         if ($char eq "\n") {
783             last;
784         } elsif ($char eq "\b" or $char eq "\x7f") { # backspace
785             # Remove a character, not a byte.
786             $search = $screen->decode($search);
787             chop $search;
788             $search = $screen->encode($search);
789         } else {
790             $search .= $char;
791             next unless defined $screen->decode($search);
792         }
793
794         my @matches;
795         if ($search ne '') {
796             my $case = '';
797             if (($config->{setting}{smartcase} and $search eq lc $search)
798                     or $config->{setting}{ignorecase}) {
799                 $case = '(?i)';
800             }
801             # Ignore invalid regexps.
802             # TODO: display warning on error?
803             eval {
804                 @matches = get_regex_matches($input, qr/($case$search)/);
805             };
806         }
807         $screen->draw_matches($config, \@last_matches, \@matches);
808         @last_matches = @matches;
809     }
810
811     $screen->cursor(0);
812
813     return {
814         select  => 'search',
815         matches => \@last_matches,
816         extend  => 1,
817         handler => $config->{handler}{yank},
818     };
819 }
820
821 sub mapping_quit {
822     my ($key, $screen, $config, $input) = @_;
823
824     # Key is necessary to fall through to main event loop which then quits.
825     return { key => $key, quit => 1 };
826 }
827
828
829 sub handler_yank {
830     my ($screen, $config, $match) = @_;
831
832     $screen->debug('handler_yank', 'started');
833
834     require File::Temp;
835
836     # Use a temporary file to prevent leaking the yanked data to other users
837     # with the command line, e.g. ps aux or top.
838     my ($fh, $tmp) = File::Temp::tempfile(); # dies on its own
839     print $fh $screen->encode($match->{value});
840     close $fh or die $!;
841
842     if ($config->{setting}{multiplexer} eq 'screen') {
843         $screen->debug('handler_yank', 'using screen');
844
845         # GNU screen displays an annoying "Slurping X characters into buffer".
846         # Use 'msgwait 0' as a hack to disable it.
847         my $msgwait = $config->{setting}{screen_msgwait};
848         run_command($screen, $config, ['screen', '-X', 'msgwait', 0]);
849         run_command($screen, $config, ['screen', '-X', 'readbuf', $tmp]);
850         run_command($screen, $config, ['screen', '-X', 'msgwait', $msgwait]);
851     } elsif ($config->{setting}{multiplexer} eq 'tmux') {
852         $screen->debug('handler_yank', 'using tmux');
853
854         run_command($screen, $config, ['tmux', 'load-buffer', $tmp]);
855     } else {
856         die 'unsupported multiplexer';
857     }
858
859     unlink $tmp or die $!;
860     return;
861 }
862 sub handler_paste {
863     my ($screen, $config, $match) = @_;
864
865     $screen->debug('handler_paste', 'started');
866
867     require Time::HiRes;
868
869     my @cmd;
870     if ($config->{setting}{multiplexer} eq 'screen') {
871         $screen->debug('handler_paste', 'using screen');
872         @cmd = qw( screen -X paste . );
873     } elsif ($config->{setting}{multiplexer} eq 'tmux') {
874         $screen->debug('handler_paste', 'using tmux');
875         @cmd = qw( tmux paste-buffer );
876     } else {
877         die 'unsupported multiplexer';
878     }
879
880     run_in_background($screen, sub {
881         # We need to get the data in the paste buffer before we can paste
882         # it.
883         handler_yank($screen, $config, $match);
884
885         # Sleep until we switch back to the current window.
886         Time::HiRes::usleep($config->{setting}{paste_sleep});
887
888         run_command($screen, $config, \@cmd);
889     });
890     return;
891 }
892 sub handler_url {
893     my ($screen, $config, $match) = @_;
894
895     $screen->debug('handler_url', "opening $match->{value}");
896
897     run_in_background($screen, sub {
898         my @cmd = map { $screen->encode($_) } (
899             @{$config->{setting}{browser}},
900             $match->{value},
901         );
902         run_command($screen, $config, \@cmd);
903     });
904     return;
905 }
906
907
908
909 # CONFIGURATION DEFAULTS
910
911 =head1 CONFIGURATION
912
913 fcscs is configured through F<~/.fcscsrc> or F<~/.config/fcscs/fcscsrc> which
914 is a normal Perl script with all of Perl's usual features.
915
916 All configuration values are stored in the hash C<%config>. All manually
917 defined keys overwrite the default settings.
918
919 A simple F<~/.fcscsrc> could look like this (for details about the used
920 settings see below):
921
922     use strict;
923     use warnings;
924
925     use Curses; # for COLOR_* and A_* constants
926
927     our %config;
928
929     # Draw matches in blue.
930     $config{attribute}{match_string} = color_pair(COLOR_BLUE, -1);
931     # Enable Vim-like 'smartcase', ignore case until an upper character is
932     # searched.
933     $config{setting}{smartcase} = 1;
934
935     # Use chromium to open URLs if running under X, elinks otherwise.
936     if (defined $ENV{DISPLAY}) {
937         $config{setting}{browser} = ['chromium'];
938     } else {
939         $config{setting}{browser} = ['elinks'];
940     }
941
942     # Let fcscs know the file was loaded successfully.
943     1;
944
945 =cut
946
947
948 if (@ARGV != 1) {
949     require Pod::Usage;
950     Pod::Usage::pod2usage(2);
951 }
952
953
954 # Determine terminal encoding from the environment ($ENV{LANG} or similar).
955 my $encoding = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET);
956
957 my $screen = Screen->init($encoding);
958
959 # We must restore the screen before exiting.
960 local $SIG{INT} = sub {
961     $screen->deinit;
962     exit 128 + 2;
963 };
964 # Make all warnings fatal to make sure they don't get lost (stderr is normally
965 # not displayed).
966 local $SIG{__WARN__} = sub {
967     $screen->die('warning', @_);
968 };
969
970
971
972 =head2 MAPPINGS
973
974 I<NOTE>: Mappings are split in two categories: Mode mappings which change the
975 selection and may receive additional input (e.g. a search string) and simple
976 mappings which only change some value. Mode mappings are configured via
977 C<$config{mapping}{mode}>, simple mappings via C<$config{mapping}{simple}>.
978
979 The following mode mappings are available by default (the function to remap
980 them in parentheses):
981
982 =over
983
984 =item B<f> select absolute/relative paths (C<\&mapping_mode_path>)
985
986 =item B<u> select URLs (C<\&mapping_mode_url>)
987
988 =item B</> search for regex to get selection (C<\&mapping_mode_search>)
989
990 =item B<q> quit fcscs (C<\&mapping_quit>)
991
992 =back
993
994 The following simple mappings are available by default:
995
996 =over
997
998 =item B<p> enable pasting (C<\&mapping_paste>)
999
1000 =item B<y> enable yanking (copying) (C<\&mapping_yank>)
1001
1002 =back
1003
1004 All (single-byte) keys except numbers, backspace and return can be mapped.
1005
1006 Unknown mappings are ignored when pressing keys.
1007
1008 To remove a default mapping, delete it from the mapping hash.
1009
1010 Example:
1011
1012     # Map 'p' to select paths, 'P' to enable pasting.
1013     $config{mapping}{mode}{p} = \&mapping_mode_path;
1014     $config{mapping}{simple}{P} = \&mapping_paste;
1015
1016     # Disable 'f' mapping.
1017     delete $config{mapping}{mode}{f};
1018
1019 =cut
1020 my %mapping_mode = (
1021     f   => \&mapping_mode_path,
1022     u   => \&mapping_mode_url,
1023     '/' => \&mapping_mode_search,
1024     q   => \&mapping_quit,
1025 );
1026 my %mapping_simple = (
1027     p => \&mapping_paste,
1028     y => \&mapping_yank,
1029 );
1030
1031 =head2 ATTRIBUTES
1032
1033 Attributes are used to style the output. They must be Curses attributes.
1034 Defaults in parentheses (foreground, background, attribute).
1035
1036 =over
1037
1038 =item B<match_id>      attribute for match numbers (red, default, bold)
1039
1040 =item B<match_string>  attribute for matches (yellow, default, normal)
1041
1042 =item B<prompt_name>   attribute for prompt name (standout)
1043
1044 =item B<prompt_flags>  attribute for prompt flags (standout)
1045
1046 =back
1047
1048 Example:
1049
1050     # Draw prompt flags in bold red with default background color.
1051     $config{attribute}{prompt_flags}
1052         = Curses::A_BOLD
1053         | color_pair(Curses::COLOR_RED, -1);
1054
1055 =cut
1056 my %attribute = (
1057     match_id     => $screen->color_pair(Curses::COLOR_RED, -1)
1058                     | Curses::A_BOLD,
1059     match_string => $screen->color_pair(Curses::COLOR_YELLOW, -1),
1060     prompt_name  => Curses::A_STANDOUT,
1061     prompt_flags => Curses::A_STANDOUT,
1062 );
1063
1064 =head2 SETTINGS
1065
1066 Defaults in parentheses.
1067
1068 =over
1069
1070 =item B<debug>          enable debug mode, writes to I<~/.config/fcscs/log> (C<0>)
1071
1072 =item B<initial_mode>   start in this mode, must be a valid mode mapping (C<\&mapping_mode_url>)
1073
1074 =item B<multiplexer>    set multiplexer ("screen" or "tmux") if not autodetected (C<undef>)
1075
1076 =item B<ignorecase>     ignore case when searching (C<0>)
1077
1078 =item B<smartcase>      ignore case unless one uppercase character is searched (C<1>)
1079
1080 =item B<paste_sleep>    sleep x us before running paste command (C<100_000>)
1081
1082 =item B<screen_msgwait> GNU Screen's msgwait variable, used when yanking (C<5>)
1083
1084 =item B<browser>        browser command as array reference (C<['x-www-browser']>)
1085
1086 =back
1087
1088 Example:
1089
1090     # Select paths on startup instead of URLs.
1091     $config{setting}{initial_mode} = \&mapping_mode_path;
1092
1093 =cut
1094 my %setting = (
1095     # options
1096     debug          => 0,
1097     initial_mode   => \&mapping_mode_url,
1098     multiplexer    => undef,
1099     ignorecase     => 0,
1100     smartcase      => 1,
1101     paste_sleep    => 100_000,
1102     screen_msgwait => 5,
1103     # commands
1104     browser        => ['x-www-browser'],
1105 );
1106
1107 =head2 REGEXPS
1108
1109 =over
1110
1111 =item B<url>  used by C<\&mapping_mode_url()>
1112
1113 =item B<path> used by C<\&mapping_mode_path()>
1114
1115 =back
1116
1117 Example:
1118
1119     # Select all non-whitespace characters when searching for paths.
1120     $config{regex}{path} = qr{(\S+)};
1121
1122 =cut
1123 my %regex = (
1124     # Taken from urlview's default configuration file, thanks.
1125     url  => qr{((?:(?:(?:http|https|ftp|gopher)|mailto):(?://)?[^ <>"\t]*|(?:www|ftp)[0-9]?\.[-a-z0-9.]+)[^ .,;\t\n\r<">\):]?[^, <>"\t]*[^ .,;\t\n\r<">\):])},
1126     path => qr{(~?[a-zA-Z0-9_./-]*/[a-zA-Z0-9_./-]+)},
1127 );
1128
1129 =head2 HANDLERS
1130
1131 Handlers are used to perform actions on the selected string.
1132
1133 The following handlers are available, defaults in parentheses.
1134
1135 =over
1136
1137 =item B<yank>  used to yank (copy) selection to paste buffer (C<\&handler_yank>)
1138
1139 =item B<paste> used to paste selection into window (C<\&handler_paste>)
1140
1141 =item B<url>   used to open URLs (e.g. in a browser) (C<\&handler_url>)
1142
1143 =back
1144
1145 Example:
1146
1147     # Download YouTube videos with a custom wrapper, handle all other URLs
1148     # with the default URL handler.
1149     $config{handler}{url} = sub {
1150         my ($screen, $config, $match) = @_;
1151
1152         if ($match->{value} =~ m{^https://www.youtube.com/}) {
1153             return run_in_background($screen, sub {
1154                 run_command($screen, $config,
1155                             ['youtube-dl-wrapper', $match->{value}]);
1156             });
1157         }
1158         handler_url(@_);
1159     };
1160
1161 =cut
1162 my %handler = (
1163     yank  => \&handler_yank,
1164     paste => \&handler_paste,
1165     url   => \&handler_url,
1166 );
1167
1168 my %state = (
1169     initial => 1, # used by select_match() for 'initial_mode'
1170     handler => undef,
1171 );
1172
1173
1174
1175 # CONFIGURATION "API"
1176
1177 =head2 FUNCTIONS
1178
1179 The following functions are available:
1180
1181     color_pair($fg, $bg)
1182
1183 Create a new Curses attribute with the given fore- and background color.
1184
1185     mapping_mode_path()
1186     mapping_mode_url()
1187     mapping_mode_search()
1188
1189     mapping_paste()
1190     mapping_yank()
1191     mapping_quit()
1192
1193 Used as mappings, see L</MAPPINGS> above.
1194
1195     handler_yank()
1196     handler_paste()
1197     handler_url()
1198
1199 Used as handler to yank, paste selection or open URL in browser.
1200
1201     debug()
1202     get_regex_matches()
1203     select_match()
1204     run_command()
1205     run_in_background()
1206
1207 Helper functions when writing custom mappings, see the source for details.
1208
1209 Example:
1210
1211     TODO
1212
1213 =cut
1214
1215 # All variables and functions which are usable by ~/.fcscsrc.
1216 package Fcscs {
1217     our $screen; # "private"
1218     our %config;
1219
1220     sub color_pair { return $screen->color_pair(@_); }
1221
1222     sub mapping_mode_path { return main::mapping_mode_path(@_); }
1223     sub mapping_mode_url { return main::mapping_mode_url(@_); }
1224     sub mapping_mode_search { return main::mapping_mode_search(@_); }
1225
1226     sub mapping_paste { return main::mapping_paste(@_); }
1227     sub mapping_yank { return main::mapping_yank(@_); }
1228     sub mapping_quit { return main::mapping_quit(@_); }
1229
1230     sub handler_yank { return main::handler_yank(@_); }
1231     sub handler_paste { return main::handler_paste(@_); }
1232     sub handler_url { return main::handler_url(@_); }
1233
1234     sub debug { return main::debug(@_); }
1235
1236     sub get_regex_matches { return main::get_regex_matches(@_); }
1237     sub select_match { return main::select_match(@_); }
1238
1239     sub run_command { return main::run_command(@_); }
1240     sub run_in_background { return main::run_in_background(@_); }
1241 }
1242 $Fcscs::screen = $screen;
1243
1244
1245
1246 # LOAD USER CONFIG
1247
1248 # Alias %config and %Fcscs::config. %config is less to type.
1249 our %config;
1250 local *config = \%Fcscs::config;
1251
1252 $config{mapping}{mode}   = \%mapping_mode;
1253 $config{mapping}{simple} = \%mapping_simple;
1254 $config{attribute}       = \%attribute;
1255 $config{setting}         = \%setting;
1256 $config{regex}           = \%regex;
1257 $config{handler}         = \%handler;
1258 $config{state}           = \%state;
1259
1260 package Fcscs {
1261     my @configs = ("$ENV{HOME}/.fcscsrc",
1262                    "$ENV{HOME}/.config/fcscs/fcscsrc");
1263     foreach my $path (@configs) {
1264         my $decoded = $screen->decode($path);
1265
1266         # Load configuration file. Checks have a race condition if the home
1267         # directory is writable by an attacker (but then the user is screwed
1268         # anyway).
1269         next unless -e $path;
1270         if (not -O $path) {
1271             $screen->die("Config '$decoded' not owned by current user!");
1272         }
1273         # Make sure the file is not writable by other users. Doesn't handle
1274         # ACLs and see comment above about race conditions.
1275         my @stat = stat $path or die $!;
1276         my $mode = $stat[2];
1277         if (($mode & Fcntl::S_IWGRP) or ($mode & Fcntl::S_IWOTH)) {
1278             die "Config '$decoded' must not be writable by other users.";
1279         }
1280
1281         my $result = do $path;
1282         if (not $result) {
1283             $screen->die("Failed to parse '$decoded': $@") if $@;
1284             $screen->die("Failed to do '$decoded': $!") unless defined $result;
1285             $screen->die("Failed to run '$decoded'.");
1286         }
1287
1288         last; # success, don't load more files
1289     }
1290 }
1291 $screen->{debug} = $config{setting}{debug};
1292
1293
1294 # MAIN
1295
1296 eval {
1297     # Auto-detect current multiplexer.
1298     if (not defined $config{setting}{multiplexer}) {
1299         if (defined $ENV{STY} and defined $ENV{TMUX}) {
1300             die 'Found both $STY and $TMUX, set $config{setting}{multiplexer}.';
1301         } elsif (defined $ENV{STY}) {
1302             $config{setting}{multiplexer} = 'screen';
1303         } elsif (defined $ENV{TMUX}) {
1304             $config{setting}{multiplexer} = 'tmux';
1305         } else {
1306             die 'No multiplexer found.';
1307         }
1308     }
1309
1310     my $binmode = $encoding;
1311     # GNU screen stores the screen dump for unknown reasons as ISO-8859-1
1312     # instead of the currently active encoding.
1313     if ($config{setting}{multiplexer} eq 'screen') {
1314         $binmode = 'ISO-8859-1';
1315     }
1316
1317     my @input_lines;
1318     open my $fh, '<', $ARGV[0] or die $!;
1319     binmode $fh, ":encoding($binmode)" or die $!;
1320     while (<$fh>) {
1321         chomp;
1322         push @input_lines, $_;
1323     }
1324     close $fh or die $!;
1325
1326     my $input = prepare_input($screen, \@input_lines);
1327
1328     # Display original screen content.
1329     my $y = 0;
1330     foreach (@{$input->{lines}}) {
1331         $screen->draw_simple($y++, 0, undef, $_);
1332     }
1333     $screen->refresh;
1334
1335
1336     my $mapping = $config{setting}{initial_mode};
1337
1338     my $key;
1339     while (1) {
1340         if (not defined $mapping) {
1341             $key = $screen->getch unless defined $key;
1342             $screen->debug('input', "got key '$key'");
1343
1344             $mapping = $config{mapping}{mode}{$key};
1345             $mapping = $config{mapping}{simple}{$key} unless defined $mapping;
1346             if (not defined $mapping) { # ignore unknown mappings
1347                 $key = undef;
1348                 next;
1349             }
1350         }
1351
1352         $screen->debug('input', 'running mapping');
1353         my $result = $mapping->($key, $screen, \%config, $input);
1354         $mapping = undef;
1355
1356 RESULT:
1357         if (defined $result->{quit}) {
1358             $screen->debug('input', 'quitting');
1359             last;
1360         }
1361         if (defined $result->{key}) {
1362             $key = $result->{key}; # lookup another mapping
1363             $screen->debug('input', "processing new key: '$key'");
1364             next;
1365         }
1366         if (defined $result->{select}) {
1367             $screen->debug('input', 'selecting match');
1368             my $tmp = $result;
1369             $result = select_match($result->{select},
1370                                 $screen, \%config, $input,
1371                                 $result->{matches});
1372             $result->{handler} = $tmp->{handler};
1373             $result->{extend}  = $tmp->{extend};
1374             goto RESULT; # reprocess special entries in result
1375         }
1376         if (defined $result->{extend}) {
1377             $screen->debug('input', 'extending match');
1378             $result = extend_match($screen, \%config, $input,
1379                                    $result->{match});
1380             goto RESULT; # reprocess special entries in result
1381         }
1382         if (defined $result->{match}) {
1383             if (not defined $result->{match}{value}) {
1384                 $result->{match}{value} = $result->{match}{string};
1385             }
1386
1387             $screen->debug('input', 'running handler');
1388
1389             # Choose handler with falling priority.
1390             my @handlers = (
1391                 $config{state}{handler},     # set by user
1392                 $result->{match}{handler},   # set by match
1393                 $result->{handler},          # set by mapping
1394                 $config{handler}{yank},      # fallback
1395             );
1396             foreach my $handler (@handlers) {
1397                 next unless defined $handler;
1398
1399                 $handler->($screen, \%config, $result->{match});
1400                 last;
1401             }
1402             last;
1403         }
1404
1405         $key = undef; # get next key from user
1406     }
1407 };
1408 if ($@) {
1409     $screen->die("$@");
1410 }
1411
1412 $screen->deinit;
1413
1414 __END__
1415
1416 =head1 EXIT STATUS
1417
1418 =over 4
1419
1420 =item B<0>
1421
1422 Success.
1423
1424 =item B<1>
1425
1426 An error occurred.
1427
1428 =item B<2>
1429
1430 Invalid arguments/options.
1431
1432 =back
1433
1434 =head1 AUTHOR
1435
1436 Simon Ruderich E<lt>simon@ruderich.orgE<gt>
1437
1438 =head1 LICENSE AND COPYRIGHT
1439
1440 Copyright (C) 2013-2016 by Simon Ruderich
1441
1442 This program is free software: you can redistribute it and/or modify
1443 it under the terms of the GNU General Public License as published by
1444 the Free Software Foundation, either version 3 of the License, or
1445 (at your option) any later version.
1446
1447 This program is distributed in the hope that it will be useful,
1448 but WITHOUT ANY WARRANTY; without even the implied warranty of
1449 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1450 GNU General Public License for more details.
1451
1452 You should have received a copy of the GNU General Public License
1453 along with this program.  If not, see E<lt>http://www.gnu.org/licenses/E<gt>.
1454
1455 =head1 SEE ALSO
1456
1457 L<screen(1)>, L<tmux(1)>, L<urlview(1)>
1458
1459 =cut