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         - 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> or F<~/.config/fcscs/fcscsrc> which
 992 is a normal Perl script with all of Perl's usual features.
 993
 994 All configuration values are stored in the hash C<%config>. All manually
 995 defined keys overwrite the default settings.
 996
 997 A simple F<~/.fcscsrc> could look like this (for details about the used
 998 settings see below):
 999
1000     use strict;
1001     use warnings;
1002
1003     use Curses; # for COLOR_* and A_* constants
1004
1005     our %config;
1006
1007     # Draw matches in blue.
1008     $config{attribute}{match_string} = color_pair(COLOR_BLUE, -1);
1009     # Draw numbers in bold yellow.
1010     $config{attribute}{match_id} = color_pair(COLOR_YELLOW, -1)
1011                                  | A_BOLD;
1012     # Disable Vim-like 'smartcase', ignore case until an upper character is
1013     # searched.
1014     $config{setting}{smartcase} = 0;
1015
1016     # Use chromium to open URLs if running under X, elinks otherwise.
1017     if (defined $ENV{DISPLAY}) {
1018         $config{setting}{browser} = ['chromium'];
1019     } else {
1020         $config{setting}{browser} = ['elinks', '-remote'];
1021     }
1022
1023     # Let fcscs know the file was loaded successfully.
1024     1;
1025
1026 =cut
1027
1028
1029 if (@ARGV != 1) {
1030     require Pod::Usage;
1031     Pod::Usage::pod2usage(2);
1032 }
1033
1034
1035 # Determine terminal encoding from the environment ($ENV{LANG} or similar).
1036 my $encoding = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET);
1037
1038 my $screen = Screen->init($encoding);
1039
1040 # We must restore the screen before exiting.
1041 local $SIG{INT} = sub {
1042     $screen->deinit;
1043     exit 128 + 2;
1044 };
1045 # Make all warnings fatal to make sure they don't get lost (stderr is normally
1046 # not displayed).
1047 local $SIG{__WARN__} = sub {
1048     $screen->die('warning', @_);
1049 };
1050
1051
1052
1053 =head2 MAPPINGS
1054
1055 I<NOTE>: Mappings are split in two categories: Mode mappings which change the
1056 selection and may receive additional input (e.g. a search string) and simple
1057 mappings which only change some config value. Mode mappings are configured via
1058 C<$config{mapping}{mode}>, simple mappings via C<$config{mapping}{simple}>.
1059
1060 The following mode mappings are available by default (the function to remap
1061 them in parentheses):
1062
1063 =over
1064
1065 =item B<f> select absolute/relative paths (C<\&mapping_mode_path>)
1066
1067 =item B<u> select URLs (C<\&mapping_mode_url>)
1068
1069 =item B<i> select IPv4 and IPv6 addresses (C<\&mapping_mode_ip>)
1070
1071 =item B<c> select checksums (e.g. MD5, SHA) (C<\&mapping_mode_checksum>)
1072
1073 =item B</> search for regex to get selection (C<\&mapping_mode_search>)
1074
1075 =item B<q> quit fcscs (C<\&mapping_quit>)
1076
1077 =back
1078
1079 The following simple mappings are available by default:
1080
1081 =over
1082
1083 =item B<p> enable pasting (C<\&mapping_paste>)
1084
1085 =item B<P> paste current selection (like C<\n> but paste) (C<\&mapping_paste_now>)
1086
1087 =item B<y> enable yanking (copying) (C<\&mapping_yank>)
1088
1089 =item B<Y> yank current selection (like C<\n> but yank) (C<\&mapping_yank_now>)
1090
1091 =back
1092
1093 Note that yanking only uses the GNU screen or Tmux paste buffer by default. To
1094 also copy to X11 selection, enable the B<yank_x11> option.
1095
1096 The following additional mappings are available by default:
1097
1098 =over
1099
1100 =item B<\n> accept current selection (not customizable)
1101
1102 =item B<s>  additional key to accept selection (B<alternative_return> option)
1103
1104 =back
1105
1106 All (single-byte) keys except numbers, backspace and return can be mapped.
1107
1108 Unknown mappings are ignored when pressing keys.
1109
1110 To remove a default mapping, delete it from the mapping hash.
1111
1112 Example:
1113
1114     # Map 'p' to select paths, 'P' to enable pasting.
1115     $config{mapping}{mode}{p} = \&mapping_mode_path;
1116     $config{mapping}{simple}{P} = \&mapping_paste;
1117
1118     # Disable 'f' mapping.
1119     delete $config{mapping}{mode}{f};
1120
1121 =cut
1122 my %mapping_mode = (
1123     f   => \&mapping_mode_path,
1124     u   => \&mapping_mode_url,
1125     i   => \&mapping_mode_ip,
1126     c   => \&mapping_mode_checksum,
1127     '/' => \&mapping_mode_search,
1128     q   => \&mapping_quit,
1129 );
1130 my %mapping_simple = (
1131     p => \&mapping_paste,
1132     P => \&mapping_paste_now,
1133     y => \&mapping_yank,
1134     Y => \&mapping_yank_now,
1135 );
1136
1137 =head2 ATTRIBUTES
1138
1139 Attributes are used to style the output. They must be Curses attributes.
1140 Defaults in parentheses (foreground, background, attribute).
1141
1142 =over
1143
1144 =item B<match_id>      attribute for match numbers (red, default, bold)
1145
1146 =item B<match_string>  attribute for matches (yellow, default, normal)
1147
1148 =item B<match_last>    attribute for the match selected by return (yellow, default, underline)
1149
1150 =item B<prompt_name>   attribute for prompt name (standout)
1151
1152 =item B<prompt_flags>  attribute for prompt flags (standout)
1153
1154 =back
1155
1156 Example:
1157
1158     # Draw prompt flags in bold red with default background color.
1159     $config{attribute}{prompt_flags}
1160         = Curses::A_BOLD
1161         | color_pair(Curses::COLOR_RED, -1);
1162
1163 =cut
1164 my %attribute = (
1165     match_id     => $screen->color_pair(Curses::COLOR_RED, -1)
1166                     | Curses::A_BOLD,
1167     match_string => $screen->color_pair(Curses::COLOR_YELLOW, -1),
1168     match_last   => $screen->color_pair(Curses::COLOR_YELLOW, -1)
1169                     | Curses::A_UNDERLINE,
1170     prompt_name  => Curses::A_STANDOUT,
1171     prompt_flags => Curses::A_STANDOUT,
1172 );
1173
1174 =head2 SETTINGS
1175
1176 Defaults in parentheses.
1177
1178 =over
1179
1180 =item B<debug>              enable debug mode, writes to I<~/.config/fcscs/log> (C<0>)
1181
1182 =item B<initial_mode>       start in this mode, must be a valid mode mapping (C<\&mapping_mode_url>)
1183
1184 =item B<multiplexer>        set multiplexer ("screen" or "tmux"), defaults to autodetection (C<undef>)
1185
1186 =item B<ignorecase>         ignore case when searching (C<0>)
1187
1188 =item B<smartcase>          ignore case unless one uppercase character is searched (C<1>)
1189
1190 =item B<yank_x11>           copy selection also to X11 primary selection when yanking (C<0>)
1191
1192 =item B<paste_sleep>        sleep x us before running paste command (C<100_000>)
1193
1194 =item B<screen_msgwait>     GNU Screen's msgwait variable, used when yanking (C<5>)
1195
1196 =item B<alternative_return> additional accept key like return, set to C<\n> to disable (C<s>)
1197
1198 =item B<browser>            browser command as array reference (C<['x-www-browser']>)
1199
1200 =back
1201
1202 Example:
1203
1204     # Select paths on startup instead of URLs.
1205     $config{setting}{initial_mode} = \&mapping_mode_path;
1206
1207 =cut
1208 my %setting = (
1209     # options
1210     debug              => 0,
1211     initial_mode       => \&mapping_mode_url,
1212     multiplexer        => undef,
1213     ignorecase         => 0,
1214     smartcase          => 1,
1215     yank_x11           => 0,
1216     paste_sleep        => 100_000,
1217     screen_msgwait     => 5,
1218     # global mappings
1219     alternative_return => 's',
1220     # commands
1221     browser            => ['x-www-browser'],
1222 );
1223
1224 =head2 REGEXPS
1225
1226 =over
1227
1228 =item B<url>  used by C<\&mapping_mode_url>
1229
1230 =item B<path> used by C<\&mapping_mode_path>
1231
1232 =item B<ipv4> used by C<\&mapping_mode_ip>
1233
1234 =item B<ipv6> used by C<\&mapping_mode_ip>
1235
1236 =back
1237
1238 Example:
1239
1240     # Select all non-whitespace characters when searching for paths.
1241     $config{regex}{path} = qr{(\S+)};
1242
1243 =cut
1244 my %regex = (
1245     # Taken from urlview's default configuration file, thanks.
1246     url  => qr{((?:(?:(?:http|https|ftp|gopher)|mailto):(?://)?[^ <>"\t]*|(?:www|ftp)[0-9]?\.[-a-z0-9.]+)[^ .,;\t\n\r<">\):]?[^, <>"\t]*[^ .,;\t\n\r<">\):])},
1247     path => qr{(~?[a-zA-Z0-9_./-]*/[a-zA-Z0-9_./-]+)},
1248     # IP addresses with optional prefix. Not perfectly accurate but good
1249     # enough.
1250     ipv4 => qr!\b(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}(?:/\d{1,2})?)\b!,
1251     ipv6 => qr!\b((?:[0-9a-fA-F]{1,4})?(?::+[0-9a-fA-F]{1,4})+(?:/\d{1,3})?)\b!,
1252     # MD5, SHA1, SHA256, SHA512
1253     checksum => qr!\b([0-9a-fA-F]{32}|[0-9a-fA-F]{40}|[0-9a-fA-F]{64}|[0-9a-fA-F]{128})\b!,
1254 );
1255
1256 =head2 HANDLERS
1257
1258 Handlers are used to perform actions on the selected string.
1259
1260 The following handlers are available, defaults in parentheses.
1261
1262 =over
1263
1264 =item B<yank>     used to yank (copy) selection to paste buffer (C<\&handler_yank>)
1265
1266 =item B<paste>    used to paste selection into window (C<\&handler_paste>)
1267
1268 =item B<path>     used to handle paths (C<\&handler_yank>)
1269
1270 =item B<url>      used to open URLs (e.g. in a browser) (C<\&handler_url>)
1271
1272 =item B<ip>       used to handle IPs (C<\&handler_yank>)
1273
1274 =item B<checksum> used to handle checksums (C<\&handler_yank>)
1275
1276 =back
1277
1278 Example:
1279
1280     # Download YouTube videos with a custom wrapper, handle all other URLs
1281     # with the default URL handler.
1282     $config{handler}{url} = sub {
1283         my ($screen, $config, $match) = @_;
1284
1285         if ($match->{value} =~ m{^https://www.youtube.com/}) {
1286             return run_in_background($screen, sub {
1287                 run_command($screen, ['youtube-dl-wrapper', $match->{value}]);
1288             });
1289         }
1290         handler_url(@_);
1291     };
1292
1293 =cut
1294 my %handler = (
1295     yank     => \&handler_yank,
1296     paste    => \&handler_paste,
1297     path     => \&handler_yank,
1298     url      => \&handler_url,
1299     ip       => \&handler_yank,
1300     checksum => \&handler_yank,
1301 );
1302
1303 my %state = (
1304     initial => 1, # used by select_match() for 'initial_mode'
1305     handler => undef,
1306 );
1307
1308
1309
1310 # CONFIGURATION "API"
1311
1312 =head2 FUNCTIONS
1313
1314 The following functions are available:
1315
1316     color_pair($fg, $bg)
1317
1318 Create a new Curses attribute with the given fore- and background color.
1319
1320     mapping_mode_path()
1321     mapping_mode_url()
1322     mapping_mode_ip()
1323     mapping_mode_checksum()
1324     mapping_mode_search()
1325
1326     mapping_paste()
1327     mapping_paste_now()
1328     mapping_yank()
1329     mapping_yank_now()
1330     mapping_quit()
1331
1332 Used as mappings, see L</MAPPINGS> above.
1333
1334     handler_yank()
1335     handler_paste()
1336     handler_url()
1337
1338 Used as handler to yank, paste selection or open URL in browser.
1339
1340     get_regex_matches()
1341     select_match()
1342     run_command()
1343     run_in_background()
1344
1345 Helper functions when writing custom mappings, see the source and example for
1346 details.
1347
1348 Example:
1349
1350     # Enhance URL mode by updating the mapping.
1351     $config{mapping}{mode}{u} = sub {
1352         my ($key, $screen, $config, $input) = @_;
1353
1354         # First get matches of normal URL mode.
1355         my $result = mapping_mode_url(@_);
1356
1357         # Add all strings matching "CVE-1234-1234" with URLs pointing to the
1358         # Debian security tracker. "->{value}" is the string which is used as
1359         # result of the match (e.g. the URL in this case).
1360         my @matches = get_regex_matches($input, qr/\b(CVE-\d+-\d+)\b/);
1361         foreach (@matches) {
1362             $_->{value} = "https://security-tracker.debian.org/$_->{string}";
1363         }
1364         push @{$result->{matches}}, @matches;
1365
1366         # Change all YouTube links to use the custom "youtube" handler (see
1367         # below). This will allow us to automatically open YouTube URLs with a
1368         # custom program, like `youtube-dl` or `mpv`.
1369         foreach (@{$result->{matches}}) {
1370             if ($_->{string} =~ m{^https://www.youtube.com/}) {
1371                 $_->{handler} = $config{handler}{youtube};
1372             }
1373         }
1374
1375         return $result;
1376     };
1377     # Also update initial mode to use our new "URL mode".
1378     $config{setting}{initial_mode} = $config{mapping}{mode}{u};
1379
1380     # Special handler to download YouTube URLs with `youtube-dl`. You could
1381     # also use `mpv` here to immediately play them.
1382     $config{handler}{youtube} = sub {
1383         my ($screen, $config, $match) = @_;
1384
1385         return run_in_background($screen, sub {
1386             run_command($screen, ['youtube-dl', $match->{value}]);
1387         });
1388     };
1389
1390 =cut
1391
1392 # All variables and functions which are usable by ~/.fcscsrc.
1393 package Fcscs {
1394     our $screen; # "private"
1395     our %config;
1396
1397     sub color_pair { return $screen->color_pair(@_); }
1398
1399     sub mapping_mode_path { return main::mapping_mode_path(@_); }
1400     sub mapping_mode_url { return main::mapping_mode_url(@_); }
1401     sub mapping_mode_ip { return main::mapping_mode_ip(@_); }
1402     sub mapping_mode_checksum { return main::mapping_mode_checksum(@_); }
1403     sub mapping_mode_search { return main::mapping_mode_search(@_); }
1404
1405     sub mapping_paste { return main::mapping_paste(@_); }
1406     sub mapping_paste_now { return main::mapping_paste_now(@_); }
1407     sub mapping_yank { return main::mapping_yank(@_); }
1408     sub mapping_yank_now { return main::mapping_yank_now(@_); }
1409     sub mapping_quit { return main::mapping_quit(@_); }
1410
1411     sub handler_yank { return main::handler_yank(@_); }
1412     sub handler_paste { return main::handler_paste(@_); }
1413     sub handler_url { return main::handler_url(@_); }
1414
1415     sub get_regex_matches { return main::get_regex_matches(@_); }
1416     sub select_match { return main::select_match(@_); }
1417
1418     sub run_command { return main::run_command(@_); }
1419     sub run_in_background { return main::run_in_background(@_); }
1420 }
1421 $Fcscs::screen = $screen;
1422
1423
1424
1425 # LOAD USER CONFIG
1426
1427 # Alias %config and %Fcscs::config. %config is less to type.
1428 our %config;
1429 local *config = \%Fcscs::config;
1430
1431 $config{mapping}{mode}   = \%mapping_mode;
1432 $config{mapping}{simple} = \%mapping_simple;
1433 $config{attribute}       = \%attribute;
1434 $config{setting}         = \%setting;
1435 $config{regex}           = \%regex;
1436 $config{handler}         = \%handler;
1437 $config{state}           = \%state;
1438
1439 package Fcscs {
1440     my @configs = ("$ENV{HOME}/.fcscsrc",
1441                    "$ENV{HOME}/.config/fcscs/fcscsrc");
1442     foreach my $path (@configs) {
1443         my $decoded = $screen->decode($path);
1444
1445         # Load configuration file. Checks have a race condition if the home
1446         # directory is writable by an attacker (but then the user is screwed
1447         # anyway).
1448         next unless -e $path;
1449         if (not -O $path) {
1450             $screen->die("Config '$decoded' not owned by current user!");
1451         }
1452         # Make sure the file is not writable by other users. Doesn't handle
1453         # ACLs and see comment above about race conditions.
1454         my @stat = stat $path or $screen->die("Config '$decoded': $!");
1455         my $mode = $stat[2];
1456         if (($mode & Fcntl::S_IWGRP) or ($mode & Fcntl::S_IWOTH)) {
1457             $screen->die("Config '$decoded' must not be writable by other users.");
1458         }
1459
1460         my $result = do $path;
1461         if (not $result) {
1462             $screen->die("Failed to parse '$decoded': $@") if $@;
1463             $screen->die("Failed to do '$decoded': $!") unless defined $result;
1464             $screen->die("Failed to run '$decoded'.");
1465         }
1466
1467         last; # success, don't load more files
1468     }
1469 }
1470 $screen->{debug} = $config{setting}{debug};
1471
1472
1473 # MAIN
1474
1475 eval {
1476     # Auto-detect current multiplexer.
1477     if (not defined $config{setting}{multiplexer}) {
1478         if (defined $ENV{STY} and defined $ENV{TMUX}) {
1479             die 'Found both $STY and $TMUX, set $config{setting}{multiplexer}.';
1480         } elsif (defined $ENV{STY}) {
1481             $config{setting}{multiplexer} = 'screen';
1482         } elsif (defined $ENV{TMUX}) {
1483             $config{setting}{multiplexer} = 'tmux';
1484         } else {
1485             die 'No multiplexer found.';
1486         }
1487     }
1488
1489     my $binmode = $encoding;
1490     # GNU screen stores the screen dump for unknown reasons as ISO-8859-1
1491     # instead of the currently active encoding.
1492     if ($config{setting}{multiplexer} eq 'screen') {
1493         $binmode = 'ISO-8859-1';
1494     }
1495
1496     my @input_lines;
1497     open my $fh, '<', $ARGV[0] or die $!;
1498     binmode $fh, ":encoding($binmode)" or die $!;
1499     while (<$fh>) {
1500         chomp;
1501         push @input_lines, $_;
1502     }
1503     close $fh or die $!;
1504
1505     my $input = prepare_input($screen, \@input_lines);
1506
1507     # Display original screen content.
1508     my $y = 0;
1509     foreach (@{$input->{lines}}) {
1510         $screen->draw_simple($y++, 0, undef, $_);
1511     }
1512     $screen->refresh;
1513
1514
1515     my $mapping = $config{setting}{initial_mode};
1516
1517     my $key;
1518     while (1) {
1519         if (not defined $mapping) {
1520             $key = $screen->getch unless defined $key;
1521             $screen->debug('input', "got key '$key'");
1522
1523             $mapping = $config{mapping}{mode}{$key};
1524             $mapping = $config{mapping}{simple}{$key} unless defined $mapping;
1525             if (not defined $mapping) { # ignore unknown mappings
1526                 $key = undef;
1527                 next;
1528             }
1529         }
1530
1531         $screen->debug('input', 'running mapping');
1532         my $result = $mapping->($key, $screen, \%config, $input);
1533         $mapping = undef;
1534
1535 RESULT:
1536         if (defined $result->{quit}) {
1537             $screen->debug('input', 'quitting');
1538             last;
1539         }
1540         if (defined $result->{key}) {
1541             $key = $result->{key}; # lookup another mapping
1542             $screen->debug('input', "processing new key: '$key'");
1543             next;
1544         }
1545         if (defined $result->{select}) {
1546             $screen->debug('input', 'selecting match');
1547             my $tmp = $result;
1548             $result = select_match($result->{select},
1549                                    $screen, \%config, $input,
1550                                    $result->{matches});
1551             $result->{handler} = $tmp->{handler};
1552             $result->{extend}  = $tmp->{extend};
1553             goto RESULT; # reprocess special entries in result
1554         }
1555         if (defined $result->{extend}) {
1556             $screen->debug('input', 'extending match');
1557             $result = extend_match($screen, \%config, $input,
1558                                    $result->{match});
1559             goto RESULT; # reprocess special entries in result
1560         }
1561         if (defined $result->{match}) {
1562             if (not defined $result->{match}{value}) {
1563                 $result->{match}{value} = $result->{match}{string};
1564             }
1565
1566             $screen->debug('input', 'running handler');
1567
1568             # Choose handler with falling priority.
1569             my @handlers = (
1570                 $config{state}{handler},     # set by user
1571                 $result->{match}{handler},   # set by match
1572                 $result->{handler},          # set by mapping
1573                 $config{handler}{yank},      # fallback
1574             );
1575             foreach my $handler (@handlers) {
1576                 next unless defined $handler;
1577
1578                 $handler->($screen, \%config, $result->{match});
1579                 last;
1580             }
1581             last;
1582         }
1583
1584         $key = undef; # get next key from user
1585     }
1586 };
1587 if ($@) {
1588     $screen->die("$@");
1589 }
1590
1591 $screen->deinit;
1592
1593 __END__
1594
1595 =head1 EXIT STATUS
1596
1597 =over 4
1598
1599 =item B<0>
1600
1601 Success.
1602
1603 =item B<1>
1604
1605 An error occurred.
1606
1607 =item B<2>
1608
1609 Invalid arguments/options.
1610
1611 =back
1612
1613 =head1 AUTHOR
1614
1615 Simon Ruderich E<lt>simon@ruderich.orgE<gt>
1616
1617 =head1 LICENSE AND COPYRIGHT
1618
1619 Copyright (C) 2013-2016 by Simon Ruderich
1620
1621 This program is free software: you can redistribute it and/or modify
1622 it under the terms of the GNU General Public License as published by
1623 the Free Software Foundation, either version 3 of the License, or
1624 (at your option) any later version.
1625
1626 This program is distributed in the hope that it will be useful,
1627 but WITHOUT ANY WARRANTY; without even the implied warranty of
1628 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1629 GNU General Public License for more details.
1630
1631 You should have received a copy of the GNU General Public License
1632 along with this program.  If not, see E<lt>http://www.gnu.org/licenses/E<gt>.
1633
1634 =head1 SEE ALSO
1635
1636 L<screen(1)>, L<tmux(1)>, L<urlview(1)>
1637
1638 =cut