bin/fcscs

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