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