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         say $fh "$module: @args";
 359         return;
 360     }
 361
 362
 363     sub prompt {
 364         my ($self, %settings) = @_;
 365
 366         foreach (keys %settings) {
 367             CORE::die if not exists $self->{prompt}{$_};
 368             $self->{prompt}{$_} = $settings{$_};
 369         }
 370         return;
 371     }
 372
 373     # Wrapper for Curses.
 374     sub width   { return $Curses::COLS; }
 375     sub height  { return $Curses::LINES; }
 376     sub refresh { return $_[0]->{curses}->refresh; }
 377     sub getch   { return $_[0]->{curses}->getch; }
 378     sub cursor  { Curses::curs_set($_[1]); return; }
 379 }
 380
 381
 382
 383 # FUNCTIONS
 384
 385 sub prepare_input {
 386     my ($screen, $input_ref) = @_;
 387
 388     # Make sure the input fits on the screen by removing the top lines if
 389     # necessary.
 390     splice @{$input_ref}, 0, -$screen->height;
 391
 392     # Pad each line with spaces to the screen width to correctly handle
 393     # multi-line regexes.
 394     # FIXME: wide characters
 395     my @padded = map { sprintf '%-*s', $screen->width, $_ } @{$input_ref};
 396
 397     my $string = join "\n", @padded;
 398     return {
 399         string => $string,
 400         lines  => $input_ref,
 401         width  => $screen->width + 1,
 402                   # + 1 = "\n", used in input_match_offset_to_coordinates
 403     };
 404 }
 405
 406 sub input_match_offset_to_coordinates {
 407     my ($width, $offset) = @_;
 408
 409     die unless defined $offset;
 410
 411     my $y = int($offset / $width);
 412     my $x = $offset - $y * $width;
 413     return ($x, $y);
 414 }
 415
 416 sub get_regex_matches {
 417     my ($input, $regex) = @_;
 418
 419     my @matches;
 420     while ($input->{string} =~ /$regex/g) {
 421         my $offset = $-[1];
 422         die "Match group required in regex '$regex'" if not defined $offset;
 423
 424         my ($x, $y) = input_match_offset_to_coordinates($input->{width},
 425                                                         $offset);
 426         push @matches, { x => $x, y => $y, offset => $offset, string => $1 };
 427     }
 428     return @matches;
 429 }
 430
 431
 432 sub run_command {
 433     my ($screen, $config, $cmd) = @_;
 434
 435     $screen->debug('run_command', "running @{$cmd}");
 436
 437     my $exit = do {
 438         # Perl's system() combined with a $SIG{__WARN__} which die()s has
 439         # issues due to the fork. The die() in the __WARN__ handler doesn't
 440         # die but the program continues after the system().
 441         #
 442         # If the forked process fails to exec (e.g. program not found) then
 443         # the __WARN__ handler is called (because a warning is about to be
 444         # displayed) and the die() should display a message and terminate the
 445         # process. But due to the fork it doesn't terminate the parent process
 446         # and instead changes the return value of system(); it's no longer -1
 447         # which makes it impossible to detect that case.
 448         #
 449         # Perl < 5.18 (found in 5.14) doesn't setup $$ during system() which
 450         # makes it impossible to detect if the handler was called from inside
 451         # the child.
 452         #
 453         # Instead, just ignore any warnings during the system(). Thanks to
 454         # mauke in #perl on Freenode (2013-10-29 23:30 CET) for the idea to
 455         # use no warnings and anno for testing a more recent Perl version with
 456         # a working $$.
 457         no warnings;
 458
 459         system { $cmd->[0] } @{$cmd};
 460     };
 461     if ($exit != 0) {
 462         my $msg;
 463         if ($? == -1) {
 464             $msg = 'failed to execute: ' . $!;
 465         } elsif ($? & 127) {
 466             $msg = 'killed by signal ' . ($? & 127);
 467         } else {
 468             $msg = 'exited with code ' . ($? >> 8);
 469         }
 470         die "system(@{$cmd}) $msg.";
 471     }
 472     return;
 473 }
 474 sub run_in_background {
 475     my ($screen, $sub) = @_;
 476
 477     $screen->debug('run_in_background', "running $sub");
 478
 479     my $pid = fork;
 480     defined $pid or die $!;
 481
 482     if ($pid == 0) {
 483         # The terminal multiplexer sends a SIGHUP to the process when it
 484         # closes the window (because the parent process has exited).
 485         local $SIG{HUP} = 'IGNORE';
 486
 487         # Necessary for GNU screen or it'll keep the window open until the
 488         # paste command has run.
 489         close STDIN  or die $!;
 490         close STDOUT or die $!;
 491         close STDERR or die $!;
 492
 493         # Double-fork to prevent zombies.
 494         my $pid = fork;
 495         defined $pid or die $!;
 496         if ($pid == 0) { # child
 497             $sub->();
 498         }
 499         exit;
 500     }
 501     waitpid $pid, 0 or die $!;
 502     return;
 503 }
 504
 505
 506 sub select_match {
 507     my ($name, $screen, $config, $input, $matches) = @_;
 508
 509     $screen->debug('select_match', 'started');
 510
 511     return if @{$matches} == 0;
 512     # Don't return on initial run to give the user a chance to select another
 513     # mode, e.g. to switch from URL selection to search selection.
 514     if (@{$matches} == 1 and not $config->{state}{initial}) {
 515         return { match => $matches->[0] };
 516     }
 517     $config->{state}{initial} = 0;
 518
 519     my @sorted = sort { $b->{y} <=> $a->{y} or $b->{x} <=> $a->{x} } @{$matches};
 520
 521     my $i = 1;
 522     foreach (@sorted) {
 523         $_->{id} = $i++;
 524     }
 525
 526     $screen->prompt(name => $name, value => undef);
 527     $screen->draw_prompt($config);
 528
 529     $screen->draw_matches($config, [], $matches);
 530     $screen->refresh;
 531
 532     my $number = 0;
 533     while (1) {
 534         my $char = $screen->getch;
 535         if ($char =~ /^\d$/) {
 536             $number = $number * 10 + $char;
 537         } elsif ($char eq "\b" or $char eq "\x7f") { # backspace
 538             $number = int($number / 10);
 539         } elsif ($char eq "\n") {
 540             if ($number == 0) { # number without selection matches last entry
 541                 $number = 1;
 542             }
 543             last;
 544
 545         # Selecting a new mode requires falling through into the main input
 546         # loop and then starting the new mode.
 547         } elsif (defined $config->{mapping}{mode}{$char}) {
 548             $screen->draw_matches($config, $matches, []); # clear matches
 549             return { key => $char };
 550         # All other mappings stay in the current mode.
 551         } elsif (defined (my $m = $config->{mapping}{simple}{$char})) {
 552             $m->($char, $screen, $config, $input);
 553             next;
 554
 555         } else {
 556             next; # ignore unknown mappings
 557         }
 558
 559         last if $number > 0 and $number * 10 > @{$matches}; # unique match
 560
 561         my @remaining = $number == 0
 562                       ? @{$matches}
 563                       : grep { $_->{id} =~ /^$number/ } @{$matches};
 564         $screen->draw_matches($config, $matches, \@remaining);
 565         $screen->refresh;
 566     }
 567
 568     $screen->draw_matches($config, $matches, []); # remove matches
 569
 570     foreach (@{$matches}) {
 571         return { match => $_ } if $_->{id} == $number;
 572     }
 573     $screen->debug('select_match', 'no match selected');
 574     return { match => undef };
 575 }
 576
 577 sub extend_match_regex_left {
 578     my ($line, $match, $regex) = @_;
 579
 580     my $s = reverse substr $line, 0, $match->{x};
 581     if ($s =~ /^($regex)/) {
 582         $match->{string}  = reverse($1) . $match->{string};
 583         $match->{x}      -= length $1;
 584         $match->{offset} -= length $1;
 585     }
 586     return;
 587 }
 588 sub extend_match_regex_right {
 589     my ($line, $match, $regex) = @_;
 590
 591     my $s = substr $line, $match->{x} + length $match->{string};
 592     if ($s =~ /^($regex)/) {
 593         $match->{string} .= $1;
 594     }
 595     return;
 596 }
 597 sub extend_match {
 598     my ($screen, $config, $input, $match) = @_;
 599
 600     $screen->debug('extend_match', 'started');
 601
 602     $screen->prompt(name => 'extend', value => undef);
 603     $screen->draw_prompt($config);
 604
 605     delete $match->{id}; # don't draw any match ids
 606     $screen->draw_matches($config, [], [$match]);
 607     $screen->refresh;
 608
 609     my $line = $input->{lines}[$match->{y}];
 610
 611     while (1) {
 612         my $match_old = \%{$match};
 613
 614         my $char = $screen->getch;
 615         if ($char eq "\n") { # accept match
 616             last;
 617
 618         } elsif ($char eq 'w') { # select current word (both directions)
 619             extend_match_regex_left($line,  $match, qr/\w+/);
 620             extend_match_regex_right($line, $match, qr/\w+/);
 621         } elsif ($char eq 'b') { # select current word (only left)
 622             extend_match_regex_left($line,  $match, qr/\w+/);
 623         } elsif ($char eq 'e') { # select current word (only right)
 624             extend_match_regex_right($line, $match, qr/\w+/);
 625
 626         } elsif ($char eq 'W') { # select current WORD (both directions)
 627             extend_match_regex_left($line,  $match, qr/\S+/);
 628             extend_match_regex_right($line, $match, qr/\S+/);
 629         } elsif ($char eq 'B') { # select current WORD (only left)
 630             extend_match_regex_left($line,  $match, qr/\S+/);
 631         } elsif ($char eq 'E') { # select current WORD (only right)
 632             extend_match_regex_right($line, $match, qr/\S+/);
 633
 634         } elsif ($char eq '^') { # select to beginning of line
 635             extend_match_regex_left($line, $match, qr/.+/);
 636         } elsif ($char eq '$') { # select to end of line
 637             extend_match_regex_right($line, $match, qr/.+/);
 638
 639         # Allow mode changes if not overwritten by local mappings.
 640         } elsif (defined $config->{mapping}{mode}{$char}) {
 641             $screen->draw_matches($config, [$match_old], []); # clear match
 642             return { key => $char };
 643
 644         } else {
 645             next; # ignore unknown mappings
 646         }
 647
 648         $screen->draw_matches($config, [$match_old], [$match]);
 649         $screen->refresh;
 650     }
 651
 652     $screen->debug('extend_match', 'done');
 653
 654     return { match => $match };
 655 }
 656
 657
 658 sub mapping_paste {
 659     my ($key, $screen, $config, $input) = @_;
 660
 661     $screen->debug('mapping_paste', 'started');
 662
 663     $config->{state}{handler} = $config->{handler}{paste};
 664
 665     $screen->prompt(flags => 'P'); # paste
 666     $screen->draw_prompt($config);
 667     $screen->refresh;
 668
 669     return {};
 670 }
 671 sub mapping_yank {
 672     my ($key, $screen, $config, $input) = @_;
 673
 674     $screen->debug('mapping_yank', 'started');
 675
 676     $config->{state}{handler} = $config->{handler}{yank};
 677
 678     $screen->prompt(flags => 'Y'); # yank
 679     $screen->draw_prompt($config);
 680     $screen->refresh;
 681
 682     return {};
 683 }
 684
 685
 686 =head2 NORMAL MODES
 687
 688 Normal modes select matches by calling a function which returns them, e.g. by
 689 using a regex.
 690
 691 The following normal modes are available:
 692
 693 =over 4
 694
 695 =item B<path mode> select relative/absolute paths
 696
 697 =item B<url mode>  select URLs
 698
 699 =back
 700
 701 =cut
 702 sub mapping_mode_path {
 703     my ($key, $screen, $config, $input) = @_;
 704
 705     $screen->debug('mapping_mode_path', 'started');
 706
 707     my @matches = get_regex_matches($input, $config->{regex}{path});
 708     return {
 709         select  => 'path select',
 710         matches => \@matches,
 711         handler => $config->{handler}{yank},
 712     };
 713 }
 714 sub mapping_mode_url {
 715     my ($key, $screen, $config, $input) = @_;
 716
 717     $screen->debug('mapping_mode_url', 'started');
 718
 719     my @matches = get_regex_matches($input, $config->{regex}{url});
 720     return {
 721         select  => 'url select',
 722         matches => \@matches,
 723         handler => $config->{handler}{url},
 724     };
 725 }
 726
 727 =head2 SEARCH MODE (AND EXTEND MODE)
 728
 729 Search mode is a special mode which lets you type a search string (a Perl
 730 regex) and then select one of the matches. Afterwards you can extend the
 731 match. For example select the complete word or to the end of the line. This
 732 allows quick selection of arbitrary text.
 733
 734 The following mappings are available during the extension mode (not
 735 configurable at the moment):
 736
 737 =over 4
 738
 739 =item B<w> select current word
 740
 741 =item B<b> extend word to the left
 742
 743 =item B<e> extend word to the right
 744
 745 =item B<W> select current WORD
 746
 747 =item B<B> extend WORD to the left
 748
 749 =item B<E> extend WORD to the right
 750
 751 =item B<^> extend to beginning of line
 752
 753 =item B<$> extend to end of line
 754
 755 =back
 756
 757 C<word> includes any characters matching C<\w+>, C<WORD> any non-whitespace
 758 characters (C<\S+>), just like in Vim.
 759
 760 =cut
 761 sub mapping_mode_search {
 762     my ($key, $screen, $config, $input) = @_;
 763
 764     $screen->debug('mapping_mode_search', 'started');
 765
 766     $screen->cursor(1);
 767
 768     my $search = ''; # encoded
 769     my @last_matches;
 770     while (1) {
 771         # getch doesn't return decoded characters but raw input bytes. Wait
 772         # until the input character is complete.
 773         my $value = $screen->decode($search);
 774         $value = '' unless defined $value; # undef on decode failure
 775
 776         $screen->prompt(name => 'search', value => $value);
 777         $screen->draw_prompt($config);
 778         $screen->refresh;
 779
 780         my $char = $screen->getch;
 781         # TODO: readline editing support
 782         if ($char eq "\n") {
 783             last;
 784         } elsif ($char eq "\b" or $char eq "\x7f") { # backspace
 785             # Remove a character, not a byte.
 786             $search = $screen->decode($search);
 787             chop $search;
 788             $search = $screen->encode($search);
 789         } else {
 790             $search .= $char;
 791             next unless defined $screen->decode($search);
 792         }
 793
 794         my @matches;
 795         if ($search ne '') {
 796             my $case = '';
 797             if (($config->{setting}{smartcase} and $search eq lc $search)
 798                     or $config->{setting}{ignorecase}) {
 799                 $case = '(?i)';
 800             }
 801             # Ignore invalid regexps.
 802             # TODO: display warning on error?
 803             eval {
 804                 @matches = get_regex_matches($input, qr/($case$search)/);
 805             };
 806         }
 807         $screen->draw_matches($config, \@last_matches, \@matches);
 808         @last_matches = @matches;
 809     }
 810
 811     $screen->cursor(0);
 812
 813     return {
 814         select  => 'search',
 815         matches => \@last_matches,
 816         extend  => 1,
 817         handler => $config->{handler}{yank},
 818     };
 819 }
 820
 821 sub mapping_quit {
 822     my ($key, $screen, $config, $input) = @_;
 823
 824     # Key is necessary to fall through to main event loop which then quits.
 825     return { key => $key, quit => 1 };
 826 }
 827
 828
 829 sub handler_yank {
 830     my ($screen, $config, $match) = @_;
 831
 832     $screen->debug('handler_yank', 'started');
 833
 834     require File::Temp;
 835
 836     # Use a temporary file to prevent leaking the yanked data to other users
 837     # with the command line, e.g. ps aux or top.
 838     my ($fh, $tmp) = File::Temp::tempfile(); # dies on its own
 839     print $fh $screen->encode($match->{value});
 840     close $fh or die $!;
 841
 842     if ($config->{setting}{multiplexer} eq 'screen') {
 843         $screen->debug('handler_yank', 'using screen');
 844
 845         # GNU screen displays an annoying "Slurping X characters into buffer".
 846         # Use 'msgwait 0' as a hack to disable it.
 847         my $msgwait = $config->{setting}{screen_msgwait};
 848         run_command($screen, $config, ['screen', '-X', 'msgwait', 0]);
 849         run_command($screen, $config, ['screen', '-X', 'readbuf', $tmp]);
 850         run_command($screen, $config, ['screen', '-X', 'msgwait', $msgwait]);
 851     } elsif ($config->{setting}{multiplexer} eq 'tmux') {
 852         $screen->debug('handler_yank', 'using tmux');
 853
 854         run_command($screen, $config, ['tmux', 'load-buffer', $tmp]);
 855     } else {
 856         die 'unsupported multiplexer';
 857     }
 858
 859     unlink $tmp or die $!;
 860     return;
 861 }
 862 sub handler_paste {
 863     my ($screen, $config, $match) = @_;
 864
 865     $screen->debug('handler_paste', 'started');
 866
 867     require Time::HiRes;
 868
 869     my @cmd;
 870     if ($config->{setting}{multiplexer} eq 'screen') {
 871         $screen->debug('handler_paste', 'using screen');
 872         @cmd = qw( screen -X paste . );
 873     } elsif ($config->{setting}{multiplexer} eq 'tmux') {
 874         $screen->debug('handler_paste', 'using tmux');
 875         @cmd = qw( tmux paste-buffer );
 876     } else {
 877         die 'unsupported multiplexer';
 878     }
 879
 880     run_in_background($screen, sub {
 881         # We need to get the data in the paste buffer before we can paste
 882         # it.
 883         handler_yank($screen, $config, $match);
 884
 885         # Sleep until we switch back to the current window.
 886         Time::HiRes::usleep($config->{setting}{paste_sleep});
 887
 888         run_command($screen, $config, \@cmd);
 889     });
 890     return;
 891 }
 892 sub handler_url {
 893     my ($screen, $config, $match) = @_;
 894
 895     $screen->debug('handler_url', "opening $match->{value}");
 896
 897     run_in_background($screen, sub {
 898         my @cmd = map { $screen->encode($_) } (
 899             @{$config->{setting}{browser}},
 900             $match->{value},
 901         );
 902         run_command($screen, $config, \@cmd);
 903     });
 904     return;
 905 }
 906
 907
 908
 909 # CONFIGURATION DEFAULTS
 910
 911 =head1 CONFIGURATION
 912
 913 fcscs is configured through F<~/.fcscsrc> or F<~/.config/fcscs/fcscsrc> which
 914 is a normal Perl script with all of Perl's usual features.
 915
 916 All configuration values are stored in the hash C<%config>. All manually
 917 defined keys overwrite the default settings.
 918
 919 A simple F<~/.fcscsrc> could look like this (for details about the used
 920 settings see below):
 921
 922     use strict;
 923     use warnings;
 924
 925     use Curses; # for COLOR_* and A_* constants
 926
 927     our %config;
 928
 929     # Draw matches in blue.
 930     $config{attribute}{match_string} = color_pair(COLOR_BLUE, -1);
 931     # Enable Vim-like 'smartcase', ignore case until an upper character is
 932     # searched.
 933     $config{setting}{smartcase} = 1;
 934
 935     # Use chromium to open URLs if running under X, elinks otherwise.
 936     if (defined $ENV{DISPLAY}) {
 937         $config{setting}{browser} = ['chromium'];
 938     } else {
 939         $config{setting}{browser} = ['elinks'];
 940     }
 941
 942     # Let fcscs know the file was loaded successfully.
 943     1;
 944
 945 =cut
 946
 947
 948 if (@ARGV != 1) {
 949     require Pod::Usage;
 950     Pod::Usage::pod2usage(2);
 951 }
 952
 953
 954 # Determine terminal encoding from the environment ($ENV{LANG} or similar).
 955 my $encoding = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET);
 956
 957 my $screen = Screen->init($encoding);
 958
 959 # We must restore the screen before exiting.
 960 local $SIG{INT} = sub {
 961     $screen->deinit;
 962     exit 128 + 2;
 963 };
 964 # Make all warnings fatal to make sure they don't get lost (stderr is normally
 965 # not displayed).
 966 local $SIG{__WARN__} = sub {
 967     $screen->die('warning', @_);
 968 };
 969
 970
 971
 972 =head2 MAPPINGS
 973
 974 I<NOTE>: Mappings are split in two categories: Mode mappings which change the
 975 selection and may receive additional input (e.g. a search string) and simple
 976 mappings which only change some value. Mode mappings are configured via
 977 C<$config{mapping}{mode}>, simple mappings via C<$config{mapping}{simple}>.
 978
 979 The following mode mappings are available by default (the function to remap
 980 them in parentheses):
 981
 982 =over
 983
 984 =item B<f> select absolute/relative paths (C<\&mapping_mode_path>)
 985
 986 =item B<u> select URLs (C<\&mapping_mode_url>)
 987
 988 =item B</> search for regex to get selection (C<\&mapping_mode_search>)
 989
 990 =item B<q> quit fcscs (C<\&mapping_quit>)
 991
 992 =back
 993
 994 The following simple mappings are available by default:
 995
 996 =over
 997
 998 =item B<p> enable pasting (C<\&mapping_paste>)
 999
1000 =item B<y> enable yanking (copying) (C<\&mapping_yank>)
1001
1002 =back
1003
1004 All (single-byte) keys except numbers, backspace and return can be mapped.
1005
1006 Unknown mappings are ignored when pressing keys.
1007
1008 To remove a default mapping, delete it from the mapping hash.
1009
1010 Example:
1011
1012     # Map 'p' to select paths, 'P' to enable pasting.
1013     $config{mapping}{mode}{p} = \&mapping_mode_path;
1014     $config{mapping}{simple}{P} = \&mapping_paste;
1015
1016     # Disable 'f' mapping.
1017     delete $config{mapping}{mode}{f};
1018
1019 =cut
1020 my %mapping_mode = (
1021     f   => \&mapping_mode_path,
1022     u   => \&mapping_mode_url,
1023     '/' => \&mapping_mode_search,
1024     q   => \&mapping_quit,
1025 );
1026 my %mapping_simple = (
1027     p => \&mapping_paste,
1028     y => \&mapping_yank,
1029 );
1030
1031 =head2 ATTRIBUTES
1032
1033 Attributes are used to style the output. They must be Curses attributes.
1034 Defaults in parentheses (foreground, background, attribute).
1035
1036 =over
1037
1038 =item B<match_id>      attribute for match numbers (red, default, bold)
1039
1040 =item B<match_string>  attribute for matches (yellow, default, normal)
1041
1042 =item B<prompt_name>   attribute for prompt name (standout)
1043
1044 =item B<prompt_flags>  attribute for prompt flags (standout)
1045
1046 =back
1047
1048 Example:
1049
1050     # Draw prompt flags in bold red with default background color.
1051     $config{attribute}{prompt_flags}
1052         = Curses::A_BOLD
1053         | color_pair(Curses::COLOR_RED, -1);
1054
1055 =cut
1056 my %attribute = (
1057     match_id     => $screen->color_pair(Curses::COLOR_RED, -1)
1058                     | Curses::A_BOLD,
1059     match_string => $screen->color_pair(Curses::COLOR_YELLOW, -1),
1060     prompt_name  => Curses::A_STANDOUT,
1061     prompt_flags => Curses::A_STANDOUT,
1062 );
1063
1064 =head2 SETTINGS
1065
1066 Defaults in parentheses.
1067
1068 =over
1069
1070 =item B<debug>          enable debug mode, writes to I<~/.config/fcscs/log> (C<0>)
1071
1072 =item B<initial_mode>   start in this mode, must be a valid mode mapping (C<\&mapping_mode_url>)
1073
1074 =item B<multiplexer>    set multiplexer ("screen" or "tmux") if not autodetected (C<undef>)
1075
1076 =item B<ignorecase>     ignore case when searching (C<0>)
1077
1078 =item B<smartcase>      ignore case unless one uppercase character is searched (C<1>)
1079
1080 =item B<paste_sleep>    sleep x us before running paste command (C<100_000>)
1081
1082 =item B<screen_msgwait> GNU Screen's msgwait variable, used when yanking (C<5>)
1083
1084 =item B<browser>        browser command as array reference (C<['x-www-browser']>)
1085
1086 =back
1087
1088 Example:
1089
1090     # Select paths on startup instead of URLs.
1091     $config{setting}{initial_mode} = \&mapping_mode_path;
1092
1093 =cut
1094 my %setting = (
1095     # options
1096     debug          => 0,
1097     initial_mode   => \&mapping_mode_url,
1098     multiplexer    => undef,
1099     ignorecase     => 0,
1100     smartcase      => 1,
1101     paste_sleep    => 100_000,
1102     screen_msgwait => 5,
1103     # commands
1104     browser        => ['x-www-browser'],
1105 );
1106
1107 =head2 REGEXPS
1108
1109 =over
1110
1111 =item B<url>  used by C<\&mapping_mode_url()>
1112
1113 =item B<path> used by C<\&mapping_mode_path()>
1114
1115 =back
1116
1117 Example:
1118
1119     # Select all non-whitespace characters when searching for paths.
1120     $config{regex}{path} = qr{(\S+)};
1121
1122 =cut
1123 my %regex = (
1124     # Taken from urlview's default configuration file, thanks.
1125     url  => qr{((?:(?:(?:http|https|ftp|gopher)|mailto):(?://)?[^ <>"\t]*|(?:www|ftp)[0-9]?\.[-a-z0-9.]+)[^ .,;\t\n\r<">\):]?[^, <>"\t]*[^ .,;\t\n\r<">\):])},
1126     path => qr{(~?[a-zA-Z0-9_./-]*/[a-zA-Z0-9_./-]+)},
1127 );
1128
1129 =head2 HANDLERS
1130
1131 Handlers are used to perform actions on the selected string.
1132
1133 The following handlers are available, defaults in parentheses.
1134
1135 =over
1136
1137 =item B<yank>  used to yank (copy) selection to paste buffer (C<\&handler_yank>)
1138
1139 =item B<paste> used to paste selection into window (C<\&handler_paste>)
1140
1141 =item B<url>   used to open URLs (e.g. in a browser) (C<\&handler_url>)
1142
1143 =back
1144
1145 Example:
1146
1147     # Download YouTube videos with a custom wrapper, handle all other URLs
1148     # with the default URL handler.
1149     $config{handler}{url} = sub {
1150         my ($screen, $config, $match) = @_;
1151
1152         if ($match->{value} =~ m{^https://www.youtube.com/}) {
1153             return run_in_background($screen, sub {
1154                 run_command($screen, $config,
1155                             ['youtube-dl-wrapper', $match->{value}]);
1156             });
1157         }
1158         handler_url(@_);
1159     };
1160
1161 =cut
1162 my %handler = (
1163     yank  => \&handler_yank,
1164     paste => \&handler_paste,
1165     url   => \&handler_url,
1166 );
1167
1168 my %state = (
1169     initial => 1, # used by select_match() for 'initial_mode'
1170     handler => undef,
1171 );
1172
1173
1174
1175 # CONFIGURATION "API"
1176
1177 =head2 FUNCTIONS
1178
1179 The following functions are available:
1180
1181     color_pair($fg, $bg)
1182
1183 Create a new Curses attribute with the given fore- and background color.
1184
1185     mapping_mode_path()
1186     mapping_mode_url()
1187     mapping_mode_search()
1188
1189     mapping_paste()
1190     mapping_yank()
1191     mapping_quit()
1192
1193 Used as mappings, see L</MAPPINGS> above.
1194
1195     handler_yank()
1196     handler_paste()
1197     handler_url()
1198
1199 Used as handler to yank, paste selection or open URL in browser.
1200
1201     debug()
1202     get_regex_matches()
1203     select_match()
1204     run_command()
1205     run_in_background()
1206
1207 Helper functions when writing custom mappings, see the source for details.
1208
1209 Example:
1210
1211     TODO
1212
1213 =cut
1214
1215 # All variables and functions which are usable by ~/.fcscsrc.
1216 package Fcscs {
1217     our $screen; # "private"
1218     our %config;
1219
1220     sub color_pair { return $screen->color_pair(@_); }
1221
1222     sub mapping_mode_path { return main::mapping_mode_path(@_); }
1223     sub mapping_mode_url { return main::mapping_mode_url(@_); }
1224     sub mapping_mode_search { return main::mapping_mode_search(@_); }
1225
1226     sub mapping_paste { return main::mapping_paste(@_); }
1227     sub mapping_yank { return main::mapping_yank(@_); }
1228     sub mapping_quit { return main::mapping_quit(@_); }
1229
1230     sub handler_yank { return main::handler_yank(@_); }
1231     sub handler_paste { return main::handler_paste(@_); }
1232     sub handler_url { return main::handler_url(@_); }
1233
1234     sub debug { return main::debug(@_); }
1235
1236     sub get_regex_matches { return main::get_regex_matches(@_); }
1237     sub select_match { return main::select_match(@_); }
1238
1239     sub run_command { return main::run_command(@_); }
1240     sub run_in_background { return main::run_in_background(@_); }
1241 }
1242 $Fcscs::screen = $screen;
1243
1244
1245
1246 # LOAD USER CONFIG
1247
1248 # Alias %config and %Fcscs::config. %config is less to type.
1249 our %config;
1250 local *config = \%Fcscs::config;
1251
1252 $config{mapping}{mode}   = \%mapping_mode;
1253 $config{mapping}{simple} = \%mapping_simple;
1254 $config{attribute}       = \%attribute;
1255 $config{setting}         = \%setting;
1256 $config{regex}           = \%regex;
1257 $config{handler}         = \%handler;
1258 $config{state}           = \%state;
1259
1260 package Fcscs {
1261     my @configs = ("$ENV{HOME}/.fcscsrc",
1262                    "$ENV{HOME}/.config/fcscs/fcscsrc");
1263     foreach my $path (@configs) {
1264         my $decoded = $screen->decode($path);
1265
1266         # Load configuration file. Checks have a race condition if the home
1267         # directory is writable by an attacker (but then the user is screwed
1268         # anyway).
1269         next unless -e $path;
1270         if (not -O $path) {
1271             $screen->die("Config '$decoded' not owned by current user!");
1272         }
1273         # Make sure the file is not writable by other users. Doesn't handle
1274         # ACLs and see comment above about race conditions.
1275         my @stat = stat $path or die $!;
1276         my $mode = $stat[2];
1277         if (($mode & Fcntl::S_IWGRP) or ($mode & Fcntl::S_IWOTH)) {
1278             die "Config '$decoded' must not be writable by other users.";
1279         }
1280
1281         my $result = do $path;
1282         if (not $result) {
1283             $screen->die("Failed to parse '$decoded': $@") if $@;
1284             $screen->die("Failed to do '$decoded': $!") unless defined $result;
1285             $screen->die("Failed to run '$decoded'.");
1286         }
1287
1288         last; # success, don't load more files
1289     }
1290 }
1291 $screen->{debug} = $config{setting}{debug};
1292
1293
1294 # MAIN
1295
1296 eval {
1297     # Auto-detect current multiplexer.
1298     if (not defined $config{setting}{multiplexer}) {
1299         if (defined $ENV{STY} and defined $ENV{TMUX}) {
1300             die 'Found both $STY and $TMUX, set $config{setting}{multiplexer}.';
1301         } elsif (defined $ENV{STY}) {
1302             $config{setting}{multiplexer} = 'screen';
1303         } elsif (defined $ENV{TMUX}) {
1304             $config{setting}{multiplexer} = 'tmux';
1305         } else {
1306             die 'No multiplexer found.';
1307         }
1308     }
1309
1310     my $binmode = $encoding;
1311     # GNU screen stores the screen dump for unknown reasons as ISO-8859-1
1312     # instead of the currently active encoding.
1313     if ($config{setting}{multiplexer} eq 'screen') {
1314         $binmode = 'ISO-8859-1';
1315     }
1316
1317     my @input_lines;
1318     open my $fh, '<', $ARGV[0] or die $!;
1319     binmode $fh, ":encoding($binmode)" or die $!;
1320     while (<$fh>) {
1321         chomp;
1322         push @input_lines, $_;
1323     }
1324     close $fh or die $!;
1325
1326     my $input = prepare_input($screen, \@input_lines);
1327
1328     # Display original screen content.
1329     my $y = 0;
1330     foreach (@{$input->{lines}}) {
1331         $screen->draw_simple($y++, 0, undef, $_);
1332     }
1333     $screen->refresh;
1334
1335
1336     my $mapping = $config{setting}{initial_mode};
1337
1338     my $key;
1339     while (1) {
1340         if (not defined $mapping) {
1341             $key = $screen->getch unless defined $key;
1342             $screen->debug('input', "got key '$key'");
1343
1344             $mapping = $config{mapping}{mode}{$key};
1345             $mapping = $config{mapping}{simple}{$key} unless defined $mapping;
1346             if (not defined $mapping) { # ignore unknown mappings
1347                 $key = undef;
1348                 next;
1349             }
1350         }
1351
1352         $screen->debug('input', 'running mapping');
1353         my $result = $mapping->($key, $screen, \%config, $input);
1354         $mapping = undef;
1355
1356 RESULT:
1357         if (defined $result->{quit}) {
1358             $screen->debug('input', 'quitting');
1359             last;
1360         }
1361         if (defined $result->{key}) {
1362             $key = $result->{key}; # lookup another mapping
1363             $screen->debug('input', "processing new key: '$key'");
1364             next;
1365         }
1366         if (defined $result->{select}) {
1367             $screen->debug('input', 'selecting match');
1368             my $tmp = $result;
1369             $result = select_match($result->{select},
1370                                 $screen, \%config, $input,
1371                                 $result->{matches});
1372             $result->{handler} = $tmp->{handler};
1373             $result->{extend}  = $tmp->{extend};
1374             goto RESULT; # reprocess special entries in result
1375         }
1376         if (defined $result->{extend}) {
1377             $screen->debug('input', 'extending match');
1378             $result = extend_match($screen, \%config, $input,
1379                                    $result->{match});
1380             goto RESULT; # reprocess special entries in result
1381         }
1382         if (defined $result->{match}) {
1383             if (not defined $result->{match}{value}) {
1384                 $result->{match}{value} = $result->{match}{string};
1385             }
1386
1387             $screen->debug('input', 'running handler');
1388
1389             # Choose handler with falling priority.
1390             my @handlers = (
1391                 $config{state}{handler},     # set by user
1392                 $result->{match}{handler},   # set by match
1393                 $result->{handler},          # set by mapping
1394                 $config{handler}{yank},      # fallback
1395             );
1396             foreach my $handler (@handlers) {
1397                 next unless defined $handler;
1398
1399                 $handler->($screen, \%config, $result->{match});
1400                 last;
1401             }
1402             last;
1403         }
1404
1405         $key = undef; # get next key from user
1406     }
1407 };
1408 if ($@) {
1409     $screen->die("$@");
1410 }
1411
1412 $screen->deinit;
1413
1414 __END__
1415
1416 =head1 EXIT STATUS
1417
1418 =over 4
1419
1420 =item B<0>
1421
1422 Success.
1423
1424 =item B<1>
1425
1426 An error occurred.
1427
1428 =item B<2>
1429
1430 Invalid arguments/options.
1431
1432 =back
1433
1434 =head1 AUTHOR
1435
1436 Simon Ruderich E<lt>simon@ruderich.orgE<gt>
1437
1438 =head1 LICENSE AND COPYRIGHT
1439
1440 Copyright (C) 2013-2016 by Simon Ruderich
1441
1442 This program is free software: you can redistribute it and/or modify
1443 it under the terms of the GNU General Public License as published by
1444 the Free Software Foundation, either version 3 of the License, or
1445 (at your option) any later version.
1446
1447 This program is distributed in the hope that it will be useful,
1448 but WITHOUT ANY WARRANTY; without even the implied warranty of
1449 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1450 GNU General Public License for more details.
1451
1452 You should have received a copy of the GNU General Public License
1453 along with this program.  If not, see E<lt>http://www.gnu.org/licenses/E<gt>.
1454
1455 =head1 SEE ALSO
1456
1457 L<screen(1)>, L<tmux(1)>, L<urlview(1)>
1458
1459 =cut