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