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